From 3b66834a900028ac96ecea82c0095353f7c55fc2 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Mon, 11 Apr 2022 19:41:33 +0000 Subject: [PATCH 001/380] Add loop over columns in RRTMGP longwave scheme. Collapse GP schemes into loop. --- physics/GFS_rrtmgp_pre.F90 | 42 +- physics/GFS_rrtmgp_pre.meta | 64 ++- physics/rrtmgp_lw_cloud_optics.F90 | 173 -------- physics/rrtmgp_lw_cloud_optics.meta | 323 -------------- physics/rrtmgp_lw_gas_optics.F90 | 76 +--- physics/rrtmgp_lw_gas_optics.meta | 102 ----- physics/rrtmgp_lw_main.F90 | 527 +++++++++++++++++++++++ physics/rrtmgp_lw_main.meta | 635 ++++++++++++++++++++++++++++ 8 files changed, 1220 insertions(+), 722 deletions(-) create mode 100644 physics/rrtmgp_lw_main.F90 create mode 100644 physics/rrtmgp_lw_main.meta diff --git a/physics/GFS_rrtmgp_pre.F90 b/physics/GFS_rrtmgp_pre.F90 index faf8d4986..7e22c41c1 100644 --- a/physics/GFS_rrtmgp_pre.F90 +++ b/physics/GFS_rrtmgp_pre.F90 @@ -9,8 +9,6 @@ module GFS_rrtmgp_pre NF_VGAS, & ! Number of active gas species getgases, & ! Routine to setup trace gases getozn ! Routine to setup ozone - ! RRTMGP types - use mo_gas_concentrations, only: ty_gas_concs use radiation_tools, only: check_error_msg,cmp_tlev real(kind_phys), parameter :: & @@ -98,18 +96,17 @@ end subroutine GFS_rrtmgp_pre_init !> \section arg_table_GFS_rrtmgp_pre_run !! \htmlinclude GFS_rrtmgp_pre_run.html !! - subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhswr, fhlwr, & + subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, lsswr, lslwr, fhswr, fhlwr, & xlat, xlon, prsl, tgrs, prslk, prsi, qgrs, tsfc, coslat, sinlat, con_g, con_rd, & con_eps, con_epsm1, con_fvirt, con_epsqs, solhr, minGPpres, maxGPpres, minGPtemp, & - maxGPtemp, raddt, p_lay, t_lay, p_lev, t_lev, tsfg, tsfa, qs_lay, q_lay, tv_lay, & - relhum, tracer, deltaZ, deltaZc, deltaP, active_gases_array, gas_concentrations, & - tsfc_radtime, coszen, coszdg, top_at_1, iSFC, iTOA, errmsg, errflg) + maxGPtemp, raddt, p_lay, t_lay, p_lev, t_lev, vmr_o2, vmr_h2o, vmr_o3, vmr_ch4, & + vmr_n2o, vmr_co2, tsfg, tsfa, qs_lay, q_lay, tv_lay, relhum, deltaZ, deltaZc, deltaP,& + active_gases_array, tsfc_radtime, coszen, coszdg, top_at_1, iSFC, iTOA, errmsg, errflg) ! Inputs integer, intent(in) :: & nCol, & ! Number of horizontal grid points nLev, & ! Number of vertical layers - nTracers, & ! Number of tracers from model. i_o3 ! Index into tracer array for ozone logical, intent(in) :: & lsswr, & ! Call SW radiation? @@ -173,15 +170,11 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw deltaZc, & ! Layer thickness (m) (between layer centers) deltaP, & ! Layer thickness (Pa) p_lev, & ! Pressure at model-interface - t_lev ! Temperature at model-interface - real(kind_phys), dimension(:,:,:),intent(inout) :: & - tracer ! Array containing trace gases - type(ty_gas_concs), intent(inout) :: & - gas_concentrations ! RRTMGP DDT: gas volumne mixing ratios + t_lev, & ! Temperature at model-interface + vmr_o2, vmr_h2o, vmr_o3, vmr_ch4, vmr_n2o, vmr_co2 ! Local variables integer :: i, j, iCol, iBand, iLay, iLev, iSFC_ilev - real(kind_phys),dimension(nCol,nLev) :: vmr_o3, vmr_h2o real(kind_phys) :: es, tem1, tem2, pfac real(kind_phys), dimension(nLev+1) :: hgtb real(kind_phys), dimension(nLev) :: hgtc @@ -323,16 +316,10 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw ! ####################################################################################### ! Get layer ozone mass mixing ratio ! ####################################################################################### - ! First recast remaining all tracers (except sphum) forcing them all to be positive - do j = 2, nTracers - tracer(1:NCOL,:,j) = qgrs(1:NCOL,:,j) - where(tracer(:,:,j) .lt. 0.0) tracer(:,:,j) = 0._kind_phys - enddo - if (i_o3 > 0) then do iLay=1,nlev do iCol=1,NCOL - o3_lay(iCol,iLay) = max( con_epsqs, tracer(iCol,iLay,i_o3) ) + o3_lay(iCol,iLay) = max( con_epsqs, qgrs(iCol,iLay,i_o3) ) enddo enddo ! OR Use climatological ozone data @@ -345,21 +332,14 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw ! ####################################################################################### ! Call getgases(), to set up non-prognostic gas volume mixing ratios (gas_vmr). call getgases (p_lev/100., xlon, xlat, nCol, nLev, gas_vmr) + vmr_o2 = gas_vmr(:,:,4) + vmr_ch4 = gas_vmr(:,:,3) + vmr_n2o = gas_vmr(:,:,2) + vmr_co2 = gas_vmr(:,:,1) ! Compute volume mixing-ratios for ozone (mmr) and specific-humidity. vmr_h2o = merge((q_lay/(1-q_lay))*amdw, 0., q_lay .ne. 1.) vmr_o3 = merge(o3_lay*amdo3, 0., o3_lay .gt. 0.) - - ! Populate RRTMGP DDT w/ gas-concentrations - gas_concentrations%ncol = nCol - gas_concentrations%nlay = nLev - gas_concentrations%gas_name(:) = active_gases_array(:) - gas_concentrations%concs(istr_o2)%conc(:,:) = gas_vmr(:,:,4) - gas_concentrations%concs(istr_co2)%conc(:,:) = gas_vmr(:,:,1) - gas_concentrations%concs(istr_ch4)%conc(:,:) = gas_vmr(:,:,3) - gas_concentrations%concs(istr_n2o)%conc(:,:) = gas_vmr(:,:,2) - gas_concentrations%concs(istr_h2o)%conc(:,:) = vmr_h2o(:,:) - gas_concentrations%concs(istr_o3)%conc(:,:) = vmr_o3(:,:) ! ####################################################################################### ! Radiation time step (output) (Is this really needed?) (Used by some diagnostics) diff --git a/physics/GFS_rrtmgp_pre.meta b/physics/GFS_rrtmgp_pre.meta index 88face855..800bc470d 100644 --- a/physics/GFS_rrtmgp_pre.meta +++ b/physics/GFS_rrtmgp_pre.meta @@ -72,13 +72,6 @@ dimensions = () type = integer intent = in -[nTracers] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in [lsswr] standard_name = flag_for_calling_shortwave_radiation long_name = logical flags for sw radiation calls @@ -425,11 +418,51 @@ type = real kind = kind_phys intent = inout -[tracer] - standard_name = chemical_tracers - long_name = chemical tracers - units = g g-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) +[vmr_o2] + standard_name = volume_mixing_ratio_for_o2 + long_name = molar mixing ratio of o2 in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[vmr_h2o] + standard_name = volume_mixing_ratio_for_h2o + long_name = molar mixing ratio of h2o in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[vmr_o3] + standard_name = volume_mixing_ratio_for_o3 + long_name = molar mixing ratio of o3 in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[vmr_ch4] + standard_name = volume_mixing_ratio_for_ch4 + long_name = molar mixing ratio of ch4 in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[vmr_n2o] + standard_name = volume_mixing_ratio_for_n2o + long_name = molar mixing ratio of n2o in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[vmr_co2] + standard_name = volume_mixing_ratio_for_co2 + long_name = molar mixing ratio of co2 in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -441,13 +474,6 @@ type = character kind = len=* intent = in -[gas_concentrations] - standard_name = Gas_concentrations_for_RRTMGP_suite - long_name = DDT containing gas concentrations for RRTMGP radiation scheme - units = DDT - dimensions = () - type = ty_gas_concs - intent = inout [coszdg] standard_name = cosine_of_solar_zenith_angle_on_radiation_timestep long_name = daytime mean cosz over rad call period diff --git a/physics/rrtmgp_lw_cloud_optics.F90 b/physics/rrtmgp_lw_cloud_optics.F90 index 835261071..68f5a4472 100644 --- a/physics/rrtmgp_lw_cloud_optics.F90 +++ b/physics/rrtmgp_lw_cloud_optics.F90 @@ -376,177 +376,4 @@ subroutine rrtmgp_lw_cloud_optics_init(nrghice, mpicomm, mpirank, mpiroot, end subroutine rrtmgp_lw_cloud_optics_init - ! ###################################################################################### - ! SUBROUTINE rrtmgp_lw_cloud_optics_run() - ! ###################################################################################### -!! \section arg_table_rrtmgp_lw_cloud_optics_run -!! \htmlinclude rrtmgp_lw_cloud_optics.html -!! - subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw, & - doGP_cldoptics_PADE, doGP_cldoptics_LUT, doGP_lwscat, do_mynnedmf, imfdeepcnv, & - imfdeepcnv_gf, imfdeepcnv_samf, nCol, nLev, nbndsGPlw , p_lay, cld_frac, cld_lwp, & - cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, cld_rerain, & - precip_frac, cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, cld_cnv_reice, cld_pbl_lwp, & - cld_pbl_reliq, cld_pbl_iwp, cld_pbl_reice, lon, lat, cldtaulw, & - lw_optical_props_cloudsByBand, lw_optical_props_cnvcloudsByBand, & - lw_optical_props_MYNNcloudsByBand, lw_optical_props_precipByBand, errmsg, errflg) - - ! Inputs - logical, intent(in) :: & - doLWrad, & ! Logical flag for longwave radiation call - doG_cldoptics, & ! Use legacy RRTMG cloud-optics? - doGP_cldoptics_PADE, & ! Use RRTMGP cloud-optics: PADE approximation? - doGP_cldoptics_LUT, & ! Use RRTMGP cloud-optics: LUTs? - doGP_lwscat, & ! Include scattering in LW cloud-optics? - do_mynnedmf ! - integer, intent(in) :: & - nbndsGPlw, & ! - nCol, & ! Number of horizontal gridpoints - nLev, & ! Number of vertical levels - icliq_lw, & ! Choice of treatment of liquid cloud optical properties (RRTMG legacy) - icice_lw, & ! Choice of treatment of ice cloud optical properties (RRTMG legacy) - imfdeepcnv, & ! - imfdeepcnv_gf, & ! - imfdeepcnv_samf ! - real(kind_phys), dimension(:), intent(in) :: & - lon, & ! Longitude - lat ! Latitude - real(kind_phys), dimension(:,:),intent(in) :: & - p_lay, & ! Layer pressure (Pa) - cld_frac, & ! Total cloud fraction by layer - cld_lwp, & ! Cloud liquid water path - cld_reliq, & ! Cloud liquid effective radius - cld_iwp, & ! Cloud ice water path - cld_reice, & ! Cloud ice effective radius - cld_swp, & ! Cloud snow water path - cld_resnow, & ! Cloud snow effective radius - cld_rwp, & ! Cloud rain water path - cld_rerain, & ! Cloud rain effective radius - precip_frac, & ! Precipitation fraction by layer. - cld_cnv_lwp, & ! Water path for convective liquid cloud-particles (microns) - cld_cnv_reliq, & ! Effective radius for convective liquid cloud-particles (microns) - cld_cnv_iwp, & ! Water path for convective ice cloud-particles (microns) - cld_cnv_reice, & ! Effective radius for convective ice cloud-particles (microns) - cld_pbl_lwp, & ! Water path for SGS PBL liquid cloud-particles - cld_pbl_reliq, & ! Effective radius for SGS PBL liquid cloud-particles - cld_pbl_iwp, & ! Water path for SGS PBL ice cloud-particles - cld_pbl_reice ! Effective radius for SGS PBL ice cloud-particles - - ! Outputs - character(len=*), intent(out) :: & - errmsg ! CCPP error message - integer, intent(out) :: & - errflg ! CCPP error flag - type(ty_optical_props_2str),intent(inout) :: & - lw_optical_props_cloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (clouds) - lw_optical_props_cnvcloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (convective cloud) - lw_optical_props_MYNNcloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (MYNN-PBL cloud) - lw_optical_props_precipByBand ! RRTMGP DDT: Longwave optical properties in each band (precipitation) - real(kind_phys), dimension(:,:), intent(inout) :: & - cldtaulw ! Approx 10.mu band layer cloud optical depth - - ! Local variables - real(kind_phys) :: tau_rain, tau_snow - real(kind_phys), dimension(ncol,nLev,nbndsGPlw) :: & - tau_cld, tau_precip - integer :: iCol, iLay, iBand - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - ! Initialize locals - tau_cld = 0._kind_phys - tau_precip = 0._kind_phys - - if (.not. doLWrad) return - - ! Compute cloud-optics for RTE. - if (doGP_cldoptics_PADE .or. doGP_cldoptics_LUT) then - - ! i) Cloud-optics. - lw_optical_props_cloudsByBand%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() - do iBand=1,lw_gas_props%get_nband() - lw_optical_props_cloudsByBand%band2gpt(1:2,iBand) = iBand - lw_optical_props_cloudsByBand%gpt2band(iBand) = iBand - end do - call check_error_msg('rrtmgp_lw_cloud_optics_run - clouds',lw_cloud_props%cloud_optics(& - cld_lwp, & ! IN - Cloud liquid water path (g/m2) - cld_iwp, & ! IN - Cloud ice water path (g/m2) - cld_reliq, & ! IN - Cloud liquid effective radius (microns) - cld_reice, & ! IN - Cloud ice effective radius (microns) - lw_optical_props_cloudsByBand)) ! OUT - RRTMGP DDT containing cloud radiative properties - ! in each band - ! ii) Convective cloud-optics - if (imfdeepcnv == imfdeepcnv_samf .or. imfdeepcnv == imfdeepcnv_gf) then - lw_optical_props_cnvcloudsByBand%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() - do iBand=1,lw_gas_props%get_nband() - lw_optical_props_cnvcloudsByBand%band2gpt(1:2,iBand) = iBand - lw_optical_props_cnvcloudsByBand%gpt2band(iBand) = iBand - end do - call check_error_msg('rrtmgp_lw_cnvcloud_optics_run - convective cloud',lw_cloud_props%cloud_optics(& - cld_cnv_lwp, & ! IN - Convective cloud liquid water path (g/m2) - cld_cnv_iwp, & ! IN - Convective cloud ice water path (g/m2) - cld_cnv_reliq, & ! IN - Convective cloud liquid effective radius (microns) - cld_cnv_reice, & ! IN - Convective cloud ice effective radius (microns) - lw_optical_props_cnvcloudsByBand)) ! OUT - RRTMGP DDT containing convective cloud radiative properties - ! in each band - endif - - ! iii) MYNN cloud-optics - if (do_mynnedmf) then - lw_optical_props_MYNNcloudsByBand%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() - do iBand=1,lw_gas_props%get_nband() - lw_optical_props_MYNNcloudsByBand%band2gpt(1:2,iBand) = iBand - lw_optical_props_MYNNcloudsByBand%gpt2band(iBand) = iBand - end do - call check_error_msg('rrtmgp_lw_MYNNcloud_optics_run - MYNN-EDMF cloud',lw_cloud_props%cloud_optics(& - cld_pbl_lwp, & ! IN - MYNN-EDMF PBL cloud liquid water path (g/m2) - cld_pbl_iwp, & ! IN - MYNN-EDMF PBL cloud ice water path (g/m2) - cld_pbl_reliq, & ! IN - MYNN-EDMF PBL cloud liquid effective radius (microns) - cld_pbl_reice, & ! IN - MYNN-EDMF PBL cloud ice effective radius (microns) - lw_optical_props_MYNNcloudsByBand)) ! OUT - RRTMGP DDT containing MYNN-EDMF PBL cloud radiative properties - ! in each band - endif - - ! iv) Cloud precipitation optics: rain and snow(+groupel) - lw_optical_props_precipByBand%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() - do iBand=1,lw_gas_props%get_nband() - lw_optical_props_precipByBand%band2gpt(1:2,iBand) = iBand - lw_optical_props_precipByBand%gpt2band(iBand) = iBand - end do - do iCol=1,nCol - do iLay=1,nLev - if (cld_frac(iCol,iLay) .gt. 0.) then - ! Rain optical-depth (No band dependence) - tau_rain = absrain*cld_rwp(iCol,iLay) - - ! Snow (+groupel) optical-depth (No band dependence) - if (cld_swp(iCol,iLay) .gt. 0. .and. cld_resnow(iCol,iLay) .gt. 10._kind_phys) then - tau_snow = abssnow0*1.05756*cld_swp(iCol,iLay)/cld_resnow(iCol,iLay) - else - tau_snow = 0.0 - endif - do iBand=1,nbndsGPlw - lw_optical_props_precipByBand%tau(iCol,iLay,iBand) = tau_rain + tau_snow - enddo - endif - enddo - enddo - endif - - ! All-sky LW optical depth ~10microns (DJS asks: Same as SW, move to cloud-diagnostics?) - cldtaulw = lw_optical_props_cloudsByBand%tau(:,:,7) - - end subroutine rrtmgp_lw_cloud_optics_run - - ! ######################################################################################### - ! SUBROUTINE rrtmgp_lw_cloud_optics_finalize() - ! ######################################################################################### -!! \section arg_table_rrtmgp_lw_cloud_optics_finalize -!! \htmlinclude rrtmgp_lw_cloud_optics.html -!! - subroutine rrtmgp_lw_cloud_optics_finalize() - end subroutine rrtmgp_lw_cloud_optics_finalize - end module rrtmgp_lw_cloud_optics diff --git a/physics/rrtmgp_lw_cloud_optics.meta b/physics/rrtmgp_lw_cloud_optics.meta index c58496dc5..4b2d9cfc0 100644 --- a/physics/rrtmgp_lw_cloud_optics.meta +++ b/physics/rrtmgp_lw_cloud_optics.meta @@ -87,326 +87,3 @@ dimensions = () type = integer intent = out - -######################################################################## -[ccpp-arg-table] - name = rrtmgp_lw_cloud_optics_run - type = scheme -[doLWrad] - standard_name = flag_for_calling_longwave_radiation - long_name = logical flags for lw radiation calls - units = flag - dimensions = () - type = logical - intent = in -[doG_cldoptics] - standard_name = flag_to_calc_lw_cld_optics_using_RRTMG - long_name = logical flag to control cloud optics scheme. - units = flag - dimensions = () - type = logical - intent = in -[icliq_lw] - standard_name = flag_for_optical_property_for_liquid_clouds_for_longwave_radiation - long_name = lw optical property for liquid clouds - units = flag - dimensions = () - type = integer - intent = in -[icice_lw] - standard_name = flag_for_optical_property_for_ice_clouds_for_longwave_radiation - long_name = lw optical property for ice clouds - units = flag - dimensions = () - type = integer - intent = in -[doGP_cldoptics_PADE] - standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_PADE - long_name = logical flag to control cloud optics scheme. - units = flag - dimensions = () - type = logical - intent = in -[doGP_cldoptics_LUT] - standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_LUT - long_name = logical flag to control cloud optics scheme. - units = flag - dimensions = () - type = logical - intent = in -[doGP_lwscat] - standard_name = flag_to_include_longwave_scattering_in_cloud_optics - long_name = logical flag to control the addition of LW scattering in RRTMGP - units = flag - dimensions = () - type = logical - intent = in -[do_mynnedmf] - standard_name = flag_for_mellor_yamada_nakanishi_niino_pbl_scheme - long_name = flag to activate MYNN-EDMF - units = flag - dimensions = () - type = logical - intent = in -[imfdeepcnv] - standard_name = control_for_deep_convection_scheme - long_name = flag for mass-flux deep convection scheme - units = flag - dimensions = () - type = integer - intent = in -[imfdeepcnv_gf] - standard_name = identifier_for_grell_freitas_deep_convection - long_name = flag for Grell-Freitas deep convection scheme - units = flag - dimensions = () - type = integer - intent = in -[imfdeepcnv_samf] - standard_name = identifer_for_scale_aware_mass_flux_deep_convection - long_name = flag for SAMF deep convection scheme - units = flag - dimensions = () - type = integer - intent = in -[ncol] - standard_name = horizontal_loop_extent - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in -[nLev] - standard_name = vertical_layer_dimension - long_name = number of vertical levels - units = count - dimensions = () - type = integer - intent = in -[cld_frac] - standard_name = total_cloud_fraction - long_name = layer total cloud fraction - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - intent = in - kind = kind_phys -[cld_lwp] - standard_name = cloud_liquid_water_path - long_name = layer cloud liquid water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - intent = in - kind = kind_phys -[cld_reliq] - standard_name = mean_effective_radius_for_liquid_cloud - long_name = mean effective radius for liquid cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - intent = in - kind = kind_phys -[cld_iwp] - standard_name = cloud_ice_water_path - long_name = layer cloud ice water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - intent = in - kind = kind_phys -[cld_reice] - standard_name = mean_effective_radius_for_ice_cloud - long_name = mean effective radius for ice cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - intent = in - kind = kind_phys -[cld_swp] - standard_name = cloud_snow_water_path - long_name = cloud snow water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - intent = in - kind = kind_phys -[cld_resnow] - standard_name = mean_effective_radius_for_snow_flake - long_name = mean effective radius for snow flake - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - intent = in - kind = kind_phys -[cld_rwp] - standard_name = cloud_rain_water_path - long_name = cloud rain water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - intent = in - kind = kind_phys -[cld_rerain] - standard_name = mean_effective_radius_for_rain_drop - long_name = mean effective radius for rain drop - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - intent = in - kind = kind_phys -[precip_frac] - standard_name = precipitation_fraction_by_layer - long_name = precipitation fraction in each layer - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_cnv_lwp] - standard_name = convective_cloud_liquid_water_path - long_name = layer convective cloud liquid water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_cnv_iwp] - standard_name = convective_cloud_ice_water_path - long_name = layer convective cloud ice water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_cnv_reliq] - standard_name = mean_effective_radius_for_liquid_convective_cloud - long_name = mean effective radius for liquid convective cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_cnv_reice] - standard_name = mean_effective_radius_for_ice_convective_cloud - long_name = mean effective radius for ice convective cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_pbl_lwp] - standard_name = MYNN_SGS_cloud_liquid_water_path - long_name = layer convective cloud liquid water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_pbl_iwp] - standard_name = MYNN_SGS_cloud_ice_water_path - long_name = layer convective cloud ice water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_pbl_reliq] - standard_name = mean_effective_radius_for_liquid_MYNN_SGS_cloud - long_name = mean effective radius for liquid MYNN_SGS cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_pbl_reice] - standard_name = mean_effective_radius_for_ice_MYNN_SGS_cloud - long_name = mean effective radius for ice MYNN_SGS cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[p_lay] - standard_name = air_pressure_at_layer_for_RRTMGP - long_name = air pressure layer - units = Pa - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[nbndsGPlw] - standard_name = number_of_longwave_bands - long_name = number of lw bands used in RRTMGP - units = count - dimensions = () - type = integer - intent = in -[lon] - standard_name = longitude - long_name = longitude - units = radian - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[lat] - standard_name = latitude - long_name = latitude - units = radian - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[cldtaulw] - standard_name = cloud_optical_depth_layers_at_10mu_band - long_name = approx 10mu band layer cloud optical depth - units = none - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[lw_optical_props_cloudsByBand] - standard_name = longwave_optical_properties_for_cloudy_atmosphere_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = inout -[lw_optical_props_cnvcloudsByBand] - standard_name = longwave_optical_properties_for_convective_cloudy_atmosphere_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = inout -[lw_optical_props_MYNNcloudsByBand] - standard_name = longwave_optical_properties_for_MYNN_EDMF_PBL_cloudy_atmosphere_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = inout -[lw_optical_props_precipByBand] - standard_name = longwave_optical_properties_for_precipitation_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = inout -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - diff --git a/physics/rrtmgp_lw_gas_optics.F90 b/physics/rrtmgp_lw_gas_optics.F90 index 67a888911..d198a5859 100644 --- a/physics/rrtmgp_lw_gas_optics.F90 +++ b/physics/rrtmgp_lw_gas_optics.F90 @@ -6,6 +6,8 @@ module rrtmgp_lw_gas_optics use mo_source_functions, only: ty_source_func_lw use mo_optical_props, only: ty_optical_props_1scl use radiation_tools, only: check_error_msg + use GFS_rrtmgp_pre, only: iStr_h2o, iStr_co2, iStr_o3, iStr_n2o, iStr_ch4, & + iStr_o2, iStr_ccl4, iStr_cfc11, iStr_cfc12, iStr_cfc22 use netcdf #ifdef MPI use mpi @@ -458,79 +460,5 @@ subroutine rrtmgp_lw_gas_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, mpicom maxGPtemp = lw_gas_props%get_temp_max() end subroutine rrtmgp_lw_gas_optics_init - - ! ######################################################################################### - ! SUBROUTINE rrtmgp_lw_gas_optics_run - ! ######################################################################################### -!! \section arg_table_rrtmgp_lw_gas_optics_run -!! \htmlinclude rrtmgp_lw_gas_optics_run.html -!! - subroutine rrtmgp_lw_gas_optics_run(doLWrad, nCol, nLev, p_lay, p_lev, t_lay, t_lev, tsfg, & - gas_concentrations, lw_optical_props_clrsky, sources, errmsg, errflg) - - ! Inputs - logical, intent(in) :: & - doLWrad ! Flag to calculate LW irradiances - integer,intent(in) :: & - ncol, & ! Number of horizontal points - nLev ! Number of vertical levels - real(kind_phys), dimension(ncol,nLev), intent(in) :: & - p_lay, & ! Pressure @ model layer-centers (Pa) - t_lay ! Temperature (K) - real(kind_phys), dimension(ncol,nLev+1), intent(in) :: & - p_lev, & ! Pressure @ model layer-interfaces (Pa) - t_lev ! Temperature @ model levels - real(kind_phys), dimension(ncol), intent(in) :: & - tsfg ! Surface ground temperature (K) - type(ty_gas_concs),intent(in) :: & - gas_concentrations ! RRTMGP DDT: trace gas concentrations (vmr) - - ! Output - character(len=*), intent(out) :: & - errmsg ! CCPP error message - integer, intent(out) :: & - errflg ! CCPP error code - type(ty_optical_props_1scl),intent(inout) :: & - lw_optical_props_clrsky ! RRTMGP DDT: longwave clear-sky radiative properties - type(ty_source_func_lw),intent(inout) :: & - sources ! RRTMGP DDT: longwave source functions - - ! Local - integer :: ii - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (.not. doLWrad) return - - ! Copy spectral information into GP DDTs. - lw_optical_props_clrsky%band2gpt = lw_gas_props%get_band_lims_gpoint() - sources%band2gpt = lw_gas_props%get_band_lims_gpoint() - sources%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() - lw_optical_props_clrsky%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() - do ii=1,nbndsLW - lw_optical_props_clrsky%gpt2band(band2gptLW(1,ii):band2gptLW(2,ii)) = ii - sources%gpt2band(band2gptLW(1,ii):band2gptLW(2,ii)) = ii - end do - - ! Gas-optics - call check_error_msg('rrtmgp_lw_gas_optics_run',lw_gas_props%gas_optics(& - p_lay, & ! IN - Pressure @ layer-centers (Pa) - p_lev, & ! IN - Pressure @ layer-interfaces (Pa) - t_lay, & ! IN - Temperature @ layer-centers (K) - tsfg, & ! IN - Skin-temperature (K) - gas_concentrations, & ! IN - RRTMGP DDT: trace gas volumne mixing-ratios - lw_optical_props_clrsky, & ! OUT - RRTMGP DDT: longwave optical properties - sources, & ! OUT - RRTMGP DDT: source functions - tlev=t_lev)) ! IN - Temperature @ layer-interfaces (K) (optional) - - end subroutine rrtmgp_lw_gas_optics_run - - ! ######################################################################################### - ! SUBROUTINE rrtmgp_lw_gas_optics_finalize - ! ######################################################################################### - subroutine rrtmgp_lw_gas_optics_finalize() - end subroutine rrtmgp_lw_gas_optics_finalize end module rrtmgp_lw_gas_optics diff --git a/physics/rrtmgp_lw_gas_optics.meta b/physics/rrtmgp_lw_gas_optics.meta index 0b484b6ac..a7ca8aacb 100644 --- a/physics/rrtmgp_lw_gas_optics.meta +++ b/physics/rrtmgp_lw_gas_optics.meta @@ -99,105 +99,3 @@ dimensions = () type = integer intent = out - -######################################################################## -[ccpp-arg-table] - name = rrtmgp_lw_gas_optics_run - type = scheme -[doLWrad] - standard_name = flag_for_calling_longwave_radiation - long_name = flag to calculate LW irradiances - units = flag - dimensions = () - type = logical - intent = in -[ncol] - standard_name = horizontal_loop_extent - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in -[nLev] - standard_name = vertical_layer_dimension - long_name = number of vertical levels - units = count - dimensions = () - type = integer - intent = in -[p_lay] - standard_name = air_pressure_at_layer_for_RRTMGP - long_name = air pressure layer - units = Pa - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[p_lev] - standard_name = air_pressure_at_interface_for_RRTMGP - long_name = air pressure level - units = Pa - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = in -[t_lay] - standard_name = air_temperature_at_layer_for_RRTMGP - long_name = air temperature layer - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[t_lev] - standard_name = air_temperature_at_interface_for_RRTMGP - long_name = air temperature level - units = K - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = in -[tsfg] - standard_name = surface_ground_temperature_for_radiation - long_name = surface ground temperature for radiation - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[gas_concentrations] - standard_name = Gas_concentrations_for_RRTMGP_suite - long_name = DDT containing gas concentrations for RRTMGP radiation scheme - units = DDT - dimensions = () - type = ty_gas_concs - intent = in -[lw_optical_props_clrsky] - standard_name = longwave_optical_properties_for_clear_sky - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_1scl - intent = inout -[sources] - standard_name = longwave_source_function - long_name = Fortran DDT containing RRTMGP source functions - units = DDT - dimensions = () - type = ty_source_func_lw - intent = inout -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out diff --git a/physics/rrtmgp_lw_main.F90 b/physics/rrtmgp_lw_main.F90 new file mode 100644 index 000000000..ce1b767b0 --- /dev/null +++ b/physics/rrtmgp_lw_main.F90 @@ -0,0 +1,527 @@ +! ########################################################################################### +! ########################################################################################### +module rrtmgp_lw_main + use machine, only: kind_phys + use mo_optical_props, only: ty_optical_props_1scl, ty_optical_props_2str + use mo_cloud_optics, only: ty_cloud_optics + use mo_rte_lw, only: rte_lw + use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp + use mo_gas_concentrations, only: ty_gas_concs + use mo_fluxes_byband, only: ty_fluxes_byband + use mo_source_functions, only: ty_source_func_lw + use radiation_tools, only: check_error_msg + use rrtmgp_lw_gas_optics, only: lw_gas_props,rrtmgp_lw_gas_optics_init + use rrtmgp_lw_cloud_optics, only: lw_cloud_props, rrtmgp_lw_cloud_optics_init, abssnow0, & + abssnow1,absrain + use module_radiation_gases, only: NF_VGAS, getgases, getozn + use GFS_rrtmgp_pre, only: iStr_h2o, iStr_co2, iStr_o3, iStr_n2o, iStr_ch4, & + iStr_o2, iStr_ccl4, iStr_cfc11, iStr_cfc12, iStr_cfc22 + use mersenne_twister, only: random_setseed, random_number, random_stat + use rrtmgp_sampling, only: sampled_mask, draw_samples + implicit none + + public rrtmgp_lw_main_init, rrtmgp_lw_main_run +contains + + ! ######################################################################################### + ! SUBROUTINE rrtmgp_lw_main_init + ! ######################################################################################### +!! \section arg_table_rrtmgp_lw_main_init +!! \htmlinclude rrtmgp_lw_main_int.html +!! + subroutine rrtmgp_lw_main_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, mpicomm, mpirank, & + mpiroot, minGPpres, maxGPpres, minGPtemp, maxGPtemp, active_gases_array, nrghice, & + doG_cldoptics, doGP_cldoptics_PADE, doGP_cldoptics_LUT,rrtmgp_lw_file_clouds, errmsg,& + errflg) + + ! Inputs + logical, intent(in) :: & + doG_cldoptics, & ! Use legacy RRTMG cloud-optics? + doGP_cldoptics_PADE, & ! Use RRTMGP cloud-optics: PADE approximation? + doGP_cldoptics_LUT ! Use RRTMGP cloud-optics: LUTs? + integer, intent(inout) :: & + nrghice ! Number of ice-roughness categories + character(len=128),intent(in) :: & + rrtmgp_root_dir, & ! RTE-RRTMGP root directory + rrtmgp_lw_file_clouds, & ! RRTMGP file containing coefficients used to compute clouds optical properties + rrtmgp_lw_file_gas ! RRTMGP file containing coefficients used to compute gaseous optical properties + integer,intent(in) :: & + mpicomm, & ! MPI communicator + mpirank, & ! Current MPI rank + mpiroot ! Master MPI rank + character(len=*), dimension(:), intent(in) :: & + active_gases_array ! List of active gases from namelist as array) + ! Outputs + character(len=*), intent(out) :: & + errmsg ! CCPP error message + integer, intent(out) :: & + errflg ! CCPP error code + real(kind_phys), intent(out) :: & + minGPtemp, & ! Minimum temperature allowed by RRTMGP. + maxGPtemp, & ! Maximum ... + minGPpres, & ! Minimum pressure allowed by RRTMGP. + maxGPpres ! Maximum pressure allowed by RRTMGP. + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! RRTMGP longwave gas-optics (k-distribution) initialization + call rrtmgp_lw_gas_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, mpicomm, mpirank, & + mpiroot, minGPpres, maxGPpres, minGPtemp, maxGPtemp, active_gases_array, errmsg, & + errflg) + + ! RRTMGP longwave cloud-optics initialization + call rrtmgp_lw_cloud_optics_init(nrghice, mpicomm, mpirank, mpiroot, doG_cldoptics, & + doGP_cldoptics_PADE, doGP_cldoptics_LUT, rrtmgp_root_dir, rrtmgp_lw_file_clouds, & + errmsg, errflg) + + end subroutine rrtmgp_lw_main_init + + ! ######################################################################################### + ! SUBROUTINE rrtmgp_lw_main_run + ! ######################################################################################### +!! \section arg_table_rrtmgp_lw_main_run +!! \htmlinclude rrtmgp_lw_main_run.html +!! + subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, use_LW_jacobian,& + doGP_sgs_cnv, doGP_sgs_pbl, nCol, nLay, nGases, nGauss_angles, i_o3, icseed_lw, iovr,& + iovr_convcld, iovr_max, iovr_maxrand, iovr_rand, iovr_dcorr, iovr_exp, iovr_exprand, & + isubc_lw, tsfg, p_lay, p_lev, t_lay, t_lev, vmr_o2, vmr_h2o, vmr_o3, vmr_ch4, & + vmr_n2o, vmr_co2, cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, & + cld_resnow, cld_rwp, cld_rerain, precip_frac, cld_cnv_lwp, cld_cnv_reliq, & + cld_cnv_iwp, cld_cnv_reice, cld_pbl_lwp, cld_pbl_reliq, cld_pbl_iwp, cld_pbl_reice, & + cloud_overlap_param, sfc_emiss_byband, active_gases_array, lw_optical_props_aerosol, & + fluxlwUP_allsky, fluxlwDOWN_allsky, fluxlwUP_clrsky, fluxlwDOWN_clrsky, fluxlwUP_jac,& + fluxlwUP_radtime, fluxlwDOWN_radtime, errmsg, errflg) + + ! Inputs + logical, intent(in) :: & + doLWrad, & ! Flag to calculate LW irradiances + doLWclrsky, & ! Flag to compute clear-sky fluxes (diagnostic) + top_at_1, & ! Vertical ordering flag + use_LW_jacobian, & ! Compute Jacobian of LW to update radiative fluxes between radiation calls? + doGP_sgs_pbl, & ! Flag for sgs MYNN-EDMF PBL cloud scheme + doGP_sgs_cnv, & ! Flag for sgs convective cloud scheme + doGP_lwscat ! Include scattering in LW cloud-optics? + integer,intent(in) :: & + nCol, & ! Number of horizontal points + nLay, & ! Number of vertical grid points. + nGases, & ! Number of active gases in RRTMGP + nGauss_angles, & ! + i_o3, & ! + iovr, & ! Choice of cloud-overlap method + iovr_convcld, & ! Choice of convective cloud-overlap + iovr_max, & ! Flag for maximum cloud overlap method + iovr_maxrand, & ! Flag for maximum-random cloud overlap method + iovr_rand, & ! Flag for random cloud overlap method + iovr_dcorr, & ! Flag for decorrelation-length cloud overlap method + iovr_exp, & ! Flag for exponential cloud overlap method + iovr_exprand, & ! Flag for exponential-random cloud overlap method + isubc_lw ! + integer,intent(in),dimension(:) :: & + icseed_lw ! Seed for random number generation for longwave radiation + real(kind_phys), dimension(:), intent(in) :: & + tsfg ! + real(kind_phys), dimension(:,:), intent(in) :: & + p_lay, & ! Pressure @ model layer-centers (Pa) + t_lay, & ! Temperature (K) + p_lev, & ! Pressure @ model layer-interfaces (Pa) + t_lev, & ! Temperature @ model levels (K) + vmr_o2, & ! Molar-mixing ratio oxygen + vmr_h2o, & ! Molar-mixing ratio water vapor + vmr_o3, & ! Molar-mixing ratio ozone + vmr_ch4, & ! Molar-mixing ratio methane + vmr_n2o, & ! Molar-mixing ratio nitrous oxide + vmr_co2, & ! Molar-mixing ratio carbon dioxide + cld_frac, & ! Cloud-fraction for stratiform clouds + cld_lwp, & ! Water path for stratiform liquid cloud-particles + cld_reliq, & ! Effective radius for stratiform liquid cloud-particles + cld_iwp, & ! Water path for stratiform ice cloud-particles + cld_reice, & ! Effective radius for stratiform ice cloud-particles + cld_swp, & ! Water path for snow hydrometeors + cld_resnow, & ! Effective radius for snow hydrometeors + cld_rwp, & ! Water path for rain hydrometeors + cld_rerain, & ! Effective radius for rain hydrometeors + precip_frac, & ! Precipitation fraction + cld_cnv_lwp, & ! Water path for convective liquid cloud-particles + cld_cnv_reliq, & ! Effective radius for convective liquid cloud-particles + cld_cnv_iwp, & ! Water path for convective ice cloud-particles + cld_cnv_reice, & ! Effective radius for convective ice cloud-particles + cld_pbl_lwp, & ! Water path for SGS PBL liquid cloud-particles + cld_pbl_reliq, & ! Effective radius for SGS PBL liquid cloud-particles + cld_pbl_iwp, & ! Water path for SGS PBL ice cloud-particles + cld_pbl_reice, & ! Effective radius for SGS PBL ice cloud-particles + cloud_overlap_param, & ! + sfc_emiss_byband ! Surface emissivity in each band + character(len=*), dimension(:), intent(in) :: & + active_gases_array ! List of active gases from namelist as array + type(ty_optical_props_1scl),intent(inout) :: & + lw_optical_props_aerosol ! RRTMGP DDT: Longwave aerosol optical properties (tau) + + ! Outputs + real(kind_phys), dimension(:,:), intent(inout) :: & + fluxlwUP_jac, & ! Jacobian of upwelling LW surface radiation (W/m2/K) + fluxlwUP_allsky, & ! All-sky flux (W/m2) + fluxlwDOWN_allsky, & ! All-sky flux (W/m2) + fluxlwUP_clrsky, & ! Clear-sky flux (W/m2) + fluxlwDOWN_clrsky, & ! All-sky flux (W/m2) + fluxlwUP_radtime, & ! Copy of fluxes (Used for coupling) + fluxlwDOWN_radtime ! + character(len=*), intent(out) :: & + errmsg ! CCPP error message + integer, intent(out) :: & + errflg ! CCPP error flag + + ! Local variables + type(ty_gas_concs) :: & + gas_concentrations ! RRTMGP DDT: trace gas concentrations (vmr) + type(ty_optical_props_1scl) :: & + lw_optical_props_clrsky, & ! RRTMGP DDT: longwave clear-sky radiative properties + lw_optical_props_aerosol_local, & ! RRTMGP DDT: longwave aerosol radiative properties + lw_optical_props_cloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (clouds) + lw_optical_props_cnvcloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (convective cloud) + lw_optical_props_pblcloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (PBL cloud) + lw_optical_props_precipByBand ! RRTMGP DDT: Longwave optical properties in each band (precipitation) + type(ty_optical_props_2str) :: & + lw_optical_props_clouds ! RRTMGP DDT: Longwave optical properties in each band (sampled clouds) + type(ty_source_func_lw) :: & + sources ! RRTMGP DDT: longwave source functions + type(ty_fluxes_byband) :: & + flux_allsky, flux_clrsky ! RRTMGP DDT: Longwave flux profiles + integer :: iCol, iLay, iGas, iBand, ipseed_lw + type(random_stat) :: rng_stat + real(kind_phys) :: tau_rain, tau_snow + real(kind_phys), dimension(lw_gas_props%get_ngpt()) :: rng1D + real(kind_phys), dimension(lw_gas_props%get_ngpt(),nLay,1) :: rng3D,rng3D2 + real(kind_phys), dimension(lw_gas_props%get_ngpt()*nLay) :: rng2D + logical, dimension(1,nLay,lw_gas_props%get_ngpt()) :: maskMCICA + real(kind_phys), dimension(1,nLay+1,lw_gas_props%get_nband()),target :: & + fluxLW_up_allsky, fluxLW_up_clrsky, fluxLW_dn_allsky, fluxLW_dn_clrsky + real(kind_phys), dimension(1,lw_gas_props%get_ngpt()) :: lw_Ds + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (.not. doLWrad) return + + ! ###################################################################################### + ! + ! Allocate/initialize RRTMGP DDT's + ! + ! ###################################################################################### + ! + ! ty_gas_concs + ! + gas_concentrations%ncol = 1 + gas_concentrations%nlay = nLay + allocate(gas_concentrations%gas_name(nGases)) + allocate(gas_concentrations%concs(nGases)) + do iGas=1,nGases + allocate(gas_concentrations%concs(iGas)%conc(1, nLay)) + enddo + gas_concentrations%gas_name(:) = active_gases_array(:) + ! + ! ty_optical_props + ! + call check_error_msg('rrtmgp_lw_main_gas_optics_init',& + lw_optical_props_clrsky%alloc_1scl(1, nLay, lw_gas_props)) + call check_error_msg('rrtmgp_lw_main_sources_init',& + sources%alloc(1, nLay, lw_gas_props)) + call check_error_msg('rrtmgp_lw_main_cloud_optics_init',& + lw_optical_props_cloudsByBand%alloc_1scl(1, nLay, lw_gas_props%get_band_lims_wavenumber())) + call check_error_msg('rrtmgp_lw_main_precip_optics_init',& + lw_optical_props_precipByBand%alloc_1scl(1, nLay, lw_gas_props%get_band_lims_wavenumber())) + call check_error_msg('rrtmgp_lw_mian_cloud_sampling_init', & + lw_optical_props_clouds%alloc_2str(1, nLay, lw_gas_props)) + call check_error_msg('rrtmgp_lw_main_aerosol_optics_init',& + lw_optical_props_aerosol_local%alloc_1scl(1, nLay, lw_gas_props%get_band_lims_wavenumber())) + if (doGP_sgs_cnv) then + call check_error_msg('rrtmgp_lw_main_cnv_cloud_optics_init',& + lw_optical_props_cnvcloudsByBand%alloc_1scl(1, nLay, lw_gas_props%get_band_lims_wavenumber())) + endif + if (doGP_sgs_pbl) then + call check_error_msg('rrtmgp_lw_main_pbl_cloud_optics_init',& + lw_optical_props_pblcloudsByBand%alloc_1scl(1, nLay, lw_gas_props%get_band_lims_wavenumber())) + endif + ! + ! ty_fluxes_byband + ! + flux_allsky%bnd_flux_up => fluxLW_up_allsky + flux_allsky%bnd_flux_dn => fluxLW_dn_allsky + flux_clrsky%bnd_flux_up => fluxLW_up_clrsky + flux_clrsky%bnd_flux_dn => fluxLW_dn_clrsky + + ! Loop over all columns... + do iCol=1,nCol + ! Initialize/reset + lw_optical_props_clrsky%tau = 0._kind_phys + lw_optical_props_clouds%tau = 0._kind_phys + lw_optical_props_clouds%ssa = 1._kind_phys + lw_optical_props_clouds%g = 0._kind_phys + lw_optical_props_precipByBand%tau = 0._kind_phys + + ! ################################################################################### + ! + ! Set gas-concentrations + ! + ! ################################################################################### + gas_concentrations%concs(istr_o2)%conc(1,:) = vmr_o2(iCol,:) + gas_concentrations%concs(istr_co2)%conc(1,:) = vmr_co2(iCol,:) + gas_concentrations%concs(istr_ch4)%conc(1,:) = vmr_ch4(iCol,:) + gas_concentrations%concs(istr_n2o)%conc(1,:) = vmr_n2o(iCol,:) + gas_concentrations%concs(istr_h2o)%conc(1,:) = vmr_h2o(iCol,:) + gas_concentrations%concs(istr_o3)%conc(1,:) = vmr_o3(iCol,:) + + ! ################################################################################### + ! + ! Gas-optics + ! + ! ################################################################################### + call check_error_msg('rrtmgp_lw_main_gas_optics',lw_gas_props%gas_optics(& + p_lay(iCol:iCol,:), & ! IN - Pressure @ layer-centers (Pa) + p_lev(iCol:iCol,:), & ! IN - Pressure @ layer-interfaces (Pa) + t_lay(iCol:iCol,:), & ! IN - Temperature @ layer-centers (K) + tsfg(iCol:iCol), & ! IN - Skin-temperature (K) + gas_concentrations, & ! IN - RRTMGP DDT: trace gas volumne mixing-ratios + lw_optical_props_clrsky, & ! OUT - RRTMGP DDT: longwave optical properties + sources, & ! OUT - RRTMGP DDT: source functions + tlev=t_lev(iCol:iCol,:))) ! IN - Temperature @ layer-interfaces (K) (optional) + + ! ################################################################################### + ! + ! Cloud-optics + ! + ! ################################################################################### + call check_error_msg('rrtmgp_lw_main_cloud_optics',lw_cloud_props%cloud_optics(& + cld_lwp(iCol:iCol,:), & ! IN - Cloud liquid water path (g/m2) + cld_iwp(iCol:iCol,:), & ! IN - Cloud ice water path (g/m2) + cld_reliq(iCol:iCol,:), & ! IN - Cloud liquid effective radius (microns) + cld_reice(iCol:iCol,:), & ! IN - Cloud ice effective radius (microns) + lw_optical_props_cloudsByBand)) ! OUT - RRTMGP DDT containing cloud radiative properties + ! in each band + + ! Convective cloud-optics? + if (doGP_sgs_cnv) then + call check_error_msg('rrtmgp_lw_main_cnv_cloud_optics',lw_cloud_props%cloud_optics(& + cld_cnv_lwp(iCol:iCol,:), & ! IN - Convective cloud liquid water path (g/m2) + cld_cnv_iwp(iCol:iCol,:), & ! IN - Convective cloud ice water path (g/m2) + cld_cnv_reliq(iCol:iCol,:), & ! IN - Convective cloud liquid effective radius (microns) + cld_cnv_reice(iCol:iCol,:), & ! IN - Convective cloud ice effective radius (microns) + lw_optical_props_cnvcloudsByBand)) ! OUT - RRTMGP DDT containing convective cloud radiative properties + ! in each band + !call check_error_msg('rrtmgp_lw_main_increment_cnvclouds_to_clouds',& + ! lw_optical_props_cnvcloudsByBand%increment(lw_optical_props_cloudsByBand)) + endif + + ! MYNN PBL cloud-optics? + if (doGP_sgs_cnv) then + call check_error_msg('rrtmgp_lw_main_pbl_cloud_optics',lw_cloud_props%cloud_optics(& + cld_pbl_lwp(iCol:iCol,:), & ! IN - MYNN-EDMF PBL cloud liquid water path (g/m2) + cld_pbl_iwp(iCol:iCol,:), & ! IN - MYNN-EDMF PBL cloud ice water path (g/m2) + cld_pbl_reliq(iCol:iCol,:), & ! IN - MYNN-EDMF PBL cloud liquid effective radius (microns) + cld_pbl_reice(iCol:iCol,:), & ! IN - MYNN-EDMF PBL cloud ice effective radius (microns) + lw_optical_props_pblcloudsByBand)) ! OUT - RRTMGP DDT containing MYNN-EDMF PBL cloud radiative properties + ! in each band + !call check_error_msg('rrtmgp_lw_main_increment_pblclouds_to_clouds',& + ! lw_optical_props_pblcloudsByBand%increment(lw_optical_props_cloudsByBand)) + endif + + ! Cloud precipitation optics: rain and snow(+groupel) + do iLay=1,nLay + if (cld_frac(iCol,iLay) .gt. 0.) then + ! Rain optical-depth (No band dependence) + tau_rain = absrain*cld_rwp(iCol,iLay) + + ! Snow (+groupel) optical-depth (No band dependence) + if (cld_swp(iCol,iLay) .gt. 0. .and. cld_resnow(iCol,iLay) .gt. 10._kind_phys) then + tau_snow = abssnow0*1.05756*cld_swp(iCol,iLay)/cld_resnow(iCol,iLay) + else + tau_snow = 0.0 + endif + do iBand=1,lw_gas_props%get_nband() + lw_optical_props_precipByBand%tau(1,iLay,iBand) = tau_rain + tau_snow + enddo + endif + enddo + !call check_error_msg('rrtmgp_lw_main_increment_precip_to_clouds',& + ! lw_optical_props_precipByBand%increment(lw_optical_props_cloudsByBand)) + + ! ################################################################################### + ! + ! Cloud-sampling + ! + ! ################################################################################### + ! Change random number seed value for each radiation invocation (isubc_lw =1 or 2). + if(isubc_lw == 1) then ! advance prescribed permutation seed + ipseed_lw = lw_gas_props%get_ngpt() + iCol + elseif (isubc_lw == 2) then ! use input array of permutaion seeds + ipseed_lw = icseed_lw(iCol) + endif + ! Call RNG + call random_setseed(ipseed_lw,rng_stat) + ! Use same rng for each layer + if (iovr == iovr_max) then + call random_number(rng1D,rng_stat) + do iLay=1,nLay + rng3D(:,iLay,1) = rng1D + enddo + else + do iLay=1,nLay + call random_number(rng1D,rng_stat) + rng3D(:,iLay,1) = rng1D + enddo + endif + ! Cloud-overlap. + ! Maximum-random, random or maximum. + if (iovr == iovr_maxrand .or. iovr == iovr_rand .or. iovr == iovr_max) then + call sampled_mask(rng3D, cld_frac(iCol:iCol,:), maskMCICA) + endif + ! Exponential decorrelation length overlap + if (iovr == iovr_dcorr) then + ! Generate second RNG + call random_setseed(ipseed_lw,rng_stat) + call random_number(rng2D,rng_stat) + rng3D2(:,:,1) = reshape(source = rng2D,shape=[lw_gas_props%get_ngpt(),nLay]) + ! + call sampled_mask(rng3D, cld_frac(iCol:iCol,:), maskMCICA, & + overlap_param = cloud_overlap_param(iCol:iCol,1:nLay-1), randoms2 = rng3D2) + endif + ! Exponential or Exponential-random + if (iovr == iovr_exp .or. iovr == iovr_exprand) then + call sampled_mask(rng3D, cld_frac(iCol:iCol,:), maskMCICA, & + overlap_param = cloud_overlap_param(iCol:iCol,1:nLay-1)) + endif + ! Sampling. Map band optical depth to each g-point using McICA + call check_error_msg('rrtmgp_lw_main_cloud_sampling',& + draw_samples(maskMCICA, .true., & + lw_optical_props_cloudsByBand, lw_optical_props_clouds)) + + ! ################################################################################### + ! + ! Compute clear-sky fluxes (gaseous+aerosol) (optional) + ! + ! ################################################################################### + ! Add aerosol optics to gas optics + lw_optical_props_aerosol_local%tau = lw_optical_props_aerosol%tau(iCol:iCol,:,:) + call check_error_msg('rrtmgp_lw_main_increment_aerosol_to_clrsky',& + lw_optical_props_aerosol_local%increment(lw_optical_props_clrsky)) + + ! Call RTE solver + if (doLWclrsky) then + call check_error_msg('rrtmgp_lw_main_opt_angle',& + lw_gas_props%compute_optimal_angles(lw_optical_props_clrsky,lw_Ds)) + if (nGauss_angles .gt. 1) then + call check_error_msg('rrtmgp_lw_main_lw_rte_clrsky',rte_lw( & + lw_optical_props_clrsky, & ! IN - optical-properties + top_at_1, & ! IN - veritcal ordering flag + sources, & ! IN - source function + sfc_emiss_byband(:,iCol:iCol), & ! IN - surface emissivity in each LW band + flux_clrsky, & ! OUT - Fluxes + n_gauss_angles = nGauss_angles)) ! IN - Number of angles in Gaussian quadrature + else + call check_error_msg('rrtmgp_lw_main_lw_rte_clrsky',rte_lw( & + lw_optical_props_clrsky, & ! IN - optical-properties + top_at_1, & ! IN - veritcal ordering flag + sources, & ! IN - source function + sfc_emiss_byband(:,iCol:iCol), & ! IN - surface emissivity in each LW band + flux_clrsky, & ! OUT - Fluxes + lw_Ds = lw_Ds)) + endif + + ! Store fluxes + fluxlwUP_clrsky(iCol,:) = sum(flux_clrsky%bnd_flux_up(1,:,:),dim=2) + fluxlwDOWN_clrsky(iCol,:) = sum(flux_clrsky%bnd_flux_dn(1,:,:),dim=2) + else + fluxlwUP_clrsky(iCol,:) = 0.0 + fluxlwDOWN_clrsky(iCol,:) = 0.0 + endif + + ! ################################################################################### + ! + ! All-sky fluxes (clear-sky + clouds + precipitation) + ! + ! ################################################################################### + + ! Include convective cloud? + if (doGP_sgs_cnv) then + call check_error_msg('rrtmgp_lw_main_increment_cnvclouds_to_clrsky',& + lw_optical_props_cnvcloudsByBand%increment(lw_optical_props_clouds)) + endif + + ! Include MYNN-EDMF PBL clouds? + if (doGP_sgs_pbl) then + call check_error_msg('rrtmgp_lw_main_increment_pblclouds_to_clrsky',& + lw_optical_props_pblcloudsByBand%increment(lw_optical_props_clouds)) + endif + + ! Add in precipitation + call check_error_msg('rrtmgp_lw_main_increment_precip_to_clrsky',& + lw_optical_props_precipByBand%increment(lw_optical_props_clouds)) + + ! Include LW cloud-scattering? + if (doGP_lwscat) then + ! Add clear-sky optics to cloud-optics (2-stream) + call check_error_msg('rrtmgp_lw_main_increment_clrsky_to_clouds',& + lw_optical_props_clrsky%increment(lw_optical_props_clouds)) + + if (use_LW_jacobian) then + ! Compute LW Jacobians + call check_error_msg('rrtmgp_lw_main_lw_rte_allsky',rte_lw( & + lw_optical_props_clouds, & ! IN - optical-properties + top_at_1, & ! IN - veritcal ordering flag + sources, & ! IN - source function + sfc_emiss_byband(:,iCol:iCol), & ! IN - surface emissivity in each LW band + flux_allsky, & ! OUT - Flxues + n_gauss_angles = nGauss_angles, & ! IN - Number of angles in Gaussian quadrature + flux_up_Jac = fluxlwUP_jac)) ! OUT - surface temperature flux (upward) Jacobian (W/m2/K) + else + call check_error_msg('rrtmgp_lw_main_lw_rte_allsky',rte_lw( & + lw_optical_props_clouds, & ! IN - optical-properties + top_at_1, & ! IN - veritcal ordering flag + sources, & ! IN - source function + sfc_emiss_byband(:,iCol:iCol), & ! IN - surface emissivity in each LW band + flux_allsky, & ! OUT - Flxues + n_gauss_angles = nGauss_angles)) ! IN - Number of angles in Gaussian quadrature + end if + ! No scattering in LW clouds. + else + ! Add cloud optics to clear-sky optics (scalar) + call check_error_msg('rrtmgp_lw_main_increment_clouds_to_clrsky', & + lw_optical_props_clouds%increment(lw_optical_props_clrsky)) + + if (use_LW_jacobian) then + ! Compute LW Jacobians + call check_error_msg('rrtmgp_lw_rte_run',rte_lw( & + lw_optical_props_clrsky, & ! IN - optical-properties + top_at_1, & ! IN - veritcal ordering flag + sources, & ! IN - source function + sfc_emiss_byband(:,iCol:iCol), & ! IN - surface emissivity in each LW band + flux_allsky, & ! OUT - Flxues + n_gauss_angles = nGauss_angles, & ! IN - Number of angles in Gaussian quadrature + flux_up_Jac = fluxlwUP_jac)) ! OUT - surface temperature flux (upward) Jacobian (W/m2/K) + else + call check_error_msg('rrtmgp_lw_rte_run',rte_lw( & + lw_optical_props_clrsky, & ! IN - optical-properties + top_at_1, & ! IN - veritcal ordering flag + sources, & ! IN - source function + sfc_emiss_byband(:,iCol:iCol), & ! IN - surface emissivity in each LW band + flux_allsky, & ! OUT - Flxues + n_gauss_angles = nGauss_angles)) ! IN - Number of angles in Gaussian quadrature + end if + endif + + ! Store fluxes + fluxlwUP_allsky(iCol,:) = sum(flux_allsky%bnd_flux_up(1,:,:),dim=2) + fluxlwDOWN_allsky(iCol,:) = sum(flux_allsky%bnd_flux_dn(1,:,:),dim=2) + + ! Save fluxes for coupling + fluxlwUP_radtime(iCol,:) = fluxlwUP_allsky(iCol,:) + fluxlwDOWN_radtime(iCol,:) = fluxlwDOWN_allsky(iCol,:) + + enddo + + end subroutine rrtmgp_lw_main_run + +end module rrtmgp_lw_main diff --git a/physics/rrtmgp_lw_main.meta b/physics/rrtmgp_lw_main.meta new file mode 100644 index 000000000..6f10b8504 --- /dev/null +++ b/physics/rrtmgp_lw_main.meta @@ -0,0 +1,635 @@ +[ccpp-table-properties] + name = rrtmgp_lw_main + type = scheme + dependencies = machine.F,radiation_tools.F90,GFS_rrtmgp_pre.F90,rte-rrtmgp/rrtmgp/mo_gas_optics_rrtmgp.F90 + dependencies = rte-rrtmgp/rte/mo_rte_kind.F90,rte-rrtmgp/rrtmgp/mo_gas_concentrations.F90,rte-rrtmgp/rte/mo_optical_props.F90 + dependencies = rte-rrtmgp/rte/mo_source_functions.F90,rte-rrtmgp/rte/mo_rte_lw.F90,rte-rrtmgp/rte/mo_fluxes.F90 + dependencies = rte-rrtmgp/rte/kernels/mo_fluxes_broadband_kernels.F90, rte-rrtmgp/rte/kernels/mo_rte_solver_kernels.F90 + dependencies = mersenne_twister.f,rrtmgp_sampling.F90,rte-rrtmgp/extensions/mo_fluxes_byband.F90 + dependencies = rrtmgp_lw_gas_optics.F90, rrtmgp_lw_cloud_optics.F90 + +######################################################################## +[ccpp-arg-table] + name = rrtmgp_lw_main_init + type = scheme +[rrtmgp_root_dir] + standard_name = directory_for_rte_rrtmgp_source_code + long_name = directory for rte+rrtmgp source code + units = none + dimensions = () + type = character + intent = in + kind = len=128 +[rrtmgp_lw_file_gas] + standard_name = filename_of_rrtmgp_longwave_k_distribution + long_name = file containing RRTMGP LW k-distribution + units = none + dimensions = () + type = character + intent = in + kind = len=128 +[rrtmgp_lw_file_clouds] + standard_name = filename_of_rrtmgp_longwave_cloud_optics_coefficients + long_name = file containing coefficients for RRTMGP LW cloud optics + units = none + dimensions = () + type = character + intent = in + kind = len=128 +[doG_cldoptics] + standard_name = flag_to_calc_lw_cld_optics_using_RRTMG + long_name = logical flag to control cloud optics scheme. + units = flag + dimensions = () + type = logical + intent = in +[doGP_cldoptics_PADE] + standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_PADE + long_name = logical flag to control cloud optics scheme. + units = flag + dimensions = () + type = logical + intent = in +[doGP_cldoptics_LUT] + standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_LUT + long_name = logical flag to control cloud optics scheme. + units = flag + dimensions = () + type = logical + intent = in +[nrghice] + standard_name = number_of_ice_roughness_categories + long_name = number of ice-roughness categories in RRTMGP calculation + units = count + dimensions = () + type = integer + intent = inout +[mpirank] + standard_name = mpi_rank + long_name = current MPI rank + units = index + dimensions = () + type = integer + intent = in +[mpiroot] + standard_name = mpi_root + long_name = master MPI rank + units = index + dimensions = () + type = integer + intent = in +[mpicomm] + standard_name = mpi_communicator + long_name = MPI communicator + units = index + dimensions = () + type = integer + intent = in +[minGPpres] + standard_name = minimum_pressure_in_RRTMGP + long_name = minimum pressure allowed in RRTMGP + units = Pa + dimensions = () + type = real + kind = kind_phys + intent = out +[maxGPpres] + standard_name = maximum_pressure_in_RRTMGP + long_name = maximum pressure allowed in RRTMGP + units = Pa + dimensions = () + type = real + kind = kind_phys + intent = out +[minGPtemp] + standard_name = minimum_temperature_in_RRTMGP + long_name = minimum temperature allowed in RRTMGP + units = K + dimensions = () + type = real + kind = kind_phys + intent = out +[maxGPtemp] + standard_name = maximum_temperature_in_RRTMGP + long_name = maximum temperature allowed in RRTMGP + units = K + dimensions = () + type = real + kind = kind_phys + intent = out +[active_gases_array] + standard_name = list_of_active_gases_used_by_RRTMGP + long_name = list of active gases used by RRTMGP + units = none + dimensions = (number_of_active_gases_used_by_RRTMGP) + type = character + kind = len=* + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out + +######################################################################## +[ccpp-arg-table] + name = rrtmgp_lw_main_run + type = scheme +[doLWrad] + standard_name = flag_for_calling_longwave_radiation + long_name = logical flags for lw radiation calls + units = flag + dimensions = () + type = logical + intent = in +[doLWclrsky] + standard_name = flag_for_output_of_tendency_of_air_temperature_due_to_longwave_heating_on_radiation_timestep_assuming_clear_sky + long_name = flag to output lw heating rate (Radtend%lwhc) + units = flag + dimensions = () + type = logical + intent = in +[top_at_1] + standard_name = flag_for_vertical_ordering_in_RRTMGP + long_name = flag for vertical ordering in RRTMGP + units = flag + dimensions = () + type = logical + intent = in +[use_LW_jacobian] + standard_name = flag_to_calc_RRTMGP_LW_jacobian + long_name = logical flag to control RRTMGP LW calculation + units = flag + dimensions = () + type = logical + intent = in +[doGP_lwscat] + standard_name = flag_to_include_longwave_scattering_in_cloud_optics + long_name = logical flag to control the addition of LW scattering in RRTMGP + units = flag + dimensions = () + type = logical + intent = in +[doGP_sgs_cnv] + standard_name = flag_to_include_sgs_convective_cloud_in_RRTMGP + long_name = logical flag to control sgs convective cloud in RRTMGP + units = flag + dimensions = () + type = logical + intent = in +[doGP_sgs_pbl] + standard_name = flag_to_include_sgs_MYNN_EDMF_cloud_in_RRTMGP + long_name = logical flag to control MYNN-EDMF PBL cloud in RRTMGP + units = flag + dimensions = () + type = logical + intent = in +[ncol] + standard_name = horizontal_loop_extent + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in +[nLay] + standard_name = vertical_layer_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in +[nGauss_angles] + standard_name = number_of_gaussian_quadrature_angles_for_radiation + long_name = Number of angles used in Gaussian quadrature + units = count + dimensions = () + type = integer + intent = in +[nGases] + standard_name = number_of_active_gases_used_by_RRTMGP + long_name = number of gases available used by RRTMGP (Model%nGases) + units = count + dimensions = () + type = integer + intent = in +[i_o3] + standard_name = index_of_ozone_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for ozone mixing ratio + units = index + dimensions = () + type = integer + intent = in +[isubc_lw] + standard_name = flag_for_lw_clouds_sub_grid_approximation + long_name = flag for lw clouds sub-grid approximation + units = flag + dimensions = () + type = integer + intent = in +[iovr] + standard_name = flag_for_cloud_overlap_method_for_radiation + long_name = max-random overlap clouds + units = flag + dimensions = () + type = integer + intent = in +[iovr_maxrand] + standard_name = flag_for_maximum_random_cloud_overlap_method + long_name = choice of maximum-random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_dcorr] + standard_name = flag_for_decorrelation_length_cloud_overlap_method + long_name = choice of decorrelation-length cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_exp] + standard_name = flag_for_exponential_cloud_overlap_method + long_name = choice of exponential cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_exprand] + standard_name = flag_for_exponential_random_cloud_overlap_method + long_name = choice of exponential-random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_rand] + standard_name = flag_for_random_cloud_overlap_method + long_name = choice of random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_max] + standard_name = flag_for_maximum_cloud_overlap_method + long_name = choice of maximum cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_convcld] + standard_name = flag_for_convective_cloud_overlap_method_for_radiation + long_name = flag for convective cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[icseed_lw] + standard_name = random_number_seed_for_mcica_longwave + long_name = seed for random number generation for longwave radiation + units = none + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[tsfg] + standard_name = surface_ground_temperature_for_radiation + long_name = surface ground temperature for radiation + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[p_lay] + standard_name = air_pressure_at_layer_for_RRTMGP + long_name = air pressure at vertical layer for radiation calculation + units = Pa + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[p_lev] + standard_name = air_pressure_at_interface_for_RRTMGP + long_name = air pressure at vertical interface for radiation calculation + units = Pa + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in +[t_lay] + standard_name = air_temperature_at_layer_for_RRTMGP + long_name = air temperature at vertical layer for radiation calculation + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[t_lev] + standard_name = air_temperature_at_interface_for_RRTMGP + long_name = air temperature at vertical interface for radiation calculation + units = K + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in +[vmr_o2] + standard_name = volume_mixing_ratio_for_o2 + long_name = molar mixing ratio of o2 in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[vmr_h2o] + standard_name = volume_mixing_ratio_for_h2o + long_name = molar mixing ratio of h2o in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[vmr_o3] + standard_name = volume_mixing_ratio_for_o3 + long_name = molar mixing ratio of o3 in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[vmr_ch4] + standard_name = volume_mixing_ratio_for_ch4 + long_name = molar mixing ratio of ch4 in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[vmr_n2o] + standard_name = volume_mixing_ratio_for_n2o + long_name = molar mixing ratio of n2o in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[vmr_co2] + standard_name = volume_mixing_ratio_for_co2 + long_name = molar mixing ratio of co2 in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_frac] + standard_name = total_cloud_fraction + long_name = layer total cloud fraction + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_lwp] + standard_name = cloud_liquid_water_path + long_name = layer cloud liquid water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_reliq] + standard_name = mean_effective_radius_for_liquid_cloud + long_name = mean effective radius for liquid cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_iwp] + standard_name = cloud_ice_water_path + long_name = layer cloud ice water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_reice] + standard_name = mean_effective_radius_for_ice_cloud + long_name = mean effective radius for ice cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_swp] + standard_name = cloud_snow_water_path + long_name = layer cloud snow water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_resnow] + standard_name = mean_effective_radius_for_snow_flake + long_name = mean effective radius for snow cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_rwp] + standard_name = cloud_rain_water_path + long_name = layer cloud rain water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_rerain] + standard_name = mean_effective_radius_for_rain_drop + long_name = mean effective radius for rain cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[precip_frac] + standard_name = precipitation_fraction_by_layer + long_name = precipitation fraction in each layer + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_cnv_lwp] + standard_name = convective_cloud_liquid_water_path + long_name = layer convective cloud liquid water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_cnv_iwp] + standard_name = convective_cloud_ice_water_path + long_name = layer convective cloud ice water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_cnv_reliq] + standard_name = mean_effective_radius_for_liquid_convective_cloud + long_name = mean effective radius for liquid convective cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_cnv_reice] + standard_name = mean_effective_radius_for_ice_convective_cloud + long_name = mean effective radius for ice convective cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_pbl_lwp] + standard_name = MYNN_SGS_cloud_liquid_water_path + long_name = layer convective cloud liquid water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_pbl_iwp] + standard_name = MYNN_SGS_cloud_ice_water_path + long_name = layer convective cloud ice water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_pbl_reliq] + standard_name = mean_effective_radius_for_liquid_MYNN_SGS_cloud + long_name = mean effective radius for liquid MYNN_SGS cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_pbl_reice] + standard_name = mean_effective_radius_for_ice_MYNN_SGS_cloud + long_name = mean effective radius for ice MYNN_SGS cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cloud_overlap_param] + standard_name = cloud_overlap_param + long_name = cloud overlap parameter + units = km + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[sfc_emiss_byband] + standard_name = surface_emissivity_in_each_RRTMGP_LW_band + long_name = surface emissivity in each RRTMGP LW band + units = none + dimensions = (number_of_longwave_bands,horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[active_gases_array] + standard_name = list_of_active_gases_used_by_RRTMGP + long_name = list of active gases used by RRTMGP + units = none + dimensions = (number_of_active_gases_used_by_RRTMGP) + type = character + kind = len=* + intent = in +[lw_optical_props_aerosol] + standard_name = longwave_optical_properties_for_aerosols + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_1scl + intent = in +[fluxlwUP_radtime] + standard_name = RRTMGP_lw_flux_profile_upward_allsky_on_radiation_timestep + long_name = RRTMGP upward longwave all-sky flux profile + units = W m-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = inout +[fluxlwDOWN_radtime] + standard_name = RRTMGP_lw_flux_profile_downward_allsky_on_radiation_timestep + long_name = RRTMGP downward longwave all-sky flux profile + units = W m-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = inout +[fluxlwUP_allsky] + standard_name = RRTMGP_lw_flux_profile_upward_allsky + long_name = RRTMGP upward longwave all-sky flux profile + units = W m-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = inout +[fluxlwDOWN_allsky] + standard_name = RRTMGP_lw_flux_profile_downward_allsky + long_name = RRTMGP downward longwave all-sky flux profile + units = W m-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = inout +[fluxlwUP_clrsky] + standard_name = RRTMGP_lw_flux_profile_upward_clrsky + long_name = RRTMGP upward longwave clr-sky flux profile + units = W m-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = inout +[fluxlwDOWN_clrsky] + standard_name = RRTMGP_lw_flux_profile_downward_clrsky + long_name = RRTMGP downward longwave clr-sky flux profile + units = W m-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = inout +[fluxlwUP_jac] + standard_name = RRTMGP_jacobian_of_lw_flux_upward + long_name = RRTMGP Jacobian upward longwave flux profile + units = W m-2 K-1 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = inout +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out \ No newline at end of file From a8d3f24d3c88f6bbd6c2360868178d996a531e60 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Mon, 11 Apr 2022 23:14:50 +0000 Subject: [PATCH 002/380] Add loop over columns in RRTMGP scheme. Collapse GP schemes into loop. Removed deprecated scheme files. --- physics/GFS_rrtmgp_pre.F90 | 20 +- physics/GFS_rrtmgp_pre.meta | 14 + physics/GFS_rrtmgp_sw_pre.F90 | 98 ---- physics/GFS_rrtmgp_sw_pre.meta | 124 ------ physics/rrtmgp_aerosol_optics.F90 | 8 +- physics/rrtmgp_lw_cloud_optics.F90 | 2 - physics/rrtmgp_lw_cloud_optics.meta | 89 ---- physics/rrtmgp_lw_cloud_sampling.F90 | 166 ------- physics/rrtmgp_lw_cloud_sampling.meta | 226 ---------- physics/rrtmgp_lw_gas_optics.meta | 101 ----- physics/rrtmgp_lw_main.F90 | 44 +- physics/rrtmgp_lw_main.meta | 16 +- physics/rrtmgp_lw_pre.F90 | 64 --- physics/rrtmgp_lw_pre.meta | 47 -- physics/rrtmgp_lw_rte.F90 | 213 --------- physics/rrtmgp_lw_rte.meta | 208 --------- physics/rrtmgp_sw_cloud_optics.F90 | 189 +------- physics/rrtmgp_sw_cloud_optics.meta | 393 ---------------- physics/rrtmgp_sw_cloud_sampling.F90 | 170 ------- physics/rrtmgp_sw_cloud_sampling.meta | 240 ---------- physics/rrtmgp_sw_gas_optics.F90 | 115 +---- physics/rrtmgp_sw_gas_optics.meta | 201 --------- physics/rrtmgp_sw_main.F90 | 555 +++++++++++++++++++++++ physics/rrtmgp_sw_main.meta | 618 ++++++++++++++++++++++++++ physics/rrtmgp_sw_rte.F90 | 221 --------- physics/rrtmgp_sw_rte.meta | 240 ---------- 26 files changed, 1251 insertions(+), 3131 deletions(-) delete mode 100644 physics/GFS_rrtmgp_sw_pre.F90 delete mode 100644 physics/GFS_rrtmgp_sw_pre.meta delete mode 100644 physics/rrtmgp_lw_cloud_optics.meta delete mode 100644 physics/rrtmgp_lw_cloud_sampling.F90 delete mode 100644 physics/rrtmgp_lw_cloud_sampling.meta delete mode 100644 physics/rrtmgp_lw_gas_optics.meta delete mode 100644 physics/rrtmgp_lw_pre.F90 delete mode 100644 physics/rrtmgp_lw_pre.meta delete mode 100644 physics/rrtmgp_lw_rte.F90 delete mode 100644 physics/rrtmgp_lw_rte.meta delete mode 100644 physics/rrtmgp_sw_cloud_optics.meta delete mode 100644 physics/rrtmgp_sw_cloud_sampling.F90 delete mode 100644 physics/rrtmgp_sw_cloud_sampling.meta delete mode 100644 physics/rrtmgp_sw_gas_optics.meta create mode 100644 physics/rrtmgp_sw_main.F90 create mode 100644 physics/rrtmgp_sw_main.meta delete mode 100644 physics/rrtmgp_sw_rte.F90 delete mode 100644 physics/rrtmgp_sw_rte.meta diff --git a/physics/GFS_rrtmgp_pre.F90 b/physics/GFS_rrtmgp_pre.F90 index 7e22c41c1..7804ecef7 100644 --- a/physics/GFS_rrtmgp_pre.F90 +++ b/physics/GFS_rrtmgp_pre.F90 @@ -101,7 +101,8 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, lsswr, lslwr, fhswr, fhlwr, con_eps, con_epsm1, con_fvirt, con_epsqs, solhr, minGPpres, maxGPpres, minGPtemp, & maxGPtemp, raddt, p_lay, t_lay, p_lev, t_lev, vmr_o2, vmr_h2o, vmr_o3, vmr_ch4, & vmr_n2o, vmr_co2, tsfg, tsfa, qs_lay, q_lay, tv_lay, relhum, deltaZ, deltaZc, deltaP,& - active_gases_array, tsfc_radtime, coszen, coszdg, top_at_1, iSFC, iTOA, errmsg, errflg) + active_gases_array, tsfc_radtime, coszen, coszdg, top_at_1, iSFC, iTOA, nDay, idxday,& + errmsg, errflg) ! Inputs integer, intent(in) :: & @@ -148,7 +149,8 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, lsswr, lslwr, fhswr, fhlwr, integer, intent(out) :: & errflg, & ! Error flag iSFC, & ! Vertical index for surface - iTOA ! Vertical index for TOA + iTOA, & ! Vertical index for TOA + nDay logical, intent(out) :: & top_at_1 ! Vertical ordering flag real(kind_phys), intent(inout) :: & @@ -159,6 +161,8 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, lsswr, lslwr, fhswr, fhlwr, tsfc_radtime, & ! Surface temperature at radiation timestep coszen, & ! Cosine of SZA coszdg ! Cosine of SZA, daytime + integer, dimension(:), intent(out) :: & + idxday ! Indices for daylit points real(kind_phys), dimension(:,:), intent(inout) :: & p_lay, & ! Pressure at model-layer t_lay, & ! Temperature at model layer @@ -357,6 +361,18 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, lsswr, lslwr, fhswr, fhlwr, ! ####################################################################################### if (lsswr) then call coszmn (xlon, sinlat, coslat, solhr, nCol, me, coszen, coszdg) + ! For SW gather daylit points + nday = 0 + idxday = 0 + do iCol = 1, nCol + if (coszen(iCol) >= 0.0001) then + nday = nday + 1 + idxday(nday) = i + endif + enddo + else + nday = 0 + idxday = 0 endif end subroutine GFS_rrtmgp_pre_run diff --git a/physics/GFS_rrtmgp_pre.meta b/physics/GFS_rrtmgp_pre.meta index 800bc470d..39cf198f6 100644 --- a/physics/GFS_rrtmgp_pre.meta +++ b/physics/GFS_rrtmgp_pre.meta @@ -490,6 +490,20 @@ type = real kind = kind_phys intent = inout +[nday] + standard_name = daytime_points_dimension + long_name = daytime points dimension + units = count + dimensions = () + type = integer + intent = inout +[idxday] + standard_name = daytime_points + long_name = daytime points + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = out [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/GFS_rrtmgp_sw_pre.F90 b/physics/GFS_rrtmgp_sw_pre.F90 deleted file mode 100644 index 3566575f4..000000000 --- a/physics/GFS_rrtmgp_sw_pre.F90 +++ /dev/null @@ -1,98 +0,0 @@ -module GFS_rrtmgp_sw_pre - use machine, only: kind_phys - use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp - use rrtmgp_sw_gas_optics, only: sw_gas_props - - public GFS_rrtmgp_sw_pre_run, GFS_rrtmgp_sw_pre_init, GFS_rrtmgp_sw_pre_finalize -contains - - ! ######################################################################################### - ! SUBROUTINE GFS_rrtmgp_sw_pre_init - ! ######################################################################################### - subroutine GFS_rrtmgp_sw_pre_init () - end subroutine GFS_rrtmgp_sw_pre_init - - ! ######################################################################################### - ! SUBROUTINE GFS_rrtmgp_sw_pre_run - ! ######################################################################################### -!> \section arg_table_GFS_rrtmgp_sw_pre_run -!! \htmlinclude GFS_rrtmgp_sw_pre.html -!! - subroutine GFS_rrtmgp_sw_pre_run(nCol, doSWrad, coszen, nday, idxday, sfc_alb_nir_dir, & - sfc_alb_nir_dif, sfc_alb_uvvis_dir, sfc_alb_uvvis_dif, sfc_alb_nir_dir_byband, & - sfc_alb_nir_dif_byband, sfc_alb_uvvis_dir_byband, sfc_alb_uvvis_dif_byband, errmsg, & - errflg) - - ! Input - integer, intent(in) :: & - nCol ! Number of horizontal grid points - logical,intent(in) :: & - doSWrad ! Call RRTMGP SW radiation? - real(kind_phys), dimension(:), intent(in) :: & - coszen - real(kind_phys), dimension(:), intent(in) :: & - sfc_alb_nir_dir, & ! - sfc_alb_nir_dif, & ! - sfc_alb_uvvis_dir, & ! - sfc_alb_uvvis_dif ! - - ! Outputs - integer, intent(out) :: & - nday ! Number of daylit points - integer, dimension(:), intent(out) :: & - idxday ! Indices for daylit points - real(kind_phys), dimension(:,:), intent(out) :: & - sfc_alb_nir_dir_byband, & ! Surface albedo (direct) - sfc_alb_nir_dif_byband, & ! Surface albedo (diffuse) - sfc_alb_uvvis_dir_byband, & ! Surface albedo (direct) - sfc_alb_uvvis_dif_byband ! Surface albedo (diffuse) - character(len=*), intent(out) :: & - errmsg ! Error message - integer, intent(out) :: & - errflg ! Error flag - - ! Local variables - integer :: i, iBand - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (doSWrad) then - ! #################################################################################### - ! For SW gather daylit points - ! #################################################################################### - nday = 0 - idxday = 0 - do i = 1, nCol - if (coszen(i) >= 0.0001) then - nday = nday + 1 - idxday(nday) = i - endif - enddo - - ! Spread across all SW bands - do iBand=1,sw_gas_props%get_nband() - sfc_alb_nir_dir_byband(iBand,1:nCol) = sfc_alb_nir_dir(1:nCol) - sfc_alb_nir_dif_byband(iBand,1:nCol) = sfc_alb_nir_dif(1:nCol) - sfc_alb_uvvis_dir_byband(iBand,1:nCol) = sfc_alb_uvvis_dir(1:nCol) - sfc_alb_uvvis_dif_byband(iBand,1:nCol) = sfc_alb_uvvis_dif(1:nCol) - enddo - else - nday = 0 - idxday = 0 - sfc_alb_nir_dir_byband(:,1:nCol) = 0. - sfc_alb_nir_dif_byband(:,1:nCol) = 0. - sfc_alb_uvvis_dir_byband(:,1:nCol) = 0. - sfc_alb_uvvis_dif_byband(:,1:nCol) = 0. - endif - - end subroutine GFS_rrtmgp_sw_pre_run - - ! ######################################################################################### - ! SUBROUTINE GFS_rrtmgp_sw_pre_finalize - ! ######################################################################################### - subroutine GFS_rrtmgp_sw_pre_finalize () - end subroutine GFS_rrtmgp_sw_pre_finalize - -end module GFS_rrtmgp_sw_pre diff --git a/physics/GFS_rrtmgp_sw_pre.meta b/physics/GFS_rrtmgp_sw_pre.meta deleted file mode 100644 index 462ab5f18..000000000 --- a/physics/GFS_rrtmgp_sw_pre.meta +++ /dev/null @@ -1,124 +0,0 @@ -[ccpp-table-properties] - name = GFS_rrtmgp_sw_pre - type = scheme - dependencies = machine.F,radiation_astronomy.f,rrtmgp_sw_gas_optics.F90,rte-rrtmgp/rrtmgp/mo_gas_optics_rrtmgp.F90, - -######################################################################## -[ccpp-arg-table] - name = GFS_rrtmgp_sw_pre_run - type = scheme -[ncol] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[doSWrad] - standard_name = flag_for_calling_shortwave_radiation - long_name = logical flags for sw radiation calls - units = flag - dimensions = () - type = logical - intent = in -[nday] - standard_name = daytime_points_dimension - long_name = daytime points dimension - units = count - dimensions = () - type = integer - intent = out -[idxday] - standard_name = daytime_points - long_name = daytime points - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = out -[coszen] - standard_name = cosine_of_solar_zenith_angle_for_daytime_points_on_radiation_timestep - long_name = mean cos of zenith angle over rad call period - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[sfc_alb_nir_dir] - standard_name = surface_albedo_due_to_near_IR_direct - long_name = surface albedo due to near IR direct beam - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[sfc_alb_nir_dif] - standard_name = surface_albedo_due_to_near_IR_diffused - long_name = surface albedo due to near IR diffused beam - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[sfc_alb_uvvis_dir] - standard_name = surface_albedo_due_to_UV_and_VIS_direct - long_name = surface albedo due to UV+VIS direct beam - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[sfc_alb_uvvis_dif] - standard_name = surface_albedo_due_to_UV_and_VIS_diffused - long_name = surface albedo due to UV+VIS diffused beam - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[sfc_alb_nir_dir_byband] - standard_name = surface_albedo_nearIR_direct - long_name = near-IR (direct) surface albedo (sfc_alb_nir_dir) - units = none - dimensions = (number_of_shortwave_bands,horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[sfc_alb_nir_dif_byband] - standard_name = surface_albedo_nearIR_diffuse - long_name = near-IR (diffuse) surface albedo (sfc_alb_nir_dif) - units = none - dimensions = (number_of_shortwave_bands,horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[sfc_alb_uvvis_dir_byband] - standard_name = surface_albedo_uvvis_direct - long_name = UVVIS (direct) surface albedo (sfc_alb_uvvis_dir) - units = none - dimensions = (number_of_shortwave_bands,horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[sfc_alb_uvvis_dif_byband] - standard_name = surface_albedo_uvvis_diffuse - long_name = UVVIS (diffuse) surface albedo (sfc_alb_uvvis_dif) - units = none - dimensions = (number_of_shortwave_bands,horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out diff --git a/physics/rrtmgp_aerosol_optics.F90 b/physics/rrtmgp_aerosol_optics.F90 index eb7797125..9c440a09e 100644 --- a/physics/rrtmgp_aerosol_optics.F90 +++ b/physics/rrtmgp_aerosol_optics.F90 @@ -110,14 +110,10 @@ subroutine rrtmgp_aerosol_optics_run(doSWrad, doLWrad, nCol, nLev, nTracer, nTra ! Longwave if (.not. doLWrad) return + call check_error_msg('rrtmgp_aerosol_optics_run',lw_optical_props_aerosol%alloc_1scl( & + nCol, nlev, lw_gas_props%get_band_lims_wavenumber())) lw_optical_props_aerosol%tau = aerosolslw(:,:,:,1) * (1. - aerosolslw(:,:,:,2)) - lw_optical_props_aerosol%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() - do iBand=1,lw_gas_props%get_nband() - lw_optical_props_aerosol%band2gpt(1:2,iBand) = iBand - lw_optical_props_aerosol%gpt2band(iBand) = iBand - end do - end subroutine rrtmgp_aerosol_optics_run end module rrtmgp_aerosol_optics diff --git a/physics/rrtmgp_lw_cloud_optics.F90 b/physics/rrtmgp_lw_cloud_optics.F90 index 68f5a4472..37d7e697f 100644 --- a/physics/rrtmgp_lw_cloud_optics.F90 +++ b/physics/rrtmgp_lw_cloud_optics.F90 @@ -2,8 +2,6 @@ module rrtmgp_lw_cloud_optics use machine, only: kind_phys use mo_rte_kind, only: wl use mo_cloud_optics, only: ty_cloud_optics - use mo_optical_props, only: ty_optical_props_1scl, ty_optical_props_2str - use mo_rrtmg_lw_cloud_optics, only: rrtmg_lw_cloud_optics use rrtmgp_lw_gas_optics, only: lw_gas_props use radiation_tools, only: check_error_msg use netcdf diff --git a/physics/rrtmgp_lw_cloud_optics.meta b/physics/rrtmgp_lw_cloud_optics.meta deleted file mode 100644 index 4b2d9cfc0..000000000 --- a/physics/rrtmgp_lw_cloud_optics.meta +++ /dev/null @@ -1,89 +0,0 @@ -[ccpp-table-properties] - name = rrtmgp_lw_cloud_optics - type = scheme - dependencies = machine.F,rrtmg_lw_cloud_optics.F90,radiation_tools.F90 - -######################################################################## -[ccpp-arg-table] - name = rrtmgp_lw_cloud_optics_init - type = scheme -[doG_cldoptics] - standard_name = flag_to_calc_lw_cld_optics_using_RRTMG - long_name = logical flag to control cloud optics scheme. - units = flag - dimensions = () - type = logical - intent = in -[doGP_cldoptics_PADE] - standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_PADE - long_name = logical flag to control cloud optics scheme. - units = flag - dimensions = () - type = logical - intent = in -[doGP_cldoptics_LUT] - standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_LUT - long_name = logical flag to control cloud optics scheme. - units = flag - dimensions = () - type = logical - intent = in -[nrghice] - standard_name = number_of_ice_roughness_categories - long_name = number of ice-roughness categories in RRTMGP calculation - units = count - dimensions = () - type = integer - intent = inout -[rrtmgp_root_dir] - standard_name = directory_for_rte_rrtmgp_source_code - long_name = directory for rte+rrtmgp source code - units = none - dimensions = () - type = character - intent = in - kind = len=128 -[rrtmgp_lw_file_clouds] - standard_name = filename_of_rrtmgp_longwave_cloud_optics_coefficients - long_name = file containing coefficients for RRTMGP LW cloud optics - units = none - dimensions = () - type = character - intent = in - kind = len=128 -[mpirank] - standard_name = mpi_rank - long_name = current MPI rank - units = index - dimensions = () - type = integer - intent = in -[mpiroot] - standard_name = mpi_root - long_name = master MPI rank - units = index - dimensions = () - type = integer - intent = in -[mpicomm] - standard_name = mpi_communicator - long_name = MPI communicator - units = index - dimensions = () - type = integer - intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out diff --git a/physics/rrtmgp_lw_cloud_sampling.F90 b/physics/rrtmgp_lw_cloud_sampling.F90 deleted file mode 100644 index cb11607dc..000000000 --- a/physics/rrtmgp_lw_cloud_sampling.F90 +++ /dev/null @@ -1,166 +0,0 @@ -module rrtmgp_lw_cloud_sampling - use machine, only: kind_phys - use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp - use mo_optical_props, only: ty_optical_props_2str - use rrtmgp_sampling, only: sampled_mask, draw_samples - use mersenne_twister, only: random_setseed, random_number, random_stat - use radiation_tools, only: check_error_msg - use rrtmgp_lw_gas_optics, only: lw_gas_props - use netcdf - - implicit none - -contains - - ! ######################################################################################### - ! SUBROTUINE rrtmgp_lw_cloud_sampling_run() - ! ######################################################################################### -!! \section arg_table_rrtmgp_lw_cloud_sampling_run -!! \htmlinclude rrtmgp_lw_cloud_sampling_run.html -!! - subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, icseed_lw, iovr,iovr_convcld,& - iovr_max, iovr_maxrand, iovr_rand, iovr_dcorr, iovr_exp, iovr_exprand, isubc_lw, & - cld_frac, precip_frac, cloud_overlap_param, precip_overlap_param, cld_cnv_frac, & - cnv_cloud_overlap_param, imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_samf, & - lw_optical_props_cloudsByBand, lw_optical_props_cnvcloudsByBand, & - lw_optical_props_precipByBand, lw_optical_props_clouds, lw_optical_props_cnvclouds, & - lw_optical_props_precip, errmsg, errflg) - - ! Inputs - logical, intent(in) :: & - doLWrad ! Logical flag for shortwave radiation call - integer, intent(in) :: & - nCol, & ! Number of horizontal gridpoints - nLev, & ! Number of vertical layers - imfdeepcnv, & ! - imfdeepcnv_gf, & ! - imfdeepcnv_samf, & ! - iovr, & ! Choice of cloud-overlap method - iovr_convcld, & ! Choice of convective cloud-overlap - iovr_max, & ! Flag for maximum cloud overlap method - iovr_maxrand, & ! Flag for maximum-random cloud overlap method - iovr_rand, & ! Flag for random cloud overlap method - iovr_dcorr, & ! Flag for decorrelation-length cloud overlap method - iovr_exp, & ! Flag for exponential cloud overlap method - iovr_exprand, & ! Flag for exponential-random cloud overlap method - isubc_lw - integer,intent(in),dimension(:) :: & - icseed_lw ! auxiliary special cloud related array when module - ! variable isubc_lw=2, it provides permutation seed - ! for each column profile that are used for generating - ! random numbers. when isubc_lw /=2, it will not be used. - real(kind_phys), dimension(:,:),intent(in) :: & - cld_frac, & ! Total cloud fraction by layer - cld_cnv_frac, & ! Convective cloud fraction by layer - precip_frac, & ! Precipitation fraction by layer - cloud_overlap_param, & ! Cloud overlap parameter - cnv_cloud_overlap_param, & ! Convective cloud overlap parameter - precip_overlap_param ! Precipitation overlap parameter - type(ty_optical_props_2str),intent(in) :: & - lw_optical_props_cloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (clouds) - lw_optical_props_cnvcloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (convective cloud) - lw_optical_props_precipByBand ! RRTMGP DDT: Longwave optical properties in each band (precipitation) - - ! Outputs - character(len=*), intent(out) :: & - errmsg ! CCPP error message - integer, intent(out) :: & - errflg ! CCPP error code - type(ty_optical_props_2str),intent(inout) :: & - lw_optical_props_clouds, & ! RRTMGP DDT: Shortwave optical properties by spectral point (clouds) - lw_optical_props_cnvclouds, & ! RRTMGP DDT: Shortwave optical properties by spectral point (convective cloud) - lw_optical_props_precip ! RRTMGP DDT: Shortwave optical properties by spectral point (precipitation) - - ! Local variables - integer :: iCol, iLay, iBand - integer,dimension(ncol) :: ipseed_lw - type(random_stat) :: rng_stat - real(kind_phys), dimension(lw_gas_props%get_ngpt(),nLev,ncol) :: rng3D,rng3D2 - real(kind_phys), dimension(lw_gas_props%get_ngpt()*nLev) :: rng2D - real(kind_phys), dimension(lw_gas_props%get_ngpt()) :: rng1D - logical, dimension(ncol,nLev,lw_gas_props%get_ngpt()) :: maskMCICA - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (.not. doLWrad) return - - ! #################################################################################### - ! First sample the clouds... - ! #################################################################################### - lw_optical_props_clouds%band2gpt = lw_gas_props%get_band_lims_gpoint() - lw_optical_props_clouds%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() - do iBand=1,lw_gas_props%get_nband() - lw_optical_props_clouds%gpt2band(lw_optical_props_clouds%band2gpt(1,iBand):lw_optical_props_clouds%band2gpt(2,iBand)) = iBand - end do - - ! Change random number seed value for each radiation invocation (isubc_lw =1 or 2). - if(isubc_lw == 1) then ! advance prescribed permutation seed - do iCol = 1, ncol - ipseed_lw(iCol) = lw_gas_props%get_ngpt() + iCol - enddo - elseif (isubc_lw == 2) then ! use input array of permutaion seeds - do iCol = 1, ncol - ipseed_lw(iCol) = icseed_lw(iCol) - enddo - endif - - ! Call RNG. Mersennse Twister accepts 1D array, so loop over columns and collapse along G-points - ! and layers. ([nGpts,nLev,nColumn]-> [nGpts*nLev]*nColumn) - do iCol=1,ncol - call random_setseed(ipseed_lw(icol),rng_stat) - ! Use same rng for each layer - if (iovr == iovr_max) then - call random_number(rng1D,rng_stat) - do iLay=1,nLev - rng3D(:,iLay,iCol) = rng1D - enddo - else - do iLay=1,nLev - call random_number(rng1D,rng_stat) - rng3D(:,iLay,iCol) = rng1D - enddo - endif - enddo - - ! Cloud-overlap. - ! Maximum-random, random or maximum. - if (iovr == iovr_maxrand .or. iovr == iovr_rand .or. iovr == iovr_max) then - call sampled_mask(rng3D, cld_frac, maskMCICA) - endif - ! Exponential decorrelation length overlap - if (iovr == iovr_dcorr) then - ! Generate second RNG - do iCol=1,ncol - call random_setseed(ipseed_lw(icol),rng_stat) - call random_number(rng2D,rng_stat) - rng3D2(:,:,iCol) = reshape(source = rng2D,shape=[lw_gas_props%get_ngpt(),nLev]) - enddo - call sampled_mask(rng3D, cld_frac, maskMCICA, & - overlap_param = cloud_overlap_param(:,1:nLev-1), & - randoms2 = rng3D2) - endif - ! Exponential or Exponential-random - if (iovr == iovr_exp .or. iovr == iovr_exprand) then - call sampled_mask(rng3D, cld_frac, maskMCICA, & - overlap_param = cloud_overlap_param(:,1:nLev-1)) - endif - - ! - ! Sampling. Map band optical depth to each g-point using McICA - ! - call check_error_msg('rrtmgp_lw_cloud_sampling_run_draw_samples',& - draw_samples(maskMCICA, .true., & - lw_optical_props_cloudsByBand, & - lw_optical_props_clouds)) - - end subroutine rrtmgp_lw_cloud_sampling_run - - ! ######################################################################################### - ! SUBROTUINE rrtmgp_lw_cloud_sampling_finalize() - ! ######################################################################################### - subroutine rrtmgp_lw_cloud_sampling_finalize() - end subroutine rrtmgp_lw_cloud_sampling_finalize - -end module rrtmgp_lw_cloud_sampling diff --git a/physics/rrtmgp_lw_cloud_sampling.meta b/physics/rrtmgp_lw_cloud_sampling.meta deleted file mode 100644 index c1ae9d139..000000000 --- a/physics/rrtmgp_lw_cloud_sampling.meta +++ /dev/null @@ -1,226 +0,0 @@ -[ccpp-table-properties] - name = rrtmgp_lw_cloud_sampling - type = scheme - dependencies = machine.F,mersenne_twister.f,rrtmgp_sampling.F90,radiation_tools.F90 - -###################################################### -[ccpp-arg-table] - name = rrtmgp_lw_cloud_sampling_run - type = scheme -[doLWrad] - standard_name = flag_for_calling_longwave_radiation - long_name = logical flags for lw radiation calls - units = flag - dimensions = () - type = logical - intent = in -[imfdeepcnv] - standard_name = control_for_deep_convection_scheme - long_name = flag for mass-flux deep convection scheme - units = flag - dimensions = () - type = integer - intent = in -[imfdeepcnv_gf] - standard_name = identifier_for_grell_freitas_deep_convection - long_name = flag for Grell-Freitas deep convection scheme - units = flag - dimensions = () - type = integer - intent = in -[imfdeepcnv_samf] - standard_name = identifer_for_scale_aware_mass_flux_deep_convection - long_name = flag for SAMF deep convection scheme - units = flag - dimensions = () - type = integer - intent = in -[iovr_convcld] - standard_name = flag_for_convective_cloud_overlap_method_for_radiation - long_name = flag for convective cloud overlap method - units = flag - dimensions = () - type = integer - intent = in -[ncol] - standard_name = horizontal_loop_extent - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in -[nLev] - standard_name = vertical_layer_dimension - long_name = number of vertical levels - units = count - dimensions = () - type = integer - intent = in -[isubc_lw] - standard_name = flag_for_lw_clouds_sub_grid_approximation - long_name = flag for lw clouds sub-grid approximation - units = flag - dimensions = () - type = integer - intent = in -[iovr] - standard_name = flag_for_cloud_overlap_method_for_radiation - long_name = max-random overlap clouds - units = flag - dimensions = () - type = integer - intent = in -[iovr_maxrand] - standard_name = flag_for_maximum_random_cloud_overlap_method - long_name = choice of maximum-random cloud overlap method - units = flag - dimensions = () - type = integer - intent = in -[iovr_dcorr] - standard_name = flag_for_decorrelation_length_cloud_overlap_method - long_name = choice of decorrelation-length cloud overlap method - units = flag - dimensions = () - type = integer - intent = in -[iovr_exp] - standard_name = flag_for_exponential_cloud_overlap_method - long_name = choice of exponential cloud overlap method - units = flag - dimensions = () - type = integer - intent = in -[iovr_exprand] - standard_name = flag_for_exponential_random_cloud_overlap_method - long_name = choice of exponential-random cloud overlap method - units = flag - dimensions = () - type = integer - intent = in -[iovr_rand] - standard_name = flag_for_random_cloud_overlap_method - long_name = choice of random cloud overlap method - units = flag - dimensions = () - type = integer - intent = in -[iovr_max] - standard_name = flag_for_maximum_cloud_overlap_method - long_name = choice of maximum cloud overlap method - units = flag - dimensions = () - type = integer - intent = in -[icseed_lw] - standard_name = random_number_seed_for_mcica_longwave - long_name = seed for random number generation for longwave radiation - units = none - dimensions = (horizontal_loop_extent) - type = integer - intent = in -[cld_frac] - standard_name = total_cloud_fraction - long_name = layer total cloud fraction - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_cnv_frac] - standard_name = convective_cloud_fraction_for_RRTMGP - long_name = layer convective cloud fraction - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[precip_frac] - standard_name = precipitation_fraction_by_layer - long_name = precipitation fraction in each layer - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cloud_overlap_param] - standard_name = cloud_overlap_param - long_name = cloud overlap parameter - units = km - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cnv_cloud_overlap_param] - standard_name = convective_cloud_overlap_param - long_name = convective cloud overlap parameter - units = km - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[precip_overlap_param] - standard_name = precip_overlap_param - long_name = precipitation overlap parameter - units = km - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[lw_optical_props_cloudsByBand] - standard_name = longwave_optical_properties_for_cloudy_atmosphere_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = in -[lw_optical_props_cnvcloudsByBand] - standard_name = longwave_optical_properties_for_convective_cloudy_atmosphere_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = in -[lw_optical_props_precipByBand] - standard_name = longwave_optical_properties_for_precipitation_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = in -[lw_optical_props_clouds] - standard_name = longwave_optical_properties_for_cloudy_atmosphere - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = inout -[lw_optical_props_precip] - standard_name = longwave_optical_properties_for_precipitation - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = inout -[lw_optical_props_cnvclouds] - standard_name = longwave_optical_properties_for_convective_cloudy_atmosphere - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = inout -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out diff --git a/physics/rrtmgp_lw_gas_optics.meta b/physics/rrtmgp_lw_gas_optics.meta deleted file mode 100644 index a7ca8aacb..000000000 --- a/physics/rrtmgp_lw_gas_optics.meta +++ /dev/null @@ -1,101 +0,0 @@ -[ccpp-table-properties] - name = rrtmgp_lw_gas_optics - type = scheme - dependencies = machine.F,radiation_tools.F90,GFS_rrtmgp_pre.F90,rte-rrtmgp/rrtmgp/mo_gas_optics_rrtmgp.F90,rte-rrtmgp/rte/mo_rte_kind.F90,rte-rrtmgp/rrtmgp/mo_gas_concentrations.F90,rte-rrtmgp/rte/mo_optical_props.F90,rte-rrtmgp/rte/mo_source_functions.F90 - -######################################################################## -[ccpp-arg-table] - name = rrtmgp_lw_gas_optics_init - type = scheme -[rrtmgp_root_dir] - standard_name = directory_for_rte_rrtmgp_source_code - long_name = directory for rte+rrtmgp source code - units = none - dimensions = () - type = character - intent = in - kind = len=128 -[rrtmgp_lw_file_gas] - standard_name = filename_of_rrtmgp_longwave_k_distribution - long_name = file containing RRTMGP LW k-distribution - units = none - dimensions = () - type = character - intent = in - kind = len=128 -[mpirank] - standard_name = mpi_rank - long_name = current MPI rank - units = index - dimensions = () - type = integer - intent = in -[mpiroot] - standard_name = mpi_root - long_name = master MPI rank - units = index - dimensions = () - type = integer - intent = in -[mpicomm] - standard_name = mpi_communicator - long_name = MPI communicator - units = index - dimensions = () - type = integer - intent = in -[minGPpres] - standard_name = minimum_pressure_in_RRTMGP - long_name = minimum pressure allowed in RRTMGP - units = Pa - dimensions = () - type = real - kind = kind_phys - intent = out -[maxGPpres] - standard_name = maximum_pressure_in_RRTMGP - long_name = maximum pressure allowed in RRTMGP - units = Pa - dimensions = () - type = real - kind = kind_phys - intent = out -[minGPtemp] - standard_name = minimum_temperature_in_RRTMGP - long_name = minimum temperature allowed in RRTMGP - units = K - dimensions = () - type = real - kind = kind_phys - intent = out -[maxGPtemp] - standard_name = maximum_temperature_in_RRTMGP - long_name = maximum temperature allowed in RRTMGP - units = K - dimensions = () - type = real - kind = kind_phys - intent = out -[active_gases_array] - standard_name = list_of_active_gases_used_by_RRTMGP - long_name = list of active gases used by RRTMGP - units = none - dimensions = (number_of_active_gases_used_by_RRTMGP) - type = character - kind = len=* - intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out diff --git a/physics/rrtmgp_lw_main.F90 b/physics/rrtmgp_lw_main.F90 index ce1b767b0..0b55d9831 100644 --- a/physics/rrtmgp_lw_main.F90 +++ b/physics/rrtmgp_lw_main.F90 @@ -87,11 +87,11 @@ end subroutine rrtmgp_lw_main_init subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, use_LW_jacobian,& doGP_sgs_cnv, doGP_sgs_pbl, nCol, nLay, nGases, nGauss_angles, i_o3, icseed_lw, iovr,& iovr_convcld, iovr_max, iovr_maxrand, iovr_rand, iovr_dcorr, iovr_exp, iovr_exprand, & - isubc_lw, tsfg, p_lay, p_lev, t_lay, t_lev, vmr_o2, vmr_h2o, vmr_o3, vmr_ch4, & + isubc_lw, semis, tsfg, p_lay, p_lev, t_lay, t_lev, vmr_o2, vmr_h2o, vmr_o3, vmr_ch4, & vmr_n2o, vmr_co2, cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, & cld_resnow, cld_rwp, cld_rerain, precip_frac, cld_cnv_lwp, cld_cnv_reliq, & cld_cnv_iwp, cld_cnv_reice, cld_pbl_lwp, cld_pbl_reliq, cld_pbl_iwp, cld_pbl_reice, & - cloud_overlap_param, sfc_emiss_byband, active_gases_array, lw_optical_props_aerosol, & + cloud_overlap_param, active_gases_array, lw_optical_props_aerosol, & fluxlwUP_allsky, fluxlwDOWN_allsky, fluxlwUP_clrsky, fluxlwDOWN_clrsky, fluxlwUP_jac,& fluxlwUP_radtime, fluxlwDOWN_radtime, errmsg, errflg) @@ -122,7 +122,8 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, use_LW integer,intent(in),dimension(:) :: & icseed_lw ! Seed for random number generation for longwave radiation real(kind_phys), dimension(:), intent(in) :: & - tsfg ! + semis, & ! Surface-emissivity + tsfg ! real(kind_phys), dimension(:,:), intent(in) :: & p_lay, & ! Pressure @ model layer-centers (Pa) t_lay, & ! Temperature (K) @@ -152,8 +153,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, use_LW cld_pbl_reliq, & ! Effective radius for SGS PBL liquid cloud-particles cld_pbl_iwp, & ! Water path for SGS PBL ice cloud-particles cld_pbl_reice, & ! Effective radius for SGS PBL ice cloud-particles - cloud_overlap_param, & ! - sfc_emiss_byband ! Surface emissivity in each band + cloud_overlap_param character(len=*), dimension(:), intent(in) :: & active_gases_array ! List of active gases from namelist as array type(ty_optical_props_1scl),intent(inout) :: & @@ -199,6 +199,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, use_LW real(kind_phys), dimension(1,nLay+1,lw_gas_props%get_nband()),target :: & fluxLW_up_allsky, fluxLW_up_clrsky, fluxLW_dn_allsky, fluxLW_dn_clrsky real(kind_phys), dimension(1,lw_gas_props%get_ngpt()) :: lw_Ds + real(kind_phys), dimension(lw_gas_props%get_nband(),1) :: sfc_emiss_byband ! Initialize CCPP error handling variables errmsg = '' @@ -257,10 +258,13 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, use_LW do iCol=1,nCol ! Initialize/reset lw_optical_props_clrsky%tau = 0._kind_phys + lw_optical_props_precipByBand%tau = 0._kind_phys + lw_optical_props_cloudsByBand%tau = 0._kind_phys lw_optical_props_clouds%tau = 0._kind_phys lw_optical_props_clouds%ssa = 1._kind_phys lw_optical_props_clouds%g = 0._kind_phys - lw_optical_props_precipByBand%tau = 0._kind_phys + if (doGP_sgs_cnv) lw_optical_props_cnvcloudsByBand%tau = 0._kind_phys + if (doGP_sgs_pbl) lw_optical_props_pblcloudsByBand%tau = 0._kind_phys ! ################################################################################### ! @@ -274,6 +278,20 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, use_LW gas_concentrations%concs(istr_h2o)%conc(1,:) = vmr_h2o(iCol,:) gas_concentrations%concs(istr_o3)%conc(1,:) = vmr_o3(iCol,:) + ! ################################################################################### + ! + ! Surface emissity in each band + ! + ! ################################################################################### + ! Assign same emissivity to all band + if (semis(iCol) > 1e-6 .and. semis(iCol) <= 1.0) then + do iBand=1,lw_gas_props%get_nband() + sfc_emiss_byband(iBand,1) = semis(iCol) + enddo + else + sfc_emiss_byband(1:lw_gas_props%get_nband(),1) = 1.0 + endif + ! ################################################################################### ! ! Gas-optics @@ -316,7 +334,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, use_LW endif ! MYNN PBL cloud-optics? - if (doGP_sgs_cnv) then + if (doGP_sgs_pbl) then call check_error_msg('rrtmgp_lw_main_pbl_cloud_optics',lw_cloud_props%cloud_optics(& cld_pbl_lwp(iCol:iCol,:), & ! IN - MYNN-EDMF PBL cloud liquid water path (g/m2) cld_pbl_iwp(iCol:iCol,:), & ! IN - MYNN-EDMF PBL cloud ice water path (g/m2) @@ -417,7 +435,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, use_LW lw_optical_props_clrsky, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag sources, & ! IN - source function - sfc_emiss_byband(:,iCol:iCol), & ! IN - surface emissivity in each LW band + sfc_emiss_byband, & ! IN - surface emissivity in each LW band flux_clrsky, & ! OUT - Fluxes n_gauss_angles = nGauss_angles)) ! IN - Number of angles in Gaussian quadrature else @@ -425,7 +443,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, use_LW lw_optical_props_clrsky, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag sources, & ! IN - source function - sfc_emiss_byband(:,iCol:iCol), & ! IN - surface emissivity in each LW band + sfc_emiss_byband, & ! IN - surface emissivity in each LW band flux_clrsky, & ! OUT - Fluxes lw_Ds = lw_Ds)) endif @@ -472,7 +490,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, use_LW lw_optical_props_clouds, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag sources, & ! IN - source function - sfc_emiss_byband(:,iCol:iCol), & ! IN - surface emissivity in each LW band + sfc_emiss_byband, & ! IN - surface emissivity in each LW band flux_allsky, & ! OUT - Flxues n_gauss_angles = nGauss_angles, & ! IN - Number of angles in Gaussian quadrature flux_up_Jac = fluxlwUP_jac)) ! OUT - surface temperature flux (upward) Jacobian (W/m2/K) @@ -481,7 +499,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, use_LW lw_optical_props_clouds, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag sources, & ! IN - source function - sfc_emiss_byband(:,iCol:iCol), & ! IN - surface emissivity in each LW band + sfc_emiss_byband, & ! IN - surface emissivity in each LW band flux_allsky, & ! OUT - Flxues n_gauss_angles = nGauss_angles)) ! IN - Number of angles in Gaussian quadrature end if @@ -497,7 +515,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, use_LW lw_optical_props_clrsky, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag sources, & ! IN - source function - sfc_emiss_byband(:,iCol:iCol), & ! IN - surface emissivity in each LW band + sfc_emiss_byband, & ! IN - surface emissivity in each LW band flux_allsky, & ! OUT - Flxues n_gauss_angles = nGauss_angles, & ! IN - Number of angles in Gaussian quadrature flux_up_Jac = fluxlwUP_jac)) ! OUT - surface temperature flux (upward) Jacobian (W/m2/K) @@ -506,7 +524,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, use_LW lw_optical_props_clrsky, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag sources, & ! IN - source function - sfc_emiss_byband(:,iCol:iCol), & ! IN - surface emissivity in each LW band + sfc_emiss_byband, & ! IN - surface emissivity in each LW band flux_allsky, & ! OUT - Flxues n_gauss_angles = nGauss_angles)) ! IN - Number of angles in Gaussian quadrature end if diff --git a/physics/rrtmgp_lw_main.meta b/physics/rrtmgp_lw_main.meta index 6f10b8504..ad0b88c86 100644 --- a/physics/rrtmgp_lw_main.meta +++ b/physics/rrtmgp_lw_main.meta @@ -299,6 +299,14 @@ dimensions = (horizontal_loop_extent) type = integer intent = in +[semis] + standard_name = surface_longwave_emissivity + long_name = surface lw emissivity in fraction + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [tsfg] standard_name = surface_ground_temperature_for_radiation long_name = surface ground temperature for radiation @@ -539,14 +547,6 @@ type = real kind = kind_phys intent = in -[sfc_emiss_byband] - standard_name = surface_emissivity_in_each_RRTMGP_LW_band - long_name = surface emissivity in each RRTMGP LW band - units = none - dimensions = (number_of_longwave_bands,horizontal_loop_extent) - type = real - kind = kind_phys - intent = in [active_gases_array] standard_name = list_of_active_gases_used_by_RRTMGP long_name = list of active gases used by RRTMGP diff --git a/physics/rrtmgp_lw_pre.F90 b/physics/rrtmgp_lw_pre.F90 deleted file mode 100644 index d33a4e52c..000000000 --- a/physics/rrtmgp_lw_pre.F90 +++ /dev/null @@ -1,64 +0,0 @@ -module rrtmgp_lw_pre - use machine, only: & - kind_phys ! Working type - use mo_gas_optics_rrtmgp, only: & - ty_gas_optics_rrtmgp - use rrtmgp_lw_gas_optics, only: lw_gas_props - - implicit none - - public rrtmgp_lw_pre_run,rrtmgp_lw_pre_init,rrtmgp_lw_pre_finalize - -contains - - ! ######################################################################################### - ! SUBROUTINE rrtmgp_lw_pre_init - ! ######################################################################################### - subroutine rrtmgp_lw_pre_init () - end subroutine rrtmgp_lw_pre_init - - ! ######################################################################################### - ! SUBROUTINE rrtmgp_lw_pre_run - ! ######################################################################################### -!> \section arg_table_rrtmgp_lw_pre_run -!! \htmlinclude rrtmgp_lw_pre_run.html -!! - subroutine rrtmgp_lw_pre_run (doLWrad, semis, sfc_emiss_byband, errmsg, errflg) - - ! Inputs - logical, intent(in) :: & - doLWrad - real(kind_phys), dimension(:), intent(in) :: & - semis - - ! Outputs - real(kind_phys), dimension(:,:), intent(inout) :: & - sfc_emiss_byband ! Surface emissivity in each band - character(len=*), intent(out) :: & - errmsg ! Error message - integer, intent(out) :: & - errflg ! Error flag - - ! Local variables - integer :: iBand - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (.not. doLWrad) return - - ! Assign same emissivity to all bands - do iBand=1,lw_gas_props%get_nband() - sfc_emiss_byband(iBand,:) = semis - enddo - - end subroutine rrtmgp_lw_pre_run - - ! ######################################################################################### - ! SUBROUTINE rrtmgp_lw_pre_finalize - ! ######################################################################################### - subroutine rrtmgp_lw_pre_finalize () - end subroutine rrtmgp_lw_pre_finalize - -end module rrtmgp_lw_pre diff --git a/physics/rrtmgp_lw_pre.meta b/physics/rrtmgp_lw_pre.meta deleted file mode 100644 index aa2a06a0f..000000000 --- a/physics/rrtmgp_lw_pre.meta +++ /dev/null @@ -1,47 +0,0 @@ -[ccpp-table-properties] - name = rrtmgp_lw_pre - type = scheme - dependencies = iounitdef.f,machine.F - -######################################################################## -[ccpp-arg-table] - name = rrtmgp_lw_pre_run - type = scheme -[doLWrad] - standard_name = flag_for_calling_longwave_radiation - long_name = logical flags for lw radiation calls - units = flag - dimensions = () - type = logical - intent = in -[semis] - standard_name = surface_longwave_emissivity - long_name = surface lw emissivity in fraction - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[sfc_emiss_byband] - standard_name = surface_emissivity_in_each_RRTMGP_LW_band - long_name = surface emissivity in each RRTMGP LW band - units = none - dimensions = (number_of_longwave_bands,horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out diff --git a/physics/rrtmgp_lw_rte.F90 b/physics/rrtmgp_lw_rte.F90 deleted file mode 100644 index a141a4e08..000000000 --- a/physics/rrtmgp_lw_rte.F90 +++ /dev/null @@ -1,213 +0,0 @@ -! ########################################################################################### -! ########################################################################################### -module rrtmgp_lw_rte - use machine, only: kind_phys - use mo_optical_props, only: ty_optical_props_1scl, ty_optical_props_2str - use mo_rte_lw, only: rte_lw - use mo_fluxes_byband, only: ty_fluxes_byband - use mo_source_functions, only: ty_source_func_lw - use radiation_tools, only: check_error_msg - use rrtmgp_lw_gas_optics, only: lw_gas_props - implicit none - - public rrtmgp_lw_rte_init, rrtmgp_lw_rte_run, rrtmgp_lw_rte_finalize -contains - - ! ######################################################################################### - ! SUBROUTINE rrtmgp_lw_rte_init - ! ######################################################################################### - subroutine rrtmgp_lw_rte_init() - end subroutine rrtmgp_lw_rte_init - - ! ######################################################################################### - ! SUBROUTINE rrtmgp_lw_rte_run - ! ######################################################################################### -!! \section arg_table_rrtmgp_lw_rte_run -!! \htmlinclude rrtmgp_lw_rte_run.html -!! - subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, nCol, & - nLev, top_at_1, doGP_sgs_cnv, doGP_sgs_mynn, sfc_emiss_byband, sources, & - lw_optical_props_clrsky, lw_optical_props_clouds, lw_optical_props_precipByBand, & - lw_optical_props_cnvcloudsByBand, lw_optical_props_MYNNcloudsByBand, & - lw_optical_props_aerosol, nGauss_angles, fluxlwUP_allsky, fluxlwDOWN_allsky, & - fluxlwUP_clrsky, fluxlwDOWN_clrsky, fluxlwUP_jac, fluxlwUP_radtime, & - fluxlwDOWN_radtime, errmsg, errflg) - - ! Inputs - logical, intent(in) :: & - top_at_1, & ! Vertical ordering flag - doLWrad, & ! Logical flag for longwave radiation call - doLWclrsky, & ! Compute clear-sky fluxes for clear-sky heating-rate? - use_LW_jacobian, & ! Compute Jacobian of LW to update radiative fluxes between radiation calls? - doGP_sgs_mynn, & ! Flag for sgs MYNN-EDMF PBL cloud scheme - doGP_sgs_cnv, & ! Flagg for sgs convective cloud scheme - doGP_lwscat ! Include scattering in LW cloud-optics? - integer, intent(in) :: & - nCol, & ! Number of horizontal gridpoints - nLev, & ! Number of vertical levels - nGauss_angles ! Number of angles used in Gaussian quadrature - real(kind_phys), dimension(:,:), intent(in) :: & - sfc_emiss_byband ! Surface emissivity in each band - type(ty_source_func_lw),intent(in) :: & - sources ! RRTMGP DDT: longwave source functions - type(ty_optical_props_1scl),intent(inout) :: & - lw_optical_props_aerosol, &! RRTMGP DDT: longwave aerosol optical properties - lw_optical_props_clrsky ! RRTMGP DDT: longwave clear-sky optical properties - type(ty_optical_props_2str),intent(inout) :: & - lw_optical_props_clouds, & ! RRTMGP DDT: longwave cloud optical properties - lw_optical_props_precipByBand, & ! RRTMGP DDT: longwave precipitation optical properties - lw_optical_props_cnvcloudsByBand, & ! RRTMGP DDT: longwave convective cloud optical properties - lw_optical_props_MYNNcloudsByBand ! RRTMGP DDT: longwave MYNN-EDMF PBL cloud optical properties - ! Outputs - real(kind_phys), dimension(:,:), intent(inout) :: & - fluxlwUP_jac, & ! Jacobian of upwelling LW surface radiation (W/m2/K) - fluxlwUP_allsky, & ! All-sky flux (W/m2) - fluxlwDOWN_allsky, & ! All-sky flux (W/m2) - fluxlwUP_clrsky, & ! Clear-sky flux (W/m2) - fluxlwDOWN_clrsky, & ! All-sky flux (W/m2) - fluxlwUP_radtime, & ! Copy of fluxes (Used for coupling) - fluxlwDOWN_radtime - character(len=*), intent(out) :: & - errmsg ! CCPP error message - integer, intent(out) :: & - errflg ! CCPP error flag - - ! Local variables - type(ty_fluxes_byband) :: & - flux_allsky, flux_clrsky - real(kind_phys), dimension(ncol,nLev+1,lw_gas_props%get_nband()),target :: & - fluxLW_up_allsky, fluxLW_up_clrsky, fluxLW_dn_allsky, fluxLW_dn_clrsky - real(kind_phys), dimension(nCol,lw_gas_props%get_ngpt()) :: lw_Ds - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (.not. doLWrad) return - - ! Initialize RRTMGP DDT containing 2D(3D) fluxes - flux_allsky%bnd_flux_up => fluxLW_up_allsky - flux_allsky%bnd_flux_dn => fluxLW_dn_allsky - flux_clrsky%bnd_flux_up => fluxLW_up_clrsky - flux_clrsky%bnd_flux_dn => fluxLW_dn_clrsky - - ! - ! Compute clear-sky fluxes (if requested) - ! - ! Add aerosol optics to gas optics - call check_error_msg('rrtmgp_lw_rte_run',lw_optical_props_aerosol%increment(lw_optical_props_clrsky)) - - ! Call RTE solver - if (doLWclrsky) then - call check_error_msg('rrtmgp_lw_rte_run_opt_angle',lw_gas_props%compute_optimal_angles(lw_optical_props_clrsky,lw_Ds)) - if (nGauss_angles .gt. 1) then - call check_error_msg('rrtmgp_lw_rte_run',rte_lw( & - lw_optical_props_clrsky, & ! IN - optical-properties - top_at_1, & ! IN - veritcal ordering flag - sources, & ! IN - source function - sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_clrsky, & ! OUT - Fluxes - n_gauss_angles = nGauss_angles)) ! IN - Number of angles in Gaussian quadrature - else - call check_error_msg('rrtmgp_lw_rte_run',rte_lw( & - lw_optical_props_clrsky, & ! IN - optical-properties - top_at_1, & ! IN - veritcal ordering flag - sources, & ! IN - source function - sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_clrsky, & ! OUT - Fluxes - lw_Ds = lw_Ds)) - endif - - ! Store fluxes - fluxlwUP_clrsky = sum(flux_clrsky%bnd_flux_up,dim=3) - fluxlwDOWN_clrsky = sum(flux_clrsky%bnd_flux_dn,dim=3) - else - fluxlwUP_clrsky = 0.0 - fluxlwDOWN_clrsky = 0.0 - endif - - ! - ! All-sky fluxes (clear-sky + clouds + precipitation) - ! - - ! Include convective cloud? - if (doGP_sgs_cnv) then - call check_error_msg('rrtmgp_lw_rte_run',lw_optical_props_cnvcloudsByBand%increment(lw_optical_props_clrsky)) - endif - - ! Include MYNN-EDMF PBL clouds? - if (doGP_sgs_mynn) then - call check_error_msg('rrtmgp_lw_rte_run',lw_optical_props_MYNNcloudsByBand%increment(lw_optical_props_clrsky)) - endif - - ! Add in precipitation - call check_error_msg('rrtmgp_lw_rte_run',lw_optical_props_precipByBand%increment(lw_optical_props_clouds)) - - ! Include LW cloud-scattering? - if (doGP_lwscat) then - ! Add clear-sky optics to cloud-optics (2-stream) - call check_error_msg('rrtmgp_lw_rte_run',lw_optical_props_clrsky%increment(lw_optical_props_clouds)) - - if (use_LW_jacobian) then - ! Compute LW Jacobians - call check_error_msg('rrtmgp_lw_rte_run',rte_lw( & - lw_optical_props_clouds, & ! IN - optical-properties - top_at_1, & ! IN - veritcal ordering flag - sources, & ! IN - source function - sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_allsky, & ! OUT - Flxues - n_gauss_angles = nGauss_angles, & ! IN - Number of angles in Gaussian quadrature - flux_up_Jac = fluxlwUP_jac)) ! OUT - surface temperature flux (upward) Jacobian (W/m2/K) - else - call check_error_msg('rrtmgp_lw_rte_run',rte_lw( & - lw_optical_props_clouds, & ! IN - optical-properties - top_at_1, & ! IN - veritcal ordering flag - sources, & ! IN - source function - sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_allsky, & ! OUT - Flxues - n_gauss_angles = nGauss_angles)) ! IN - Number of angles in Gaussian quadrature - end if - ! No scattering in LW clouds. - else - ! Add cloud optics to clear-sky optics (scalar) - call check_error_msg('rrtmgp_lw_rte_run',lw_optical_props_clouds%increment(lw_optical_props_clrsky)) - - if (use_LW_jacobian) then - ! Compute LW Jacobians - call check_error_msg('rrtmgp_lw_rte_run',rte_lw( & - lw_optical_props_clrsky, & ! IN - optical-properties - top_at_1, & ! IN - veritcal ordering flag - sources, & ! IN - source function - sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_allsky, & ! OUT - Flxues - n_gauss_angles = nGauss_angles, & ! IN - Number of angles in Gaussian quadrature - flux_up_Jac = fluxlwUP_jac)) ! OUT - surface temperature flux (upward) Jacobian (W/m2/K) - else - call check_error_msg('rrtmgp_lw_rte_run',rte_lw( & - lw_optical_props_clrsky, & ! IN - optical-properties - top_at_1, & ! IN - veritcal ordering flag - sources, & ! IN - source function - sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_allsky, & ! OUT - Flxues - n_gauss_angles = nGauss_angles)) ! IN - Number of angles in Gaussian quadrature - end if - endif - - ! Store fluxes - fluxlwUP_allsky = sum(flux_allsky%bnd_flux_up,dim=3) - fluxlwDOWN_allsky = sum(flux_allsky%bnd_flux_dn,dim=3) - - ! Save fluxes for coupling - fluxlwUP_radtime = fluxlwUP_allsky - fluxlwDOWN_radtime = fluxlwDOWN_allsky - - end subroutine rrtmgp_lw_rte_run - - ! ######################################################################################### - ! SUBROUTINE rrtmgp_lw_rte_finalize - ! ######################################################################################### - subroutine rrtmgp_lw_rte_finalize() - end subroutine rrtmgp_lw_rte_finalize - - -end module rrtmgp_lw_rte diff --git a/physics/rrtmgp_lw_rte.meta b/physics/rrtmgp_lw_rte.meta deleted file mode 100644 index 0ad0754b5..000000000 --- a/physics/rrtmgp_lw_rte.meta +++ /dev/null @@ -1,208 +0,0 @@ -[ccpp-table-properties] - name = rrtmgp_lw_rte - type = scheme - dependencies = machine.F,rte-rrtmgp/rte/mo_rte_lw.F90,rte-rrtmgp/rte/mo_fluxes.F90,rte-rrtmgp/rte/kernels/mo_fluxes_broadband_kernels.F90,radiation_tools.F90 - dependencies = rte-rrtmgp/rte/kernels/mo_rte_solver_kernels.F90,rte-rrtmgp/extensions/mo_fluxes_byband.F90 - -######################################################################## -[ccpp-arg-table] - name = rrtmgp_lw_rte_run - type = scheme -[doLWrad] - standard_name = flag_for_calling_longwave_radiation - long_name = logical flags for lw radiation calls - units = flag - dimensions = () - type = logical - intent = in -[doLWclrsky] - standard_name = flag_for_output_of_tendency_of_air_temperature_due_to_longwave_heating_on_radiation_timestep_assuming_clear_sky - long_name = flag to output lw heating rate (Radtend%lwhc) - units = flag - dimensions = () - type = logical - intent = in -[use_LW_jacobian] - standard_name = flag_to_calc_RRTMGP_LW_jacobian - long_name = logical flag to control RRTMGP LW calculation - units = flag - dimensions = () - type = logical - intent = in -[doGP_lwscat] - standard_name = flag_to_include_longwave_scattering_in_cloud_optics - long_name = logical flag to control the addition of LW scattering in RRTMGP - units = flag - dimensions = () - type = logical - intent = in -[doGP_sgs_cnv] - standard_name = flag_to_include_sgs_convective_cloud_in_RRTMGP - long_name = logical flag to control sgs convective cloud in RRTMGP - units = flag - dimensions = () - type = logical - intent = in -[doGP_sgs_mynn] - standard_name = flag_to_include_sgs_MYNN_EDMF_cloud_in_RRTMGP - long_name = logical flag to control MYNN-EDMF PBL cloud in RRTMGP - units = flag - dimensions = () - type = logical - intent = in -[ncol] - standard_name = horizontal_loop_extent - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in -[nLev] - standard_name = vertical_layer_dimension - long_name = number of vertical levels - units = count - dimensions = () - type = integer - intent = in -[nGauss_angles] - standard_name = number_of_gaussian_quadrature_angles_for_radiation - long_name = Number of angles used in Gaussian quadrature - units = count - dimensions = () - type = integer - intent = in -[top_at_1] - standard_name = flag_for_vertical_ordering_in_RRTMGP - long_name = flag for vertical ordering in RRTMGP - units = flag - dimensions = () - type = logical - intent = in -[sfc_emiss_byband] - standard_name = surface_emissivity_in_each_RRTMGP_LW_band - long_name = surface emissivity in each RRTMGP LW band - units = none - dimensions = (number_of_longwave_bands,horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[lw_optical_props_clrsky] - standard_name = longwave_optical_properties_for_clear_sky - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_1scl - intent = inout -[lw_optical_props_clouds] - standard_name = longwave_optical_properties_for_cloudy_atmosphere - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = inout -[lw_optical_props_precipByBand] - standard_name = longwave_optical_properties_for_precipitation_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = inout -[lw_optical_props_cnvcloudsByBand] - standard_name = longwave_optical_properties_for_convective_cloudy_atmosphere_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = inout -[lw_optical_props_MYNNcloudsByBand] - standard_name = longwave_optical_properties_for_MYNN_EDMF_PBL_cloudy_atmosphere_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = inout -[lw_optical_props_aerosol] - standard_name = longwave_optical_properties_for_aerosols - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_1scl - intent = inout -[sources] - standard_name = longwave_source_function - long_name = Fortran DDT containing RRTMGP source functions - units = DDT - dimensions = () - type = ty_source_func_lw - intent = in -[fluxlwUP_radtime] - standard_name = RRTMGP_lw_flux_profile_upward_allsky_on_radiation_timestep - long_name = RRTMGP upward longwave all-sky flux profile - units = W m-2 - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = inout -[fluxlwDOWN_radtime] - standard_name = RRTMGP_lw_flux_profile_downward_allsky_on_radiation_timestep - long_name = RRTMGP downward longwave all-sky flux profile - units = W m-2 - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = inout -[fluxlwUP_allsky] - standard_name = RRTMGP_lw_flux_profile_upward_allsky - long_name = RRTMGP upward longwave all-sky flux profile - units = W m-2 - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = inout -[fluxlwDOWN_allsky] - standard_name = RRTMGP_lw_flux_profile_downward_allsky - long_name = RRTMGP downward longwave all-sky flux profile - units = W m-2 - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = inout -[fluxlwUP_clrsky] - standard_name = RRTMGP_lw_flux_profile_upward_clrsky - long_name = RRTMGP upward longwave clr-sky flux profile - units = W m-2 - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = inout -[fluxlwDOWN_clrsky] - standard_name = RRTMGP_lw_flux_profile_downward_clrsky - long_name = RRTMGP downward longwave clr-sky flux profile - units = W m-2 - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = inout -[fluxlwUP_jac] - standard_name = RRTMGP_jacobian_of_lw_flux_upward - long_name = RRTMGP Jacobian upward longwave flux profile - units = W m-2 K-1 - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = inout -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out diff --git a/physics/rrtmgp_sw_cloud_optics.F90 b/physics/rrtmgp_sw_cloud_optics.F90 index fd648de02..24fafbffe 100644 --- a/physics/rrtmgp_sw_cloud_optics.F90 +++ b/physics/rrtmgp_sw_cloud_optics.F90 @@ -3,7 +3,6 @@ module rrtmgp_sw_cloud_optics use mo_rte_kind, only: wl use mo_cloud_optics, only: ty_cloud_optics use mo_optical_props, only: ty_optical_props_2str - use mo_rrtmg_sw_cloud_optics, only: rrtmg_sw_cloud_optics use rrtmgp_sw_gas_optics, only: sw_gas_props use radiation_tools, only: check_error_msg use netcdf @@ -67,12 +66,9 @@ module rrtmgp_sw_cloud_optics ! ###################################################################################### ! SUBROUTINE sw_cloud_optics_init ! ###################################################################################### -!! \section arg_table_rrtmgp_sw_cloud_optics_init -!! \htmlinclude rrtmgp_lw_cloud_optics.html -!! - subroutine rrtmgp_sw_cloud_optics_init(doG_cldoptics, doGP_cldoptics_PADE, & - doGP_cldoptics_LUT, nrghice, rrtmgp_root_dir, rrtmgp_sw_file_clouds, mpicomm, & - mpirank, mpiroot, errmsg, errflg) + subroutine rrtmgp_sw_cloud_optics_init(nrghice, mpicomm, mpirank, mpiroot, doG_cldoptics, & + doGP_cldoptics_PADE, doGP_cldoptics_LUT, rrtmgp_root_dir, rrtmgp_sw_file_clouds, & + errmsg, errflg) ! Inputs logical, intent(in) :: & @@ -388,183 +384,4 @@ subroutine rrtmgp_sw_cloud_optics_init(doG_cldoptics, doGP_cldoptics_PADE, end subroutine rrtmgp_sw_cloud_optics_init - ! ######################################################################################### - ! SUBROTUINE rrtmgp_sw_cloud_optics_run() - ! ######################################################################################### -!! \section arg_table_rrtmgp_sw_cloud_optics_run -!! \htmlinclude rrtmgp_sw_cloud_optics.html -!! - subroutine rrtmgp_sw_cloud_optics_run(doSWrad, doG_cldoptics, icliq_sw, icice_sw, & - doGP_cldoptics_PADE, doGP_cldoptics_LUT, do_mynnedmf, imfdeepcnv, imfdeepcnv_gf, & - imfdeepcnv_samf, nCol, nLev, nDay, nbndsGPsw, idxday, cld_frac, cld_lwp, cld_reliq, & - cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, cld_rerain, precip_frac, & - cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, cld_cnv_reice, cld_pbl_lwp, cld_pbl_reliq, & - cld_pbl_iwp, cld_pbl_reice, sw_optical_props_cloudsByBand, & - sw_optical_props_cnvcloudsByBand, sw_optical_props_precipByBand, & - sw_optical_props_MYNNcloudsByBand, cldtausw, errmsg, errflg) - - ! Inputs - logical, intent(in) :: & - doSWrad, & ! Logical flag for shortwave radiation call - doG_cldoptics, & ! Use legacy RRTMG cloud-optics? - doGP_cldoptics_PADE, & ! Use RRTMGP cloud-optics: PADE approximation? - doGP_cldoptics_LUT, & ! Use RRTMGP cloud-optics: LUTs? - do_mynnedmf ! - integer, intent(in) :: & - nbndsGPsw, & ! Number of shortwave bands - nCol, & ! Number of horizontal gridpoints - nLev, & ! Number of vertical levels - nday, & ! Number of daylit points. - icliq_sw, & ! Choice of treatment of liquid cloud optical properties (RRTMG legacy) - icice_sw, & ! Choice of treatment of ice cloud optical properties (RRTMG legacy) - imfdeepcnv, & ! - imfdeepcnv_gf, & ! - imfdeepcnv_samf ! - integer,intent(in),dimension(:) :: & - idxday ! Indices for daylit points. - real(kind_phys), dimension(:,:),intent(in) :: & - cld_frac, & ! Total cloud fraction by layer - cld_lwp, & ! Cloud liquid water path - cld_reliq, & ! Cloud liquid effective radius - cld_iwp, & ! Cloud ice water path - cld_reice, & ! Cloud ice effective radius - cld_swp, & ! Cloud snow water path - cld_resnow, & ! Cloud snow effective radius - cld_rwp, & ! Cloud rain water path - cld_rerain, & ! Cloud rain effective radius - precip_frac, & ! Precipitation fraction by layer - cld_cnv_lwp, & ! Water path for convective liquid cloud-particles (microns) - cld_cnv_reliq, & ! Effective radius for convective liquid cloud-particles (microns) - cld_cnv_iwp, & ! Water path for convective ice cloud-particles (microns) - cld_cnv_reice, & ! Effective radius for convective ice cloud-particles (microns) - cld_pbl_lwp, & ! Water path for SGS PBL liquid cloud-particles - cld_pbl_reliq, & ! Effective radius for SGS PBL liquid cloud-particles - cld_pbl_iwp, & ! Water path for SGS PBL ice cloud-particles - cld_pbl_reice ! Effective radius for SGS PBL ice cloud-particles - ! Outputs - character(len=*), intent(out) :: & - errmsg ! CCPP error message - integer, intent(out) :: & - errflg ! CCPP error flag - type(ty_optical_props_2str),intent(out) :: & - sw_optical_props_cloudsByBand, & ! RRTMGP DDT: Shortwave optical properties in each band (clouds) - sw_optical_props_cnvcloudsByBand, & ! RRTMGP DDT: Shortwave optical properties in each band (convective cloud) - sw_optical_props_MYNNcloudsByBand,& ! RRTMGP DDT: Shortwave optical properties in each band (MYNN PBL cloud) - sw_optical_props_precipByBand ! RRTMGP DDT: Shortwave optical properties in each band (cloud precipitation) - real(kind_phys), dimension(:,:), intent(out) :: & - cldtausw ! Approx 10.mu band layer cloud optical depth - - ! Local variables - integer :: iDay, iLay, iBand - real(kind_phys) :: tau_rain, tau_snow, ssa_rain, ssa_snow, asy_rain, asy_snow, & - tau_prec, asy_prec, ssa_prec, asyw, ssaw, za1, za2 - real(kind_phys), dimension(nday,nLev,nbndsGPsw) :: & - tau_cld, ssa_cld, asy_cld, tau_precip, ssa_precip, asy_precip - type(ty_optical_props_2str) :: sw_optical_props_cloudsByBand_daylit - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (.not. doSWrad) return - - ! Only process sunlit points... - if (nDay .gt. 0) then - - ! Compute cloud/precipitation optics. - if (doGP_cldoptics_PADE .or. doGP_cldoptics_LUT) then - ! i) Cloud-optics. - call check_error_msg('rrtmgp_sw_cloud_optics_run - sw_optical_props_cloudsByBand',& - sw_optical_props_cloudsByBand%alloc_2str(nday, nLev, sw_cloud_props%get_band_lims_wavenumber())) - - call check_error_msg('rrtmgp_sw_cloud_optics_run - clouds',sw_cloud_props%cloud_optics(& - cld_lwp(idxday(1:nday),:), & ! IN - Cloud liquid water path - cld_iwp(idxday(1:nday),:), & ! IN - Cloud ice water path - cld_reliq(idxday(1:nday),:), & ! IN - Cloud liquid effective radius - cld_reice(idxday(1:nday),:), & ! IN - Cloud ice effective radius - sw_optical_props_cloudsByBand)) ! OUT - RRTMGP DDT: Shortwave optical properties, - ! in each band (tau,ssa,g) - - ! ii) Convective cloud-optics - if (imfdeepcnv == imfdeepcnv_samf .or. imfdeepcnv == imfdeepcnv_gf) then - call check_error_msg('rrtmgp_sw_cloud_optics_run - sw_optical_props_cnvcloudsByBand',& - sw_optical_props_cnvcloudsByBand%alloc_2str(nday, nLev, sw_cloud_props%get_band_lims_wavenumber())) - - call check_error_msg('rrtmgp_sw_cloud_optics_run - convective clouds',sw_cloud_props%cloud_optics(& - cld_cnv_lwp(idxday(1:nday),:), & ! IN - Convective cloud liquid water path - cld_cnv_iwp(idxday(1:nday),:), & ! IN - Convective cloud ice water path - cld_cnv_reliq(idxday(1:nday),:), & ! IN - Convective cloud liquid effective radius - cld_cnv_reice(idxday(1:nday),:), & ! IN - Convective cloud ice effective radius - sw_optical_props_cnvcloudsByBand)) ! OUT - RRTMGP DDT: Shortwave optical properties, - ! in each band (tau,ssa,g) - endif - - ! iii) MYNN cloud-optics - if (do_mynnedmf) then - call check_error_msg('rrtmgp_sw_cloud_optics_run - sw_optical_props_MYNNcloudsByBand',& - sw_optical_props_MYNNcloudsByBand%alloc_2str(nday, nLev, sw_cloud_props%get_band_lims_wavenumber())) - - call check_error_msg('rrtmgp_sw_MYNNcloud_optics_run - MYNN-EDMF cloud',sw_cloud_props%cloud_optics(& - cld_pbl_lwp(idxday(1:nday),:), & ! IN - MYNN-EDMF PBL cloud liquid water path (g/m2) - cld_pbl_iwp(idxday(1:nday),:), & ! IN - MYNN-EDMF PBL cloud ice water path (g/m2) - cld_pbl_reliq(idxday(1:nday),:), & ! IN - MYNN-EDMF PBL cloud liquid effective radius (microns) - cld_pbl_reice(idxday(1:nday),:), & ! IN - MYNN-EDMF PBL cloud ice effective radius (microns) - sw_optical_props_MYNNcloudsByBand)) ! OUT - RRTMGP DDT containing MYNN-EDMF PBL cloud radiative properties - ! in each band - endif - - ! iv) Cloud precipitation optics: rain and snow(+groupel) - call check_error_msg('rrtmgp_sw_cloud_optics_run - sw_optical_props_precipByBand',& - sw_optical_props_precipByBand%alloc_2str(nday, nLev, sw_cloud_props%get_band_lims_wavenumber())) - sw_optical_props_precipByBand%tau(:,:,:) = 0._kind_phys - sw_optical_props_precipByBand%ssa(:,:,:) = 1._kind_phys - sw_optical_props_precipByBand%g(:,:,:) = 0._kind_phys - - do iDay=1,nDay - do iLay=1,nLev - if (cld_frac(idxday(iDay),iLay) .gt. 1.e-12_kind_phys) then - ! Rain/Snow optical depth (No band dependence) - tau_rain = cld_rwp(idxday(iDay),iLay)*a0r - if (cld_swp(idxday(iDay),iLay) .gt. 0. .and. cld_resnow(idxday(iDay),iLay) .gt. 10._kind_phys) then - tau_snow = cld_swp(idxday(iDay),iLay)*1.09087*(a0s + a1s/(1.0315*cld_resnow(idxday(iDay),iLay))) ! fu's formula - else - tau_snow = 0._kind_phys - endif - - ! Rain/Snow single-scattering albedo and asymmetry (Band dependent) - do iBand=1,nbndsGPsw - ! By species - ssa_rain = tau_rain*(1.-b0r(iBand)) - asy_rain = ssa_rain*c0r(iBand) - ssa_snow = tau_snow*(1.-(b0s(iBand)+b1s(iBand)*1.0315*cld_resnow(idxday(iDay),iLay))) - asy_snow = ssa_snow*c0s(iBand) - ! Combine - tau_prec = max(1.e-12_kind_phys, tau_rain + tau_snow) - ssa_prec = max(1.e-12_kind_phys, ssa_rain + ssa_snow) - asy_prec = max(1.e-12_kind_phys, asy_rain + asy_snow) - asyw = asy_prec/max(1.e-12_kind_phys, ssa_prec) - ssaw = min(1._kind_phys-0.000001, ssa_prec/tau_prec) - za1 = asyw * asyw - za2 = ssaw * za1 - sw_optical_props_precipByBand%tau(iDay,iLay,iBand) = (1._kind_phys - za2) * tau_prec - sw_optical_props_precipByBand%ssa(iDay,iLay,iBand) = (ssaw - za2) / (1._kind_phys - za2) - sw_optical_props_precipByBand%g(iDay,iLay,iBand) = asyw/(1+asyw) - enddo - endif - enddo - enddo - endif - - ! All-sky SW optical depth ~0.55microns (DJS asks: Move to cloud diagnostics?) - cldtausw(idxday(1:nDay),:) = sw_optical_props_cloudsByBand%tau(:,:,11) - endif - - end subroutine rrtmgp_sw_cloud_optics_run - - ! ######################################################################################### - ! SUBROTUINE rrtmgp_sw_cloud_optics_finalize() - ! ######################################################################################### - subroutine rrtmgp_sw_cloud_optics_finalize() - end subroutine rrtmgp_sw_cloud_optics_finalize - end module rrtmgp_sw_cloud_optics diff --git a/physics/rrtmgp_sw_cloud_optics.meta b/physics/rrtmgp_sw_cloud_optics.meta deleted file mode 100644 index 064b7cf80..000000000 --- a/physics/rrtmgp_sw_cloud_optics.meta +++ /dev/null @@ -1,393 +0,0 @@ -[ccpp-table-properties] - name = rrtmgp_sw_cloud_optics - type = scheme - dependencies = machine.F,rrtmg_sw_cloud_optics.F90,radiation_tools.F90 - -######################################################################## -[ccpp-arg-table] - name = rrtmgp_sw_cloud_optics_init - type = scheme -[doG_cldoptics] - standard_name = flag_to_calc_lw_cld_optics_using_RRTMG - long_name = logical flag to control cloud optics scheme. - units = flag - dimensions = () - type = logical - intent = in -[doGP_cldoptics_PADE] - standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_PADE - long_name = logical flag to control cloud optics scheme. - units = flag - dimensions = () - type = logical - intent = in -[doGP_cldoptics_LUT] - standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_LUT - long_name = logical flag to control cloud optics scheme. - units = flag - dimensions = () - type = logical - intent = in -[nrghice] - standard_name = number_of_ice_roughness_categories - long_name = number of ice-roughness categories in RRTMGP calculation - units = count - dimensions = () - type = integer - intent = inout -[rrtmgp_root_dir] - standard_name = directory_for_rte_rrtmgp_source_code - long_name = directory for rte+rrtmgp source code - units = none - dimensions = () - type = character - intent = in - kind = len=128 -[rrtmgp_sw_file_clouds] - standard_name = filename_of_rrtmgp_shortwave_cloud_optics_coefficients - long_name = file containing coefficients for RRTMGP SW cloud optics - units = none - dimensions = () - type = character - intent = in - kind = len=128 -[mpirank] - standard_name = mpi_rank - long_name = current MPI rank - units = index - dimensions = () - type = integer - intent = in -[mpiroot] - standard_name = mpi_root - long_name = master MPI rank - units = index - dimensions = () - type = integer - intent = in -[mpicomm] - standard_name = mpi_communicator - long_name = MPI communicator - units = index - dimensions = () - type = integer - intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out -######################################################################## -[ccpp-arg-table] - name = rrtmgp_sw_cloud_optics_run - type = scheme -[doSWrad] - standard_name = flag_for_calling_shortwave_radiation - long_name = logical flags for sw radiation calls - units = flag - dimensions = () - type = logical - intent = in -[ncol] - standard_name = horizontal_loop_extent - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in -[nLev] - standard_name = vertical_layer_dimension - long_name = number of vertical levels - units = count - dimensions = () - type = integer - intent = in -[doG_cldoptics] - standard_name = flag_to_calc_lw_cld_optics_using_RRTMG - long_name = logical flag to control cloud optics scheme. - units = flag - dimensions = () - type = logical - intent = in -[icliq_sw] - standard_name = control_for_shortwave_radiation_liquid_clouds - long_name = sw optical property for liquid clouds - units = flag - dimensions = () - type = integer - intent = in -[icice_sw] - standard_name = flag_for_optical_property_for_ice_clouds_for_shortwave_radiation - long_name = sw optical property for ice clouds - units = flag - dimensions = () - type = integer - intent = in -[doGP_cldoptics_PADE] - standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_PADE - long_name = logical flag to control cloud optics scheme. - units = flag - dimensions = () - type = logical - intent = in -[doGP_cldoptics_LUT] - standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_LUT - long_name = logical flag to control cloud optics scheme. - units = flag - dimensions = () - type = logical - intent = in -[do_mynnedmf] - standard_name = flag_for_mellor_yamada_nakanishi_niino_pbl_scheme - long_name = flag to activate MYNN-EDMF - units = flag - dimensions = () - type = logical - intent = in -[imfdeepcnv] - standard_name = control_for_deep_convection_scheme - long_name = flag for mass-flux deep convection scheme - units = flag - dimensions = () - type = integer - intent = in -[imfdeepcnv_gf] - standard_name = identifier_for_grell_freitas_deep_convection - long_name = flag for Grell-Freitas deep convection scheme - units = flag - dimensions = () - type = integer - intent = in -[imfdeepcnv_samf] - standard_name = identifer_for_scale_aware_mass_flux_deep_convection - long_name = flag for SAMF deep convection scheme - units = flag - dimensions = () - type = integer - intent = in -[cld_frac] - standard_name = total_cloud_fraction - long_name = layer total cloud fraction - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_lwp] - standard_name = cloud_liquid_water_path - long_name = layer cloud liquid water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_reliq] - standard_name = mean_effective_radius_for_liquid_cloud - long_name = mean effective radius for liquid cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_iwp] - standard_name = cloud_ice_water_path - long_name = layer cloud ice water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_reice] - standard_name = mean_effective_radius_for_ice_cloud - long_name = mean effective radius for ice cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_swp] - standard_name = cloud_snow_water_path - long_name = layer cloud snow water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_resnow] - standard_name = mean_effective_radius_for_snow_flake - long_name = mean effective radius for snow cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_rwp] - standard_name = cloud_rain_water_path - long_name = layer cloud rain water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_rerain] - standard_name = mean_effective_radius_for_rain_drop - long_name = mean effective radius for rain cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[precip_frac] - standard_name = precipitation_fraction_by_layer - long_name = precipitation fraction in each layer - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_cnv_lwp] - standard_name = convective_cloud_liquid_water_path - long_name = layer convective cloud liquid water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_cnv_iwp] - standard_name = convective_cloud_ice_water_path - long_name = layer convective cloud ice water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_cnv_reliq] - standard_name = mean_effective_radius_for_liquid_convective_cloud - long_name = mean effective radius for liquid convective cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_cnv_reice] - standard_name = mean_effective_radius_for_ice_convective_cloud - long_name = mean effective radius for ice convective cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_pbl_lwp] - standard_name = MYNN_SGS_cloud_liquid_water_path - long_name = layer convective cloud liquid water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_pbl_iwp] - standard_name = MYNN_SGS_cloud_ice_water_path - long_name = layer convective cloud ice water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_pbl_reliq] - standard_name = mean_effective_radius_for_liquid_MYNN_SGS_cloud - long_name = mean effective radius for liquid MYNN_SGS cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_pbl_reice] - standard_name = mean_effective_radius_for_ice_MYNN_SGS_cloud - long_name = mean effective radius for ice MYNN_SGS cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[nbndsGPsw] - standard_name = number_of_shortwave_bands - long_name = number of sw bands used in RRTMGP - units = count - dimensions = () - type = integer - intent = in -[nday] - standard_name = daytime_points_dimension - long_name = daytime points dimension - units = count - dimensions = () - type = integer - intent = in -[idxday] - standard_name = daytime_points - long_name = daytime points - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = in -[sw_optical_props_cloudsByBand] - standard_name = shortwave_optical_properties_for_cloudy_atmosphere_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = out -[sw_optical_props_cnvcloudsByBand] - standard_name = shortwave_optical_properties_for_convective_cloudy_atmosphere_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = out -[sw_optical_props_precipByBand] - standard_name = shortwave_optical_properties_for_precipitation_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = out -[sw_optical_props_MYNNcloudsByBand] - standard_name = shortwave_optical_properties_for_MYNN_EDMF_PBL_cloudy_atmosphere_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = out -[cldtausw] - standard_name = cloud_optical_depth_layers_at_0p55mu_band - long_name = approx .55mu band layer cloud optical depth - units = none - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out diff --git a/physics/rrtmgp_sw_cloud_sampling.F90 b/physics/rrtmgp_sw_cloud_sampling.F90 deleted file mode 100644 index c4a5de4c8..000000000 --- a/physics/rrtmgp_sw_cloud_sampling.F90 +++ /dev/null @@ -1,170 +0,0 @@ -module rrtmgp_sw_cloud_sampling - use machine, only: kind_phys - use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp - use mo_optical_props, only: ty_optical_props_2str - use rrtmgp_sampling, only: sampled_mask, draw_samples - use mersenne_twister, only: random_setseed, random_number, random_stat - use radiation_tools, only: check_error_msg - use rrtmgp_sw_gas_optics, only: sw_gas_props - use netcdf - - implicit none - -contains - - ! ######################################################################################### - ! SUBROTUINE rrtmgp_sw_cloud_sampling_run() - ! ######################################################################################### -!! \section arg_table_rrtmgp_sw_cloud_sampling_run -!! \htmlinclude rrtmgp_sw_cloud_sampling.html -!! - subroutine rrtmgp_sw_cloud_sampling_run(doSWrad, nCol, nDay, nLev, idxday, iovr, & - iovr_convcld, iovr_max, iovr_maxrand, iovr_rand, iovr_dcorr, iovr_exp, iovr_exprand, & - isubc_sw,icseed_sw, cld_frac, precip_frac, cloud_overlap_param, precip_overlap_param,& - imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_samf, cnv_cloud_overlap_param, cld_cnv_frac, & - sw_optical_props_cnvcloudsByBand, sw_optical_props_cloudsByBand, & - sw_optical_props_precipByBand, sw_optical_props_clouds, sw_optical_props_cnvclouds, & - sw_optical_props_precip, errmsg, errflg) - - ! Inputs - logical, intent(in) :: & - doSWrad ! Logical flag for shortwave radiation call - integer, intent(in) :: & - nCol, & ! Number of horizontal gridpoints - nDay, & ! Number of daylit points. - nLev, & ! Number of vertical layers - imfdeepcnv, & ! - imfdeepcnv_gf, & ! - imfdeepcnv_samf, & ! - iovr, & ! Choice of cloud-overlap method - iovr_convcld, & ! Choice of convective cloud-overlap method - iovr_max, & ! Flag for maximum cloud overlap method - iovr_maxrand, & ! Flag for maximum-random cloud overlap method - iovr_rand, & ! Flag for random cloud overlap method - iovr_dcorr, & ! Flag for decorrelation-length cloud overlap method - iovr_exp, & ! Flag for exponential cloud overlap method - iovr_exprand, & ! Flag for exponential-random cloud overlap method - isubc_sw - integer,intent(in),dimension(:) :: & - idxday ! Indices for daylit points. - integer,intent(in),dimension(:) :: & - icseed_sw ! auxiliary special cloud related array when module - ! variable isubc_sw=2, it provides permutation seed - ! for each column profile that are used for generating - ! random numbers. when isubc_sw /=2, it will not be used. - real(kind_phys), dimension(:,:),intent(in) :: & - cld_frac, & ! Total cloud fraction by layer - cld_cnv_frac, & ! Convective cloud fraction by layer - precip_frac ! Precipitation fraction by layer - real(kind_phys), dimension(:,:), intent(in) :: & - cloud_overlap_param, & ! Cloud overlap parameter - cnv_cloud_overlap_param, & ! Convective cloud overlap parameter - precip_overlap_param ! Precipitation overlap parameter - type(ty_optical_props_2str),intent(in) :: & - sw_optical_props_cloudsByBand, & ! RRTMGP DDT: Shortwave optical properties in each band (clouds) - sw_optical_props_cnvcloudsByBand,& ! RRTMGP DDT: Shortwave optical properties in each band (convectivecloud) - sw_optical_props_precipByBand ! RRTMGP DDT: Shortwave optical properties in each band (precipitation) - - ! Outputs - character(len=*), intent(out) :: & - errmsg ! Error message - integer, intent(out) :: & - errflg ! Error flag - type(ty_optical_props_2str),intent(out) :: & - sw_optical_props_clouds, & ! RRTMGP DDT: Shortwave optical properties at each spectral point (clouds) - sw_optical_props_cnvclouds, & ! RRTMGP DDT: Shortwave optical properties at each spectral point (convectivecloud) - sw_optical_props_precip ! RRTMGP DDT: Shortwave optical properties at each spectral point (precipitation) - - ! Local variables - integer :: iday,iLay,iGpt - integer,dimension(nday) :: ipseed_sw - type(random_stat) :: rng_stat - real(kind_phys) :: tauloc,asyloc,ssaloc - real(kind_phys), dimension(sw_gas_props%get_ngpt(),nLev,nday) :: rng3D,rng3D2 - real(kind_phys), dimension(sw_gas_props%get_ngpt()*nLev) :: rng2D - real(kind_phys), dimension(sw_gas_props%get_ngpt()) :: rng1D - logical, dimension(nday,nLev,sw_gas_props%get_ngpt()) :: maskMCICA - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (.not. doSWrad) return - if (nDay .gt. 0) then - ! ################################################################################# - ! First sample the clouds... - ! ################################################################################# - - ! Allocate space RRTMGP DDTs [nday,nLev,nGpt] - call check_error_msg('rrtmgp_sw_cloud_sampling_run', & - sw_optical_props_clouds%alloc_2str(nday, nLev, sw_gas_props)) - - ! Change random number seed value for each radiation invocation (isubc_sw =1 or 2). - if(isubc_sw == 1) then ! advance prescribed permutation seed - do iday = 1, nday - ipseed_sw(iday) = sw_gas_props%get_ngpt() + iday - enddo - elseif (isubc_sw == 2) then ! use input array of permutaion seeds - do iday = 1, nday - ipseed_sw(iday) = icseed_sw(idxday(iday)) - enddo - endif - - ! Call RNG. Mersennse Twister accepts 1D array, so loop over columns and collapse along G-points - ! and layers. ([nGpts,nLev,nDayumn]-> [nGpts*nLev]*nDayumn) - do iday=1,nday - call random_setseed(ipseed_sw(iday),rng_stat) - ! Use same rng for each layer - if (iovr == iovr_max) then - call random_number(rng1D,rng_stat) - do iLay=1,nLev - rng3D(:,iLay,iday) = rng1D - enddo - else - do iLay=1,nLev - call random_number(rng1D,rng_stat) - rng3D(:,iLay,iday) = rng1D - enddo - endif - enddo - - ! Cloud overlap. - ! Maximum-random, random, or maximum cloud overlap - if (iovr == iovr_maxrand .or. iovr == iovr_max .or. iovr == iovr_rand) then - call sampled_mask(rng3D, cld_frac(idxday(1:nDay),:), maskMCICA) - endif - ! Decorrelation-length overlap - if (iovr == iovr_dcorr) then - do iday=1,nday - call random_setseed(ipseed_sw(iday),rng_stat) - call random_number(rng2D,rng_stat) - rng3D2(:,:,iday) = reshape(source = rng2D,shape=[sw_gas_props%get_ngpt(),nLev]) - enddo - call sampled_mask(rng3D, cld_frac(idxday(1:nDay),:), maskMCICA, & - overlap_param = cloud_overlap_param(idxday(1:nDay),1:nLev-1),& - randoms2 = rng3D2) - endif - ! Exponential or exponential-random cloud overlap - if (iovr == iovr_exp .or. iovr == iovr_exprand) then - call sampled_mask(rng3D, cld_frac(idxday(1:nDay),:), maskMCICA, & - overlap_param = cloud_overlap_param(idxday(1:nDay),1:nLev-1)) - endif - - ! - ! Sampling. Map band optical depth to each g-point using McICA - ! - call check_error_msg('rrtmgp_sw_cloud_sampling_run_draw_samples', & - draw_samples(maskMCICA, .true., & - sw_optical_props_cloudsByBand, & - sw_optical_props_clouds)) - endif - - end subroutine rrtmgp_sw_cloud_sampling_run - - ! ######################################################################################### - ! SUBROTUINE rrtmgp_sw_cloud_sampling_finalize() - ! ######################################################################################### - subroutine rrtmgp_sw_cloud_sampling_finalize() - end subroutine rrtmgp_sw_cloud_sampling_finalize - -end module rrtmgp_sw_cloud_sampling diff --git a/physics/rrtmgp_sw_cloud_sampling.meta b/physics/rrtmgp_sw_cloud_sampling.meta deleted file mode 100644 index 1415108f8..000000000 --- a/physics/rrtmgp_sw_cloud_sampling.meta +++ /dev/null @@ -1,240 +0,0 @@ -[ccpp-table-properties] - name = rrtmgp_sw_cloud_sampling - type = scheme - dependencies = machine.F,mersenne_twister.f,rrtmgp_sampling.F90,radiation_tools.F90 - -###################################################### -[ccpp-arg-table] - name = rrtmgp_sw_cloud_sampling_run - type = scheme -[doSWrad] - standard_name = flag_for_calling_shortwave_radiation - long_name = logical flags for sw radiation calls - units = flag - dimensions = () - type = logical - intent = in -[imfdeepcnv] - standard_name = control_for_deep_convection_scheme - long_name = flag for mass-flux deep convection scheme - units = flag - dimensions = () - type = integer - intent = in -[imfdeepcnv_gf] - standard_name = identifier_for_grell_freitas_deep_convection - long_name = flag for Grell-Freitas deep convection scheme - units = flag - dimensions = () - type = integer - intent = in -[imfdeepcnv_samf] - standard_name = identifer_for_scale_aware_mass_flux_deep_convection - long_name = flag for SAMF deep convection scheme - units = flag - dimensions = () - type = integer - intent = in -[iovr_convcld] - standard_name = flag_for_convective_cloud_overlap_method_for_radiation - long_name = flag for convective cloud overlap method - units = flag - dimensions = () - type = integer - intent = in -[ncol] - standard_name = horizontal_loop_extent - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in -[nday] - standard_name = daytime_points_dimension - long_name = daytime points dimension - units = count - dimensions = () - type = integer - intent = in -[nLev] - standard_name = vertical_layer_dimension - long_name = number of vertical levels - units = count - dimensions = () - type = integer - intent = in -[isubc_sw] - standard_name = flag_for_sw_clouds_grid_approximation - long_name = flag for sw clouds sub-grid approximation - units = flag - dimensions = () - type = integer - intent = in -[idxday] - standard_name = daytime_points - long_name = daytime points - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = in -[iovr] - standard_name = flag_for_cloud_overlap_method_for_radiation - long_name = max-random overlap clouds - units = flag - dimensions = () - type = integer - intent = in -[iovr_maxrand] - standard_name = flag_for_maximum_random_cloud_overlap_method - long_name = choice of maximum-random cloud overlap method - units = flag - dimensions = () - type = integer - intent = in -[iovr_dcorr] - standard_name = flag_for_decorrelation_length_cloud_overlap_method - long_name = choice of decorrelation-length cloud overlap method - units = flag - dimensions = () - type = integer - intent = in -[iovr_exp] - standard_name = flag_for_exponential_cloud_overlap_method - long_name = choice of exponential cloud overlap method - units = flag - dimensions = () - type = integer - intent = in -[iovr_exprand] - standard_name = flag_for_exponential_random_cloud_overlap_method - long_name = choice of exponential-random cloud overlap method - units = flag - dimensions = () - type = integer - intent = in -[iovr_rand] - standard_name = flag_for_random_cloud_overlap_method - long_name = choice of random cloud overlap method - units = flag - dimensions = () - type = integer - intent = in -[iovr_max] - standard_name = flag_for_maximum_cloud_overlap_method - long_name = choice of maximum cloud overlap method - units = flag - dimensions = () - type = integer - intent = in -[icseed_sw] - standard_name = random_number_seed_for_mcica_shortwave - long_name = seed for random number generation for shortwave radiation - units = none - dimensions = (horizontal_loop_extent) - type = integer - intent = in -[cld_frac] - standard_name = total_cloud_fraction - long_name = layer total cloud fraction - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[precip_frac] - standard_name = precipitation_fraction_by_layer - long_name = precipitation fraction in each layer - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_cnv_frac] - standard_name = convective_cloud_fraction_for_RRTMGP - long_name = layer convective cloud fraction - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cnv_cloud_overlap_param] - standard_name = convective_cloud_overlap_param - long_name = convective cloud overlap parameter - units = km - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cloud_overlap_param] - standard_name = cloud_overlap_param - long_name = cloud overlap parameter - units = km - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[precip_overlap_param] - standard_name = precip_overlap_param - long_name = precipitation overlap parameter - units = km - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[sw_optical_props_cloudsByBand] - standard_name = shortwave_optical_properties_for_cloudy_atmosphere_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = in -[sw_optical_props_cnvcloudsByBand] - standard_name = shortwave_optical_properties_for_convective_cloudy_atmosphere_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = in -[sw_optical_props_precipByBand] - standard_name = shortwave_optical_properties_for_precipitation_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = in -[sw_optical_props_clouds] - standard_name = shortwave_optical_properties_for_cloudy_atmosphere - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = out -[sw_optical_props_cnvclouds] - standard_name = shortwave_optical_properties_for_convective_cloudy_atmosphere - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = out -[sw_optical_props_precip] - standard_name = shortwave_optical_properties_for_precipitation - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = out -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out diff --git a/physics/rrtmgp_sw_gas_optics.F90 b/physics/rrtmgp_sw_gas_optics.F90 index 260f65fe7..9193b9134 100644 --- a/physics/rrtmgp_sw_gas_optics.F90 +++ b/physics/rrtmgp_sw_gas_optics.F90 @@ -4,7 +4,6 @@ module rrtmgp_sw_gas_optics use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp use mo_gas_concentrations, only: ty_gas_concs use radiation_tools, only: check_error_msg - use mo_optical_props, only: ty_optical_props_2str use netcdf #ifdef MPI use mpi @@ -76,11 +75,8 @@ module rrtmgp_sw_gas_optics ! ######################################################################################### ! SUBROUTINE sw_gas_optics_init ! ######################################################################################### -!! \section arg_table_rrtmgp_sw_gas_optics_init -!! \htmlinclude rrtmgp_sw_gas_optics.html -!! - subroutine rrtmgp_sw_gas_optics_init(rrtmgp_root_dir, rrtmgp_sw_file_gas, & - active_gases_array, mpicomm, mpirank, mpiroot, errmsg, errflg) + subroutine rrtmgp_sw_gas_optics_init(rrtmgp_root_dir, rrtmgp_sw_file_gas, mpicomm, mpirank, & + mpiroot, active_gases_array, errmsg, errflg) ! Inputs character(len=128),intent(in) :: & @@ -481,111 +477,4 @@ subroutine rrtmgp_sw_gas_optics_init(rrtmgp_root_dir, rrtmgp_sw_file_gas, end subroutine rrtmgp_sw_gas_optics_init - ! ######################################################################################### - ! SUBROUTINE rrtmgp_sw_gas_optics_run - ! ######################################################################################### -!! \section arg_table_rrtmgp_sw_gas_optics_run -!! \htmlinclude rrtmgp_sw_gas_optics.html -!! - subroutine rrtmgp_sw_gas_optics_run(doSWrad, nCol, nLev, ngptsGPsw, nday, idxday, p_lay, & - p_lev, toa_src_sw, t_lay, t_lev, active_gases_array, gas_concentrations, solcon, & - sw_optical_props_clrsky, errmsg, errflg) - - ! Inputs - logical, intent(in) :: & - doSWrad ! Flag to calculate SW irradiances - integer,intent(in) :: & - ngptsGPsw, & ! Number of spectral (g) points. - nDay, & ! Number of daylit points. - nCol, & ! Number of horizontal points - nLev ! Number of vertical levels - integer,intent(in),dimension(ncol) :: & - idxday ! Indices for daylit points. - real(kind_phys), dimension(ncol,nLev), intent(in) :: & - p_lay, & ! Pressure @ model layer-centers (Pa) - t_lay ! Temperature (K) - real(kind_phys), dimension(ncol,nLev+1), intent(in) :: & - p_lev, & ! Pressure @ model layer-interfaces (Pa) - t_lev ! Temperature @ model levels - type(ty_gas_concs),intent(inout) :: & - gas_concentrations ! RRTMGP DDT: trace gas concentrations (vmr) - real(kind_phys), intent(in) :: & - solcon ! Solar constant - - ! Output - character(len=*), intent(out) :: & - errmsg ! CCPP error message - integer, intent(out) :: & - errflg ! CCPP error code - type(ty_optical_props_2str),intent(out) :: & - sw_optical_props_clrsky ! RRTMGP DDT: clear-sky shortwave optical properties, spectral (tau,ssa,g) - real(kind_phys), dimension(nCol,ngptsGPsw), intent(out) :: & - toa_src_sw ! TOA incident spectral flux (W/m2) - character(len=*), dimension(:), intent(in) :: & - active_gases_array ! List of active gases from namelist as array - - ! Local variables - integer :: ij,iGas - real(kind_phys), dimension(ncol,nLev) :: vmrTemp - real(kind_phys), dimension(nday,ngptsGPsw) :: toa_src_sw_temp - type(ty_gas_concs) :: gas_concentrations_daylit - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (.not. doSWrad) return - - gas_concentrations%gas_name(:) = active_gases_array(:) - - toa_src_sw(:,:) = 0._kind_phys - if (nDay .gt. 0) then - ! Allocate space - call check_error_msg('rrtmgp_sw_gas_optics_run_alloc_2str',& - sw_optical_props_clrsky%alloc_2str(nday, nLev, sw_gas_props)) - - gas_concentrations_daylit%ncol = nDay - gas_concentrations_daylit%nlay = nLev - allocate(gas_concentrations_daylit%gas_name(gas_concentrations%get_num_gases())) - allocate(gas_concentrations_daylit%concs(gas_concentrations%get_num_gases())) - do iGas=1,gas_concentrations%get_num_gases() - allocate(gas_concentrations_daylit%concs(iGas)%conc(nDay, nLev)) - enddo - gas_concentrations_daylit%gas_name(:) = active_gases_array(:) - - ! Subset the gas concentrations. - do iGas=1,gas_concentrations%get_num_gases() - call check_error_msg('rrtmgp_sw_gas_optics_run_get_vmr',& - gas_concentrations%get_vmr(trim(gas_concentrations_daylit%gas_name(iGas)),vmrTemp)) - call check_error_msg('rrtmgp_sw_gas_optics_run_set_vmr',& - gas_concentrations_daylit%set_vmr(trim(gas_concentrations_daylit%gas_name(iGas)),vmrTemp(idxday(1:nday),:))) - enddo - - ! Call SW gas-optics - call check_error_msg('rrtmgp_sw_gas_optics_run',sw_gas_props%gas_optics(& - p_lay(idxday(1:nday),:), & ! IN - Pressure @ layer-centers (Pa) - p_lev(idxday(1:nday),:), & ! IN - Pressure @ layer-interfaces (Pa) - t_lay(idxday(1:nday),:), & ! IN - Temperature @ layer-centers (K) - gas_concentrations_daylit, & ! IN - RRTMGP DDT: trace gas volumne mixing-ratios - sw_optical_props_clrsky, & ! OUT - RRTMGP DDT: Shortwave optical properties, by - ! spectral point (tau,ssa,g) - toa_src_sw_temp)) ! OUT - TOA incident shortwave radiation (spectral) - toa_src_sw(idxday(1:nday),:) = toa_src_sw_temp - - ! Scale incident flux - do ij=1,nday - toa_src_sw(idxday(ij),:) = toa_src_sw(idxday(ij),:)*solcon/ & - sum(toa_src_sw(idxday(ij),:)) - enddo - endif - - end subroutine rrtmgp_sw_gas_optics_run - - ! ######################################################################################### - ! SUBROUTINE rrtmgp_sw_gas_optics_finalize - ! ######################################################################################### - subroutine rrtmgp_sw_gas_optics_finalize() - end subroutine rrtmgp_sw_gas_optics_finalize - end module rrtmgp_sw_gas_optics - diff --git a/physics/rrtmgp_sw_gas_optics.meta b/physics/rrtmgp_sw_gas_optics.meta deleted file mode 100644 index 1fdbc946b..000000000 --- a/physics/rrtmgp_sw_gas_optics.meta +++ /dev/null @@ -1,201 +0,0 @@ -[ccpp-table-properties] - name = rrtmgp_sw_gas_optics - type = scheme - dependencies = machine.F,radiation_tools.F90,GFS_rrtmgp_pre.F90,rte-rrtmgp/rrtmgp/mo_gas_optics_rrtmgp.F90,rte-rrtmgp/rte/mo_rte_kind.F90,rte-rrtmgp/rrtmgp/mo_gas_concentrations.F90,rte-rrtmgp/rte/mo_optical_props.F90 - -######################################################################## -[ccpp-arg-table] - name = rrtmgp_sw_gas_optics_init - type = scheme -[rrtmgp_root_dir] - standard_name = directory_for_rte_rrtmgp_source_code - long_name = directory for rte+rrtmgp source code - units = none - dimensions = () - type = character - intent = in - kind = len=128 -[rrtmgp_sw_file_gas] - standard_name = filename_of_rrtmgp_shortwave_k_distribution - long_name = file containing RRTMGP SW k-distribution - units = none - dimensions = () - type = character - intent = in - kind = len=128 -[active_gases_array] - standard_name = list_of_active_gases_used_by_RRTMGP - long_name = list of active gases used by RRTMGP - units = none - dimensions = (number_of_active_gases_used_by_RRTMGP) - type = character - kind = len=* - intent = in -[mpirank] - standard_name = mpi_rank - long_name = current MPI rank - units = index - dimensions = () - type = integer - intent = in -[mpiroot] - standard_name = mpi_root - long_name = master MPI rank - units = index - dimensions = () - type = integer - intent = in -[mpicomm] - standard_name = mpi_communicator - long_name = MPI communicator - units = index - dimensions = () - type = integer - intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - -######################################################################## -[ccpp-arg-table] - name = rrtmgp_sw_gas_optics_run - type = scheme -[doSWrad] - standard_name = flag_for_calling_shortwave_radiation - long_name = flag to calculate SW irradiances - units = flag - dimensions = () - type = logical - intent = in -[ncol] - standard_name = horizontal_loop_extent - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in -[nLev] - standard_name = vertical_layer_dimension - long_name = number of vertical levels - units = count - dimensions = () - type = integer - intent = in -[nday] - standard_name = daytime_points_dimension - long_name = daytime points dimension - units = count - dimensions = () - type = integer - intent = in -[idxday] - standard_name = daytime_points - long_name = daytime points - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = in -[ngptsGPsw] - standard_name = number_of_shortwave_spectral_points - long_name = number of spectral points in RRTMGP SW calculation - units = count - dimensions = () - type = integer - intent = in -[p_lay] - standard_name = air_pressure_at_layer_for_RRTMGP - long_name = air pressure layer - units = Pa - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[p_lev] - standard_name = air_pressure_at_interface_for_RRTMGP - long_name = air pressure level - units = Pa - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = in -[t_lay] - standard_name = air_temperature_at_layer_for_RRTMGP - long_name = air temperature layer - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[t_lev] - standard_name = air_temperature_at_interface_for_RRTMGP - long_name = air temperature level - units = K - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = in -[toa_src_sw] - standard_name = toa_incident_sw_flux_by_spectral_point - long_name = TOA shortwave incident flux at each spectral points - units = W m-2 - dimensions = (horizontal_loop_extent,number_of_shortwave_spectral_points) - type = real - kind = kind_phys - intent = out -[active_gases_array] - standard_name = list_of_active_gases_used_by_RRTMGP - long_name = list of active gases used by RRTMGP - units = none - dimensions = (number_of_active_gases_used_by_RRTMGP) - type = character - kind = len=* - intent = in -[gas_concentrations] - standard_name = Gas_concentrations_for_RRTMGP_suite - long_name = DDT containing gas concentrations for RRTMGP radiation scheme - units = DDT - dimensions = () - type = ty_gas_concs - intent = inout -[solcon] - standard_name = solar_constant - long_name = solar constant - units = W m-2 - dimensions = () - type = real - kind = kind_phys - intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out -[sw_optical_props_clrsky] - standard_name = shortwave_optical_properties_for_clear_sky - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = out diff --git a/physics/rrtmgp_sw_main.F90 b/physics/rrtmgp_sw_main.F90 new file mode 100644 index 000000000..fd8964c4d --- /dev/null +++ b/physics/rrtmgp_sw_main.F90 @@ -0,0 +1,555 @@ +! ########################################################################################### +! ########################################################################################### +module rrtmgp_sw_main + use machine, only: kind_phys + use mo_optical_props, only: ty_optical_props_2str + use mo_cloud_optics, only: ty_cloud_optics + use module_radsw_parameters, only: cmpfsw_type + use mo_rte_sw, only: rte_sw + use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp + use mo_gas_concentrations, only: ty_gas_concs + use mo_fluxes_byband, only: ty_fluxes_byband + use radiation_tools, only: check_error_msg + use rrtmgp_sw_gas_optics, only: sw_gas_props,rrtmgp_sw_gas_optics_init + use rrtmgp_sw_cloud_optics, only: sw_cloud_props, rrtmgp_sw_cloud_optics_init, a0r, a0s, & + a1s, b0r, b0s, b1s, c0r, c0s + use module_radiation_gases, only: NF_VGAS, getgases, getozn + use GFS_rrtmgp_pre, only: iStr_h2o, iStr_co2, iStr_o3, iStr_n2o, iStr_ch4, & + iStr_o2, iStr_ccl4, iStr_cfc11, iStr_cfc12, iStr_cfc22 + use mersenne_twister, only: random_setseed, random_number, random_stat + use rrtmgp_sampling, only: sampled_mask, draw_samples + implicit none + + public rrtmgp_sw_main_init, rrtmgp_sw_main_run +contains + + ! ######################################################################################### + ! SUBROUTINE rrtmgp_sw_main_init + ! ######################################################################################### +!! \section arg_table_rrtmgp_sw_main_init +!! \htmlinclude rrtmgp_sw_main_init.html +!! + subroutine rrtmgp_sw_main_init(rrtmgp_root_dir, rrtmgp_sw_file_gas, mpicomm, mpirank, & + mpiroot, active_gases_array, nrghice, doG_cldoptics, doGP_cldoptics_PADE, & + doGP_cldoptics_LUT,rrtmgp_sw_file_clouds, errmsg, errflg) + ! Inputs + logical, intent(in) :: & + doG_cldoptics, & ! Use legacy RRTMG cloud-optics? + doGP_cldoptics_PADE, & ! Use RRTMGP cloud-optics: PADE approximation? + doGP_cldoptics_LUT ! Use RRTMGP cloud-optics: LUTs? + integer, intent(inout) :: & + nrghice ! Number of ice-roughness categories + character(len=128),intent(in) :: & + rrtmgp_root_dir, & ! RTE-RRTMGP root directory + rrtmgp_sw_file_clouds, & ! RRTMGP file containing coefficients used to compute clouds optical properties + rrtmgp_sw_file_gas ! RRTMGP file containing coefficients used to compute gaseous optical properties + integer,intent(in) :: & + mpicomm, & ! MPI communicator + mpirank, & ! Current MPI rank + mpiroot ! Master MPI rank + character(len=*), dimension(:), intent(in) :: & + active_gases_array ! List of active gases from namelist as array) + ! Outputs + character(len=*), intent(out) :: & + errmsg ! CCPP error message + integer, intent(out) :: & + errflg ! CCPP error code + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! RRTMGP shortwave gas-optics (k-distribution) initialization + call rrtmgp_sw_gas_optics_init(rrtmgp_root_dir, rrtmgp_sw_file_gas, mpicomm, mpirank, & + mpiroot, active_gases_array, errmsg, errflg) + + ! RRTMGP shortwave cloud-optics initialization + call rrtmgp_sw_cloud_optics_init(nrghice, mpicomm, mpirank, mpiroot, doG_cldoptics, & + doGP_cldoptics_PADE, doGP_cldoptics_LUT, rrtmgp_root_dir, rrtmgp_sw_file_clouds, & + errmsg, errflg) + + end subroutine rrtmgp_sw_main_init + + ! ######################################################################################### + ! SUBROUTINE rrtmgp_sw_main_run + ! ######################################################################################### +!! \section arg_table_rrtmgp_sw_main_run +!! \htmlinclude rrtmgp_sw_main_run.html +!! + subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_sgs_pbl, & + nCol, nDay, nLay, nGases, i_o3, idxday, icseed_sw, iovr, iovr_convcld, iovr_max, & + iovr_maxrand, iovr_rand, iovr_dcorr, iovr_exp, iovr_exprand, isubc_sw, iSFC, & + sfc_alb_nir_dir, sfc_alb_nir_dif, sfc_alb_uvvis_dir, sfc_alb_uvvis_dif, coszen, & + p_lay, p_lev, t_lay, t_lev, vmr_o2, vmr_h2o, vmr_o3, vmr_ch4, vmr_n2o, vmr_co2, & + cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, & + cld_rerain, precip_frac, cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, cld_cnv_reice, & + cld_pbl_lwp, cld_pbl_reliq, cld_pbl_iwp, cld_pbl_reice, cloud_overlap_param, & + active_gases_array, sw_optical_props_aerosol, scmpsw, fluxswUP_allsky, & + fluxswDOWN_allsky, fluxswUP_clrsky, fluxswDOWN_clrsky, cldtausw, errmsg, errflg) + + ! Inputs + logical, intent(in) :: & + doSWrad, & ! Flag to calculate SW irradiances + doSWclrsky, & ! Flag to compute clear-sky fluxes (diagnostic) + top_at_1, & ! Vertical ordering flag + doGP_sgs_pbl, & ! Flag for sgs MYNN-EDMF PBL cloud scheme + doGP_sgs_cnv ! Flag for sgs convective cloud scheme + integer,intent(in) :: & + nCol, & ! Number of horizontal points + nDay, & ! Number of daytime points + nLay, & ! Number of vertical grid points. + nGases, & ! Number of active gases in RRTMGP + i_o3, & ! + iovr, & ! Choice of cloud-overlap method + iovr_convcld, & ! Choice of convective cloud-overlap + iovr_max, & ! Flag for maximum cloud overlap method + iovr_maxrand, & ! Flag for maximum-random cloud overlap method + iovr_rand, & ! Flag for random cloud overlap method + iovr_dcorr, & ! Flag for decorrelation-length cloud overlap method + iovr_exp, & ! Flag for exponential cloud overlap method + iovr_exprand, & ! Flag for exponential-random cloud overlap method + isubc_sw, & ! + iSFC + integer,intent(in),dimension(:) :: & + idxday, & ! Index array for daytime points + icseed_sw ! Seed for random number generation for shortwave radiation + real(kind_phys), dimension(:), intent(in) :: & + sfc_alb_nir_dir, & ! Surface albedo (direct) + sfc_alb_nir_dif, & ! Surface albedo (diffuse) + sfc_alb_uvvis_dir, & ! Surface albedo (direct) + sfc_alb_uvvis_dif, & ! Surface albedo (diffuse) + coszen ! Cosize of SZA + real(kind_phys), dimension(:,:), intent(in) :: & + p_lay, & ! Pressure @ model layer-centers (Pa) + t_lay, & ! Temperature (K) + p_lev, & ! Pressure @ model layer-interfaces (Pa) + t_lev, & ! Temperature @ model levels (K) + vmr_o2, & ! Molar-mixing ratio oxygen + vmr_h2o, & ! Molar-mixing ratio water vapor + vmr_o3, & ! Molar-mixing ratio ozone + vmr_ch4, & ! Molar-mixing ratio methane + vmr_n2o, & ! Molar-mixing ratio nitrous oxide + vmr_co2, & ! Molar-mixing ratio carbon dioxide + cld_frac, & ! Cloud-fraction for stratiform clouds + cld_lwp, & ! Water path for stratiform liquid cloud-particles + cld_reliq, & ! Effective radius for stratiform liquid cloud-particles + cld_iwp, & ! Water path for stratiform ice cloud-particles + cld_reice, & ! Effective radius for stratiform ice cloud-particles + cld_swp, & ! Water path for snow hydrometeors + cld_resnow, & ! Effective radius for snow hydrometeors + cld_rwp, & ! Water path for rain hydrometeors + cld_rerain, & ! Effective radius for rain hydrometeors + precip_frac, & ! Precipitation fraction + cld_cnv_lwp, & ! Water path for convective liquid cloud-particles + cld_cnv_reliq, & ! Effective radius for convective liquid cloud-particles + cld_cnv_iwp, & ! Water path for convective ice cloud-particles + cld_cnv_reice, & ! Effective radius for convective ice cloud-particles + cld_pbl_lwp, & ! Water path for SGS PBL liquid cloud-particles + cld_pbl_reliq, & ! Effective radius for SGS PBL liquid cloud-particles + cld_pbl_iwp, & ! Water path for SGS PBL ice cloud-particles + cld_pbl_reice, & ! Effective radius for SGS PBL ice cloud-particles + cloud_overlap_param ! + character(len=*), dimension(:), intent(in) :: & + active_gases_array ! List of active gases from namelist as array + type(ty_optical_props_2str),intent(in) :: & + sw_optical_props_aerosol ! RRTMGP DDT: Shortwave aerosol optical properties (tau,ssa,g) + + ! Outputs + character(len=*), intent(out) :: & + errmsg ! CCPP error message + integer, intent(out) :: & + errflg ! CCPP error flag + real(kind_phys), dimension(:,:), intent(out) :: & + cldtausw ! Approx 10.mu band layer cloud optical depth + real(kind_phys), dimension(:,:), intent(inout) :: & + fluxswUP_allsky, & ! RRTMGP upward all-sky flux profiles (W/m2) + fluxswDOWN_allsky, & ! RRTMGP downward all-sky flux profiles (W/m2) + fluxswUP_clrsky, & ! RRTMGP upward clear-sky flux profiles (W/m2) + fluxswDOWN_clrsky ! RRTMGP downward clear-sky flux profiles (W/m2) + type(cmpfsw_type), dimension(:), intent(inout) :: & + scmpsw ! 2D surface fluxes, components: + ! uvbfc - total sky downward uv-b flux (W/m2) + ! uvbf0 - clear sky downward uv-b flux (W/m2) + ! nirbm - downward nir direct beam flux (W/m2) + ! nirdf - downward nir diffused flux (W/m2) + ! visbm - downward uv+vis direct beam flux (W/m2) + ! visdf - downward uv+vis diffused flux (W/m2) + + ! Local variables + type(ty_gas_concs) :: & + gas_concentrations ! RRTMGP DDT: trace gas concentrations (vmr) + type(ty_optical_props_2str) :: & + sw_optical_props_clrsky, & ! RRTMGP DDT: Shortwave clear-sky radiative properties + sw_optical_props_aerosol_local, & ! RRTMGP DDT: Shortave aerosol radiative properties + sw_optical_props_cloudsByBand, & ! RRTMGP DDT: Shortwave optical properties in each band (clouds) + sw_optical_props_cnvcloudsByBand, & ! RRTMGP DDT: Shortwave optical properties in each band (convective cloud) + sw_optical_props_pblcloudsByBand, & ! RRTMGP DDT: Shortwave optical properties in each band (PBL cloud) + sw_optical_props_precipByBand, & ! RRTMGP DDT: Shortwave optical properties in each band (precipitation) + sw_optical_props_clouds ! RRTMGP DDT: Shortwave optical properties in each band (sampled clouds) + type(ty_fluxes_byband) :: & + flux_allsky, & ! RRTMGP DDT: All-sky flux (W/m2) + flux_clrsky ! RRTMGP DDT: Clear-sky flux (W/m2) + real(kind_phys) :: & + tau_rain, tau_snow, ssa_rain, ssa_snow, asy_rain, asy_snow, & + tau_prec, asy_prec, ssa_prec, asyw, ssaw, za1, za2 + real(kind_phys), dimension(sw_gas_props%get_ngpt()) :: rng1D + real(kind_phys), dimension(sw_gas_props%get_ngpt(),nLay,1) :: rng3D,rng3D2 + real(kind_phys), dimension(sw_gas_props%get_ngpt()*nLay) :: rng2D + logical, dimension(1,nLay,sw_gas_props%get_ngpt()) :: maskMCICA + real(kind_phys), dimension(sw_gas_props%get_nband(),1) :: & + sfc_alb_dir, sfc_alb_dif + real(kind_phys), dimension(1,nLay+1,sw_gas_props%get_nband()),target :: & + fluxSW_up_allsky, fluxSW_up_clrsky, fluxSW_dn_allsky, fluxSW_dn_clrsky, fluxSW_dn_dir_allsky + integer :: iBand, ibd, iCol, iGas, iLay, ipseed_sw + type(random_stat) :: rng_stat + real(kind_phys), dimension(2,sw_gas_props%get_nband()) :: bandlimits + real(kind_phys), dimension(2), parameter :: nIR_uvvis_bnd = (/12850,16000/) + real(kind_phys), dimension(1,sw_gas_props%get_ngpt()) :: toa_src_sw + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (.not. doSWrad) return + if (nDay .le. 0) then + fluxswUP_allsky(:,:) = 0._kind_phys + fluxswDOWN_allsky(:,:) = 0._kind_phys + fluxswUP_clrsky(:,:) = 0._kind_phys + fluxswDOWN_clrsky(:,:) = 0._kind_phys + scmpsw = cmpfsw_type( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 ) + return + endif + + ! ###################################################################################### + ! + ! Allocate/initialize RRTMGP DDT's + ! + ! ###################################################################################### + ! + ! ty_gas_concs + ! + gas_concentrations%ncol = 1 + gas_concentrations%nlay = nLay + allocate(gas_concentrations%gas_name(nGases)) + allocate(gas_concentrations%concs(nGases)) + do iGas=1,nGases + allocate(gas_concentrations%concs(iGas)%conc(1, nLay)) + enddo + gas_concentrations%gas_name(:) = active_gases_array(:) + ! + ! ty_optical_props + ! + call check_error_msg('rrtmgp_sw_main_gas_optics_init',& + sw_optical_props_clrsky%alloc_2str(1, nLay, sw_gas_props)) + call check_error_msg('rrtmgp_sw_main_cloud_optics_init',& + sw_optical_props_cloudsByBand%alloc_2str(1, nLay, sw_gas_props%get_band_lims_wavenumber())) + call check_error_msg('rrtmgp_sw_main_precip_optics_init',& + sw_optical_props_precipByBand%alloc_2str(1, nLay, sw_gas_props%get_band_lims_wavenumber())) + call check_error_msg('rrtmgp_sw_mian_cloud_sampling_init', & + sw_optical_props_clouds%alloc_2str(1, nLay, sw_gas_props)) + call check_error_msg('rrtmgp_sw_main_aerosol_optics_init',& + sw_optical_props_aerosol_local%alloc_2str(1, nLay, sw_gas_props%get_band_lims_wavenumber())) + if (doGP_sgs_cnv) then + call check_error_msg('rrtmgp_sw_main_cnv_cloud_optics_init',& + sw_optical_props_cnvcloudsByBand%alloc_2str(1, nLay, sw_gas_props%get_band_lims_wavenumber())) + endif + if (doGP_sgs_pbl) then + call check_error_msg('rrtmgp_sw_main_pbl_cloud_optics_init',& + sw_optical_props_pblcloudsByBand%alloc_2str(1, nLay, sw_gas_props%get_band_lims_wavenumber())) + endif + ! + ! ty_fluxes_byband + ! + flux_allsky%bnd_flux_up => fluxSW_up_allsky + flux_allsky%bnd_flux_dn => fluxSW_dn_allsky + flux_allsky%bnd_flux_dn_dir => fluxSW_dn_dir_allsky + flux_clrsky%bnd_flux_up => fluxSW_up_clrsky + flux_clrsky%bnd_flux_dn => fluxSW_dn_clrsky + + ! Loop over all (daylit)columns... + do iCol=1,nDay + ! Initialize/reset + sw_optical_props_clouds%tau = 0._kind_phys + sw_optical_props_clouds%ssa = 1._kind_phys + sw_optical_props_clouds%g = 0._kind_phys + sw_optical_props_clrsky%tau = 0._kind_phys + sw_optical_props_clrsky%ssa = 1._kind_phys + sw_optical_props_clrsky%g = 0._kind_phys + sw_optical_props_cloudsByBand%tau = 0._kind_phys + sw_optical_props_cloudsByBand%ssa = 1._kind_phys + sw_optical_props_cloudsByBand%g = 0._kind_phys + sw_optical_props_precipByBand%tau = 0._kind_phys + sw_optical_props_precipByBand%ssa = 1._kind_phys + sw_optical_props_precipByBand%g = 0._kind_phys + sw_optical_props_aerosol_local%tau = 0._kind_phys + sw_optical_props_aerosol_local%ssa = 1._kind_phys + sw_optical_props_aerosol_local%g = 0._kind_phys + if (doGP_sgs_cnv) then + sw_optical_props_cnvcloudsByBand%tau = 0._kind_phys + sw_optical_props_cnvcloudsByBand%ssa = 1._kind_phys + sw_optical_props_cnvcloudsByBand%g = 0._kind_phys + endif + if (doGP_sgs_pbl) then + sw_optical_props_pblcloudsByBand%tau = 0._kind_phys + sw_optical_props_pblcloudsByBand%ssa = 1._kind_phys + sw_optical_props_pblcloudsByBand%g = 0._kind_phys + endif + + ! ################################################################################### + ! + ! Set gas-concentrations + ! + ! ################################################################################### + gas_concentrations%concs(istr_o2)%conc(1,:) = vmr_o2(idxday(iCol),:) + gas_concentrations%concs(istr_co2)%conc(1,:) = vmr_co2(idxday(iCol),:) + gas_concentrations%concs(istr_ch4)%conc(1,:) = vmr_ch4(idxday(iCol),:) + gas_concentrations%concs(istr_n2o)%conc(1,:) = vmr_n2o(idxday(iCol),:) + gas_concentrations%concs(istr_h2o)%conc(1,:) = vmr_h2o(idxday(iCol),:) + gas_concentrations%concs(istr_o3)%conc(1,:) = vmr_o3(idxday(iCol),:) + + ! ################################################################################### + ! + ! Set surface albedo + ! + ! Use near-IR albedo for bands with wavenumbers extending to 12850cm-1 + ! Use uv-vis albedo for bands with wavenumbers greater than 16000cm-1 + ! For overlapping band, average near-IR and us-vis albedos. + ! + ! ################################################################################### + bandlimits = sw_gas_props%get_band_lims_wavenumber() + do iBand=1,sw_gas_props%get_nband() + if (bandlimits(1,iBand) .lt. nIR_uvvis_bnd(1)) then + sfc_alb_dir(iBand,1) = sfc_alb_nir_dir(idxday(iCol)) + sfc_alb_dif(iBand,1) = sfc_alb_nir_dif(idxday(iCol)) + endif + if (bandlimits(1,iBand) .eq. nIR_uvvis_bnd(1)) then + sfc_alb_dir(iBand,1) = 0.5_kind_phys*(sfc_alb_nir_dir(idxday(iCol)) + sfc_alb_uvvis_dir(idxday(iCol))) + sfc_alb_dif(iBand,1) = 0.5_kind_phys*(sfc_alb_nir_dif(idxday(iCol)) + sfc_alb_uvvis_dif(idxday(iCol))) + ibd = iBand + endif + if (bandlimits(1,iBand) .ge. nIR_uvvis_bnd(2)) then + sfc_alb_dir(iBand,1) = sfc_alb_uvvis_dir(idxday(iCol)) + sfc_alb_dif(iBand,1) = sfc_alb_uvvis_dif(idxday(iCol)) + endif + enddo + + ! ################################################################################### + ! + ! Gas-optics + ! + ! ################################################################################### + call check_error_msg('rrtmgp_sw_main_gas_optics',sw_gas_props%gas_optics(& + p_lay(idxday(iCol:iCol),:), & ! IN - Pressure @ layer-centers (Pa) + p_lev(idxday(iCol:iCol),:), & ! IN - Pressure @ layer-interfaces (Pa) + t_lay(idxday(iCol:iCol),:), & ! IN - Temperature @ layer-centers (K) + gas_concentrations, & ! IN - RRTMGP DDT: trace gas volumne mixing-ratios + sw_optical_props_clrsky, & ! OUT - RRTMGP DDT: Shortwave optical properties, by + ! spectral point (tau,ssa,g) + toa_src_sw)) ! OUT - TOA incident shortwave radiation (spectral) + + ! ################################################################################### + ! + ! Cloud-optics + ! + ! ################################################################################### + call check_error_msg('rrtmgp_sw_main_cloud_optics',sw_cloud_props%cloud_optics(& + cld_lwp(idxday(iCol:iCol),:), & ! IN - Cloud liquid water path + cld_iwp(idxday(iCol:iCol),:), & ! IN - Cloud ice water path + cld_reliq(idxday(iCol:iCol),:), & ! IN - Cloud liquid effective radius + cld_reice(idxday(iCol:iCol),:), & ! IN - Cloud ice effective radius + sw_optical_props_cloudsByBand)) ! OUT - RRTMGP DDT: Shortwave optical properties, + ! in each band (tau,ssa,g) + cldtausw(idxday(iCol),:) = sw_optical_props_cloudsByBand%tau(1,:,11) + + ! Convective cloud-optics? + if (doGP_sgs_cnv) then + call check_error_msg('rrtmgp_sw_main_cnv_cloud_optics',sw_cloud_props%cloud_optics(& + cld_cnv_lwp(idxday(iCol:iCol),:), & ! IN - Convective cloud liquid water path (g/m2) + cld_cnv_iwp(idxday(iCol:iCol),:), & ! IN - Convective cloud ice water path (g/m2) + cld_cnv_reliq(idxday(iCol:iCol),:), & ! IN - Convective cloud liquid effective radius (microns) + cld_cnv_reice(idxday(iCol:iCol),:), & ! IN - Convective cloud ice effective radius (microns) + sw_optical_props_cnvcloudsByBand)) ! OUT - RRTMGP DDT containing convective cloud radiative properties + ! in each band + !call check_error_msg('rrtmgp_sw_main_increment_cnvclouds_to_clouds',& + ! sw_optical_props_cnvcloudsByBand%increment(sw_optical_props_cloudsByBand)) + endif + + ! MYNN PBL cloud-optics? + if (doGP_sgs_pbl) then + call check_error_msg('rrtmgp_sw_main_pbl_cloud_optics',sw_cloud_props%cloud_optics(& + cld_pbl_lwp(idxday(iCol:iCol),:), & ! IN - MYNN-EDMF PBL cloud liquid water path (g/m2) + cld_pbl_iwp(idxday(iCol:iCol),:), & ! IN - MYNN-EDMF PBL cloud ice water path (g/m2) + cld_pbl_reliq(idxday(iCol:iCol),:), & ! IN - MYNN-EDMF PBL cloud liquid effective radius (microns) + cld_pbl_reice(idxday(iCol:iCol),:), & ! IN - MYNN-EDMF PBL cloud ice effective radius (microns) + sw_optical_props_pblcloudsByBand)) ! OUT - RRTMGP DDT containing MYNN-EDMF PBL cloud radiative properties + ! in each band + !call check_error_msg('rrtmgp_sw_main_increment_pblclouds_to_clouds',& + ! sw_optical_props_pblcloudsByBand%increment(sw_optical_props_cloudsByBand)) + endif + + ! Cloud precipitation optics: rain and snow(+groupel) + do iLay=1,nLay + if (cld_frac(idxday(iCol),iLay) .gt. 1.e-12_kind_phys) then + ! Rain/Snow optical depth (No band dependence) + tau_rain = cld_rwp(idxday(iCol),iLay)*a0r + if (cld_swp(idxday(iCol),iLay) .gt. 0. .and. cld_resnow(idxday(iCol),iLay) .gt. 10._kind_phys) then + tau_snow = cld_swp(idxday(iCol),iLay)*1.09087*(a0s + a1s/(1.0315*cld_resnow(idxday(iCol),iLay))) ! fu's formula + else + tau_snow = 0._kind_phys + endif + + ! Rain/Snow single-scattering albedo and asymmetry (Band dependent) + do iBand=1,sw_gas_props%get_nband() + ! By species + ssa_rain = tau_rain*(1.-b0r(iBand)) + asy_rain = ssa_rain*c0r(iBand) + ssa_snow = tau_snow*(1.-(b0s(iBand)+b1s(iBand)*1.0315*cld_resnow(idxday(iCol),iLay))) + asy_snow = ssa_snow*c0s(iBand) + ! Combine + tau_prec = max(1.e-12_kind_phys, tau_rain + tau_snow) + ssa_prec = max(1.e-12_kind_phys, ssa_rain + ssa_snow) + asy_prec = max(1.e-12_kind_phys, asy_rain + asy_snow) + asyw = asy_prec/max(1.e-12_kind_phys, ssa_prec) + ssaw = min(1._kind_phys-0.000001, ssa_prec/tau_prec) + za1 = asyw * asyw + za2 = ssaw * za1 + sw_optical_props_precipByBand%tau(1,iLay,iBand) = (1._kind_phys - za2) * tau_prec + sw_optical_props_precipByBand%ssa(1,iLay,iBand) = (ssaw - za2) / (1._kind_phys - za2) + sw_optical_props_precipByBand%g(1,iLay,iBand) = asyw/(1+asyw) + enddo + endif + enddo + + ! ################################################################################### + ! + ! Cloud-sampling + ! + ! ################################################################################### + ! Change random number seed value for each radiation invocation (isubc_sw =1 or 2). + if(isubc_sw == 1) then ! advance prescribed permutation seed + ipseed_sw = sw_gas_props%get_ngpt() + iCol + elseif (isubc_sw == 2) then ! use input array of permutaion seeds + ipseed_sw = icseed_sw(idxday(iCol)) + endif + ! Call RNG + call random_setseed(ipseed_sw,rng_stat) + ! Use same rng for each layer + if (iovr == iovr_max) then + call random_number(rng1D,rng_stat) + do iLay=1,nLay + rng3D(:,iLay,1) = rng1D + enddo + else + do iLay=1,nLay + call random_number(rng1D,rng_stat) + rng3D(:,iLay,1) = rng1D + enddo + endif + ! Cloud-overlap. + ! Maximum-random, random or maximum. + if (iovr == iovr_maxrand .or. iovr == iovr_rand .or. iovr == iovr_max) then + call sampled_mask(rng3D, cld_frac(idxday(iCol:iCol),:), maskMCICA) + endif + ! Exponential decorrelation length overlap + if (iovr == iovr_dcorr) then + ! Generate second RNG + call random_setseed(ipseed_sw,rng_stat) + call random_number(rng2D,rng_stat) + rng3D2(:,:,1) = reshape(source = rng2D,shape=[sw_gas_props%get_ngpt(),nLay]) + ! + call sampled_mask(rng3D, cld_frac(idxday(iCol:iCol),:), maskMCICA, & + overlap_param = cloud_overlap_param(idxday(iCol:iCol),1:nLay-1), randoms2 = rng3D2) + endif + ! Exponential or Exponential-random + if (iovr == iovr_exp .or. iovr == iovr_exprand) then + call sampled_mask(rng3D, cld_frac(idxday(iCol:iCol),:), maskMCICA, & + overlap_param = cloud_overlap_param(idxday(iCol:iCol),1:nLay-1)) + endif + ! Sampling. Map band optical depth to each g-point using McICA + call check_error_msg('rrtmgp_sw_main_cloud_sampling',& + draw_samples(maskMCICA, .true., & + sw_optical_props_cloudsByBand, sw_optical_props_clouds)) + + ! ################################################################################### + ! + ! Compute clear-sky fluxes (gaseous+aerosol) (optional) + ! + ! ################################################################################### + ! Add aerosol optics to gas optics + sw_optical_props_aerosol_local%tau = sw_optical_props_aerosol%tau(iCol:iCol,:,:) + sw_optical_props_aerosol_local%ssa = sw_optical_props_aerosol%ssa(iCol:iCol,:,:) + sw_optical_props_aerosol_local%g = sw_optical_props_aerosol%g(iCol:iCol,:,:) + call check_error_msg('rrtmgp_sw_main_increment_aerosol_to_clrsky',& + sw_optical_props_aerosol_local%increment(sw_optical_props_clrsky)) + + ! Delta-scale optical properties + call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_clrsky%delta_scale()) + if (doSWclrsky) then + call check_error_msg('rrtmgp_sw_main_rte_sw_clrsky',rte_sw( & + sw_optical_props_clrsky, & ! IN - optical-properties + top_at_1, & ! IN - veritcal ordering flag + coszen(idxday(iCol:iCol)), & ! IN - Cosine of solar zenith angle + toa_src_sw, & ! IN - incident solar flux at TOA + sfc_alb_dir, & ! IN - Shortwave surface albedo (direct) + sfc_alb_dif, & ! IN - Shortwave surface albedo (diffuse) + flux_clrsky)) ! OUT - Fluxes, clear-sky, 3D (1,nLay,nBand) + ! Store fluxes + fluxswUP_clrsky(idxday(iCol),:) = sum(flux_clrsky%bnd_flux_up(1,:,:),dim=2) + fluxswDOWN_clrsky(idxday(iCol),:) = sum(flux_clrsky%bnd_flux_dn(1,:,:),dim=2) + else + fluxswUP_clrsky(idxday(iCol),:) = 0.0 + fluxswDOWN_clrsky(idxday(iCol),:) = 0.0 + endif + + ! ################################################################################### + ! + ! All-sky fluxes (clear-sky + clouds + precipitation) + ! + ! ################################################################################### + + ! Include convective cloud? + if (doGP_sgs_cnv) then + call check_error_msg('rrtmgp_sw_main_increment_cnvclouds_to_clrsky',& + sw_optical_props_cnvcloudsByBand%increment(sw_optical_props_clouds)) + endif + + ! Include MYNN-EDMF PBL clouds? + if (doGP_sgs_pbl) then + call check_error_msg('rrtmgp_sw_main_increment_pblclouds_to_clrsky',& + sw_optical_props_pblcloudsByBand%increment(sw_optical_props_clouds)) + endif + + ! Add in precipitation + call check_error_msg('rrtmgp_sw_main_increment_precip_to_clrsky',& + sw_optical_props_precipByBand%increment(sw_optical_props_clouds)) + + ! Delta-scale optical properties + call check_error_msg('rrtmgp_sw_main_delta_scale',sw_optical_props_clrsky%delta_scale()) + call check_error_msg('rrtmgp_sw_main_rte_sw_allsky',rte_sw( & + sw_optical_props_clouds, & ! IN - optical-properties + top_at_1, & ! IN - veritcal ordering flag + coszen(idxday(iCol:iCol)), & ! IN - Cosine of solar zenith angle + toa_src_sw, & ! IN - incident solar flux at TOA + sfc_alb_dir, & ! IN - Shortwave surface albedo (direct) + sfc_alb_dif, & ! IN - Shortwave surface albedo (diffuse) + flux_allsky)) ! OUT - Fluxes, clear-sky, 3D (1,nLay,nBand) + + ! Store fluxes + fluxswUP_allsky(idxday(iCol),:) = sum(flux_allsky%bnd_flux_up(1,:,:),dim=2) + fluxswDOWN_allsky(idxday(iCol),:) = sum(flux_allsky%bnd_flux_dn(1,:,:),dim=2) + ! Near IR + scmpsw(idxday(iCol))%nirbm = sum(flux_allsky%bnd_flux_dn_dir(1,iSFC,1:ibd-1)) + & + flux_allsky%bnd_flux_dn_dir(1,iSFC,ibd)/2. + scmpsw(idxday(iCol))%nirdf = (sum(flux_allsky%bnd_flux_dn(1,iSFC,1:ibd-1)) + & + flux_allsky%bnd_flux_dn(1,iSFC,ibd)/2.) - & + (sum(flux_allsky%bnd_flux_dn_dir(1,iSFC,1:ibd-1)) + & + flux_allsky%bnd_flux_dn_dir(1,iSFC,ibd)/2.) + ! UV-VIS + scmpsw(idxday(iCol))%visbm = sum(flux_allsky%bnd_flux_dn_dir(1,iSFC,ibd+1:sw_gas_props%get_nband())) + & + flux_allsky%bnd_flux_dn_dir(1,iSFC,ibd)/2. + scmpsw(idxday(iCol))%visdf = (sum(flux_allsky%bnd_flux_dn(1,iSFC,ibd+1:sw_gas_props%get_nband())) + & + flux_allsky%bnd_flux_dn(1,iSFC,ibd)/2. ) - & + (sum(flux_allsky%bnd_flux_dn_dir(1,iSFC,ibd+1:sw_gas_props%get_nband())) + & + flux_allsky%bnd_flux_dn_dir(1,iSFC,ibd)/2.) + enddo + end subroutine rrtmgp_sw_main_run +end module rrtmgp_sw_main diff --git a/physics/rrtmgp_sw_main.meta b/physics/rrtmgp_sw_main.meta new file mode 100644 index 000000000..06f295230 --- /dev/null +++ b/physics/rrtmgp_sw_main.meta @@ -0,0 +1,618 @@ +[ccpp-table-properties] + name = rrtmgp_sw_main + type = scheme + dependencies = machine.F,radiation_tools.F90,GFS_rrtmgp_pre.F90,rte-rrtmgp/rrtmgp/mo_gas_optics_rrtmgp.F90 + dependencies = rte-rrtmgp/rte/mo_rte_kind.F90,rte-rrtmgp/rrtmgp/mo_gas_concentrations.F90,rte-rrtmgp/rte/mo_optical_props.F90 + dependencies = rte-rrtmgp/rte/mo_rte_sw.F90,rte-rrtmgp/rte/mo_fluxes.F90 + dependencies = rte-rrtmgp/rte/kernels/mo_fluxes_broadband_kernels.F90, rte-rrtmgp/rte/kernels/mo_rte_solver_kernels.F90 + dependencies = mersenne_twister.f,rrtmgp_sampling.F90,rte-rrtmgp/extensions/mo_fluxes_byband.F90 + dependencies = rrtmgp_sw_gas_optics.F90, rrtmgp_sw_cloud_optics.F90 + +######################################################################## +[ccpp-arg-table] + name = rrtmgp_sw_main_init + type = scheme +[rrtmgp_root_dir] + standard_name = directory_for_rte_rrtmgp_source_code + long_name = directory for rte+rrtmgp source code + units = none + dimensions = () + type = character + intent = in + kind = len=128 +[rrtmgp_sw_file_gas] + standard_name = filename_of_rrtmgp_shortwave_k_distribution + long_name = file containing RRTMGP SW k-distribution + units = none + dimensions = () + type = character + intent = in + kind = len=128 +[rrtmgp_sw_file_clouds] + standard_name = filename_of_rrtmgp_shortwave_cloud_optics_coefficients + long_name = file containing coefficients for RRTMGP SW cloud optics + units = none + dimensions = () + type = character + intent = in + kind = len=128 +[doG_cldoptics] + standard_name = flag_to_calc_lw_cld_optics_using_RRTMG + long_name = logical flag to control cloud optics scheme. + units = flag + dimensions = () + type = logical + intent = in +[doGP_cldoptics_PADE] + standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_PADE + long_name = logical flag to control cloud optics scheme. + units = flag + dimensions = () + type = logical + intent = in +[doGP_cldoptics_LUT] + standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_LUT + long_name = logical flag to control cloud optics scheme. + units = flag + dimensions = () + type = logical + intent = in +[nrghice] + standard_name = number_of_ice_roughness_categories + long_name = number of ice-roughness categories in RRTMGP calculation + units = count + dimensions = () + type = integer + intent = inout +[mpirank] + standard_name = mpi_rank + long_name = current MPI rank + units = index + dimensions = () + type = integer + intent = in +[mpiroot] + standard_name = mpi_root + long_name = master MPI rank + units = index + dimensions = () + type = integer + intent = in +[mpicomm] + standard_name = mpi_communicator + long_name = MPI communicator + units = index + dimensions = () + type = integer + intent = in +[active_gases_array] + standard_name = list_of_active_gases_used_by_RRTMGP + long_name = list of active gases used by RRTMGP + units = none + dimensions = (number_of_active_gases_used_by_RRTMGP) + type = character + kind = len=* + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out + +######################################################################## +[ccpp-arg-table] + name = rrtmgp_sw_main_run + type = scheme +[doSWrad] + standard_name = flag_for_calling_shortwave_radiation + long_name = logical flags for sw radiation calls + units = flag + dimensions = () + type = logical + intent = in +[doSWclrsky] + standard_name = flag_for_output_of_tendency_of_air_temperature_due_to_shortwave_heating_on_radiation_timestep_assuming_clear_sky + long_name = flag to output sw heating rate (Radtend%swhc) + units = flag + dimensions = () + type = logical + intent = in +[top_at_1] + standard_name = flag_for_vertical_ordering_in_RRTMGP + long_name = flag for vertical ordering in RRTMGP + units = flag + dimensions = () + type = logical + intent = in +[iSFC] + standard_name = vertical_index_for_surface_in_RRTMGP + long_name = index for surface layer in RRTMGP + units = flag + dimensions = () + type = integer + intent = in +[doGP_sgs_cnv] + standard_name = flag_to_include_sgs_convective_cloud_in_RRTMGP + long_name = logical flag to control sgs convective cloud in RRTMGP + units = flag + dimensions = () + type = logical + intent = in +[doGP_sgs_pbl] + standard_name = flag_to_include_sgs_MYNN_EDMF_cloud_in_RRTMGP + long_name = logical flag to control MYNN-EDMF PBL cloud in RRTMGP + units = flag + dimensions = () + type = logical + intent = in +[ncol] + standard_name = horizontal_loop_extent + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in +[nLay] + standard_name = vertical_layer_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in +[nday] + standard_name = daytime_points_dimension + long_name = daytime points dimension + units = count + dimensions = () + type = integer + intent = in +[idxday] + standard_name = daytime_points + long_name = daytime points + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[coszen] + standard_name = cosine_of_solar_zenith_angle_for_daytime_points_on_radiation_timestep + long_name = mean cos of zenith angle over rad call period + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[nGases] + standard_name = number_of_active_gases_used_by_RRTMGP + long_name = number of gases available used by RRTMGP (Model%nGases) + units = count + dimensions = () + type = integer + intent = in +[i_o3] + standard_name = index_of_ozone_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for ozone mixing ratio + units = index + dimensions = () + type = integer + intent = in +[isubc_sw] + standard_name = flag_for_sw_clouds_grid_approximation + long_name = flag for sw clouds sub-grid approximation + units = flag + dimensions = () + type = integer + intent = in +[iovr] + standard_name = flag_for_cloud_overlap_method_for_radiation + long_name = max-random overlap clouds + units = flag + dimensions = () + type = integer + intent = in +[iovr_maxrand] + standard_name = flag_for_maximum_random_cloud_overlap_method + long_name = choice of maximum-random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_dcorr] + standard_name = flag_for_decorrelation_length_cloud_overlap_method + long_name = choice of decorrelation-length cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_exp] + standard_name = flag_for_exponential_cloud_overlap_method + long_name = choice of exponential cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_exprand] + standard_name = flag_for_exponential_random_cloud_overlap_method + long_name = choice of exponential-random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_rand] + standard_name = flag_for_random_cloud_overlap_method + long_name = choice of random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_max] + standard_name = flag_for_maximum_cloud_overlap_method + long_name = choice of maximum cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_convcld] + standard_name = flag_for_convective_cloud_overlap_method_for_radiation + long_name = flag for convective cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[icseed_sw] + standard_name = random_number_seed_for_mcica_shortwave + long_name = seed for random number generation for shortwave radiation + units = none + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[p_lay] + standard_name = air_pressure_at_layer_for_RRTMGP + long_name = air pressure at vertical layer for radiation calculation + units = Pa + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[p_lev] + standard_name = air_pressure_at_interface_for_RRTMGP + long_name = air pressure at vertical interface for radiation calculation + units = Pa + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in +[t_lay] + standard_name = air_temperature_at_layer_for_RRTMGP + long_name = air temperature at vertical layer for radiation calculation + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[t_lev] + standard_name = air_temperature_at_interface_for_RRTMGP + long_name = air temperature at vertical interface for radiation calculation + units = K + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in +[vmr_o2] + standard_name = volume_mixing_ratio_for_o2 + long_name = molar mixing ratio of o2 in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[vmr_h2o] + standard_name = volume_mixing_ratio_for_h2o + long_name = molar mixing ratio of h2o in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[vmr_o3] + standard_name = volume_mixing_ratio_for_o3 + long_name = molar mixing ratio of o3 in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[vmr_ch4] + standard_name = volume_mixing_ratio_for_ch4 + long_name = molar mixing ratio of ch4 in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[vmr_n2o] + standard_name = volume_mixing_ratio_for_n2o + long_name = molar mixing ratio of n2o in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[vmr_co2] + standard_name = volume_mixing_ratio_for_co2 + long_name = molar mixing ratio of co2 in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_frac] + standard_name = total_cloud_fraction + long_name = layer total cloud fraction + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_lwp] + standard_name = cloud_liquid_water_path + long_name = layer cloud liquid water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_reliq] + standard_name = mean_effective_radius_for_liquid_cloud + long_name = mean effective radius for liquid cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_iwp] + standard_name = cloud_ice_water_path + long_name = layer cloud ice water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_reice] + standard_name = mean_effective_radius_for_ice_cloud + long_name = mean effective radius for ice cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_swp] + standard_name = cloud_snow_water_path + long_name = layer cloud snow water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_resnow] + standard_name = mean_effective_radius_for_snow_flake + long_name = mean effective radius for snow cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_rwp] + standard_name = cloud_rain_water_path + long_name = layer cloud rain water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_rerain] + standard_name = mean_effective_radius_for_rain_drop + long_name = mean effective radius for rain cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[precip_frac] + standard_name = precipitation_fraction_by_layer + long_name = precipitation fraction in each layer + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_cnv_lwp] + standard_name = convective_cloud_liquid_water_path + long_name = layer convective cloud liquid water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_cnv_iwp] + standard_name = convective_cloud_ice_water_path + long_name = layer convective cloud ice water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_cnv_reliq] + standard_name = mean_effective_radius_for_liquid_convective_cloud + long_name = mean effective radius for liquid convective cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_cnv_reice] + standard_name = mean_effective_radius_for_ice_convective_cloud + long_name = mean effective radius for ice convective cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_pbl_lwp] + standard_name = MYNN_SGS_cloud_liquid_water_path + long_name = layer convective cloud liquid water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_pbl_iwp] + standard_name = MYNN_SGS_cloud_ice_water_path + long_name = layer convective cloud ice water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_pbl_reliq] + standard_name = mean_effective_radius_for_liquid_MYNN_SGS_cloud + long_name = mean effective radius for liquid MYNN_SGS cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_pbl_reice] + standard_name = mean_effective_radius_for_ice_MYNN_SGS_cloud + long_name = mean effective radius for ice MYNN_SGS cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cloud_overlap_param] + standard_name = cloud_overlap_param + long_name = cloud overlap parameter + units = km + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[sfc_alb_nir_dir] + standard_name = surface_albedo_due_to_near_IR_direct + long_name = surface albedo due to near IR direct beam + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[sfc_alb_nir_dif] + standard_name = surface_albedo_due_to_near_IR_diffused + long_name = surface albedo due to near IR diffused beam + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[sfc_alb_uvvis_dir] + standard_name = surface_albedo_due_to_UV_and_VIS_direct + long_name = surface albedo due to UV+VIS direct beam + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[sfc_alb_uvvis_dif] + standard_name = surface_albedo_due_to_UV_and_VIS_diffused + long_name = surface albedo due to UV+VIS diffused beam + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[active_gases_array] + standard_name = list_of_active_gases_used_by_RRTMGP + long_name = list of active gases used by RRTMGP + units = none + dimensions = (number_of_active_gases_used_by_RRTMGP) + type = character + kind = len=* + intent = in +[sw_optical_props_aerosol] + standard_name = shortwave_optical_properties_for_aerosols + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = in +[scmpsw] + standard_name = components_of_surface_downward_shortwave_fluxes + long_name = derived type for special components of surface downward shortwave fluxes + units = W m-2 + dimensions = (horizontal_loop_extent) + type = cmpfsw_type + intent = inout +[fluxswUP_allsky] + standard_name = RRTMGP_sw_flux_profile_upward_allsky + long_name = RRTMGP upward shortwave all-sky flux profile + units = W m-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = inout +[fluxswDOWN_allsky] + standard_name = RRTMGP_sw_flux_profile_downward_allsky + long_name = RRTMGP downward shortwave all-sky flux profile + units = W m-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = inout +[fluxswUP_clrsky] + standard_name = RRTMGP_sw_flux_profile_upward_clrsky + long_name = RRTMGP upward shortwave clr-sky flux profile + units = W m-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = inout +[fluxswDOWN_clrsky] + standard_name = RRTMGP_sw_flux_profile_downward_clrsky + long_name = RRTMGP downward shortwave clr-sky flux profile + units = W m-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = inout +[cldtausw] + standard_name = cloud_optical_depth_layers_at_0p55mu_band + long_name = approx .55mu band layer cloud optical depth + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out diff --git a/physics/rrtmgp_sw_rte.F90 b/physics/rrtmgp_sw_rte.F90 deleted file mode 100644 index e1879bd7a..000000000 --- a/physics/rrtmgp_sw_rte.F90 +++ /dev/null @@ -1,221 +0,0 @@ -module rrtmgp_sw_rte - use machine, only: kind_phys - use mo_optical_props, only: ty_optical_props_2str - use mo_rte_sw, only: rte_sw - use mo_fluxes_byband, only: ty_fluxes_byband - use module_radsw_parameters, only: cmpfsw_type - use radiation_tools, only: check_error_msg - use rrtmgp_sw_gas_optics, only: sw_gas_props - implicit none - - public rrtmgp_sw_rte_init, rrtmgp_sw_rte_run, rrtmgp_sw_rte_finalize - -contains - - ! ######################################################################################### - ! SUBROUTINE rrtmgp_sw_rte_init - ! ######################################################################################### - subroutine rrtmgp_sw_rte_init() - end subroutine rrtmgp_sw_rte_init - - ! ######################################################################################### - ! SUBROUTINE rrtmgp_sw_rte_run - ! ######################################################################################### -!! \section arg_table_rrtmgp_sw_rte_run -!! \htmlinclude rrtmgp_sw_rte.html -!! - subroutine rrtmgp_sw_rte_run(doSWrad, doSWclrsky, nCol, nLev, nDay, idxday, coszen, p_lay,& - t_lay, top_at_1, doGP_sgs_cnv, doGP_sgs_mynn, iSFC, sfc_alb_nir_dir, sfc_alb_nir_dif,& - sfc_alb_uvvis_dir, sfc_alb_uvvis_dif, toa_src_sw, sw_optical_props_clrsky, & - sw_optical_props_clouds, sw_optical_props_precipByBand, & - sw_optical_props_cnvcloudsByBand, sw_optical_props_MYNNcloudsByBand, & - sw_optical_props_aerosol, scmpsw, fluxswUP_allsky, fluxswDOWN_allsky, & - fluxswUP_clrsky, fluxswDOWN_clrsky, errmsg, errflg) - - ! Inputs - logical, intent(in) :: & - top_at_1, & ! Vertical ordering flag - doGP_sgs_mynn, & ! Flag for MYNN-EDMF PBL cloud scheme - doGP_sgs_cnv, & ! Flag for sgs convective clouds scheme - doSWrad, & ! Flag to calculate SW irradiances - doSWclrsky ! Compute clear-sky fluxes? - integer, intent(in) :: & - nCol, & ! Number of horizontal gridpoints - nday, & ! Number of daytime points - nLev, & ! Number of vertical levels - iSFC ! Vertical index for surface-level - integer, intent(in), dimension(:) :: & - idxday ! Index array for daytime points - real(kind_phys),intent(in), dimension(:) :: & - sfc_alb_nir_dir, & ! Surface albedo (direct) - sfc_alb_nir_dif, & ! Surface albedo (diffuse) - sfc_alb_uvvis_dir, & ! Surface albedo (direct) - sfc_alb_uvvis_dif, & ! Surface albedo (diffuse) - coszen ! Cosize of SZA - real(kind_phys), dimension(:,:), intent(in) :: & - p_lay, & ! Pressure @ model layer-centers (Pa) - t_lay, & ! Temperature (K) - toa_src_sw ! TOA incident spectral flux (W/m2) - type(ty_optical_props_2str),intent(inout) :: & - sw_optical_props_clrsky ! RRTMGP DDT: shortwave clear-sky radiative properties - type(ty_optical_props_2str),intent(in) :: & - sw_optical_props_clouds, & ! RRTMGP DDT: shortwave cloud optical properties - sw_optical_props_cnvcloudsByBand, & ! RRTMGP DDT: shortwave convecive cloud optical properties - sw_optical_props_MYNNcloudsByBand, & ! RRTMGP DDT: shortwave MYNN-EDMF PBL cloud optical properties - sw_optical_props_precipByBand, & ! RRTMGP DDT: shortwave precipitation optical properties - sw_optical_props_aerosol ! RRTMGP DDT: shortwave aerosol optical properties - - ! Outputs - character(len=*), intent(out) :: & - errmsg ! CCPP error message - integer, intent(out) :: & - errflg ! CCPP error flag - real(kind_phys), dimension(:,:), intent(inout) :: & - fluxswUP_allsky, & ! RRTMGP upward all-sky flux profiles (W/m2) - fluxswDOWN_allsky, & ! RRTMGP downward all-sky flux profiles (W/m2) - fluxswUP_clrsky, & ! RRTMGP upward clear-sky flux profiles (W/m2) - fluxswDOWN_clrsky ! RRTMGP downward clear-sky flux profiles (W/m2) - type(cmpfsw_type), dimension(:), intent(inout) :: & - scmpsw ! 2D surface fluxes, components: - ! uvbfc - total sky downward uv-b flux (W/m2) - ! uvbf0 - clear sky downward uv-b flux (W/m2) - ! nirbm - downward nir direct beam flux (W/m2) - ! nirdf - downward nir diffused flux (W/m2) - ! visbm - downward uv+vis direct beam flux (W/m2) - ! visdf - downward uv+vis diffused flux (W/m2) - - ! Local variables - real(kind_phys), dimension(sw_gas_props%get_nband(),nday) :: & - sfc_alb_dir,sfc_alb_dif - type(ty_fluxes_byband) :: & - flux_allsky, & ! All-sky flux (W/m2) - flux_clrsky ! Clear-sky flux (W/m2) - real(kind_phys), dimension(nday,NLev+1,sw_gas_props%get_nband()),target :: & - fluxSW_up_allsky, fluxSW_up_clrsky, fluxSW_dn_allsky, fluxSW_dn_clrsky, fluxSW_dn_dir_allsky - real(kind_phys), dimension(ncol,NLev) :: vmrTemp - integer :: iBand, iDay,ibd - real(kind_phys), dimension(2,sw_gas_props%get_nband()) :: bandlimits - real(kind_phys), dimension(2), parameter :: nIR_uvvis_bnd = (/12850,16000/) - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (.not. doSWrad) return - - if (nDay .gt. 0) then - - ! Initialize RRTMGP DDT containing 2D(3D) fluxes - flux_allsky%bnd_flux_up => fluxSW_up_allsky - flux_allsky%bnd_flux_dn => fluxSW_dn_allsky - flux_allsky%bnd_flux_dn_dir => fluxSW_dn_dir_allsky - flux_clrsky%bnd_flux_up => fluxSW_up_clrsky - flux_clrsky%bnd_flux_dn => fluxSW_dn_clrsky - - ! Use near-IR albedo for bands with wavenumbers extending to 12850cm-1 - ! Use uv-vis albedo for bands with wavenumbers greater than 16000cm-1 - ! For overlapping band, average near-IR and us-vis albedos. - bandlimits = sw_gas_props%get_band_lims_wavenumber() - do iBand=1,sw_gas_props%get_nband() - if (bandlimits(1,iBand) .lt. nIR_uvvis_bnd(1)) then - sfc_alb_dir(iBand,:) = sfc_alb_nir_dir(idxday(1:nday)) - sfc_alb_dif(iBand,:) = sfc_alb_nir_dif(idxday(1:nday)) - endif - if (bandlimits(1,iBand) .eq. nIR_uvvis_bnd(1)) then - sfc_alb_dir(iBand,:) = 0.5_kind_phys*(sfc_alb_nir_dir(idxday(1:nday)) + sfc_alb_uvvis_dir(idxday(1:nday))) - sfc_alb_dif(iBand,:) = 0.5_kind_phys*(sfc_alb_nir_dif(idxday(1:nday)) + sfc_alb_uvvis_dif(idxday(1:nday))) - ibd = iBand - endif - if (bandlimits(1,iBand) .ge. nIR_uvvis_bnd(2)) then - sfc_alb_dir(iBand,:) = sfc_alb_uvvis_dir(idxday(1:nday)) - sfc_alb_dif(iBand,:) = sfc_alb_uvvis_dif(idxday(1:nday)) - endif - enddo - - ! - ! Compute clear-sky fluxes (if requested) - ! - - ! Clear-sky fluxes (gas+aerosol) - call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_aerosol%increment(sw_optical_props_clrsky)) - ! Delta-scale optical properties - call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_clrsky%delta_scale()) - if (doSWclrsky) then - call check_error_msg('rrtmgp_sw_rte_run',rte_sw( & - sw_optical_props_clrsky, & ! IN - optical-properties - top_at_1, & ! IN - veritcal ordering flag - coszen(idxday(1:nday)), & ! IN - Cosine of solar zenith angle - toa_src_sw(idxday(1:nday),:), & ! IN - incident solar flux at TOA - sfc_alb_dir, & ! IN - Shortwave surface albedo (direct) - sfc_alb_dif, & ! IN - Shortwave surface albedo (diffuse) - flux_clrsky)) ! OUT - Fluxes, clear-sky, 3D (nCol,NLev,nBand) - ! Store fluxes - fluxswUP_clrsky(idxday(1:nday),:) = sum(flux_clrsky%bnd_flux_up,dim=3) - fluxswDOWN_clrsky(idxday(1:nday),:) = sum(flux_clrsky%bnd_flux_dn,dim=3) - endif - - ! - ! Compute all-sky fluxes - ! - - ! Include convective cloud? - if (doGP_sgs_cnv) then - call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_cnvcloudsByBand%increment(sw_optical_props_clrsky)) - endif - - ! Include MYNN-EDMF PBL cloud? - if (doGP_sgs_mynn) then - call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_MYNNcloudsByBand%increment(sw_optical_props_clrsky)) - endif - - ! All-sky fluxes (clear-sky + clouds + precipitation) - call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_precipByBand%increment(sw_optical_props_clrsky)) - call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_clouds%increment(sw_optical_props_clrsky)) - - ! Delta-scale optical properties - call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_clrsky%delta_scale()) - call check_error_msg('rrtmgp_sw_rte_run',rte_sw( & - sw_optical_props_clrsky, & ! IN - optical-properties - top_at_1, & ! IN - veritcal ordering flag - coszen(idxday(1:nday)), & ! IN - Cosine of solar zenith angle - toa_src_sw(idxday(1:nday),:), & ! IN - incident solar flux at TOA - sfc_alb_dir, & ! IN - Shortwave surface albedo (direct) - sfc_alb_dif, & ! IN - Shortwave surface albedo (diffuse) - flux_allsky)) ! OUT - Fluxes, clear-sky, 3D (nCol,NLev,nBand) - - ! Store fluxes - fluxswUP_allsky(idxday(1:nday),:) = sum(flux_allsky%bnd_flux_up,dim=3) - fluxswDOWN_allsky(idxday(1:nday),:) = sum(flux_allsky%bnd_flux_dn,dim=3) - do iDay=1,nDay - ! Near IR - scmpsw(idxday(iDay))%nirbm = sum(flux_allsky%bnd_flux_dn_dir(iDay,iSFC,1:ibd-1)) + & - flux_allsky%bnd_flux_dn_dir(iDay,iSFC,ibd)/2. - scmpsw(idxday(iDay))%nirdf = (sum(flux_allsky%bnd_flux_dn(iDay,iSFC,1:ibd-1)) + & - flux_allsky%bnd_flux_dn(iDay,iSFC,ibd)/2.) - & - (sum(flux_allsky%bnd_flux_dn_dir(iDay,iSFC,1:ibd-1)) + & - flux_allsky%bnd_flux_dn_dir(iDay,iSFC,ibd)/2.) - ! UV-VIS - scmpsw(idxday(iDay))%visbm = sum(flux_allsky%bnd_flux_dn_dir(iDay,iSFC,ibd+1:sw_gas_props%get_nband())) + & - flux_allsky%bnd_flux_dn_dir(iDay,iSFC,ibd)/2. - scmpsw(idxday(iDay))%visdf = (sum(flux_allsky%bnd_flux_dn(iDay,iSFC,ibd+1:sw_gas_props%get_nband())) + & - flux_allsky%bnd_flux_dn(iDay,iSFC,ibd)/2. ) - & - (sum(flux_allsky%bnd_flux_dn_dir(iDay,iSFC,ibd+1:sw_gas_props%get_nband())) + & - flux_allsky%bnd_flux_dn_dir(iDay,iSFC,ibd)/2.) - enddo - else - fluxswUP_allsky(:,:) = 0._kind_phys - fluxswDOWN_allsky(:,:) = 0._kind_phys - fluxswUP_clrsky(:,:) = 0._kind_phys - fluxswDOWN_clrsky(:,:) = 0._kind_phys - scmpsw = cmpfsw_type( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 ) - endif - - end subroutine rrtmgp_sw_rte_run - - ! ######################################################################################### - ! SUBROUTINE rrtmgp_sw_rte_finalize - ! ######################################################################################### - subroutine rrtmgp_sw_rte_finalize() - end subroutine rrtmgp_sw_rte_finalize - -end module rrtmgp_sw_rte diff --git a/physics/rrtmgp_sw_rte.meta b/physics/rrtmgp_sw_rte.meta deleted file mode 100644 index 9ab24c8b3..000000000 --- a/physics/rrtmgp_sw_rte.meta +++ /dev/null @@ -1,240 +0,0 @@ -[ccpp-table-properties] - name = rrtmgp_sw_rte - type = scheme - dependencies = machine.F,radsw_param.f,rte-rrtmgp/rte/mo_rte_sw.F90,rte-rrtmgp/rte/mo_fluxes.F90,rte-rrtmgp/rte/kernels/mo_fluxes_broadband_kernels.F90,radiation_tools.F90 - dependencies = rte-rrtmgp/rte/kernels/mo_rte_solver_kernels.F90,rte-rrtmgp/extensions/mo_fluxes_byband.F90 - -######################################################################## -[ccpp-arg-table] - name = rrtmgp_sw_rte_run - type = scheme -[doSWrad] - standard_name = flag_for_calling_shortwave_radiation - long_name = flag to calculate SW irradiances - units = flag - dimensions = () - type = logical - intent = in -[doSWclrsky] - standard_name = flag_for_output_of_tendency_of_air_temperature_due_to_shortwave_heating_on_radiation_timestep_assuming_clear_sky - long_name = flag to output sw heating rate (Radtend%swhc) - units = flag - dimensions = () - type = logical - intent = in -[ncol] - standard_name = horizontal_loop_extent - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in -[nLev] - standard_name = vertical_layer_dimension - long_name = number of vertical levels - units = count - dimensions = () - type = integer - intent = in -[nday] - standard_name = daytime_points_dimension - long_name = daytime points dimension - units = count - dimensions = () - type = integer - intent = in -[idxday] - standard_name = daytime_points - long_name = daytime points - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = in -[coszen] - standard_name = cosine_of_solar_zenith_angle_for_daytime_points_on_radiation_timestep - long_name = mean cos of zenith angle over rad call period - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[p_lay] - standard_name = air_pressure_at_layer_for_RRTMGP - long_name = air pressure layer - units = Pa - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[top_at_1] - standard_name = flag_for_vertical_ordering_in_RRTMGP - long_name = flag for vertical ordering in RRTMGP - units = flag - dimensions = () - type = logical - intent = in -[doGP_sgs_cnv] - standard_name = flag_to_include_sgs_convective_cloud_in_RRTMGP - long_name = logical flag to control sgs convective cloud in RRTMGP - units = flag - dimensions = () - type = logical - intent = in -[doGP_sgs_mynn] - standard_name = flag_to_include_sgs_MYNN_EDMF_cloud_in_RRTMGP - long_name = logical flag to control MYNN-EDMF PBL cloud in RRTMGP - units = flag - dimensions = () - type = logical - intent = in -[iSFC] - standard_name = vertical_index_for_surface_in_RRTMGP - long_name = index for surface layer in RRTMGP - units = flag - dimensions = () - type = integer - intent = in -[t_lay] - standard_name = air_temperature_at_layer_for_RRTMGP - long_name = air temperature layer - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[sw_optical_props_clrsky] - standard_name = shortwave_optical_properties_for_clear_sky - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = inout -[sw_optical_props_clouds] - standard_name = shortwave_optical_properties_for_cloudy_atmosphere - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = in -[sw_optical_props_precipByBand] - standard_name = shortwave_optical_properties_for_precipitation_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = in -[sw_optical_props_cnvcloudsByBand] - standard_name = shortwave_optical_properties_for_convective_cloudy_atmosphere_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = in -[sw_optical_props_MYNNcloudsByBand] - standard_name = shortwave_optical_properties_for_MYNN_EDMF_PBL_cloudy_atmosphere_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = in -[sw_optical_props_aerosol] - standard_name = shortwave_optical_properties_for_aerosols - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = in -[sfc_alb_nir_dir] - standard_name = surface_albedo_due_to_near_IR_direct - long_name = surface albedo due to near IR direct beam - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[sfc_alb_nir_dif] - standard_name = surface_albedo_due_to_near_IR_diffused - long_name = surface albedo due to near IR diffused beam - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[sfc_alb_uvvis_dir] - standard_name = surface_albedo_due_to_UV_and_VIS_direct - long_name = surface albedo due to UV+VIS direct beam - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[sfc_alb_uvvis_dif] - standard_name = surface_albedo_due_to_UV_and_VIS_diffused - long_name = surface albedo due to UV+VIS diffused beam - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[toa_src_sw] - standard_name = toa_incident_sw_flux_by_spectral_point - long_name = TOA shortwave incident flux at each spectral points - units = W m-2 - dimensions = (horizontal_loop_extent,number_of_shortwave_spectral_points) - type = real - kind = kind_phys - intent = in -[scmpsw] - standard_name = components_of_surface_downward_shortwave_fluxes - long_name = derived type for special components of surface downward shortwave fluxes - units = W m-2 - dimensions = (horizontal_loop_extent) - type = cmpfsw_type - intent = inout -[fluxswUP_allsky] - standard_name = RRTMGP_sw_flux_profile_upward_allsky - long_name = RRTMGP upward shortwave all-sky flux profile - units = W m-2 - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = inout -[fluxswDOWN_allsky] - standard_name = RRTMGP_sw_flux_profile_downward_allsky - long_name = RRTMGP downward shortwave all-sky flux profile - units = W m-2 - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = inout -[fluxswUP_clrsky] - standard_name = RRTMGP_sw_flux_profile_upward_clrsky - long_name = RRTMGP upward shortwave clr-sky flux profile - units = W m-2 - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = inout -[fluxswDOWN_clrsky] - standard_name = RRTMGP_sw_flux_profile_downward_clrsky - long_name = RRTMGP downward shortwave clr-sky flux profile - units = W m-2 - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = inout -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out From 8c2382394c23e484f2211b479151d4ddbc8802ca Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Tue, 12 Apr 2022 04:17:07 +0000 Subject: [PATCH 003/380] Bug fixes. Working now. --- physics/GFS_rrtmgp_pre.F90 | 17 ++-- physics/GFS_rrtmgp_pre.meta | 2 +- physics/GFS_rrtmgp_sw_post.F90 | 2 +- physics/rrtmgp_aerosol_optics.F90 | 17 ++-- physics/rrtmgp_aerosol_optics.meta | 2 +- physics/rrtmgp_sw_main.F90 | 147 +++++++++++++++-------------- physics/rrtmgp_sw_main.meta | 2 +- 7 files changed, 94 insertions(+), 95 deletions(-) diff --git a/physics/GFS_rrtmgp_pre.F90 b/physics/GFS_rrtmgp_pre.F90 index 7804ecef7..d028917d5 100644 --- a/physics/GFS_rrtmgp_pre.F90 +++ b/physics/GFS_rrtmgp_pre.F90 @@ -22,7 +22,7 @@ module GFS_rrtmgp_pre integer :: iStr_h2o, iStr_co2, iStr_o3, iStr_n2o, iStr_ch4, iStr_o2, iStr_ccl4, & iStr_cfc11, iStr_cfc12, iStr_cfc22 - public GFS_rrtmgp_pre_run,GFS_rrtmgp_pre_init,GFS_rrtmgp_pre_finalize + public GFS_rrtmgp_pre_run,GFS_rrtmgp_pre_init contains ! ######################################################################################### @@ -32,6 +32,7 @@ module GFS_rrtmgp_pre !! \htmlinclude GFS_rrtmgp_pre_init.html !! subroutine GFS_rrtmgp_pre_init(nGases, active_gases, active_gases_array, errmsg, errflg) + implicit none ! Inputs integer, intent(in) :: & nGases ! Number of active gases in RRTMGP @@ -103,9 +104,11 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, lsswr, lslwr, fhswr, fhlwr, vmr_n2o, vmr_co2, tsfg, tsfa, qs_lay, q_lay, tv_lay, relhum, deltaZ, deltaZc, deltaP,& active_gases_array, tsfc_radtime, coszen, coszdg, top_at_1, iSFC, iTOA, nDay, idxday,& errmsg, errflg) - + implicit none + ! Inputs integer, intent(in) :: & + me, & ! nCol, & ! Number of horizontal grid points nLev, & ! Number of vertical layers i_o3 ! Index into tracer array for ozone @@ -191,7 +194,7 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, lsswr, lslwr, fhswr, fhlwr, errflg = 0 if (.not. (lsswr .or. lslwr)) return - + ! ####################################################################################### ! What is vertical ordering? ! ####################################################################################### @@ -367,7 +370,7 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, lsswr, lslwr, fhswr, fhlwr, do iCol = 1, nCol if (coszen(iCol) >= 0.0001) then nday = nday + 1 - idxday(nday) = i + idxday(nday) = iCol endif enddo else @@ -376,10 +379,4 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, lsswr, lslwr, fhswr, fhlwr, endif end subroutine GFS_rrtmgp_pre_run - - ! ######################################################################################### - ! SUBROUTINE GFS_rrtmgp_pre_finalize - ! ######################################################################################### - subroutine GFS_rrtmgp_pre_finalize () - end subroutine GFS_rrtmgp_pre_finalize end module GFS_rrtmgp_pre diff --git a/physics/GFS_rrtmgp_pre.meta b/physics/GFS_rrtmgp_pre.meta index 39cf198f6..cc1e84a92 100644 --- a/physics/GFS_rrtmgp_pre.meta +++ b/physics/GFS_rrtmgp_pre.meta @@ -503,7 +503,7 @@ units = index dimensions = (horizontal_loop_extent) type = integer - intent = out + intent = inout [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/GFS_rrtmgp_sw_post.F90 b/physics/GFS_rrtmgp_sw_post.F90 index fafa162d9..9d537b909 100644 --- a/physics/GFS_rrtmgp_sw_post.F90 +++ b/physics/GFS_rrtmgp_sw_post.F90 @@ -38,7 +38,7 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky nDay, & ! Number of daylit columns iSFC, & ! Vertical index for surface level iTOA ! Vertical index for TOA level - integer, intent(in), dimension(nday) :: & + integer, intent(in), dimension(:) :: & idxday ! Index array for daytime points logical, intent(in) :: & lsswr, & ! Call SW radiation? diff --git a/physics/rrtmgp_aerosol_optics.F90 b/physics/rrtmgp_aerosol_optics.F90 index 9c440a09e..fdf80c61a 100644 --- a/physics/rrtmgp_aerosol_optics.F90 +++ b/physics/rrtmgp_aerosol_optics.F90 @@ -38,7 +38,7 @@ subroutine rrtmgp_aerosol_optics_run(doSWrad, doLWrad, nCol, nLev, nTracer, nTra nLev, & ! Number of vertical layers nTracer, & ! Number of tracers nTracerAer ! Number of aerosol tracers - integer,intent(in),dimension(:) :: & + integer,dimension(:), intent(in) :: & idxday ! Indices for daylit points. real(kind_phys), dimension(:), intent(in) :: & lon, & ! Longitude @@ -61,7 +61,7 @@ subroutine rrtmgp_aerosol_optics_run(doSWrad, doLWrad, nCol, nLev, nTracer, nTra aerodp ! Vertical integrated optical depth for various aerosol species type(ty_optical_props_2str),intent(out) :: & sw_optical_props_aerosol ! RRTMGP DDT: Longwave aerosol optical properties (tau) - type(ty_optical_props_1scl),intent(inout) :: & + type(ty_optical_props_1scl),intent(out) :: & lw_optical_props_aerosol ! RRTMGP DDT: Longwave aerosol optical properties (tau) integer, intent(out) :: & errflg ! CCPP error flag @@ -79,14 +79,14 @@ subroutine rrtmgp_aerosol_optics_run(doSWrad, doLWrad, nCol, nLev, nTracer, nTra errmsg = '' errflg = 0 - if (.not. doSWrad) return + if (.not. (doSWrad .or. doLWrad)) return ! Call module_radiation_aerosols::setaer(),to setup aerosols property profile call setaer(p_lev*0.01, p_lay*0.01, p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, nCol, nLev, & nLev+1, .true., .true., aerosolssw2, aerosolslw, aerodp) ! Shortwave - if (nDay .gt. 0) then + if (doSWrad .and. (nDay .gt. 0)) then ! Store aerosol optical properties ! SW. ! For RRTMGP SW the bands are now ordered from [IR(band) -> nIR -> UV], in RRTMG the @@ -109,10 +109,11 @@ subroutine rrtmgp_aerosol_optics_run(doSWrad, doLWrad, nCol, nLev, nTracer, nTra endif ! Longwave - if (.not. doLWrad) return - call check_error_msg('rrtmgp_aerosol_optics_run',lw_optical_props_aerosol%alloc_1scl( & - nCol, nlev, lw_gas_props%get_band_lims_wavenumber())) - lw_optical_props_aerosol%tau = aerosolslw(:,:,:,1) * (1. - aerosolslw(:,:,:,2)) + if (doLWrad) then + call check_error_msg('rrtmgp_aerosol_optics_run',lw_optical_props_aerosol%alloc_1scl( & + nCol, nlev, lw_gas_props%get_band_lims_wavenumber())) + lw_optical_props_aerosol%tau = aerosolslw(:,:,:,1) * (1. - aerosolslw(:,:,:,2)) + endif end subroutine rrtmgp_aerosol_optics_run diff --git a/physics/rrtmgp_aerosol_optics.meta b/physics/rrtmgp_aerosol_optics.meta index cd7c77d4d..da2d79efb 100644 --- a/physics/rrtmgp_aerosol_optics.meta +++ b/physics/rrtmgp_aerosol_optics.meta @@ -164,7 +164,7 @@ units = DDT dimensions = () type = ty_optical_props_1scl - intent = inout + intent = out [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/rrtmgp_sw_main.F90 b/physics/rrtmgp_sw_main.F90 index fd8964c4d..2a66f592c 100644 --- a/physics/rrtmgp_sw_main.F90 +++ b/physics/rrtmgp_sw_main.F90 @@ -13,7 +13,6 @@ module rrtmgp_sw_main use rrtmgp_sw_gas_optics, only: sw_gas_props,rrtmgp_sw_gas_optics_init use rrtmgp_sw_cloud_optics, only: sw_cloud_props, rrtmgp_sw_cloud_optics_init, a0r, a0s, & a1s, b0r, b0s, b1s, c0r, c0s - use module_radiation_gases, only: NF_VGAS, getgases, getozn use GFS_rrtmgp_pre, only: iStr_h2o, iStr_co2, iStr_o3, iStr_n2o, iStr_ch4, & iStr_o2, iStr_ccl4, iStr_cfc11, iStr_cfc12, iStr_cfc22 use mersenne_twister, only: random_setseed, random_number, random_stat @@ -77,7 +76,7 @@ end subroutine rrtmgp_sw_main_init !! \htmlinclude rrtmgp_sw_main_run.html !! subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_sgs_pbl, & - nCol, nDay, nLay, nGases, i_o3, idxday, icseed_sw, iovr, iovr_convcld, iovr_max, & + nCol, nDay, nLay, nGases, i_o3, idx, icseed_sw, iovr, iovr_convcld, iovr_max, & iovr_maxrand, iovr_rand, iovr_dcorr, iovr_exp, iovr_exprand, isubc_sw, iSFC, & sfc_alb_nir_dir, sfc_alb_nir_dif, sfc_alb_uvvis_dir, sfc_alb_uvvis_dif, coszen, & p_lay, p_lev, t_lay, t_lev, vmr_o2, vmr_h2o, vmr_o3, vmr_ch4, vmr_n2o, vmr_co2, & @@ -111,7 +110,7 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ isubc_sw, & ! iSFC integer,intent(in),dimension(:) :: & - idxday, & ! Index array for daytime points + idx, & ! Index array for daytime points icseed_sw ! Seed for random number generation for shortwave radiation real(kind_phys), dimension(:), intent(in) :: & sfc_alb_nir_dir, & ! Surface albedo (direct) @@ -200,7 +199,7 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ sfc_alb_dir, sfc_alb_dif real(kind_phys), dimension(1,nLay+1,sw_gas_props%get_nband()),target :: & fluxSW_up_allsky, fluxSW_up_clrsky, fluxSW_dn_allsky, fluxSW_dn_clrsky, fluxSW_dn_dir_allsky - integer :: iBand, ibd, iCol, iGas, iLay, ipseed_sw + integer :: iBand, ibd, iCol, iGas, iLay, ipseed_sw, ix type(random_stat) :: rng_stat real(kind_phys), dimension(2,sw_gas_props%get_nband()) :: bandlimits real(kind_phys), dimension(2), parameter :: nIR_uvvis_bnd = (/12850,16000/) @@ -267,6 +266,8 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ ! Loop over all (daylit)columns... do iCol=1,nDay + ix = idx(iCol) + ! Initialize/reset sw_optical_props_clouds%tau = 0._kind_phys sw_optical_props_clouds%ssa = 1._kind_phys @@ -299,12 +300,12 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ ! Set gas-concentrations ! ! ################################################################################### - gas_concentrations%concs(istr_o2)%conc(1,:) = vmr_o2(idxday(iCol),:) - gas_concentrations%concs(istr_co2)%conc(1,:) = vmr_co2(idxday(iCol),:) - gas_concentrations%concs(istr_ch4)%conc(1,:) = vmr_ch4(idxday(iCol),:) - gas_concentrations%concs(istr_n2o)%conc(1,:) = vmr_n2o(idxday(iCol),:) - gas_concentrations%concs(istr_h2o)%conc(1,:) = vmr_h2o(idxday(iCol),:) - gas_concentrations%concs(istr_o3)%conc(1,:) = vmr_o3(idxday(iCol),:) + gas_concentrations%concs(istr_o2)%conc(1,:) = vmr_o2(ix,:) + gas_concentrations%concs(istr_co2)%conc(1,:) = vmr_co2(ix,:) + gas_concentrations%concs(istr_ch4)%conc(1,:) = vmr_ch4(ix,:) + gas_concentrations%concs(istr_n2o)%conc(1,:) = vmr_n2o(ix,:) + gas_concentrations%concs(istr_h2o)%conc(1,:) = vmr_h2o(ix,:) + gas_concentrations%concs(istr_o3)%conc(1,:) = vmr_o3(ix,:) ! ################################################################################### ! @@ -318,17 +319,17 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ bandlimits = sw_gas_props%get_band_lims_wavenumber() do iBand=1,sw_gas_props%get_nband() if (bandlimits(1,iBand) .lt. nIR_uvvis_bnd(1)) then - sfc_alb_dir(iBand,1) = sfc_alb_nir_dir(idxday(iCol)) - sfc_alb_dif(iBand,1) = sfc_alb_nir_dif(idxday(iCol)) + sfc_alb_dir(iBand,1) = sfc_alb_nir_dir(ix) + sfc_alb_dif(iBand,1) = sfc_alb_nir_dif(ix) endif if (bandlimits(1,iBand) .eq. nIR_uvvis_bnd(1)) then - sfc_alb_dir(iBand,1) = 0.5_kind_phys*(sfc_alb_nir_dir(idxday(iCol)) + sfc_alb_uvvis_dir(idxday(iCol))) - sfc_alb_dif(iBand,1) = 0.5_kind_phys*(sfc_alb_nir_dif(idxday(iCol)) + sfc_alb_uvvis_dif(idxday(iCol))) + sfc_alb_dir(iBand,1) = 0.5_kind_phys*(sfc_alb_nir_dir(ix) + sfc_alb_uvvis_dir(ix)) + sfc_alb_dif(iBand,1) = 0.5_kind_phys*(sfc_alb_nir_dif(ix) + sfc_alb_uvvis_dif(ix)) ibd = iBand endif if (bandlimits(1,iBand) .ge. nIR_uvvis_bnd(2)) then - sfc_alb_dir(iBand,1) = sfc_alb_uvvis_dir(idxday(iCol)) - sfc_alb_dif(iBand,1) = sfc_alb_uvvis_dif(idxday(iCol)) + sfc_alb_dir(iBand,1) = sfc_alb_uvvis_dir(ix) + sfc_alb_dif(iBand,1) = sfc_alb_uvvis_dif(ix) endif enddo @@ -338,13 +339,13 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ ! ! ################################################################################### call check_error_msg('rrtmgp_sw_main_gas_optics',sw_gas_props%gas_optics(& - p_lay(idxday(iCol:iCol),:), & ! IN - Pressure @ layer-centers (Pa) - p_lev(idxday(iCol:iCol),:), & ! IN - Pressure @ layer-interfaces (Pa) - t_lay(idxday(iCol:iCol),:), & ! IN - Temperature @ layer-centers (K) - gas_concentrations, & ! IN - RRTMGP DDT: trace gas volumne mixing-ratios - sw_optical_props_clrsky, & ! OUT - RRTMGP DDT: Shortwave optical properties, by - ! spectral point (tau,ssa,g) - toa_src_sw)) ! OUT - TOA incident shortwave radiation (spectral) + p_lay(ix:ix,:), & ! IN - Pressure @ layer-centers (Pa) + p_lev(ix:ix,:), & ! IN - Pressure @ layer-interfaces (Pa) + t_lay(ix:ix,:), & ! IN - Temperature @ layer-centers (K) + gas_concentrations, & ! IN - RRTMGP DDT: trace gas volumne mixing-ratios + sw_optical_props_clrsky, & ! OUT - RRTMGP DDT: Shortwave optical properties, by + ! spectral point (tau,ssa,g) + toa_src_sw)) ! OUT - TOA incident shortwave radiation (spectral) ! ################################################################################### ! @@ -352,23 +353,23 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ ! ! ################################################################################### call check_error_msg('rrtmgp_sw_main_cloud_optics',sw_cloud_props%cloud_optics(& - cld_lwp(idxday(iCol:iCol),:), & ! IN - Cloud liquid water path - cld_iwp(idxday(iCol:iCol),:), & ! IN - Cloud ice water path - cld_reliq(idxday(iCol:iCol),:), & ! IN - Cloud liquid effective radius - cld_reice(idxday(iCol:iCol),:), & ! IN - Cloud ice effective radius - sw_optical_props_cloudsByBand)) ! OUT - RRTMGP DDT: Shortwave optical properties, - ! in each band (tau,ssa,g) - cldtausw(idxday(iCol),:) = sw_optical_props_cloudsByBand%tau(1,:,11) + cld_lwp(ix:ix,:), & ! IN - Cloud liquid water path + cld_iwp(ix:ix,:), & ! IN - Cloud ice water path + cld_reliq(ix:ix,:), & ! IN - Cloud liquid effective radius + cld_reice(ix:ix,:), & ! IN - Cloud ice effective radius + sw_optical_props_cloudsByBand)) ! OUT - RRTMGP DDT: Shortwave optical properties, + ! in each band (tau,ssa,g) + cldtausw(ix,:) = sw_optical_props_cloudsByBand%tau(1,:,11) ! Convective cloud-optics? if (doGP_sgs_cnv) then call check_error_msg('rrtmgp_sw_main_cnv_cloud_optics',sw_cloud_props%cloud_optics(& - cld_cnv_lwp(idxday(iCol:iCol),:), & ! IN - Convective cloud liquid water path (g/m2) - cld_cnv_iwp(idxday(iCol:iCol),:), & ! IN - Convective cloud ice water path (g/m2) - cld_cnv_reliq(idxday(iCol:iCol),:), & ! IN - Convective cloud liquid effective radius (microns) - cld_cnv_reice(idxday(iCol:iCol),:), & ! IN - Convective cloud ice effective radius (microns) - sw_optical_props_cnvcloudsByBand)) ! OUT - RRTMGP DDT containing convective cloud radiative properties - ! in each band + cld_cnv_lwp(ix:ix,:), & ! IN - Convective cloud liquid water path (g/m2) + cld_cnv_iwp(ix:ix,:), & ! IN - Convective cloud ice water path (g/m2) + cld_cnv_reliq(ix:ix,:), & ! IN - Convective cloud liquid effective radius (microns) + cld_cnv_reice(ix:ix,:), & ! IN - Convective cloud ice effective radius (microns) + sw_optical_props_cnvcloudsByBand)) ! OUT - RRTMGP DDT containing convective cloud radiative properties + ! in each band !call check_error_msg('rrtmgp_sw_main_increment_cnvclouds_to_clouds',& ! sw_optical_props_cnvcloudsByBand%increment(sw_optical_props_cloudsByBand)) endif @@ -376,23 +377,23 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ ! MYNN PBL cloud-optics? if (doGP_sgs_pbl) then call check_error_msg('rrtmgp_sw_main_pbl_cloud_optics',sw_cloud_props%cloud_optics(& - cld_pbl_lwp(idxday(iCol:iCol),:), & ! IN - MYNN-EDMF PBL cloud liquid water path (g/m2) - cld_pbl_iwp(idxday(iCol:iCol),:), & ! IN - MYNN-EDMF PBL cloud ice water path (g/m2) - cld_pbl_reliq(idxday(iCol:iCol),:), & ! IN - MYNN-EDMF PBL cloud liquid effective radius (microns) - cld_pbl_reice(idxday(iCol:iCol),:), & ! IN - MYNN-EDMF PBL cloud ice effective radius (microns) - sw_optical_props_pblcloudsByBand)) ! OUT - RRTMGP DDT containing MYNN-EDMF PBL cloud radiative properties - ! in each band + cld_pbl_lwp(ix:ix,:), & ! IN - MYNN-EDMF PBL cloud liquid water path (g/m2) + cld_pbl_iwp(ix:ix,:), & ! IN - MYNN-EDMF PBL cloud ice water path (g/m2) + cld_pbl_reliq(ix:ix,:), & ! IN - MYNN-EDMF PBL cloud liquid effective radius (microns) + cld_pbl_reice(ix:ix,:), & ! IN - MYNN-EDMF PBL cloud ice effective radius (microns) + sw_optical_props_pblcloudsByBand)) ! OUT - RRTMGP DDT containing MYNN-EDMF PBL cloud radiative properties + ! in each band !call check_error_msg('rrtmgp_sw_main_increment_pblclouds_to_clouds',& ! sw_optical_props_pblcloudsByBand%increment(sw_optical_props_cloudsByBand)) endif ! Cloud precipitation optics: rain and snow(+groupel) do iLay=1,nLay - if (cld_frac(idxday(iCol),iLay) .gt. 1.e-12_kind_phys) then + if (cld_frac(ix,iLay) .gt. 1.e-12_kind_phys) then ! Rain/Snow optical depth (No band dependence) - tau_rain = cld_rwp(idxday(iCol),iLay)*a0r - if (cld_swp(idxday(iCol),iLay) .gt. 0. .and. cld_resnow(idxday(iCol),iLay) .gt. 10._kind_phys) then - tau_snow = cld_swp(idxday(iCol),iLay)*1.09087*(a0s + a1s/(1.0315*cld_resnow(idxday(iCol),iLay))) ! fu's formula + tau_rain = cld_rwp(ix,iLay)*a0r + if (cld_swp(ix,iLay) .gt. 0. .and. cld_resnow(ix,iLay) .gt. 10._kind_phys) then + tau_snow = cld_swp(ix,iLay)*1.09087*(a0s + a1s/(1.0315*cld_resnow(ix,iLay))) ! fu's formula else tau_snow = 0._kind_phys endif @@ -402,7 +403,7 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ ! By species ssa_rain = tau_rain*(1.-b0r(iBand)) asy_rain = ssa_rain*c0r(iBand) - ssa_snow = tau_snow*(1.-(b0s(iBand)+b1s(iBand)*1.0315*cld_resnow(idxday(iCol),iLay))) + ssa_snow = tau_snow*(1.-(b0s(iBand)+b1s(iBand)*1.0315*cld_resnow(ix,iLay))) asy_snow = ssa_snow*c0s(iBand) ! Combine tau_prec = max(1.e-12_kind_phys, tau_rain + tau_snow) @@ -428,7 +429,7 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ if(isubc_sw == 1) then ! advance prescribed permutation seed ipseed_sw = sw_gas_props%get_ngpt() + iCol elseif (isubc_sw == 2) then ! use input array of permutaion seeds - ipseed_sw = icseed_sw(idxday(iCol)) + ipseed_sw = icseed_sw(ix) endif ! Call RNG call random_setseed(ipseed_sw,rng_stat) @@ -447,7 +448,7 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ ! Cloud-overlap. ! Maximum-random, random or maximum. if (iovr == iovr_maxrand .or. iovr == iovr_rand .or. iovr == iovr_max) then - call sampled_mask(rng3D, cld_frac(idxday(iCol:iCol),:), maskMCICA) + call sampled_mask(rng3D, cld_frac(ix:ix,:), maskMCICA) endif ! Exponential decorrelation length overlap if (iovr == iovr_dcorr) then @@ -456,13 +457,13 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ call random_number(rng2D,rng_stat) rng3D2(:,:,1) = reshape(source = rng2D,shape=[sw_gas_props%get_ngpt(),nLay]) ! - call sampled_mask(rng3D, cld_frac(idxday(iCol:iCol),:), maskMCICA, & - overlap_param = cloud_overlap_param(idxday(iCol:iCol),1:nLay-1), randoms2 = rng3D2) + call sampled_mask(rng3D, cld_frac(ix:ix,:), maskMCICA, & + overlap_param = cloud_overlap_param(ix:ix,1:nLay-1), randoms2 = rng3D2) endif ! Exponential or Exponential-random if (iovr == iovr_exp .or. iovr == iovr_exprand) then - call sampled_mask(rng3D, cld_frac(idxday(iCol:iCol),:), maskMCICA, & - overlap_param = cloud_overlap_param(idxday(iCol:iCol),1:nLay-1)) + call sampled_mask(rng3D, cld_frac(ix:ix,:), maskMCICA, & + overlap_param = cloud_overlap_param(ix:ix,1:nLay-1)) endif ! Sampling. Map band optical depth to each g-point using McICA call check_error_msg('rrtmgp_sw_main_cloud_sampling',& @@ -487,17 +488,17 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ call check_error_msg('rrtmgp_sw_main_rte_sw_clrsky',rte_sw( & sw_optical_props_clrsky, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag - coszen(idxday(iCol:iCol)), & ! IN - Cosine of solar zenith angle + coszen(ix:ix), & ! IN - Cosine of solar zenith angle toa_src_sw, & ! IN - incident solar flux at TOA sfc_alb_dir, & ! IN - Shortwave surface albedo (direct) sfc_alb_dif, & ! IN - Shortwave surface albedo (diffuse) flux_clrsky)) ! OUT - Fluxes, clear-sky, 3D (1,nLay,nBand) ! Store fluxes - fluxswUP_clrsky(idxday(iCol),:) = sum(flux_clrsky%bnd_flux_up(1,:,:),dim=2) - fluxswDOWN_clrsky(idxday(iCol),:) = sum(flux_clrsky%bnd_flux_dn(1,:,:),dim=2) + fluxswUP_clrsky(ix,:) = sum(flux_clrsky%bnd_flux_up(1,:,:),dim=2) + fluxswDOWN_clrsky(ix,:) = sum(flux_clrsky%bnd_flux_dn(1,:,:),dim=2) else - fluxswUP_clrsky(idxday(iCol),:) = 0.0 - fluxswDOWN_clrsky(idxday(iCol),:) = 0.0 + fluxswUP_clrsky(ix,:) = 0.0 + fluxswDOWN_clrsky(ix,:) = 0.0 endif ! ################################################################################### @@ -527,29 +528,29 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ call check_error_msg('rrtmgp_sw_main_rte_sw_allsky',rte_sw( & sw_optical_props_clouds, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag - coszen(idxday(iCol:iCol)), & ! IN - Cosine of solar zenith angle + coszen(ix:ix), & ! IN - Cosine of solar zenith angle toa_src_sw, & ! IN - incident solar flux at TOA sfc_alb_dir, & ! IN - Shortwave surface albedo (direct) sfc_alb_dif, & ! IN - Shortwave surface albedo (diffuse) flux_allsky)) ! OUT - Fluxes, clear-sky, 3D (1,nLay,nBand) ! Store fluxes - fluxswUP_allsky(idxday(iCol),:) = sum(flux_allsky%bnd_flux_up(1,:,:),dim=2) - fluxswDOWN_allsky(idxday(iCol),:) = sum(flux_allsky%bnd_flux_dn(1,:,:),dim=2) + fluxswUP_allsky(ix,:) = sum(flux_allsky%bnd_flux_up(1,:,:),dim=2) + fluxswDOWN_allsky(ix,:) = sum(flux_allsky%bnd_flux_dn(1,:,:),dim=2) ! Near IR - scmpsw(idxday(iCol))%nirbm = sum(flux_allsky%bnd_flux_dn_dir(1,iSFC,1:ibd-1)) + & - flux_allsky%bnd_flux_dn_dir(1,iSFC,ibd)/2. - scmpsw(idxday(iCol))%nirdf = (sum(flux_allsky%bnd_flux_dn(1,iSFC,1:ibd-1)) + & - flux_allsky%bnd_flux_dn(1,iSFC,ibd)/2.) - & - (sum(flux_allsky%bnd_flux_dn_dir(1,iSFC,1:ibd-1)) + & - flux_allsky%bnd_flux_dn_dir(1,iSFC,ibd)/2.) + scmpsw(ix)%nirbm = sum(flux_allsky%bnd_flux_dn_dir(1,iSFC,1:ibd-1)) + & + flux_allsky%bnd_flux_dn_dir(1,iSFC,ibd)/2. + scmpsw(ix)%nirdf = (sum(flux_allsky%bnd_flux_dn(1,iSFC,1:ibd-1)) + & + flux_allsky%bnd_flux_dn(1,iSFC,ibd)/2.) - & + (sum(flux_allsky%bnd_flux_dn_dir(1,iSFC,1:ibd-1)) + & + flux_allsky%bnd_flux_dn_dir(1,iSFC,ibd)/2.) ! UV-VIS - scmpsw(idxday(iCol))%visbm = sum(flux_allsky%bnd_flux_dn_dir(1,iSFC,ibd+1:sw_gas_props%get_nband())) + & - flux_allsky%bnd_flux_dn_dir(1,iSFC,ibd)/2. - scmpsw(idxday(iCol))%visdf = (sum(flux_allsky%bnd_flux_dn(1,iSFC,ibd+1:sw_gas_props%get_nband())) + & - flux_allsky%bnd_flux_dn(1,iSFC,ibd)/2. ) - & - (sum(flux_allsky%bnd_flux_dn_dir(1,iSFC,ibd+1:sw_gas_props%get_nband())) + & - flux_allsky%bnd_flux_dn_dir(1,iSFC,ibd)/2.) + scmpsw(ix)%visbm = sum(flux_allsky%bnd_flux_dn_dir(1,iSFC,ibd+1:sw_gas_props%get_nband())) + & + flux_allsky%bnd_flux_dn_dir(1,iSFC,ibd)/2. + scmpsw(ix)%visdf = (sum(flux_allsky%bnd_flux_dn(1,iSFC,ibd+1:sw_gas_props%get_nband())) + & + flux_allsky%bnd_flux_dn(1,iSFC,ibd)/2. ) - & + (sum(flux_allsky%bnd_flux_dn_dir(1,iSFC,ibd+1:sw_gas_props%get_nband())) + & + flux_allsky%bnd_flux_dn_dir(1,iSFC,ibd)/2.) enddo end subroutine rrtmgp_sw_main_run end module rrtmgp_sw_main diff --git a/physics/rrtmgp_sw_main.meta b/physics/rrtmgp_sw_main.meta index 06f295230..1be643701 100644 --- a/physics/rrtmgp_sw_main.meta +++ b/physics/rrtmgp_sw_main.meta @@ -176,7 +176,7 @@ dimensions = () type = integer intent = in -[idxday] +[idx] standard_name = daytime_points long_name = daytime points units = index From 0532ca3d5ce2ae1ee4dfc491b7f07e411fb27c27 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Tue, 12 Apr 2022 22:17:17 +0000 Subject: [PATCH 004/380] Some more cleanup. --- physics/GFS_rrtmgp_cloud_mp.meta | 6 +++--- physics/rrtmgp_aerosol_optics.F90 | 6 ++---- physics/rrtmgp_aerosol_optics.meta | 20 +++----------------- physics/rrtmgp_lw_main.F90 | 14 +++++++------- physics/rrtmgp_sw_main.F90 | 14 ++++++-------- 5 files changed, 21 insertions(+), 39 deletions(-) diff --git a/physics/GFS_rrtmgp_cloud_mp.meta b/physics/GFS_rrtmgp_cloud_mp.meta index 88530d84c..88a050abb 100644 --- a/physics/GFS_rrtmgp_cloud_mp.meta +++ b/physics/GFS_rrtmgp_cloud_mp.meta @@ -338,9 +338,9 @@ kind = kind_phys intent = inout [tracer] - standard_name = chemical_tracers - long_name = chemical tracers - units = g g-1 + standard_name = tracer_concentration + long_name = model layer mean tracer concentration + units = kg kg-1 dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) type = real kind = kind_phys diff --git a/physics/rrtmgp_aerosol_optics.F90 b/physics/rrtmgp_aerosol_optics.F90 index fdf80c61a..6d3d36f57 100644 --- a/physics/rrtmgp_aerosol_optics.F90 +++ b/physics/rrtmgp_aerosol_optics.F90 @@ -24,7 +24,7 @@ module rrtmgp_aerosol_optics !! \section arg_table_rrtmgp_aerosol_optics_run !! \htmlinclude rrtmgp_aerosol_optics_run.html !! - subroutine rrtmgp_aerosol_optics_run(doSWrad, doLWrad, nCol, nLev, nTracer, nTracerAer, & + subroutine rrtmgp_aerosol_optics_run(doSWrad, doLWrad, nCol, nLev, & nDay, idxday, p_lev, p_lay, p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, & aerodp, sw_optical_props_aerosol, lw_optical_props_aerosol, errmsg, errflg ) @@ -35,9 +35,7 @@ subroutine rrtmgp_aerosol_optics_run(doSWrad, doLWrad, nCol, nLev, nTracer, nTra integer, intent(in) :: & nCol, & ! Number of horizontal grid points nDay, & ! Number of daylit points - nLev, & ! Number of vertical layers - nTracer, & ! Number of tracers - nTracerAer ! Number of aerosol tracers + nLev ! Number of vertical layers integer,dimension(:), intent(in) :: & idxday ! Indices for daylit points. real(kind_phys), dimension(:), intent(in) :: & diff --git a/physics/rrtmgp_aerosol_optics.meta b/physics/rrtmgp_aerosol_optics.meta index da2d79efb..61074cdff 100644 --- a/physics/rrtmgp_aerosol_optics.meta +++ b/physics/rrtmgp_aerosol_optics.meta @@ -35,20 +35,6 @@ dimensions = () type = integer intent = in -[nTracer] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in -[nTracerAer] - standard_name = number_of_aerosol_tracers_MG - long_name = number of aerosol tracers for Morrison Gettelman MP - units = count - dimensions = () - type = integer - intent = in [nday] standard_name = daytime_points_dimension long_name = daytime points dimension @@ -112,9 +98,9 @@ kind = kind_phys intent = in [tracer] - standard_name = chemical_tracers - long_name = chemical tracers - units = g g-1 + standard_name = tracer_concentration + long_name = model layer mean tracer concentration + units = kg kg-1 dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) type = real kind = kind_phys diff --git a/physics/rrtmgp_lw_main.F90 b/physics/rrtmgp_lw_main.F90 index 0b55d9831..f45a5d07e 100644 --- a/physics/rrtmgp_lw_main.F90 +++ b/physics/rrtmgp_lw_main.F90 @@ -284,13 +284,13 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, use_LW ! ! ################################################################################### ! Assign same emissivity to all band - if (semis(iCol) > 1e-6 .and. semis(iCol) <= 1.0) then - do iBand=1,lw_gas_props%get_nband() - sfc_emiss_byband(iBand,1) = semis(iCol) - enddo - else - sfc_emiss_byband(1:lw_gas_props%get_nband(),1) = 1.0 - endif + !if (semis(iCol) > 1e-6 .and. semis(iCol) <= 1.0) then + do iBand=1,lw_gas_props%get_nband() + sfc_emiss_byband(iBand,1) = semis(iCol) + enddo + !else + ! sfc_emiss_byband(1:lw_gas_props%get_nband(),1) = 1.0 + !endif ! ################################################################################### ! diff --git a/physics/rrtmgp_sw_main.F90 b/physics/rrtmgp_sw_main.F90 index 2a66f592c..781af606b 100644 --- a/physics/rrtmgp_sw_main.F90 +++ b/physics/rrtmgp_sw_main.F90 @@ -209,14 +209,12 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ errflg = 0 if (.not. doSWrad) return - if (nDay .le. 0) then - fluxswUP_allsky(:,:) = 0._kind_phys - fluxswDOWN_allsky(:,:) = 0._kind_phys - fluxswUP_clrsky(:,:) = 0._kind_phys - fluxswDOWN_clrsky(:,:) = 0._kind_phys - scmpsw = cmpfsw_type( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 ) - return - endif + fluxswUP_allsky(:,:) = 0._kind_phys + fluxswDOWN_allsky(:,:) = 0._kind_phys + fluxswUP_clrsky(:,:) = 0._kind_phys + fluxswDOWN_clrsky(:,:) = 0._kind_phys + scmpsw = cmpfsw_type( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 ) + if (nDay .le. 0) return ! ###################################################################################### ! From 9345505a251524693dcab23ac1095efb9044359a Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Thu, 21 Apr 2022 22:57:17 +0000 Subject: [PATCH 005/380] Longwave RRTMGP loop over ncol working. --- physics/GFS_rrtmgp_pre.F90 | 81 ++-- physics/GFS_rrtmgp_pre.meta | 90 ++-- physics/rrtmgp_lw_cloud_optics.F90 | 3 - physics/rrtmgp_lw_gas_optics.F90 | 7 - physics/rrtmgp_lw_main.F90 | 321 +++++++------ physics/rrtmgp_lw_main.meta | 77 +-- physics/rrtmgp_sw_cloud_optics.F90 | 189 +++++++- physics/rrtmgp_sw_cloud_optics.meta | 393 +++++++++++++++ physics/rrtmgp_sw_cloud_sampling.F90 | 170 +++++++ physics/rrtmgp_sw_cloud_sampling.meta | 240 ++++++++++ physics/rrtmgp_sw_gas_optics.F90 | 115 ++++- physics/rrtmgp_sw_gas_optics.meta | 201 ++++++++ physics/rrtmgp_sw_main.F90 | 663 +++++++++++++------------- physics/rrtmgp_sw_main.meta | 29 +- physics/rrtmgp_sw_rte.F90 | 221 +++++++++ physics/rrtmgp_sw_rte.meta | 240 ++++++++++ 16 files changed, 2384 insertions(+), 656 deletions(-) create mode 100644 physics/rrtmgp_sw_cloud_optics.meta create mode 100644 physics/rrtmgp_sw_cloud_sampling.F90 create mode 100644 physics/rrtmgp_sw_cloud_sampling.meta create mode 100644 physics/rrtmgp_sw_gas_optics.meta create mode 100644 physics/rrtmgp_sw_rte.F90 create mode 100644 physics/rrtmgp_sw_rte.meta diff --git a/physics/GFS_rrtmgp_pre.F90 b/physics/GFS_rrtmgp_pre.F90 index d028917d5..e0046f61e 100644 --- a/physics/GFS_rrtmgp_pre.F90 +++ b/physics/GFS_rrtmgp_pre.F90 @@ -9,7 +9,10 @@ module GFS_rrtmgp_pre NF_VGAS, & ! Number of active gas species getgases, & ! Routine to setup trace gases getozn ! Routine to setup ozone + ! RRTMGP types + use mo_gas_concentrations, only: ty_gas_concs use radiation_tools, only: check_error_msg,cmp_tlev + use rrtmgp_lw_gas_optics, only: lw_gas_props real(kind_phys), parameter :: & amd = 28.9644_kind_phys, & ! Molecular weight of dry-air (g/mol) @@ -32,7 +35,6 @@ module GFS_rrtmgp_pre !! \htmlinclude GFS_rrtmgp_pre_init.html !! subroutine GFS_rrtmgp_pre_init(nGases, active_gases, active_gases_array, errmsg, errflg) - implicit none ! Inputs integer, intent(in) :: & nGases ! Number of active gases in RRTMGP @@ -97,20 +99,19 @@ end subroutine GFS_rrtmgp_pre_init !> \section arg_table_GFS_rrtmgp_pre_run !! \htmlinclude GFS_rrtmgp_pre_run.html !! - subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, lsswr, lslwr, fhswr, fhlwr, & + subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhswr, fhlwr, & xlat, xlon, prsl, tgrs, prslk, prsi, qgrs, tsfc, coslat, sinlat, con_g, con_rd, & con_eps, con_epsm1, con_fvirt, con_epsqs, solhr, minGPpres, maxGPpres, minGPtemp, & - maxGPtemp, raddt, p_lay, t_lay, p_lev, t_lev, vmr_o2, vmr_h2o, vmr_o3, vmr_ch4, & - vmr_n2o, vmr_co2, tsfg, tsfa, qs_lay, q_lay, tv_lay, relhum, deltaZ, deltaZc, deltaP,& - active_gases_array, tsfc_radtime, coszen, coszdg, top_at_1, iSFC, iTOA, nDay, idxday,& - errmsg, errflg) - implicit none - + maxGPtemp, raddt, p_lay, t_lay, p_lev, t_lev, tsfg, tsfa, qs_lay, q_lay, tv_lay, & + relhum, tracer, deltaZ, deltaZc, deltaP, active_gases_array, gas_concentrations, & + tsfc_radtime, coszen, coszdg, top_at_1, iSFC, iTOA, semis, sfc_emiss_byband, errmsg, & + errflg) + ! Inputs integer, intent(in) :: & - me, & ! nCol, & ! Number of horizontal grid points nLev, & ! Number of vertical layers + nTracers, & ! Number of tracers from model. i_o3 ! Index into tracer array for ozone logical, intent(in) :: & lsswr, & ! Call SW radiation? @@ -135,7 +136,8 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, lsswr, lslwr, fhswr, fhlwr, xlat, & ! Latitude tsfc, & ! Surface skin temperature (K) coslat, & ! Cosine(latitude) - sinlat ! Sine(latitude) + sinlat, & ! Sine(latitude) + semis real(kind_phys), dimension(:,:), intent(in) :: & prsl, & ! Pressure at model-layer centers (Pa) tgrs, & ! Temperature at model-layer centers (K) @@ -152,8 +154,7 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, lsswr, lslwr, fhswr, fhlwr, integer, intent(out) :: & errflg, & ! Error flag iSFC, & ! Vertical index for surface - iTOA, & ! Vertical index for TOA - nDay + iTOA ! Vertical index for TOA logical, intent(out) :: & top_at_1 ! Vertical ordering flag real(kind_phys), intent(inout) :: & @@ -164,8 +165,6 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, lsswr, lslwr, fhswr, fhlwr, tsfc_radtime, & ! Surface temperature at radiation timestep coszen, & ! Cosine of SZA coszdg ! Cosine of SZA, daytime - integer, dimension(:), intent(out) :: & - idxday ! Indices for daylit points real(kind_phys), dimension(:,:), intent(inout) :: & p_lay, & ! Pressure at model-layer t_lay, & ! Temperature at model layer @@ -177,11 +176,16 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, lsswr, lslwr, fhswr, fhlwr, deltaZc, & ! Layer thickness (m) (between layer centers) deltaP, & ! Layer thickness (Pa) p_lev, & ! Pressure at model-interface - t_lev, & ! Temperature at model-interface - vmr_o2, vmr_h2o, vmr_o3, vmr_ch4, vmr_n2o, vmr_co2 + sfc_emiss_byband, & ! + t_lev ! Temperature at model-interface + real(kind_phys), dimension(:,:,:),intent(inout) :: & + tracer ! Array containing trace gases + type(ty_gas_concs), intent(inout) :: & + gas_concentrations ! RRTMGP DDT: gas volumne mixing ratios ! Local variables integer :: i, j, iCol, iBand, iLay, iLev, iSFC_ilev + real(kind_phys),dimension(nCol,nLev) :: vmr_o3, vmr_h2o real(kind_phys) :: es, tem1, tem2, pfac real(kind_phys), dimension(nLev+1) :: hgtb real(kind_phys), dimension(nLev) :: hgtc @@ -194,7 +198,7 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, lsswr, lslwr, fhswr, fhlwr, errflg = 0 if (.not. (lsswr .or. lslwr)) return - + ! ####################################################################################### ! What is vertical ordering? ! ####################################################################################### @@ -323,10 +327,16 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, lsswr, lslwr, fhswr, fhlwr, ! ####################################################################################### ! Get layer ozone mass mixing ratio ! ####################################################################################### + ! First recast remaining all tracers (except sphum) forcing them all to be positive + do j = 2, nTracers + tracer(1:NCOL,:,j) = qgrs(1:NCOL,:,j) + where(tracer(:,:,j) .lt. 0.0) tracer(:,:,j) = 0._kind_phys + enddo + if (i_o3 > 0) then do iLay=1,nlev do iCol=1,NCOL - o3_lay(iCol,iLay) = max( con_epsqs, qgrs(iCol,iLay,i_o3) ) + o3_lay(iCol,iLay) = max( con_epsqs, tracer(iCol,iLay,i_o3) ) enddo enddo ! OR Use climatological ozone data @@ -339,14 +349,21 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, lsswr, lslwr, fhswr, fhlwr, ! ####################################################################################### ! Call getgases(), to set up non-prognostic gas volume mixing ratios (gas_vmr). call getgases (p_lev/100., xlon, xlat, nCol, nLev, gas_vmr) - vmr_o2 = gas_vmr(:,:,4) - vmr_ch4 = gas_vmr(:,:,3) - vmr_n2o = gas_vmr(:,:,2) - vmr_co2 = gas_vmr(:,:,1) ! Compute volume mixing-ratios for ozone (mmr) and specific-humidity. vmr_h2o = merge((q_lay/(1-q_lay))*amdw, 0., q_lay .ne. 1.) vmr_o3 = merge(o3_lay*amdo3, 0., o3_lay .gt. 0.) + + ! Populate RRTMGP DDT w/ gas-concentrations + gas_concentrations%ncol = nCol + gas_concentrations%nlay = nLev + gas_concentrations%gas_name(:) = active_gases_array(:) + gas_concentrations%concs(istr_o2)%conc(:,:) = gas_vmr(:,:,4) + gas_concentrations%concs(istr_co2)%conc(:,:) = gas_vmr(:,:,1) + gas_concentrations%concs(istr_ch4)%conc(:,:) = gas_vmr(:,:,3) + gas_concentrations%concs(istr_n2o)%conc(:,:) = gas_vmr(:,:,2) + gas_concentrations%concs(istr_h2o)%conc(:,:) = vmr_h2o(:,:) + gas_concentrations%concs(istr_o3)%conc(:,:) = vmr_o3(:,:) ! ####################################################################################### ! Radiation time step (output) (Is this really needed?) (Used by some diagnostics) @@ -364,19 +381,15 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, lsswr, lslwr, fhswr, fhlwr, ! ####################################################################################### if (lsswr) then call coszmn (xlon, sinlat, coslat, solhr, nCol, me, coszen, coszdg) - ! For SW gather daylit points - nday = 0 - idxday = 0 - do iCol = 1, nCol - if (coszen(iCol) >= 0.0001) then - nday = nday + 1 - idxday(nday) = iCol - endif - enddo - else - nday = 0 - idxday = 0 endif + ! ####################################################################################### + ! Surface emissivity + ! ####################################################################################### + do iBand=1,lw_gas_props%get_nband() + sfc_emiss_byband(iBand,:) = semis + enddo + end subroutine GFS_rrtmgp_pre_run + end module GFS_rrtmgp_pre diff --git a/physics/GFS_rrtmgp_pre.meta b/physics/GFS_rrtmgp_pre.meta index cc1e84a92..4992f4ef8 100644 --- a/physics/GFS_rrtmgp_pre.meta +++ b/physics/GFS_rrtmgp_pre.meta @@ -72,6 +72,13 @@ dimensions = () type = integer intent = in +[nTracers] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in [lsswr] standard_name = flag_for_calling_shortwave_radiation long_name = logical flags for sw radiation calls @@ -418,51 +425,11 @@ type = real kind = kind_phys intent = inout -[vmr_o2] - standard_name = volume_mixing_ratio_for_o2 - long_name = molar mixing ratio of o2 in with respect to dry air - units = 1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[vmr_h2o] - standard_name = volume_mixing_ratio_for_h2o - long_name = molar mixing ratio of h2o in with respect to dry air - units = 1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[vmr_o3] - standard_name = volume_mixing_ratio_for_o3 - long_name = molar mixing ratio of o3 in with respect to dry air - units = 1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[vmr_ch4] - standard_name = volume_mixing_ratio_for_ch4 - long_name = molar mixing ratio of ch4 in with respect to dry air - units = 1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[vmr_n2o] - standard_name = volume_mixing_ratio_for_n2o - long_name = molar mixing ratio of n2o in with respect to dry air - units = 1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[vmr_co2] - standard_name = volume_mixing_ratio_for_co2 - long_name = molar mixing ratio of co2 in with respect to dry air - units = 1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) +[tracer] + standard_name = chemical_tracers + long_name = chemical tracers + units = g g-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) type = real kind = kind_phys intent = inout @@ -474,6 +441,13 @@ type = character kind = len=* intent = in +[gas_concentrations] + standard_name = Gas_concentrations_for_RRTMGP_suite + long_name = DDT containing gas concentrations for RRTMGP radiation scheme + units = DDT + dimensions = () + type = ty_gas_concs + intent = inout [coszdg] standard_name = cosine_of_solar_zenith_angle_on_radiation_timestep long_name = daytime mean cosz over rad call period @@ -490,19 +464,21 @@ type = real kind = kind_phys intent = inout -[nday] - standard_name = daytime_points_dimension - long_name = daytime points dimension - units = count - dimensions = () - type = integer - intent = inout -[idxday] - standard_name = daytime_points - long_name = daytime points - units = index +[semis] + standard_name = surface_longwave_emissivity + long_name = surface lw emissivity in fraction + units = frac dimensions = (horizontal_loop_extent) - type = integer + type = real + kind = kind_phys + intent = in +[sfc_emiss_byband] + standard_name = surface_emissivity_in_each_RRTMGP_LW_band + long_name = surface emissivity in each RRTMGP LW band + units = none + dimensions = (number_of_longwave_bands,horizontal_loop_extent) + type = real + kind = kind_phys intent = inout [errmsg] standard_name = ccpp_error_message diff --git a/physics/rrtmgp_lw_cloud_optics.F90 b/physics/rrtmgp_lw_cloud_optics.F90 index 37d7e697f..d50900aab 100644 --- a/physics/rrtmgp_lw_cloud_optics.F90 +++ b/physics/rrtmgp_lw_cloud_optics.F90 @@ -65,9 +65,6 @@ module rrtmgp_lw_cloud_optics ! ###################################################################################### ! SUBROUTINE rrtmgp_lw_cloud_optics_init() ! ###################################################################################### -!! \section arg_table_rrtmgp_lw_cloud_optics_init -!! \htmlinclude rrtmgp_lw_cloud_optics.html -!! subroutine rrtmgp_lw_cloud_optics_init(nrghice, mpicomm, mpirank, mpiroot, & doG_cldoptics, doGP_cldoptics_PADE, doGP_cldoptics_LUT, rrtmgp_root_dir, & rrtmgp_lw_file_clouds, errmsg, errflg) diff --git a/physics/rrtmgp_lw_gas_optics.F90 b/physics/rrtmgp_lw_gas_optics.F90 index d198a5859..8f9e9f24c 100644 --- a/physics/rrtmgp_lw_gas_optics.F90 +++ b/physics/rrtmgp_lw_gas_optics.F90 @@ -3,11 +3,7 @@ module rrtmgp_lw_gas_optics use mo_rte_kind, only: wl use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp use mo_gas_concentrations, only: ty_gas_concs - use mo_source_functions, only: ty_source_func_lw - use mo_optical_props, only: ty_optical_props_1scl use radiation_tools, only: check_error_msg - use GFS_rrtmgp_pre, only: iStr_h2o, iStr_co2, iStr_o3, iStr_n2o, iStr_ch4, & - iStr_o2, iStr_ccl4, iStr_cfc11, iStr_cfc12, iStr_cfc22 use netcdf #ifdef MPI use mpi @@ -73,9 +69,6 @@ module rrtmgp_lw_gas_optics ! ######################################################################################### ! SUBROUTINE rrtmgp_lw_gas_optics_init ! ######################################################################################### -!! \section arg_table_rrtmgp_lw_gas_optics_init -!! \htmlinclude rrtmgp_lw_gas_optics_init.html -!! subroutine rrtmgp_lw_gas_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, mpicomm, & mpirank, mpiroot, minGPpres, maxGPpres, minGPtemp, maxGPtemp, active_gases_array, & errmsg, errflg) diff --git a/physics/rrtmgp_lw_main.F90 b/physics/rrtmgp_lw_main.F90 index f45a5d07e..b58e5a45d 100644 --- a/physics/rrtmgp_lw_main.F90 +++ b/physics/rrtmgp_lw_main.F90 @@ -1,5 +1,11 @@ -! ########################################################################################### -! ########################################################################################### +! ###################################################################################### +!> \file rrtmgp_lw_main.F90 +!! +!> \defgroup rrtmgp_lw_main rrtmgp_lw_main.F90 +!! +!! \brief This module contains the longwave RRTMGP radiation scheme. +!! +! ###################################################################################### module rrtmgp_lw_main use machine, only: kind_phys use mo_optical_props, only: ty_optical_props_1scl, ty_optical_props_2str @@ -11,10 +17,10 @@ module rrtmgp_lw_main use mo_source_functions, only: ty_source_func_lw use radiation_tools, only: check_error_msg use rrtmgp_lw_gas_optics, only: lw_gas_props,rrtmgp_lw_gas_optics_init - use rrtmgp_lw_cloud_optics, only: lw_cloud_props, rrtmgp_lw_cloud_optics_init, abssnow0, & - abssnow1,absrain + use rrtmgp_lw_cloud_optics, only: lw_cloud_props, rrtmgp_lw_cloud_optics_init, & + abssnow0, abssnow1, absrain use module_radiation_gases, only: NF_VGAS, getgases, getozn - use GFS_rrtmgp_pre, only: iStr_h2o, iStr_co2, iStr_o3, iStr_n2o, iStr_ch4, & + use GFS_rrtmgp_pre, only: iStr_h2o, iStr_co2, iStr_o3, iStr_n2o, iStr_ch4, & iStr_o2, iStr_ccl4, iStr_cfc11, iStr_cfc12, iStr_cfc22 use mersenne_twister, only: random_setseed, random_number, random_stat use rrtmgp_sampling, only: sampled_mask, draw_samples @@ -22,17 +28,21 @@ module rrtmgp_lw_main public rrtmgp_lw_main_init, rrtmgp_lw_main_run contains - - ! ######################################################################################### - ! SUBROUTINE rrtmgp_lw_main_init - ! ######################################################################################### + ! ###################################################################################### !! \section arg_table_rrtmgp_lw_main_init !! \htmlinclude rrtmgp_lw_main_int.html !! - subroutine rrtmgp_lw_main_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, mpicomm, mpirank, & - mpiroot, minGPpres, maxGPpres, minGPtemp, maxGPtemp, active_gases_array, nrghice, & - doG_cldoptics, doGP_cldoptics_PADE, doGP_cldoptics_LUT,rrtmgp_lw_file_clouds, errmsg,& - errflg) +!> \ingroup rrtmgp_lw_main +!! +!! \brief +!! +!! \section rrtmgp_lw_main_init +!> @{ + ! ###################################################################################### + subroutine rrtmgp_lw_main_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, mpicomm, mpirank, & + mpiroot, minGPpres, maxGPpres, minGPtemp, maxGPtemp, active_gases_array, nrghice, & + doG_cldoptics, doGP_cldoptics_PADE, doGP_cldoptics_LUT, rrtmgp_lw_file_clouds, & + errmsg, errflg) ! Inputs logical, intent(in) :: & @@ -43,8 +53,10 @@ subroutine rrtmgp_lw_main_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, mpicomm, mpi nrghice ! Number of ice-roughness categories character(len=128),intent(in) :: & rrtmgp_root_dir, & ! RTE-RRTMGP root directory - rrtmgp_lw_file_clouds, & ! RRTMGP file containing coefficients used to compute clouds optical properties - rrtmgp_lw_file_gas ! RRTMGP file containing coefficients used to compute gaseous optical properties + rrtmgp_lw_file_clouds, & ! RRTMGP file containing coefficients used to compute + ! clouds optical properties + rrtmgp_lw_file_gas ! RRTMGP file containing coefficients used to compute + ! gaseous optical properties integer,intent(in) :: & mpicomm, & ! MPI communicator mpirank, & ! Current MPI rank @@ -67,32 +79,37 @@ subroutine rrtmgp_lw_main_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, mpicomm, mpi errflg = 0 ! RRTMGP longwave gas-optics (k-distribution) initialization - call rrtmgp_lw_gas_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, mpicomm, mpirank, & - mpiroot, minGPpres, maxGPpres, minGPtemp, maxGPtemp, active_gases_array, errmsg, & + call rrtmgp_lw_gas_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, mpicomm, mpirank,& + mpiroot, minGPpres, maxGPpres, minGPtemp, maxGPtemp, active_gases_array, errmsg,& errflg) ! RRTMGP longwave cloud-optics initialization - call rrtmgp_lw_cloud_optics_init(nrghice, mpicomm, mpirank, mpiroot, doG_cldoptics, & - doGP_cldoptics_PADE, doGP_cldoptics_LUT, rrtmgp_root_dir, rrtmgp_lw_file_clouds, & + call rrtmgp_lw_cloud_optics_init(nrghice, mpicomm, mpirank, mpiroot, doG_cldoptics, & + doGP_cldoptics_PADE, doGP_cldoptics_LUT, rrtmgp_root_dir, rrtmgp_lw_file_clouds,& errmsg, errflg) end subroutine rrtmgp_lw_main_init - - ! ######################################################################################### - ! SUBROUTINE rrtmgp_lw_main_run - ! ######################################################################################### +!> @} + ! ###################################################################################### !! \section arg_table_rrtmgp_lw_main_run !! \htmlinclude rrtmgp_lw_main_run.html !! - subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, use_LW_jacobian,& - doGP_sgs_cnv, doGP_sgs_pbl, nCol, nLay, nGases, nGauss_angles, i_o3, icseed_lw, iovr,& - iovr_convcld, iovr_max, iovr_maxrand, iovr_rand, iovr_dcorr, iovr_exp, iovr_exprand, & - isubc_lw, semis, tsfg, p_lay, p_lev, t_lay, t_lev, vmr_o2, vmr_h2o, vmr_o3, vmr_ch4, & - vmr_n2o, vmr_co2, cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, & - cld_resnow, cld_rwp, cld_rerain, precip_frac, cld_cnv_lwp, cld_cnv_reliq, & - cld_cnv_iwp, cld_cnv_reice, cld_pbl_lwp, cld_pbl_reliq, cld_pbl_iwp, cld_pbl_reice, & - cloud_overlap_param, active_gases_array, lw_optical_props_aerosol, & - fluxlwUP_allsky, fluxlwDOWN_allsky, fluxlwUP_clrsky, fluxlwDOWN_clrsky, fluxlwUP_jac,& +!> \ingroup rrtmgp_lw_main +!! +!! \brief +!! +!! \section rrtmgp_lw_main_run +!> @{ + ! ###################################################################################### + subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, & + use_LW_jacobian, doGP_sgs_cnv, doGP_sgs_pbl, nCol, nLay, nGauss_angles, icseed_lw,& + iovr, iovr_convcld, iovr_max, iovr_maxrand, iovr_rand, iovr_dcorr, iovr_exp, & + iovr_exprand, isubc_lw, semis, tsfg, p_lay, p_lev, t_lay, t_lev, cld_frac, & + cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, cld_rerain, & + precip_frac, cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, cld_cnv_reice, cld_pbl_lwp, & + cld_pbl_reliq, cld_pbl_iwp, cld_pbl_reice, cloud_overlap_param, sfc_emiss_byband, & + active_gases_array, lw_optical_props_aerosol, gas_concentrations, fluxlwUP_allsky,& + fluxlwDOWN_allsky, fluxlwUP_clrsky, fluxlwDOWN_clrsky, fluxlwUP_jac, & fluxlwUP_radtime, fluxlwDOWN_radtime, errmsg, errflg) ! Inputs @@ -107,9 +124,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, use_LW integer,intent(in) :: & nCol, & ! Number of horizontal points nLay, & ! Number of vertical grid points. - nGases, & ! Number of active gases in RRTMGP nGauss_angles, & ! - i_o3, & ! iovr, & ! Choice of cloud-overlap method iovr_convcld, & ! Choice of convective cloud-overlap iovr_max, & ! Flag for maximum cloud overlap method @@ -129,12 +144,6 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, use_LW t_lay, & ! Temperature (K) p_lev, & ! Pressure @ model layer-interfaces (Pa) t_lev, & ! Temperature @ model levels (K) - vmr_o2, & ! Molar-mixing ratio oxygen - vmr_h2o, & ! Molar-mixing ratio water vapor - vmr_o3, & ! Molar-mixing ratio ozone - vmr_ch4, & ! Molar-mixing ratio methane - vmr_n2o, & ! Molar-mixing ratio nitrous oxide - vmr_co2, & ! Molar-mixing ratio carbon dioxide cld_frac, & ! Cloud-fraction for stratiform clouds cld_lwp, & ! Water path for stratiform liquid cloud-particles cld_reliq, & ! Effective radius for stratiform liquid cloud-particles @@ -153,12 +162,14 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, use_LW cld_pbl_reliq, & ! Effective radius for SGS PBL liquid cloud-particles cld_pbl_iwp, & ! Water path for SGS PBL ice cloud-particles cld_pbl_reice, & ! Effective radius for SGS PBL ice cloud-particles + sfc_emiss_byband, & ! cloud_overlap_param character(len=*), dimension(:), intent(in) :: & active_gases_array ! List of active gases from namelist as array type(ty_optical_props_1scl),intent(inout) :: & lw_optical_props_aerosol ! RRTMGP DDT: Longwave aerosol optical properties (tau) - + type(ty_gas_concs), intent(in) :: & + gas_concentrations ! RRTMGP DDT: ! Outputs real(kind_phys), dimension(:,:), intent(inout) :: & fluxlwUP_jac, & ! Jacobian of upwelling LW surface radiation (W/m2/K) @@ -175,16 +186,16 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, use_LW ! Local variables type(ty_gas_concs) :: & - gas_concentrations ! RRTMGP DDT: trace gas concentrations (vmr) + gas_concs ! RRTMGP DDT: trace gas concentrations (vmr) type(ty_optical_props_1scl) :: & lw_optical_props_clrsky, & ! RRTMGP DDT: longwave clear-sky radiative properties - lw_optical_props_aerosol_local, & ! RRTMGP DDT: longwave aerosol radiative properties + lw_optical_props_aerosol_local ! RRTMGP DDT: longwave aerosol radiative properties + type(ty_optical_props_2str) :: & + lw_optical_props_clouds, & ! RRTMGP DDT: Longwave optical properties in each band (sampled clouds) lw_optical_props_cloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (clouds) lw_optical_props_cnvcloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (convective cloud) - lw_optical_props_pblcloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (PBL cloud) - lw_optical_props_precipByBand ! RRTMGP DDT: Longwave optical properties in each band (precipitation) - type(ty_optical_props_2str) :: & - lw_optical_props_clouds ! RRTMGP DDT: Longwave optical properties in each band (sampled clouds) + lw_optical_props_pblcloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (PBL cloud) + lw_optical_props_precipByBand ! RRTMGP DDT: Longwave optical properties in each band (precipitation) type(ty_source_func_lw) :: & sources ! RRTMGP DDT: longwave source functions type(ty_fluxes_byband) :: & @@ -199,7 +210,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, use_LW real(kind_phys), dimension(1,nLay+1,lw_gas_props%get_nband()),target :: & fluxLW_up_allsky, fluxLW_up_clrsky, fluxLW_dn_allsky, fluxLW_dn_clrsky real(kind_phys), dimension(1,lw_gas_props%get_ngpt()) :: lw_Ds - real(kind_phys), dimension(lw_gas_props%get_nband(),1) :: sfc_emiss_byband + real(kind_phys), dimension(nCol, nLay,gas_concentrations%get_num_gases()) :: vmrTemp ! Initialize CCPP error handling variables errmsg = '' @@ -207,6 +218,8 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, use_LW if (.not. doLWrad) return + fluxlwUP_clrsky(:,:) = 0._kind_phys + fluxlwDOWN_clrsky(:,:) = 0._kind_phys ! ###################################################################################### ! ! Allocate/initialize RRTMGP DDT's @@ -215,14 +228,18 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, use_LW ! ! ty_gas_concs ! - gas_concentrations%ncol = 1 - gas_concentrations%nlay = nLay - allocate(gas_concentrations%gas_name(nGases)) - allocate(gas_concentrations%concs(nGases)) - do iGas=1,nGases - allocate(gas_concentrations%concs(iGas)%conc(1, nLay)) + gas_concs%ncol = 1 + gas_concs%nlay = nLay + allocate(gas_concs%gas_name(gas_concentrations%get_num_gases())) + allocate(gas_concs%concs(gas_concentrations%get_num_gases())) + do iGas=1,gas_concentrations%get_num_gases() + allocate(gas_concs%concs(iGas)%conc(1, nLay)) + enddo + gas_concs%gas_name(:) = active_gases_array(:) + do iGas=1,gas_concentrations%get_num_gases() + call check_error_msg('rrtmgp_lw_main_get_vmr',& + gas_concentrations%get_vmr(trim(gas_concentrations%gas_name(iGas)),vmrTemp(:,:,iGas))) enddo - gas_concentrations%gas_name(:) = active_gases_array(:) ! ! ty_optical_props ! @@ -231,66 +248,63 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, use_LW call check_error_msg('rrtmgp_lw_main_sources_init',& sources%alloc(1, nLay, lw_gas_props)) call check_error_msg('rrtmgp_lw_main_cloud_optics_init',& - lw_optical_props_cloudsByBand%alloc_1scl(1, nLay, lw_gas_props%get_band_lims_wavenumber())) + lw_optical_props_cloudsByBand%alloc_2str(1, nLay, lw_gas_props%get_band_lims_wavenumber())) call check_error_msg('rrtmgp_lw_main_precip_optics_init',& - lw_optical_props_precipByBand%alloc_1scl(1, nLay, lw_gas_props%get_band_lims_wavenumber())) + lw_optical_props_precipByBand%alloc_2str(1, nLay, lw_gas_props%get_band_lims_wavenumber())) call check_error_msg('rrtmgp_lw_mian_cloud_sampling_init', & lw_optical_props_clouds%alloc_2str(1, nLay, lw_gas_props)) call check_error_msg('rrtmgp_lw_main_aerosol_optics_init',& lw_optical_props_aerosol_local%alloc_1scl(1, nLay, lw_gas_props%get_band_lims_wavenumber())) if (doGP_sgs_cnv) then call check_error_msg('rrtmgp_lw_main_cnv_cloud_optics_init',& - lw_optical_props_cnvcloudsByBand%alloc_1scl(1, nLay, lw_gas_props%get_band_lims_wavenumber())) + lw_optical_props_cnvcloudsByBand%alloc_2str(1, nLay, lw_gas_props%get_band_lims_wavenumber())) endif if (doGP_sgs_pbl) then call check_error_msg('rrtmgp_lw_main_pbl_cloud_optics_init',& - lw_optical_props_pblcloudsByBand%alloc_1scl(1, nLay, lw_gas_props%get_band_lims_wavenumber())) + lw_optical_props_pblcloudsByBand%alloc_2str(1, nLay, lw_gas_props%get_band_lims_wavenumber())) endif - ! - ! ty_fluxes_byband - ! - flux_allsky%bnd_flux_up => fluxLW_up_allsky - flux_allsky%bnd_flux_dn => fluxLW_dn_allsky - flux_clrsky%bnd_flux_up => fluxLW_up_clrsky - flux_clrsky%bnd_flux_dn => fluxLW_dn_clrsky ! Loop over all columns... do iCol=1,nCol ! Initialize/reset + do iGas=1,gas_concentrations%get_num_gases() + gas_concs%concs(iGas)%conc(1,:) = 0._kind_phys + end do lw_optical_props_clrsky%tau = 0._kind_phys lw_optical_props_precipByBand%tau = 0._kind_phys + lw_optical_props_precipByBand%ssa = 0._kind_phys + lw_optical_props_precipByBand%g = 0._kind_phys lw_optical_props_cloudsByBand%tau = 0._kind_phys + lw_optical_props_cloudsByBand%ssa = 0._kind_phys + lw_optical_props_cloudsByBand%g = 0._kind_phys lw_optical_props_clouds%tau = 0._kind_phys - lw_optical_props_clouds%ssa = 1._kind_phys + lw_optical_props_clouds%ssa = 0._kind_phys lw_optical_props_clouds%g = 0._kind_phys + sources%sfc_source = 0._kind_phys + sources%lay_source = 0._kind_phys + sources%lev_source_inc = 0._kind_phys + sources%lev_source_dec = 0._kind_phys + sources%sfc_source_Jac = 0._kind_phys + fluxLW_up_allsky = 0._kind_phys + fluxLW_dn_allsky = 0._kind_phys + fluxLW_up_clrsky = 0._kind_phys + fluxLW_dn_clrsky = 0._kind_phys if (doGP_sgs_cnv) lw_optical_props_cnvcloudsByBand%tau = 0._kind_phys if (doGP_sgs_pbl) lw_optical_props_pblcloudsByBand%tau = 0._kind_phys + flux_allsky%bnd_flux_up => fluxLW_up_allsky + flux_allsky%bnd_flux_dn => fluxLW_dn_allsky + flux_clrsky%bnd_flux_up => fluxLW_up_clrsky + flux_clrsky%bnd_flux_dn => fluxLW_dn_clrsky ! ################################################################################### ! ! Set gas-concentrations ! ! ################################################################################### - gas_concentrations%concs(istr_o2)%conc(1,:) = vmr_o2(iCol,:) - gas_concentrations%concs(istr_co2)%conc(1,:) = vmr_co2(iCol,:) - gas_concentrations%concs(istr_ch4)%conc(1,:) = vmr_ch4(iCol,:) - gas_concentrations%concs(istr_n2o)%conc(1,:) = vmr_n2o(iCol,:) - gas_concentrations%concs(istr_h2o)%conc(1,:) = vmr_h2o(iCol,:) - gas_concentrations%concs(istr_o3)%conc(1,:) = vmr_o3(iCol,:) - - ! ################################################################################### - ! - ! Surface emissity in each band - ! - ! ################################################################################### - ! Assign same emissivity to all band - !if (semis(iCol) > 1e-6 .and. semis(iCol) <= 1.0) then - do iBand=1,lw_gas_props%get_nband() - sfc_emiss_byband(iBand,1) = semis(iCol) + do iGas=1,gas_concentrations%get_num_gases() + call check_error_msg('rrtmgp_sw_gas_optics_run_set_vmr',& + gas_concs%set_vmr(trim(gas_concentrations%gas_name(iGas)),vmrTemp(iCol,:,iGas))) enddo - !else - ! sfc_emiss_byband(1:lw_gas_props%get_nband(),1) = 1.0 - !endif ! ################################################################################### ! @@ -302,7 +316,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, use_LW p_lev(iCol:iCol,:), & ! IN - Pressure @ layer-interfaces (Pa) t_lay(iCol:iCol,:), & ! IN - Temperature @ layer-centers (K) tsfg(iCol:iCol), & ! IN - Skin-temperature (K) - gas_concentrations, & ! IN - RRTMGP DDT: trace gas volumne mixing-ratios + gas_concs, & ! IN - RRTMGP DDT: trace gas volumne mixing-ratios lw_optical_props_clrsky, & ! OUT - RRTMGP DDT: longwave optical properties sources, & ! OUT - RRTMGP DDT: source functions tlev=t_lev(iCol:iCol,:))) ! IN - Temperature @ layer-interfaces (K) (optional) @@ -312,14 +326,16 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, use_LW ! Cloud-optics ! ! ################################################################################### - call check_error_msg('rrtmgp_lw_main_cloud_optics',lw_cloud_props%cloud_optics(& - cld_lwp(iCol:iCol,:), & ! IN - Cloud liquid water path (g/m2) - cld_iwp(iCol:iCol,:), & ! IN - Cloud ice water path (g/m2) - cld_reliq(iCol:iCol,:), & ! IN - Cloud liquid effective radius (microns) - cld_reice(iCol:iCol,:), & ! IN - Cloud ice effective radius (microns) - lw_optical_props_cloudsByBand)) ! OUT - RRTMGP DDT containing cloud radiative properties - ! in each band - + if (any(cld_frac(iCol,:) .gt. 0.)) then + call check_error_msg('rrtmgp_lw_main_cloud_optics',lw_cloud_props%cloud_optics(& + cld_lwp(iCol:iCol,:), & ! IN - Cloud liquid water path (g/m2) + cld_iwp(iCol:iCol,:), & ! IN - Cloud ice water path (g/m2) + cld_reliq(iCol:iCol,:), & ! IN - Cloud liquid effective radius (microns) + cld_reice(iCol:iCol,:), & ! IN - Cloud ice effective radius (microns) + lw_optical_props_cloudsByBand)) ! OUT - RRTMGP DDT containing cloud radiative properties + ! in each band + endif + ! Convective cloud-optics? if (doGP_sgs_cnv) then call check_error_msg('rrtmgp_lw_main_cnv_cloud_optics',lw_cloud_props%cloud_optics(& @@ -347,6 +363,8 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, use_LW endif ! Cloud precipitation optics: rain and snow(+groupel) + tau_rain = 0._kind_phys + tau_snow = 0._kind_phys do iLay=1,nLay if (cld_frac(iCol,iLay) .gt. 0.) then ! Rain optical-depth (No band dependence) @@ -371,51 +389,52 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, use_LW ! Cloud-sampling ! ! ################################################################################### - ! Change random number seed value for each radiation invocation (isubc_lw =1 or 2). - if(isubc_lw == 1) then ! advance prescribed permutation seed - ipseed_lw = lw_gas_props%get_ngpt() + iCol - elseif (isubc_lw == 2) then ! use input array of permutaion seeds - ipseed_lw = icseed_lw(iCol) - endif - ! Call RNG - call random_setseed(ipseed_lw,rng_stat) - ! Use same rng for each layer - if (iovr == iovr_max) then - call random_number(rng1D,rng_stat) - do iLay=1,nLay - rng3D(:,iLay,1) = rng1D - enddo - else - do iLay=1,nLay - call random_number(rng1D,rng_stat) - rng3D(:,iLay,1) = rng1D - enddo - endif - ! Cloud-overlap. - ! Maximum-random, random or maximum. - if (iovr == iovr_maxrand .or. iovr == iovr_rand .or. iovr == iovr_max) then - call sampled_mask(rng3D, cld_frac(iCol:iCol,:), maskMCICA) - endif - ! Exponential decorrelation length overlap - if (iovr == iovr_dcorr) then - ! Generate second RNG + if (any(cld_frac(iCol,:) .gt. 0.)) then + ! Change random number seed value for each radiation invocation (isubc_lw =1 or 2). + if(isubc_lw == 1) then ! advance prescribed permutation seed + ipseed_lw = lw_gas_props%get_ngpt() + iCol + elseif (isubc_lw == 2) then ! use input array of permutaion seeds + ipseed_lw = icseed_lw(iCol) + endif + ! Call RNG call random_setseed(ipseed_lw,rng_stat) - call random_number(rng2D,rng_stat) - rng3D2(:,:,1) = reshape(source = rng2D,shape=[lw_gas_props%get_ngpt(),nLay]) - ! - call sampled_mask(rng3D, cld_frac(iCol:iCol,:), maskMCICA, & - overlap_param = cloud_overlap_param(iCol:iCol,1:nLay-1), randoms2 = rng3D2) - endif - ! Exponential or Exponential-random - if (iovr == iovr_exp .or. iovr == iovr_exprand) then - call sampled_mask(rng3D, cld_frac(iCol:iCol,:), maskMCICA, & - overlap_param = cloud_overlap_param(iCol:iCol,1:nLay-1)) + ! Use same rng for each layer + if (iovr == iovr_max) then + call random_number(rng1D,rng_stat) + do iLay=1,nLay + rng3D(:,iLay,1) = rng1D + enddo + else + do iLay=1,nLay + call random_number(rng1D,rng_stat) + rng3D(:,iLay,1) = rng1D + enddo + endif + ! Cloud-overlap. + ! Maximum-random, random or maximum. + if (iovr == iovr_maxrand .or. iovr == iovr_rand .or. iovr == iovr_max) then + call sampled_mask(rng3D, cld_frac(iCol:iCol,:), maskMCICA) + endif + ! Exponential decorrelation length overlap + if (iovr == iovr_dcorr) then + ! Generate second RNG + call random_setseed(ipseed_lw,rng_stat) + call random_number(rng2D,rng_stat) + rng3D2(:,:,1) = reshape(source = rng2D,shape=[lw_gas_props%get_ngpt(),nLay]) + ! + call sampled_mask(rng3D, cld_frac(iCol:iCol,:), maskMCICA, & + overlap_param = cloud_overlap_param(iCol:iCol,1:nLay-1), randoms2 = rng3D2) + endif + ! Exponential or Exponential-random + if (iovr == iovr_exp .or. iovr == iovr_exprand) then + call sampled_mask(rng3D, cld_frac(iCol:iCol,:), maskMCICA, & + overlap_param = cloud_overlap_param(iCol:iCol,1:nLay-1)) + endif + ! Sampling. Map band optical depth to each g-point using McICA + call check_error_msg('rrtmgp_lw_main_cloud_sampling',& + draw_samples(maskMCICA, .true., & + lw_optical_props_cloudsByBand, lw_optical_props_clouds)) endif - ! Sampling. Map band optical depth to each g-point using McICA - call check_error_msg('rrtmgp_lw_main_cloud_sampling',& - draw_samples(maskMCICA, .true., & - lw_optical_props_cloudsByBand, lw_optical_props_clouds)) - ! ################################################################################### ! ! Compute clear-sky fluxes (gaseous+aerosol) (optional) @@ -435,7 +454,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, use_LW lw_optical_props_clrsky, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag sources, & ! IN - source function - sfc_emiss_byband, & ! IN - surface emissivity in each LW band + sfc_emiss_byband(:,iCol:iCol), & ! IN - surface emissivity in each LW band flux_clrsky, & ! OUT - Fluxes n_gauss_angles = nGauss_angles)) ! IN - Number of angles in Gaussian quadrature else @@ -443,14 +462,14 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, use_LW lw_optical_props_clrsky, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag sources, & ! IN - source function - sfc_emiss_byband, & ! IN - surface emissivity in each LW band + sfc_emiss_byband(:,iCol:iCol), & ! IN - surface emissivity in each LW band flux_clrsky, & ! OUT - Fluxes lw_Ds = lw_Ds)) endif ! Store fluxes - fluxlwUP_clrsky(iCol,:) = sum(flux_clrsky%bnd_flux_up(1,:,:),dim=2) - fluxlwDOWN_clrsky(iCol,:) = sum(flux_clrsky%bnd_flux_dn(1,:,:),dim=2) + fluxlwUP_clrsky(iCol:iCol,:) = sum(flux_clrsky%bnd_flux_up, dim=3) + fluxlwDOWN_clrsky(iCol:iCol,:) = sum(flux_clrsky%bnd_flux_dn, dim=3) else fluxlwUP_clrsky(iCol,:) = 0.0 fluxlwDOWN_clrsky(iCol,:) = 0.0 @@ -465,13 +484,13 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, use_LW ! Include convective cloud? if (doGP_sgs_cnv) then call check_error_msg('rrtmgp_lw_main_increment_cnvclouds_to_clrsky',& - lw_optical_props_cnvcloudsByBand%increment(lw_optical_props_clouds)) + lw_optical_props_cnvcloudsByBand%increment(lw_optical_props_clrsky)) endif ! Include MYNN-EDMF PBL clouds? if (doGP_sgs_pbl) then call check_error_msg('rrtmgp_lw_main_increment_pblclouds_to_clrsky',& - lw_optical_props_pblcloudsByBand%increment(lw_optical_props_clouds)) + lw_optical_props_pblcloudsByBand%increment(lw_optical_props_clrsky)) endif ! Add in precipitation @@ -490,7 +509,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, use_LW lw_optical_props_clouds, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag sources, & ! IN - source function - sfc_emiss_byband, & ! IN - surface emissivity in each LW band + sfc_emiss_byband(:,iCol:iCol), & ! IN - surface emissivity in each LW band flux_allsky, & ! OUT - Flxues n_gauss_angles = nGauss_angles, & ! IN - Number of angles in Gaussian quadrature flux_up_Jac = fluxlwUP_jac)) ! OUT - surface temperature flux (upward) Jacobian (W/m2/K) @@ -499,7 +518,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, use_LW lw_optical_props_clouds, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag sources, & ! IN - source function - sfc_emiss_byband, & ! IN - surface emissivity in each LW band + sfc_emiss_byband(:,iCol:iCol), & ! IN - surface emissivity in each LW band flux_allsky, & ! OUT - Flxues n_gauss_angles = nGauss_angles)) ! IN - Number of angles in Gaussian quadrature end if @@ -515,7 +534,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, use_LW lw_optical_props_clrsky, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag sources, & ! IN - source function - sfc_emiss_byband, & ! IN - surface emissivity in each LW band + sfc_emiss_byband(:,iCol:iCol), & ! IN - surface emissivity in each LW band flux_allsky, & ! OUT - Flxues n_gauss_angles = nGauss_angles, & ! IN - Number of angles in Gaussian quadrature flux_up_Jac = fluxlwUP_jac)) ! OUT - surface temperature flux (upward) Jacobian (W/m2/K) @@ -524,15 +543,15 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, use_LW lw_optical_props_clrsky, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag sources, & ! IN - source function - sfc_emiss_byband, & ! IN - surface emissivity in each LW band + sfc_emiss_byband(:,iCol:iCol), & ! IN - surface emissivity in each LW band flux_allsky, & ! OUT - Flxues n_gauss_angles = nGauss_angles)) ! IN - Number of angles in Gaussian quadrature end if endif ! Store fluxes - fluxlwUP_allsky(iCol,:) = sum(flux_allsky%bnd_flux_up(1,:,:),dim=2) - fluxlwDOWN_allsky(iCol,:) = sum(flux_allsky%bnd_flux_dn(1,:,:),dim=2) + fluxlwUP_allsky(iCol:iCol,:) = sum(flux_allsky%bnd_flux_up, dim=3) + fluxlwDOWN_allsky(iCol:iCol,:) = sum(flux_allsky%bnd_flux_dn, dim=3) ! Save fluxes for coupling fluxlwUP_radtime(iCol,:) = fluxlwUP_allsky(iCol,:) @@ -541,5 +560,5 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, use_LW enddo end subroutine rrtmgp_lw_main_run - +!> @} end module rrtmgp_lw_main diff --git a/physics/rrtmgp_lw_main.meta b/physics/rrtmgp_lw_main.meta index ad0b88c86..ec352c0a8 100644 --- a/physics/rrtmgp_lw_main.meta +++ b/physics/rrtmgp_lw_main.meta @@ -215,20 +215,6 @@ dimensions = () type = integer intent = in -[nGases] - standard_name = number_of_active_gases_used_by_RRTMGP - long_name = number of gases available used by RRTMGP (Model%nGases) - units = count - dimensions = () - type = integer - intent = in -[i_o3] - standard_name = index_of_ozone_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for ozone mixing ratio - units = index - dimensions = () - type = integer - intent = in [isubc_lw] standard_name = flag_for_lw_clouds_sub_grid_approximation long_name = flag for lw clouds sub-grid approximation @@ -347,54 +333,6 @@ type = real kind = kind_phys intent = in -[vmr_o2] - standard_name = volume_mixing_ratio_for_o2 - long_name = molar mixing ratio of o2 in with respect to dry air - units = 1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[vmr_h2o] - standard_name = volume_mixing_ratio_for_h2o - long_name = molar mixing ratio of h2o in with respect to dry air - units = 1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[vmr_o3] - standard_name = volume_mixing_ratio_for_o3 - long_name = molar mixing ratio of o3 in with respect to dry air - units = 1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[vmr_ch4] - standard_name = volume_mixing_ratio_for_ch4 - long_name = molar mixing ratio of ch4 in with respect to dry air - units = 1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[vmr_n2o] - standard_name = volume_mixing_ratio_for_n2o - long_name = molar mixing ratio of n2o in with respect to dry air - units = 1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[vmr_co2] - standard_name = volume_mixing_ratio_for_co2 - long_name = molar mixing ratio of co2 in with respect to dry air - units = 1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in [cld_frac] standard_name = total_cloud_fraction long_name = layer total cloud fraction @@ -547,6 +485,14 @@ type = real kind = kind_phys intent = in +[sfc_emiss_byband] + standard_name = surface_emissivity_in_each_RRTMGP_LW_band + long_name = surface emissivity in each RRTMGP LW band + units = none + dimensions = (number_of_longwave_bands,horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [active_gases_array] standard_name = list_of_active_gases_used_by_RRTMGP long_name = list of active gases used by RRTMGP @@ -562,6 +508,13 @@ dimensions = () type = ty_optical_props_1scl intent = in +[gas_concentrations] + standard_name = Gas_concentrations_for_RRTMGP_suite + long_name = DDT containing gas concentrations for RRTMGP radiation scheme + units = DDT + dimensions = () + type = ty_gas_concs + intent = in [fluxlwUP_radtime] standard_name = RRTMGP_lw_flux_profile_upward_allsky_on_radiation_timestep long_name = RRTMGP upward longwave all-sky flux profile diff --git a/physics/rrtmgp_sw_cloud_optics.F90 b/physics/rrtmgp_sw_cloud_optics.F90 index 24fafbffe..fd648de02 100644 --- a/physics/rrtmgp_sw_cloud_optics.F90 +++ b/physics/rrtmgp_sw_cloud_optics.F90 @@ -3,6 +3,7 @@ module rrtmgp_sw_cloud_optics use mo_rte_kind, only: wl use mo_cloud_optics, only: ty_cloud_optics use mo_optical_props, only: ty_optical_props_2str + use mo_rrtmg_sw_cloud_optics, only: rrtmg_sw_cloud_optics use rrtmgp_sw_gas_optics, only: sw_gas_props use radiation_tools, only: check_error_msg use netcdf @@ -66,9 +67,12 @@ module rrtmgp_sw_cloud_optics ! ###################################################################################### ! SUBROUTINE sw_cloud_optics_init ! ###################################################################################### - subroutine rrtmgp_sw_cloud_optics_init(nrghice, mpicomm, mpirank, mpiroot, doG_cldoptics, & - doGP_cldoptics_PADE, doGP_cldoptics_LUT, rrtmgp_root_dir, rrtmgp_sw_file_clouds, & - errmsg, errflg) +!! \section arg_table_rrtmgp_sw_cloud_optics_init +!! \htmlinclude rrtmgp_lw_cloud_optics.html +!! + subroutine rrtmgp_sw_cloud_optics_init(doG_cldoptics, doGP_cldoptics_PADE, & + doGP_cldoptics_LUT, nrghice, rrtmgp_root_dir, rrtmgp_sw_file_clouds, mpicomm, & + mpirank, mpiroot, errmsg, errflg) ! Inputs logical, intent(in) :: & @@ -384,4 +388,183 @@ subroutine rrtmgp_sw_cloud_optics_init(nrghice, mpicomm, mpirank, mpiroot, doG_c end subroutine rrtmgp_sw_cloud_optics_init + ! ######################################################################################### + ! SUBROTUINE rrtmgp_sw_cloud_optics_run() + ! ######################################################################################### +!! \section arg_table_rrtmgp_sw_cloud_optics_run +!! \htmlinclude rrtmgp_sw_cloud_optics.html +!! + subroutine rrtmgp_sw_cloud_optics_run(doSWrad, doG_cldoptics, icliq_sw, icice_sw, & + doGP_cldoptics_PADE, doGP_cldoptics_LUT, do_mynnedmf, imfdeepcnv, imfdeepcnv_gf, & + imfdeepcnv_samf, nCol, nLev, nDay, nbndsGPsw, idxday, cld_frac, cld_lwp, cld_reliq, & + cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, cld_rerain, precip_frac, & + cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, cld_cnv_reice, cld_pbl_lwp, cld_pbl_reliq, & + cld_pbl_iwp, cld_pbl_reice, sw_optical_props_cloudsByBand, & + sw_optical_props_cnvcloudsByBand, sw_optical_props_precipByBand, & + sw_optical_props_MYNNcloudsByBand, cldtausw, errmsg, errflg) + + ! Inputs + logical, intent(in) :: & + doSWrad, & ! Logical flag for shortwave radiation call + doG_cldoptics, & ! Use legacy RRTMG cloud-optics? + doGP_cldoptics_PADE, & ! Use RRTMGP cloud-optics: PADE approximation? + doGP_cldoptics_LUT, & ! Use RRTMGP cloud-optics: LUTs? + do_mynnedmf ! + integer, intent(in) :: & + nbndsGPsw, & ! Number of shortwave bands + nCol, & ! Number of horizontal gridpoints + nLev, & ! Number of vertical levels + nday, & ! Number of daylit points. + icliq_sw, & ! Choice of treatment of liquid cloud optical properties (RRTMG legacy) + icice_sw, & ! Choice of treatment of ice cloud optical properties (RRTMG legacy) + imfdeepcnv, & ! + imfdeepcnv_gf, & ! + imfdeepcnv_samf ! + integer,intent(in),dimension(:) :: & + idxday ! Indices for daylit points. + real(kind_phys), dimension(:,:),intent(in) :: & + cld_frac, & ! Total cloud fraction by layer + cld_lwp, & ! Cloud liquid water path + cld_reliq, & ! Cloud liquid effective radius + cld_iwp, & ! Cloud ice water path + cld_reice, & ! Cloud ice effective radius + cld_swp, & ! Cloud snow water path + cld_resnow, & ! Cloud snow effective radius + cld_rwp, & ! Cloud rain water path + cld_rerain, & ! Cloud rain effective radius + precip_frac, & ! Precipitation fraction by layer + cld_cnv_lwp, & ! Water path for convective liquid cloud-particles (microns) + cld_cnv_reliq, & ! Effective radius for convective liquid cloud-particles (microns) + cld_cnv_iwp, & ! Water path for convective ice cloud-particles (microns) + cld_cnv_reice, & ! Effective radius for convective ice cloud-particles (microns) + cld_pbl_lwp, & ! Water path for SGS PBL liquid cloud-particles + cld_pbl_reliq, & ! Effective radius for SGS PBL liquid cloud-particles + cld_pbl_iwp, & ! Water path for SGS PBL ice cloud-particles + cld_pbl_reice ! Effective radius for SGS PBL ice cloud-particles + ! Outputs + character(len=*), intent(out) :: & + errmsg ! CCPP error message + integer, intent(out) :: & + errflg ! CCPP error flag + type(ty_optical_props_2str),intent(out) :: & + sw_optical_props_cloudsByBand, & ! RRTMGP DDT: Shortwave optical properties in each band (clouds) + sw_optical_props_cnvcloudsByBand, & ! RRTMGP DDT: Shortwave optical properties in each band (convective cloud) + sw_optical_props_MYNNcloudsByBand,& ! RRTMGP DDT: Shortwave optical properties in each band (MYNN PBL cloud) + sw_optical_props_precipByBand ! RRTMGP DDT: Shortwave optical properties in each band (cloud precipitation) + real(kind_phys), dimension(:,:), intent(out) :: & + cldtausw ! Approx 10.mu band layer cloud optical depth + + ! Local variables + integer :: iDay, iLay, iBand + real(kind_phys) :: tau_rain, tau_snow, ssa_rain, ssa_snow, asy_rain, asy_snow, & + tau_prec, asy_prec, ssa_prec, asyw, ssaw, za1, za2 + real(kind_phys), dimension(nday,nLev,nbndsGPsw) :: & + tau_cld, ssa_cld, asy_cld, tau_precip, ssa_precip, asy_precip + type(ty_optical_props_2str) :: sw_optical_props_cloudsByBand_daylit + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (.not. doSWrad) return + + ! Only process sunlit points... + if (nDay .gt. 0) then + + ! Compute cloud/precipitation optics. + if (doGP_cldoptics_PADE .or. doGP_cldoptics_LUT) then + ! i) Cloud-optics. + call check_error_msg('rrtmgp_sw_cloud_optics_run - sw_optical_props_cloudsByBand',& + sw_optical_props_cloudsByBand%alloc_2str(nday, nLev, sw_cloud_props%get_band_lims_wavenumber())) + + call check_error_msg('rrtmgp_sw_cloud_optics_run - clouds',sw_cloud_props%cloud_optics(& + cld_lwp(idxday(1:nday),:), & ! IN - Cloud liquid water path + cld_iwp(idxday(1:nday),:), & ! IN - Cloud ice water path + cld_reliq(idxday(1:nday),:), & ! IN - Cloud liquid effective radius + cld_reice(idxday(1:nday),:), & ! IN - Cloud ice effective radius + sw_optical_props_cloudsByBand)) ! OUT - RRTMGP DDT: Shortwave optical properties, + ! in each band (tau,ssa,g) + + ! ii) Convective cloud-optics + if (imfdeepcnv == imfdeepcnv_samf .or. imfdeepcnv == imfdeepcnv_gf) then + call check_error_msg('rrtmgp_sw_cloud_optics_run - sw_optical_props_cnvcloudsByBand',& + sw_optical_props_cnvcloudsByBand%alloc_2str(nday, nLev, sw_cloud_props%get_band_lims_wavenumber())) + + call check_error_msg('rrtmgp_sw_cloud_optics_run - convective clouds',sw_cloud_props%cloud_optics(& + cld_cnv_lwp(idxday(1:nday),:), & ! IN - Convective cloud liquid water path + cld_cnv_iwp(idxday(1:nday),:), & ! IN - Convective cloud ice water path + cld_cnv_reliq(idxday(1:nday),:), & ! IN - Convective cloud liquid effective radius + cld_cnv_reice(idxday(1:nday),:), & ! IN - Convective cloud ice effective radius + sw_optical_props_cnvcloudsByBand)) ! OUT - RRTMGP DDT: Shortwave optical properties, + ! in each band (tau,ssa,g) + endif + + ! iii) MYNN cloud-optics + if (do_mynnedmf) then + call check_error_msg('rrtmgp_sw_cloud_optics_run - sw_optical_props_MYNNcloudsByBand',& + sw_optical_props_MYNNcloudsByBand%alloc_2str(nday, nLev, sw_cloud_props%get_band_lims_wavenumber())) + + call check_error_msg('rrtmgp_sw_MYNNcloud_optics_run - MYNN-EDMF cloud',sw_cloud_props%cloud_optics(& + cld_pbl_lwp(idxday(1:nday),:), & ! IN - MYNN-EDMF PBL cloud liquid water path (g/m2) + cld_pbl_iwp(idxday(1:nday),:), & ! IN - MYNN-EDMF PBL cloud ice water path (g/m2) + cld_pbl_reliq(idxday(1:nday),:), & ! IN - MYNN-EDMF PBL cloud liquid effective radius (microns) + cld_pbl_reice(idxday(1:nday),:), & ! IN - MYNN-EDMF PBL cloud ice effective radius (microns) + sw_optical_props_MYNNcloudsByBand)) ! OUT - RRTMGP DDT containing MYNN-EDMF PBL cloud radiative properties + ! in each band + endif + + ! iv) Cloud precipitation optics: rain and snow(+groupel) + call check_error_msg('rrtmgp_sw_cloud_optics_run - sw_optical_props_precipByBand',& + sw_optical_props_precipByBand%alloc_2str(nday, nLev, sw_cloud_props%get_band_lims_wavenumber())) + sw_optical_props_precipByBand%tau(:,:,:) = 0._kind_phys + sw_optical_props_precipByBand%ssa(:,:,:) = 1._kind_phys + sw_optical_props_precipByBand%g(:,:,:) = 0._kind_phys + + do iDay=1,nDay + do iLay=1,nLev + if (cld_frac(idxday(iDay),iLay) .gt. 1.e-12_kind_phys) then + ! Rain/Snow optical depth (No band dependence) + tau_rain = cld_rwp(idxday(iDay),iLay)*a0r + if (cld_swp(idxday(iDay),iLay) .gt. 0. .and. cld_resnow(idxday(iDay),iLay) .gt. 10._kind_phys) then + tau_snow = cld_swp(idxday(iDay),iLay)*1.09087*(a0s + a1s/(1.0315*cld_resnow(idxday(iDay),iLay))) ! fu's formula + else + tau_snow = 0._kind_phys + endif + + ! Rain/Snow single-scattering albedo and asymmetry (Band dependent) + do iBand=1,nbndsGPsw + ! By species + ssa_rain = tau_rain*(1.-b0r(iBand)) + asy_rain = ssa_rain*c0r(iBand) + ssa_snow = tau_snow*(1.-(b0s(iBand)+b1s(iBand)*1.0315*cld_resnow(idxday(iDay),iLay))) + asy_snow = ssa_snow*c0s(iBand) + ! Combine + tau_prec = max(1.e-12_kind_phys, tau_rain + tau_snow) + ssa_prec = max(1.e-12_kind_phys, ssa_rain + ssa_snow) + asy_prec = max(1.e-12_kind_phys, asy_rain + asy_snow) + asyw = asy_prec/max(1.e-12_kind_phys, ssa_prec) + ssaw = min(1._kind_phys-0.000001, ssa_prec/tau_prec) + za1 = asyw * asyw + za2 = ssaw * za1 + sw_optical_props_precipByBand%tau(iDay,iLay,iBand) = (1._kind_phys - za2) * tau_prec + sw_optical_props_precipByBand%ssa(iDay,iLay,iBand) = (ssaw - za2) / (1._kind_phys - za2) + sw_optical_props_precipByBand%g(iDay,iLay,iBand) = asyw/(1+asyw) + enddo + endif + enddo + enddo + endif + + ! All-sky SW optical depth ~0.55microns (DJS asks: Move to cloud diagnostics?) + cldtausw(idxday(1:nDay),:) = sw_optical_props_cloudsByBand%tau(:,:,11) + endif + + end subroutine rrtmgp_sw_cloud_optics_run + + ! ######################################################################################### + ! SUBROTUINE rrtmgp_sw_cloud_optics_finalize() + ! ######################################################################################### + subroutine rrtmgp_sw_cloud_optics_finalize() + end subroutine rrtmgp_sw_cloud_optics_finalize + end module rrtmgp_sw_cloud_optics diff --git a/physics/rrtmgp_sw_cloud_optics.meta b/physics/rrtmgp_sw_cloud_optics.meta new file mode 100644 index 000000000..064b7cf80 --- /dev/null +++ b/physics/rrtmgp_sw_cloud_optics.meta @@ -0,0 +1,393 @@ +[ccpp-table-properties] + name = rrtmgp_sw_cloud_optics + type = scheme + dependencies = machine.F,rrtmg_sw_cloud_optics.F90,radiation_tools.F90 + +######################################################################## +[ccpp-arg-table] + name = rrtmgp_sw_cloud_optics_init + type = scheme +[doG_cldoptics] + standard_name = flag_to_calc_lw_cld_optics_using_RRTMG + long_name = logical flag to control cloud optics scheme. + units = flag + dimensions = () + type = logical + intent = in +[doGP_cldoptics_PADE] + standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_PADE + long_name = logical flag to control cloud optics scheme. + units = flag + dimensions = () + type = logical + intent = in +[doGP_cldoptics_LUT] + standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_LUT + long_name = logical flag to control cloud optics scheme. + units = flag + dimensions = () + type = logical + intent = in +[nrghice] + standard_name = number_of_ice_roughness_categories + long_name = number of ice-roughness categories in RRTMGP calculation + units = count + dimensions = () + type = integer + intent = inout +[rrtmgp_root_dir] + standard_name = directory_for_rte_rrtmgp_source_code + long_name = directory for rte+rrtmgp source code + units = none + dimensions = () + type = character + intent = in + kind = len=128 +[rrtmgp_sw_file_clouds] + standard_name = filename_of_rrtmgp_shortwave_cloud_optics_coefficients + long_name = file containing coefficients for RRTMGP SW cloud optics + units = none + dimensions = () + type = character + intent = in + kind = len=128 +[mpirank] + standard_name = mpi_rank + long_name = current MPI rank + units = index + dimensions = () + type = integer + intent = in +[mpiroot] + standard_name = mpi_root + long_name = master MPI rank + units = index + dimensions = () + type = integer + intent = in +[mpicomm] + standard_name = mpi_communicator + long_name = MPI communicator + units = index + dimensions = () + type = integer + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out +######################################################################## +[ccpp-arg-table] + name = rrtmgp_sw_cloud_optics_run + type = scheme +[doSWrad] + standard_name = flag_for_calling_shortwave_radiation + long_name = logical flags for sw radiation calls + units = flag + dimensions = () + type = logical + intent = in +[ncol] + standard_name = horizontal_loop_extent + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in +[nLev] + standard_name = vertical_layer_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in +[doG_cldoptics] + standard_name = flag_to_calc_lw_cld_optics_using_RRTMG + long_name = logical flag to control cloud optics scheme. + units = flag + dimensions = () + type = logical + intent = in +[icliq_sw] + standard_name = control_for_shortwave_radiation_liquid_clouds + long_name = sw optical property for liquid clouds + units = flag + dimensions = () + type = integer + intent = in +[icice_sw] + standard_name = flag_for_optical_property_for_ice_clouds_for_shortwave_radiation + long_name = sw optical property for ice clouds + units = flag + dimensions = () + type = integer + intent = in +[doGP_cldoptics_PADE] + standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_PADE + long_name = logical flag to control cloud optics scheme. + units = flag + dimensions = () + type = logical + intent = in +[doGP_cldoptics_LUT] + standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_LUT + long_name = logical flag to control cloud optics scheme. + units = flag + dimensions = () + type = logical + intent = in +[do_mynnedmf] + standard_name = flag_for_mellor_yamada_nakanishi_niino_pbl_scheme + long_name = flag to activate MYNN-EDMF + units = flag + dimensions = () + type = logical + intent = in +[imfdeepcnv] + standard_name = control_for_deep_convection_scheme + long_name = flag for mass-flux deep convection scheme + units = flag + dimensions = () + type = integer + intent = in +[imfdeepcnv_gf] + standard_name = identifier_for_grell_freitas_deep_convection + long_name = flag for Grell-Freitas deep convection scheme + units = flag + dimensions = () + type = integer + intent = in +[imfdeepcnv_samf] + standard_name = identifer_for_scale_aware_mass_flux_deep_convection + long_name = flag for SAMF deep convection scheme + units = flag + dimensions = () + type = integer + intent = in +[cld_frac] + standard_name = total_cloud_fraction + long_name = layer total cloud fraction + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_lwp] + standard_name = cloud_liquid_water_path + long_name = layer cloud liquid water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_reliq] + standard_name = mean_effective_radius_for_liquid_cloud + long_name = mean effective radius for liquid cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_iwp] + standard_name = cloud_ice_water_path + long_name = layer cloud ice water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_reice] + standard_name = mean_effective_radius_for_ice_cloud + long_name = mean effective radius for ice cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_swp] + standard_name = cloud_snow_water_path + long_name = layer cloud snow water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_resnow] + standard_name = mean_effective_radius_for_snow_flake + long_name = mean effective radius for snow cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_rwp] + standard_name = cloud_rain_water_path + long_name = layer cloud rain water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_rerain] + standard_name = mean_effective_radius_for_rain_drop + long_name = mean effective radius for rain cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[precip_frac] + standard_name = precipitation_fraction_by_layer + long_name = precipitation fraction in each layer + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_cnv_lwp] + standard_name = convective_cloud_liquid_water_path + long_name = layer convective cloud liquid water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_cnv_iwp] + standard_name = convective_cloud_ice_water_path + long_name = layer convective cloud ice water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_cnv_reliq] + standard_name = mean_effective_radius_for_liquid_convective_cloud + long_name = mean effective radius for liquid convective cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_cnv_reice] + standard_name = mean_effective_radius_for_ice_convective_cloud + long_name = mean effective radius for ice convective cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_pbl_lwp] + standard_name = MYNN_SGS_cloud_liquid_water_path + long_name = layer convective cloud liquid water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_pbl_iwp] + standard_name = MYNN_SGS_cloud_ice_water_path + long_name = layer convective cloud ice water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_pbl_reliq] + standard_name = mean_effective_radius_for_liquid_MYNN_SGS_cloud + long_name = mean effective radius for liquid MYNN_SGS cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_pbl_reice] + standard_name = mean_effective_radius_for_ice_MYNN_SGS_cloud + long_name = mean effective radius for ice MYNN_SGS cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[nbndsGPsw] + standard_name = number_of_shortwave_bands + long_name = number of sw bands used in RRTMGP + units = count + dimensions = () + type = integer + intent = in +[nday] + standard_name = daytime_points_dimension + long_name = daytime points dimension + units = count + dimensions = () + type = integer + intent = in +[idxday] + standard_name = daytime_points + long_name = daytime points + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[sw_optical_props_cloudsByBand] + standard_name = shortwave_optical_properties_for_cloudy_atmosphere_by_band + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = out +[sw_optical_props_cnvcloudsByBand] + standard_name = shortwave_optical_properties_for_convective_cloudy_atmosphere_by_band + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = out +[sw_optical_props_precipByBand] + standard_name = shortwave_optical_properties_for_precipitation_by_band + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = out +[sw_optical_props_MYNNcloudsByBand] + standard_name = shortwave_optical_properties_for_MYNN_EDMF_PBL_cloudy_atmosphere_by_band + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = out +[cldtausw] + standard_name = cloud_optical_depth_layers_at_0p55mu_band + long_name = approx .55mu band layer cloud optical depth + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out diff --git a/physics/rrtmgp_sw_cloud_sampling.F90 b/physics/rrtmgp_sw_cloud_sampling.F90 new file mode 100644 index 000000000..c4a5de4c8 --- /dev/null +++ b/physics/rrtmgp_sw_cloud_sampling.F90 @@ -0,0 +1,170 @@ +module rrtmgp_sw_cloud_sampling + use machine, only: kind_phys + use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp + use mo_optical_props, only: ty_optical_props_2str + use rrtmgp_sampling, only: sampled_mask, draw_samples + use mersenne_twister, only: random_setseed, random_number, random_stat + use radiation_tools, only: check_error_msg + use rrtmgp_sw_gas_optics, only: sw_gas_props + use netcdf + + implicit none + +contains + + ! ######################################################################################### + ! SUBROTUINE rrtmgp_sw_cloud_sampling_run() + ! ######################################################################################### +!! \section arg_table_rrtmgp_sw_cloud_sampling_run +!! \htmlinclude rrtmgp_sw_cloud_sampling.html +!! + subroutine rrtmgp_sw_cloud_sampling_run(doSWrad, nCol, nDay, nLev, idxday, iovr, & + iovr_convcld, iovr_max, iovr_maxrand, iovr_rand, iovr_dcorr, iovr_exp, iovr_exprand, & + isubc_sw,icseed_sw, cld_frac, precip_frac, cloud_overlap_param, precip_overlap_param,& + imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_samf, cnv_cloud_overlap_param, cld_cnv_frac, & + sw_optical_props_cnvcloudsByBand, sw_optical_props_cloudsByBand, & + sw_optical_props_precipByBand, sw_optical_props_clouds, sw_optical_props_cnvclouds, & + sw_optical_props_precip, errmsg, errflg) + + ! Inputs + logical, intent(in) :: & + doSWrad ! Logical flag for shortwave radiation call + integer, intent(in) :: & + nCol, & ! Number of horizontal gridpoints + nDay, & ! Number of daylit points. + nLev, & ! Number of vertical layers + imfdeepcnv, & ! + imfdeepcnv_gf, & ! + imfdeepcnv_samf, & ! + iovr, & ! Choice of cloud-overlap method + iovr_convcld, & ! Choice of convective cloud-overlap method + iovr_max, & ! Flag for maximum cloud overlap method + iovr_maxrand, & ! Flag for maximum-random cloud overlap method + iovr_rand, & ! Flag for random cloud overlap method + iovr_dcorr, & ! Flag for decorrelation-length cloud overlap method + iovr_exp, & ! Flag for exponential cloud overlap method + iovr_exprand, & ! Flag for exponential-random cloud overlap method + isubc_sw + integer,intent(in),dimension(:) :: & + idxday ! Indices for daylit points. + integer,intent(in),dimension(:) :: & + icseed_sw ! auxiliary special cloud related array when module + ! variable isubc_sw=2, it provides permutation seed + ! for each column profile that are used for generating + ! random numbers. when isubc_sw /=2, it will not be used. + real(kind_phys), dimension(:,:),intent(in) :: & + cld_frac, & ! Total cloud fraction by layer + cld_cnv_frac, & ! Convective cloud fraction by layer + precip_frac ! Precipitation fraction by layer + real(kind_phys), dimension(:,:), intent(in) :: & + cloud_overlap_param, & ! Cloud overlap parameter + cnv_cloud_overlap_param, & ! Convective cloud overlap parameter + precip_overlap_param ! Precipitation overlap parameter + type(ty_optical_props_2str),intent(in) :: & + sw_optical_props_cloudsByBand, & ! RRTMGP DDT: Shortwave optical properties in each band (clouds) + sw_optical_props_cnvcloudsByBand,& ! RRTMGP DDT: Shortwave optical properties in each band (convectivecloud) + sw_optical_props_precipByBand ! RRTMGP DDT: Shortwave optical properties in each band (precipitation) + + ! Outputs + character(len=*), intent(out) :: & + errmsg ! Error message + integer, intent(out) :: & + errflg ! Error flag + type(ty_optical_props_2str),intent(out) :: & + sw_optical_props_clouds, & ! RRTMGP DDT: Shortwave optical properties at each spectral point (clouds) + sw_optical_props_cnvclouds, & ! RRTMGP DDT: Shortwave optical properties at each spectral point (convectivecloud) + sw_optical_props_precip ! RRTMGP DDT: Shortwave optical properties at each spectral point (precipitation) + + ! Local variables + integer :: iday,iLay,iGpt + integer,dimension(nday) :: ipseed_sw + type(random_stat) :: rng_stat + real(kind_phys) :: tauloc,asyloc,ssaloc + real(kind_phys), dimension(sw_gas_props%get_ngpt(),nLev,nday) :: rng3D,rng3D2 + real(kind_phys), dimension(sw_gas_props%get_ngpt()*nLev) :: rng2D + real(kind_phys), dimension(sw_gas_props%get_ngpt()) :: rng1D + logical, dimension(nday,nLev,sw_gas_props%get_ngpt()) :: maskMCICA + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (.not. doSWrad) return + if (nDay .gt. 0) then + ! ################################################################################# + ! First sample the clouds... + ! ################################################################################# + + ! Allocate space RRTMGP DDTs [nday,nLev,nGpt] + call check_error_msg('rrtmgp_sw_cloud_sampling_run', & + sw_optical_props_clouds%alloc_2str(nday, nLev, sw_gas_props)) + + ! Change random number seed value for each radiation invocation (isubc_sw =1 or 2). + if(isubc_sw == 1) then ! advance prescribed permutation seed + do iday = 1, nday + ipseed_sw(iday) = sw_gas_props%get_ngpt() + iday + enddo + elseif (isubc_sw == 2) then ! use input array of permutaion seeds + do iday = 1, nday + ipseed_sw(iday) = icseed_sw(idxday(iday)) + enddo + endif + + ! Call RNG. Mersennse Twister accepts 1D array, so loop over columns and collapse along G-points + ! and layers. ([nGpts,nLev,nDayumn]-> [nGpts*nLev]*nDayumn) + do iday=1,nday + call random_setseed(ipseed_sw(iday),rng_stat) + ! Use same rng for each layer + if (iovr == iovr_max) then + call random_number(rng1D,rng_stat) + do iLay=1,nLev + rng3D(:,iLay,iday) = rng1D + enddo + else + do iLay=1,nLev + call random_number(rng1D,rng_stat) + rng3D(:,iLay,iday) = rng1D + enddo + endif + enddo + + ! Cloud overlap. + ! Maximum-random, random, or maximum cloud overlap + if (iovr == iovr_maxrand .or. iovr == iovr_max .or. iovr == iovr_rand) then + call sampled_mask(rng3D, cld_frac(idxday(1:nDay),:), maskMCICA) + endif + ! Decorrelation-length overlap + if (iovr == iovr_dcorr) then + do iday=1,nday + call random_setseed(ipseed_sw(iday),rng_stat) + call random_number(rng2D,rng_stat) + rng3D2(:,:,iday) = reshape(source = rng2D,shape=[sw_gas_props%get_ngpt(),nLev]) + enddo + call sampled_mask(rng3D, cld_frac(idxday(1:nDay),:), maskMCICA, & + overlap_param = cloud_overlap_param(idxday(1:nDay),1:nLev-1),& + randoms2 = rng3D2) + endif + ! Exponential or exponential-random cloud overlap + if (iovr == iovr_exp .or. iovr == iovr_exprand) then + call sampled_mask(rng3D, cld_frac(idxday(1:nDay),:), maskMCICA, & + overlap_param = cloud_overlap_param(idxday(1:nDay),1:nLev-1)) + endif + + ! + ! Sampling. Map band optical depth to each g-point using McICA + ! + call check_error_msg('rrtmgp_sw_cloud_sampling_run_draw_samples', & + draw_samples(maskMCICA, .true., & + sw_optical_props_cloudsByBand, & + sw_optical_props_clouds)) + endif + + end subroutine rrtmgp_sw_cloud_sampling_run + + ! ######################################################################################### + ! SUBROTUINE rrtmgp_sw_cloud_sampling_finalize() + ! ######################################################################################### + subroutine rrtmgp_sw_cloud_sampling_finalize() + end subroutine rrtmgp_sw_cloud_sampling_finalize + +end module rrtmgp_sw_cloud_sampling diff --git a/physics/rrtmgp_sw_cloud_sampling.meta b/physics/rrtmgp_sw_cloud_sampling.meta new file mode 100644 index 000000000..1415108f8 --- /dev/null +++ b/physics/rrtmgp_sw_cloud_sampling.meta @@ -0,0 +1,240 @@ +[ccpp-table-properties] + name = rrtmgp_sw_cloud_sampling + type = scheme + dependencies = machine.F,mersenne_twister.f,rrtmgp_sampling.F90,radiation_tools.F90 + +###################################################### +[ccpp-arg-table] + name = rrtmgp_sw_cloud_sampling_run + type = scheme +[doSWrad] + standard_name = flag_for_calling_shortwave_radiation + long_name = logical flags for sw radiation calls + units = flag + dimensions = () + type = logical + intent = in +[imfdeepcnv] + standard_name = control_for_deep_convection_scheme + long_name = flag for mass-flux deep convection scheme + units = flag + dimensions = () + type = integer + intent = in +[imfdeepcnv_gf] + standard_name = identifier_for_grell_freitas_deep_convection + long_name = flag for Grell-Freitas deep convection scheme + units = flag + dimensions = () + type = integer + intent = in +[imfdeepcnv_samf] + standard_name = identifer_for_scale_aware_mass_flux_deep_convection + long_name = flag for SAMF deep convection scheme + units = flag + dimensions = () + type = integer + intent = in +[iovr_convcld] + standard_name = flag_for_convective_cloud_overlap_method_for_radiation + long_name = flag for convective cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[ncol] + standard_name = horizontal_loop_extent + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in +[nday] + standard_name = daytime_points_dimension + long_name = daytime points dimension + units = count + dimensions = () + type = integer + intent = in +[nLev] + standard_name = vertical_layer_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in +[isubc_sw] + standard_name = flag_for_sw_clouds_grid_approximation + long_name = flag for sw clouds sub-grid approximation + units = flag + dimensions = () + type = integer + intent = in +[idxday] + standard_name = daytime_points + long_name = daytime points + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[iovr] + standard_name = flag_for_cloud_overlap_method_for_radiation + long_name = max-random overlap clouds + units = flag + dimensions = () + type = integer + intent = in +[iovr_maxrand] + standard_name = flag_for_maximum_random_cloud_overlap_method + long_name = choice of maximum-random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_dcorr] + standard_name = flag_for_decorrelation_length_cloud_overlap_method + long_name = choice of decorrelation-length cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_exp] + standard_name = flag_for_exponential_cloud_overlap_method + long_name = choice of exponential cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_exprand] + standard_name = flag_for_exponential_random_cloud_overlap_method + long_name = choice of exponential-random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_rand] + standard_name = flag_for_random_cloud_overlap_method + long_name = choice of random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_max] + standard_name = flag_for_maximum_cloud_overlap_method + long_name = choice of maximum cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[icseed_sw] + standard_name = random_number_seed_for_mcica_shortwave + long_name = seed for random number generation for shortwave radiation + units = none + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[cld_frac] + standard_name = total_cloud_fraction + long_name = layer total cloud fraction + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[precip_frac] + standard_name = precipitation_fraction_by_layer + long_name = precipitation fraction in each layer + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_cnv_frac] + standard_name = convective_cloud_fraction_for_RRTMGP + long_name = layer convective cloud fraction + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cnv_cloud_overlap_param] + standard_name = convective_cloud_overlap_param + long_name = convective cloud overlap parameter + units = km + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cloud_overlap_param] + standard_name = cloud_overlap_param + long_name = cloud overlap parameter + units = km + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[precip_overlap_param] + standard_name = precip_overlap_param + long_name = precipitation overlap parameter + units = km + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[sw_optical_props_cloudsByBand] + standard_name = shortwave_optical_properties_for_cloudy_atmosphere_by_band + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = in +[sw_optical_props_cnvcloudsByBand] + standard_name = shortwave_optical_properties_for_convective_cloudy_atmosphere_by_band + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = in +[sw_optical_props_precipByBand] + standard_name = shortwave_optical_properties_for_precipitation_by_band + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = in +[sw_optical_props_clouds] + standard_name = shortwave_optical_properties_for_cloudy_atmosphere + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = out +[sw_optical_props_cnvclouds] + standard_name = shortwave_optical_properties_for_convective_cloudy_atmosphere + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = out +[sw_optical_props_precip] + standard_name = shortwave_optical_properties_for_precipitation + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = out +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out diff --git a/physics/rrtmgp_sw_gas_optics.F90 b/physics/rrtmgp_sw_gas_optics.F90 index 9193b9134..260f65fe7 100644 --- a/physics/rrtmgp_sw_gas_optics.F90 +++ b/physics/rrtmgp_sw_gas_optics.F90 @@ -4,6 +4,7 @@ module rrtmgp_sw_gas_optics use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp use mo_gas_concentrations, only: ty_gas_concs use radiation_tools, only: check_error_msg + use mo_optical_props, only: ty_optical_props_2str use netcdf #ifdef MPI use mpi @@ -75,8 +76,11 @@ module rrtmgp_sw_gas_optics ! ######################################################################################### ! SUBROUTINE sw_gas_optics_init ! ######################################################################################### - subroutine rrtmgp_sw_gas_optics_init(rrtmgp_root_dir, rrtmgp_sw_file_gas, mpicomm, mpirank, & - mpiroot, active_gases_array, errmsg, errflg) +!! \section arg_table_rrtmgp_sw_gas_optics_init +!! \htmlinclude rrtmgp_sw_gas_optics.html +!! + subroutine rrtmgp_sw_gas_optics_init(rrtmgp_root_dir, rrtmgp_sw_file_gas, & + active_gases_array, mpicomm, mpirank, mpiroot, errmsg, errflg) ! Inputs character(len=128),intent(in) :: & @@ -477,4 +481,111 @@ subroutine rrtmgp_sw_gas_optics_init(rrtmgp_root_dir, rrtmgp_sw_file_gas, mpicom end subroutine rrtmgp_sw_gas_optics_init + ! ######################################################################################### + ! SUBROUTINE rrtmgp_sw_gas_optics_run + ! ######################################################################################### +!! \section arg_table_rrtmgp_sw_gas_optics_run +!! \htmlinclude rrtmgp_sw_gas_optics.html +!! + subroutine rrtmgp_sw_gas_optics_run(doSWrad, nCol, nLev, ngptsGPsw, nday, idxday, p_lay, & + p_lev, toa_src_sw, t_lay, t_lev, active_gases_array, gas_concentrations, solcon, & + sw_optical_props_clrsky, errmsg, errflg) + + ! Inputs + logical, intent(in) :: & + doSWrad ! Flag to calculate SW irradiances + integer,intent(in) :: & + ngptsGPsw, & ! Number of spectral (g) points. + nDay, & ! Number of daylit points. + nCol, & ! Number of horizontal points + nLev ! Number of vertical levels + integer,intent(in),dimension(ncol) :: & + idxday ! Indices for daylit points. + real(kind_phys), dimension(ncol,nLev), intent(in) :: & + p_lay, & ! Pressure @ model layer-centers (Pa) + t_lay ! Temperature (K) + real(kind_phys), dimension(ncol,nLev+1), intent(in) :: & + p_lev, & ! Pressure @ model layer-interfaces (Pa) + t_lev ! Temperature @ model levels + type(ty_gas_concs),intent(inout) :: & + gas_concentrations ! RRTMGP DDT: trace gas concentrations (vmr) + real(kind_phys), intent(in) :: & + solcon ! Solar constant + + ! Output + character(len=*), intent(out) :: & + errmsg ! CCPP error message + integer, intent(out) :: & + errflg ! CCPP error code + type(ty_optical_props_2str),intent(out) :: & + sw_optical_props_clrsky ! RRTMGP DDT: clear-sky shortwave optical properties, spectral (tau,ssa,g) + real(kind_phys), dimension(nCol,ngptsGPsw), intent(out) :: & + toa_src_sw ! TOA incident spectral flux (W/m2) + character(len=*), dimension(:), intent(in) :: & + active_gases_array ! List of active gases from namelist as array + + ! Local variables + integer :: ij,iGas + real(kind_phys), dimension(ncol,nLev) :: vmrTemp + real(kind_phys), dimension(nday,ngptsGPsw) :: toa_src_sw_temp + type(ty_gas_concs) :: gas_concentrations_daylit + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (.not. doSWrad) return + + gas_concentrations%gas_name(:) = active_gases_array(:) + + toa_src_sw(:,:) = 0._kind_phys + if (nDay .gt. 0) then + ! Allocate space + call check_error_msg('rrtmgp_sw_gas_optics_run_alloc_2str',& + sw_optical_props_clrsky%alloc_2str(nday, nLev, sw_gas_props)) + + gas_concentrations_daylit%ncol = nDay + gas_concentrations_daylit%nlay = nLev + allocate(gas_concentrations_daylit%gas_name(gas_concentrations%get_num_gases())) + allocate(gas_concentrations_daylit%concs(gas_concentrations%get_num_gases())) + do iGas=1,gas_concentrations%get_num_gases() + allocate(gas_concentrations_daylit%concs(iGas)%conc(nDay, nLev)) + enddo + gas_concentrations_daylit%gas_name(:) = active_gases_array(:) + + ! Subset the gas concentrations. + do iGas=1,gas_concentrations%get_num_gases() + call check_error_msg('rrtmgp_sw_gas_optics_run_get_vmr',& + gas_concentrations%get_vmr(trim(gas_concentrations_daylit%gas_name(iGas)),vmrTemp)) + call check_error_msg('rrtmgp_sw_gas_optics_run_set_vmr',& + gas_concentrations_daylit%set_vmr(trim(gas_concentrations_daylit%gas_name(iGas)),vmrTemp(idxday(1:nday),:))) + enddo + + ! Call SW gas-optics + call check_error_msg('rrtmgp_sw_gas_optics_run',sw_gas_props%gas_optics(& + p_lay(idxday(1:nday),:), & ! IN - Pressure @ layer-centers (Pa) + p_lev(idxday(1:nday),:), & ! IN - Pressure @ layer-interfaces (Pa) + t_lay(idxday(1:nday),:), & ! IN - Temperature @ layer-centers (K) + gas_concentrations_daylit, & ! IN - RRTMGP DDT: trace gas volumne mixing-ratios + sw_optical_props_clrsky, & ! OUT - RRTMGP DDT: Shortwave optical properties, by + ! spectral point (tau,ssa,g) + toa_src_sw_temp)) ! OUT - TOA incident shortwave radiation (spectral) + toa_src_sw(idxday(1:nday),:) = toa_src_sw_temp + + ! Scale incident flux + do ij=1,nday + toa_src_sw(idxday(ij),:) = toa_src_sw(idxday(ij),:)*solcon/ & + sum(toa_src_sw(idxday(ij),:)) + enddo + endif + + end subroutine rrtmgp_sw_gas_optics_run + + ! ######################################################################################### + ! SUBROUTINE rrtmgp_sw_gas_optics_finalize + ! ######################################################################################### + subroutine rrtmgp_sw_gas_optics_finalize() + end subroutine rrtmgp_sw_gas_optics_finalize + end module rrtmgp_sw_gas_optics + diff --git a/physics/rrtmgp_sw_gas_optics.meta b/physics/rrtmgp_sw_gas_optics.meta new file mode 100644 index 000000000..1fdbc946b --- /dev/null +++ b/physics/rrtmgp_sw_gas_optics.meta @@ -0,0 +1,201 @@ +[ccpp-table-properties] + name = rrtmgp_sw_gas_optics + type = scheme + dependencies = machine.F,radiation_tools.F90,GFS_rrtmgp_pre.F90,rte-rrtmgp/rrtmgp/mo_gas_optics_rrtmgp.F90,rte-rrtmgp/rte/mo_rte_kind.F90,rte-rrtmgp/rrtmgp/mo_gas_concentrations.F90,rte-rrtmgp/rte/mo_optical_props.F90 + +######################################################################## +[ccpp-arg-table] + name = rrtmgp_sw_gas_optics_init + type = scheme +[rrtmgp_root_dir] + standard_name = directory_for_rte_rrtmgp_source_code + long_name = directory for rte+rrtmgp source code + units = none + dimensions = () + type = character + intent = in + kind = len=128 +[rrtmgp_sw_file_gas] + standard_name = filename_of_rrtmgp_shortwave_k_distribution + long_name = file containing RRTMGP SW k-distribution + units = none + dimensions = () + type = character + intent = in + kind = len=128 +[active_gases_array] + standard_name = list_of_active_gases_used_by_RRTMGP + long_name = list of active gases used by RRTMGP + units = none + dimensions = (number_of_active_gases_used_by_RRTMGP) + type = character + kind = len=* + intent = in +[mpirank] + standard_name = mpi_rank + long_name = current MPI rank + units = index + dimensions = () + type = integer + intent = in +[mpiroot] + standard_name = mpi_root + long_name = master MPI rank + units = index + dimensions = () + type = integer + intent = in +[mpicomm] + standard_name = mpi_communicator + long_name = MPI communicator + units = index + dimensions = () + type = integer + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out + +######################################################################## +[ccpp-arg-table] + name = rrtmgp_sw_gas_optics_run + type = scheme +[doSWrad] + standard_name = flag_for_calling_shortwave_radiation + long_name = flag to calculate SW irradiances + units = flag + dimensions = () + type = logical + intent = in +[ncol] + standard_name = horizontal_loop_extent + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in +[nLev] + standard_name = vertical_layer_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in +[nday] + standard_name = daytime_points_dimension + long_name = daytime points dimension + units = count + dimensions = () + type = integer + intent = in +[idxday] + standard_name = daytime_points + long_name = daytime points + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[ngptsGPsw] + standard_name = number_of_shortwave_spectral_points + long_name = number of spectral points in RRTMGP SW calculation + units = count + dimensions = () + type = integer + intent = in +[p_lay] + standard_name = air_pressure_at_layer_for_RRTMGP + long_name = air pressure layer + units = Pa + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[p_lev] + standard_name = air_pressure_at_interface_for_RRTMGP + long_name = air pressure level + units = Pa + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in +[t_lay] + standard_name = air_temperature_at_layer_for_RRTMGP + long_name = air temperature layer + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[t_lev] + standard_name = air_temperature_at_interface_for_RRTMGP + long_name = air temperature level + units = K + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in +[toa_src_sw] + standard_name = toa_incident_sw_flux_by_spectral_point + long_name = TOA shortwave incident flux at each spectral points + units = W m-2 + dimensions = (horizontal_loop_extent,number_of_shortwave_spectral_points) + type = real + kind = kind_phys + intent = out +[active_gases_array] + standard_name = list_of_active_gases_used_by_RRTMGP + long_name = list of active gases used by RRTMGP + units = none + dimensions = (number_of_active_gases_used_by_RRTMGP) + type = character + kind = len=* + intent = in +[gas_concentrations] + standard_name = Gas_concentrations_for_RRTMGP_suite + long_name = DDT containing gas concentrations for RRTMGP radiation scheme + units = DDT + dimensions = () + type = ty_gas_concs + intent = inout +[solcon] + standard_name = solar_constant + long_name = solar constant + units = W m-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out +[sw_optical_props_clrsky] + standard_name = shortwave_optical_properties_for_clear_sky + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = out diff --git a/physics/rrtmgp_sw_main.F90 b/physics/rrtmgp_sw_main.F90 index 781af606b..66f4b7553 100644 --- a/physics/rrtmgp_sw_main.F90 +++ b/physics/rrtmgp_sw_main.F90 @@ -62,7 +62,7 @@ subroutine rrtmgp_sw_main_init(rrtmgp_root_dir, rrtmgp_sw_file_gas, mpicomm, mpi call rrtmgp_sw_gas_optics_init(rrtmgp_root_dir, rrtmgp_sw_file_gas, mpicomm, mpirank, & mpiroot, active_gases_array, errmsg, errflg) - ! RRTMGP shortwave cloud-optics initialization + ! RRTMGP shortwave cloud-optics initialization call rrtmgp_sw_cloud_optics_init(nrghice, mpicomm, mpirank, mpiroot, doG_cldoptics, & doGP_cldoptics_PADE, doGP_cldoptics_LUT, rrtmgp_root_dir, rrtmgp_sw_file_clouds, & errmsg, errflg) @@ -76,15 +76,16 @@ end subroutine rrtmgp_sw_main_init !! \htmlinclude rrtmgp_sw_main_run.html !! subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_sgs_pbl, & - nCol, nDay, nLay, nGases, i_o3, idx, icseed_sw, iovr, iovr_convcld, iovr_max, & + nCol, nDay, nLay, idx, icseed_sw, iovr, iovr_convcld, iovr_max, & iovr_maxrand, iovr_rand, iovr_dcorr, iovr_exp, iovr_exprand, isubc_sw, iSFC, & sfc_alb_nir_dir, sfc_alb_nir_dif, sfc_alb_uvvis_dir, sfc_alb_uvvis_dif, coszen, & p_lay, p_lev, t_lay, t_lev, vmr_o2, vmr_h2o, vmr_o3, vmr_ch4, vmr_n2o, vmr_co2, & cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, & cld_rerain, precip_frac, cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, cld_cnv_reice, & cld_pbl_lwp, cld_pbl_reliq, cld_pbl_iwp, cld_pbl_reice, cloud_overlap_param, & - active_gases_array, sw_optical_props_aerosol, scmpsw, fluxswUP_allsky, & - fluxswDOWN_allsky, fluxswUP_clrsky, fluxswDOWN_clrsky, cldtausw, errmsg, errflg) + active_gases_array, sw_optical_props_aerosol, gas_concentrations, solcon, scmpsw, & + fluxswUP_allsky, fluxswDOWN_allsky, fluxswUP_clrsky, fluxswDOWN_clrsky, cldtausw, & + errmsg, errflg) ! Inputs logical, intent(in) :: & @@ -97,8 +98,6 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ nCol, & ! Number of horizontal points nDay, & ! Number of daytime points nLay, & ! Number of vertical grid points. - nGases, & ! Number of active gases in RRTMGP - i_o3, & ! iovr, & ! Choice of cloud-overlap method iovr_convcld, & ! Choice of convective cloud-overlap iovr_max, & ! Flag for maximum cloud overlap method @@ -152,6 +151,10 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ active_gases_array ! List of active gases from namelist as array type(ty_optical_props_2str),intent(in) :: & sw_optical_props_aerosol ! RRTMGP DDT: Shortwave aerosol optical properties (tau,ssa,g) + type(ty_gas_concs), intent(in) :: & + gas_concentrations ! RRTMGP DDT: gas concentrations + real(kind_phys), intent(in) :: & + solcon ! Solar constant ! Outputs character(len=*), intent(out) :: & @@ -176,7 +179,7 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ ! Local variables type(ty_gas_concs) :: & - gas_concentrations ! RRTMGP DDT: trace gas concentrations (vmr) + gas_concs ! RRTMGP DDT: trace gas concentrations (vmr) type(ty_optical_props_2str) :: & sw_optical_props_clrsky, & ! RRTMGP DDT: Shortwave clear-sky radiative properties sw_optical_props_aerosol_local, & ! RRTMGP DDT: Shortave aerosol radiative properties @@ -204,351 +207,365 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ real(kind_phys), dimension(2,sw_gas_props%get_nband()) :: bandlimits real(kind_phys), dimension(2), parameter :: nIR_uvvis_bnd = (/12850,16000/) real(kind_phys), dimension(1,sw_gas_props%get_ngpt()) :: toa_src_sw + real(kind_phys), dimension(nCol, nLay, gas_concentrations%get_num_gases()) :: vmrTemp + ! Initialize CCPP error handling variables errmsg = '' errflg = 0 if (.not. doSWrad) return - fluxswUP_allsky(:,:) = 0._kind_phys - fluxswDOWN_allsky(:,:) = 0._kind_phys - fluxswUP_clrsky(:,:) = 0._kind_phys - fluxswDOWN_clrsky(:,:) = 0._kind_phys - scmpsw = cmpfsw_type( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 ) - if (nDay .le. 0) return - - ! ###################################################################################### - ! - ! Allocate/initialize RRTMGP DDT's - ! - ! ###################################################################################### - ! - ! ty_gas_concs - ! - gas_concentrations%ncol = 1 - gas_concentrations%nlay = nLay - allocate(gas_concentrations%gas_name(nGases)) - allocate(gas_concentrations%concs(nGases)) - do iGas=1,nGases - allocate(gas_concentrations%concs(iGas)%conc(1, nLay)) - enddo - gas_concentrations%gas_name(:) = active_gases_array(:) - ! - ! ty_optical_props - ! - call check_error_msg('rrtmgp_sw_main_gas_optics_init',& - sw_optical_props_clrsky%alloc_2str(1, nLay, sw_gas_props)) - call check_error_msg('rrtmgp_sw_main_cloud_optics_init',& - sw_optical_props_cloudsByBand%alloc_2str(1, nLay, sw_gas_props%get_band_lims_wavenumber())) - call check_error_msg('rrtmgp_sw_main_precip_optics_init',& - sw_optical_props_precipByBand%alloc_2str(1, nLay, sw_gas_props%get_band_lims_wavenumber())) - call check_error_msg('rrtmgp_sw_mian_cloud_sampling_init', & - sw_optical_props_clouds%alloc_2str(1, nLay, sw_gas_props)) - call check_error_msg('rrtmgp_sw_main_aerosol_optics_init',& - sw_optical_props_aerosol_local%alloc_2str(1, nLay, sw_gas_props%get_band_lims_wavenumber())) - if (doGP_sgs_cnv) then - call check_error_msg('rrtmgp_sw_main_cnv_cloud_optics_init',& - sw_optical_props_cnvcloudsByBand%alloc_2str(1, nLay, sw_gas_props%get_band_lims_wavenumber())) - endif - if (doGP_sgs_pbl) then - call check_error_msg('rrtmgp_sw_main_pbl_cloud_optics_init',& - sw_optical_props_pblcloudsByBand%alloc_2str(1, nLay, sw_gas_props%get_band_lims_wavenumber())) - endif - ! - ! ty_fluxes_byband - ! - flux_allsky%bnd_flux_up => fluxSW_up_allsky - flux_allsky%bnd_flux_dn => fluxSW_dn_allsky - flux_allsky%bnd_flux_dn_dir => fluxSW_dn_dir_allsky - flux_clrsky%bnd_flux_up => fluxSW_up_clrsky - flux_clrsky%bnd_flux_dn => fluxSW_dn_clrsky - - ! Loop over all (daylit)columns... - do iCol=1,nDay - ix = idx(iCol) - - ! Initialize/reset - sw_optical_props_clouds%tau = 0._kind_phys - sw_optical_props_clouds%ssa = 1._kind_phys - sw_optical_props_clouds%g = 0._kind_phys - sw_optical_props_clrsky%tau = 0._kind_phys - sw_optical_props_clrsky%ssa = 1._kind_phys - sw_optical_props_clrsky%g = 0._kind_phys - sw_optical_props_cloudsByBand%tau = 0._kind_phys - sw_optical_props_cloudsByBand%ssa = 1._kind_phys - sw_optical_props_cloudsByBand%g = 0._kind_phys - sw_optical_props_precipByBand%tau = 0._kind_phys - sw_optical_props_precipByBand%ssa = 1._kind_phys - sw_optical_props_precipByBand%g = 0._kind_phys - sw_optical_props_aerosol_local%tau = 0._kind_phys - sw_optical_props_aerosol_local%ssa = 1._kind_phys - sw_optical_props_aerosol_local%g = 0._kind_phys - if (doGP_sgs_cnv) then - sw_optical_props_cnvcloudsByBand%tau = 0._kind_phys - sw_optical_props_cnvcloudsByBand%ssa = 1._kind_phys - sw_optical_props_cnvcloudsByBand%g = 0._kind_phys - endif - if (doGP_sgs_pbl) then - sw_optical_props_pblcloudsByBand%tau = 0._kind_phys - sw_optical_props_pblcloudsByBand%ssa = 1._kind_phys - sw_optical_props_pblcloudsByBand%g = 0._kind_phys - endif - ! ################################################################################### - ! - ! Set gas-concentrations + if (nDay .gt. 0) then + ! ###################################################################################### ! - ! ################################################################################### - gas_concentrations%concs(istr_o2)%conc(1,:) = vmr_o2(ix,:) - gas_concentrations%concs(istr_co2)%conc(1,:) = vmr_co2(ix,:) - gas_concentrations%concs(istr_ch4)%conc(1,:) = vmr_ch4(ix,:) - gas_concentrations%concs(istr_n2o)%conc(1,:) = vmr_n2o(ix,:) - gas_concentrations%concs(istr_h2o)%conc(1,:) = vmr_h2o(ix,:) - gas_concentrations%concs(istr_o3)%conc(1,:) = vmr_o3(ix,:) - - ! ################################################################################### + ! Allocate/initialize RRTMGP DDT's ! - ! Set surface albedo - ! - ! Use near-IR albedo for bands with wavenumbers extending to 12850cm-1 - ! Use uv-vis albedo for bands with wavenumbers greater than 16000cm-1 - ! For overlapping band, average near-IR and us-vis albedos. - ! - ! ################################################################################### + ! ###################################################################################### bandlimits = sw_gas_props%get_band_lims_wavenumber() - do iBand=1,sw_gas_props%get_nband() - if (bandlimits(1,iBand) .lt. nIR_uvvis_bnd(1)) then - sfc_alb_dir(iBand,1) = sfc_alb_nir_dir(ix) - sfc_alb_dif(iBand,1) = sfc_alb_nir_dif(ix) - endif - if (bandlimits(1,iBand) .eq. nIR_uvvis_bnd(1)) then - sfc_alb_dir(iBand,1) = 0.5_kind_phys*(sfc_alb_nir_dir(ix) + sfc_alb_uvvis_dir(ix)) - sfc_alb_dif(iBand,1) = 0.5_kind_phys*(sfc_alb_nir_dif(ix) + sfc_alb_uvvis_dif(ix)) - ibd = iBand - endif - if (bandlimits(1,iBand) .ge. nIR_uvvis_bnd(2)) then - sfc_alb_dir(iBand,1) = sfc_alb_uvvis_dir(ix) - sfc_alb_dif(iBand,1) = sfc_alb_uvvis_dif(ix) - endif - enddo - - ! ################################################################################### ! - ! Gas-optics + ! ty_gas_concs ! - ! ################################################################################### - call check_error_msg('rrtmgp_sw_main_gas_optics',sw_gas_props%gas_optics(& - p_lay(ix:ix,:), & ! IN - Pressure @ layer-centers (Pa) - p_lev(ix:ix,:), & ! IN - Pressure @ layer-interfaces (Pa) - t_lay(ix:ix,:), & ! IN - Temperature @ layer-centers (K) - gas_concentrations, & ! IN - RRTMGP DDT: trace gas volumne mixing-ratios - sw_optical_props_clrsky, & ! OUT - RRTMGP DDT: Shortwave optical properties, by - ! spectral point (tau,ssa,g) - toa_src_sw)) ! OUT - TOA incident shortwave radiation (spectral) - - ! ################################################################################### + gas_concs%ncol = 1 + gas_concs%nlay = nLay + allocate(gas_concs%gas_name(gas_concentrations%get_num_gases())) + allocate(gas_concs%concs(gas_concentrations%get_num_gases())) + do iGas=1,gas_concentrations%get_num_gases() + allocate(gas_concs%concs(iGas)%conc(1, nLay)) + enddo + gas_concs%gas_name(:) = active_gases_array(:) + do iGas=1,gas_concentrations%get_num_gases() + call check_error_msg('rrtmgp_sw_main_get_vmr',& + gas_concentrations%get_vmr(trim(gas_concentrations%gas_name(iGas)),vmrTemp(:,:,iGas))) + enddo ! - ! Cloud-optics + ! ty_optical_props ! - ! ################################################################################### - call check_error_msg('rrtmgp_sw_main_cloud_optics',sw_cloud_props%cloud_optics(& - cld_lwp(ix:ix,:), & ! IN - Cloud liquid water path - cld_iwp(ix:ix,:), & ! IN - Cloud ice water path - cld_reliq(ix:ix,:), & ! IN - Cloud liquid effective radius - cld_reice(ix:ix,:), & ! IN - Cloud ice effective radius - sw_optical_props_cloudsByBand)) ! OUT - RRTMGP DDT: Shortwave optical properties, - ! in each band (tau,ssa,g) - cldtausw(ix,:) = sw_optical_props_cloudsByBand%tau(1,:,11) - - ! Convective cloud-optics? + call check_error_msg('rrtmgp_sw_main_gas_optics_init',& + sw_optical_props_clrsky%alloc_2str(1, nLay, sw_gas_props)) + call check_error_msg('rrtmgp_sw_main_cloud_optics_init',& + sw_optical_props_cloudsByBand%alloc_2str(1, nLay, sw_gas_props%get_band_lims_wavenumber())) + call check_error_msg('rrtmgp_sw_main_precip_optics_init',& + sw_optical_props_precipByBand%alloc_2str(1, nLay, sw_gas_props%get_band_lims_wavenumber())) + call check_error_msg('rrtmgp_sw_mian_cloud_sampling_init', & + sw_optical_props_clouds%alloc_2str(1, nLay, sw_gas_props)) + call check_error_msg('rrtmgp_sw_main_aerosol_optics_init',& + sw_optical_props_aerosol_local%alloc_2str(1, nLay, sw_gas_props%get_band_lims_wavenumber())) if (doGP_sgs_cnv) then - call check_error_msg('rrtmgp_sw_main_cnv_cloud_optics',sw_cloud_props%cloud_optics(& - cld_cnv_lwp(ix:ix,:), & ! IN - Convective cloud liquid water path (g/m2) - cld_cnv_iwp(ix:ix,:), & ! IN - Convective cloud ice water path (g/m2) - cld_cnv_reliq(ix:ix,:), & ! IN - Convective cloud liquid effective radius (microns) - cld_cnv_reice(ix:ix,:), & ! IN - Convective cloud ice effective radius (microns) - sw_optical_props_cnvcloudsByBand)) ! OUT - RRTMGP DDT containing convective cloud radiative properties - ! in each band - !call check_error_msg('rrtmgp_sw_main_increment_cnvclouds_to_clouds',& - ! sw_optical_props_cnvcloudsByBand%increment(sw_optical_props_cloudsByBand)) + call check_error_msg('rrtmgp_sw_main_cnv_cloud_optics_init',& + sw_optical_props_cnvcloudsByBand%alloc_2str(1, nLay, sw_gas_props%get_band_lims_wavenumber())) endif - - ! MYNN PBL cloud-optics? if (doGP_sgs_pbl) then - call check_error_msg('rrtmgp_sw_main_pbl_cloud_optics',sw_cloud_props%cloud_optics(& - cld_pbl_lwp(ix:ix,:), & ! IN - MYNN-EDMF PBL cloud liquid water path (g/m2) - cld_pbl_iwp(ix:ix,:), & ! IN - MYNN-EDMF PBL cloud ice water path (g/m2) - cld_pbl_reliq(ix:ix,:), & ! IN - MYNN-EDMF PBL cloud liquid effective radius (microns) - cld_pbl_reice(ix:ix,:), & ! IN - MYNN-EDMF PBL cloud ice effective radius (microns) - sw_optical_props_pblcloudsByBand)) ! OUT - RRTMGP DDT containing MYNN-EDMF PBL cloud radiative properties - ! in each band - !call check_error_msg('rrtmgp_sw_main_increment_pblclouds_to_clouds',& - ! sw_optical_props_pblcloudsByBand%increment(sw_optical_props_cloudsByBand)) + call check_error_msg('rrtmgp_sw_main_pbl_cloud_optics_init',& + sw_optical_props_pblcloudsByBand%alloc_2str(1, nLay, sw_gas_props%get_band_lims_wavenumber())) endif - - ! Cloud precipitation optics: rain and snow(+groupel) - do iLay=1,nLay - if (cld_frac(ix,iLay) .gt. 1.e-12_kind_phys) then - ! Rain/Snow optical depth (No band dependence) - tau_rain = cld_rwp(ix,iLay)*a0r - if (cld_swp(ix,iLay) .gt. 0. .and. cld_resnow(ix,iLay) .gt. 10._kind_phys) then - tau_snow = cld_swp(ix,iLay)*1.09087*(a0s + a1s/(1.0315*cld_resnow(ix,iLay))) ! fu's formula - else - tau_snow = 0._kind_phys - endif - - ! Rain/Snow single-scattering albedo and asymmetry (Band dependent) - do iBand=1,sw_gas_props%get_nband() - ! By species - ssa_rain = tau_rain*(1.-b0r(iBand)) - asy_rain = ssa_rain*c0r(iBand) - ssa_snow = tau_snow*(1.-(b0s(iBand)+b1s(iBand)*1.0315*cld_resnow(ix,iLay))) - asy_snow = ssa_snow*c0s(iBand) - ! Combine - tau_prec = max(1.e-12_kind_phys, tau_rain + tau_snow) - ssa_prec = max(1.e-12_kind_phys, ssa_rain + ssa_snow) - asy_prec = max(1.e-12_kind_phys, asy_rain + asy_snow) - asyw = asy_prec/max(1.e-12_kind_phys, ssa_prec) - ssaw = min(1._kind_phys-0.000001, ssa_prec/tau_prec) - za1 = asyw * asyw - za2 = ssaw * za1 - sw_optical_props_precipByBand%tau(1,iLay,iBand) = (1._kind_phys - za2) * tau_prec - sw_optical_props_precipByBand%ssa(1,iLay,iBand) = (ssaw - za2) / (1._kind_phys - za2) - sw_optical_props_precipByBand%g(1,iLay,iBand) = asyw/(1+asyw) - enddo - endif - enddo - - ! ################################################################################### ! - ! Cloud-sampling + ! ty_fluxes_byband ! - ! ################################################################################### - ! Change random number seed value for each radiation invocation (isubc_sw =1 or 2). - if(isubc_sw == 1) then ! advance prescribed permutation seed - ipseed_sw = sw_gas_props%get_ngpt() + iCol - elseif (isubc_sw == 2) then ! use input array of permutaion seeds - ipseed_sw = icseed_sw(ix) - endif - ! Call RNG - call random_setseed(ipseed_sw,rng_stat) - ! Use same rng for each layer - if (iovr == iovr_max) then - call random_number(rng1D,rng_stat) - do iLay=1,nLay - rng3D(:,iLay,1) = rng1D + flux_allsky%bnd_flux_up => fluxSW_up_allsky + flux_allsky%bnd_flux_dn => fluxSW_dn_allsky + flux_allsky%bnd_flux_dn_dir => fluxSW_dn_dir_allsky + flux_clrsky%bnd_flux_up => fluxSW_up_clrsky + flux_clrsky%bnd_flux_dn => fluxSW_dn_clrsky + + ! Loop over all (daylit) columns... + do iCol=1,nDay + ix = idx(iCol) + + ! Initialize/reset + fluxSW_up_allsky = 0._kind_phys + fluxSW_dn_allsky = 0._kind_phys + fluxSW_dn_dir_allsky = 0._kind_phys + fluxSW_up_clrsky = 0._kind_phys + fluxSW_dn_clrsky = 0._kind_phys + sw_optical_props_clouds%tau = 0._kind_phys + sw_optical_props_clouds%ssa = 0._kind_phys + sw_optical_props_clouds%g = 0._kind_phys + sw_optical_props_clrsky%tau = 0._kind_phys + sw_optical_props_clrsky%ssa = 0._kind_phys + sw_optical_props_clrsky%g = 0._kind_phys + sw_optical_props_cloudsByBand%tau = 0._kind_phys + sw_optical_props_cloudsByBand%ssa = 0._kind_phys + sw_optical_props_cloudsByBand%g = 0._kind_phys + sw_optical_props_precipByBand%tau = 0._kind_phys + sw_optical_props_precipByBand%ssa = 0._kind_phys + sw_optical_props_precipByBand%g = 0._kind_phys + sw_optical_props_aerosol_local%tau = 0._kind_phys + sw_optical_props_aerosol_local%ssa = 0._kind_phys + sw_optical_props_aerosol_local%g = 0._kind_phys + if (doGP_sgs_cnv) then + sw_optical_props_cnvcloudsByBand%tau = 0._kind_phys + sw_optical_props_cnvcloudsByBand%ssa = 0._kind_phys + sw_optical_props_cnvcloudsByBand%g = 0._kind_phys + endif + if (doGP_sgs_pbl) then + sw_optical_props_pblcloudsByBand%tau = 0._kind_phys + sw_optical_props_pblcloudsByBand%ssa = 0._kind_phys + sw_optical_props_pblcloudsByBand%g = 0._kind_phys + endif + + ! ################################################################################### + ! + ! Set gas-concentrations + ! + ! ################################################################################### + ! Subset the gas concentrations. + do iGas=1,gas_concentrations%get_num_gases() + call check_error_msg('rrtmgp_sw_gas_optics_run_set_vmr',& + gas_concs%set_vmr(trim(gas_concentrations%gas_name(iGas)),vmrTemp(ix,:,iGas))) enddo - else + + ! ################################################################################### + ! + ! Set surface albedo + ! + ! Use near-IR albedo for bands with wavenumbers extending to 12850cm-1 + ! Use uv-vis albedo for bands with wavenumbers greater than 16000cm-1 + ! For overlapping band, average near-IR and us-vis albedos. + ! + ! ################################################################################### + do iBand=1,sw_gas_props%get_nband() + if (bandlimits(1,iBand) .lt. nIR_uvvis_bnd(1)) then + sfc_alb_dir(iBand,1) = sfc_alb_nir_dir(ix) + sfc_alb_dif(iBand,1) = sfc_alb_nir_dif(ix) + endif + if (bandlimits(1,iBand) .eq. nIR_uvvis_bnd(1)) then + sfc_alb_dir(iBand,1) = 0.5_kind_phys*(sfc_alb_nir_dir(ix) + sfc_alb_uvvis_dir(ix)) + sfc_alb_dif(iBand,1) = 0.5_kind_phys*(sfc_alb_nir_dif(ix) + sfc_alb_uvvis_dif(ix)) + ibd = iBand + endif + if (bandlimits(1,iBand) .ge. nIR_uvvis_bnd(2)) then + sfc_alb_dir(iBand,1) = sfc_alb_uvvis_dir(ix) + sfc_alb_dif(iBand,1) = sfc_alb_uvvis_dif(ix) + endif + enddo + + ! ################################################################################### + ! + ! Gas-optics + ! + ! ################################################################################### + call check_error_msg('rrtmgp_sw_main_gas_optics',sw_gas_props%gas_optics(& + p_lay(ix:ix,:), & ! IN - Pressure @ layer-centers (Pa) + p_lev(ix:ix,:), & ! IN - Pressure @ layer-interfaces (Pa) + t_lay(ix:ix,:), & ! IN - Temperature @ layer-centers (K) + gas_concs, & ! IN - RRTMGP DDT: trace gas volumne mixing-ratios + sw_optical_props_clrsky, & ! OUT - RRTMGP DDT: Shortwave optical properties, by + ! spectral point (tau,ssa,g) + toa_src_sw)) ! OUT - TOA incident shortwave radiation (spectral) + + ! Scale incident flux + toa_src_sw(1,:) = toa_src_sw(1,:)*solcon / sum(toa_src_sw(1,:)) + ! ################################################################################### + ! + ! Cloud-optics + ! + ! ################################################################################### + call check_error_msg('rrtmgp_sw_main_cloud_optics',sw_cloud_props%cloud_optics(& + cld_lwp(ix:ix,:), & ! IN - Cloud liquid water path + cld_iwp(ix:ix,:), & ! IN - Cloud ice water path + cld_reliq(ix:ix,:), & ! IN - Cloud liquid effective radius + cld_reice(ix:ix,:), & ! IN - Cloud ice effective radius + sw_optical_props_cloudsByBand)) ! OUT - RRTMGP DDT: Shortwave optical properties, + ! in each band (tau,ssa,g) + cldtausw(ix,:) = sw_optical_props_cloudsByBand%tau(1,:,11) + + ! Convective cloud-optics? + if (doGP_sgs_cnv) then + call check_error_msg('rrtmgp_sw_main_cnv_cloud_optics',sw_cloud_props%cloud_optics(& + cld_cnv_lwp(ix:ix,:), & ! IN - Convective cloud liquid water path (g/m2) + cld_cnv_iwp(ix:ix,:), & ! IN - Convective cloud ice water path (g/m2) + cld_cnv_reliq(ix:ix,:), & ! IN - Convective cloud liquid effective radius (microns) + cld_cnv_reice(ix:ix,:), & ! IN - Convective cloud ice effective radius (microns) + sw_optical_props_cnvcloudsByBand)) ! OUT - RRTMGP DDT containing convective cloud radiative properties + ! in each band + !call check_error_msg('rrtmgp_sw_main_increment_cnvclouds_to_clouds',& + ! sw_optical_props_cnvcloudsByBand%increment(sw_optical_props_cloudsByBand)) + endif + + ! MYNN PBL cloud-optics? + if (doGP_sgs_pbl) then + call check_error_msg('rrtmgp_sw_main_pbl_cloud_optics',sw_cloud_props%cloud_optics(& + cld_pbl_lwp(ix:ix,:), & ! IN - MYNN-EDMF PBL cloud liquid water path (g/m2) + cld_pbl_iwp(ix:ix,:), & ! IN - MYNN-EDMF PBL cloud ice water path (g/m2) + cld_pbl_reliq(ix:ix,:), & ! IN - MYNN-EDMF PBL cloud liquid effective radius (microns) + cld_pbl_reice(ix:ix,:), & ! IN - MYNN-EDMF PBL cloud ice effective radius (microns) + sw_optical_props_pblcloudsByBand)) ! OUT - RRTMGP DDT containing MYNN-EDMF PBL cloud radiative properties + ! in each band + !call check_error_msg('rrtmgp_sw_main_increment_pblclouds_to_clouds',& + ! sw_optical_props_pblcloudsByBand%increment(sw_optical_props_cloudsByBand)) + endif + + ! Cloud precipitation optics: rain and snow(+groupel) do iLay=1,nLay - call random_number(rng1D,rng_stat) - rng3D(:,iLay,1) = rng1D + if (cld_frac(ix,iLay) .gt. 1.e-12_kind_phys) then + ! Rain/Snow optical depth (No band dependence) + tau_rain = cld_rwp(ix,iLay)*a0r + if (cld_swp(ix,iLay) .gt. 0. .and. cld_resnow(ix,iLay) .gt. 10._kind_phys) then + tau_snow = cld_swp(ix,iLay)*1.09087*(a0s + a1s/(1.0315*cld_resnow(ix,iLay))) ! fu's formula + else + tau_snow = 0._kind_phys + endif + + ! Rain/Snow single-scattering albedo and asymmetry (Band dependent) + do iBand=1,sw_gas_props%get_nband() + ! By species + ssa_rain = tau_rain*(1.-b0r(iBand)) + asy_rain = ssa_rain*c0r(iBand) + ssa_snow = tau_snow*(1.-(b0s(iBand)+b1s(iBand)*1.0315*cld_resnow(ix,iLay))) + asy_snow = ssa_snow*c0s(iBand) + ! Combine + tau_prec = max(1.e-12_kind_phys, tau_rain + tau_snow) + ssa_prec = max(1.e-12_kind_phys, ssa_rain + ssa_snow) + asy_prec = max(1.e-12_kind_phys, asy_rain + asy_snow) + asyw = asy_prec/max(1.e-12_kind_phys, ssa_prec) + ssaw = min(1._kind_phys-0.000001, ssa_prec/tau_prec) + za1 = asyw * asyw + za2 = ssaw * za1 + sw_optical_props_precipByBand%tau(1,iLay,iBand) = (1._kind_phys - za2) * tau_prec + sw_optical_props_precipByBand%ssa(1,iLay,iBand) = (ssaw - za2) / (1._kind_phys - za2) + sw_optical_props_precipByBand%g(1,iLay,iBand) = asyw/(1+asyw) + enddo + endif enddo - endif - ! Cloud-overlap. - ! Maximum-random, random or maximum. - if (iovr == iovr_maxrand .or. iovr == iovr_rand .or. iovr == iovr_max) then - call sampled_mask(rng3D, cld_frac(ix:ix,:), maskMCICA) - endif - ! Exponential decorrelation length overlap - if (iovr == iovr_dcorr) then - ! Generate second RNG + + ! ################################################################################### + ! + ! Cloud-sampling + ! + ! ################################################################################### + ! Change random number seed value for each radiation invocation (isubc_sw =1 or 2). + if(isubc_sw == 1) then ! advance prescribed permutation seed + ipseed_sw = sw_gas_props%get_ngpt() + iCol + elseif (isubc_sw == 2) then ! use input array of permutaion seeds + ipseed_sw = icseed_sw(ix) + endif + ! Call RNG call random_setseed(ipseed_sw,rng_stat) - call random_number(rng2D,rng_stat) - rng3D2(:,:,1) = reshape(source = rng2D,shape=[sw_gas_props%get_ngpt(),nLay]) + ! Use same rng for each layer + if (iovr == iovr_max) then + call random_number(rng1D,rng_stat) + do iLay=1,nLay + rng3D(:,iLay,1) = rng1D + enddo + else + do iLay=1,nLay + call random_number(rng1D,rng_stat) + rng3D(:,iLay,1) = rng1D + enddo + endif + ! Cloud-overlap. + ! Maximum-random, random or maximum. + if (iovr == iovr_maxrand .or. iovr == iovr_rand .or. iovr == iovr_max) then + call sampled_mask(rng3D, cld_frac(ix:ix,:), maskMCICA) + endif + ! Exponential decorrelation length overlap + if (iovr == iovr_dcorr) then + ! Generate second RNG + call random_setseed(ipseed_sw,rng_stat) + call random_number(rng2D,rng_stat) + rng3D2(:,:,1) = reshape(source = rng2D,shape=[sw_gas_props%get_ngpt(),nLay]) + ! + call sampled_mask(rng3D, cld_frac(ix:ix,:), maskMCICA, & + overlap_param = cloud_overlap_param(ix:ix,1:nLay-1), randoms2 = rng3D2) + endif + ! Exponential or Exponential-random + if (iovr == iovr_exp .or. iovr == iovr_exprand) then + call sampled_mask(rng3D, cld_frac(ix:ix,:), maskMCICA, & + overlap_param = cloud_overlap_param(ix:ix,1:nLay-1)) + endif + ! Sampling. Map band optical depth to each g-point using McICA + call check_error_msg('rrtmgp_sw_main_cloud_sampling',& + draw_samples(maskMCICA, .true., & + sw_optical_props_cloudsByBand, sw_optical_props_clouds)) + + ! ################################################################################### ! - call sampled_mask(rng3D, cld_frac(ix:ix,:), maskMCICA, & - overlap_param = cloud_overlap_param(ix:ix,1:nLay-1), randoms2 = rng3D2) - endif - ! Exponential or Exponential-random - if (iovr == iovr_exp .or. iovr == iovr_exprand) then - call sampled_mask(rng3D, cld_frac(ix:ix,:), maskMCICA, & - overlap_param = cloud_overlap_param(ix:ix,1:nLay-1)) - endif - ! Sampling. Map band optical depth to each g-point using McICA - call check_error_msg('rrtmgp_sw_main_cloud_sampling',& - draw_samples(maskMCICA, .true., & - sw_optical_props_cloudsByBand, sw_optical_props_clouds)) - - ! ################################################################################### - ! - ! Compute clear-sky fluxes (gaseous+aerosol) (optional) - ! - ! ################################################################################### - ! Add aerosol optics to gas optics - sw_optical_props_aerosol_local%tau = sw_optical_props_aerosol%tau(iCol:iCol,:,:) - sw_optical_props_aerosol_local%ssa = sw_optical_props_aerosol%ssa(iCol:iCol,:,:) - sw_optical_props_aerosol_local%g = sw_optical_props_aerosol%g(iCol:iCol,:,:) - call check_error_msg('rrtmgp_sw_main_increment_aerosol_to_clrsky',& - sw_optical_props_aerosol_local%increment(sw_optical_props_clrsky)) - - ! Delta-scale optical properties - call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_clrsky%delta_scale()) - if (doSWclrsky) then - call check_error_msg('rrtmgp_sw_main_rte_sw_clrsky',rte_sw( & - sw_optical_props_clrsky, & ! IN - optical-properties + ! Compute clear-sky fluxes (gaseous+aerosol) (optional) + ! + ! ################################################################################### + ! Add aerosol optics to gas optics + sw_optical_props_aerosol_local%tau = sw_optical_props_aerosol%tau(iCol:iCol,:,:) + sw_optical_props_aerosol_local%ssa = sw_optical_props_aerosol%ssa(iCol:iCol,:,:) + sw_optical_props_aerosol_local%g = sw_optical_props_aerosol%g(iCol:iCol,:,:) + call check_error_msg('rrtmgp_sw_main_increment_aerosol_to_clrsky',& + sw_optical_props_aerosol_local%increment(sw_optical_props_clrsky)) + + ! Delta-scale optical properties + call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_clrsky%delta_scale()) + if (doSWclrsky) then + call check_error_msg('rrtmgp_sw_main_rte_sw_clrsky',rte_sw( & + sw_optical_props_clrsky, & ! IN - optical-properties + top_at_1, & ! IN - veritcal ordering flag + coszen(ix:ix), & ! IN - Cosine of solar zenith angle + toa_src_sw, & ! IN - incident solar flux at TOA + sfc_alb_dir, & ! IN - Shortwave surface albedo (direct) + sfc_alb_dif, & ! IN - Shortwave surface albedo (diffuse) + flux_clrsky)) ! OUT - Fluxes, clear-sky, 3D (1,nLay,nBand) + ! Store fluxes + fluxswUP_clrsky(ix,:) = sum(flux_clrsky%bnd_flux_up(1,:,:),dim=2) + fluxswDOWN_clrsky(ix,:) = sum(flux_clrsky%bnd_flux_dn(1,:,:),dim=2) + else + fluxswUP_clrsky(ix,:) = 0.0 + fluxswDOWN_clrsky(ix,:) = 0.0 + endif + + ! ################################################################################### + ! + ! All-sky fluxes (clear-sky + clouds + precipitation) + ! + ! ################################################################################### + + ! Include convective cloud? + if (doGP_sgs_cnv) then + call check_error_msg('rrtmgp_sw_main_increment_cnvclouds_to_clrsky',& + sw_optical_props_cnvcloudsByBand%increment(sw_optical_props_clouds)) + endif + + ! Include MYNN-EDMF PBL clouds? + if (doGP_sgs_pbl) then + call check_error_msg('rrtmgp_sw_main_increment_pblclouds_to_clrsky',& + sw_optical_props_pblcloudsByBand%increment(sw_optical_props_clouds)) + endif + + ! Add in precipitation + call check_error_msg('rrtmgp_sw_main_increment_precip_to_clrsky',& + sw_optical_props_precipByBand%increment(sw_optical_props_clouds)) + + ! Delta-scale optical properties + call check_error_msg('rrtmgp_sw_main_delta_scale',sw_optical_props_clrsky%delta_scale()) + call check_error_msg('rrtmgp_sw_main_rte_sw_allsky',rte_sw( & + sw_optical_props_clouds, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag coszen(ix:ix), & ! IN - Cosine of solar zenith angle toa_src_sw, & ! IN - incident solar flux at TOA sfc_alb_dir, & ! IN - Shortwave surface albedo (direct) sfc_alb_dif, & ! IN - Shortwave surface albedo (diffuse) - flux_clrsky)) ! OUT - Fluxes, clear-sky, 3D (1,nLay,nBand) + flux_allsky)) ! OUT - Fluxes, clear-sky, 3D (1,nLay,nBand) + ! Store fluxes - fluxswUP_clrsky(ix,:) = sum(flux_clrsky%bnd_flux_up(1,:,:),dim=2) - fluxswDOWN_clrsky(ix,:) = sum(flux_clrsky%bnd_flux_dn(1,:,:),dim=2) - else - fluxswUP_clrsky(ix,:) = 0.0 - fluxswDOWN_clrsky(ix,:) = 0.0 - endif - - ! ################################################################################### - ! - ! All-sky fluxes (clear-sky + clouds + precipitation) - ! - ! ################################################################################### - - ! Include convective cloud? - if (doGP_sgs_cnv) then - call check_error_msg('rrtmgp_sw_main_increment_cnvclouds_to_clrsky',& - sw_optical_props_cnvcloudsByBand%increment(sw_optical_props_clouds)) - endif - - ! Include MYNN-EDMF PBL clouds? - if (doGP_sgs_pbl) then - call check_error_msg('rrtmgp_sw_main_increment_pblclouds_to_clrsky',& - sw_optical_props_pblcloudsByBand%increment(sw_optical_props_clouds)) - endif - - ! Add in precipitation - call check_error_msg('rrtmgp_sw_main_increment_precip_to_clrsky',& - sw_optical_props_precipByBand%increment(sw_optical_props_clouds)) - - ! Delta-scale optical properties - call check_error_msg('rrtmgp_sw_main_delta_scale',sw_optical_props_clrsky%delta_scale()) - call check_error_msg('rrtmgp_sw_main_rte_sw_allsky',rte_sw( & - sw_optical_props_clouds, & ! IN - optical-properties - top_at_1, & ! IN - veritcal ordering flag - coszen(ix:ix), & ! IN - Cosine of solar zenith angle - toa_src_sw, & ! IN - incident solar flux at TOA - sfc_alb_dir, & ! IN - Shortwave surface albedo (direct) - sfc_alb_dif, & ! IN - Shortwave surface albedo (diffuse) - flux_allsky)) ! OUT - Fluxes, clear-sky, 3D (1,nLay,nBand) - - ! Store fluxes - fluxswUP_allsky(ix,:) = sum(flux_allsky%bnd_flux_up(1,:,:),dim=2) - fluxswDOWN_allsky(ix,:) = sum(flux_allsky%bnd_flux_dn(1,:,:),dim=2) - ! Near IR - scmpsw(ix)%nirbm = sum(flux_allsky%bnd_flux_dn_dir(1,iSFC,1:ibd-1)) + & - flux_allsky%bnd_flux_dn_dir(1,iSFC,ibd)/2. - scmpsw(ix)%nirdf = (sum(flux_allsky%bnd_flux_dn(1,iSFC,1:ibd-1)) + & - flux_allsky%bnd_flux_dn(1,iSFC,ibd)/2.) - & - (sum(flux_allsky%bnd_flux_dn_dir(1,iSFC,1:ibd-1)) + & - flux_allsky%bnd_flux_dn_dir(1,iSFC,ibd)/2.) - ! UV-VIS - scmpsw(ix)%visbm = sum(flux_allsky%bnd_flux_dn_dir(1,iSFC,ibd+1:sw_gas_props%get_nband())) + & - flux_allsky%bnd_flux_dn_dir(1,iSFC,ibd)/2. - scmpsw(ix)%visdf = (sum(flux_allsky%bnd_flux_dn(1,iSFC,ibd+1:sw_gas_props%get_nband())) + & - flux_allsky%bnd_flux_dn(1,iSFC,ibd)/2. ) - & - (sum(flux_allsky%bnd_flux_dn_dir(1,iSFC,ibd+1:sw_gas_props%get_nband())) + & - flux_allsky%bnd_flux_dn_dir(1,iSFC,ibd)/2.) - enddo + fluxswUP_allsky(ix,:) = sum(flux_allsky%bnd_flux_up(1,:,:),dim=2) + fluxswDOWN_allsky(ix,:) = sum(flux_allsky%bnd_flux_dn(1,:,:),dim=2) + ! Near IR + scmpsw(ix)%nirbm = sum(flux_allsky%bnd_flux_dn_dir(1,iSFC,1:ibd-1)) + & + flux_allsky%bnd_flux_dn_dir(1,iSFC,ibd)/2. + scmpsw(ix)%nirdf = (sum(flux_allsky%bnd_flux_dn(1,iSFC,1:ibd-1)) + & + flux_allsky%bnd_flux_dn(1,iSFC,ibd)/2.) - & + (sum(flux_allsky%bnd_flux_dn_dir(1,iSFC,1:ibd-1)) + & + flux_allsky%bnd_flux_dn_dir(1,iSFC,ibd)/2.) + ! UV-VIS + scmpsw(ix)%visbm = sum(flux_allsky%bnd_flux_dn_dir(1,iSFC,ibd+1:sw_gas_props%get_nband())) + & + flux_allsky%bnd_flux_dn_dir(1,iSFC,ibd)/2. + scmpsw(ix)%visdf = (sum(flux_allsky%bnd_flux_dn(1,iSFC,ibd+1:sw_gas_props%get_nband())) + & + flux_allsky%bnd_flux_dn(1,iSFC,ibd)/2. ) - & + (sum(flux_allsky%bnd_flux_dn_dir(1,iSFC,ibd+1:sw_gas_props%get_nband())) + & + flux_allsky%bnd_flux_dn_dir(1,iSFC,ibd)/2.) + enddo + else + fluxswUP_allsky(:,:) = 0._kind_phys + fluxswDOWN_allsky(:,:) = 0._kind_phys + fluxswUP_clrsky(:,:) = 0._kind_phys + fluxswDOWN_clrsky(:,:) = 0._kind_phys + scmpsw = cmpfsw_type( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 ) + endif end subroutine rrtmgp_sw_main_run end module rrtmgp_sw_main diff --git a/physics/rrtmgp_sw_main.meta b/physics/rrtmgp_sw_main.meta index 1be643701..634516ea1 100644 --- a/physics/rrtmgp_sw_main.meta +++ b/physics/rrtmgp_sw_main.meta @@ -191,20 +191,6 @@ type = real kind = kind_phys intent = in -[nGases] - standard_name = number_of_active_gases_used_by_RRTMGP - long_name = number of gases available used by RRTMGP (Model%nGases) - units = count - dimensions = () - type = integer - intent = in -[i_o3] - standard_name = index_of_ozone_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for ozone mixing ratio - units = index - dimensions = () - type = integer - intent = in [isubc_sw] standard_name = flag_for_sw_clouds_grid_approximation long_name = flag for sw clouds sub-grid approximation @@ -554,6 +540,21 @@ dimensions = () type = ty_optical_props_2str intent = in +[gas_concentrations] + standard_name = Gas_concentrations_for_RRTMGP_suite + long_name = DDT containing gas concentrations for RRTMGP radiation scheme + units = DDT + dimensions = () + type = ty_gas_concs + intent = in +[solcon] + standard_name = solar_constant + long_name = solar constant + units = W m-2 + dimensions = () + type = real + kind = kind_phys + intent = in [scmpsw] standard_name = components_of_surface_downward_shortwave_fluxes long_name = derived type for special components of surface downward shortwave fluxes diff --git a/physics/rrtmgp_sw_rte.F90 b/physics/rrtmgp_sw_rte.F90 new file mode 100644 index 000000000..e1879bd7a --- /dev/null +++ b/physics/rrtmgp_sw_rte.F90 @@ -0,0 +1,221 @@ +module rrtmgp_sw_rte + use machine, only: kind_phys + use mo_optical_props, only: ty_optical_props_2str + use mo_rte_sw, only: rte_sw + use mo_fluxes_byband, only: ty_fluxes_byband + use module_radsw_parameters, only: cmpfsw_type + use radiation_tools, only: check_error_msg + use rrtmgp_sw_gas_optics, only: sw_gas_props + implicit none + + public rrtmgp_sw_rte_init, rrtmgp_sw_rte_run, rrtmgp_sw_rte_finalize + +contains + + ! ######################################################################################### + ! SUBROUTINE rrtmgp_sw_rte_init + ! ######################################################################################### + subroutine rrtmgp_sw_rte_init() + end subroutine rrtmgp_sw_rte_init + + ! ######################################################################################### + ! SUBROUTINE rrtmgp_sw_rte_run + ! ######################################################################################### +!! \section arg_table_rrtmgp_sw_rte_run +!! \htmlinclude rrtmgp_sw_rte.html +!! + subroutine rrtmgp_sw_rte_run(doSWrad, doSWclrsky, nCol, nLev, nDay, idxday, coszen, p_lay,& + t_lay, top_at_1, doGP_sgs_cnv, doGP_sgs_mynn, iSFC, sfc_alb_nir_dir, sfc_alb_nir_dif,& + sfc_alb_uvvis_dir, sfc_alb_uvvis_dif, toa_src_sw, sw_optical_props_clrsky, & + sw_optical_props_clouds, sw_optical_props_precipByBand, & + sw_optical_props_cnvcloudsByBand, sw_optical_props_MYNNcloudsByBand, & + sw_optical_props_aerosol, scmpsw, fluxswUP_allsky, fluxswDOWN_allsky, & + fluxswUP_clrsky, fluxswDOWN_clrsky, errmsg, errflg) + + ! Inputs + logical, intent(in) :: & + top_at_1, & ! Vertical ordering flag + doGP_sgs_mynn, & ! Flag for MYNN-EDMF PBL cloud scheme + doGP_sgs_cnv, & ! Flag for sgs convective clouds scheme + doSWrad, & ! Flag to calculate SW irradiances + doSWclrsky ! Compute clear-sky fluxes? + integer, intent(in) :: & + nCol, & ! Number of horizontal gridpoints + nday, & ! Number of daytime points + nLev, & ! Number of vertical levels + iSFC ! Vertical index for surface-level + integer, intent(in), dimension(:) :: & + idxday ! Index array for daytime points + real(kind_phys),intent(in), dimension(:) :: & + sfc_alb_nir_dir, & ! Surface albedo (direct) + sfc_alb_nir_dif, & ! Surface albedo (diffuse) + sfc_alb_uvvis_dir, & ! Surface albedo (direct) + sfc_alb_uvvis_dif, & ! Surface albedo (diffuse) + coszen ! Cosize of SZA + real(kind_phys), dimension(:,:), intent(in) :: & + p_lay, & ! Pressure @ model layer-centers (Pa) + t_lay, & ! Temperature (K) + toa_src_sw ! TOA incident spectral flux (W/m2) + type(ty_optical_props_2str),intent(inout) :: & + sw_optical_props_clrsky ! RRTMGP DDT: shortwave clear-sky radiative properties + type(ty_optical_props_2str),intent(in) :: & + sw_optical_props_clouds, & ! RRTMGP DDT: shortwave cloud optical properties + sw_optical_props_cnvcloudsByBand, & ! RRTMGP DDT: shortwave convecive cloud optical properties + sw_optical_props_MYNNcloudsByBand, & ! RRTMGP DDT: shortwave MYNN-EDMF PBL cloud optical properties + sw_optical_props_precipByBand, & ! RRTMGP DDT: shortwave precipitation optical properties + sw_optical_props_aerosol ! RRTMGP DDT: shortwave aerosol optical properties + + ! Outputs + character(len=*), intent(out) :: & + errmsg ! CCPP error message + integer, intent(out) :: & + errflg ! CCPP error flag + real(kind_phys), dimension(:,:), intent(inout) :: & + fluxswUP_allsky, & ! RRTMGP upward all-sky flux profiles (W/m2) + fluxswDOWN_allsky, & ! RRTMGP downward all-sky flux profiles (W/m2) + fluxswUP_clrsky, & ! RRTMGP upward clear-sky flux profiles (W/m2) + fluxswDOWN_clrsky ! RRTMGP downward clear-sky flux profiles (W/m2) + type(cmpfsw_type), dimension(:), intent(inout) :: & + scmpsw ! 2D surface fluxes, components: + ! uvbfc - total sky downward uv-b flux (W/m2) + ! uvbf0 - clear sky downward uv-b flux (W/m2) + ! nirbm - downward nir direct beam flux (W/m2) + ! nirdf - downward nir diffused flux (W/m2) + ! visbm - downward uv+vis direct beam flux (W/m2) + ! visdf - downward uv+vis diffused flux (W/m2) + + ! Local variables + real(kind_phys), dimension(sw_gas_props%get_nband(),nday) :: & + sfc_alb_dir,sfc_alb_dif + type(ty_fluxes_byband) :: & + flux_allsky, & ! All-sky flux (W/m2) + flux_clrsky ! Clear-sky flux (W/m2) + real(kind_phys), dimension(nday,NLev+1,sw_gas_props%get_nband()),target :: & + fluxSW_up_allsky, fluxSW_up_clrsky, fluxSW_dn_allsky, fluxSW_dn_clrsky, fluxSW_dn_dir_allsky + real(kind_phys), dimension(ncol,NLev) :: vmrTemp + integer :: iBand, iDay,ibd + real(kind_phys), dimension(2,sw_gas_props%get_nband()) :: bandlimits + real(kind_phys), dimension(2), parameter :: nIR_uvvis_bnd = (/12850,16000/) + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (.not. doSWrad) return + + if (nDay .gt. 0) then + + ! Initialize RRTMGP DDT containing 2D(3D) fluxes + flux_allsky%bnd_flux_up => fluxSW_up_allsky + flux_allsky%bnd_flux_dn => fluxSW_dn_allsky + flux_allsky%bnd_flux_dn_dir => fluxSW_dn_dir_allsky + flux_clrsky%bnd_flux_up => fluxSW_up_clrsky + flux_clrsky%bnd_flux_dn => fluxSW_dn_clrsky + + ! Use near-IR albedo for bands with wavenumbers extending to 12850cm-1 + ! Use uv-vis albedo for bands with wavenumbers greater than 16000cm-1 + ! For overlapping band, average near-IR and us-vis albedos. + bandlimits = sw_gas_props%get_band_lims_wavenumber() + do iBand=1,sw_gas_props%get_nband() + if (bandlimits(1,iBand) .lt. nIR_uvvis_bnd(1)) then + sfc_alb_dir(iBand,:) = sfc_alb_nir_dir(idxday(1:nday)) + sfc_alb_dif(iBand,:) = sfc_alb_nir_dif(idxday(1:nday)) + endif + if (bandlimits(1,iBand) .eq. nIR_uvvis_bnd(1)) then + sfc_alb_dir(iBand,:) = 0.5_kind_phys*(sfc_alb_nir_dir(idxday(1:nday)) + sfc_alb_uvvis_dir(idxday(1:nday))) + sfc_alb_dif(iBand,:) = 0.5_kind_phys*(sfc_alb_nir_dif(idxday(1:nday)) + sfc_alb_uvvis_dif(idxday(1:nday))) + ibd = iBand + endif + if (bandlimits(1,iBand) .ge. nIR_uvvis_bnd(2)) then + sfc_alb_dir(iBand,:) = sfc_alb_uvvis_dir(idxday(1:nday)) + sfc_alb_dif(iBand,:) = sfc_alb_uvvis_dif(idxday(1:nday)) + endif + enddo + + ! + ! Compute clear-sky fluxes (if requested) + ! + + ! Clear-sky fluxes (gas+aerosol) + call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_aerosol%increment(sw_optical_props_clrsky)) + ! Delta-scale optical properties + call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_clrsky%delta_scale()) + if (doSWclrsky) then + call check_error_msg('rrtmgp_sw_rte_run',rte_sw( & + sw_optical_props_clrsky, & ! IN - optical-properties + top_at_1, & ! IN - veritcal ordering flag + coszen(idxday(1:nday)), & ! IN - Cosine of solar zenith angle + toa_src_sw(idxday(1:nday),:), & ! IN - incident solar flux at TOA + sfc_alb_dir, & ! IN - Shortwave surface albedo (direct) + sfc_alb_dif, & ! IN - Shortwave surface albedo (diffuse) + flux_clrsky)) ! OUT - Fluxes, clear-sky, 3D (nCol,NLev,nBand) + ! Store fluxes + fluxswUP_clrsky(idxday(1:nday),:) = sum(flux_clrsky%bnd_flux_up,dim=3) + fluxswDOWN_clrsky(idxday(1:nday),:) = sum(flux_clrsky%bnd_flux_dn,dim=3) + endif + + ! + ! Compute all-sky fluxes + ! + + ! Include convective cloud? + if (doGP_sgs_cnv) then + call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_cnvcloudsByBand%increment(sw_optical_props_clrsky)) + endif + + ! Include MYNN-EDMF PBL cloud? + if (doGP_sgs_mynn) then + call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_MYNNcloudsByBand%increment(sw_optical_props_clrsky)) + endif + + ! All-sky fluxes (clear-sky + clouds + precipitation) + call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_precipByBand%increment(sw_optical_props_clrsky)) + call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_clouds%increment(sw_optical_props_clrsky)) + + ! Delta-scale optical properties + call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_clrsky%delta_scale()) + call check_error_msg('rrtmgp_sw_rte_run',rte_sw( & + sw_optical_props_clrsky, & ! IN - optical-properties + top_at_1, & ! IN - veritcal ordering flag + coszen(idxday(1:nday)), & ! IN - Cosine of solar zenith angle + toa_src_sw(idxday(1:nday),:), & ! IN - incident solar flux at TOA + sfc_alb_dir, & ! IN - Shortwave surface albedo (direct) + sfc_alb_dif, & ! IN - Shortwave surface albedo (diffuse) + flux_allsky)) ! OUT - Fluxes, clear-sky, 3D (nCol,NLev,nBand) + + ! Store fluxes + fluxswUP_allsky(idxday(1:nday),:) = sum(flux_allsky%bnd_flux_up,dim=3) + fluxswDOWN_allsky(idxday(1:nday),:) = sum(flux_allsky%bnd_flux_dn,dim=3) + do iDay=1,nDay + ! Near IR + scmpsw(idxday(iDay))%nirbm = sum(flux_allsky%bnd_flux_dn_dir(iDay,iSFC,1:ibd-1)) + & + flux_allsky%bnd_flux_dn_dir(iDay,iSFC,ibd)/2. + scmpsw(idxday(iDay))%nirdf = (sum(flux_allsky%bnd_flux_dn(iDay,iSFC,1:ibd-1)) + & + flux_allsky%bnd_flux_dn(iDay,iSFC,ibd)/2.) - & + (sum(flux_allsky%bnd_flux_dn_dir(iDay,iSFC,1:ibd-1)) + & + flux_allsky%bnd_flux_dn_dir(iDay,iSFC,ibd)/2.) + ! UV-VIS + scmpsw(idxday(iDay))%visbm = sum(flux_allsky%bnd_flux_dn_dir(iDay,iSFC,ibd+1:sw_gas_props%get_nband())) + & + flux_allsky%bnd_flux_dn_dir(iDay,iSFC,ibd)/2. + scmpsw(idxday(iDay))%visdf = (sum(flux_allsky%bnd_flux_dn(iDay,iSFC,ibd+1:sw_gas_props%get_nband())) + & + flux_allsky%bnd_flux_dn(iDay,iSFC,ibd)/2. ) - & + (sum(flux_allsky%bnd_flux_dn_dir(iDay,iSFC,ibd+1:sw_gas_props%get_nband())) + & + flux_allsky%bnd_flux_dn_dir(iDay,iSFC,ibd)/2.) + enddo + else + fluxswUP_allsky(:,:) = 0._kind_phys + fluxswDOWN_allsky(:,:) = 0._kind_phys + fluxswUP_clrsky(:,:) = 0._kind_phys + fluxswDOWN_clrsky(:,:) = 0._kind_phys + scmpsw = cmpfsw_type( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 ) + endif + + end subroutine rrtmgp_sw_rte_run + + ! ######################################################################################### + ! SUBROUTINE rrtmgp_sw_rte_finalize + ! ######################################################################################### + subroutine rrtmgp_sw_rte_finalize() + end subroutine rrtmgp_sw_rte_finalize + +end module rrtmgp_sw_rte diff --git a/physics/rrtmgp_sw_rte.meta b/physics/rrtmgp_sw_rte.meta new file mode 100644 index 000000000..9ab24c8b3 --- /dev/null +++ b/physics/rrtmgp_sw_rte.meta @@ -0,0 +1,240 @@ +[ccpp-table-properties] + name = rrtmgp_sw_rte + type = scheme + dependencies = machine.F,radsw_param.f,rte-rrtmgp/rte/mo_rte_sw.F90,rte-rrtmgp/rte/mo_fluxes.F90,rte-rrtmgp/rte/kernels/mo_fluxes_broadband_kernels.F90,radiation_tools.F90 + dependencies = rte-rrtmgp/rte/kernels/mo_rte_solver_kernels.F90,rte-rrtmgp/extensions/mo_fluxes_byband.F90 + +######################################################################## +[ccpp-arg-table] + name = rrtmgp_sw_rte_run + type = scheme +[doSWrad] + standard_name = flag_for_calling_shortwave_radiation + long_name = flag to calculate SW irradiances + units = flag + dimensions = () + type = logical + intent = in +[doSWclrsky] + standard_name = flag_for_output_of_tendency_of_air_temperature_due_to_shortwave_heating_on_radiation_timestep_assuming_clear_sky + long_name = flag to output sw heating rate (Radtend%swhc) + units = flag + dimensions = () + type = logical + intent = in +[ncol] + standard_name = horizontal_loop_extent + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in +[nLev] + standard_name = vertical_layer_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in +[nday] + standard_name = daytime_points_dimension + long_name = daytime points dimension + units = count + dimensions = () + type = integer + intent = in +[idxday] + standard_name = daytime_points + long_name = daytime points + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[coszen] + standard_name = cosine_of_solar_zenith_angle_for_daytime_points_on_radiation_timestep + long_name = mean cos of zenith angle over rad call period + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[p_lay] + standard_name = air_pressure_at_layer_for_RRTMGP + long_name = air pressure layer + units = Pa + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[top_at_1] + standard_name = flag_for_vertical_ordering_in_RRTMGP + long_name = flag for vertical ordering in RRTMGP + units = flag + dimensions = () + type = logical + intent = in +[doGP_sgs_cnv] + standard_name = flag_to_include_sgs_convective_cloud_in_RRTMGP + long_name = logical flag to control sgs convective cloud in RRTMGP + units = flag + dimensions = () + type = logical + intent = in +[doGP_sgs_mynn] + standard_name = flag_to_include_sgs_MYNN_EDMF_cloud_in_RRTMGP + long_name = logical flag to control MYNN-EDMF PBL cloud in RRTMGP + units = flag + dimensions = () + type = logical + intent = in +[iSFC] + standard_name = vertical_index_for_surface_in_RRTMGP + long_name = index for surface layer in RRTMGP + units = flag + dimensions = () + type = integer + intent = in +[t_lay] + standard_name = air_temperature_at_layer_for_RRTMGP + long_name = air temperature layer + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[sw_optical_props_clrsky] + standard_name = shortwave_optical_properties_for_clear_sky + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = inout +[sw_optical_props_clouds] + standard_name = shortwave_optical_properties_for_cloudy_atmosphere + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = in +[sw_optical_props_precipByBand] + standard_name = shortwave_optical_properties_for_precipitation_by_band + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = in +[sw_optical_props_cnvcloudsByBand] + standard_name = shortwave_optical_properties_for_convective_cloudy_atmosphere_by_band + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = in +[sw_optical_props_MYNNcloudsByBand] + standard_name = shortwave_optical_properties_for_MYNN_EDMF_PBL_cloudy_atmosphere_by_band + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = in +[sw_optical_props_aerosol] + standard_name = shortwave_optical_properties_for_aerosols + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_2str + intent = in +[sfc_alb_nir_dir] + standard_name = surface_albedo_due_to_near_IR_direct + long_name = surface albedo due to near IR direct beam + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[sfc_alb_nir_dif] + standard_name = surface_albedo_due_to_near_IR_diffused + long_name = surface albedo due to near IR diffused beam + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[sfc_alb_uvvis_dir] + standard_name = surface_albedo_due_to_UV_and_VIS_direct + long_name = surface albedo due to UV+VIS direct beam + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[sfc_alb_uvvis_dif] + standard_name = surface_albedo_due_to_UV_and_VIS_diffused + long_name = surface albedo due to UV+VIS diffused beam + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[toa_src_sw] + standard_name = toa_incident_sw_flux_by_spectral_point + long_name = TOA shortwave incident flux at each spectral points + units = W m-2 + dimensions = (horizontal_loop_extent,number_of_shortwave_spectral_points) + type = real + kind = kind_phys + intent = in +[scmpsw] + standard_name = components_of_surface_downward_shortwave_fluxes + long_name = derived type for special components of surface downward shortwave fluxes + units = W m-2 + dimensions = (horizontal_loop_extent) + type = cmpfsw_type + intent = inout +[fluxswUP_allsky] + standard_name = RRTMGP_sw_flux_profile_upward_allsky + long_name = RRTMGP upward shortwave all-sky flux profile + units = W m-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = inout +[fluxswDOWN_allsky] + standard_name = RRTMGP_sw_flux_profile_downward_allsky + long_name = RRTMGP downward shortwave all-sky flux profile + units = W m-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = inout +[fluxswUP_clrsky] + standard_name = RRTMGP_sw_flux_profile_upward_clrsky + long_name = RRTMGP upward shortwave clr-sky flux profile + units = W m-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = inout +[fluxswDOWN_clrsky] + standard_name = RRTMGP_sw_flux_profile_downward_clrsky + long_name = RRTMGP downward shortwave clr-sky flux profile + units = W m-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = inout +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out From cbbc106fdba491398b9ccfab7d658744a9f4dda1 Mon Sep 17 00:00:00 2001 From: "Yihua.Wu" Date: Mon, 8 Aug 2022 14:07:41 +0000 Subject: [PATCH 006/380] Updated Flake physics and modified related files --- physics/GFS_phys_time_vary.fv3.F90 | 21 +- physics/GFS_phys_time_vary.fv3.meta | 30 ++ physics/GFS_radiation_surface.F90 | 3 +- physics/GFS_radiation_surface.meta | 2 +- physics/GFS_surface_composites_inter.F90 | 9 +- physics/GFS_surface_composites_inter.meta | 11 +- physics/GFS_surface_composites_post.F90 | 14 +- physics/GFS_surface_composites_pre.F90 | 23 +- physics/GFS_surface_composites_pre.meta | 4 +- physics/flake.F90 | 83 ++++-- physics/flake_driver.F90 | 316 ++++++++++++++-------- physics/flake_driver.meta | 282 +++++++++++++++++-- physics/lsm_ruc.F90 | 5 +- physics/lsm_ruc.meta | 2 +- physics/radiation_surface.f | 4 +- physics/sfc_diff.f | 9 +- physics/sfc_diff.meta | 9 +- physics/sfc_nst.f | 12 +- physics/sfc_nst.meta | 4 +- physics/sfc_nst_post.f | 5 +- physics/sfc_nst_post.meta | 2 +- physics/sfc_ocean.F | 5 +- physics/sfc_ocean.meta | 2 +- physics/sfc_sice.f | 5 +- physics/sfc_sice.meta | 2 +- 25 files changed, 656 insertions(+), 208 deletions(-) diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index 3c5a5af9b..25e5218d5 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -82,7 +82,7 @@ subroutine GFS_phys_time_vary_init ( zwtxy, xlaixy, xsaixy, lfmassxy, stmassxy, rtmassxy, woodxy, stblcpxy, fastcpxy, & smcwtdxy, deeprechxy, rechxy, snowxy, snicexy, snliqxy, tsnoxy , smoiseq, zsnsoxy, & slc, smc, stc, tsfcl, snowd, canopy, tg3, stype, con_t0c, lsm_cold_start, nthrds, & - errmsg, errflg) + lkm, use_flake, lakefrac, lakedepth, errmsg, errflg) implicit none @@ -93,6 +93,10 @@ subroutine GFS_phys_time_vary_init ( real(kind_phys), intent(in) :: fhour real(kind_phys), intent(in) :: xlat_d(:), xlon_d(:) + integer, intent(in) :: lkm + integer, intent(inout) :: use_flake(:) + real(kind=kind_phys), intent(in ) :: lakefrac(:), lakedepth(:) + integer, intent(inout) :: jindx1_o3(:), jindx2_o3(:), jindx1_h(:), jindx2_h(:) real(kind_phys), intent(inout) :: ddy_o3(:), ddy_h(:) real(kind_phys), intent(in) :: ozpl(:,:,:), h2opl(:,:,:) @@ -672,6 +676,21 @@ subroutine GFS_phys_time_vary_init ( endif noahmp_init endif lsm_init +!Flake + do i = 1, im + if (lakefrac(i) > 0.0 .and. lakedepth(i) > 1.0 ) then + if (lkm == 1 ) then + use_flake(i) = 1 + elseif (lkm == 2 ) then + use_flake(i) = 2 + else + use_flake(i) = 0 + endif + else + use_flake(i) = 0 + endif + enddo + is_initialized = .true. contains diff --git a/physics/GFS_phys_time_vary.fv3.meta b/physics/GFS_phys_time_vary.fv3.meta index f37235975..c8f178bf3 100644 --- a/physics/GFS_phys_time_vary.fv3.meta +++ b/physics/GFS_phys_time_vary.fv3.meta @@ -895,6 +895,36 @@ dimensions = () type = integer intent = in +[lkm] + standard_name = control_for_lake_surface_scheme + long_name = flag for lake surface model + units = flag + dimensions = () + type = integer + intent = in +[use_flake] + standard_name = flag_for_using_flake + long_name = flag indicating lake points using flake model + units = flag + dimensions = (horizontal_dimension) + type = integer + intent = inout +[lakefrac] + standard_name = lake_area_fraction + long_name = fraction of horizontal grid area occupied by lake + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in +[lakedepth] + standard_name = lake_depth + long_name = lake depth + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/GFS_radiation_surface.F90 b/physics/GFS_radiation_surface.F90 index 73de41282..07c87414e 100644 --- a/physics/GFS_radiation_surface.F90 +++ b/physics/GFS_radiation_surface.F90 @@ -67,7 +67,8 @@ subroutine GFS_radiation_surface_run ( & logical, intent(in) :: frac_grid, lslwr, lsswr, use_cice_alb, cplice integer, intent(in) :: lsm, lsm_noahmp, lsm_ruc, lndp_type, n_var_lndp real(kind=kind_phys), intent(in) :: min_seaice, min_lakeice - logical, dimension(:), intent(in) :: use_flake + + integer, dimension(:), intent(in) :: use_flake real(kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, slmsk, & sfc_alb_pert, lndp_prt_list, & diff --git a/physics/GFS_radiation_surface.meta b/physics/GFS_radiation_surface.meta index 3fd851a40..e9de370e8 100644 --- a/physics/GFS_radiation_surface.meta +++ b/physics/GFS_radiation_surface.meta @@ -291,7 +291,7 @@ long_name = flag indicating lake points using flake model units = flag dimensions = (horizontal_loop_extent) - type = logical + type = integer intent = inout [alvsf] standard_name = vis_albedo_strong_cosz diff --git a/physics/GFS_surface_composites_inter.F90 b/physics/GFS_surface_composites_inter.F90 index 0e288691c..715b85518 100644 --- a/physics/GFS_surface_composites_inter.F90 +++ b/physics/GFS_surface_composites_inter.F90 @@ -18,17 +18,19 @@ module GFS_surface_composites_inter !! subroutine GFS_surface_composites_inter_run (im, dry, icy, wet, semis_wat, semis_lnd, semis_ice, & adjsfcdlw, gabsbdlw_lnd, gabsbdlw_ice, gabsbdlw_wat,& - adjsfcusw, adjsfcdsw, adjsfcnsw, errmsg, errflg) + adjsfcusw, adjsfcdsw, adjsfcnsw, use_flake, errmsg, errflg) implicit none ! Interface variables integer, intent(in ) :: im - logical, dimension(:), intent(in ) :: dry, icy, wet + logical, dimension(:), intent(in ) :: dry, icy + logical, dimension(:), intent(inout) :: wet real(kind=kind_phys), dimension(:), intent(in ) :: semis_wat, semis_lnd, semis_ice, & adjsfcdlw, adjsfcdsw, adjsfcnsw real(kind=kind_phys), dimension(:), intent(inout) :: gabsbdlw_lnd, gabsbdlw_ice, gabsbdlw_wat real(kind=kind_phys), dimension(:), intent(out) :: adjsfcusw + integer, dimension(:), intent(in) :: use_flake ! CCPP error handling character(len=*), intent(out) :: errmsg @@ -60,6 +62,7 @@ subroutine GFS_surface_composites_inter_run (im, dry, icy, wet, semis_wat, semis ! --- ... define the downward lw flux absorbed by ground do i=1,im + if(use_flake(i)>0.0) wet(i)=.true. if (dry(i)) gabsbdlw_lnd(i) = semis_lnd(i) * adjsfcdlw(i) if (icy(i)) gabsbdlw_ice(i) = semis_ice(i) * adjsfcdlw(i) if (wet(i)) gabsbdlw_wat(i) = semis_wat(i) * adjsfcdlw(i) @@ -68,4 +71,4 @@ subroutine GFS_surface_composites_inter_run (im, dry, icy, wet, semis_wat, semis end subroutine GFS_surface_composites_inter_run -end module GFS_surface_composites_inter \ No newline at end of file +end module GFS_surface_composites_inter diff --git a/physics/GFS_surface_composites_inter.meta b/physics/GFS_surface_composites_inter.meta index 00227a09b..2ed966d01 100644 --- a/physics/GFS_surface_composites_inter.meta +++ b/physics/GFS_surface_composites_inter.meta @@ -35,7 +35,7 @@ units = flag dimensions = (horizontal_loop_extent) type = logical - intent = in + intent = inout [semis_wat] standard_name = surface_longwave_emissivity_over_water long_name = surface lw emissivity in fraction over water @@ -116,6 +116,13 @@ type = real kind = kind_phys intent = in +[use_flake] + standard_name = flag_for_using_flake + long_name = flag indicating lake points using flake model + units = flag + dimensions = (horizontal_loop_extent) + type = integer + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -130,4 +137,4 @@ units = 1 dimensions = () type = integer - intent = out \ No newline at end of file + intent = out diff --git a/physics/GFS_surface_composites_post.F90 b/physics/GFS_surface_composites_post.F90 index f39ccb77e..62c014417 100644 --- a/physics/GFS_surface_composites_post.F90 +++ b/physics/GFS_surface_composites_post.F90 @@ -40,7 +40,8 @@ subroutine GFS_surface_composites_post_run ( integer, intent(in) :: im, kice, km logical, intent(in) :: cplflx, frac_grid, cplwav2atm logical, intent(in) :: lheatstrg - logical, dimension(:), intent(in) :: flag_cice, dry, wet, icy + logical, dimension(:), intent(in) :: flag_cice, dry, icy + logical, dimension(:), intent(inout) :: wet integer, dimension(:), intent(in) :: islmsk real(kind=kind_phys), dimension(:), intent(in) :: wind, t1, q1, prsl1, landfrac, lakefrac, oceanfrac, & cd_wat, cd_lnd, cd_ice, cdq_wat, cdq_lnd, cdq_ice, rb_wat, rb_lnd, rb_ice, stress_wat, & @@ -87,6 +88,11 @@ subroutine GFS_surface_composites_post_run ( errflg = 0 ! --- generate ocean/land/ice composites + do i=1, im + if(lakefrac(i)>0.0) then + wet(i) = .true. + endif + enddo if (frac_grid) then @@ -263,7 +269,8 @@ subroutine GFS_surface_composites_post_run ( else do i=1,im - if (islmsk(i) == 1) then +! if (islmsk(i) == 1) then + if (dry(i)) then !-- land zorl(i) = zorll(i) cd(i) = cd_lnd(i) @@ -289,7 +296,8 @@ subroutine GFS_surface_composites_post_run ( qss(i) = qss_lnd(i) hice(i) = zero cice(i) = zero - elseif (islmsk(i) == 0) then +! elseif (islmsk(i) == 0) then + elseif (wet(i)) then !-- water zorl(i) = zorlo(i) cd(i) = cd_wat(i) diff --git a/physics/GFS_surface_composites_pre.F90 b/physics/GFS_surface_composites_pre.F90 index 734f1965b..04ce7e314 100644 --- a/physics/GFS_surface_composites_pre.F90 +++ b/physics/GFS_surface_composites_pre.F90 @@ -38,7 +38,8 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, integer, intent(in ) :: im, lkm, kdt, lsm, lsm_ruc logical, intent(in ) :: cplflx, cplice, cplwav2atm, frac_grid logical, dimension(:), intent(inout) :: flag_cice - logical, dimension(:), intent(inout) :: dry, icy, lake, use_flake, wet + logical, dimension(:), intent(inout) :: dry, icy, lake, wet + integer, dimension(:), intent(inout) :: use_flake real(kind=kind_phys), dimension(:), intent(in ) :: landfrac, lakefrac, lakedepth, oceanfrac real(kind=kind_phys), dimension(:), intent(inout) :: cice, hice real(kind=kind_phys), dimension(:), intent( out) :: frland @@ -71,6 +72,12 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, errmsg = '' errflg = 0 + do i=1,im + if(use_flake(i) > 0.0) then + wet(i) = .true. + endif + enddo + if (frac_grid) then ! cice is ice fraction wrt water area do i=1,im frland(i) = landfrac(i) @@ -239,20 +246,6 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, if (nint(slmsk(i)) /= 1) slmsk(i) = islmsk(i) enddo -! to prepare to separate lake from ocean under water category - do i = 1, im - if ((wet(i) .or. icy(i)) .and. lakefrac(i) > zero) then - lake(i) = .true. - if (lkm == 1 .and. lakefrac(i) >= 0.15 .and. lakedepth(i) > one) then - use_flake(i) = .true. - else - use_flake(i) = .false. - endif - else - lake(i) = .false. - use_flake(i) = .false. - endif - enddo ! if (frac_grid) then do i=1,im diff --git a/physics/GFS_surface_composites_pre.meta b/physics/GFS_surface_composites_pre.meta index e87af3e28..1aef9a76b 100644 --- a/physics/GFS_surface_composites_pre.meta +++ b/physics/GFS_surface_composites_pre.meta @@ -136,7 +136,7 @@ long_name = flag indicating lake points using flake model units = flag dimensions = (horizontal_loop_extent) - type = logical + type = integer intent = inout [wet] standard_name = flag_nonzero_wet_surface_fraction @@ -484,4 +484,4 @@ units = 1 dimensions = () type = integer - intent = out \ No newline at end of file + intent = out diff --git a/physics/flake.F90 b/physics/flake.F90 index 2c2e7218c..74394847b 100644 --- a/physics/flake.F90 +++ b/physics/flake.F90 @@ -101,7 +101,8 @@ MODULE flake_albedo_ref albedo_water_ref = 0.07 , & ! Water albedo_whiteice_ref = 0.60 , & ! White ice albedo_blueice_ref = 0.10 , & ! Blue ice - albedo_drysnow_ref = 0.60 , & ! Dry snow +! albedo_drysnow_ref = 0.60 , & ! Dry snow + albedo_drysnow_ref = 0.90 , & ! Dry snow albedo_meltingsnow_ref = 0.10 ! Melting snow ! Empirical parameters. @@ -1544,7 +1545,11 @@ SUBROUTINE flake_main ( depthw, depthbs, T_bs, par_Coriolis, & flk_str_1 = flk_str_1 - CTT/CT*( (Q_bot_flk+I_bot_flk-I_HH_flk)/tpl_rho_w_r/tpl_c_w - & depth_bs * ( 1.0 - CT ) * (T_bot_n_flk-T_bot_p_flk)/del_time ) flk_str_2 = CTT * (T_bot_p_flk-T_bot_2_in) - d_h_D_dt = flk_str_1/flk_str_2 + if(abs(flk_str_2)<0.01) then + d_h_D_dt = 0.0 + else + d_h_D_dt = flk_str_1/flk_str_2 + endif ! compute d_T_H_dt flk_str_1 = (Q_bot_flk+I_bot_flk-I_HH_flk)/tpl_rho_w_r/tpl_c_w @@ -1869,7 +1874,8 @@ MODULE SfcFlx ! similarity relations and in the expressions for the roughness lengths. REAL (KIND = kind_phys), PARAMETER :: & c_Karman = 0.40 , & ! The von Karman constant - Pr_neutral = 1.0 , & ! Turbulent Prandtl number at neutral static stability +! Pr_neutral = 1.0 , & ! Turbulent Prandtl number at neutral static stability + Pr_neutral = 0.9 , & ! Turbulent Prandtl number at neutral static stability Sc_neutral = 1.0 , & ! Turbulent Schmidt number at neutral static stability c_MO_u_stab = 5.0 , & ! Constant of the MO theory (wind, stable stratification) c_MO_t_stab = 5.0 , & ! Constant of the MO theory (temperature, stable stratification) @@ -2480,18 +2486,37 @@ SUBROUTINE SfcFlx_momsenlat ( height_u, height_tq, fetch, & ELSE ! Convection psi_u = (1.0-c_MO_t_conv*R_z*ZoL)**c_MO_t_exp psi_t = (1.0-c_MO_t_conv*R_z*ZoL*MIN(z0t_sf/height_tq, 1.0))**c_MO_t_exp - psi_t = 2.0*LOG((1.0+psi_t)/(1.0+psi_u)) +! psi_t = 2.0*LOG((1.0+psi_t)/(1.0+psi_u)) + psi_t = abs(2.0*LOG((1.0+psi_t)/(1.0+psi_u))) psi_u = (1.0-c_MO_q_conv*R_z*ZoL)**c_MO_q_exp psi_q = (1.0-c_MO_q_conv*R_z*ZoL*MIN(z0q_sf/height_tq, 1.0))**c_MO_q_exp - psi_q = 2.0*LOG((1.0+psi_q)/(1.0+psi_u)) +! psi_q = 2.0*LOG((1.0+psi_q)/(1.0+psi_u)) + psi_q = abs(2.0*LOG((1.0+psi_q)/(1.0+psi_u))) +! write(0,*) 'psi_q= ',psi_q !_dbg ! print*(*,*) 'CONV: psi_t = ', psi_t, ' psi_q = ', psi_q !_dbg END IF Q_sen_tur = -(T_a-T_s)*u_star_st*c_Karman/Pr_neutral & / MAX(c_small_sf, LOG(height_tq/z0t_sf)+psi_t) +if(MAX(c_small_sf, LOG(height_tq/z0t_sf)+psi_t) .lt. 10E-6) then + write(0,*)'inside flake' + write(0,*) Q_sen_tur, T_a, T_s, u_star_st, c_Karman, Pr_neutral + write(0,*) c_small_sf,height_tq,z0t_sf,psi_t + write(0,*) 'nominator= ', (T_a-T_s)*u_star_st*c_Karman/Pr_neutral + write(0,*) 'denominator= ',MAX(c_small_sf, LOG(height_tq/z0t_sf)+psi_t) +endif Q_lat_tur = -(q_a-q_s)*u_star_st*c_Karman/Sc_neutral & / MAX(c_small_sf, LOG(height_tq/z0q_sf)+psi_q) +if(Q_lat_tur .gt. 6.0E-4) then + Q_lat_tur = -(q_a-q_s)*u_star_st*c_Karman/3.0 & + / MAX(c_small_sf, LOG(height_tq/z0q_sf)+psi_q) + write(0,*) 'Q_lat_tur= ',Q_lat_tur + write(0,135) q_a,q_s,u_star_st,c_Karman + write(0,136) MAX(c_small_sf,LOG(height_tq/z0q_sf)+psi_q),c_small_sf, LOG(height_tq/z0q_sf),psi_q +endif +135 format(1x,4(f16.4)) +136 format(1x,4(f16.4)) END IF Turb_Fluxes @@ -2536,13 +2561,19 @@ SUBROUTINE SfcFlx_momsenlat ( height_u, height_tq, fetch, & Q_momentum = Q_momentum*rho_a !Q_sensible = Q_sensible*rho_a*tpsf_c_a_p +!write(0,*) 'Q_sensible= ',Q_sensible Q_watvap = Q_latent*rho_a -Q_latent = tpsf_L_evap +!Q_latent = tpsf_L_evap IF(h_ice.GE.h_Ice_min_flk) Q_latent = Q_latent + tpl_L_f ! Add latent heat of fusion over ice -Q_latent = Q_watvap*Q_latent - +!Q_latent = Q_watvap*Q_latent +Q_latent = Q_watvap*tpsf_L_evap +if(Q_latent .gt. 2000.00) then + write(0,145) 'final Q_watvap= ',Q_watvap, 'tpsf_L_evap= ',tpsf_L_evap, 'Q_latent= ', Q_latent +endif +!Q_latent = Q_watvap*Q_latent +145 format(A17,E12.5,1x,A13,1x,f10.2,1x,A10,1x,E12.4) ! Set "*_sf" variables to make fluxes accessible to driving routines that use "SfcFlx" u_star_a_sf = u_star_st Q_mom_a_sf = Q_momentum @@ -2551,7 +2582,7 @@ SUBROUTINE SfcFlx_momsenlat ( height_u, height_tq, fetch, & Q_watvap_a_sf = Q_watvap !write(85,127) Q_sensible, Q_watvap, Q_latent - 127 format(1x, 3(f16.9,1x)) + 127 format(1x, 3(f16.5,1x)) !------------------------------------------------------------------------------ ! End calculations @@ -2945,7 +2976,7 @@ SUBROUTINE flake_interface ( dMsnowdt_in, I_atm_in, Q_atm_lw_in, height_u_in, he T_snow_out, T_ice_out, T_mnw_out, T_wML_out, T_bot_out, & T_B1_out, C_T_out, h_snow_out, h_ice_out, h_ML_out, & - H_B1_out, T_sfc_n, hflx_out, evap_out, & + H_B1_out, T_sfc_n, hflx_out, evap_out, gflx_out, lflx_out, & T_bot_2_in, T_bot_2_out,ustar, q_sfc, chh, cmm ) @@ -2987,11 +3018,11 @@ SUBROUTINE flake_interface ( dMsnowdt_in, I_atm_in, Q_atm_lw_in, height_u_in, he USE flake_derivedtypes ! Definitions of several derived TYPEs -USE flake_parameters , ONLY : & - tpl_T_f , & ! Fresh water freezing point [K] - tpl_rho_w_r , & ! Maximum density of fresh water [kg m^{-3}] - h_Snow_min_flk , & ! Minimum snow thickness [m] - h_Ice_min_flk ! Minimum ice thickness [m] +!USE flake_parameters , ONLY : & +! tpl_T_f , & ! Fresh water freezing point [K] +! tpl_rho_w_r , & ! Maximum density of fresh water [kg m^{-3}] +! h_Snow_min_flk , & ! Minimum snow thickness [m] +! h_Ice_min_flk ! Minimum ice thickness [m] USE flake_paramoptic_ref ! Reference values of the optical characteristics ! of the lake water, lake ice and snow @@ -3117,6 +3148,8 @@ SUBROUTINE flake_interface ( dMsnowdt_in, I_atm_in, Q_atm_lw_in, height_u_in, he T_sfc_n , & ! Updated surface temperature [K] hflx_out , & ! sensibl heat flux evap_out , & ! Latent heat flux + gflx_out , & ! flux from to water + lflx_out , & ! latent heat flux T_bot_2_out , & ! Bottom temperature ustar , & q_sfc , & @@ -3130,16 +3163,21 @@ SUBROUTINE flake_interface ( dMsnowdt_in, I_atm_in, Q_atm_lw_in, height_u_in, he Q_sensible , & ! Sensible heat flux [W m^{-2}] Q_latent , & ! Latent heat flux [W m^{-2}] Q_watvap , & ! Flux of water vapour [kg m^{-2} s^{-1}] + Q_w_flux , & ! flux from ice to water rho_a ! ADDED by Shaobo Zhang LOGICAL lflk_botsed_use !REAL (KIND = kind_phys) :: T_bot_2_in, T_bot_2_out - +REAL (KIND = kind_phys), parameter :: tpl_rho_w_r = 1.0E+03 +REAL (KIND = kind_phys), parameter :: tpl_T_f = 273.15 +REAL (KIND = kind_phys), parameter :: h_Snow_min_flk = 1.0E-5 +REAL (KIND = kind_phys), parameter :: h_Ice_min_flk = 1.0E-9 !============================================================================== ! Start calculations !------------------------------------------------------------------------------ - lflk_botsed_use = .TRUE. +! lflk_botsed_use = .TRUE. + lflk_botsed_use = .FALSE. !------------------------------------------------------------------------------ ! Set albedos of the lake water, lake ice and snow !------------------------------------------------------------------------------ @@ -3153,9 +3191,10 @@ SUBROUTINE flake_interface ( dMsnowdt_in, I_atm_in, Q_atm_lw_in, height_u_in, he ! Snow is not considered !albedo_snow = albedo_ice albedo_ice = albedo_whiteice_ref -albedo_snow = albedo_ice +!albedo_snow = albedo_ice +albedo_snow = albedo_drysnow_ref opticpar_water%extincoef_optic(1) = water_extinc -!print*,'albedo= ',albedo_water,albedo_ice,albedo_snow +!write(0,*)'albedo= ',albedo_water,albedo_ice,albedo_snow !------------------------------------------------------------------------------ ! Set optical characteristics of the lake water, lake ice and snow @@ -3218,7 +3257,8 @@ SUBROUTINE flake_interface ( dMsnowdt_in, I_atm_in, Q_atm_lw_in, height_u_in, he CALL SfcFlx_momsenlat ( height_u_in, height_tq_in, fetch, & U_a_in, T_a_in, q_a_in, T_sfc_p, P_a_in, h_ice_p_flk, & Q_momentum, Q_sensible, Q_latent, Q_watvap, q_sfc, rho_a ) - +!write(0,*)'tpl_rho_w_r= ', tpl_rho_w_r +!write(0,*) 'Q_momentum= ',Q_momentum u_star_w_flk = SQRT(-Q_momentum/tpl_rho_w_r) ustar = u_star_w_flk @@ -3268,6 +3308,9 @@ SUBROUTINE flake_interface ( dMsnowdt_in, I_atm_in, Q_atm_lw_in, height_u_in, he H_B1_out = H_B1_n_flk hflx_out = Q_sensible evap_out = Q_watvap +!evap_out = Q_latent +gflx_out = Q_w_flk +lflx_out = Q_latent chh = ch * U_a_in * rho_a cmm = cm * U_a_in diff --git a/physics/flake_driver.F90 b/physics/flake_driver.F90 index 94fe8286b..a78c6acf6 100644 --- a/physics/flake_driver.F90 +++ b/physics/flake_driver.F90 @@ -49,13 +49,17 @@ end subroutine flake_driver_finalize !! SUBROUTINE flake_driver_run ( & ! ---- Inputs - im, ps, t1, q1, wind, & - dlwflx, dswsfc, weasd, lakedepth, & - use_flake, xlat, delt, zlvl, elev, & - wet, flag_iter, yearlen, julian, imon, & + im, ps, t1, q1, wind, min_lakeice, & + dlwflx, dswsfc, lakedepth, lakefrac, & + use_flake, snow, xlat, delt, zlvl, elev, & + wet, yearlen, julian, imon, & + flag_iter, first_time_step, flag_restart, & + weasd, & ! ---- in/outs - snwdph, hice, tsurf, fice, T_sfc, hflx, evap, & - ustar, qsfc, ch, cm, chh, cmm, & + snwdph, hice, tsurf, t_sfc, fice, hflx, evap, & + lflx, gflx, ustar, qsfc, ch, cm, chh, cmm, & + h_ML, t_wML, t_mnw, H_B, T_B, t_bot1, & + t_bot2, c_t, T_snow, T_ice, tsurf_ice, & errmsg, errflg ) !============================================================================== @@ -84,37 +88,41 @@ SUBROUTINE flake_driver_run ( & real (kind=kind_phys), dimension(:), intent(in) :: ps, wind, & & t1, q1, dlwflx, dswsfc, zlvl, elev - real (kind=kind_phys), intent(in) :: delt + real (kind=kind_phys), intent(in) :: delt, min_lakeice real (kind=kind_phys), dimension(:), intent(in) :: & - & xlat, weasd, lakedepth + & xlat, lakedepth, lakefrac, snow - real (kind=kind_phys),dimension(:),intent(inout) :: & - & snwdph, hice, tsurf, t_sfc, hflx, evap, fice, ustar, qsfc, & - & ch, cm, chh, cmm + real (kind=kind_phys), dimension(:), intent(in) :: weasd + + real (kind=kind_phys),dimension(:),intent(inout) :: & + & snwdph, hice, tsurf, t_sfc, hflx, evap, fice, ustar, qsfc, & + & ch, cm, chh, cmm, h_ML, t_wML, t_mnw, H_B, T_B, & + & t_bot1, t_bot2, c_t, T_snow, T_ice, tsurf_ice, lflx, gflx real (kind=kind_phys), intent(in) :: julian - logical, dimension(:), intent(in) :: flag_iter, wet, use_flake + logical, dimension(:), intent(in) :: flag_iter, wet + integer, dimension(:), intent(in) :: use_flake + logical, intent(in) :: flag_restart, first_time_step character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg ! --- locals - - real (kind=kind_phys) , parameter :: lake_pct_min = 0.1 + real (kind=kind_phys), parameter :: lake_pct_min = 0.1 real (kind=kind_phys), dimension(im) :: & - T_snow , & ! Temperature at the air-snow interface [K] - T_ice , & ! Temperature at the snow-ice or air-ice interface [K] - T_mnw , & ! Mean temperature of the water column [K] - T_wML , & ! Mixed-layer temperature [K] - T_bot , & ! Temperature at the water-bottom sediment interface [K] - T_B1 , & ! Temperature at the upper layer of the sediments [K] - C_T , & ! Shape factor (thermocline) +! T_snow , & ! Temperature at the air-snow interface [K] +! T_ice , & ! Temperature at the snow-ice or air-ice interface [K] +! T_mnw , & ! Mean temperature of the water column [K] +! T_wML , & ! Mixed-layer temperature [K] +! T_bot , & ! Temperature at the water-bottom sediment interface [K] +! T_B , & ! Temperature at the upper layer of the sediments [K] +! C_T , & ! Shape factor (thermocline) fetch , & ! Typical wind fetch [m] - h_ML , & ! Thickness of the mixed-layer [m] - H_B1 , & ! Thickness of the upper layer of bottom sediments [m] +! h_ML , & ! Thickness of the mixed-layer [m] +! H_B1 , & ! Thickness of the upper layer of bottom sediments [m] w_albedo , & ! w_extinc @@ -147,7 +155,7 @@ SUBROUTINE flake_driver_run ( & T_mnw_in , & ! Mean temperature of the water column [K] T_wML_in , & ! Mixed-layer temperature [K] T_bot_in , & ! Temperature at the water-bottom sediment interface [K] - T_B1_in , & ! Temperature at the bottom of the upper layer of the sediments [K] + T_B_in , & ! Temperature at the bottom of the upper layer of the sediments [K] C_T_in , & ! Shape factor (thermocline) h_snow_in , & ! Snow thickness [m] h_ice_in , & ! Ice thickness [m] @@ -165,7 +173,7 @@ SUBROUTINE flake_driver_run ( & T_mnw_out , & ! Mean temperature of the water column [K] T_wML_out , & ! Mixed-layer temperature [K] T_bot_out , & ! Temperature at the water-bottom sediment interface [K] - T_B1_out , & ! Temperature at the bottom of the upper layer of the sediments [K] + T_B_out , & ! Temperature at the bottom of the upper layer of the sediments [K] C_T_out , & ! Shape factor (thermocline) h_snow_out , & ! Snow thickness [m] h_ice_out , & ! Ice thickness [m] @@ -182,17 +190,19 @@ SUBROUTINE flake_driver_run ( & Q_momentum , & ! Momentum flux [N m^{-2}] Q_SHT_flx , & ! Sensible heat flux [W m^{-2}] Q_LHT_flx , & ! Latent heat flux [W m^{-2}] - Q_watvap ! Flux of water vapour [kg m^{-2} s^{-1}] + Q_watvap , & ! Flux of water vapour [kg m^{-2} s^{-1}] + Q_gflx , & ! Flux from ice to water [W m^{-2}] + Q_lflx ! latent fluxes [W m^{-2}] REAL (KIND = kind_phys) :: & - lake_depth_max, T_bot_2_in, T_bot_2_out, dxlat,tb,tr,tt,temp,temp2 + lake_depth_max, T_bot_2_in, T_bot_2_out, dlat,tb,tr,tt,temp,temp2 real (kind=kind_phys), parameter :: pi=4.0_kind_phys*atan(1.0_kind_phys) real (kind=kind_phys), parameter :: degrad=180.0_kind_phys/pi real (kind=kind_phys), parameter :: Kbar = 3.5_kind_phys, DelK = 3.0_kind_phys, & KbaroDelK = Kbar / DelK - REAL (KIND = kind_phys) :: x, y !temperarory variables used for Tbot and Tsfc + REAL (KIND = kind_phys) :: x, y, w !temperarory variables used for Tbot and Tsfc !initilizations INTEGER :: i,ipr,iter @@ -205,15 +215,17 @@ SUBROUTINE flake_driver_run ( & ! Start calculations !------------------------------------------------------------------------------ ! FLake_write need to assign original value to make the model somooth + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 ! --- ... set flag for lake points do_flake = .false. do i = 1, im - flag(i) = wet(i) .and. flag_iter(i) .and. use_flake(i) - do_flake = flag(i) .or. do_flake + flag(i) = flag_iter(i) .and. use_flake(i) .gt. 0 + do_flake = flag(i) .or. do_flake enddo - if (.not. do_flake) return lake_depth_max = 60.0 @@ -230,61 +242,61 @@ SUBROUTINE flake_driver_run ( & temp2 = sin((pi+pi)*(julian-151)/244) do i = 1, im - if (flag(i)) then - T_ice(i) = 273.15 - T_snow(i) = 273.15 - fetch(i) = 2.0E+03 - C_T(i) = 0.50 - - dxlat = degrad*abs(xlat(i)) - tt = 29.275+(0.0813-0.0052*dxlat)*dxlat-0.0038*elev(i)+273.15 - tb = 29.075-(0.7566-0.0051*dxlat)*dxlat-0.0038*elev(i)+273.15 -! if (fice(i).le.0.0) then -! h_ice(i) = 0.0 -! h_snow(i)= 0.0 -! endif - if (snwdph(i) > 0.0 .or. hice(i) > 0.0) then - if (tsurf(i) < T_ice(i)) then - T_sfc(i) = T_ice(i) - else - T_sfc(i) = tsurf(i) - endif - else -! if (tsurf(i) < tt) then -! T_sfc(i) = tt -! else -! T_sfc(i) = tsurf(i) -! endif - T_sfc(i) = 0.1*tt + 0.9* tsurf(i) - endif -! + if (flag(i) .and. lakedepth(i) >1.0) then + if(.not.flag_restart .and. first_time_step) then + T_ice(i) = 273.15 + T_snow(i) = 273.15 + C_T(i) = 0.50 + dlat = abs(xlat(i)) + if(dlat .lt. 1.40) then + tt = (((21.181*dlat-51.376)*dlat+20.808)*dlat-3.8408)*dlat+29.554 + tt = tt -0.0038*elev(i)+273.15 + tb = (((-29.794*dlat+96.91)*dlat-86.129)*dlat-7.1921)*dlat+28.176 + tb = tb -0.0038*elev(i)+273.15 + w = (((2.5467*dlat-7.4683)*dlat+5.2465)*dlat+0.4360)*dlat+0.0643 + else + tt = 4.0+273.15-0.0038*elev(i) + tb = 0.05+273.15-0.0038*elev(i) + w = 0.207312 + endif + if(tsurf(i) > 400.00) then + write(0,*) tsurf(i) + write(0,*) 'Surface temperature initial is bad' + tsurf(i) = tt + write(0,*) tsurf(i) + endif + T_sfc(i) = 0.05*tt + 0.95* tsurf(i) + ! Add empirical climatology of lake Tsfc and Tbot to the current Tsfc and Tbot ! to make sure Tsfc and Tbot are warmer than Tair in Winter or colder than Tair ! in Summer - if (xlat(i) >= 0.0) then - T_sfc(i) = T_sfc(i) + 0.3*y - tb = tb + 0.05*y - else - T_sfc(i) = T_sfc(i) - 0.3*y - tb = tb - 0.05*y - endif - T_bot(i) = tb - T_B1(i) = tb - -! if (lakedepth(i) < 10.0) then -! T_bot(i) = T_sfc(i) -! T_B1(i) = T_bot(i) -! endif - - T_mnw(i) = C_T(i)*T_sfc(i) + (1-C_T(i))*T_bot(i) - T_wML(i) = C_T(i)*T_sfc(i) + (1-C_T(i))*T_bot(i) - h_ML(i) = C_T(i)* min ( lakedepth(i), lake_depth_max ) - H_B1(i) = min ( lakedepth(i),4.0) - hflx(i) = 0.0 - evap(i) = 0.0 + if (xlat(i) >= 0.0) then + T_sfc(i) = T_sfc(i) + 0.05*y*w + tb = tb + 0.005*y*w + else + T_sfc(i) = T_sfc(i) - 0.5*y*w + tb = tb - 0.005*y*w + endif + + t_bot1(i) = tb + t_bot2(i) = tb + T_B(i) = tb + + T_mnw(i) = C_T(i)*T_sfc(i) + (1-C_T(i))*t_bot1(i) + T_wML(i) = C_T(i)*T_sfc(i) + (1-C_T(i))*t_bot1(i) + h_ML(i) = C_T(i)* min ( lakedepth(i), lake_depth_max ) + H_B(i) = min ( lakedepth(i),4.0) + hflx(i) = 0.0 + lflx(i) = 0.0 + evap(i) = 0.0 + chh = ch(i) * wind(i) * 1.225 !(kg/m3) + cmm = cm(i) * wind(i) + endif !end of .not.flag_restart + fetch(i) = 2.0E+03 ! compute albedo as a function of julian day and latitude +! write(0,*) ' xlat= ',xlat(i), temp w_albedo(I) = 0.06/cos((xlat(i)-temp)/1.2) ! w_albedo(I) = 0.06 ! compute water extinction coefficient as a function of julian day @@ -295,24 +307,26 @@ SUBROUTINE flake_driver_run ( & endif ! w_extinc(i) = 3.0 -! write(65,1002) julian,xlat(i),w_albedo(I),w_extinc(i),lakedepth(i),elev(i),tb,tt,tsurf(i),T_sfc(i) -! print 1002 julian,xlat(i),w_albedo(I),w_extinc(i),lakedepth(i),elev(i),tb,tt,tsurf(i),T_sfc(i) -! print*,'inside flake driver' -! print*, julian,xlat(i),w_albedo(I),w_extinc(i),lakedepth(i),elev(i),tb,tt,tsurf(i),T_sfc(i) +! write(0,1002) julian,xlat(i),w_albedo(I),w_extinc(i),elev(i),tsurf(i),T_sfc(i),t_bot1(i) +! write(0,1003) use_flake(i),i,lakefrac(i),lakedepth(i), snwdph(i), hice(i), fice(i) +! write(0,1004) ps(i), wind(i), t1(i), q1(i), dlwflx(i), dswsfc(i), zlvl(i) endif !flag enddo - 1001 format ( 'At icount=', i5, ' x = ', f5.2,5x, 'y = ', & - 1p, e12.3) -! 1002 format ( ' julian= ',F6.2,1x,5(F8.4,1x),3(f11.4,1x)) - 1002 format (I4,1x,3(f8.4,1x),6(f11.4,1x)) - - + 1002 format ( 'julian=',F6.2,1x,F8.3,1x,2(E7.2,1x),E7.2,1x,3(E7.2,1x)) + 1003 format ( 'use_flake=',I2,1x,I3,1x,F6.4,1x,F9.4,1x,2(F8.4,1x),F7.4) + 1004 format ( 'pressure',F12.2,1x,F6.2,1x,F7.2,1x,F7.4,1x,2(F8.2,1x),F8.4) ! ! call lake interface do i=1,im - if (flag(i)) then - dMsnowdt_in = weasd(i)/delt + if (flag(i) .and. lakedepth(i) > 1.0) then +! write(0,*) 'flag(i)= ', i, flag(i) +! if(weasd(i) < 0.0 .or. hice(i) < 0.0) weasd(i) =0.0 + if(snwdph(i) < 0.0) snwdph(i) =0.0 +! dMsnowdt_in = 10.0*0.001*weasd(i)/delt +! dMsnowdt_in = snow(i)/delt + dMsnowdt_in = snow(i)*0.001 + if(dMsnowdt_in < 0.0) dMsnowdt_in=0.0 I_atm_in = dswsfc(i) Q_atm_lw_in = dlwflx(i) height_u_in = zlvl(i) @@ -329,27 +343,36 @@ SUBROUTINE flake_driver_run ( & depth_w = min ( lakedepth(i), lake_depth_max ) depth_bs_in = max ( 4.0, min ( depth_w * 0.2, 10.0 ) ) fetch_in = fetch(i) - T_bs_in = T_bot(i) + T_bs_in = T_bot1(i) par_Coriolis = 2 * 7.2921 / 100000. * sin ( xlat(i) ) del_time = delt - do iter=1,10 !interation loop +! if(lakedepth(i).lt.10) then +! T_sfc(i) = t1(i) +! T_bs_in = T_sfc(i) +! T_B(i) = T_bs_in +! endif + + do iter=1,5 !interation loop T_snow_in = T_snow(i) T_ice_in = T_ice(i) T_mnw_in = T_mnw(i) T_wML_in = T_wML(i) - T_bot_in = T_bot(i) - T_B1_in = T_B1(i) + T_bot_in = t_bot1(i) + T_B_in = T_B(i) C_T_in = C_T(i) h_snow_in = snwdph(i) h_ice_in = hice(i) h_ML_in = h_ML(i) - H_B1_in = H_B1(i) + H_B1_in = H_B(i) T_sfc_in = T_sfc(i) + tsurf_ice(i)= T_ice(i) - T_bot_2_in = T_bot(i) + T_bot_2_in = t_bot2(i) Q_SHT_flx = hflx(i) Q_watvap = evap(i) + Q_gflx = 0.0 + Q_lflx = 0.0 !------------------------------------------------------------------------------ ! Set the rate of snow accumulation @@ -359,13 +382,13 @@ SUBROUTINE flake_driver_run ( & height_tq_in, U_a_in, T_a_in, q_a_in, P_a_in, & depth_w, fetch_in, depth_bs_in, T_bs_in, par_Coriolis, del_time, & - T_snow_in, T_ice_in, T_mnw_in, T_wML_in, T_bot_in, T_B1_in, & + T_snow_in, T_ice_in, T_mnw_in, T_wML_in, T_bot_in, T_B_in, & C_T_in, h_snow_in, h_ice_in, h_ML_in, H_B1_in, T_sfc_in, & ch_in, cm_in, albedo_water, water_extinc, & ! T_snow_out, T_ice_out, T_mnw_out, T_wML_out, T_bot_out, & - T_B1_out, C_T_out, h_snow_out, h_ice_out, h_ML_out, & - H_B1_out, T_sfc_out, Q_SHT_flx, Q_watvap, & + T_B_out, C_T_out, h_snow_out, h_ice_out, h_ML_out, & + H_B1_out, T_sfc_out, Q_SHT_flx, Q_watvap, Q_gflx, Q_lflx, & ! T_bot_2_in, T_bot_2_out,u_star, q_sfc,chh_out,cmm_out ) @@ -378,11 +401,13 @@ SUBROUTINE flake_driver_run ( & T_wML(i) = T_wML_out T_sfc(i) = T_sfc_out Tsurf(i) = T_sfc_out - T_bot(i) = T_bot_out - T_B1(i) = T_B1_out + tsurf_ice(i) = T_ice(i) + t_bot1(i) = T_bot_out + t_bot2(i) = T_bot_2_out + T_B(i) = T_B_out C_T(i) = C_T_out h_ML(i) = h_ML_out - H_B1(i) = H_B1_out + H_B(i) = H_B1_out ustar(i) = u_star qsfc(i) = q_sfc chh(i) = chh_out @@ -391,26 +416,91 @@ SUBROUTINE flake_driver_run ( & hice(i) = h_ice_out evap(i) = Q_watvap hflx(i) = Q_SHT_flx - - if (hice(i) > 0.0 .or. snwdph(i) > 0.0) then - fice(i) = 1.0 - else - fice(i) = 0.0 - endif + gflx(i) = Q_gflx + lflx(i) = Q_lflx +! if(lflx(i) > 2500.00 .or. Tsurf(i) > 350.00) then +! write(0,125) i,lflx(i), Tsurf(i),ps(i), wind(i), & +! & t1(i), q1(i), dlwflx(i), dswsfc(i),hflx(i) +! endif +! fice(i) = fice(i)+0.01*(h_ice_out-h_ice_in) +! if(fice(i) .lt. min_lakeice ) then +! fice(i) = 0.0 +! elseif(fice(i) .gt. 1.0) then +! fice(i) = 1.0 +! endif enddo !iter loop +! endif !endif use_flake endif !endif of flag enddo -!125 format(1x,i2,1x,i2,1x,i2,1x,6(1x,f14.8)) +125 format(1x,i3,1x,9(1x,f10.3)) !126 format(1x,i2,1x,i2,1x,6(1x,f14.8)) !127 format(1x,i2,2(1x,f16.9)) !------------------------------------------------------------------------------ ! End calculations !============================================================================== -END SUBROUTINE flake_driver_run + END SUBROUTINE flake_driver_run + +end module flake_driver + +module flake_driver_post + use machine, only: kind_phys + implicit none + private + public flake_driver_post_init, flake_driver_post_finalize, flake_driver_post_run + +contains + subroutine flake_driver_post_init() + end subroutine flake_driver_post_init + + subroutine flake_driver_post_finalize() + end subroutine flake_driver_post_finalize + +!> \section arg_table_flake_driver_post Argument Table +!! \htmlinclude flake_driver_post.html +!! +subroutine flake_driver_post_run (im, use_flake, h_ML, T_wML, Tsurf, & + lakedepth, xz, zm, tref, tsfco, & + errmsg, errflg) + +!use machine , only : kind_phys +!============================================================================== + + implicit none + integer, intent(in) :: im +! integer, dimension(im), intent(in) :: islmsk + + real (kind=kind_phys), dimension(:), intent(in) :: & + & lakedepth, tsurf, h_ML, t_wML + + real (kind=kind_phys),dimension(:),intent(inout) :: & + & xz, zm, tref, tsfco + + integer, dimension(:), intent(in) :: use_flake + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + integer :: i + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + do I=1, im + if(use_flake(i).eq.2) then + write(0,*)'flake-post-use-flake= ',use_flake(i) + xz(i) = lakedepth(i) + zm(i) = h_ML(i) + tref(i) = tsurf(i) + tsfco(i) = t_wML(i) + endif + enddo + + +end subroutine flake_driver_post_run !--------------------------------- - end module flake_driver +end module flake_driver_post diff --git a/physics/flake_driver.meta b/physics/flake_driver.meta index 7ed80d866..67822df05 100644 --- a/physics/flake_driver.meta +++ b/physics/flake_driver.meta @@ -86,9 +86,17 @@ type = real kind = kind_phys intent = in +[min_lakeice] + standard_name = min_lake_ice_area_fraction + long_name = minimum lake ice value + units = frac + dimensions = () + type = real + kind = kind_phys + intent = in [dlwflx] - standard_name = surface_downwelling_longwave_flux_absorbed_by_ground_over_water - long_name = total sky surface downward longwave flux absorbed by the ground over water + standard_name = surface_downwelling_longwave_flux + long_name = surface downwelling longwave flux at current time units = W m-2 dimensions = (horizontal_loop_extent) type = real @@ -102,14 +110,6 @@ type = real kind = kind_phys intent = in -[weasd] - standard_name = water_equivalent_accumulated_snow_depth_over_ice - long_name = water equiv of acc snow depth over ice - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in [lakedepth] standard_name = lake_depth long_name = lake depth @@ -118,12 +118,28 @@ type = real kind = kind_phys intent = in +[lakefrac] + standard_name = lake_area_fraction + long_name = fraction of horizontal grid area occupied by lake + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [use_flake] standard_name = flag_for_using_flake long_name = flag indicating lake points using flake model units = flag dimensions = (horizontal_loop_extent) - type = logical + type = integer + intent = in +[snow] + standard_name = lwe_thickness_of_snow_amount_on_dynamics_timestep + long_name = snow fall at this time step + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys intent = in [xlat] standard_name = latitude @@ -164,13 +180,6 @@ dimensions = (horizontal_loop_extent) type = logical intent = in -[flag_iter] - standard_name = flag_for_iteration - long_name = flag for iteration - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in [yearlen] standard_name = number_of_days_in_current_year long_name = number of days in a year @@ -193,6 +202,35 @@ dimensions = () type = integer intent = in +[flag_iter] + standard_name = flag_for_iteration + long_name = flag for iteration + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in +[first_time_step] + standard_name = flag_for_first_timestep + long_name = flag for first time step for time integration loop (cold/warmstart) + units = flag + dimensions = () + type = logical + intent = in +[flag_restart] + standard_name = flag_for_restart + long_name = flag for restart (warmstart) or coldstart + units = flag + dimensions = () + type = logical + intent = in +[weasd] + standard_name = water_equivalent_accumulated_snow_depth_over_ice + long_name = water equiv of acc snow depth over ice + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout [snwdph] standard_name = surface_snow_thickness_water_equivalent_over_ice long_name = water equivalent snow depth over ice @@ -210,8 +248,8 @@ kind = kind_phys intent = inout [tsurf] - standard_name = surface_skin_temperature_after_iteration_over_water - long_name = surface skin temperature after iteration over water + standard_name = surface_skin_temperature_over_water + long_name = surface skin temperature over water units = K dimensions = (horizontal_loop_extent) type = real @@ -226,8 +264,8 @@ kind = kind_phys intent = inout [t_sfc] - standard_name = surface_skin_temperature_over_water - long_name = surface skin temperature over water + standard_name = surface_skin_temperature_after_iteration_over_water + long_name = surface skin temperature after iteration over water units = K dimensions = (horizontal_loop_extent) type = real @@ -249,6 +287,22 @@ type = real kind = kind_phys intent = inout +[lflx] + standard_name = surface_upward_potential_latent_heat_flux_over_water + long_name = surface upward potential latent heat flux over water + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[gflx] + standard_name = upward_heat_flux_in_soil_over_water + long_name = soil heat flux over water + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout [ustar] standard_name = surface_friction_velocity_over_water long_name = surface friction velocity over water @@ -297,6 +351,190 @@ type = real kind = kind_phys intent = inout +[h_ML] + standard_name = mixed_layer_depth_of_lakes + long_name = depth of lake mixing layer + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[t_wML] + standard_name = lake_mixed_layer_temperature + long_name = temperature of lake mixing layer + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[t_mnw] + standard_name = mean_temperature_of_the_water_column + long_name = thee mean temperature of the water column + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[H_B] + standard_name = the_thermally_active_layer_depth_of_the_bottom_sediment + long_name = the depth of the thermally active layer of the bottom sediment + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[T_B] + standard_name = temperature_at_the_bottom_of_the_sediment_upper_layer + long_name = the temperature at the bottom of the sediment upper layer + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[t_bot1] + standard_name = lake_bottom_temperature + long_name = the temperature at the water-bottom sediment interface + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[t_bot2] + standard_name = temperature_for_bottom_layer_of_water + long_name = the temperature at the lake bottom layer water + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[c_t] + standard_name = shape_factor_of_water_temperature_vertical_profile + long_name = the shape factor of water temperature vertical profile + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[T_snow] + standard_name = temperature_of_snow_on_lake + long_name = the temperature of snow on a lake + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[T_ice] + standard_name = surface_skin_temperature_over_ice + long_name = surface skin temperature over ice + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[tsurf_ice] + standard_name = surface_skin_temperature_after_iteration_over_ice + long_name = surface skin temperature after iteration over ice + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out + +######################################################################## +[ccpp-table-properties] + name = flake_driver_post + type = scheme + dependencies = machine.F +######################################################################## +[ccpp-arg-table] + name = flake_driver_post_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[lakedepth] + standard_name = lake_depth + long_name = lake depth + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[tsurf] + standard_name = surface_skin_temperature_after_iteration_over_water + long_name = surface skin temperature after iteration over water + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[h_ML] + standard_name = mixed_layer_depth_of_lakes + long_name = depth of lake mixing layer + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[t_wML] + standard_name = lake_mixed_layer_temperature + long_name = temperature of lake mixing layer + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[xz] + standard_name = diurnal_thermocline_layer_thickness + long_name = diurnal thermocline layer thickness + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[zm] + standard_name = ocean_mixed_layer_thickness + long_name = mixed layer thickness + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[tref] + standard_name = reference_sea_surface_temperature + long_name = reference/foundation temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[tfco] + standard_name = sea_surface_temperature + long_name = sea surface temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/lsm_ruc.F90 b/physics/lsm_ruc.F90 index 3ca78ad04..cd65dd8f8 100644 --- a/physics/lsm_ruc.F90 +++ b/physics/lsm_ruc.F90 @@ -393,7 +393,8 @@ subroutine lsm_ruc_run & ! inputs con_hvap, con_fvirt logical, dimension(:), intent(in) :: flag_iter, flag_guess - logical, dimension(:), intent(in) :: land, icy, use_lake + logical, dimension(:), intent(in) :: land, icy + integer, dimension(:), intent(in) :: use_lake logical, dimension(:), intent(in) :: flag_cice logical, intent(in) :: frac_grid logical, intent(in) :: do_mynnsfclay @@ -565,7 +566,7 @@ subroutine lsm_ruc_run & ! inputs endif ! - Set flag for ice points for uncoupled model (islmsk(i) == 4 when coupled to CICE) ! - Exclude ice on the lakes if the lake model is turned on. - flag_ice_uncoupled(i) = (flag_ice(i) .and. .not. use_lake(i)) + flag_ice_uncoupled(i) = (flag_ice(i) .and. use_lake(i)<1) !> - Set flag for land and ice points. !- 10may19 - ice points are turned off. flag(i) = land(i) .or. flag_ice_uncoupled(i) diff --git a/physics/lsm_ruc.meta b/physics/lsm_ruc.meta index 587fda681..9e56e2941 100644 --- a/physics/lsm_ruc.meta +++ b/physics/lsm_ruc.meta @@ -784,7 +784,7 @@ long_name = flag indicating lake points using flake model units = flag dimensions = (horizontal_loop_extent) - type = logical + type = integer intent = in [rainnc] standard_name = lwe_thickness_of_explicit_precipitation_amount_on_previous_timestep diff --git a/physics/radiation_surface.f b/physics/radiation_surface.f index 64afd0a35..ffda6fd89 100644 --- a/physics/radiation_surface.f +++ b/physics/radiation_surface.f @@ -794,7 +794,7 @@ subroutine setemis & integer, intent(in) :: IMAX integer, intent(in) :: lsm, lsm_noahmp, lsm_ruc logical, intent(in) :: frac_grid, cplice - logical, dimension(:), intent(in) :: use_flake + integer, dimension(:), intent(in) :: use_flake real (kind=kind_phys), dimension(:), intent(in) :: lakefrac real (kind=kind_phys), dimension(:), intent(in) :: & @@ -959,7 +959,7 @@ subroutine setemis & sfcemis_ice = semis_ice(i) ! output from CICE endif elseif (lsm == lsm_ruc) then - if (use_flake(i)) then + if (use_flake(i)>0) then if (sncovr_ice(i) > f_zero) then sfcemis_ice = emsref(7) * (f_one-sncovr_ice(i)) & & + emsref(8) * sncovr_ice(i) diff --git a/physics/sfc_diff.f b/physics/sfc_diff.f index 59c6d2d60..7a7a4496c 100644 --- a/physics/sfc_diff.f +++ b/physics/sfc_diff.f @@ -84,7 +84,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) & fm10_wat, fm10_lnd, fm10_ice, & !intent(inout) & fh2_wat, fh2_lnd, fh2_ice, & !intent(inout) & ztmax_wat, ztmax_lnd, ztmax_ice, & !intent(inout) - & zvfun, & !intent(out) + & zvfun, use_flake, & !intent(out) & errmsg, errflg) !intent(out) ! implicit none @@ -94,9 +94,11 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) integer, intent(in) :: sfc_z0_type ! option for calculating surface roughness length over ocean integer, dimension(:), intent(in) :: vegtype + integer, dimension(:), intent(in) :: use_flake logical, intent(in) :: redrag ! reduced drag coeff. flag for high wind over sea (j.han) - logical, dimension(:), intent(in) :: flag_iter, wet, dry, icy + logical, dimension(:), intent(in) :: flag_iter, dry, icy + logical, dimension(:), intent(inout) :: wet logical, intent(in) :: thsfc_loc ! Flag for reference pressure in theta calculation @@ -171,6 +173,9 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! ps is in pascals, wind is wind speed, ! surface roughness length is converted to m from cm ! + do i=1,im + if(use_flake(i) > 0) wet(i) = .true. + enddo ! write(0,*)'in sfc_diff, sfc_z0_type=',sfc_z0_type diff --git a/physics/sfc_diff.meta b/physics/sfc_diff.meta index a2e1fe9f7..33149eb16 100644 --- a/physics/sfc_diff.meta +++ b/physics/sfc_diff.meta @@ -223,7 +223,7 @@ units = flag dimensions = (horizontal_loop_extent) type = logical - intent = in + intent = inout [dry] standard_name = flag_nonzero_land_surface_fraction long_name = flag indicating presence of some land surface area fraction @@ -565,6 +565,13 @@ type = real kind = kind_phys intent = inout +[use_flake] + standard_name = flag_for_using_flake + long_name = flag indicating lake points using flake model + units = flag + dimensions = (horizontal_loop_extent) + type = integer + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/sfc_nst.f b/physics/sfc_nst.f index 22961458d..e8e3627c5 100644 --- a/physics/sfc_nst.f +++ b/physics/sfc_nst.f @@ -193,8 +193,8 @@ subroutine sfc_nst_run & ! For sea spray effect logical, intent(in) :: lseaspray ! - logical, dimension(:), intent(in) :: flag_iter, flag_guess, wet, & - & use_flake + logical, dimension(:), intent(in) :: flag_iter, flag_guess, wet + integer, dimension(:), intent(in) :: use_flake ! &, icy logical, intent(in) :: lprnt logical, intent(in) :: thsfc_loc @@ -276,7 +276,7 @@ subroutine sfc_nst_run & do_nst = .false. do i = 1, im ! flag(i) = wet(i) .and. .not.icy(i) .and. flag_iter(i) - flag(i) = wet(i) .and. flag_iter(i) .and. .not. use_flake(i) + flag(i) = wet(i) .and. flag_iter(i) .and. use_flake(i)/=1 do_nst = do_nst .or. flag(i) enddo if (.not. do_nst) return @@ -285,7 +285,7 @@ subroutine sfc_nst_run & ! do i=1, im ! if(wet(i) .and. .not.icy(i) .and. flag_guess(i)) then - if(wet(i) .and. flag_guess(i) .and. .not. use_flake(i)) then + if(wet(i) .and. flag_guess(i) .and. use_flake(i)/=1) then xt_old(i) = xt(i) xs_old(i) = xs(i) xu_old(i) = xu(i) @@ -604,7 +604,7 @@ subroutine sfc_nst_run & ! restore nst-related prognostic fields for guess run do i=1, im ! if (wet(i) .and. .not.icy(i)) then - if (wet(i) .and. .not. use_flake(i)) then + if (wet(i) .and. use_flake(i)/=1) then if (flag_guess(i)) then ! when it is guess of xt(i) = xt_old(i) xs(i) = xs_old(i) @@ -692,4 +692,4 @@ subroutine sfc_nst_run & return end subroutine sfc_nst_run !> @} - end module sfc_nst \ No newline at end of file + end module sfc_nst diff --git a/physics/sfc_nst.meta b/physics/sfc_nst.meta index fa15749b6..3f281231c 100644 --- a/physics/sfc_nst.meta +++ b/physics/sfc_nst.meta @@ -241,7 +241,7 @@ long_name = flag indicating lake points using flake model units = flag dimensions = (horizontal_loop_extent) - type = logical + type = integer intent = in [xlon] standard_name = longitude @@ -616,4 +616,4 @@ units = 1 dimensions = () type = integer - intent = out \ No newline at end of file + intent = out diff --git a/physics/sfc_nst_post.f b/physics/sfc_nst_post.f index 80f96d3f8..b316dccd0 100644 --- a/physics/sfc_nst_post.f +++ b/physics/sfc_nst_post.f @@ -30,7 +30,8 @@ subroutine sfc_nst_post_run & ! --- inputs: integer, intent(in) :: im, kdt, nthreads - logical, dimension(:), intent(in) :: wet, icy, use_flake + logical, dimension(:), intent(in) :: wet, icy + integer, dimension(:), intent(in) :: use_flake real (kind=kind_phys), intent(in) :: rlapse, tgice real (kind=kind_phys), dimension(:), intent(in) :: oro, oro_uf integer, intent(in) :: nstf_name1, nstf_name4, nstf_name5 @@ -75,7 +76,7 @@ subroutine sfc_nst_post_run & do i = 1, im ! if (wet(i) .and. .not.icy(i)) then ! if (wet(i) .and. (frac_grid .or. .not. icy(i))) then - if (wet(i) .and. .not. use_flake(i)) then + if (wet(i) .and. use_flake(i) /=1) then tsfc_wat(i) = max(tgice, tref(i) + dtzm(i)) ! tsfc_wat(i) = max(271.2, tref(i) + dtzm(i)) - & ! (oro(i)-oro_uf(i))*rlapse diff --git a/physics/sfc_nst_post.meta b/physics/sfc_nst_post.meta index aefa53bb0..45257fe41 100644 --- a/physics/sfc_nst_post.meta +++ b/physics/sfc_nst_post.meta @@ -50,7 +50,7 @@ long_name = flag indicating lake points using flake model units = flag dimensions = (horizontal_loop_extent) - type = logical + type = integer intent = in [icy] standard_name = flag_nonzero_sea_ice_surface_fraction diff --git a/physics/sfc_ocean.F b/physics/sfc_ocean.F index 2b9449eab..574388317 100644 --- a/physics/sfc_ocean.F +++ b/physics/sfc_ocean.F @@ -117,7 +117,8 @@ subroutine sfc_ocean_run & ! For sea spray effect logical, intent(in) :: lseaspray ! - logical, dimension(:), intent(in) :: flag_iter, wet, use_flake + logical, dimension(:), intent(in) :: flag_iter, wet + integer, dimension(:), intent(in) :: use_flake ! logical, intent(in) :: use_med_flux @@ -166,7 +167,7 @@ subroutine sfc_ocean_run & ! ! --- ... flag for open water do i = 1, im - flag(i) = (wet(i) .and. flag_iter(i) .and. .not. use_flake(i)) + flag(i) = (wet(i) .and. flag_iter(i) .and. use_flake(i) /=1) ! --- ... initialize variables. all units are supposedly m.k.s. unless specified ! ps is in pascals, wind is wind speed, ! rho is density, qss is sat. hum. at surface diff --git a/physics/sfc_ocean.meta b/physics/sfc_ocean.meta index fcf4daa07..f30be6ea8 100644 --- a/physics/sfc_ocean.meta +++ b/physics/sfc_ocean.meta @@ -177,7 +177,7 @@ long_name = flag indicating lake points using flake model units = flag dimensions = (horizontal_loop_extent) - type = logical + type = integer intent = in [wind] standard_name = wind_speed_at_lowest_model_layer diff --git a/physics/sfc_sice.f b/physics/sfc_sice.f index b88178702..195ebec80 100644 --- a/physics/sfc_sice.f +++ b/physics/sfc_sice.f @@ -167,7 +167,8 @@ subroutine sfc_sice_run & integer, dimension(:), intent(in) :: islmsk real (kind=kind_phys), intent(in) :: delt - logical, dimension(im), intent(in) :: flag_iter, use_flake + logical, dimension(im), intent(in) :: flag_iter + integer, dimension(im), intent(in) :: use_flake ! --- input/outputs: real (kind=kind_phys), dimension(:), intent(inout) :: hice, & @@ -215,7 +216,7 @@ subroutine sfc_sice_run & do_sice = .false. do i = 1, im flag(i) = islmsk(i) == 2 .and. flag_iter(i) & - & .and. .not. use_flake(i) + & .and. use_flake(i) /=1 do_sice = do_sice .or. flag(i) ! if (flag_iter(i) .and. islmsk(i) < 2) then ! hice(i) = zero diff --git a/physics/sfc_sice.meta b/physics/sfc_sice.meta index 718109879..489c3758b 100644 --- a/physics/sfc_sice.meta +++ b/physics/sfc_sice.meta @@ -241,7 +241,7 @@ long_name = flag indicating lake points using flake model units = flag dimensions = (horizontal_loop_extent) - type = logical + type = integer intent = in [lprnt] standard_name = flag_print From 23290c37b305181bbd801b29b33bafd1a6f75e01 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 11 Aug 2022 20:27:23 +0000 Subject: [PATCH 007/380] add clm lake --- physics/GFS_phys_time_vary.fv3.F90 | 43 +- physics/GFS_phys_time_vary.fv3.meta | 47 +- physics/GFS_radiation_surface.F90 | 6 +- physics/GFS_radiation_surface.meta | 6 +- physics/GFS_surface_composites_inter.F90 | 6 +- physics/GFS_surface_composites_inter.meta | 6 +- physics/GFS_surface_composites_pre.F90 | 6 +- physics/GFS_surface_composites_pre.meta | 10 +- physics/clm_lake.f90 | 5441 +++++++++++++++++++++ physics/clm_lake.meta | 680 +++ physics/flake_driver.F90 | 22 +- physics/flake_driver.meta | 6 +- physics/radiation_surface.f | 8 +- physics/scm_sfc_flux_spec.F90 | 10 +- physics/scm_sfc_flux_spec.meta | 12 +- physics/sfc_diff.f | 7 +- physics/sfc_diff.meta | 6 +- physics/sfc_nst.f | 14 +- physics/sfc_nst.meta | 6 +- physics/sfc_nst_post.f | 8 +- physics/sfc_nst_post.meta | 6 +- physics/sfc_ocean.F | 8 +- physics/sfc_ocean.meta | 6 +- physics/sfc_sice.f | 8 +- physics/sfc_sice.meta | 6 +- 25 files changed, 6275 insertions(+), 109 deletions(-) create mode 100644 physics/clm_lake.f90 create mode 100644 physics/clm_lake.meta diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index 25e5218d5..db293503e 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -82,19 +82,20 @@ subroutine GFS_phys_time_vary_init ( zwtxy, xlaixy, xsaixy, lfmassxy, stmassxy, rtmassxy, woodxy, stblcpxy, fastcpxy, & smcwtdxy, deeprechxy, rechxy, snowxy, snicexy, snliqxy, tsnoxy , smoiseq, zsnsoxy, & slc, smc, stc, tsfcl, snowd, canopy, tg3, stype, con_t0c, lsm_cold_start, nthrds, & - lkm, use_flake, lakefrac, lakedepth, errmsg, errflg) + lkm, use_lake_model, lakefrac, lakedepth, iopt_lake, iopt_lake_clm, iopt_lake_flake, & + lakefrac_threshold, lakedepth_threshold, errmsg, errflg) implicit none ! Interface variables integer, intent(in) :: me, master, ntoz, iccn, iflip, im, nx, ny, levs logical, intent(in) :: h2o_phys, iaerclm, lsm_cold_start - integer, intent(in) :: idate(:) - real(kind_phys), intent(in) :: fhour + integer, intent(in) :: idate(:), iopt_lake, iopt_lake_clm, iopt_lake_flake + real(kind_phys), intent(in) :: fhour, lakefrac_threshold, lakedepth_threshold real(kind_phys), intent(in) :: xlat_d(:), xlon_d(:) integer, intent(in) :: lkm - integer, intent(inout) :: use_flake(:) + integer, intent(inout) :: use_lake_model(:) real(kind=kind_phys), intent(in ) :: lakefrac(:), lakedepth(:) integer, intent(inout) :: jindx1_o3(:), jindx2_o3(:), jindx1_h(:), jindx2_h(:) @@ -676,20 +677,26 @@ subroutine GFS_phys_time_vary_init ( endif noahmp_init endif lsm_init -!Flake - do i = 1, im - if (lakefrac(i) > 0.0 .and. lakedepth(i) > 1.0 ) then - if (lkm == 1 ) then - use_flake(i) = 1 - elseif (lkm == 2 ) then - use_flake(i) = 2 - else - use_flake(i) = 0 - endif - else - use_flake(i) = 0 - endif - enddo +!Lake model + if((lkm==1 .or. lkm==2) .and. (iopt_lake==iopt_lake_flake .or. iopt_lake==iopt_lake_clm)) then + ! A lake model is enabled. + do i = 1, im + !if (lakefrac(i) > 0.0 .and. lakedepth(i) > 1.0 ) then + + ! The lake data must say there's a lake here (lakefrac) with a depth (lakedepth) + if (lakefrac(i) > lakefrac_threshold .and. lakedepth(i) > lakedepth_threshold ) then + ! This is a lake point. Inform the other schemes to use a lake model, and possibly nsst (lkm) + use_lake_model(i) = lkm + cycle + else + ! Not a valid lake point. + use_lake_model(i) = 0 + endif + enddo + else + ! Lake model is disabled or settings are invalid. + use_lake_model = 0 + endif is_initialized = .true. diff --git a/physics/GFS_phys_time_vary.fv3.meta b/physics/GFS_phys_time_vary.fv3.meta index c8f178bf3..107eb8f56 100644 --- a/physics/GFS_phys_time_vary.fv3.meta +++ b/physics/GFS_phys_time_vary.fv3.meta @@ -896,15 +896,15 @@ type = integer intent = in [lkm] - standard_name = control_for_lake_surface_scheme - long_name = flag for lake surface model + standard_name = control_for_lake_model_execution_method + long_name = control for lake model execution: 0=no lake, 1=lake, 2=lake+nsst units = flag dimensions = () type = integer intent = in -[use_flake] - standard_name = flag_for_using_flake - long_name = flag indicating lake points using flake model +[use_lake_model] + standard_name = flag_for_using_lake_model + long_name = flag indicating lake points using a lake model units = flag dimensions = (horizontal_dimension) type = integer @@ -925,6 +925,43 @@ type = real kind = kind_phys intent = in +[iopt_lake] + standard_name = control_for_lake_model_selection + long_name = control for lake model selection + units = 1 + dimensions = () + type = integer + intent = in +[iopt_lake_clm] + standard_name = clm_lake_model_control_selection_value + long_name = value that indicates clm lake model in the control for lake model selection + units = 1 + dimensions = () + type = integer + intent = in +[iopt_lake_flake] + standard_name = flake_model_control_selection_value + long_name = value that indicates flake model in the control for lake model selection + units = 1 + dimensions = () + type = integer + intent = in +[lakefrac_threshold] + standard_name = lakefrac_threshold_for_enabling_lake_model + long_name = fraction of horizontal grid area occupied by lake must be greater than this value to enable a lake model + units = frac + dimensions = () + type = real + kind = kind_phys + intent = in +[lakedepth_threshold] + standard_name = lake_depth_threshold_for_enabling_lake_model + long_name = lake depth must be greater than this value to enable a lake model + units = m + dimensions = () + type = real + kind = kind_phys + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/GFS_radiation_surface.F90 b/physics/GFS_radiation_surface.F90 index 07c87414e..e8bcca69f 100644 --- a/physics/GFS_radiation_surface.F90 +++ b/physics/GFS_radiation_surface.F90 @@ -50,7 +50,7 @@ subroutine GFS_radiation_surface_run ( & xlat, xlon, slmsk, lndp_type, n_var_lndp, sfc_alb_pert, & lndp_var_list, lndp_prt_list, landfrac, snodl, snodi, sncovr, & sncovr_ice, fice, zorl, hprime, tsfg, tsfa, tisfc, coszen, & - cplice, min_seaice, min_lakeice, lakefrac, use_flake, & + cplice, min_seaice, min_lakeice, lakefrac, use_lake_model, & alvsf, alnsf, alvwf, alnwf, facsf, facwf, & semis_lnd, semis_ice, semis_wat, snoalb, use_cice_alb, & albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, & @@ -68,7 +68,7 @@ subroutine GFS_radiation_surface_run ( & integer, intent(in) :: lsm, lsm_noahmp, lsm_ruc, lndp_type, n_var_lndp real(kind=kind_phys), intent(in) :: min_seaice, min_lakeice - integer, dimension(:), intent(in) :: use_flake + integer, dimension(:), intent(in) :: use_lake_model real(kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, slmsk, & sfc_alb_pert, lndp_prt_list, & @@ -153,7 +153,7 @@ subroutine GFS_radiation_surface_run ( & !> - Call module_radiation_surface::setemis(),to set up surface !! emissivity for LW radiation. call setemis (lsm, lsm_noahmp, lsm_ruc, frac_grid, cplice, & - use_flake, lakefrac, xlon, xlat, slmsk, & + use_lake_model, lakefrac, xlon, xlat, slmsk, & ! frac_grid, min_seaice, xlon, xlat, slmsk, & snodl, snodi, sncovr, sncovr_ice, zorl, tsfg, & tsfa, hprime, semis_lnd, semis_ice, semis_wat,& diff --git a/physics/GFS_radiation_surface.meta b/physics/GFS_radiation_surface.meta index e9de370e8..fb19e985e 100644 --- a/physics/GFS_radiation_surface.meta +++ b/physics/GFS_radiation_surface.meta @@ -286,9 +286,9 @@ type = real kind = kind_phys intent = in -[use_flake] - standard_name = flag_for_using_flake - long_name = flag indicating lake points using flake model +[use_lake_model] + standard_name = flag_for_using_lake_model + long_name = flag indicating lake points using a lake model units = flag dimensions = (horizontal_loop_extent) type = integer diff --git a/physics/GFS_surface_composites_inter.F90 b/physics/GFS_surface_composites_inter.F90 index 715b85518..a4004bb82 100644 --- a/physics/GFS_surface_composites_inter.F90 +++ b/physics/GFS_surface_composites_inter.F90 @@ -18,7 +18,7 @@ module GFS_surface_composites_inter !! subroutine GFS_surface_composites_inter_run (im, dry, icy, wet, semis_wat, semis_lnd, semis_ice, & adjsfcdlw, gabsbdlw_lnd, gabsbdlw_ice, gabsbdlw_wat,& - adjsfcusw, adjsfcdsw, adjsfcnsw, use_flake, errmsg, errflg) + adjsfcusw, adjsfcdsw, adjsfcnsw, use_lake_model, errmsg, errflg) implicit none @@ -30,7 +30,7 @@ subroutine GFS_surface_composites_inter_run (im, dry, icy, wet, semis_wat, semis adjsfcdlw, adjsfcdsw, adjsfcnsw real(kind=kind_phys), dimension(:), intent(inout) :: gabsbdlw_lnd, gabsbdlw_ice, gabsbdlw_wat real(kind=kind_phys), dimension(:), intent(out) :: adjsfcusw - integer, dimension(:), intent(in) :: use_flake + integer, dimension(:), intent(in) :: use_lake_model ! CCPP error handling character(len=*), intent(out) :: errmsg @@ -62,7 +62,7 @@ subroutine GFS_surface_composites_inter_run (im, dry, icy, wet, semis_wat, semis ! --- ... define the downward lw flux absorbed by ground do i=1,im - if(use_flake(i)>0.0) wet(i)=.true. + if(use_lake_model(i)>0.0) wet(i)=.true. if (dry(i)) gabsbdlw_lnd(i) = semis_lnd(i) * adjsfcdlw(i) if (icy(i)) gabsbdlw_ice(i) = semis_ice(i) * adjsfcdlw(i) if (wet(i)) gabsbdlw_wat(i) = semis_wat(i) * adjsfcdlw(i) diff --git a/physics/GFS_surface_composites_inter.meta b/physics/GFS_surface_composites_inter.meta index 2ed966d01..36af0ef5a 100644 --- a/physics/GFS_surface_composites_inter.meta +++ b/physics/GFS_surface_composites_inter.meta @@ -116,9 +116,9 @@ type = real kind = kind_phys intent = in -[use_flake] - standard_name = flag_for_using_flake - long_name = flag indicating lake points using flake model +[use_lake_model] + standard_name = flag_for_using_lake_model + long_name = flag indicating lake points using a lake model units = flag dimensions = (horizontal_loop_extent) type = integer diff --git a/physics/GFS_surface_composites_pre.F90 b/physics/GFS_surface_composites_pre.F90 index 04ce7e314..862ba2b6c 100644 --- a/physics/GFS_surface_composites_pre.F90 +++ b/physics/GFS_surface_composites_pre.F90 @@ -24,7 +24,7 @@ module GFS_surface_composites_pre subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, & flag_cice, cplflx, cplice, cplwav2atm, lsm, lsm_ruc, & landfrac, lakefrac, lakedepth, oceanfrac, frland, & - dry, icy, lake, use_flake, wet, hice, cice, zorlo, zorll, zorli, & + dry, icy, lake, use_lake_model, wet, hice, cice, zorlo, zorll, zorli, & snowd, snowd_lnd, snowd_ice, tprcp, tprcp_wat, & tprcp_lnd, tprcp_ice, uustar, uustar_wat, uustar_lnd, uustar_ice, & weasd, weasd_lnd, weasd_ice, ep1d_ice, tsfc, tsfco, tsfcl, tsfc_wat, & @@ -39,7 +39,7 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, logical, intent(in ) :: cplflx, cplice, cplwav2atm, frac_grid logical, dimension(:), intent(inout) :: flag_cice logical, dimension(:), intent(inout) :: dry, icy, lake, wet - integer, dimension(:), intent(inout) :: use_flake + integer, dimension(:), intent(inout) :: use_lake_model real(kind=kind_phys), dimension(:), intent(in ) :: landfrac, lakefrac, lakedepth, oceanfrac real(kind=kind_phys), dimension(:), intent(inout) :: cice, hice real(kind=kind_phys), dimension(:), intent( out) :: frland @@ -73,7 +73,7 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, errflg = 0 do i=1,im - if(use_flake(i) > 0.0) then + if(use_lake_model(i) > 0.0) then wet(i) = .true. endif enddo diff --git a/physics/GFS_surface_composites_pre.meta b/physics/GFS_surface_composites_pre.meta index 1aef9a76b..6a56b35b8 100644 --- a/physics/GFS_surface_composites_pre.meta +++ b/physics/GFS_surface_composites_pre.meta @@ -15,8 +15,8 @@ type = integer intent = in [lkm] - standard_name = control_for_lake_surface_scheme - long_name = flag for lake surface model + standard_name = control_for_lake_model_execution_method + long_name = control for lake model execution: 0=no lake, 1=lake, 2=lake+nsst units = flag dimensions = () type = integer @@ -131,9 +131,9 @@ dimensions = (horizontal_loop_extent) type = logical intent = inout -[use_flake] - standard_name = flag_for_using_flake - long_name = flag indicating lake points using flake model +[use_lake_model] + standard_name = flag_for_using_lake_model + long_name = flag indicating lake points using a lake model units = flag dimensions = (horizontal_loop_extent) type = integer diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90 new file mode 100644 index 000000000..384faf419 --- /dev/null +++ b/physics/clm_lake.f90 @@ -0,0 +1,5441 @@ +!> \file clm_lake.F90 +!! Contains code related to the CLM lake model +!! +!! This lake scheme was taken from module_sf_lake in WRF 4.3.1, and +!! modified for CCPP by Sam Trahan in June 2022. +!! +!! The original documentation said: +!! +!! The lake scheme was retrieved from the Community Land Model version 4.5 +!! (Oleson et al. 2013) with some modifications by Gu et al. (2013). It is a +!! one-dimensional mass and energy balance scheme with 20-25 model layers, +!! including up to 5 snow layers on the lake ice, 10 water layers, and 10 soil +!! layers on the lake bottom. The lake scheme is used with actual lake points and +!! lake depth derived from the WPS, and it also can be used with user defined +!! lake points and lake depth in WRF (lake_min_elev and lakedepth_default). +!! The lake scheme is independent of a land surface scheme and therefore +!! can be used with any land surface scheme embedded in WRF. The lake scheme +!! developments and evaluations were included in Subin et al. (2012) and Gu et al. (2013) +!! +!! Subin et al. 2012: Improved lake model for climate simulations, J. Adv. Model. +!! +!! Earth Syst., 4, M02001. DOI:10.1029/2011MS000072; +!! +!! Gu et al. 2013: Calibration and validation of lake surface temperature simulations +!! +!! with the coupled WRF-Lake model. Climatic Change, 1-13, 10.1007/s10584-013-0978-y. + +MODULE clm_lake + + use machine, only: kind_phys + + implicit none + + logical, parameter :: LAKEDEBUG = .true. ! Enable lots of checks and debug prints + + real(kind_phys), parameter :: zero_h2o = 1e-12 + + ! FIXME: REMOVE OR DOCUMENT PERGRO + logical, parameter :: PERGRO = .false. + + ! FIXME: REMOVE OR DOCUMENT ETALAKE + logical, parameter :: USE_ETALAKE = .false. + real, parameter :: ETALAKE = 1.1925*50**(-0.424) ! Set this to your desired value if USE_ETALAKE=.true. + + real(kind_phys), parameter :: snow_bd = 250._kind_phys !constant snow bulk density (only used in special case here) [kg/m^3] + + integer, parameter :: nlevsoil = 10 ! number of soil layers + integer, parameter :: nlevlake = 10 ! number of lake layers + integer, parameter :: nlevsnow = 5 ! maximum number of snow layers + + integer,parameter :: lbp = 1 ! pft-index bounds + integer,parameter :: ubp = 1 + integer,parameter :: lbc = 1 ! column-index bounds + integer,parameter :: ubc = 1 + integer,parameter :: num_shlakec = 1 ! number of columns in lake filter + integer,parameter :: filter_shlakec(1) = 1 ! lake filter (columns) + integer,parameter :: num_shlakep = 1 ! number of pfts in lake filter + integer,parameter :: filter_shlakep(1) = 1 ! lake filter (pfts) + integer,parameter :: pcolumn(1) = 1 + integer,parameter :: pgridcell(1) = 1 + integer,parameter :: cgridcell(1) = 1 ! gridcell index of column + integer,parameter :: clandunit(1) = 1 ! landunit index of column + + integer,parameter :: begg = 1 + integer,parameter :: endg = 1 + integer,parameter :: begl = 1 + integer,parameter :: endl = 1 + integer,parameter :: begc = 1 + integer,parameter :: endc = 1 + integer,parameter :: begp = 1 + integer,parameter :: endp = 1 + + integer,parameter :: column =1 + logical,parameter :: lakpoi(1) = .true. + + + + + !Initialize physical constants: + ! FIXME: GET THESE FROM THE MODEL + real(kind_phys), parameter :: vkc = 0.4_kind_phys !von Karman constant [-] + real(kind_phys), parameter :: pi = 3.141592653589793_kind_phys ! pi + real(kind_phys), parameter :: grav = 9.80616_kind_phys !gravity constant [m/s2] + real(kind_phys), parameter :: sb = 5.67e-8_kind_phys !stefan-boltzmann constant [W/m2/K4] + real(kind_phys), parameter :: tfrz = 273.16_kind_phys !freezing temperature [K] + real(kind_phys), parameter :: denh2o = 1.000e3_kind_phys !density of liquid water [kg/m3] + real(kind_phys), parameter :: denice = 0.917e3_kind_phys !density of ice [kg/m3] + real(kind_phys), parameter :: cpice = 2.11727e3_kind_phys !Specific heat of ice [J/kg-K] + real(kind_phys), parameter :: cpliq = 4.188e3_kind_phys !Specific heat of water [J/kg-K] + real(kind_phys), parameter :: hfus = 3.337e5_kind_phys !Latent heat of fusion for ice [J/kg] + real(kind_phys), parameter :: hvap = 2.501e6_kind_phys !Latent heat of evap for water [J/kg] + real(kind_phys), parameter :: hsub = 2.501e6_kind_phys+3.337e5_kind_phys !Latent heat of sublimation [J/kg] + real(kind_phys), parameter :: rair = 287.0423_kind_phys !gas constant for dry air [J/kg/K] + real(kind_phys), parameter :: cpair = 1.00464e3_kind_phys !specific heat of dry air [J/kg/K] + real(kind_phys), parameter :: tcrit = 2.5 !critical temperature to determine rain or snow + real(kind_phys), parameter :: tkwat = 0.6 !thermal conductivity of water [W/m/k] + real(kind_phys), parameter :: tkice = 2.290 !thermal conductivity of ice [W/m/k] + real(kind_phys), parameter :: tkairc = 0.023 !thermal conductivity of air [W/m/k] + real(kind_phys), parameter :: bdsno = 250. !bulk density snow (kg/m**3) + + real(kind_phys), public, parameter :: spval = 1.e36 !special value for missing data (ocean) + + real(kind_phys), parameter :: depth_c = 50. ! below the level t_lake3d will be 277.0 !mchen + + + ! These are tunable constants + real(kind_phys), parameter :: wimp = 0.05 !Water impermeable if porosity less than wimp + real(kind_phys), parameter :: ssi = 0.033 !Irreducible water saturation of snow + real(kind_phys), parameter :: cnfac = 0.5 !Crank Nicholson factor between 0 and 1 + + + ! Initialize water type constants + integer,parameter :: istsoil = 1 !soil "water" type + integer, private :: i ! loop index + real(kind_phys) :: dtime ! land model time step (sec) + + real(kind_phys) :: zlak(1:nlevlake) !lake z (layers) + real(kind_phys) :: dzlak(1:nlevlake) !lake dz (thickness) + real(kind_phys) :: zsoi(1:nlevsoil) !soil z (layers) + real(kind_phys) :: dzsoi(1:nlevsoil) !soil dz (thickness) + real(kind_phys) :: zisoi(0:nlevsoil) !soil zi (interfaces) + + + real(kind_phys) :: sand(19) ! percent sand + real(kind_phys) :: clay(19) ! percent clay + + data(sand(i), i=1,19)/92.,80.,66.,20.,5.,43.,60.,& + 10.,32.,51., 6.,22.,39.7,0.,100.,54.,17.,100.,92./ + + data(clay(i), i=1,19)/ 3., 5.,10.,15.,5.,18.,27.,& + 33.,33.,41.,47.,58.,14.7,0., 0., 8.5,54., 0., 3./ + + + ! real(kind_phys) :: dtime ! land model time step (sec) + real(kind_phys) :: watsat(1,nlevsoil) ! volumetric soil water at saturation (porosity) + real(kind_phys) :: tksatu(1,nlevsoil) ! thermal conductivity, saturated soil [W/m-K] + real(kind_phys) :: tkmg(1,nlevsoil) ! thermal conductivity, soil minerals [W/m-K] + real(kind_phys) :: tkdry(1,nlevsoil) ! thermal conductivity, dry soil (W/m/Kelvin) + real(kind_phys) :: csol(1,nlevsoil) ! heat capacity, soil solids (J/m**3/Kelvin) + CONTAINS + + !> \section arg_table_clm_lake_run Argument Table + !! \htmlinclude clm_lake_run.html + !! + SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& + gt0 ,prsi ,con_rd,con_g ,qvcurr ,& !i + gu0 ,gv0 ,dlwsfci ,emiss ,& + rain ,dtp ,dswsfci ,albedo ,& + xlat_d ,z_lake3d ,dz_lake3d ,lakedepth2d ,& + watsat3d ,csol3d ,tkmg3d ,tkdry3d ,& + tksatu3d ,phii ,& + xice, xice_threshold ,im,km ,& + h2osno2d ,snowdp2d ,snl2d ,z3d ,& !h + dz3d ,zi3d ,h2osoi_vol3d ,h2osoi_liq3d ,& + h2osoi_ice3d ,t_grnd2d ,t_soisno3d ,t_lake3d ,& + savedtke12d ,lake_icefrac3d ,use_lake_model ,& + iopt_lake ,iopt_lake_clm ,& + con_cp ,& + hflx ,evap ,grdflx ,tsfc ,& !o + lake_t2m ,lake_q2m ,clm_lake_initialized ,& + isltyp ,snow ,use_lakedepth ,& + restart ,lakedepth_default ,& + sand3d ,clay3d ,& +! Flake output variables + weasd ,snwdph ,hice ,tsurf ,& + t_sfc ,lflx ,ustar ,qsfc ,& + ch ,cm ,chh ,cmm ,& + T_snow ,T_ice ,tsurf_ice ,wind ,& +! + xlon_d ,kdt ,tg3 ,& + me ,master ,errmsg ,errflg ) + + !============================================================================== + ! This subroutine was first edited by Hongping Gu and Jiming Jin for coupling + ! 07/20/2010 + ! Long after, in June 2022, Sam Trahan updated it for CCPP + !============================================================================== + + IMPLICIT NONE + + !in: + + INTEGER, INTENT(IN) :: iopt_lake, iopt_lake_clm, kdt + INTEGER, INTENT(OUT) :: errflg + CHARACTER(*), INTENT(OUT) :: errmsg + INTEGER , INTENT (IN) :: im,km,me,master + LOGICAL, INTENT(IN) :: restart,use_lakedepth,first_time_step + INTEGER, INTENT(INOUT) :: clm_lake_initialized(:) + REAL(KIND_PHYS), INTENT(IN) :: xice_threshold, con_rd,con_g,con_cp,lakedepth_default + REAL(KIND_PHYS), DIMENSION( : ), INTENT(INOUT):: XICE + REAL(KIND_PHYS), DIMENSION( : ), INTENT(IN):: tg3 + REAL(KIND_PHYS), DIMENSION( : ), INTENT(IN) :: SNOW, ZLVL + + INTEGER, DIMENSION(:), INTENT(IN) :: use_lake_model + real(kind_phys), dimension(:), intent(in) :: rho0 ! air density at surface + + REAL(KIND_PHYS), DIMENSION( : ), INTENT(INOUT) :: & + weasd ,snwdph ,hice ,tsurf ,& + t_sfc ,lflx ,ustar ,qsfc ,& + chh ,cmm ,T_snow ,T_ice ,& + tsurf_ice ,wind + LOGICAL, DIMENSION(:), INTENT(IN) :: flag_iter + REAL(KIND_PHYS), DIMENSION( :, : ),INTENT(IN) :: gt0 + REAL(KIND_PHYS), DIMENSION( :, : ),INTENT(IN) :: prsi + REAL(KIND_PHYS), DIMENSION( :, : ),INTENT(IN) :: phii + REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(IN) :: qvcurr + REAL(KIND_PHYS), DIMENSION( :, : ),INTENT(IN) :: gu0 + REAL(KIND_PHYS), DIMENSION( :, : ),INTENT(IN) :: gv0 + REAL(KIND_PHYS), DIMENSION( : ), INTENT(IN) :: xlat_d, xlon_d + REAL(KIND_PHYS), DIMENSION( : ), INTENT(IN) :: ch + REAL(KIND_PHYS), DIMENSION( : ), INTENT(IN) :: cm + REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(IN) :: dlwsfci + REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(IN) :: dswsfci + REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(IN) :: emiss + REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(IN) :: rain + REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(INOUT) :: albedo + INTEGER, DIMENSION( : ), INTENT(IN) :: ISLTYP + REAL(KIND_PHYS), INTENT(IN) :: dtp + REAL(KIND_PHYS), DIMENSION( :,: ),INTENT(INOUT) :: z_lake3d + REAL(KIND_PHYS), DIMENSION( :,: ),INTENT(INOUT) :: dz_lake3d + REAL(KIND_PHYS), DIMENSION( :,: ),INTENT(INOUT) :: watsat3d + REAL(KIND_PHYS), DIMENSION( :,: ),INTENT(INOUT) :: csol3d, sand3d, clay3d + REAL(KIND_PHYS), DIMENSION( :,: ),INTENT(INOUT) :: tkmg3d + REAL(KIND_PHYS), DIMENSION( :,: ),INTENT(INOUT) :: tkdry3d + REAL(KIND_PHYS), DIMENSION( :,: ),INTENT(INOUT) :: tksatu3d + REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(INOUT) :: lakedepth2d + + !feedback to atmosphere: + REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(OUT) :: hflx + REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(OUT) :: evap + REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(OUT) :: GRDFLX + REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(IN ) :: tsfc + REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(OUT) :: lake_t2m + REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(OUT) :: lake_q2m + + !in&out: + + real(kind_phys), dimension(: ) ,intent(inout) :: savedtke12d + real(kind_phys), dimension(: ) ,intent(inout) :: snowdp2d, & + h2osno2d, & + snl2d, & + t_grnd2d + + real(kind_phys), dimension( :,: ) ,INTENT(inout) :: t_lake3d, & + lake_icefrac3d + real(kind_phys), dimension( :,-nlevsnow+1: ) ,INTENT(inout) :: t_soisno3d, & + h2osoi_ice3d, & + h2osoi_liq3d, & + h2osoi_vol3d, & + z3d, & + dz3d + real(kind_phys), dimension( :,-nlevsnow+0: ) ,INTENT(inout) :: zi3d + + + !local variable: + + REAL(kind_phys) :: SFCTMP,PBOT,PSFC,Q2K,LWDN,PRCP,SOLDN,SOLNET + INTEGER :: C,i,j,k + + + !tempory varibles in: + real(kind_phys) :: forc_t(1) ! atmospheric temperature (Kelvin) + real(kind_phys) :: forc_pbot(1) ! atm bottom level pressure (Pa) + real(kind_phys) :: forc_psrf(1) ! atmospheric surface pressure (Pa) + real(kind_phys) :: forc_hgt(1) ! atmospheric reference height (m) + real(kind_phys) :: forc_hgt_q(1) ! observational height of humidity [m] + real(kind_phys) :: forc_hgt_t(1) ! observational height of temperature [m] + real(kind_phys) :: forc_hgt_u(1) ! observational height of wind [m] + real(kind_phys) :: forc_q(1) ! atmospheric specific humidity (kg/kg) + real(kind_phys) :: forc_u(1) ! atmospheric wind speed in east direction (m/s) + real(kind_phys) :: forc_v(1) ! atmospheric wind speed in north direction (m/s) + real(kind_phys) :: forc_lwrad(1) ! downward infrared (longwave) radiation (W/m**2) + real(kind_phys) :: prec(1) ! snow or rain rate [mm/s] + real(kind_phys) :: sabg(1) ! solar radiation absorbed by ground (W/m**2) + real(kind_phys) :: lat(1) ! latitude (radians) + real(kind_phys) :: z_lake(1,nlevlake) ! layer depth for lake (m) + real(kind_phys) :: dz_lake(1,nlevlake) ! layer thickness for lake (m) + + real(kind_phys) :: lakedepth(1) ! column lake depth (m) + logical :: do_capsnow(1) ! true => do snow capping + + !in&out + real(kind_phys) :: h2osoi_vol(1,-nlevsnow+1:nlevsoil) ! volumetric soil water (0<=h2osoi_vol<=watsat)[m3/m3] + real(kind_phys) :: t_grnd(1) ! ground temperature (Kelvin) + real(kind_phys) :: h2osno(1) ! snow water (mm H2O) + real(kind_phys) :: snowdp(1) ! snow height (m) + real(kind_phys) :: z(1,-nlevsnow+1:nlevsoil) ! layer depth for snow & soil (m) + real(kind_phys) :: dz(1,-nlevsnow+1:nlevsoil) ! layer thickness for soil or snow (m) + real(kind_phys) :: t_soisno(1,-nlevsnow+1:nlevsoil) ! soil (or snow) temperature (Kelvin) + real(kind_phys) :: t_lake(1,nlevlake) ! lake temperature (Kelvin) + integer :: snl(1) ! number of snow layers + real(kind_phys) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) ! liquid water (kg/m2) + real(kind_phys) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) ! ice lens (kg/m2) + real(kind_phys) :: savedtke1(1) ! top level eddy conductivity from previous timestep (W/m.K) + real(kind_phys) :: zi(1,-nlevsnow+0:nlevsoil) ! interface level below a "z" level (m) + real(kind_phys) :: lake_icefrac(1,nlevlake) ! mass fraction of lake layer that is frozen + + + !out: + real(kind_phys) :: eflx_gnet(1) !net heat flux into ground (W/m**2) + real(kind_phys) :: eflx_lwrad_net(1) ! net infrared (longwave) rad (W/m**2) [+ = to atm] + real(kind_phys) :: eflx_sh_tot(1) ! total sensible heat flux (W/m**2) [+ to atm] + real(kind_phys) :: eflx_lh_tot(1) ! total latent heat flux (W/m8*2) [+ to atm] + real(kind_phys) :: t_ref2m(1) ! 2 m height surface air temperature (Kelvin) + real(kind_phys) :: q_ref2m(1) ! 2 m height surface specific humidity (kg/kg) + real(kind_phys) :: taux(1) ! wind (shear) stress: e-w (kg/m/s**2) + real(kind_phys) :: tauy(1) ! wind (shear) stress: n-s (kg/m/s**2) + real(kind_phys) :: ram1(1) ! aerodynamical resistance (s/m) + ! for calculation of decay of eddy diffusivity with depth + ! Change the type variable to pass back to WRF. + real(kind_phys) :: z0mg(1) ! roughness length over ground, momentum (m( + real(kind_phys) :: qfx ! mass flux, old WRF qfx(:) variable, (kg/(sm^2)) + + real(kind_phys) :: ustar_out(1) ! friction velocity (temporary) [m/s] + + real(kind_phys) :: discard1, discard2, discard3 ! for unused temporary data + + integer :: lake_points + character*255 :: message + logical, parameter :: feedback_to_atmosphere = .true. ! FIXME: REMOVE + logical :: was_unhappy,is_unhappy + + integer, parameter :: HAVE_NOT_READ_UNHAPPY_POINTS_YET = -1 + integer, parameter :: FAILED_TO_READ_UNHAPPY_POINTS = -2 + + integer, save :: unhappy_count = HAVE_NOT_READ_UNHAPPY_POINTS_YET + real(kind_phys), allocatable, save :: unhappy_lat(:),unhappy_lon(:) + character(*), parameter :: unhappy_txt = "unhappy.txt" + + errmsg = ' ' + errflg = 0 + + if(LAKEDEBUG) then + if(unhappy_count==HAVE_NOT_READ_UNHAPPY_POINTS_YET) then + !$OMP CRITICAL + if(unhappy_count==HAVE_NOT_READ_UNHAPPY_POINTS_YET) then + call read_unhappy_points + if(unhappy_count>0) then +1308 format("Read ",I0,' points from unhappy point list file "',A,'"!') + print 1308,unhappy_count,unhappy_txt +8031 format('Read unhappy xlat_d=',F20.12,' xlon_d=',F20.12) + do i=1,unhappy_count + print 8031,unhappy_lat(i),unhappy_lon(i) + enddo + endif + endif + !$OMP END CRITICAL + endif + if(unhappy_count==FAILED_TO_READ_UNHAPPY_POINTS) then + write(message,'(A)') "ERROR: Could not read unhappy points" + errmsg=message + errflg=1 + return + endif + endif + + ! Still have some points to initialize + call lakeini( ISLTYP, gt0, SNOW, & !i + restart, lakedepth_default, & + lakedepth2d, savedtke12d, snowdp2d, h2osno2d, & !o + snl2d, t_grnd2d, t_lake3d, lake_icefrac3d, & + z_lake3d, dz_lake3d, t_soisno3d, h2osoi_ice3d, & + h2osoi_liq3d, h2osoi_vol3d, z3d, dz3d, & + zi3d, watsat3d, csol3d, tkmg3d, & + xice, xice_threshold, tsfc, & + use_lake_model, use_lakedepth, con_g, con_rd, & + tkdry3d, tksatu3d, im, prsi, & + clm_lake_initialized, & + sand3d, clay3d, tg3, & + km, me, master, errmsg, errflg) + if(errflg/=0) then + return + endif + if(any(clay3d>0 .and. clay3d<1)) then + write(message,*) 'Invalid clay3d. Abort.' + errmsg=trim(message) + errflg=1 + return + endif + if(any(dz_lake3d>0 .and. dz_lake3d<.1)) then + write(message,*) 'Invalid dz_lake3d. Abort.' + errmsg=trim(message) + errflg=1 + return + endif + + lake_points=0 + + dtime = dtp + + lake_top_loop: DO I = 1,im + + if_lake_is_here: if (flag_iter(i) .and. use_lake_model(i)/=0) THEN + + SFCTMP = gt0(i,1) + PBOT = prsi(i,2) + PSFC = prsi(i,1) + Q2K = qvcurr(i) + LWDN = DLWSFCI(I)*EMISS(I) + PRCP = RAIN(i)*1000.0_kind_phys/dtp ! use physics timestep since PRCP comes from non-surface schemes + SOLDN = DSWSFCI(I) ! SOLDN is total incoming solar + SOLNET = SOLDN*(1.-ALBEDO(I)) ! use mid-day albedo to determine net downward solar + ! (no solar zenith angle correction) + + lake_points = lake_points+1 + + do c = 1,column + + forc_t(c) = SFCTMP ! [K] + forc_pbot(c) = PBOT ! [Pa] + forc_psrf(c) = PSFC ! [Pa] + forc_hgt(c) = zlvl(i) ! [m] + forc_hgt_q(c) = zlvl(i) ! [m] + forc_hgt_t(c) = zlvl(i) ! [m] + forc_hgt_u(c) = zlvl(i) ! [m] + forc_q(c) = Q2K ! [kg/kg] + forc_u(c) = gu0(I,1) ! [m/s] + forc_v(c) = gv0(I,1) ! [m/s] + forc_lwrad(c) = LWDN ! [W/m/m] + prec(c) = PRCP ! [mm/s] + sabg(c) = SOLNET + lat(c) = XLAT_D(I)*pi/180 ! [radian] + do_capsnow(c) = .false. + + lakedepth(c) = lakedepth2d(i) + savedtke1(c) = savedtke12d(i) + snowdp(c) = snowdp2d(i) + h2osno(c) = h2osno2d(i) + snl(c) = snl2d(i) + t_grnd(c) = t_grnd2d(i) + do k = 1,nlevlake + t_lake(c,k) = t_lake3d(i,k) + lake_icefrac(c,k) = lake_icefrac3d(i,k) + z_lake(c,k) = z_lake3d(i,k) + dz_lake(c,k) = dz_lake3d(i,k) + enddo + do k = -nlevsnow+1,nlevsoil + t_soisno(c,k) = t_soisno3d(i,k) + h2osoi_ice(c,k) = h2osoi_ice3d(i,k) + h2osoi_liq(c,k) = h2osoi_liq3d(i,k) + h2osoi_vol(c,k) = h2osoi_vol3d(i,k) + z(c,k) = z3d(i,k) + dz(c,k) = dz3d(i,k) + enddo + do k = -nlevsnow+0,nlevsoil + zi(c,k) = zi3d(i,k) + enddo + do k = 1,nlevsoil + watsat(c,k) = watsat3d(i,k) + csol(c,k) = csol3d(i,k) + tkmg(c,k) = tkmg3d(i,k) + tkdry(c,k) = tkdry3d(i,k) + tksatu(c,k) = tksatu3d(i,k) + enddo + + enddo + if(LAKEDEBUG.and.kdt<3) then + was_unhappy = point_is_unhappy(xlat_d(i),xlon_d(i)) + if(was_unhappy) then + print *,'Unhappy point before LakeMain t_lake = ',t_lake(1,:) + print *,'Unhappy point before LakeMain t_soilsno = ',t_soisno(1,:) + endif + endif + is_unhappy=.false. + CALL LakeMain(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, & !I + forc_hgt_t,forc_hgt_u,forc_q, forc_u, & + forc_v,forc_lwrad,prec, sabg,lat, & + z_lake,dz_lake,lakedepth,do_capsnow, & + h2osno,snowdp,snl,z,dz,zi, & !H + h2osoi_vol,h2osoi_liq,h2osoi_ice, & + t_grnd,t_soisno,t_lake, & + savedtke1,lake_icefrac, & + eflx_lwrad_net,eflx_gnet, & !O + eflx_sh_tot,eflx_lh_tot, & + t_ref2m,q_ref2m, & + taux,tauy,ram1,z0mg,ustar_out,errmsg,errflg, & + xlat_d(i),xlon_d(i),is_unhappy) + if(LAKEDEBUG) then + if((was_unhappy .or. is_unhappy) .and. kdt<3) then + print *,'Unhappy point after LakeMain t_lake = ',t_lake(1,:) + print *,'Unhappy point after LakeMain t_soilsno = ',t_soisno(1,:) + endif + if(is_unhappy .and. kdt<3) then +3081 format('UNHAPPY AT: lat=',F20.12,' lon=',F20.12) + print 3081,xlat_d(i),xlon_d(i) + endif + if(errflg/=0) then + errflg=0 ! Bad. Remove this + ! return ! should do this instead + endif + endif + ! Renew Lake State Variables:(14) + do c = 1,column + + savedtke12d(i) = savedtke1(c) + snowdp2d(i) = snowdp(c) + h2osno2d(i) = h2osno(c) + snl2d(i) = snl(c) + t_grnd2d(i) = t_grnd(c) + do k = 1,nlevlake + t_lake3d(i,k) = t_lake(c,k) + lake_icefrac3d(i,k) = lake_icefrac(c,k) + enddo + do k = -nlevsnow+1,nlevsoil + z3d(i,k) = z(c,k) + dz3d(i,k) = dz(c,k) + t_soisno3d(i,k) = t_soisno(c,k) + h2osoi_liq3d(i,k) = h2osoi_liq(c,k) + h2osoi_ice3d(i,k) = h2osoi_ice(c,k) + h2osoi_vol3d(i,k) = h2osoi_vol(c,k) + enddo + do k = -nlevsnow+0,nlevsoil + zi3d(i,k) = zi(c,k) + enddo + + + enddo + + if(feedback_to_atmosphere) then + c = 1 + + ! No equivalent in CCPP: + ! LH(I) = eflx_lh_tot(c)/rho1(i) ![kg*m/(kg*s)] + + + if( t_grnd(c) >= tfrz ) then + qfx = eflx_lh_tot(c)/hvap + else + qfx = eflx_lh_tot(c)/hsub ! heat flux (W/m^2)=>mass flux(kg/(sm^2)) + endif + evap(i) = qfx/rho0(i) ! kinematic_surface_upward_latent_heat_flux_over_water + HFLX(i)=eflx_sh_tot(c)/(rho0(i)*con_cp) ! kinematic_surface_upward_sensible_heat_flux_over_water + GRDFLX(I) = eflx_gnet(c) ![W/m/m] upward_heat_flux_in_soil_over_water + lflx(i) = eflx_lh_tot(c) ![W/m/m] surface_upward_potential_latent_heat_flux_over_water + tsurf(I) = t_grnd(c) ![K] surface skin temperature after iteration over water + t_sfc(I) = t_grnd(c) ![K] surface skin temperature over water + lake_t2m(I) = t_ref2m(c) + !TH2(I) = T2(I)*(1.E5/PSFC)**RCP ! potential temperature (CCPP doesn't want this) + lake_q2m(I) = q_ref2m(c) ! [frac] specific humidity + albedo(i) = ( 0.6 * lake_icefrac3d(i,1) ) + ( (1.0-lake_icefrac3d(i,1)) * 0.08) + xice(i) = lake_icefrac3d(i,1) + + if(xice(i)>0) then + weasd(i) = h2osno(c) ! water_equivalent_accumulated_snow_depth_over_ice + snwdph(i) = h2osno(c)/snow_bd*1000 ! surface_snow_thickness_water_equivalent_over_ice + T_ice(i) = t_grnd(c) ! surface_skin_temperature_over_ice + tsurf_ice(i) = t_grnd(c) ! surface_skin_temperature_after_iteration_over_ice + + ! Assume that, if a layer has ice, the entire layer thickness is ice. + hice(I) = 0 + do k=1,nlevlake + if(lake_icefrac3d(i,k)>0) then + hice(i) = hice(i) + dz_lake3d(i,k) + endif + end do + else + weasd(i) = 0 + snwdph(i) = 0 + T_ice(i) = tsurf(i) + tsurf_ice(i) = T_ice(i) + hice(i) = 0 + endif + + if(snl2d(i)>0) then + T_snow(i) = t_grnd(c) ! temperature_of_snow_on_lake + endif + + ustar = ustar_out(1) ! surface_friction_velocity_over_water + + ! Calculate qsfc from t_grnd: (surface_specific_humidity_over_water) + call QSat(t_grnd(c),psfc,discard1,discard2,qsfc(i),discard3) + + ! From flake driver: + chh(i)=ch(i)*wind(i)*1.225 ! surface_drag_mass_flux_for_heat_and_moisture_in_air_over_water + cmm(i)=cm(i)*wind(i) ! surface_drag_wind_speed_for_momentum_in_air_over_water + + endif + + endif if_lake_is_here + ENDDO lake_top_loop + + if(LAKEDEBUG .and. lake_points>0) then +3082 format('lake points processed in timestep ',I0,' by rank ',I0,' = ',I0) + print 3082,kdt,me,lake_points + endif + + CONTAINS + + logical function point_is_unhappy(xlat_d,xlon_d) + implicit none + integer :: j + real, intent(in) :: xlat_d,xlon_d + + do j=1,unhappy_count + if(abs(xlat_d-unhappy_lat(j))<.015 .and. abs(xlon_d-unhappy_lon(j))<.015) then + point_is_unhappy=.true. +1444 format('Now processing unhappy point ',I0,' location xlat_d=',F20.12,' xlon_d=',F20.12,' close to xlat_d=',F20.12,' xlon_d=',F20.12) + print 1444,j,xlat_d,xlon_d,unhappy_lat(j),unhappy_lon(j) + return + endif + enddo + + ! No points matched + point_is_unhappy=.false. + end function point_is_unhappy + + subroutine read_unhappy_points + use ISO_FORTRAN_ENV, only: iostat_end, iostat_eor + implicit none + integer :: i,unhappy_iostat,unhappy_unit,expect_count,actual_count + + ! Number of points actually read in is 0 since we haven't read yet. + actual_count=0 + + ! Open the unhappy points file + open(file=unhappy_txt,form='formatted',newunit=unhappy_unit,action='read',iostat=unhappy_iostat,status='old') + if(unhappy_iostat/=0) then + write(message,'(A,A,A)') 'Could not open "',unhappy_txt,'"!!' + goto 1001 ! Error handler without closing file + endif + + ! Determine how many points to read in. + expect_count=-1 + read(unit=unhappy_unit,fmt='(I12)',iostat=unhappy_iostat) expect_count + if(unhappy_iostat/=0 .or. expect_count<0) then + write(message,'(A,A,A)') 'Could not read unhappy point count from "',unhappy_txt,'"!!' + goto 1000 ! Error handler that also closes the file + endif + + ! Allocate enough data for the number of points we expect to read in + allocate(unhappy_lat(expect_count)) + allocate(unhappy_lon(expect_count)) + + unhappy_lat = -999 + unhappy_lon = -999 + + ! Read data, and determine the number of points actually in the file + do i=1,expect_count + read(unit=unhappy_unit,fmt='(F20.14,F20.14)',iostat=unhappy_iostat) & + unhappy_lat(actual_count+1),unhappy_lon(actual_count+1) + if(unhappy_iostat==iostat_end) then + exit + else if(unhappy_iostat==iostat_eor) then + continue ! Probably a blank line + else if(unhappy_iostat/=0) then + write(message,'(A,A,A)') 'Error reading from "',unhappy_txt,'"!!' + goto 1000 ! Error handler that also closes the file + else + actual_count=actual_count+1 + endif + enddo + + ! Indicate successful read by setting the unhappy_count to the number of points actually read in. + unhappy_count=actual_count + close(unhappy_iostat) + + return ! Success! + +1000 continue ! Error handler, after file is opened + close(unhappy_iostat) + +1001 continue ! Error handler, whether file was opened or not + write(0,'(A)') message + errmsg=message + errflg=1 + if(allocated(unhappy_lat)) deallocate(unhappy_lat) + if(allocated(unhappy_lon)) deallocate(unhappy_lon) + unhappy_count=FAILED_TO_READ_UNHAPPY_POINTS + + end subroutine read_unhappy_points + + END SUBROUTINE clm_lake_run + + + SUBROUTINE LakeMain(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, & !I + forc_hgt_t,forc_hgt_u,forc_q, forc_u, & + forc_v,forc_lwrad,prec, sabg,lat, & + z_lake,dz_lake,lakedepth,do_capsnow, & + h2osno,snowdp,snl,z,dz,zi, & !H + h2osoi_vol,h2osoi_liq,h2osoi_ice, & + t_grnd,t_soisno,t_lake, & + savedtke1,lake_icefrac, & + eflx_lwrad_net,eflx_gnet, & !O + eflx_sh_tot,eflx_lh_tot, & + t_ref2m,q_ref2m, & + taux,tauy,ram1,z0mg,ustar_out,errmsg,errflg, xlat_d,xlon_d,unhappy) + implicit none + !in: + + logical :: unhappy + integer, intent(inout) :: errflg + character(*), intent(inout) :: errmsg + real(kind_phys),intent(in) :: xlat_d, xlon_d ! grid location for debugging + real(kind_phys),intent(in) :: forc_t(1) ! atmospheric temperature (Kelvin) + real(kind_phys),intent(in) :: forc_pbot(1) ! atm bottom level pressure (Pa) + real(kind_phys),intent(in) :: forc_psrf(1) ! atmospheric surface pressure (Pa) + real(kind_phys),intent(in) :: forc_hgt(1) ! atmospheric reference height (m) + real(kind_phys),intent(in) :: forc_hgt_q(1) ! observational height of humidity [m] + real(kind_phys),intent(in) :: forc_hgt_t(1) ! observational height of temperature [m] + real(kind_phys),intent(in) :: forc_hgt_u(1) ! observational height of wind [m] + real(kind_phys),intent(in) :: forc_q(1) ! atmospheric specific humidity (kg/kg) + real(kind_phys),intent(in) :: forc_u(1) ! atmospheric wind speed in east direction (m/s) + real(kind_phys),intent(in) :: forc_v(1) ! atmospheric wind speed in north direction (m/s) + ! real(kind_phys),intent(in) :: forc_rho(1) ! density (kg/m**3) + real(kind_phys),intent(in) :: forc_lwrad(1) ! downward infrared (longwave) radiation (W/m**2) + real(kind_phys),intent(in) :: prec(1) ! snow or rain rate [mm/s] + real(kind_phys),intent(in) :: sabg(1) ! solar radiation absorbed by ground (W/m**2) + real(kind_phys),intent(in) :: lat(1) ! latitude (radians) + real(kind_phys),intent(in) :: z_lake(1,nlevlake) ! layer depth for lake (m) + real(kind_phys),intent(in) :: dz_lake(1,nlevlake) ! layer thickness for lake (m) + real(kind_phys),intent(out) :: ustar_out(1) ! friction velocity [m/s] + real(kind_phys), intent(in) :: lakedepth(1) ! column lake depth (m) + !!!!!!!!!!!!!!!!tep(in),hydro(in) + ! real(kind_phys), intent(in) :: watsat(1,1:nlevsoil) ! volumetric soil water at saturation (porosity) + !!!!!!!!!!!!!!!!hydro + logical , intent(in) :: do_capsnow(1) ! true => do snow capping + + + + !in&out + real(kind_phys),intent(inout) :: h2osoi_vol(1,-nlevsnow+1:nlevsoil) ! volumetric soil water (0<=h2osoi_vol<=watsat)[m3/m3] + real(kind_phys),intent(inout) :: t_grnd(1) ! ground temperature (Kelvin) + real(kind_phys),intent(inout) :: h2osno(1) ! snow water (mm H2O) + real(kind_phys),intent(inout) :: snowdp(1) ! snow height (m) + real(kind_phys),intent(inout) :: z(1,-nlevsnow+1:nlevsoil) ! layer depth for snow & soil (m) + real(kind_phys),intent(inout) :: dz(1,-nlevsnow+1:nlevsoil) ! layer thickness for soil or snow (m) + real(kind_phys),intent(inout) :: t_soisno(1,-nlevsnow+1:nlevsoil) ! soil (or snow) temperature (Kelvin) + real(kind_phys),intent(inout) :: t_lake(1,nlevlake) ! lake temperature (Kelvin) + integer ,intent(inout) :: snl(1) ! number of snow layers + real(kind_phys),intent(inout) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) ! liquid water (kg/m2) + real(kind_phys),intent(inout) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) ! ice lens (kg/m2) + real(kind_phys),intent(inout) :: savedtke1(1) ! top level eddy conductivity from previous timestep (W/m.K) + real(kind_phys),intent(inout) :: zi(1,-nlevsnow+0:nlevsoil) ! interface level below a "z" level (m) + real(kind_phys),intent(inout) :: lake_icefrac(1,nlevlake) ! mass fraction of lake layer that is frozen + + + !out: + real(kind_phys),intent(out) :: eflx_gnet(1) !net heat flux into ground (W/m**2) + real(kind_phys),intent(out) :: eflx_lwrad_net(1) ! net infrared (longwave) rad (W/m**2) [+ = to atm] + real(kind_phys),intent(out) :: eflx_sh_tot(1) ! total sensible heat flux (W/m**2) [+ to atm] + real(kind_phys),intent(out) :: eflx_lh_tot(1) ! total latent heat flux (W/m8*2) [+ to atm] + real(kind_phys),intent(out) :: t_ref2m(1) ! 2 m height surface air temperature (Kelvin) + real(kind_phys),intent(out) :: q_ref2m(1) ! 2 m height surface specific humidity (kg/kg) + real(kind_phys),intent(out) :: taux(1) ! wind (shear) stress: e-w (kg/m/s**2) + real(kind_phys),intent(out) :: tauy(1) ! wind (shear) stress: n-s (kg/m/s**2) + real(kind_phys),intent(out) :: ram1(1) ! aerodynamical resistance (s/m) + ! for calculation of decay of eddy diffusivity with depth + ! Change the type variable to pass back to WRF. + real(kind_phys),intent(out) :: z0mg(1) ! roughness length over ground, momentum (m( + + + !local output + + real(kind_phys) :: begwb(1) ! water mass begining of the time step + real(kind_phys) :: t_veg(1) ! vegetation temperature (Kelvin) + real(kind_phys) :: eflx_soil_grnd(1) ! soil heat flux (W/m**2) [+ = into soil] + real(kind_phys) :: eflx_lh_grnd(1) ! ground evaporation heat flux (W/m**2) [+ to atm] + real(kind_phys) :: eflx_sh_grnd(1) ! sensible heat flux from ground (W/m**2) [+ to atm] + real(kind_phys) :: eflx_lwrad_out(1) ! emitted infrared (longwave) radiation (W/m**2) + real(kind_phys) :: qflx_evap_tot(1) ! qflx_evap_soi + qflx_evap_veg + qflx_tran_veg + real(kind_phys) :: qflx_evap_soi(1) ! soil evaporation (mm H2O/s) (+ = to atm) + real(kind_phys) :: qflx_prec_grnd(1) ! water onto ground including canopy runoff [kg/(m2 s)] + real(kind_phys) :: forc_snow(1) ! snow rate [mm/s] + real(kind_phys) :: forc_rain(1) ! rain rate [mm/s] + real(kind_phys) :: ws(1) ! surface friction velocity (m/s) + real(kind_phys) :: ks(1) ! coefficient passed to ShalLakeTemperature + real(kind_phys) :: qflx_snomelt(1) !snow melt (mm H2O /s) tem(out),snowwater(in) + integer :: imelt(1,-nlevsnow+1:nlevsoil) !flag for melting (=1), freezing (=2), Not=0 (new) + real(kind_phys) :: endwb(1) ! water mass end of the time step + real(kind_phys) :: snowage(1) ! non dimensional snow age [-] + real(kind_phys) :: snowice(1) ! average snow ice lens + real(kind_phys) :: snowliq(1) ! average snow liquid water + real(kind_phys) :: t_snow(1) ! vertically averaged snow temperature + real(kind_phys) :: qflx_drain(1) ! sub-surface runoff (mm H2O /s) + real(kind_phys) :: qflx_surf(1) ! surface runoff (mm H2O /s) + real(kind_phys) :: qflx_infl(1) ! infiltration (mm H2O /s) + real(kind_phys) :: qflx_qrgwl(1) ! qflx_surf at glaciers, wetlands, lakes + real(kind_phys) :: qcharge(1) ! aquifer recharge rate (mm/s) + real(kind_phys) :: qflx_snowcap(1) ! excess precipitation due to snow capping (mm H2O /s) [+] + real(kind_phys) :: qflx_snowcap_col(1) ! excess precipitation due to snow capping (mm H2O /s) [+] + real(kind_phys) :: qflx_snow_grnd_pft(1) ! snow on ground after interception (mm H2O/s) [+] + real(kind_phys) :: qflx_snow_grnd_col(1) ! snow on ground after interception (mm H2O/s) [+] + real(kind_phys) :: qflx_rain_grnd(1) ! rain on ground after interception (mm H2O/s) [+] + real(kind_phys) :: frac_iceold(1,-nlevsnow+1:nlevsoil) ! fraction of ice relative to the tot water + real(kind_phys) :: qflx_evap_tot_col(1) !pft quantity averaged to the column (assuming one pft) + real(kind_phys) :: soilalpha(1) !factor that reduces ground saturated specific humidity (-) + real(kind_phys) :: zwt(1) !water table depth + real(kind_phys) :: fcov(1) !fractional area with water table at surface + real(kind_phys) :: rootr_column(1,1:nlevsoil) !effective fraction of roots in each soil layer + real(kind_phys) :: qflx_evap_grnd(1) ! ground surface evaporation rate (mm H2O/s) [+] + real(kind_phys) :: qflx_sub_snow(1) ! sublimation rate from snow pack (mm H2O /s) [+] + real(kind_phys) :: qflx_dew_snow(1) ! surface dew added to snow pack (mm H2O /s) [+] + real(kind_phys) :: qflx_dew_grnd(1) ! ground surface dew formation (mm H2O /s) [+] + real(kind_phys) :: qflx_rain_grnd_col(1) !rain on ground after interception (mm H2O/s) [+] + begwb = 0 + + ! lat = lat*pi/180 ! [radian] + + if (prec(1)> 0.) then + if ( forc_t(1) > (tfrz + tcrit)) then + forc_rain(1) = prec(1) + forc_snow(1) = 0. + ! flfall(1) = 1. + else + forc_rain(1) = 0. + forc_snow(1) = prec(1) + + ! if ( forc_t(1) <= tfrz) then + ! flfall(1) = 0. + ! else if ( forc_t(1) <= tfrz+2.) then + ! flfall(1) = -54.632 + 0.2 * forc_t(1) + ! else + ! flfall(1) = 0.4 + endif + else + forc_rain(1) = 0. + forc_snow(1) = 0. + ! flfall(1) = 1. + endif + + CALL ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, & !i + forc_hgt_t,forc_hgt_u,forc_q, & + forc_u,forc_v,forc_lwrad,forc_snow, & + forc_rain,t_grnd,h2osno,snowdp,sabg,lat, & + dz,dz_lake,t_soisno,t_lake,snl,h2osoi_liq, & + h2osoi_ice,savedtke1, & + qflx_prec_grnd,qflx_evap_soi,qflx_evap_tot, & !o + eflx_sh_grnd,eflx_lwrad_out,eflx_lwrad_net, & + eflx_soil_grnd,eflx_sh_tot,eflx_lh_tot, & + eflx_lh_grnd,t_veg,t_ref2m,q_ref2m,taux,tauy, & + ram1,ws,ks,eflx_gnet,z0mg,ustar_out,errmsg,errflg,xlat_d,xlon_d,unhappy) + if(errflg/=0) then + !return ! State is invalid now, so pass error to caller. + endif + + CALL ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & !i + z_lake,ws,ks,snl,eflx_gnet,lakedepth, & + lake_icefrac,snowdp, & !i&o + eflx_sh_grnd,eflx_sh_tot,eflx_soil_grnd, & !o + t_lake,t_soisno,h2osoi_liq, & + h2osoi_ice,savedtke1, & + frac_iceold,qflx_snomelt,imelt,errmsg,errflg) + if(errflg/=0) then + !return ! State is invalid now, so pass error to caller. + endif + + CALL ShalLakeHydrology(dz_lake,forc_rain,forc_snow, & !i + begwb,qflx_evap_tot,forc_t,do_capsnow, & + t_grnd,qflx_evap_soi, & + qflx_snomelt,imelt,frac_iceold, & !i add by guhp + z,dz,zi,snl,h2osno,snowdp,lake_icefrac,t_lake, & !i&o + endwb,snowage,snowice,snowliq,t_snow, & !o + t_soisno,h2osoi_ice,h2osoi_liq,h2osoi_vol, & + qflx_drain,qflx_surf,qflx_infl,qflx_qrgwl, & + qcharge,qflx_prec_grnd,qflx_snowcap, & + qflx_snowcap_col,qflx_snow_grnd_pft, & + qflx_snow_grnd_col,qflx_rain_grnd, & + qflx_evap_tot_col,soilalpha,zwt,fcov, & + rootr_column,qflx_evap_grnd,qflx_sub_snow, & + qflx_dew_snow,qflx_dew_grnd,qflx_rain_grnd_col, & + errmsg,errflg) + if(errflg/=0) then + !return ! State is invalid now, so pass error to caller. + endif + + !================================================================================== + ! !DESCRIPTION: + ! Calculation of Shallow Lake Hydrology. Full hydrology of snow layers is + ! done. However, there is no infiltration, and the water budget is balanced with + + END SUBROUTINE LakeMain + + +SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, & !i + forc_hgt_t,forc_hgt_u,forc_q, & + forc_u,forc_v,forc_lwrad,forc_snow, & + forc_rain,t_grnd,h2osno,snowdp,sabg,lat, & + dz,dz_lake,t_soisno,t_lake,snl,h2osoi_liq, & + h2osoi_ice,savedtke1, & + qflx_prec_grnd,qflx_evap_soi,qflx_evap_tot, & !o + eflx_sh_grnd,eflx_lwrad_out,eflx_lwrad_net, & + eflx_soil_grnd,eflx_sh_tot,eflx_lh_tot, & + eflx_lh_grnd,t_veg,t_ref2m,q_ref2m,taux,tauy, & + ram1,ws,ks,eflx_gnet,z0mg,ustar_out,errmsg,errflg,xlat_d,xlon_d,unhappy) + !============================================================================== + ! DESCRIPTION: + ! Calculates lake temperatures and surface fluxes for shallow lakes. + ! + ! Shallow lakes have variable depth, possible snow layers above, freezing & thawing of lake water, + ! and soil layers with active temperature and gas diffusion below. + ! + ! WARNING: This subroutine assumes lake columns have one and only one pft. + ! + ! REVISION HISTORY: + ! Created by Zack Subin, 2009 + ! Reedited by Hongping Gu, 2010 + ! Updated for CCPP by Sam Trahan, 2022 + !============================================================================== + + ! implicit none + + implicit none + + !in: + + integer, intent(inout) :: errflg + logical :: unhappy + character(len=*), intent(inout) :: errmsg + real(kind_phys),intent(in) :: xlat_d,xlon_d + real(kind_phys),intent(in) :: forc_t(1) ! atmospheric temperature (Kelvin) + real(kind_phys),intent(in) :: forc_pbot(1) ! atmospheric pressure (Pa) + real(kind_phys),intent(in) :: forc_psrf(1) ! atmospheric surface pressure (Pa) + real(kind_phys),intent(in) :: forc_hgt(1) ! atmospheric reference height (m) + real(kind_phys),intent(in) :: forc_hgt_q(1) ! observational height of humidity [m] + real(kind_phys),intent(in) :: forc_hgt_t(1) ! observational height of temperature [m] + real(kind_phys),intent(in) :: forc_hgt_u(1) ! observational height of wind [m] + real(kind_phys),intent(in) :: forc_q(1) ! atmospheric specific humidity (kg/kg) + real(kind_phys),intent(in) :: forc_u(1) ! atmospheric wind speed in east direction (m/s) + real(kind_phys),intent(in) :: forc_v(1) ! atmospheric wind speed in north direction (m/s) + real(kind_phys),intent(in) :: forc_lwrad(1) ! downward infrared (longwave) radiation (W/m**2) + ! real(kind_phys),intent(in) :: forc_rho(1) ! density (kg/m**3) + real(kind_phys),intent(in) :: forc_snow(1) ! snow rate [mm/s] + real(kind_phys),intent(in) :: forc_rain(1) ! rain rate [mm/s] + real(kind_phys),intent(in) :: h2osno(1) ! snow water (mm H2O) + real(kind_phys),intent(in) :: snowdp(1) ! snow height (m) + real(kind_phys),intent(in) :: sabg(1) ! solar radiation absorbed by ground (W/m**2) + real(kind_phys),intent(in) :: lat(1) ! latitude (radians) + real(kind_phys),intent(in) :: dz(1,-nlevsnow+1:nlevsoil) ! layer thickness for soil or snow (m) + real(kind_phys),intent(in) :: dz_lake(1,nlevlake) ! layer thickness for lake (m) + real(kind_phys),intent(in) :: t_soisno(1,-nlevsnow+1:nlevsoil) ! soil (or snow) temperature (Kelvin) + real(kind_phys),intent(in) :: t_lake(1,nlevlake) ! lake temperature (Kelvin) + integer ,intent(in) :: snl(1) ! number of snow layers + real(kind_phys),intent(in) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) ! liquid water (kg/m2) + real(kind_phys),intent(in) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) ! ice lens (kg/m2) + real(kind_phys),intent(in) :: savedtke1(1) ! top level eddy conductivity from previous timestep (W/m.K) + + !inout: + real(kind_phys),intent(inout) :: t_grnd(1) ! ground temperature (Kelvin) + !out: + real(kind_phys),intent(out):: ustar_out(1) ! friction velocity [m/s] + real(kind_phys),intent(out):: qflx_prec_grnd(1) ! water onto ground including canopy runoff [kg/(m2 s)] + real(kind_phys),intent(out):: qflx_evap_soi(1) ! soil evaporation (mm H2O/s) (+ = to atm) + real(kind_phys),intent(out):: qflx_evap_tot(1) ! qflx_evap_soi + qflx_evap_veg + qflx_tran_veg + real(kind_phys),intent(out):: eflx_sh_grnd(1) ! sensible heat flux from ground (W/m**2) [+ to atm] + real(kind_phys),intent(out):: eflx_lwrad_out(1) ! emitted infrared (longwave) radiation (W/m**2) + real(kind_phys),intent(out):: eflx_lwrad_net(1) ! net infrared (longwave) rad (W/m**2) [+ = to atm] + real(kind_phys),intent(out):: eflx_soil_grnd(1) ! soil heat flux (W/m**2) [+ = into soil] + real(kind_phys),intent(out):: eflx_sh_tot(1) ! total sensible heat flux (W/m**2) [+ to atm] + real(kind_phys),intent(out):: eflx_lh_tot(1) ! total latent heat flux (W/m8*2) [+ to atm] + real(kind_phys),intent(out):: eflx_lh_grnd(1) ! ground evaporation heat flux (W/m**2) [+ to atm] + real(kind_phys),intent(out):: t_veg(1) ! vegetation temperature (Kelvin) + real(kind_phys),intent(out):: t_ref2m(1) ! 2 m height surface air temperature (Kelvin) + real(kind_phys),intent(out):: q_ref2m(1) ! 2 m height surface specific humidity (kg/kg) + real(kind_phys),intent(out):: taux(1) ! wind (shear) stress: e-w (kg/m/s**2) + real(kind_phys),intent(out):: tauy(1) ! wind (shear) stress: n-s (kg/m/s**2) + real(kind_phys),intent(out):: ram1(1) ! aerodynamical resistance (s/m) + real(kind_phys),intent(out):: ws(1) ! surface friction velocity (m/s) + real(kind_phys),intent(out):: ks(1) ! coefficient passed to ShalLakeTemperature + ! for calculation of decay of eddy diffusivity with depth + real(kind_phys),intent(out):: eflx_gnet(1) !net heat flux into ground (W/m**2) + ! Change the type variable to pass back to WRF. + real(kind_phys),intent(out):: z0mg(1) ! roughness length over ground, momentum (m( + + + + !OTHER LOCAL VARIABLES: + + integer , parameter :: islak = 2 ! index of lake, 1 = deep lake, 2 = shallow lake + integer , parameter :: niters = 3 ! maximum number of iterations for surface temperature + real(kind_phys), parameter :: beta1 = 1._kind_phys ! coefficient of convective velocity (in computing W_*) [-] + real(kind_phys), parameter :: emg = 0.97_kind_phys ! ground emissivity (0.97 for snow) + real(kind_phys), parameter :: zii = 1000._kind_phys! convective boundary height [m] + real(kind_phys), parameter :: tdmax = 277._kind_phys ! temperature of maximum water density + real(kind_phys) :: forc_th(1) ! atmospheric potential temperature (Kelvin) + real(kind_phys) :: forc_vp(1) !atmospheric vapor pressure (Pa) + real(kind_phys) :: forc_rho(1) ! density (kg/m**3) + integer :: i,fc,fp,g,c,p ! do loop or array index + integer :: fncopy ! number of values in pft filter copy + integer :: fnold ! previous number of pft filter values + integer :: fpcopy(num_shlakep) ! pft filter copy for iteration loop + integer :: iter ! iteration index + integer :: nmozsgn(lbp:ubp) ! number of times moz changes sign + integer :: jtop(lbc:ubc) ! top level for each column (no longer all 1) + ! real(kind_phys) :: dtime ! land model time step (sec) + real(kind_phys) :: ax ! used in iteration loop for calculating t_grnd (numerator of NR solution) + real(kind_phys) :: bx ! used in iteration loop for calculating t_grnd (denomin. of NR solution) + real(kind_phys) :: degdT ! d(eg)/dT + real(kind_phys) :: dqh(lbp:ubp) ! diff of humidity between ref. height and surface + real(kind_phys) :: dth(lbp:ubp) ! diff of virtual temp. between ref. height and surface + real(kind_phys) :: dthv ! diff of vir. poten. temp. between ref. height and surface + real(kind_phys) :: dzsur(lbc:ubc) ! 1/2 the top layer thickness (m) + real(kind_phys) :: eg ! water vapor pressure at temperature T [pa] + real(kind_phys) :: htvp(lbc:ubc) ! latent heat of vapor of water (or sublimation) [j/kg] + real(kind_phys) :: obu(lbp:ubp) ! monin-obukhov length (m) + real(kind_phys) :: obuold(lbp:ubp) ! monin-obukhov length of previous iteration + real(kind_phys) :: qsatg(lbc:ubc) ! saturated humidity [kg/kg] + real(kind_phys) :: qsatgdT(lbc:ubc) ! d(qsatg)/dT + real(kind_phys) :: qstar ! moisture scaling parameter + real(kind_phys) :: ram(lbp:ubp) ! aerodynamical resistance [s/m] + real(kind_phys) :: rah(lbp:ubp) ! thermal resistance [s/m] + real(kind_phys) :: raw(lbp:ubp) ! moisture resistance [s/m] + real(kind_phys) :: stftg3(lbp:ubp) ! derivative of fluxes w.r.t ground temperature + real(kind_phys) :: temp1(lbp:ubp) ! relation for potential temperature profile + real(kind_phys) :: temp12m(lbp:ubp) ! relation for potential temperature profile applied at 2-m + real(kind_phys) :: temp2(lbp:ubp) ! relation for specific humidity profile + real(kind_phys) :: temp22m(lbp:ubp) ! relation for specific humidity profile applied at 2-m + real(kind_phys) :: tgbef(lbc:ubc) ! initial ground temperature + real(kind_phys) :: thm(lbc:ubc) ! intermediate variable (forc_t+0.0098*forc_hgt_t) + real(kind_phys) :: thv(lbc:ubc) ! virtual potential temperature (kelvin) + real(kind_phys) :: thvstar ! virtual potential temperature scaling parameter + real(kind_phys) :: tksur ! thermal conductivity of snow/soil (w/m/kelvin) + real(kind_phys) :: tsur ! top layer temperature + real(kind_phys) :: tstar ! temperature scaling parameter + real(kind_phys) :: um(lbp:ubp) ! wind speed including the stablity effect [m/s] + real(kind_phys) :: ur(lbp:ubp) ! wind speed at reference height [m/s] + real(kind_phys) :: ustar(lbp:ubp) ! friction velocity [m/s] + real(kind_phys) :: wc ! convective velocity [m/s] + real(kind_phys) :: zeta ! dimensionless height used in Monin-Obukhov theory + real(kind_phys) :: zldis(lbp:ubp) ! reference height "minus" zero displacement height [m] + real(kind_phys) :: displa(lbp:ubp) ! displacement (always zero) [m] + ! real(kind_phys) :: z0mg(lbp:ubp) ! roughness length over ground, momentum [m] + real(kind_phys) :: z0hg(lbp:ubp) ! roughness length over ground, sensible heat [m] + real(kind_phys) :: z0qg(lbp:ubp) ! roughness length over ground, latent heat [m] + real(kind_phys) :: beta(2) ! fraction solar rad absorbed at surface: depends on lake type + real(kind_phys) :: u2m ! 2 m wind speed (m/s) + real(kind_phys) :: u10(1) ! 10-m wind (m/s) (for dust model) + real(kind_phys) :: fv(1) ! friction velocity (m/s) (for dust model) + + real(kind_phys) :: fm(lbp:ubp) ! needed for BGC only to diagnose 10m wind speed + real(kind_phys) :: bw ! partial density of water (ice + liquid) + real(kind_phys) :: t_grnd_temp ! Used in surface flux correction over frozen ground + real(kind_phys) :: betaprime(lbc:ubc) ! Effective beta: 1 for snow layers, beta(islak) otherwise + character*256 :: message + ! This assumes all radiation is absorbed in the top snow layer and will need + ! to be changed for CLM 4. + ! + ! Constants for lake temperature model + ! + data beta/0.4_kind_phys, 0.4_kind_phys/ ! (deep lake, shallow lake) + ! This is the energy absorbed at the lake surface if no snow. + ! data za /0.6_kind_phys, 0.5_kind_phys/ + ! data eta /0.1_kind_phys, 0.5_kind_phys/ + !----------------------------------------------------------------------- + + unhappy=.false. + + ! dtime = get_step_size() + + ! Begin calculations + + !dir$ concurrent + !cdir nodep + forc_th(1) = forc_t(1) * (forc_psrf(1)/ forc_pbot(1))**(rair/cpair) + forc_vp(1) = forc_q(1) * forc_pbot(1)/ (0.622 + 0.378 * forc_q(1)) + forc_rho(1) = (forc_pbot(1) - 0.378 * forc_vp(1)) / (rair * forc_t(1)) + + do fc = 1, num_shlakec + c = filter_shlakec(fc) + g = cgridcell(c) + + ! Surface temperature and fluxes + + ! Find top layer + if (snl(c) > 0 .or. snl(c) < -5) then + errmsg='snl is not defined in ShalLakeFluxesMod; snl: out of range value' + errflg=1 + unhappy=.true. + return ! Cannot continue + end if + ! if (snl(c) /= 0) then + ! write(6,*)'snl is not equal to zero in ShalLakeFluxesMod' + ! call endrun() + ! end if + jtop(c) = snl(c) + 1 + + + if (snl(c) < 0) then + betaprime(c) = 1._kind_phys !Assume all solar rad. absorbed at the surface of the top snow layer. + dzsur(c) = dz(c,jtop(c))/2._kind_phys + else + betaprime(c) = beta(islak) + dzsur(c) = dz_lake(c,1)/2._kind_phys + end if + ! Originally this was 1*dz, but shouldn't it be 1/2? + + ! Saturated vapor pressure, specific humidity and their derivatives + ! at lake surface + + call QSat(t_grnd(c), forc_pbot(g), eg, degdT, qsatg(c), qsatgdT(c)) + + ! Potential, virtual potential temperature, and wind speed at the + ! reference height + + thm(c) = forc_t(g) + 0.0098_kind_phys*forc_hgt_t(g) ! intermediate variable + thv(c) = forc_th(g)*(1._kind_phys+0.61_kind_phys*forc_q(g)) ! virtual potential T + end do + + !dir$ concurrent + !cdir nodep + do fp = 1, num_shlakep + p = filter_shlakep(fp) + c = pcolumn(p) + g = pgridcell(p) + + nmozsgn(p) = 0 + obuold(p) = 0._kind_phys + displa(p) = 0._kind_phys + + ! Roughness lengths + + + ! changed by Hongping Gu + ! if (t_grnd(c) >= tfrz) then ! for unfrozen lake + ! z0mg(p) = 0.01_kind_phys + ! else ! for frozen lake + ! ! Is this okay even if it is snow covered? What is the roughness over + ! non-veg. snow? + ! z0mg(p) = 0.04_kind_phys + ! end if + + if (t_grnd(c) >= tfrz) then ! for unfrozen lake + z0mg(p) = 0.001_kind_phys !original 0.01 + else if(snl(c) == 0 ) then ! for frozen lake + ! Is this okay even if it is snow covered? What is the roughness over + ! non-veg. snow? + z0mg(p) = 0.005_kind_phys !original 0.04, now for frozen lake without snow + else ! for frozen lake with snow + z0mg(p) = 0.0024_kind_phys + end if + + + + + z0hg(p) = z0mg(p) + z0qg(p) = z0mg(p) + + ! Latent heat + + if(PERGRO) then + htvp(c) = hvap + else + if (t_grnd(c) > tfrz) then + htvp(c) = hvap + else + htvp(c) = hsub + end if + endif + + ! Zack Subin, 3/26/09: Shouldn't this be the ground temperature rather than the air temperature above? + ! I'll change it for now. + + ! Initialize stability variables + + ur(p) = max(1.0_kind_phys,sqrt(forc_u(g)*forc_u(g)+forc_v(g)*forc_v(g))) + dth(p) = thm(c)-t_grnd(c) + dqh(p) = forc_q(g)-qsatg(c) + dthv = dth(p)*(1._kind_phys+0.61_kind_phys*forc_q(g))+0.61_kind_phys*forc_th(g)*dqh(p) + zldis(p) = forc_hgt_u(g) - 0._kind_phys + + ! Initialize Monin-Obukhov length and wind speed + + call MoninObukIni(ur(p), thv(c), dthv, zldis(p), z0mg(p), um(p), obu(p)) + + end do + + iter = 1 + fncopy = num_shlakep + fpcopy(1:num_shlakep) = filter_shlakep(1:num_shlakep) + + ! Begin stability iteration + + ITERATION : do while (iter <= niters .and. fncopy > 0) + + ! Determine friction velocity, and potential temperature and humidity + ! profiles of the surface boundary layer + + call FrictionVelocity(pgridcell,forc_hgt,forc_hgt_u, & !i + forc_hgt_t,forc_hgt_q, & !i + lbp, ubp, fncopy, fpcopy, & !i + displa, z0mg, z0hg, z0qg, & !i + obu, iter, ur, um, & !i + ustar,temp1, temp2, temp12m, temp22m, & !o + u10,fv, & !o + fm) !i&o + + !dir$ concurrent + !cdir nodep + do fp = 1, fncopy + p = fpcopy(fp) + c = pcolumn(p) + g = pgridcell(p) + + tgbef(c) = t_grnd(c) + if (t_grnd(c) > tfrz .and. t_lake(c,1) > tfrz .and. snl(c) == 0) then + tksur = savedtke1(c) + ! Set this to the eddy conductivity from the last + ! timestep, as the molecular conductivity will be orders of magnitude too small. + ! Will have to deal with first timestep. + tsur = t_lake(c,1) + else if (snl(c) == 0) then !frozen but no snow layers + tksur = tkice + tsur = t_lake(c,1) + else + !Need to calculate thermal conductivity of the top snow layer + bw = (h2osoi_ice(c,jtop(c))+h2osoi_liq(c,jtop(c)))/dz(c,jtop(c)) + tksur = tkairc + (7.75e-5_kind_phys *bw + 1.105e-6_kind_phys*bw*bw)*(tkice-tkairc) + tsur = t_soisno(c,jtop(c)) + end if + + ! Determine aerodynamic resistances + + ram(p) = 1._kind_phys/(ustar(p)*ustar(p)/um(p)) + rah(p) = 1._kind_phys/(temp1(p)*ustar(p)) + raw(p) = 1._kind_phys/(temp2(p)*ustar(p)) + ram1(p) = ram(p) !pass value to global variable + + ! Get derivative of fluxes with respect to ground temperature + + stftg3(p) = emg*sb*tgbef(c)*tgbef(c)*tgbef(c) + + ! Changed surface temperature from t_lake(c,1) to tsur. + ! Also adjusted so that if there are snow layers present, all radiation is absorbed in the top layer. + ax = betaprime(c)*sabg(p) + emg*forc_lwrad(g) + 3._kind_phys*stftg3(p)*tgbef(c) & + + forc_rho(g)*cpair/rah(p)*thm(c) & + - htvp(c)*forc_rho(g)/raw(p)*(qsatg(c)-qsatgdT(c)*tgbef(c) - forc_q(g)) & + + tksur*tsur/dzsur(c) + !Changed sabg(p) and to betaprime(c)*sabg(p). + bx = 4._kind_phys*stftg3(p) + forc_rho(g)*cpair/rah(p) & + + htvp(c)*forc_rho(g)/raw(p)*qsatgdT(c) + tksur/dzsur(c) + + t_grnd(c) = ax/bx + + ! Update htvp + if(.not.PERGRO) then + if (t_grnd(c) > tfrz) then + htvp(c) = hvap + else + htvp(c) = hsub + end if + endif + + ! Surface fluxes of momentum, sensible and latent heat + ! using ground temperatures from previous time step + + eflx_sh_grnd(p) = forc_rho(g)*cpair*(t_grnd(c)-thm(c))/rah(p) + qflx_evap_soi(p) = forc_rho(g)*(qsatg(c)+qsatgdT(c)*(t_grnd(c)-tgbef(c))-forc_q(g))/raw(p) + + ! Re-calculate saturated vapor pressure, specific humidity and their + ! derivatives at lake surface + + call QSat(t_grnd(c), forc_pbot(g), eg, degdT, qsatg(c), qsatgdT(c)) + + dth(p)=thm(c)-t_grnd(c) + dqh(p)=forc_q(g)-qsatg(c) + + tstar = temp1(p)*dth(p) + qstar = temp2(p)*dqh(p) + + thvstar=tstar*(1._kind_phys+0.61_kind_phys*forc_q(g)) + 0.61_kind_phys*forc_th(g)*qstar + zeta=zldis(p)*vkc * grav*thvstar/(ustar(p)**2*thv(c)) + + if (zeta >= 0._kind_phys) then !stable + zeta = min(2._kind_phys,max(zeta,0.01_kind_phys)) + um(p) = max(ur(p),0.1_kind_phys) + else !unstable + zeta = max(-100._kind_phys,min(zeta,-0.01_kind_phys)) + wc = beta1*(-grav*ustar(p)*thvstar*zii/thv(c))**0.333_kind_phys + um(p) = sqrt(ur(p)*ur(p)+wc*wc) + end if + obu(p) = zldis(p)/zeta + + if (obuold(p)*obu(p) < 0._kind_phys) nmozsgn(p) = nmozsgn(p)+1 + + obuold(p) = obu(p) + + end do ! end of filtered pft loop + + iter = iter + 1 + if (iter <= niters ) then + ! Rebuild copy of pft filter for next pass through the ITERATION loop + + fnold = fncopy + fncopy = 0 + do fp = 1, fnold + p = fpcopy(fp) + if (nmozsgn(p) < 3) then + fncopy = fncopy + 1 + fpcopy(fncopy) = p + end if + end do ! end of filtered pft loop + end if + + end do ITERATION ! end of stability iteration + + !dir$ concurrent + !cdir nodep + do fp = 1, num_shlakep + p = filter_shlakep(fp) + c = pcolumn(p) + g = pgridcell(p) + + ! If there is snow on the ground and t_grnd > tfrz: reset t_grnd = tfrz. + ! Re-evaluate ground fluxes. + ! h2osno > 0.5 prevents spurious fluxes. + ! note that qsatg and qsatgdT should be f(tgbef) (PET: not sure what this + ! comment means) + ! Zack Subin, 3/27/09: Since they are now a function of whatever t_grnd was before cooling + ! to freezing temperature, then this value should be used in the derivative correction term. + ! Should this happen if the lake temperature is below freezing, too? I'll assume that for now. + ! Also, allow convection if ground temp is colder than lake but warmer than 4C, or warmer than + ! lake which is warmer than freezing but less than 4C. + if ( (h2osno(c) > 0.5_kind_phys .or. t_lake(c,1) <= tfrz) .and. t_grnd(c) > tfrz) then + t_grnd_temp = t_grnd(c) + t_grnd(c) = tfrz + eflx_sh_grnd(p) = forc_rho(g)*cpair*(t_grnd(c)-thm(c))/rah(p) + qflx_evap_soi(p) = forc_rho(g)*(qsatg(c)+qsatgdT(c)*(t_grnd(c)-t_grnd_temp) - forc_q(g))/raw(p) + else if ( (t_lake(c,1) > t_grnd(c) .and. t_grnd(c) > tdmax) .or. & + (t_lake(c,1) < t_grnd(c) .and. t_lake(c,1) > tfrz .and. t_grnd(c) < tdmax) ) then + ! Convective mixing will occur at surface + t_grnd_temp = t_grnd(c) + t_grnd(c) = t_lake(c,1) + eflx_sh_grnd(p) = forc_rho(g)*cpair*(t_grnd(c)-thm(c))/rah(p) + qflx_evap_soi(p) = forc_rho(g)*(qsatg(c)+qsatgdT(c)*(t_grnd(c)-t_grnd_temp) - forc_q(g))/raw(p) + end if + + ! Update htvp + if(.not.PERGRO) then + if (t_grnd(c) > tfrz) then + htvp(c) = hvap + else + htvp(c) = hsub + end if + endif + + ! Net longwave from ground to atmosphere + + ! eflx_lwrad_out(p) = (1._kind_phys-emg)*forc_lwrad(g) + stftg3(p)*(-3._kind_phys*tgbef(c)+4._kind_phys*t_grnd(c)) + ! What is tgbef doing in this equation? Can't it be exact now? --Zack Subin, 4/14/09 + eflx_lwrad_out(p) = (1._kind_phys-emg)*forc_lwrad(g) + emg*sb*t_grnd(c)**4 + + ! Ground heat flux + + eflx_soil_grnd(p) = sabg(p) + forc_lwrad(g) - eflx_lwrad_out(p) - & + eflx_sh_grnd(p) - htvp(c)*qflx_evap_soi(p) + !Why is this sabg(p) and not beta*sabg(p)?? + !I've kept this as the incorrect sabg so that the energy balance check will be correct. + !This is the effective energy flux into the ground including the lake solar absorption + !below the surface. The variable eflx_gnet will be used to pass the actual heat flux + !from the ground interface into the lake. + + taux(p) = -forc_rho(g)*forc_u(g)/ram(p) + tauy(p) = -forc_rho(g)*forc_v(g)/ram(p) + + eflx_sh_tot(p) = eflx_sh_grnd(p) + qflx_evap_tot(p) = qflx_evap_soi(p) + eflx_lh_tot(p) = htvp(c)*qflx_evap_soi(p) + eflx_lh_grnd(p) = htvp(c)*qflx_evap_soi(p) + if(LAKEDEBUG) then +1604 format('CLM_Lake ShalLakeFluxes: c=',I0,' sensible heat = ',F12.4,' latent heat =',F12.4, & + ' ground temp = ', F12.4, ' h2osno = ', F12.4, ' at xlat_d=',F10.3,' xlon_d=',F10.3) + print 1604, c, eflx_sh_tot(p), eflx_lh_tot(p), t_grnd(c), h2osno(c),xlat_d,xlon_d + if (abs(eflx_sh_tot(p)) > 1500 .or. abs(eflx_lh_tot(p)) > 1500) then +3018 format('CLM_Lake ShalLakeFluxes: WARNING: SH=',F12.4,' LH=',F12.4,' at xlat_d=',F10.3,' xlon_d=',F10.3) + print 3018,eflx_sh_tot(p), eflx_lh_tot(p),xlat_d,xlon_d + unhappy = .true. + end if + if (abs(eflx_sh_tot(p)) > 10000 .or. abs(eflx_lh_tot(p)) > 10000 & + .or. abs(t_grnd(c)-288)>200 ) then +840 format('CLM_Lake ShalLakeFluxes: t_grnd is out of range: eflx_sh_tot(p)=',G20.12,' eflx_lh_tot(p)=',G20.12,' t_grnd(c)=',G20.12,' at p=',I0,' c=',I0,' xlat_d=',F10.3,' xlon_d=',F10.3) + write(message,840) eflx_sh_tot(p),eflx_lh_tot(p),t_grnd(c),p,c,xlat_d,xlon_d + errmsg=message + errflg=1 + unhappy = .true. + endif + endif + ! 2 m height air temperature + t_ref2m(p) = thm(c) + temp1(p)*dth(p)*(1._kind_phys/temp12m(p) - 1._kind_phys/temp1(p)) + + ! 2 m height specific humidity + q_ref2m(p) = forc_q(g) + temp2(p)*dqh(p)*(1._kind_phys/temp22m(p) - 1._kind_phys/temp2(p)) + + ! Energy residual used for melting snow + ! Effectively moved to ShalLakeTemp + + ! Prepare for lake layer temperature calculations below + ! fin(c) = betaprime * sabg(p) + forc_lwrad(g) - (eflx_lwrad_out(p) + & + ! eflx_sh_tot(p) + eflx_lh_tot(p)) + ! NOW this is just the net ground heat flux calculated below. + + eflx_gnet(p) = betaprime(c) * sabg(p) + forc_lwrad(g) - (eflx_lwrad_out(p) + & + eflx_sh_tot(p) + eflx_lh_tot(p)) + ! This is the actual heat flux from the ground interface into the lake, not including + ! the light that penetrates the surface. + + ! u2m = max(1.0_kind_phys,ustar(p)/vkc*log(2._kind_phys/z0mg(p))) + ! u2 often goes below 1 m/s; it seems like the only reason for this minimum is to + ! keep it from being zero in the ks equation below; 0.1 m/s is a better limit for + ! stable conditions --ZS + u2m = max(0.1_kind_phys,ustar(p)/vkc*log(2._kind_phys/z0mg(p))) + + ws(c) = 1.2e-03_kind_phys * u2m + ks(c) = 6.6_kind_phys*sqrt(abs(sin(lat(g))))*(u2m**(-1.84_kind_phys)) + + end do + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! End of surface flux relevant code in original BiogeophysicsLakeMod until history loop. + + ! The following are needed for global average on history tape. + + !dir$ concurrent + !cdir nodep + do fp = 1, num_shlakep + p = filter_shlakep(fp) + c = pcolumn(p) + g = pgridcell(p) + ! t_veg(p) = forc_t(g) + !This is an odd choice, since elsewhere t_veg = t_grnd for bare ground. + !Zack Subin, 4/09 + t_veg(p) = t_grnd(c) + eflx_lwrad_net(p) = eflx_lwrad_out(p) - forc_lwrad(g) + qflx_prec_grnd(p) = forc_rain(g) + forc_snow(g) + end do + + ustar_out(1) = ustar(1) + + +END SUBROUTINE ShalLakeFluxes + +SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & !i + z_lake,ws,ks,snl,eflx_gnet,lakedepth, & + lake_icefrac,snowdp, & !i&o + eflx_sh_grnd,eflx_sh_tot,eflx_soil_grnd, & !o + t_lake,t_soisno,h2osoi_liq, & + h2osoi_ice,savedtke1, & + frac_iceold,qflx_snomelt,imelt,errmsg,errflg) + !======================================================================================================= + ! !DESCRIPTION: + ! Calculates temperatures in the 20-25 layer column of (possible) snow, + ! lake water, and soil beneath lake. + ! Snow and soil temperatures are determined as in SoilTemperature, except + ! for appropriate boundary conditions at the top of the snow (the flux is fixed + ! to be the ground heat flux calculated in ShalLakeFluxes), the bottom of the snow + ! (adjacent to top lake layer), and the top of the soil (adjacent to the bottom + ! lake layer). Also, the soil is assumed to be always fully saturated (ShalLakeHydrology + ! will have to insure this). The whole column is solved simultaneously as one tridiagonal matrix. + ! Lake temperatures are determined from the Hostetler model as before, except now: + ! i) Lake water layers can freeze by any fraction and release latent heat; thermal + ! and mechanical properties are adjusted for ice fraction. + ! ii) Convective mixing (though not eddy diffusion) still occurs for frozen lakes. + ! iii) No sunlight is absorbed in the lake if there are snow layers. + ! iv) Light is allowed to reach the top soil layer (where it is assumed to be completely absorbed). + ! v) Lakes have variable depth, set ultimately in surface data set but now in initShalLakeMod. + ! + ! Eddy + molecular diffusion: + ! d ts d d ts 1 ds + ! ---- = -- [(km + ke) ----] + -- -- + ! dt dz dz cw dz + ! + ! where: ts = temperature (kelvin) + ! t = time (s) + ! z = depth (m) + ! km = molecular diffusion coefficient (m**2/s) + ! ke = eddy diffusion coefficient (m**2/s) + ! cw = heat capacity (j/m**3/kelvin) + ! s = heat source term (w/m**2) + ! + ! Shallow lakes are allowed to have variable depth, set in _____. + ! + ! For shallow lakes: ke > 0 if unfrozen, + ! and convective mixing occurs WHETHER OR NOT frozen. (See e.g. Martynov...) + ! + ! Use the Crank-Nicholson method to set up tridiagonal system of equations to + ! solve for ts at time n+1, where the temperature equation for layer i is + ! r_i = a_i [ts_i-1] n+1 + b_i [ts_i] n+1 + c_i [ts_i+1] n+1 + ! + ! The solution conserves energy as: + ! + ! [For lake layers] + ! cw*([ts( 1)] n+1 - [ts( 1)] n)*dz( 1)/dt + ... + + ! cw*([ts(nlevlake)] n+1 - [ts(nlevlake)] n)*dz(nlevlake)/dt = fin + ! But now there is phase change, so cv is not constant and there is + ! latent heat. + ! + ! where: + ! [ts] n = old temperature (kelvin) + ! [ts] n+1 = new temperature (kelvin) + ! fin = heat flux into lake (w/m**2) + ! = betaprime*sabg + forc_lwrad - eflx_lwrad_out - eflx_sh_tot - eflx_lh_tot + ! (This is now the same as the ground heat flux.) + ! + phi(1) + ... + phi(nlevlake) + phi(top soil level) + ! betaprime = beta(islak) for no snow layers, and 1 for snow layers. + ! This assumes all radiation is absorbed in the top snow layer and will need + ! to be changed for CLM 4. + ! + ! WARNING: This subroutine assumes lake columns have one and only one pft. + ! + ! Outline: + ! 1!) Initialization + ! 2!) Lake density + ! 3!) Diffusivity + ! 4!) Heat source term from solar radiation penetrating lake + ! 5!) Set thermal props and find initial energy content + ! 6!) Set up vectors for tridiagonal matrix solution + ! 7!) Solve tridiagonal and back-substitute + ! 8!) (Optional) Do first energy check using temperature change at constant heat capacity. + ! 9!) Phase change + ! 9.5!) (Optional) Do second energy check using temperature change and latent heat, considering changed heat capacity. + ! Also do soil water balance check. + !10!) Convective mixing + !11!) Do final energy check to detect small numerical errors (especially from convection) + ! and dump small imbalance into sensible heat, or pass large errors to BalanceCheckMod for abort. + ! + ! REVISION HISTORY: + ! Created by Zack Subin, 2009. + ! Reedited by Hongping Gu, 2010. + ! Updated for CCPP by Sam Trahan, 2022. + !========================================================================================================= + + + implicit none + + !in: + integer, intent(inout) :: errflg + character(*), intent(inout) :: errmsg + real(kind_phys), intent(in) :: t_grnd(1) ! ground temperature (Kelvin) + real(kind_phys), intent(inout) :: h2osno(1) ! snow water (mm H2O) + real(kind_phys), intent(in) :: sabg(1) ! solar radiation absorbed by ground (W/m**2) + real(kind_phys), intent(in) :: dz(1,-nlevsnow + 1:nlevsoil) ! layer thickness for snow & soil (m) + real(kind_phys), intent(in) :: dz_lake(1,nlevlake) ! layer thickness for lake (m) + real(kind_phys), intent(in) :: z(1,-nlevsnow+1:nlevsoil) ! layer depth for snow & soil (m) + real(kind_phys), intent(in) :: zi(1,-nlevsnow+0:nlevsoil) ! interface level below a "z" level (m) + ! the other z and dz variables + real(kind_phys), intent(in) :: z_lake(1,nlevlake) ! layer depth for lake (m) + real(kind_phys), intent(in) :: ws(1) ! surface friction velocity (m/s) + real(kind_phys), intent(in) :: ks(1) ! coefficient passed to ShalLakeTemperature + ! for calculation of decay of eddy diffusivity with depth + integer , intent(in) :: snl(1) ! negative of number of snow layers + real(kind_phys), intent(inout) :: eflx_gnet(1) ! net heat flux into ground (W/m**2) at the surface interface + real(kind_phys), intent(in) :: lakedepth(1) ! column lake depth (m) + + ! real(kind_phys), intent(in) :: watsat(1,nlevsoil) ! volumetric soil water at saturation (porosity) + real(kind_phys), intent(inout) :: snowdp(1) !snow height (m) + !out: + + real(kind_phys), intent(out) :: eflx_sh_grnd(1) ! sensible heat flux from ground (W/m**2) [+ to atm] + real(kind_phys), intent(out) :: eflx_sh_tot(1) ! total sensible heat flux (W/m**2) [+ to atm] + real(kind_phys), intent(out) :: eflx_soil_grnd(1) ! heat flux into snow / lake (W/m**2) [+ = into soil] + ! Here this includes the whole lake radiation absorbed. + !real(kind_phys), intent(out) :: qmelt(1) ! snow melt [mm/s] [temporary] + + real(kind_phys), intent(inout) :: t_lake(1,nlevlake) ! lake temperature (Kelvin) + real(kind_phys), intent(inout) :: t_soisno(1,-nlevsnow+1:nlevsoil) ! soil (or snow) temperature (Kelvin) + real(kind_phys), intent(inout) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) ! liquid water (kg/m2) [for snow & soil layers] + real(kind_phys), intent(inout) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) ! ice lens (kg/m2) [for snow & soil layers] + real(kind_phys), intent(inout) :: lake_icefrac(1,nlevlake) ! mass fraction of lake layer that is frozen + real(kind_phys), intent(out) :: savedtke1(1) ! top level thermal conductivity (W/mK) + real(kind_phys), intent(out) :: frac_iceold(1,-nlevsnow+1:nlevsoil) ! fraction of ice relative to the tot water + real(kind_phys), intent(out) :: qflx_snomelt(1) !snow melt (mm H2O /s) + integer, intent(out) :: imelt(1,-nlevsnow+1:nlevsoil) !flag for melting (=1), freezing (=2), Not=0 (new) + + + ! OTHER LOCAL VARIABLES: + + integer , parameter :: islak = 2 ! index of lake, 1 = deep lake, 2 = shallow lake + real(kind_phys), parameter :: p0 = 1._kind_phys ! neutral value of turbulent prandtl number + integer :: i,j,fc,fp,g,c,p ! do loop or array index + ! real(kind_phys) :: dtime ! land model time step (sec) + real(kind_phys) :: beta(2) ! fraction solar rad absorbed at surface: depends on lake type + real(kind_phys) :: za(2) ! base of surface absorption layer (m): depends on lake type + real(kind_phys) :: eta(2) ! light extinction coefficient (/m): depends on lake type + real(kind_phys) :: cwat ! specific heat capacity of water (j/m**3/kelvin) + real(kind_phys) :: cice_eff ! effective heat capacity of ice (using density of + ! water because layer depth is not adjusted when freezing + real(kind_phys) :: cfus ! effective heat of fusion per unit volume + ! using water density as above + real(kind_phys) :: km ! molecular diffusion coefficient (m**2/s) + real(kind_phys) :: tkice_eff ! effective conductivity since layer depth is constant + real(kind_phys) :: a(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) ! "a" vector for tridiagonal matrix + real(kind_phys) :: b(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) ! "b" vector for tridiagonal matrix + real(kind_phys) :: c1(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) ! "c" vector for tridiagonal matrix + real(kind_phys) :: r(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) ! "r" vector for tridiagonal solution + real(kind_phys) :: rhow(lbc:ubc,nlevlake) ! density of water (kg/m**3) + real(kind_phys) :: phi(lbc:ubc,nlevlake) ! solar radiation absorbed by layer (w/m**2) + real(kind_phys) :: kme(lbc:ubc,nlevlake) ! molecular + eddy diffusion coefficient (m**2/s) + real(kind_phys) :: rsfin ! relative flux of solar radiation into layer + real(kind_phys) :: rsfout ! relative flux of solar radiation out of layer + real(kind_phys) :: phi_soil(lbc:ubc) ! solar radiation into top soil layer (W/m**2) + real(kind_phys) :: ri ! richardson number + real(kind_phys) :: fin(lbc:ubc) ! net heat flux into lake at ground interface (w/m**2) + real(kind_phys) :: ocvts(lbc:ubc) ! (cwat*(t_lake[n ])*dz + real(kind_phys) :: ncvts(lbc:ubc) ! (cwat*(t_lake[n+1])*dz + real(kind_phys) :: ke ! eddy diffusion coefficient (m**2/s) + real(kind_phys) :: zin ! depth at top of layer (m) + real(kind_phys) :: zout ! depth at bottom of layer (m) + real(kind_phys) :: drhodz ! d [rhow] /dz (kg/m**4) + real(kind_phys) :: n2 ! brunt-vaisala frequency (/s**2) + real(kind_phys) :: num ! used in calculating ri + real(kind_phys) :: den ! used in calculating ri + real(kind_phys) :: tav_froz(lbc:ubc) ! used in aver temp for convectively mixed layers (C) + real(kind_phys) :: tav_unfr(lbc:ubc) ! " + real(kind_phys) :: nav(lbc:ubc) ! used in aver temp for convectively mixed layers + real(kind_phys) :: phidum ! temporary value of phi + real(kind_phys) :: iceav(lbc:ubc) ! used in calc aver ice for convectively mixed layers + real(kind_phys) :: qav(lbc:ubc) ! used in calc aver heat content for conv. mixed layers + integer :: jtop(lbc:ubc) ! top level for each column (no longer all 1) + real(kind_phys) :: cv (lbc:ubc,-nlevsnow+1:nlevsoil) !heat capacity of soil/snow [J/(m2 K)] + real(kind_phys) :: tk (lbc:ubc,-nlevsnow+1:nlevsoil) !thermal conductivity of soil/snow [W/(m K)] + !(at interface below, except for j=0) + real(kind_phys) :: cv_lake (lbc:ubc,1:nlevlake) !heat capacity [J/(m2 K)] + real(kind_phys) :: tk_lake (lbc:ubc,1:nlevlake) !thermal conductivity at layer node [W/(m K)] + real(kind_phys) :: cvx (lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) !heat capacity for whole column [J/(m2 K)] + real(kind_phys) :: tkix(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) !thermal conductivity at layer interfaces + !for whole column [W/(m K)] + real(kind_phys) :: tx(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) ! temperature of whole column [K] + real(kind_phys) :: tktopsoillay(lbc:ubc) ! thermal conductivity [W/(m K)] + real(kind_phys) :: fnx(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) !heat diffusion through the layer interface below [W/m2] + real(kind_phys) :: phix(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) !solar source term for whole column [W/m**2] + real(kind_phys) :: zx(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) !interface depth (+ below surface) for whole column [m] + real(kind_phys) :: dzm !used in computing tridiagonal matrix [m] + real(kind_phys) :: dzp !used in computing tridiagonal matrix [m] + integer :: jprime ! j - nlevlake + real(kind_phys) :: factx(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) !coefficient used in computing tridiagonal matrix + real(kind_phys) :: t_lake_bef(lbc:ubc,1:nlevlake) !beginning lake temp for energy conservation check [K] + real(kind_phys) :: t_soisno_bef(lbc:ubc,-nlevsnow+1:nlevsoil) !beginning soil temp for E cons. check [K] + real(kind_phys) :: lhabs(lbc:ubc) ! total per-column latent heat abs. from phase change (J/m^2) + real(kind_phys) :: esum1(lbc:ubc) ! temp for checking energy (J/m^2) + real(kind_phys) :: esum2(lbc:ubc) ! "" + real(kind_phys) :: zsum(lbc:ubc) ! temp for putting ice at the top during convection (m) + real(kind_phys) :: wsum(lbc:ubc) ! temp for checking water (kg/m^2) + real(kind_phys) :: wsum_end(lbc:ubc) ! temp for checking water (kg/m^2) + real(kind_phys) :: errsoi(1) ! soil/lake energy conservation error (W/m**2) + real(kind_phys) :: eflx_snomelt(1) !snow melt heat flux (W/m**2) + CHARACTER*256 :: message + ! + ! Constants for lake temperature model + ! + data beta/0.4_kind_phys, 0.4_kind_phys/ ! (deep lake, shallow lake) + data za /0.6_kind_phys, 0.6_kind_phys/ + ! For now, keep beta and za for shallow lake the same as deep lake, until better data is found. + ! It looks like eta is key and that larger values give better results for shallow lakes. Use + ! empirical expression from Hakanson (below). This is still a very unconstrained parameter + ! that deserves more attention. + ! Some radiation will be allowed to reach the soil. + !----------------------------------------------------------------------- + + + ! 1!) Initialization + ! Determine step size + + ! dtime = get_step_size() + + ! Initialize constants + cwat = cpliq*denh2o ! water heat capacity per unit volume + cice_eff = cpice*denh2o !use water density because layer depth is not adjusted + !for freezing + cfus = hfus*denh2o ! latent heat per unit volume + tkice_eff = tkice * denice/denh2o !effective conductivity since layer depth is constant + km = tkwat/cwat ! a constant (molecular diffusivity) + + ! Begin calculations + + !dir$ concurrent + !cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + + ! Initialize Ebal quantities computed below + + ocvts(c) = 0._kind_phys + ncvts(c) = 0._kind_phys + esum1(c) = 0._kind_phys + esum2(c) = 0._kind_phys + + end do + + ! Initialize set of previous time-step variables as in DriverInit, + ! which is currently not called over lakes. This has to be done + ! here because phase change will occur in this routine. + ! Ice fraction of snow at previous time step + + do j = -nlevsnow+1,0 + !dir$ concurrent + !cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + if (j >= snl(c) + 1) then + frac_iceold(c,j) = h2osoi_ice(c,j)/(h2osoi_liq(c,j)+h2osoi_ice(c,j)) + end if + end do + end do + + ! Sum soil water. + do j = 1, nlevsoil + !dir$ concurrent + !cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + if (j == 1) wsum(c) = 0._kind_phys + wsum(c) = wsum(c) + h2osoi_ice(c,j) + h2osoi_liq(c,j) + end do + end do + + !dir$ concurrent + !cdir nodep + do fp = 1, num_shlakep + p = filter_shlakep(fp) + c = pcolumn(p) + + + ! Prepare for lake layer temperature calculations below + + ! fin(c) = betaprime * sabg(p) + forc_lwrad(g) - (eflx_lwrad_out(p) + & + ! eflx_sh_tot(p) + eflx_lh_tot(p)) + ! fin(c) now passed from ShalLakeFluxes as eflx_gnet + fin(c) = eflx_gnet(p) + + end do + + ! 2!) Lake density + + do j = 1, nlevlake + !dir$ concurrent + !cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + rhow(c,j) = (1._kind_phys - lake_icefrac(c,j)) * & + 1000._kind_phys*( 1.0_kind_phys - 1.9549e-05_kind_phys*(abs(t_lake(c,j)-277._kind_phys))**1.68_kind_phys ) & + + lake_icefrac(c,j)*denice + ! Allow for ice fraction; assume constant ice density. + ! Is this the right weighted average? + ! Using this average will make sure that surface ice is treated properly during + ! convective mixing. + end do + end do + + ! 3!) Diffusivity and implied thermal "conductivity" = diffusivity * cwat + do j = 1, nlevlake-1 + !dir$ prefervector + !dir$ concurrent + !cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + drhodz = (rhow(c,j+1)-rhow(c,j)) / (z_lake(c,j+1)-z_lake(c,j)) + n2 = grav / rhow(c,j) * drhodz + ! Fixed sign error here: our z goes up going down into the lake, so no negative + ! sign is needed to make this positive unlike in Hostetler. --ZS + num = 40._kind_phys * n2 * (vkc*z_lake(c,j))**2 + den = max( (ws(c)**2) * exp(-2._kind_phys*ks(c)*z_lake(c,j)), 1.e-10_kind_phys ) + ri = ( -1._kind_phys + sqrt( max(1._kind_phys+num/den, 0._kind_phys) ) ) / 20._kind_phys + if (t_grnd(c) > tfrz .and. t_lake(c,1) > tfrz .and. snl(c) == 0) then + ! ke = vkc*ws(c)*z_lake(c,j)/p0 * exp(-ks(c)*z_lake(c,j)) / (1._kind_phys+37._kind_phys*ri*ri) + + if( t_lake(c,1) > 277.15_kind_phys ) then + if (lakedepth(c) > 15.0 ) then + ke = 1.e+2_kind_phys*vkc*ws(c)*z_lake(c,j)/p0 * exp(-ks(c)*z_lake(c,j)) / (1._kind_phys+37._kind_phys*ri*ri) + else + ke = vkc*ws(c)*z_lake(c,j)/p0 * exp(-ks(c)*z_lake(c,j)) / (1._kind_phys+37._kind_phys*ri*ri) + endif + else + if (lakedepth(c) > 15.0 ) then + if (lakedepth(c) > 150.0 ) then + ke = 1.e+5_kind_phys*vkc*ws(c)*z_lake(c,j)/p0 * exp(-ks(c)*z_lake(c,j)) / (1._kind_phys+37._kind_phys*ri*ri) + else + ke =1.e+4_kind_phys*vkc*ws(c)*z_lake(c,j)/p0 * exp(-ks(c)*z_lake(c,j)) / (1._kind_phys+37._kind_phys*ri*ri) + end if + else + ke = vkc*ws(c)*z_lake(c,j)/p0 * exp(-ks(c)*z_lake(c,j)) / (1._kind_phys+37._kind_phys*ri*ri) + endif + end if + + kme(c,j) = km + ke + tk_lake(c,j) = kme(c,j)*cwat + ! If there is some ice in this layer (this should rarely happen because the surface + ! is unfrozen and it will be unstable), still use the cwat to get out the tk b/c the eddy + ! diffusivity equation assumes water. + else + kme(c,j) = km + tk_lake(c,j) = tkwat*tkice_eff / ( (1._kind_phys-lake_icefrac(c,j))*tkice_eff & + + tkwat*lake_icefrac(c,j) ) + ! Assume the resistances add as for the calculation of conductivities at layer interfaces. + end if + end do + end do + + !dir$ concurrent + !cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + + j = nlevlake + kme(c,nlevlake) = kme(c,nlevlake-1) + + if (t_grnd(c) > tfrz .and. t_lake(c,1) > tfrz .and. snl(c) == 0) then + tk_lake(c,j) = tk_lake(c,j-1) + else + tk_lake(c,j) = tkwat*tkice_eff / ( (1._kind_phys-lake_icefrac(c,j))*tkice_eff & + + tkwat*lake_icefrac(c,j) ) + end if + + ! Use in surface flux calculation for next timestep. + savedtke1(c) = kme(c,1)*cwat ! Will only be used if unfrozen + ! set number of column levels for use by Tridiagonal below + jtop(c) = snl(c) + 1 + end do + + ! 4!) Heat source term: unfrozen lakes only + do j = 1, nlevlake + !dir$ concurrent + !cdir nodep + do fp = 1, num_shlakep + p = filter_shlakep(fp) + c = pcolumn(p) + + ! Set eta(:), the extinction coefficient, according to L Hakanson, Aquatic Sciences, 1995 + ! (regression of Secchi Depth with lake depth for small glacial basin lakes), and the + ! Poole & Atkins expression for extinction coeffient of 1.7 / Secchi Depth (m). + if(.not.USE_ETALAKE) then + eta(:) = 1.1925_kind_phys*lakedepth(c)**(-0.424) + else + eta(:) = ETALAKE + endif + + zin = z_lake(c,j) - 0.5_kind_phys*dz_lake(c,j) + zout = z_lake(c,j) + 0.5_kind_phys*dz_lake(c,j) + rsfin = exp( -eta(islak)*max( zin-za(islak),0._kind_phys ) ) + rsfout = exp( -eta(islak)*max( zout-za(islak),0._kind_phys ) ) + + ! Let rsfout for bottom layer go into soil. + ! This looks like it should be robust even for pathological cases, + ! like lakes thinner than za. + if (t_grnd(c) > tfrz .and. t_lake(c,1) > tfrz .and. snl(c) == 0) then + phidum = (rsfin-rsfout) * sabg(p) * (1._kind_phys-beta(islak)) + if (j == nlevlake) then + phi_soil(c) = rsfout * sabg(p) * (1._kind_phys-beta(islak)) + end if + else if (j == 1 .and. snl(c) == 0) then !if frozen but no snow layers + phidum = sabg(p) * (1._kind_phys-beta(islak)) + else !radiation absorbed at surface + phidum = 0._kind_phys + if (j == nlevlake) phi_soil(c) = 0._kind_phys + end if + phi(c,j) = phidum + + end do + end do + + ! 5!) Set thermal properties and check initial energy content. + + ! For lake + do j = 1, nlevlake + !dir$ concurrent + !cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + + cv_lake(c,j) = dz_lake(c,j) * (cwat*(1._kind_phys-lake_icefrac(c,j)) + cice_eff*lake_icefrac(c,j)) + end do + end do + + ! For snow / soil + call SoilThermProp_Lake (snl,dz,zi,z,t_soisno,h2osoi_liq,h2osoi_ice, & + tk, cv, tktopsoillay,errmsg,errflg) + if(errflg/=0) then + ! State is no longer valid, so return error to caller + ! FIXME: PUT THIS BACK return + endif + + ! Sum cv*t_lake for energy check + ! Include latent heat term, and correction for changing heat capacity with phase change. + + ! This will need to be over all soil / lake / snow layers. Lake is below. + do j = 1, nlevlake + !dir$ concurrent + !cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + + ! ocvts(c) = ocvts(c) + cv_lake(c,j)*t_lake(c,j) & + ocvts(c) = ocvts(c) + cv_lake(c,j)*(t_lake(c,j)-tfrz) & + + cfus*dz_lake(c,j)*(1._kind_phys-lake_icefrac(c,j)) !& + ! + (cwat-cice_eff)*lake_icefrac(c)*tfrz*dz_lake(c,j) !enthalpy reconciliation term + t_lake_bef(c,j) = t_lake(c,j) + end do + end do + + ! Now do for soil / snow layers + do j = -nlevsnow + 1, nlevsoil + !dir$ concurrent + !cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + + if (j >= jtop(c)) then + ! ocvts(c) = ocvts(c) + cv(c,j)*t_soisno(c,j) & + ocvts(c) = ocvts(c) + cv(c,j)*(t_soisno(c,j)-tfrz) & + + hfus*h2osoi_liq(c,j) !& + ! + (cpliq-cpice)*h2osoi_ice(c,j)*tfrz !enthalpy reconciliation term + if (j == 1 .and. h2osno(c) > 0._kind_phys .and. j == jtop(c)) then + ocvts(c) = ocvts(c) - h2osno(c)*hfus + end if + t_soisno_bef(c,j) = t_soisno(c,j) + if(abs(t_soisno(c,j)-288) > 150) then +48 format('WARNING: At c=',I0,' level=',I0,' extreme t_soisno = ',F15.10) + WRITE(message,48) c,j,t_soisno(c,j) + errmsg=trim(message) + errflg=1 + endif + end if + end do + end do + + !!!!!!!!!!!!!!!!!!! + ! 6!) Set up vector r and vectors a, b, c1 that define tridiagonal matrix + + ! Heat capacity and resistance of snow without snow layers (<1cm) is ignored during diffusion, + ! but its capacity to absorb latent heat may be used during phase change. + + ! Set up interface depths, zx, heat capacities, cvx, solar source terms, phix, and temperatures, tx. + do j = -nlevsnow+1, nlevlake+nlevsoil + !dir$ prefervector + !dir$ concurrent + !cdir nodep + do fc = 1,num_shlakec + c = filter_shlakec(fc) + + jprime = j - nlevlake + + if (j >= jtop(c)) then + if (j < 1) then !snow layer + zx(c,j) = z(c,j) + cvx(c,j) = cv(c,j) + phix(c,j) = 0._kind_phys + tx(c,j) = t_soisno(c,j) + else if (j <= nlevlake) then !lake layer + zx(c,j) = z_lake(c,j) + cvx(c,j) = cv_lake(c,j) + phix(c,j) = phi(c,j) + tx(c,j) = t_lake(c,j) + else !soil layer + zx(c,j) = zx(c,nlevlake) + dz_lake(c,nlevlake)/2._kind_phys + z(c,jprime) + cvx(c,j) = cv(c,jprime) + if (j == nlevlake + 1) then !top soil layer + phix(c,j) = phi_soil(c) + else !middle or bottom soil layer + phix(c,j) = 0._kind_phys + end if + tx(c,j) = t_soisno(c,jprime) + end if + end if + + end do + end do + + ! Determine interface thermal conductivities, tkix + + do j = -nlevsnow+1, nlevlake+nlevsoil + !dir$ prefervector + !dir$ concurrent + !cdir nodep + do fc = 1,num_shlakec + c = filter_shlakec(fc) + + jprime = j - nlevlake + + if (j >= jtop(c)) then + if (j < 0) then !non-bottom snow layer + tkix(c,j) = tk(c,j) + else if (j == 0) then !bottom snow layer + dzp = zx(c,j+1) - zx(c,j) + tkix(c,j) = tk_lake(c,1)*tk(c,j)*dzp / & + (tk(c,j)*z_lake(c,1) + tk_lake(c,1)*(-z(c,j)) ) + ! tk(c,0) is the conductivity at the middle of that layer, as defined in SoilThermProp_Lake + else if (j < nlevlake) then !non-bottom lake layer + tkix(c,j) = ( tk_lake(c,j)*tk_lake(c,j+1) * (dz_lake(c,j+1)+dz_lake(c,j)) ) & + / ( tk_lake(c,j)*dz_lake(c,j+1) + tk_lake(c,j+1)*dz_lake(c,j) ) + else if (j == nlevlake) then !bottom lake layer + dzp = zx(c,j+1) - zx(c,j) + tkix(c,j) = (tktopsoillay(c)*tk_lake(c,j)*dzp / & + (tktopsoillay(c)*dz_lake(c,j)/2._kind_phys + tk_lake(c,j)*z(c,1) ) ) + ! tktopsoillay is the conductivity at the middle of that layer, as defined in SoilThermProp_Lake + else !soil layer + tkix(c,j) = tk(c,jprime) + end if + end if + + end do + end do + + + ! Determine heat diffusion through the layer interface and factor used in computing + ! tridiagonal matrix and set up vector r and vectors a, b, c1 that define tridiagonal + ! matrix and solve system + + do j = -nlevsnow+1, nlevlake+nlevsoil + !dir$ prefervector + !dir$ concurrent + !cdir nodep + do fc = 1,num_shlakec + c = filter_shlakec(fc) + if (j >= jtop(c)) then + if (j < nlevlake+nlevsoil) then !top or interior layer + factx(c,j) = dtime/cvx(c,j) + fnx(c,j) = tkix(c,j)*(tx(c,j+1)-tx(c,j))/(zx(c,j+1)-zx(c,j)) + else !bottom soil layer + factx(c,j) = dtime/cvx(c,j) + fnx(c,j) = 0._kind_phys !not used + end if + end if + enddo + end do + + do j = -nlevsnow+1,nlevlake+nlevsoil + !dir$ prefervector + !dir$ concurrent + !cdir nodep + do fc = 1,num_shlakec + c = filter_shlakec(fc) + if (j >= jtop(c)) then + if (j == jtop(c)) then !top layer + dzp = zx(c,j+1)-zx(c,j) + a(c,j) = 0._kind_phys + b(c,j) = 1+(1._kind_phys-cnfac)*factx(c,j)*tkix(c,j)/dzp + c1(c,j) = -(1._kind_phys-cnfac)*factx(c,j)*tkix(c,j)/dzp + r(c,j) = tx(c,j) + factx(c,j)*( fin(c) + phix(c,j) + cnfac*fnx(c,j) ) + else if (j < nlevlake+nlevsoil) then !middle layer + dzm = (zx(c,j)-zx(c,j-1)) + dzp = (zx(c,j+1)-zx(c,j)) + a(c,j) = - (1._kind_phys-cnfac)*factx(c,j)* tkix(c,j-1)/dzm + b(c,j) = 1._kind_phys+ (1._kind_phys-cnfac)*factx(c,j)*(tkix(c,j)/dzp + tkix(c,j-1)/dzm) + c1(c,j) = - (1._kind_phys-cnfac)*factx(c,j)* tkix(c,j)/dzp + r(c,j) = tx(c,j) + cnfac*factx(c,j)*( fnx(c,j) - fnx(c,j-1) ) + factx(c,j)*phix(c,j) + else !bottom soil layer + dzm = (zx(c,j)-zx(c,j-1)) + a(c,j) = - (1._kind_phys-cnfac)*factx(c,j)*tkix(c,j-1)/dzm + b(c,j) = 1._kind_phys+ (1._kind_phys-cnfac)*factx(c,j)*tkix(c,j-1)/dzm + c1(c,j) = 0._kind_phys + r(c,j) = tx(c,j) - cnfac*factx(c,j)*fnx(c,j-1) + end if + end if + enddo + end do + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + ! 7!) Solve for tdsolution + + call Tridiagonal(lbc, ubc, -nlevsnow + 1, nlevlake + nlevsoil, jtop, num_shlakec, filter_shlakec, & + a, b, c1, r, tx) + + ! Set t_soisno and t_lake + do j = -nlevsnow+1, nlevlake + nlevsoil + !dir$ concurrent + !cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + + jprime = j - nlevlake + + ! Don't do anything with invalid snow layers. + if (j >= jtop(c)) then + if (j < 1) then !snow layer + t_soisno(c,j) = tx(c,j) + else if (j <= nlevlake) then !lake layer + t_lake(c,j) = tx(c,j) + else !soil layer + t_soisno(c,jprime) = tx(c,j) + end if + end if + end do + end do + + !!!!!!!!!!!!!!!!!!!!!!! + + ! 8!) Sum energy content and total energy into lake for energy check. Any errors will be from the + ! Tridiagonal solution. + + if_debug_energy: if (LAKEDEBUG) then + do j = 1, nlevlake + !dir$ concurrent + !cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + + esum1(c) = esum1(c) + (t_lake(c,j)-t_lake_bef(c,j))*cv_lake(c,j) + esum2(c) = esum2(c) + (t_lake(c,j)-tfrz)*cv_lake(c,j) + end do + end do + + do j = -nlevsnow+1, nlevsoil + !dir$ concurrent + !cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + + if (j >= jtop(c)) then + esum1(c) = esum1(c) + (t_soisno(c,j)-t_soisno_bef(c,j))*cv(c,j) + esum2(c) = esum2(c) + (t_soisno(c,j)-tfrz)*cv(c,j) + end if + end do + end do + + !dir$ concurrent + !cdir nodep + do fp = 1, num_shlakep + p = filter_shlakep(fp) + c = pcolumn(p) + ! Again assuming only one pft per column + ! esum1(c) = esum1(c) + lhabs(c) + errsoi(c) = esum1(c)/dtime - eflx_soil_grnd(p) + ! eflx_soil_grnd includes all the solar radiation absorbed in the lake, + ! unlike eflx_gnet + if(abs(errsoi(c)) > .001_kind_phys) then ! 1.e-5_kind_phys) then + WRITE( message,* )'Primary soil energy conservation error in shlake & + column during Tridiagonal Solution,', 'error (W/m^2):', c, errsoi(c) + errmsg=trim(message) + errflg=1 + end if + end do + ! This has to be done before convective mixing because the heat capacities for each layer + ! will get scrambled. + + end if if_debug_energy + + !!!!!!!!!!!!!!!!!!!!!!! + + ! 9!) Phase change + call PhaseChange_Lake (snl,h2osno,dz,dz_lake, & !i + t_soisno,h2osoi_liq,h2osoi_ice, & !i&o + lake_icefrac,t_lake, snowdp, & !i&o + qflx_snomelt,eflx_snomelt,imelt, & !o + cv, cv_lake, & !i&o + lhabs) !o + + !!!!!!!!!!!!!!!!!!!!!!! + + ! 9.5!) Second energy check and water check. Now check energy balance before and after phase + ! change, considering the possibility of changed heat capacity during phase change, by + ! using initial heat capacity in the first step, final heat capacity in the second step, + ! and differences from tfrz only to avoid enthalpy correction for (cpliq-cpice)*melt*tfrz. + ! Also check soil water sum. + + if_debug_balance: if (LAKEDEBUG) then + do j = 1, nlevlake + !dir$ concurrent + !cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + + esum2(c) = esum2(c) - (t_lake(c,j)-tfrz)*cv_lake(c,j) + end do + end do + + do j = -nlevsnow+1, nlevsoil + !dir$ concurrent + !cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + + if (j >= jtop(c)) then + esum2(c) = esum2(c) - (t_soisno(c,j)-tfrz)*cv(c,j) + end if + end do + end do + + !dir$ concurrent + !cdir nodep + do fp = 1, num_shlakep + p = filter_shlakep(fp) + c = pcolumn(p) + ! Again assuming only one pft per column + esum2(c) = esum2(c) - lhabs(c) + errsoi(c) = esum2(c)/dtime + if(abs(errsoi(c)) > 1.e-5_kind_phys) then + write(message,*)'Primary soil energy conservation error in shlake column during Phase Change, error (W/m^2):', & + c, errsoi(c) + errmsg=trim(message) + errflg=1 + end if + end do + + ! Check soil water + ! Sum soil water. + do j = 1, nlevsoil + !dir$ concurrent + !cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + if (j == 1) wsum_end(c) = 0._kind_phys + wsum_end(c) = wsum_end(c) + h2osoi_ice(c,j) + h2osoi_liq(c,j) + if (j == nlevsoil) then + if (abs(wsum(c)-wsum_end(c))>1.e-7_kind_phys) then + write(message,*)'Soil water balance error during phase change in ShalLakeTemperature.', & + 'column, error (kg/m^2):', c, wsum_end(c)-wsum(c) + errmsg=trim(message) + errflg=1 + end if + end if + end do + end do + + endif if_debug_balance + + !!!!!!!!!!!!!!!!!!!!!!!!!! + ! 10!) Convective mixing: make sure fracice*dz is conserved, heat content c*dz*T is conserved, and + ! all ice ends up at the top. Done over all lakes even if frozen. + ! Either an unstable density profile or ice in a layer below an incompletely frozen layer will trigger. + + !Recalculate density + do j = 1, nlevlake + !dir$ concurrent + !cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + rhow(c,j) = (1._kind_phys - lake_icefrac(c,j)) * & + 1000._kind_phys*( 1.0_kind_phys - 1.9549e-05_kind_phys*(abs(t_lake(c,j)-277._kind_phys))**1.68_kind_phys ) & + + lake_icefrac(c,j)*denice + end do + end do + + do j = 1, nlevlake-1 + !dir$ concurrent + !cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + qav(c) = 0._kind_phys + nav(c) = 0._kind_phys + iceav(c) = 0._kind_phys + end do + + do i = 1, j+1 + !dir$ concurrent + !cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + if (rhow(c,j) > rhow(c,j+1) .or. & + (lake_icefrac(c,j) < 1._kind_phys .and. lake_icefrac(c,j+1) > 0._kind_phys) ) then + if(LAKEDEBUG) then + if (i==1) then + print *, 'Convective Mixing in column ', c, '.' + endif + endif + qav(c) = qav(c) + dz_lake(c,i)*(t_lake(c,i)-tfrz) * & + ((1._kind_phys - lake_icefrac(c,i))*cwat + lake_icefrac(c,i)*cice_eff) + ! tav(c) = tav(c) + t_lake(c,i)*dz_lake(c,i) + iceav(c) = iceav(c) + lake_icefrac(c,i)*dz_lake(c,i) + nav(c) = nav(c) + dz_lake(c,i) + end if + end do + end do + + !dir$ concurrent + !cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + if (rhow(c,j) > rhow(c,j+1) .or. & + (lake_icefrac(c,j) < 1._kind_phys .and. lake_icefrac(c,j+1) > 0._kind_phys) ) then + qav(c) = qav(c)/nav(c) + iceav(c) = iceav(c)/nav(c) + !If the average temperature is above freezing, put the extra energy into the water. + !If it is below freezing, take it away from the ice. + if (qav(c) > 0._kind_phys) then + tav_froz(c) = 0._kind_phys !Celsius + tav_unfr(c) = qav(c) / ((1._kind_phys - iceav(c))*cwat) + else if (qav(c) < 0._kind_phys) then + tav_froz(c) = qav(c) / (iceav(c)*cice_eff) + tav_unfr(c) = 0._kind_phys !Celsius + else + tav_froz(c) = 0._kind_phys + tav_unfr(c) = 0._kind_phys + end if + end if + end do + + do i = 1, j+1 + !dir$ concurrent + !cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + if (nav(c) > 0._kind_phys) then + ! if(0==1) then + + !Put all the ice at the top.! + !If the average temperature is above freezing, put the extra energy into the water. + !If it is below freezing, take it away from the ice. + !For the layer with both ice & water, be careful to use the average temperature + !that preserves the correct total heat content given what the heat capacity of that + !layer will actually be. + if (i == 1) zsum(c) = 0._kind_phys + if ((zsum(c)+dz_lake(c,i))/nav(c) <= iceav(c)) then + lake_icefrac(c,i) = 1._kind_phys + t_lake(c,i) = tav_froz(c) + tfrz + else if (zsum(c)/nav(c) < iceav(c)) then + lake_icefrac(c,i) = (iceav(c)*nav(c) - zsum(c)) / dz_lake(c,i) + ! Find average value that preserves correct heat content. + t_lake(c,i) = ( lake_icefrac(c,i)*tav_froz(c)*cice_eff & + + (1._kind_phys - lake_icefrac(c,i))*tav_unfr(c)*cwat ) & + / ( lake_icefrac(c,i)*cice_eff + (1-lake_icefrac(c,i))*cwat ) + tfrz + else + lake_icefrac(c,i) = 0._kind_phys + t_lake(c,i) = tav_unfr(c) + tfrz + end if + zsum(c) = zsum(c) + dz_lake(c,i) + + rhow(c,i) = (1._kind_phys - lake_icefrac(c,i)) * & + 1000._kind_phys*( 1.0_kind_phys - 1.9549e-05_kind_phys*(abs(t_lake(c,i)-277._kind_phys))**1.68_kind_phys ) & + + lake_icefrac(c,i)*denice + end if + end do + end do + end do + + !!!!!!!!!!!!!!!!!!!!!!! + ! 11!) Re-evaluate thermal properties and sum energy content. + ! For lake + do j = 1, nlevlake + !dir$ concurrent + !cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + + cv_lake(c,j) = dz_lake(c,j) * (cwat*(1._kind_phys-lake_icefrac(c,j)) + cice_eff*lake_icefrac(c,j)) + if (LAKEDEBUG) then + print *,'Lake Ice Fraction, c, level:', c, j, lake_icefrac(c,j) + endif + end do + end do + ! For snow / soil + ! call SoilThermProp_Lake(lbc, ubc, num_shlakec, filter_shlakec, tk, cv, tktopsoillay) + call SoilThermProp_Lake (snl,dz,zi,z,t_soisno,h2osoi_liq,h2osoi_ice, & + tk, cv, tktopsoillay,errmsg,errflg) + + + ! Do as above to sum energy content + do j = 1, nlevlake + !dir$ concurrent + !cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + + ! ncvts(c) = ncvts(c) + cv_lake(c,j)*t_lake(c,j) & + ncvts(c) = ncvts(c) + cv_lake(c,j)*(t_lake(c,j)-tfrz) & + + cfus*dz_lake(c,j)*(1._kind_phys-lake_icefrac(c,j)) !& + ! + (cwat-cice_eff)*lake_icefrac(c)*tfrz*dz_lake(c,j) !enthalpy reconciliation term + fin(c) = fin(c) + phi(c,j) + end do + end do + + do j = -nlevsnow + 1, nlevsoil + !dir$ concurrent + !cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + + if (j >= jtop(c)) then + ! ncvts(c) = ncvts(c) + cv(c,j)*t_soisno(c,j) & + ncvts(c) = ncvts(c) + cv(c,j)*(t_soisno(c,j)-tfrz) & + + hfus*h2osoi_liq(c,j) !& + ! + (cpliq-cpice)*h2osoi_ice(c,j)*tfrz !enthalpy reconciliation term + if (j == 1 .and. h2osno(c) > 0._kind_phys .and. j == jtop(c)) then + ncvts(c) = ncvts(c) - h2osno(c)*hfus + end if + end if + if (j == 1) fin(c) = fin(c) + phi_soil(c) + end do + end do + + + ! Check energy conservation. + + do fp = 1, num_shlakep + p = filter_shlakep(fp) + c = pcolumn(p) + errsoi(c) = (ncvts(c)-ocvts(c)) / dtime - fin(c) + if( (LAKEDEBUG .and. abs(errsoi(c)) < 1._kind_phys) & + .or. (.not.LAKEDEBUG .and. abs(errsoi(c)) < 10._kind_phys)) then + eflx_sh_tot(p) = eflx_sh_tot(p) - errsoi(c) + eflx_sh_grnd(p) = eflx_sh_grnd(p) - errsoi(c) + eflx_soil_grnd(p) = eflx_soil_grnd(p) + errsoi(c) + eflx_gnet(p) = eflx_gnet(p) + errsoi(c) + ! if (abs(errsoi(c)) > 1.e-3_kind_phys) then + if (abs(errsoi(c)) > 1.e-1_kind_phys) then + print *,'errsoi incorporated into sensible heat in ShalLakeTemperature: c, (W/m^2):', c, errsoi(c) + end if + errsoi(c) = 0._kind_phys + else if(LAKEDEBUG) then + print *,'Soil Energy Balance Error at column, ', c, 'G, fintotal, column E tendency = ', & + eflx_gnet(p), fin(c), (ncvts(c)-ocvts(c)) / dtime + end if + end do + ! This loop assumes only one point per column. + + end subroutine ShalLakeTemperature + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !----------------------------------------------------------------------- + !BOP + ! + ! ROUTINE: SoilThermProp_Lake + ! + ! !INTERFACE: + subroutine SoilThermProp_Lake (snl,dz,zi,z,t_soisno,h2osoi_liq,h2osoi_ice, & + tk, cv, tktopsoillay,errmsg,errflg) + + ! + ! !DESCRIPTION: + ! Calculation of thermal conductivities and heat capacities of + ! snow/soil layers + ! (1) The volumetric heat capacity is calculated as a linear combination + ! in terms of the volumetric fraction of the constituent phases. + ! + ! (2) The thermal conductivity of soil is computed from the algorithm of + ! Johansen (as reported by Farouki 1981), and of snow is from the + ! formulation used in SNTHERM (Jordan 1991). + ! The thermal conductivities at the interfaces between two neighboring + ! layers (j, j+1) are derived from an assumption that the flux across + ! the interface is equal to that from the node j to the interface and the + ! flux from the interface to the node j+1. + ! + ! For lakes, the proper soil layers (not snow) should always be saturated. + ! + ! !USES: + + implicit none + !in + + integer, intent(inout) :: errflg + character(*), intent(inout) :: errmsg + integer , intent(in) :: snl(1) ! number of snow layers + ! real(kind_phys), intent(in) :: h2osno(1) ! snow water (mm H2O) + ! real(kind_phys), intent(in) :: watsat(1,nlevsoil) ! volumetric soil water at saturation (porosity) + ! real(kind_phys), intent(in) :: tksatu(1,nlevsoil) ! thermal conductivity, saturated soil [W/m-K] + ! real(kind_phys), intent(in) :: tkmg(1,nlevsoil) ! thermal conductivity, soil minerals [W/m-K] + ! real(kind_phys), intent(in) :: tkdry(1,nlevsoil) ! thermal conductivity, dry soil (W/m/Kelvin) + ! real(kind_phys), intent(in) :: csol(1,nlevsoil) ! heat capacity, soil solids (J/m**3/Kelvin) + real(kind_phys), intent(in) :: dz(1,-nlevsnow+1:nlevsoil) ! layer thickness (m) + real(kind_phys), intent(in) :: zi(1,-nlevsnow+0:nlevsoil) ! interface level below a "z" level (m) + real(kind_phys), intent(in) :: z(1,-nlevsnow+1:nlevsoil) ! layer depth (m) + real(kind_phys), intent(in) :: t_soisno(1,-nlevsnow+1:nlevsoil) ! soil temperature (Kelvin) + real(kind_phys), intent(in) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) ! liquid water (kg/m2) + real(kind_phys), intent(in) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) ! ice lens (kg/m2) + + !out + real(kind_phys), intent(out) :: cv(lbc:ubc,-nlevsnow+1:nlevsoil) ! heat capacity [J/(m2 K)] + real(kind_phys), intent(out) :: tk(lbc:ubc,-nlevsnow+1:nlevsoil) ! thermal conductivity [W/(m K)] + real(kind_phys), intent(out) :: tktopsoillay(lbc:ubc) ! thermal conductivity [W/(m K)] + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! !CALLED FROM: + ! subroutine ShalLakeTemperature in this module. + ! + ! !REVISION HISTORY: + ! 15 September 1999: Yongjiu Dai; Initial code + ! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision + ! 2/13/02, Peter Thornton: migrated to new data structures + ! 7/01/03, Mariana Vertenstein: migrated to vector code + ! 4/09, Zack Subin, adjustment for ShalLake code. + ! June 2022, Sam Trahan updated for CCPP + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! !LOCAL VARIABLES: + ! + ! local pointers to original implicit in scalars + ! + ! integer , pointer :: clandunit(:) ! column's landunit + ! integer , pointer :: ityplun(:) ! landunit type + ! + !EOP + + + ! OTHER LOCAL VARIABLES: + + integer :: l,c,j ! indices + integer :: fc ! lake filtered column indices + real(kind_phys) :: bw ! partial density of water (ice + liquid) + real(kind_phys) :: dksat ! thermal conductivity for saturated soil (j/(k s m)) + real(kind_phys) :: dke ! kersten number + real(kind_phys) :: fl ! fraction of liquid or unfrozen water to total water + real(kind_phys) :: satw ! relative total water content of soil. + real(kind_phys) :: thk(lbc:ubc,-nlevsnow+1:nlevsoil) ! thermal conductivity of layer + character*256 :: message + + real(kind_phys) :: denom + + ! Thermal conductivity of soil from Farouki (1981) + + do j = -nlevsnow+1,nlevsoil + !dir$ concurrent + !cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + + ! Only examine levels from 1->nlevsoil + if (j >= 1) then + ! l = clandunit(c) + ! if (ityplun(l) /= istwet .AND. ityplun(l) /= istice) then + ! This could be altered later for allowing this to be over glaciers. + + ! Soil should be saturated. + if (LAKEDEBUG) then + satw = (h2osoi_liq(c,j)/denh2o + h2osoi_ice(c,j)/denice)/(dz(c,j)*watsat(c,j)) + ! satw = min(1._kind_phys, satw) + if (satw < 0.999_kind_phys) then + write(message,*)'WARNING: soil layer unsaturated in SoilThermProp_Lake, satw, j = ', satw, j + errmsg=trim(message) + errflg=1 + end if + ! Could use denice because if it starts out frozen, the volume of water will go below sat., + ! since we're not yet doing excess ice. + ! But take care of this in HydrologyLake. + endif + satw = 1._kind_phys + denom = (h2osoi_ice(c,j)+h2osoi_liq(c,j)) + if(denom>zero_h2o) then + fl = h2osoi_liq(c,j)/denom + else + write(message,'(A,I0)') 'WARNING: zero h2osoi_ice+h2osoi_liq at j = ', j + errmsg=trim(message) + errflg=1 + fl = 0 + endif + if (t_soisno(c,j) >= tfrz) then ! Unfrozen soil + dke = max(0._kind_phys, log10(satw) + 1.0_kind_phys) + dksat = tksatu(c,j) + else ! Frozen soil + dke = satw + dksat = tkmg(c,j)*0.249_kind_phys**(fl*watsat(c,j))*2.29_kind_phys**watsat(c,j) + endif + thk(c,j) = dke*dksat + (1._kind_phys-dke)*tkdry(c,j) + ! else + ! thk(c,j) = tkwat + ! if (t_soisno(c,j) < tfrz) thk(c,j) = tkice + ! endif + endif + + ! Thermal conductivity of snow, which from Jordan (1991) pp. 18 + ! Only examine levels from snl(c)+1 -> 0 where snl(c) < 1 + if (snl(c)+1 < 1 .AND. (j >= snl(c)+1) .AND. (j <= 0)) then + bw = (h2osoi_ice(c,j)+h2osoi_liq(c,j))/dz(c,j) + thk(c,j) = tkairc + (7.75e-5_kind_phys *bw + 1.105e-6_kind_phys*bw*bw)*(tkice-tkairc) + end if + + end do + end do + + ! Thermal conductivity at the layer interface + + ! Have to correct for the fact that bottom snow layer and top soil layer border lake. + ! For the first case, the snow layer conductivity for the middle of the layer will be returned. + ! Because the interfaces are below the soil layers, the conductivity for the top soil layer + ! will have to be returned separately. + do j = -nlevsnow+1,nlevsoil + !dir$ concurrent + !cdir nodep + do fc = 1,num_shlakec + c = filter_shlakec(fc) + if (j >= snl(c)+1 .AND. j <= nlevsoil-1 .AND. j /= 0) then + tk(c,j) = thk(c,j)*thk(c,j+1)*(z(c,j+1)-z(c,j)) & + /(thk(c,j)*(z(c,j+1)-zi(c,j))+thk(c,j+1)*(zi(c,j)-z(c,j))) + else if (j == 0) then + tk(c,j) = thk(c,j) + else if (j == nlevsoil) then + tk(c,j) = 0._kind_phys + end if + ! For top soil layer. + if (j == 1) tktopsoillay(c) = thk(c,j) + end do + end do + + ! Soil heat capacity, from de Vires (1963) + + do j = 1, nlevsoil + !dir$ concurrent + !cdir nodep + do fc = 1,num_shlakec + c = filter_shlakec(fc) + ! l = clandunit(c) + ! if (ityplun(l) /= istwet .AND. ityplun(l) /= istice) then + cv(c,j) = csol(c,j)*(1-watsat(c,j))*dz(c,j) + & + (h2osoi_ice(c,j)*cpice + h2osoi_liq(c,j)*cpliq) + ! else + ! cv(c,j) = (h2osoi_ice(c,j)*cpice + h2osoi_liq(c,j)*cpliq) + ! endif + ! if (j == 1) then + ! if (snl(c)+1 == 1 .AND. h2osno(c) > 0._kind_phys) then + ! cv(c,j) = cv(c,j) + cpice*h2osno(c) + ! end if + ! end if + ! Won't worry about heat capacity for thin snow on lake with no snow layers. + enddo + end do + + ! Snow heat capacity + + do j = -nlevsnow+1,0 + !dir$ concurrent + !cdir nodep + do fc = 1,num_shlakec + c = filter_shlakec(fc) + if (snl(c)+1 < 1 .and. j >= snl(c)+1) then + cv(c,j) = cpliq*h2osoi_liq(c,j) + cpice*h2osoi_ice(c,j) + end if + end do + end do + + end subroutine SoilThermProp_Lake + + + !----------------------------------------------------------------------- + !BOP + ! + ! ROUTINE: PhaseChange_Lake + ! + ! !INTERFACE: + subroutine PhaseChange_Lake (snl,h2osno,dz,dz_lake, & !i + t_soisno,h2osoi_liq,h2osoi_ice, & !i&o + lake_icefrac,t_lake, snowdp, & !i&o + qflx_snomelt,eflx_snomelt,imelt, & !o + cv, cv_lake, & !i&o + lhabs) !o + !============================================================================================= + ! !DESCRIPTION: + ! Calculation of the phase change within snow, soil, & lake layers: + ! (1) Check the conditions for which the phase change may take place, + ! i.e., the layer temperature is great than the freezing point + ! and the ice mass is not equal to zero (i.e. melting), + ! or the layer temperature is less than the freezing point + ! and the liquid water mass is greater than the allowable supercooled + ! (i.e. freezing). + ! (2) Assess the amount of phase change from the energy excess (or deficit) + ! after setting the layer temperature to freezing point, depending on + ! how much water or ice is available. + ! (3) Re-adjust the ice and liquid mass, and the layer temperature: either to + ! the freezing point if enough water or ice is available to fully compensate, + ! or to a remaining temperature. + ! The specific heats are assumed constant. Potential cycling errors resulting from + ! this assumption will be trapped at the end of ShalLakeTemperature. + ! !CALLED FROM: + ! subroutine ShalLakeTemperature in this module + ! + ! !REVISION HISTORY: + ! 04/2009 Zack Subin: Initial code + ! June 2022 Sam Trahan: Modified for CCPP + !============================================================================================== + ! !USES: + ! + ! !ARGUMENTS: + implicit none + !in: + + integer , intent(in) :: snl(1) !number of snow layers + real(kind_phys), intent(inout) :: h2osno(1) !snow water (mm H2O) + real(kind_phys), intent(in) :: dz(1,-nlevsnow+1:nlevsoil) !layer thickness (m) + real(kind_phys), intent(in) :: dz_lake(1,nlevlake) !lake layer thickness (m) + ! Needed in case snow height is less than critical value. + + !inout: + + real(kind_phys), intent(inout) :: snowdp(1) !snow height (m) + real(kind_phys), intent(inout) :: t_soisno(1,-nlevsnow+1:nlevsoil) !soil temperature (Kelvin) + real(kind_phys), intent(inout) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) !liquid water (kg/m2) + real(kind_phys), intent(inout) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) !ice lens (kg/m2) + real(kind_phys), intent(inout) :: lake_icefrac(1,nlevlake) ! mass fraction of lake layer that is frozen + real(kind_phys), intent(inout) :: t_lake(1,nlevlake) ! lake temperature (Kelvin) + !out: + + real(kind_phys), intent(out) :: qflx_snomelt(1) !snow melt (mm H2O /s) + real(kind_phys), intent(out) :: eflx_snomelt(1) !snow melt heat flux (W/m**2) + integer, intent(out) :: imelt(1,-nlevsnow+1:nlevsoil) !flag for melting (=1), freezing (=2), Not=0 (new) + !What's the sign of this? Is it just output? + real(kind_phys), intent(inout) :: cv(lbc:ubc,-nlevsnow+1:nlevsoil) ! heat capacity [J/(m2 K)] + real(kind_phys), intent(inout) :: cv_lake (lbc:ubc,1:nlevlake) ! heat capacity [J/(m2 K)] + real(kind_phys), intent(out):: lhabs(lbc:ubc) ! total per-column latent heat abs. (J/m^2) + + + ! OTHER LOCAL VARIABLES: + + integer :: j,c,g !do loop index + integer :: fc !lake filtered column indices + ! real(kind_phys) :: dtime !land model time step (sec) + real(kind_phys) :: heatavail !available energy for melting or freezing (J/m^2) + real(kind_phys) :: heatrem !energy residual or loss after melting or freezing + real(kind_phys) :: melt !actual melting (+) or freezing (-) [kg/m2] + real(kind_phys), parameter :: smallnumber = 1.e-7_kind_phys !to prevent tiny residuals from rounding error + logical :: dophasechangeflag + !----------------------------------------------------------------------- + + ! dtime = get_step_size() + + ! Initialization + + !dir$ concurrent + !cdir nodep + do fc = 1,num_shlakec + c = filter_shlakec(fc) + + qflx_snomelt(c) = 0._kind_phys + eflx_snomelt(c) = 0._kind_phys + lhabs(c) = 0._kind_phys + end do + + do j = -nlevsnow+1,0 + !dir$ concurrent + !cdir nodep + do fc = 1,num_shlakec + c = filter_shlakec(fc) + + if (j >= snl(c) + 1) imelt(c,j) = 0 + end do + end do + + ! Check for case of snow without snow layers and top lake layer temp above freezing. + + !dir$ concurrent + !cdir nodep + do fc = 1,num_shlakec + c = filter_shlakec(fc) + + if (snl(c) == 0 .and. h2osno(c) > 0._kind_phys .and. t_lake(c,1) > tfrz) then + heatavail = (t_lake(c,1) - tfrz) * cv_lake(c,1) + melt = min(h2osno(c), heatavail/hfus) + heatrem = max(heatavail - melt*hfus, 0._kind_phys) + !catch small negative value to keep t at tfrz + t_lake(c,1) = tfrz + heatrem/(cv_lake(c,1)) + snowdp(c) = snowdp(c)*(1._kind_phys - melt/h2osno(c)) + h2osno(c) = h2osno(c) - melt + lhabs(c) = lhabs(c) + melt*hfus + qflx_snomelt(c) = qflx_snomelt(c) + melt + ! Prevent tiny residuals + if (h2osno(c) < smallnumber) h2osno(c) = 0._kind_phys + if (snowdp(c) < smallnumber) snowdp(c) = 0._kind_phys + end if + end do + + ! Lake phase change + + do j = 1,nlevlake + !dir$ concurrent + !cdir nodep + do fc = 1,num_shlakec + c = filter_shlakec(fc) + + dophasechangeflag = .false. + if (t_lake(c,j) > tfrz .and. lake_icefrac(c,j) > 0._kind_phys) then ! melting + dophasechangeflag = .true. + heatavail = (t_lake(c,j) - tfrz) * cv_lake(c,j) + melt = min(lake_icefrac(c,j)*denh2o*dz_lake(c,j), heatavail/hfus) + !denh2o is used because layer thickness is not adjusted for freezing + heatrem = max(heatavail - melt*hfus, 0._kind_phys) + !catch small negative value to keep t at tfrz + else if (t_lake(c,j) < tfrz .and. lake_icefrac(c,j) < 1._kind_phys) then !freezing + dophasechangeflag = .true. + heatavail = (t_lake(c,j) - tfrz) * cv_lake(c,j) + melt = max(-(1._kind_phys-lake_icefrac(c,j))*denh2o*dz_lake(c,j), heatavail/hfus) + !denh2o is used because layer thickness is not adjusted for freezing + heatrem = min(heatavail - melt*hfus, 0._kind_phys) + !catch small positive value to keep t at tfrz + end if + ! Update temperature and ice fraction. + if (dophasechangeflag) then + lake_icefrac(c,j) = lake_icefrac(c,j) - melt/(denh2o*dz_lake(c,j)) + lhabs(c) = lhabs(c) + melt*hfus + ! Update heat capacity + cv_lake(c,j) = cv_lake(c,j) + melt*(cpliq-cpice) + t_lake(c,j) = tfrz + heatrem/cv_lake(c,j) + ! Prevent tiny residuals + if (lake_icefrac(c,j) > 1._kind_phys - smallnumber) lake_icefrac(c,j) = 1._kind_phys + if (lake_icefrac(c,j) < smallnumber) lake_icefrac(c,j) = 0._kind_phys + end if + end do + end do + + ! Snow & soil phase change + + do j = -nlevsnow+1,nlevsoil + !dir$ concurrent + !cdir nodep + do fc = 1,num_shlakec + c = filter_shlakec(fc) + dophasechangeflag = .false. + + if (j >= snl(c) + 1) then + + if (t_soisno(c,j) > tfrz .and. h2osoi_ice(c,j) > 0._kind_phys) then ! melting + dophasechangeflag = .true. + heatavail = (t_soisno(c,j) - tfrz) * cv(c,j) + melt = min(h2osoi_ice(c,j), heatavail/hfus) + heatrem = max(heatavail - melt*hfus, 0._kind_phys) + !catch small negative value to keep t at tfrz + if (j <= 0) then !snow + imelt(c,j) = 1 + qflx_snomelt(c) = qflx_snomelt(c) + melt + end if + else if (t_soisno(c,j) < tfrz .and. h2osoi_liq(c,j) > 0._kind_phys) then !freezing + dophasechangeflag = .true. + heatavail = (t_soisno(c,j) - tfrz) * cv(c,j) + melt = max(-h2osoi_liq(c,j), heatavail/hfus) + heatrem = min(heatavail - melt*hfus, 0._kind_phys) + !catch small positive value to keep t at tfrz + if (j <= 0) then !snow + imelt(c,j) = 2 + qflx_snomelt(c) = qflx_snomelt(c) + melt + ! Does this works for both signs of melt in SnowHydrology? I think + ! qflx_snomelt(c) is just output. + end if + end if + + ! Update temperature and soil components. + if (dophasechangeflag) then + h2osoi_ice(c,j) = h2osoi_ice(c,j) - melt + h2osoi_liq(c,j) = h2osoi_liq(c,j) + melt + lhabs(c) = lhabs(c) + melt*hfus + ! Update heat capacity + cv(c,j) = cv(c,j) + melt*(cpliq-cpice) + t_soisno(c,j) = tfrz + heatrem/cv(c,j) + ! Prevent tiny residuals + if (h2osoi_ice(c,j) < smallnumber) h2osoi_ice(c,j) = 0._kind_phys + if (h2osoi_liq(c,j) < smallnumber) h2osoi_liq(c,j) = 0._kind_phys + end if + + end if + end do + end do + + ! Update eflx_snomelt(c) + !dir$ concurrent + !cdir nodep + do fc = 1,num_shlakec + c = filter_shlakec(fc) + eflx_snomelt(c) = qflx_snomelt(c)*hfus + end do + !!! + + end subroutine PhaseChange_Lake + + + subroutine ShalLakeHydrology(dz_lake,forc_rain,forc_snow, & !i + begwb,qflx_evap_tot,forc_t,do_capsnow, & + t_grnd,qflx_evap_soi, & + qflx_snomelt,imelt,frac_iceold, & !i add by guhp + z,dz,zi,snl,h2osno,snowdp,lake_icefrac,t_lake, & !i&o + endwb,snowage,snowice,snowliq,t_snow, & !o + t_soisno,h2osoi_ice,h2osoi_liq,h2osoi_vol, & + qflx_drain,qflx_surf,qflx_infl,qflx_qrgwl, & + qcharge,qflx_prec_grnd,qflx_snowcap, & + qflx_snowcap_col,qflx_snow_grnd_pft, & + qflx_snow_grnd_col,qflx_rain_grnd, & + qflx_evap_tot_col,soilalpha,zwt,fcov, & + rootr_column,qflx_evap_grnd,qflx_sub_snow, & + qflx_dew_snow,qflx_dew_grnd,qflx_rain_grnd_col, & + errmsg,errflg) + + !================================================================================== + ! !DESCRIPTION: + ! Calculation of Shallow Lake Hydrology. Full hydrology of snow layers is + ! done. However, there is no infiltration, and the water budget is balanced with + ! qflx_qrgwl. Lake water mass is kept constant. The soil is simply maintained at + ! volumetric saturation if ice melting frees up pore space. Likewise, if the water + ! portion alone at some point exceeds pore capacity, it is reduced. This is consistent + ! with the possibility of initializing the soil layer with excess ice. The only + ! real error with that is that the thermal conductivity will ignore the excess ice + ! (and accompanying thickness change). + ! + ! If snow layers are present over an unfrozen lake, and the top layer of the lake + ! is capable of absorbing the latent heat without going below freezing, + ! the snow-water is runoff and the latent heat is subtracted from the lake. + ! + ! WARNING: This subroutine assumes lake columns have one and only one pft. + ! + ! Sequence is: + ! ShalLakeHydrology: + ! Do needed tasks from Hydrology1, Biogeophysics2, & top of Hydrology2. + ! -> SnowWater: change of snow mass and snow water onto soil + ! -> SnowCompaction: compaction of snow layers + ! -> CombineSnowLayers: combine snow layers that are thinner than minimum + ! -> DivideSnowLayers: subdivide snow layers that are thicker than maximum + ! Add water to soil if melting has left it with open pore space. + ! Cleanup and do water balance. + ! If snow layers are found above a lake with unfrozen top layer, whose top + ! layer has enough heat to melt all the snow ice without freezing, do so + ! and eliminate the snow layers. + ! + ! !REVISION HISTORY: + ! Created by Zack Subin, 2009 + ! + !============================================================================================ + + ! USES: + ! + implicit none + + ! in: + + integer, intent(inout) :: errflg + character(*), intent(inout) :: errmsg + + ! integer , intent(in) :: clandunit(1) ! column's landunit + ! integer , intent(in) :: ityplun(1) ! landunit type + ! real(kind_phys), intent(in) :: watsat(1,1:nlevsoil) ! volumetric soil water at saturation (porosity) + real(kind_phys), intent(in) :: dz_lake(1,nlevlake) ! layer thickness for lake (m) + real(kind_phys), intent(in) :: forc_rain(1) ! rain rate [mm/s] + real(kind_phys), intent(in) :: forc_snow(1) ! snow rate [mm/s] + real(kind_phys), intent(in) :: qflx_evap_tot(1) ! qflx_evap_soi + qflx_evap_veg + qflx_tran_veg + real(kind_phys), intent(in) :: forc_t(1) ! atmospheric temperature (Kelvin) + + !real(kind_phys), intent(in),optional :: flfall(1) ! fraction of liquid water within falling precipitation (unused) + + logical , intent(in) :: do_capsnow(1) ! true => do snow capping + real(kind_phys), intent(in) :: t_grnd(1) ! ground temperature (Kelvin) + real(kind_phys), intent(in) :: qflx_evap_soi(1) ! soil evaporation (mm H2O/s) (+ = to atm) + real(kind_phys), intent(in) :: qflx_snomelt(1) !snow melt (mm H2O /s) + integer, intent(in) :: imelt(1,-nlevsnow+1:nlevsoil) !flag for melting (=1), freezing (=2), Not=0 + + !inout: + + real(kind_phys), intent(inout) :: begwb(1) ! water mass begining of the time step + + ! inout: + + + real(kind_phys), intent(inout) :: z(1,-nlevsnow+1:nlevsoil) ! layer depth (m) + real(kind_phys), intent(inout) :: dz(1,-nlevsnow+1:nlevsoil) ! layer thickness depth (m) + real(kind_phys), intent(inout) :: zi(1,-nlevsnow+0:nlevsoil) ! interface depth (m) + integer , intent(inout) :: snl(1) ! number of snow layers + real(kind_phys), intent(inout) :: h2osno(1) ! snow water (mm H2O) + real(kind_phys), intent(inout) :: snowdp(1) ! snow height (m) + real(kind_phys), intent(inout) :: lake_icefrac(1,nlevlake) ! mass fraction of lake layer that is frozen + real(kind_phys), intent(inout) :: t_lake(1,nlevlake) ! lake temperature (Kelvin) + + real(kind_phys), intent(inout) :: frac_iceold(1,-nlevsnow+1:nlevsoil) ! fraction of ice relative to the tot water + ! out: + + + real(kind_phys), intent(out) :: endwb(1) ! water mass end of the time step + real(kind_phys), intent(out) :: snowage(1) ! non dimensional snow age [-] + real(kind_phys), intent(out) :: snowice(1) ! average snow ice lens + real(kind_phys), intent(out) :: snowliq(1) ! average snow liquid water + real(kind_phys), intent(out) :: t_snow(1) ! vertically averaged snow temperature + real(kind_phys), intent(out) :: t_soisno(1,-nlevsnow+1:nlevsoil) ! snow temperature (Kelvin) + real(kind_phys), intent(out) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) ! ice lens (kg/m2) + real(kind_phys), intent(out) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) ! liquid water (kg/m2) + real(kind_phys), intent(out) :: h2osoi_vol(1,-nlevsnow+1:nlevsoil) ! volumetric soil water (0<=h2osoi_vol<=watsat)[m3/m3] + real(kind_phys), intent(out) :: qflx_drain(1) ! sub-surface runoff (mm H2O /s) + real(kind_phys), intent(out) :: qflx_surf(1) ! surface runoff (mm H2O /s) + real(kind_phys), intent(out) :: qflx_infl(1) ! infiltration (mm H2O /s) + real(kind_phys), intent(out) :: qflx_qrgwl(1) ! qflx_surf at glaciers, wetlands, lakes + real(kind_phys), intent(out) :: qcharge(1) ! aquifer recharge rate (mm/s) + real(kind_phys), intent(out) :: qflx_prec_grnd(1) ! water onto ground including canopy runoff [kg/(m2 s)] + real(kind_phys), intent(out) :: qflx_snowcap(1) ! excess precipitation due to snow capping (mm H2O /s) [+] + real(kind_phys), intent(out) :: qflx_snowcap_col(1) ! excess precipitation due to snow capping (mm H2O /s) [+] + real(kind_phys), intent(out) :: qflx_snow_grnd_pft(1) ! snow on ground after interception (mm H2O/s) [+] + real(kind_phys), intent(out) :: qflx_snow_grnd_col(1) ! snow on ground after interception (mm H2O/s) [+] + real(kind_phys), intent(out) :: qflx_rain_grnd(1) ! rain on ground after interception (mm H2O/s) [+] + real(kind_phys), intent(out) :: qflx_evap_tot_col(1) !pft quantity averaged to the column (assuming one pft) + real(kind_phys) ,intent(out) :: soilalpha(1) !factor that reduces ground saturated specific humidity (-) + real(kind_phys), intent(out) :: zwt(1) !water table depth + real(kind_phys), intent(out) :: fcov(1) !fractional area with water table at surface + real(kind_phys), intent(out) :: rootr_column(1,1:nlevsoil) !effective fraction of roots in each soil layer + real(kind_phys), intent(out) :: qflx_evap_grnd(1) ! ground surface evaporation rate (mm H2O/s) [+] + real(kind_phys), intent(out) :: qflx_sub_snow(1) ! sublimation rate from snow pack (mm H2O /s) [+] + real(kind_phys), intent(out) :: qflx_dew_snow(1) ! surface dew added to snow pack (mm H2O /s) [+] + real(kind_phys), intent(out) :: qflx_dew_grnd(1) ! ground surface dew formation (mm H2O /s) [+] + real(kind_phys), intent(out) :: qflx_rain_grnd_col(1) !rain on ground after interception (mm H2O/s) [+] + + ! Block of biogeochem currently not used. + real(kind_phys), pointer :: sucsat(:,:) ! minimum soil suction (mm) + real(kind_phys), pointer :: bsw(:,:) ! Clapp and Hornberger "b" + real(kind_phys), pointer :: bsw2(:,:) ! Clapp and Hornberger "b" for CN code + real(kind_phys), pointer :: psisat(:,:) ! soil water potential at saturation for CN code (MPa) + real(kind_phys), pointer :: vwcsat(:,:) ! volumetric water content at saturation for CN code (m3/m3) + real(kind_phys), pointer :: wf(:) ! soil water as frac. of whc for top 0.5 m + real(kind_phys), pointer :: soilpsi(:,:) ! soil water potential in each soil layer (MPa) + + ! OTHER LOCAL VARIABLES: + + integer :: p,fp,g,l,c,j,fc,jtop ! indices + integer :: num_shlakesnowc ! number of column snow points + integer :: filter_shlakesnowc(ubc-lbc+1) ! column filter for snow points + integer :: num_shlakenosnowc ! number of column non-snow points + integer :: filter_shlakenosnowc(ubc-lbc+1) ! column filter for non-snow points + ! real(kind_phys) :: dtime ! land model time step (sec) + integer :: newnode ! flag when new snow node is set, (1=yes, 0=no) + real(kind_phys) :: dz_snowf ! layer thickness rate change due to precipitation [mm/s] + real(kind_phys) :: bifall ! bulk density of newly fallen dry snow [kg/m3] + real(kind_phys) :: fracsnow(lbp:ubp) ! frac of precipitation that is snow + real(kind_phys) :: fracrain(lbp:ubp) ! frac of precipitation that is rain + real(kind_phys) :: qflx_prec_grnd_snow(lbp:ubp) ! snow precipitation incident on ground [mm/s] + real(kind_phys) :: qflx_prec_grnd_rain(lbp:ubp) ! rain precipitation incident on ground [mm/s] + real(kind_phys) :: qflx_evap_soi_lim ! temporary evap_soi limited by top snow layer content [mm/s] + real(kind_phys) :: h2osno_temp ! temporary h2osno [kg/m^2] + real(kind_phys) :: sumsnowice(lbc:ubc) ! sum of snow ice if snow layers found above unfrozen lake [kg/m&2] + logical :: unfrozen(lbc:ubc) ! true if top lake layer is unfrozen with snow layers above + real(kind_phys) :: heatrem ! used in case above [J/m^2] + real(kind_phys) :: heatsum(lbc:ubc) ! used in case above [J/m^2] + real(kind_phys) :: qflx_top_soil(1) !net water input into soil from top (mm/s) + character*256 :: message + + real(kind_phys),allocatable :: snow_water(:) ! temporary sum of snow water for Bal Check [kg/m^2] + !----------------------------------------------------------------------- + + ! Determine step size + + ! dtime = get_step_size() + + ! Add soil water to water balance. + do j = 1, nlevsoil + !dir$ concurrent + !cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + begwb(c) = begwb(c) + h2osoi_ice(c,j) + h2osoi_liq(c,j) + end do + end do + + !!!!!!!!!!!!!!!!!!!!!!!!!!! + + ! Do precipitation onto ground, etc., from Hydrology1. + + !dir$ concurrent + !cdir nodep + do fp = 1, num_shlakep + p = filter_shlakep(fp) + g = pgridcell(p) + ! l = plandunit(p) + c = pcolumn(p) + + ! Precipitation onto ground (kg/(m2 s)) + ! ! PET, 1/18/2005: Added new terms for mass balance correction + ! ! due to dynamic pft weight shifting (column-level h2ocan_loss) + ! ! Because the fractionation between rain and snow is indeterminate if + ! ! rain + snow = 0, I am adding this very small flux only to the rain + ! ! components. + ! Not relevant unless PFTs are added to lake later. + ! if (frac_veg_nosno(p) == 0) then + qflx_prec_grnd_snow(p) = forc_snow(g) + qflx_prec_grnd_rain(p) = forc_rain(g) !+ h2ocan_loss(c) + ! else + ! qflx_prec_grnd_snow(p) = qflx_through_snow(p) + (qflx_candrip(p) * fracsnow(p)) + ! qflx_prec_grnd_rain(p) = qflx_through_rain(p) + (qflx_candrip(p) * fracrain(p)) + h2ocan_loss(c) + ! end if + qflx_prec_grnd(p) = qflx_prec_grnd_snow(p) + qflx_prec_grnd_rain(p) + + if (do_capsnow(c)) then + qflx_snowcap(p) = qflx_prec_grnd_snow(p) + qflx_prec_grnd_rain(p) + qflx_snow_grnd_pft(p) = 0._kind_phys + qflx_rain_grnd(p) = 0._kind_phys + else + qflx_snowcap(p) = 0._kind_phys + qflx_snow_grnd_pft(p) = qflx_prec_grnd_snow(p) ! ice onto ground (mm/s) + qflx_rain_grnd(p) = qflx_prec_grnd_rain(p) ! liquid water onto ground (mm/s) + end if + ! Assuming one PFT; needed for below + qflx_snow_grnd_col(c) = qflx_snow_grnd_pft(p) + qflx_rain_grnd_col(c) = qflx_rain_grnd(p) + + end do ! (end pft loop) + + ! Determine snow height and snow water + + !dir$ concurrent + !cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + ! l = clandunit(c) + g = cgridcell(c) + + ! Use Alta relationship, Anderson(1976); LaChapelle(1961), + ! U.S.Department of Agriculture Forest Service, Project F, + ! Progress Rep. 1, Alta Avalanche Study Center:Snow Layer Densification. + + if (do_capsnow(c)) then + dz_snowf = 0._kind_phys + else + if (forc_t(g) > tfrz + 2._kind_phys) then + bifall=50._kind_phys + 1.7_kind_phys*(17.0_kind_phys)**1.5_kind_phys + else if (forc_t(g) > tfrz - 15._kind_phys) then + bifall=50._kind_phys + 1.7_kind_phys*(forc_t(g) - tfrz + 15._kind_phys)**1.5_kind_phys + else + bifall=50._kind_phys + end if + dz_snowf = qflx_snow_grnd_col(c)/bifall + snowdp(c) = snowdp(c) + dz_snowf*dtime + h2osno(c) = h2osno(c) + qflx_snow_grnd_col(c)*dtime ! snow water equivalent (mm) + end if + + ! if (itype(l)==istwet .and. t_grnd(c)>tfrz) then + ! h2osno(c)=0._kind_phys + ! snowdp(c)=0._kind_phys + ! snowage(c)=0._kind_phys + ! end if + ! Take care of this later in function. + + ! When the snow accumulation exceeds 10 mm, initialize snow layer + ! Currently, the water temperature for the precipitation is simply set + ! as the surface air temperature + + newnode = 0 ! flag for when snow node will be initialized + if (snl(c) == 0 .and. qflx_snow_grnd_col(c) > 0.0_kind_phys .and. snowdp(c) >= 0.01_kind_phys) then + newnode = 1 + snl(c) = -1 + dz(c,0) = snowdp(c) ! meter + z(c,0) = -0.5_kind_phys*dz(c,0) + zi(c,-1) = -dz(c,0) + snowage(c) = 0._kind_phys ! snow age + t_soisno(c,0) = min(tfrz, forc_t(g)) ! K + h2osoi_ice(c,0) = h2osno(c) ! kg/m2 + h2osoi_liq(c,0) = 0._kind_phys ! kg/m2 + frac_iceold(c,0) = 1._kind_phys + end if + + ! The change of ice partial density of surface node due to precipitation. + ! Only ice part of snowfall is added here, the liquid part will be added + ! later. + + if (snl(c) < 0 .and. newnode == 0) then + h2osoi_ice(c,snl(c)+1) = h2osoi_ice(c,snl(c)+1)+dtime*qflx_snow_grnd_col(c) + dz(c,snl(c)+1) = dz(c,snl(c)+1)+dz_snowf*dtime + end if + + end do + + ! Calculate sublimation and dew, adapted from HydrologyLake and Biogeophysics2. + + !dir$ concurrent + !cdir nodep + do fp = 1,num_shlakep + p = filter_shlakep(fp) + c = pcolumn(p) + jtop = snl(c)+1 + + ! Use column variables here + qflx_evap_grnd(c) = 0._kind_phys + qflx_sub_snow(c) = 0._kind_phys + qflx_dew_snow(c) = 0._kind_phys + qflx_dew_grnd(c) = 0._kind_phys + + if (jtop <= 0) then ! snow layers + j = jtop + ! Assign ground evaporation to sublimation from soil ice or to dew + ! on snow or ground + + if (qflx_evap_soi(p) >= 0._kind_phys) then + ! for evaporation partitioning between liquid evap and ice sublimation, + ! use the ratio of liquid to (liquid+ice) in the top layer to determine split + ! Since we're not limiting evap over lakes, but still can't remove more from top + ! snow layer than there is there, create temp. limited evap_soi. + qflx_evap_soi_lim = min(qflx_evap_soi(p), (h2osoi_liq(c,j)+h2osoi_ice(c,j))/dtime) + if ((h2osoi_liq(c,j)+h2osoi_ice(c,j)) > 0._kind_phys) then + qflx_evap_grnd(c) = max(qflx_evap_soi_lim*(h2osoi_liq(c,j)/(h2osoi_liq(c,j)+h2osoi_ice(c,j))), 0._kind_phys) + else + qflx_evap_grnd(c) = 0._kind_phys + end if + qflx_sub_snow(c) = qflx_evap_soi_lim - qflx_evap_grnd(c) + else + if (t_grnd(c) < tfrz) then + qflx_dew_snow(c) = abs(qflx_evap_soi(p)) + else + qflx_dew_grnd(c) = abs(qflx_evap_soi(p)) + end if + end if + ! Update the pft-level qflx_snowcap + ! This was moved in from Hydrology2 to keep all pft-level + ! calculations out of Hydrology2 + if (do_capsnow(c)) qflx_snowcap(p) = qflx_snowcap(p) + qflx_dew_snow(c) + qflx_dew_grnd(c) + + else ! No snow layers: do as in HydrologyLake but with actual clmtype variables + if (qflx_evap_soi(p) >= 0._kind_phys) then + ! Sublimation: do not allow for more sublimation than there is snow + ! after melt. Remaining surface evaporation used for infiltration. + qflx_sub_snow(c) = min(qflx_evap_soi(p), h2osno(c)/dtime) + qflx_evap_grnd(c) = qflx_evap_soi(p) - qflx_sub_snow(c) + else + if (t_grnd(c) < tfrz-0.1_kind_phys) then + qflx_dew_snow(c) = abs(qflx_evap_soi(p)) + else + qflx_dew_grnd(c) = abs(qflx_evap_soi(p)) + end if + end if + + ! Update snow pack for dew & sub. + h2osno_temp = h2osno(c) + if (do_capsnow(c)) then + h2osno(c) = h2osno(c) - qflx_sub_snow(c)*dtime + qflx_snowcap(p) = qflx_snowcap(p) + qflx_dew_snow(c) + qflx_dew_grnd(c) + else + h2osno(c) = h2osno(c) + (-qflx_sub_snow(c)+qflx_dew_snow(c))*dtime + end if + if (h2osno_temp > 0._kind_phys) then + snowdp(c) = snowdp(c) * h2osno(c) / h2osno_temp + else + snowdp(c) = h2osno(c)/snow_bd !Assume a constant snow bulk density = 250. + end if + + if (PERGRO) then + if (abs(h2osno(c)) < 1.e-10_kind_phys) h2osno(c) = 0._kind_phys + else + h2osno(c) = max(h2osno(c), 0._kind_phys) + endif + + end if + + qflx_snowcap_col(c) = qflx_snowcap(p) + + end do + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Determine initial snow/no-snow filters (will be modified possibly by + ! routines CombineSnowLayers and DivideSnowLayers below + + call BuildSnowFilter(lbc, ubc, num_shlakec, filter_shlakec,snl, & !i + num_shlakesnowc, filter_shlakesnowc, num_shlakenosnowc, filter_shlakenosnowc) !o + + ! Determine the change of snow mass and the snow water onto soil + + call SnowWater(lbc, ubc, num_shlakesnowc, filter_shlakesnowc, & !i + num_shlakenosnowc, filter_shlakenosnowc, & !i + snl,do_capsnow,qflx_snomelt,qflx_rain_grnd, & !i + qflx_sub_snow,qflx_evap_grnd, & !i + qflx_dew_snow,qflx_dew_grnd,dz, & !i + h2osoi_ice,h2osoi_liq, & !i&o + qflx_top_soil) !o + + + ! Determine soil hydrology + ! Here this consists only of making sure that soil is saturated even as it melts and 10% + ! of pore space opens up. Conversely, if excess ice is melting and the liquid water exceeds the + ! saturation value, then remove water. + + do j = 1,nlevsoil + !dir$ concurrent + !cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + + if (h2osoi_vol(c,j) < watsat(c,j)) then + h2osoi_liq(c,j) = (watsat(c,j)*dz(c,j) - h2osoi_ice(c,j)/denice)*denh2o + ! h2osoi_vol will be updated below, and this water addition will come from qflx_qrgwl + else if (h2osoi_liq(c,j) > watsat(c,j)*denh2o*dz(c,j)) then + h2osoi_liq(c,j) = watsat(c,j)*denh2o*dz(c,j) + end if + + end do + end do + !!!!!!!!!! + + ! if (.not. is_perpetual()) then + if (1==1) then + + ! Natural compaction and metamorphosis. + + call SnowCompaction(lbc, ubc, num_shlakesnowc, filter_shlakesnowc, &!i + snl,imelt,frac_iceold,t_soisno, &!i + h2osoi_ice,h2osoi_liq, &!i + dz) !&o + + ! Combine thin snow elements + + call CombineSnowLayers(lbc, ubc, & !i + num_shlakesnowc, filter_shlakesnowc, & !i&o + snl,h2osno,snowdp,dz,zi, & !i&o + t_soisno,h2osoi_ice,h2osoi_liq, & !i&o + z) !o + + + ! Divide thick snow elements + + call DivideSnowLayers(lbc, ubc, & !i + num_shlakesnowc, filter_shlakesnowc, & !i&o + snl,dz,zi,t_soisno, & !i&o + h2osoi_ice,h2osoi_liq, & !i&o + z) !o + + + else + + do fc = 1, num_shlakesnowc + c = filter_shlakesnowc(fc) + h2osno(c) = 0._kind_phys + end do + do j = -nlevsnow+1,0 + do fc = 1, num_shlakesnowc + c = filter_shlakesnowc(fc) + if (j >= snl(c)+1) then + h2osno(c) = h2osno(c) + h2osoi_ice(c,j) + h2osoi_liq(c,j) + end if + end do + end do + + end if + + ! Check for snow layers above lake with unfrozen top layer. Mechanically, + ! the snow will fall into the lake and melt or turn to ice. If the top layer has + ! sufficient heat to melt the snow without freezing, then that will be done. + ! Otherwise, the top layer will undergo freezing, but only if the top layer will + ! not freeze completely. Otherwise, let the snow layers persist and melt by diffusion. + !dir$ concurrent + !cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + + if (t_lake(c,1) > tfrz .and. lake_icefrac(c,1) == 0._kind_phys .and. snl(c) < 0) then + unfrozen(c) = .true. + else + unfrozen(c) = .false. + end if + end do + + do j = -nlevsnow+1,0 + !dir$ concurrent + !cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + + if (unfrozen(c)) then + if (j == -nlevsnow+1) then + sumsnowice(c) = 0._kind_phys + heatsum(c) = 0._kind_phys + end if + if (j >= snl(c)+1) then + sumsnowice(c) = sumsnowice(c) + h2osoi_ice(c,j) + heatsum(c) = heatsum(c) + h2osoi_ice(c,j)*cpice*(tfrz - t_soisno(c,j)) & + + h2osoi_liq(c,j)*cpliq*(tfrz - t_soisno(c,j)) + end if + end if + end do + end do + + !dir$ concurrent + !cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + + if (unfrozen(c)) then + heatsum(c) = heatsum(c) + sumsnowice(c)*hfus + heatrem = (t_lake(c,1) - tfrz)*cpliq*denh2o*dz_lake(c,1) - heatsum(c) + + if (heatrem + denh2o*dz_lake(c,1)*hfus > 0._kind_phys) then + ! Remove snow and subtract the latent heat from the top layer. + h2osno(c) = 0._kind_phys + snl(c) = 0 + ! The rest of the bookkeeping for the removed snow will be done below. + if (LAKEDEBUG) then + print *,'Snow layers removed above unfrozen lake for column, snowice:', & + c, sumsnowice(c) + endif + if (heatrem > 0._kind_phys) then ! simply subtract the heat from the layer + t_lake(c,1) = t_lake(c,1) - heatrem/(cpliq*denh2o*dz_lake(c,1)) + else !freeze part of the layer + t_lake(c,1) = tfrz + lake_icefrac(c,1) = -heatrem/(denh2o*dz_lake(c,1)*hfus) + end if + end if + end if + end do + !!!!!!!!!!!! + + ! Set snow age to zero if no snow + + !dir$ concurrent + !cdir nodep + do fc = 1, num_shlakesnowc + c = filter_shlakesnowc(fc) + if (snl(c) == 0) then + snowage(c) = 0._kind_phys + end if + end do + + ! Set empty snow layers to zero + + do j = -nlevsnow+1,0 + !dir$ concurrent + !cdir nodep + do fc = 1, num_shlakesnowc + c = filter_shlakesnowc(fc) + if (j <= snl(c) .and. snl(c) > -nlevsnow) then + h2osoi_ice(c,j) = 0._kind_phys + h2osoi_liq(c,j) = 0._kind_phys + t_soisno(c,j) = 0._kind_phys + dz(c,j) = 0._kind_phys + z(c,j) = 0._kind_phys + zi(c,j-1) = 0._kind_phys + end if + end do + end do + + ! Build new snow filter + + call BuildSnowFilter(lbc, ubc, num_shlakec, filter_shlakec, snl,& !i + num_shlakesnowc, filter_shlakesnowc, num_shlakenosnowc, filter_shlakenosnowc) !o + + ! Vertically average t_soisno and sum of h2osoi_liq and h2osoi_ice + ! over all snow layers for history output + + !dir$ concurrent + !cdir nodep + do fc = 1, num_shlakesnowc + c = filter_shlakesnowc(fc) + t_snow(c) = 0._kind_phys + snowice(c) = 0._kind_phys + snowliq(c) = 0._kind_phys + end do + !dir$ concurrent + !cdir nodep + do fc = 1, num_shlakenosnowc + c = filter_shlakenosnowc(fc) + t_snow(c) = spval + snowice(c) = spval + snowliq(c) = spval + end do + + do j = -nlevsnow+1, 0 + !dir$ concurrent + !cdir nodep + do fc = 1, num_shlakesnowc + c = filter_shlakesnowc(fc) + if (j >= snl(c)+1) then + t_snow(c) = t_snow(c) + t_soisno(c,j) + snowice(c) = snowice(c) + h2osoi_ice(c,j) + snowliq(c) = snowliq(c) + h2osoi_liq(c,j) + end if + end do + end do + + ! Determine ending water balance and volumetric soil water + + !dir$ concurrent + !cdir nodep + do fc = 1, num_shlakec + + c = filter_shlakec(fc) + if (snl(c) < 0) t_snow(c) = t_snow(c)/abs(snl(c)) + endwb(c) = h2osno(c) + end do + + do j = 1, nlevsoil + !dir$ concurrent + !cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + endwb(c) = endwb(c) + h2osoi_ice(c,j) + h2osoi_liq(c,j) + h2osoi_vol(c,j) = h2osoi_liq(c,j)/(dz(c,j)*denh2o) + h2osoi_ice(c,j)/(dz(c,j)*denice) + end do + end do + + check_add_snow_water: if(LAKEDEBUG) then + allocate(snow_water(lbc:ubc)) + ! Check to make sure snow water adds up correctly. + do j = -nlevsnow+1,0 + !dir$ concurrent + !cdir nodep + do fc = 1, num_shlakec + c = filter_shlakec(fc) + + jtop = snl(c)+1 + if(j == jtop) snow_water(c) = 0._kind_phys + if(j >= jtop) then + snow_water(c) = snow_water(c) + h2osoi_ice(c,j) + h2osoi_liq(c,j) + if(j == 0 .and. abs(snow_water(c)-h2osno(c))>1.e-7_kind_phys) then + write(message,*)'h2osno does not equal sum of snow layers in ShalLakeHydrology:', & + 'column, h2osno, sum of snow layers =', c, h2osno(c), snow_water(c) + errmsg=trim(message) + errflg=1 + ! FIXME: PUT THIS BACK: return + end if + end if + end do + end do + deallocate(snow_water) + end if check_add_snow_water + + !!!!!!!!!!!!! + ! Do history variables and set special landunit runoff (adapted from end of HydrologyLake) + !dir$ concurrent + !cdir nodep + do fp = 1,num_shlakep + p = filter_shlakep(fp) + c = pcolumn(p) + g = pgridcell(p) + + qflx_infl(c) = 0._kind_phys + qflx_surf(c) = 0._kind_phys + qflx_drain(c) = 0._kind_phys + rootr_column(c,:) = spval + soilalpha(c) = spval + zwt(c) = spval + fcov(c) = spval + qcharge(c) = spval + ! h2osoi_vol(c,:) = spval + + ! Insure water balance using qflx_qrgwl + qflx_qrgwl(c) = forc_rain(g) + forc_snow(g) - qflx_evap_tot(p) - (endwb(c)-begwb(c))/dtime + if (LAKEDEBUG) then + print *,'c, rain, snow, evap, endwb, begwb, qflx_qrgwl:', & + c, forc_rain(g), forc_snow(g), qflx_evap_tot(p), endwb(c), begwb(c), qflx_qrgwl(c) + endif + + ! The pft average must be done here for output to history tape + qflx_evap_tot_col(c) = qflx_evap_tot(p) + end do + + end subroutine ShalLakeHydrology + + subroutine QSat (T, p, es, esdT, qs, qsdT) + ! + ! !DESCRIPTION: + ! Computes saturation mixing ratio and the change in saturation + ! mixing ratio with respect to temperature. + ! Reference: Polynomial approximations from: + ! Piotr J. Flatau, et al.,1992: Polynomial fits to saturation + ! vapor pressure. Journal of Applied Meteorology, 31, 1507-1513. + ! + ! !USES: + ! + ! !ARGUMENTS: + implicit none + real(kind_phys), intent(in) :: T ! temperature (K) + real(kind_phys), intent(in) :: p ! surface atmospheric pressure (pa) + real(kind_phys), intent(out) :: es ! vapor pressure (pa) + real(kind_phys), intent(out) :: esdT ! d(es)/d(T) + real(kind_phys), intent(out) :: qs ! humidity (kg/kg) + real(kind_phys), intent(out) :: qsdT ! d(qs)/d(T) + ! + ! !CALLED FROM: + ! subroutine Biogeophysics1 in module Biogeophysics1Mod + ! subroutine BiogeophysicsLake in module BiogeophysicsLakeMod + ! subroutine CanopyFluxesMod CanopyFluxesMod + ! + ! !REVISION HISTORY: + ! 15 September 1999: Yongjiu Dai; Initial code + ! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision + ! + !EOP + ! + ! !LOCAL VARIABLES: + ! + real(kind_phys) :: T_limit + real(kind_phys) :: td,vp,vp1,vp2 + ! + ! For water vapor (temperature range 0C-100C) + ! + real(kind_phys), parameter :: a0 = 6.11213476 + real(kind_phys), parameter :: a1 = 0.444007856 + real(kind_phys), parameter :: a2 = 0.143064234e-01 + real(kind_phys), parameter :: a3 = 0.264461437e-03 + real(kind_phys), parameter :: a4 = 0.305903558e-05 + real(kind_phys), parameter :: a5 = 0.196237241e-07 + real(kind_phys), parameter :: a6 = 0.892344772e-10 + real(kind_phys), parameter :: a7 = -0.373208410e-12 + real(kind_phys), parameter :: a8 = 0.209339997e-15 + ! + ! For derivative:water vapor + ! + real(kind_phys), parameter :: b0 = 0.444017302 + real(kind_phys), parameter :: b1 = 0.286064092e-01 + real(kind_phys), parameter :: b2 = 0.794683137e-03 + real(kind_phys), parameter :: b3 = 0.121211669e-04 + real(kind_phys), parameter :: b4 = 0.103354611e-06 + real(kind_phys), parameter :: b5 = 0.404125005e-09 + real(kind_phys), parameter :: b6 = -0.788037859e-12 + real(kind_phys), parameter :: b7 = -0.114596802e-13 + real(kind_phys), parameter :: b8 = 0.381294516e-16 + ! + ! For ice (temperature range -75C-0C) + ! + real(kind_phys), parameter :: c0 = 6.11123516 + real(kind_phys), parameter :: c1 = 0.503109514 + real(kind_phys), parameter :: c2 = 0.188369801e-01 + real(kind_phys), parameter :: c3 = 0.420547422e-03 + real(kind_phys), parameter :: c4 = 0.614396778e-05 + real(kind_phys), parameter :: c5 = 0.602780717e-07 + real(kind_phys), parameter :: c6 = 0.387940929e-09 + real(kind_phys), parameter :: c7 = 0.149436277e-11 + real(kind_phys), parameter :: c8 = 0.262655803e-14 + ! + ! For derivative:ice + ! + real(kind_phys), parameter :: d0 = 0.503277922 + real(kind_phys), parameter :: d1 = 0.377289173e-01 + real(kind_phys), parameter :: d2 = 0.126801703e-02 + real(kind_phys), parameter :: d3 = 0.249468427e-04 + real(kind_phys), parameter :: d4 = 0.313703411e-06 + real(kind_phys), parameter :: d5 = 0.257180651e-08 + real(kind_phys), parameter :: d6 = 0.133268878e-10 + real(kind_phys), parameter :: d7 = 0.394116744e-13 + real(kind_phys), parameter :: d8 = 0.498070196e-16 + !----------------------------------------------------------------------- + + T_limit = T - tfrz + if (T_limit > 100.0) T_limit=100.0 + if (T_limit < -75.0) T_limit=-75.0 + + td = T_limit + if (td >= 0.0) then + es = a0 + td*(a1 + td*(a2 + td*(a3 + td*(a4 & + + td*(a5 + td*(a6 + td*(a7 + td*a8))))))) + esdT = b0 + td*(b1 + td*(b2 + td*(b3 + td*(b4 & + + td*(b5 + td*(b6 + td*(b7 + td*b8))))))) + else + es = c0 + td*(c1 + td*(c2 + td*(c3 + td*(c4 & + + td*(c5 + td*(c6 + td*(c7 + td*c8))))))) + esdT = d0 + td*(d1 + td*(d2 + td*(d3 + td*(d4 & + + td*(d5 + td*(d6 + td*(d7 + td*d8))))))) + endif + + es = es * 100. ! pa + esdT = esdT * 100. ! pa/K + + vp = 1.0 / (p - 0.378*es) + vp1 = 0.622 * vp + vp2 = vp1 * vp + + qs = es * vp1 ! kg/kg + qsdT = esdT * vp2 * p ! 1 / K + + end subroutine QSat + + + subroutine Tridiagonal (lbc, ubc, lbj, ubj, jtop, numf, filter, & + a, b, c, r, u) + ! + ! !DESCRIPTION: + ! Tridiagonal matrix solution + ! + ! !ARGUMENTS: + implicit none + integer , intent(in) :: lbc, ubc ! lbinning and ubing column indices + integer , intent(in) :: lbj, ubj ! lbinning and ubing level indices + integer , intent(in) :: jtop(lbc:ubc) ! top level for each column + integer , intent(in) :: numf ! filter dimension + integer , intent(in) :: filter(1:numf) ! filter + real(kind_phys), intent(in) :: a(lbc:ubc, lbj:ubj) ! "a" left off diagonal of tridiagonal matrix + real(kind_phys), intent(in) :: b(lbc:ubc, lbj:ubj) ! "b" diagonal column for tridiagonal matrix + real(kind_phys), intent(in) :: c(lbc:ubc, lbj:ubj) ! "c" right off diagonal tridiagonal matrix + real(kind_phys), intent(in) :: r(lbc:ubc, lbj:ubj) ! "r" forcing term of tridiagonal matrix + real(kind_phys), intent(inout) :: u(lbc:ubc, lbj:ubj) ! solution + ! + ! !CALLED FROM: + ! subroutine BiogeophysicsLake in module BiogeophysicsLakeMod + ! subroutine SoilTemperature in module SoilTemperatureMod + ! subroutine SoilWater in module HydrologyMod + ! + ! !REVISION HISTORY: + ! 15 September 1999: Yongjiu Dai; Initial code + ! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision + ! 1 July 2003: Mariana Vertenstein; modified for vectorization + ! + !EOP + ! + ! !OTHER LOCAL VARIABLES: + ! + integer :: j,ci,fc !indices + real(kind_phys) :: gam(lbc:ubc,lbj:ubj) !temporary + real(kind_phys) :: bet(lbc:ubc) !temporary + !----------------------------------------------------------------------- + + ! Solve the matrix + + !dir$ concurrent + !cdir nodep + do fc = 1,numf + ci = filter(fc) + bet(ci) = b(ci,jtop(ci)) + end do + + do j = lbj, ubj + !dir$ prefervector + !dir$ concurrent + !cdir nodep + do fc = 1,numf + ci = filter(fc) + if (j >= jtop(ci)) then + if (j == jtop(ci)) then + u(ci,j) = r(ci,j) / bet(ci) + else + gam(ci,j) = c(ci,j-1) / bet(ci) + bet(ci) = b(ci,j) - a(ci,j) * gam(ci,j) + u(ci,j) = (r(ci,j) - a(ci,j)*u(ci,j-1)) / bet(ci) + end if + end if + end do + end do + + !Cray X1 unroll directive used here as work-around for compiler issue 2003/10/20 + !dir$ unroll 0 + do j = ubj-1,lbj,-1 + !dir$ prefervector + !dir$ concurrent + !cdir nodep + do fc = 1,numf + ci = filter(fc) + if (j >= jtop(ci)) then + u(ci,j) = u(ci,j) - gam(ci,j+1) * u(ci,j+1) + end if + end do + end do + + end subroutine Tridiagonal + + + subroutine SnowWater(lbc, ubc, num_snowc, filter_snowc, & !i + num_nosnowc, filter_nosnowc, & !i + snl,do_capsnow,qflx_snomelt,qflx_rain_grnd, & !i + qflx_sub_snow,qflx_evap_grnd, & !i + qflx_dew_snow,qflx_dew_grnd,dz, & !i + h2osoi_ice,h2osoi_liq, & !i&o + qflx_top_soil) !o + !=============================================================================== + ! !DESCRIPTION: + ! Evaluate the change of snow mass and the snow water onto soil. + ! Water flow within snow is computed by an explicit and non-physical + ! based scheme, which permits a part of liquid water over the holding + ! capacity (a tentative value is used, i.e. equal to 0.033*porosity) to + ! percolate into the underlying layer. Except for cases where the + ! porosity of one of the two neighboring layers is less than 0.05, zero + ! flow is assumed. The water flow out of the bottom of the snow pack will + ! participate as the input of the soil water and runoff. This subroutine + ! uses a filter for columns containing snow which must be constructed prior + ! to being called. + ! + ! !REVISION HISTORY: + ! 15 September 1999: Yongjiu Dai; Initial code + ! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision + ! 15 November 2000: Mariana Vertenstein + ! 2/26/02, Peter Thornton: Migrated to new data structures. + !============================================================================= + ! !USES: + ! use clmtype + + implicit none + + !in: + integer, intent(in) :: lbc, ubc ! column bounds + integer, intent(in) :: num_snowc ! number of snow points in column filter + integer, intent(in) :: filter_snowc(ubc-lbc+1) ! column filter for snow points + integer, intent(in) :: num_nosnowc ! number of non-snow points in column filter + integer, intent(in) :: filter_nosnowc(ubc-lbc+1) ! column filter for non-snow points + + integer , intent(in) :: snl(1) !number of snow layers + logical , intent(in) :: do_capsnow(1) !true => do snow capping + real(kind_phys), intent(in) :: qflx_snomelt(1) !snow melt (mm H2O /s) + real(kind_phys), intent(in) :: qflx_rain_grnd(1) !rain on ground after interception (mm H2O/s) [+] + real(kind_phys), intent(in) :: qflx_sub_snow(1) !sublimation rate from snow pack (mm H2O /s) [+] + real(kind_phys), intent(in) :: qflx_evap_grnd(1) !ground surface evaporation rate (mm H2O/s) [+] + real(kind_phys), intent(in) :: qflx_dew_snow(1) !surface dew added to snow pack (mm H2O /s) [+] + real(kind_phys), intent(in) :: qflx_dew_grnd(1) !ground surface dew formation (mm H2O /s) [+] + real(kind_phys), intent(in) :: dz(1,-nlevsnow+1:nlevsoil) !layer depth (m) + + + !inout: + + real(kind_phys), intent(inout) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) !ice lens (kg/m2) + real(kind_phys), intent(inout) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) !liquid water (kg/m2) + + !out: + + real(kind_phys), intent(out) :: qflx_top_soil(1) !net water input into soil from top (mm/s) + + + ! OTHER LOCAL VARIABLES: + + integer :: c, j, fc !do loop/array indices + real(kind_phys) :: qin(lbc:ubc) !water flow into the elmement (mm/s) + real(kind_phys) :: qout(lbc:ubc) !water flow out of the elmement (mm/s) + real(kind_phys) :: wgdif !ice mass after minus sublimation + real(kind_phys) :: vol_liq(lbc:ubc,-nlevsnow+1:0) !partial volume of liquid water in layer + real(kind_phys) :: vol_ice(lbc:ubc,-nlevsnow+1:0) !partial volume of ice lens in layer + real(kind_phys) :: eff_porosity(lbc:ubc,-nlevsnow+1:0) !effective porosity = porosity - vol_ice + !----------------------------------------------------------------------- + ! Renew the mass of ice lens (h2osoi_ice) and liquid (h2osoi_liq) in the + ! surface snow layer resulting from sublimation (frost) / evaporation (condense) + + !dir$ concurrent + !cdir nodep + do fc = 1,num_snowc + c = filter_snowc(fc) + if (do_capsnow(c)) then + wgdif = h2osoi_ice(c,snl(c)+1) - qflx_sub_snow(c)*dtime + h2osoi_ice(c,snl(c)+1) = wgdif + if (wgdif < 0.) then + h2osoi_ice(c,snl(c)+1) = 0. + h2osoi_liq(c,snl(c)+1) = h2osoi_liq(c,snl(c)+1) + wgdif + end if + h2osoi_liq(c,snl(c)+1) = h2osoi_liq(c,snl(c)+1) - qflx_evap_grnd(c) * dtime + else + wgdif = h2osoi_ice(c,snl(c)+1) + (qflx_dew_snow(c) - qflx_sub_snow(c)) * dtime + h2osoi_ice(c,snl(c)+1) = wgdif + if (wgdif < 0.) then + h2osoi_ice(c,snl(c)+1) = 0. + h2osoi_liq(c,snl(c)+1) = h2osoi_liq(c,snl(c)+1) + wgdif + end if + h2osoi_liq(c,snl(c)+1) = h2osoi_liq(c,snl(c)+1) + & + (qflx_rain_grnd(c) + qflx_dew_grnd(c) - qflx_evap_grnd(c)) * dtime + end if + h2osoi_liq(c,snl(c)+1) = max(0._kind_phys, h2osoi_liq(c,snl(c)+1)) + end do + + ! Porosity and partial volume + + do j = -nlevsnow+1, 0 + !dir$ concurrent + !cdir nodep + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j >= snl(c)+1) then + vol_ice(c,j) = min(1._kind_phys, h2osoi_ice(c,j)/(dz(c,j)*denice)) + eff_porosity(c,j) = 1. - vol_ice(c,j) + vol_liq(c,j) = min(eff_porosity(c,j),h2osoi_liq(c,j)/(dz(c,j)*denh2o)) + end if + end do + end do + + ! Capillary forces within snow are usually two or more orders of magnitude + ! less than those of gravity. Only gravity terms are considered. + ! the genernal expression for water flow is "K * ss**3", however, + ! no effective parameterization for "K". Thus, a very simple consideration + ! (not physically based) is introduced: + ! when the liquid water of layer exceeds the layer's holding + ! capacity, the excess meltwater adds to the underlying neighbor layer. + + qin(:) = 0._kind_phys + + do j = -nlevsnow+1, 0 + !dir$ concurrent + !cdir nodep + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j >= snl(c)+1) then + h2osoi_liq(c,j) = h2osoi_liq(c,j) + qin(c) + if (j <= -1) then + ! No runoff over snow surface, just ponding on surface + if (eff_porosity(c,j) < wimp .OR. eff_porosity(c,j+1) < wimp) then + qout(c) = 0._kind_phys + else + qout(c) = max(0._kind_phys,(vol_liq(c,j)-ssi*eff_porosity(c,j))*dz(c,j)) + qout(c) = min(qout(c),(1.-vol_ice(c,j+1)-vol_liq(c,j+1))*dz(c,j+1)) + end if + else + qout(c) = max(0._kind_phys,(vol_liq(c,j) - ssi*eff_porosity(c,j))*dz(c,j)) + end if + qout(c) = qout(c)*1000. + h2osoi_liq(c,j) = h2osoi_liq(c,j) - qout(c) + qin(c) = qout(c) + end if + end do + end do + + !dir$ concurrent + !cdir nodep + do fc = 1, num_snowc + c = filter_snowc(fc) + ! Qout from snow bottom + qflx_top_soil(c) = qout(c) / dtime + end do + + !dir$ concurrent + !cdir nodep + do fc = 1, num_nosnowc + c = filter_nosnowc(fc) + qflx_top_soil(c) = qflx_rain_grnd(c) + qflx_snomelt(c) + end do + + end subroutine SnowWater + + subroutine SnowCompaction(lbc, ubc, num_snowc, filter_snowc, &!i + snl,imelt,frac_iceold,t_soisno, &!i + h2osoi_ice,h2osoi_liq, &!i + dz) !i&o + + + !================================================================================ + ! !DESCRIPTION: + ! Determine the change in snow layer thickness due to compaction and + ! settling. + ! Three metamorphisms of changing snow characteristics are implemented, + ! i.e., destructive, overburden, and melt. The treatments of the former + ! two are from SNTHERM.89 and SNTHERM.99 (1991, 1999). The contribution + ! due to melt metamorphism is simply taken as a ratio of snow ice + ! fraction after the melting versus before the melting. + ! + ! CALLED FROM: + ! subroutine Hydrology2 in module Hydrology2Mod + ! + ! REVISION HISTORY: + ! 15 September 1999: Yongjiu Dai; Initial code + ! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision + ! 2/28/02, Peter Thornton: Migrated to new data structures + !============================================================================== + ! USES: + ! use clmtype + ! + ! !ARGUMENTS: + implicit none + + !in: + integer, intent(in) :: lbc, ubc ! column bounds + integer, intent(in) :: num_snowc ! number of column snow points in column filter + integer, intent(in) :: filter_snowc(ubc-lbc+1) ! column filter for snow points + integer, intent(in) :: snl(1) !number of snow layers + integer, intent(in) :: imelt(1,-nlevsnow+1:nlevsoil) !flag for melting (=1), freezing (=2), Not=0 + real(kind_phys), intent(in) :: frac_iceold(1,-nlevsnow+1:nlevsoil) !fraction of ice relative to the tot water + real(kind_phys), intent(in) :: t_soisno(1,-nlevsnow+1:nlevsoil) !soil temperature (Kelvin) + real(kind_phys), intent(in) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) !ice lens (kg/m2) + real(kind_phys), intent(in) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) !liquid water (kg/m2) + + !inout: + + real(kind_phys), intent(inout) :: dz(1,-nlevsnow+1:nlevsoil) !layer depth (m) + + ! OTHER LOCAL VARIABLES: + + integer :: j, c, fc ! indices + real(kind_phys), parameter :: c2 = 23.e-3 ! [m3/kg] + real(kind_phys), parameter :: c3 = 2.777e-6 ! [1/s] + real(kind_phys), parameter :: c4 = 0.04 ! [1/K] + real(kind_phys), parameter :: c5 = 2.0 ! + real(kind_phys), parameter :: dm = 100.0 ! Upper Limit on Destructive Metamorphism Compaction [kg/m3] + real(kind_phys), parameter :: eta0 = 9.e+5 ! The Viscosity Coefficient Eta0 [kg-s/m2] + real(kind_phys) :: burden(lbc:ubc) ! pressure of overlying snow [kg/m2] + real(kind_phys) :: ddz1 ! Rate of settling of snowpack due to destructive metamorphism. + real(kind_phys) :: ddz2 ! Rate of compaction of snowpack due to overburden. + real(kind_phys) :: ddz3 ! Rate of compaction of snowpack due to melt [1/s] + real(kind_phys) :: dexpf ! expf=exp(-c4*(273.15-t_soisno)). + real(kind_phys) :: fi ! Fraction of ice relative to the total water content at current time step + real(kind_phys) :: td ! t_soisno - tfrz [K] + real(kind_phys) :: pdzdtc ! Nodal rate of change in fractional-thickness due to compaction [fraction/s] + real(kind_phys) :: void ! void (1 - vol_ice - vol_liq) + real(kind_phys) :: wx ! water mass (ice+liquid) [kg/m2] + real(kind_phys) :: bi ! partial density of ice [kg/m3] + + !----------------------------------------------------------------------- + + + ! Begin calculation - note that the following column loops are only invoked if snl(c) < 0 + + burden(:) = 0._kind_phys + + do j = -nlevsnow+1, 0 + !dir$ concurrent + !cdir nodep + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j >= snl(c)+1) then + + wx = h2osoi_ice(c,j) + h2osoi_liq(c,j) + void = 1. - (h2osoi_ice(c,j)/denice + h2osoi_liq(c,j)/denh2o) / dz(c,j) + + ! Allow compaction only for non-saturated node and higher ice lens node. + if (void > 0.001 .and. h2osoi_ice(c,j) > .1) then + bi = h2osoi_ice(c,j) / dz(c,j) + fi = h2osoi_ice(c,j) / wx + td = tfrz-t_soisno(c,j) + dexpf = exp(-c4*td) + + ! Settling as a result of destructive metamorphism + + ddz1 = -c3*dexpf + if (bi > dm) ddz1 = ddz1*exp(-46.0e-3*(bi-dm)) + + ! Liquid water term + + if (h2osoi_liq(c,j) > 0.01*dz(c,j)) ddz1=ddz1*c5 + + ! Compaction due to overburden + + ddz2 = -burden(c)*exp(-0.08*td - c2*bi)/eta0 + + ! Compaction occurring during melt + + if (imelt(c,j) == 1) then + ddz3 = - 1./dtime * max(0._kind_phys,(frac_iceold(c,j) - fi)/frac_iceold(c,j)) + else + ddz3 = 0._kind_phys + end if + + ! Time rate of fractional change in dz (units of s-1) + + pdzdtc = ddz1 + ddz2 + ddz3 + + ! The change in dz due to compaction + + dz(c,j) = dz(c,j) * (1.+pdzdtc*dtime) + end if + + ! Pressure of overlying snow + + burden(c) = burden(c) + wx + + end if + end do + end do + + end subroutine SnowCompaction + + subroutine CombineSnowLayers(lbc, ubc, & !i + num_snowc, filter_snowc, & !i&o + snl,h2osno,snowdp,dz,zi, & !i&o + t_soisno,h2osoi_ice,h2osoi_liq, & !i&o + z) !o + !========================================================================== + ! !DESCRIPTION: + ! Combine snow layers that are less than a minimum thickness or mass + ! If the snow element thickness or mass is less than a prescribed minimum, + ! then it is combined with a neighboring element. The subroutine + ! clm\_combo.f90 then executes the combination of mass and energy. + ! !CALLED FROM: + ! subroutine Hydrology2 in module Hydrology2Mod + ! + ! !REVISION HISTORY: + ! 15 September 1999: Yongjiu Dai; Initial code + ! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision + ! 2/28/02, Peter Thornton: Migrated to new data structures. + !========================================================================= + ! !USES: + ! use clmtype + ! + ! !ARGUMENTS: + implicit none + !in: + integer, intent(in) :: lbc, ubc ! column bounds + ! integer, intent(in) :: clandunit(1) !landunit index for each column + ! integer, intent(in) :: ityplun(1) !landunit type + + !inout: + integer, intent(inout) :: num_snowc ! number of column snow points in column filter + integer, intent(inout) :: filter_snowc(ubc-lbc+1) ! column filter for snow points + integer , intent(inout) :: snl(1) !number of snow layers + real(kind_phys), intent(inout) :: h2osno(1) !snow water (mm H2O) + real(kind_phys), intent(inout) :: snowdp(1) !snow height (m) + real(kind_phys), intent(inout) :: dz(1,-nlevsnow+1:nlevsoil) !layer depth (m) + real(kind_phys), intent(inout) :: zi(1,-nlevsnow+0:nlevsoil) !interface level below a "z" level (m) + real(kind_phys), intent(inout) :: t_soisno(1,-nlevsnow+1:nlevsoil) !soil temperature (Kelvin) + real(kind_phys), intent(inout) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) !ice lens (kg/m2) + real(kind_phys), intent(inout) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) !liquid water (kg/m2) + + !out: + + real(kind_phys), intent(out) :: z(1,-nlevsnow+1:nlevsoil) !layer thickness (m) + ! + !EOP + ! + ! !OTHER LOCAL VARIABLES: + ! + integer :: c, fc ! column indices + integer :: i,k ! loop indices + integer :: j,l ! node indices + integer :: msn_old(lbc:ubc) ! number of top snow layer + integer :: mssi(lbc:ubc) ! node index + integer :: neibor ! adjacent node selected for combination + real(kind_phys):: zwice(lbc:ubc) ! total ice mass in snow + real(kind_phys):: zwliq (lbc:ubc) ! total liquid water in snow + real(kind_phys):: dzmin(5) ! minimum of top snow layer + + data dzmin /0.010, 0.015, 0.025, 0.055, 0.115/ + !----------------------------------------------------------------------- + + ! Check the mass of ice lens of snow, when the total is less than a small value, + ! combine it with the underlying neighbor. + + !dir$ concurrent + !cdir nodep + do fc = 1, num_snowc + c = filter_snowc(fc) + msn_old(c) = snl(c) + end do + + ! The following loop is NOT VECTORIZED + + do fc = 1, num_snowc + c = filter_snowc(fc) + ! l = clandunit(c) + do j = msn_old(c)+1,0 + if (h2osoi_ice(c,j) <= .1) then + ! if (ityplun(l) == istsoil) then + ! h2osoi_liq(c,j+1) = h2osoi_liq(c,j+1) + h2osoi_liq(c,j) + ! h2osoi_ice(c,j+1) = h2osoi_ice(c,j+1) + h2osoi_ice(c,j) + ! else if (ityplun(l) /= istsoil .and. j /= 0) then + h2osoi_liq(c,j+1) = h2osoi_liq(c,j+1) + h2osoi_liq(c,j) + h2osoi_ice(c,j+1) = h2osoi_ice(c,j+1) + h2osoi_ice(c,j) + ! end if + + ! shift all elements above this down one. + if (j > snl(c)+1 .and. snl(c) < -1) then + do i = j, snl(c)+2, -1 + t_soisno(c,i) = t_soisno(c,i-1) + h2osoi_liq(c,i) = h2osoi_liq(c,i-1) + h2osoi_ice(c,i) = h2osoi_ice(c,i-1) + dz(c,i) = dz(c,i-1) + end do + end if + snl(c) = snl(c) + 1 + end if + end do + end do + + !dir$ concurrent + !cdir nodep + do fc = 1, num_snowc + c = filter_snowc(fc) + h2osno(c) = 0._kind_phys + snowdp(c) = 0._kind_phys + zwice(c) = 0._kind_phys + zwliq(c) = 0._kind_phys + end do + + do j = -nlevsnow+1,0 + !dir$ concurrent + !cdir nodep + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j >= snl(c)+1) then + h2osno(c) = h2osno(c) + h2osoi_ice(c,j) + h2osoi_liq(c,j) + snowdp(c) = snowdp(c) + dz(c,j) + zwice(c) = zwice(c) + h2osoi_ice(c,j) + zwliq(c) = zwliq(c) + h2osoi_liq(c,j) + end if + end do + end do + + ! Check the snow depth - all snow gone + ! The liquid water assumes ponding on soil surface. + + !dir$ concurrent + !cdir nodep + do fc = 1, num_snowc + c = filter_snowc(fc) + ! l = clandunit(c) + if (snowdp(c) < 0.01 .and. snowdp(c) > 0.) then + snl(c) = 0 + h2osno(c) = zwice(c) + if (h2osno(c) <= 0.) snowdp(c) = 0._kind_phys + ! if (ityplun(l) == istsoil) h2osoi_liq(c,1) = h2osoi_liq(c,1) + zwliq(c) !change by guhp + end if + end do + + ! Check the snow depth - snow layers combined + ! The following loop IS NOT VECTORIZED + + do fc = 1, num_snowc + c = filter_snowc(fc) + + ! Two or more layers + + if (snl(c) < -1) then + + msn_old(c) = snl(c) + mssi(c) = 1 + + do i = msn_old(c)+1,0 + if (dz(c,i) < dzmin(mssi(c))) then + + if (i == snl(c)+1) then + ! If top node is removed, combine with bottom neighbor. + neibor = i + 1 + else if (i == 0) then + ! If the bottom neighbor is not snow, combine with the top neighbor. + neibor = i - 1 + else + ! If none of the above special cases apply, combine with the thinnest neighbor + neibor = i + 1 + if ((dz(c,i-1)+dz(c,i)) < (dz(c,i+1)+dz(c,i))) neibor = i-1 + end if + + ! Node l and j are combined and stored as node j. + if (neibor > i) then + j = neibor + l = i + else + j = i + l = neibor + end if + + call Combo (dz(c,j), h2osoi_liq(c,j), h2osoi_ice(c,j), & + t_soisno(c,j), dz(c,l), h2osoi_liq(c,l), h2osoi_ice(c,l), t_soisno(c,l) ) + + ! Now shift all elements above this down one. + if (j-1 > snl(c)+1) then + do k = j-1, snl(c)+2, -1 + t_soisno(c,k) = t_soisno(c,k-1) + h2osoi_ice(c,k) = h2osoi_ice(c,k-1) + h2osoi_liq(c,k) = h2osoi_liq(c,k-1) + dz(c,k) = dz(c,k-1) + end do + end if + + ! Decrease the number of snow layers + snl(c) = snl(c) + 1 + if (snl(c) >= -1) EXIT + + else + + ! The layer thickness is greater than the prescribed minimum value + mssi(c) = mssi(c) + 1 + + end if + end do + + end if + + end do + + ! Reset the node depth and the depth of layer interface + + do j = 0, -nlevsnow+1, -1 + !dir$ concurrent + !cdir nodep + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j >= snl(c) + 1) then + z(c,j) = zi(c,j) - 0.5*dz(c,j) + zi(c,j-1) = zi(c,j) - dz(c,j) + end if + end do + end do + + end subroutine CombineSnowLayers + + subroutine DivideSnowLayers(lbc, ubc, & !i + num_snowc, filter_snowc, & !i&o + snl,dz,zi,t_soisno, & !i&o + h2osoi_ice,h2osoi_liq, & !i&o + z) !o + + + !============================================================================ + ! !DESCRIPTION: + ! Subdivides snow layers if they exceed their prescribed maximum thickness. + ! !CALLED FROM: + ! subroutine Hydrology2 in module Hydrology2Mod + ! + ! !REVISION HISTORY: + ! 15 September 1999: Yongjiu Dai; Initial code + ! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision + ! 2/28/02, Peter Thornton: Migrated to new data structures. + !============================================================================ + ! !USES: + ! use clmtype + ! + ! !ARGUMENTS: + implicit none + + !in: + integer, intent(in) :: lbc, ubc ! column bounds + + !inout: + + integer, intent(inout) :: num_snowc ! number of column snow points in column filter + integer, intent(inout) :: filter_snowc(ubc-lbc+1) ! column filter for snow points + integer , intent(inout) :: snl(1) !number of snow layers + real(kind_phys), intent(inout) :: dz(1,-nlevsnow+1:nlevsoil) !layer depth (m) + real(kind_phys), intent(inout) :: zi(1,-nlevsnow+0:nlevsoil) !interface level below a "z" level (m) + real(kind_phys), intent(inout) :: t_soisno(1,-nlevsnow+1:nlevsoil) !soil temperature (Kelvin) + real(kind_phys), intent(inout) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) !ice lens (kg/m2) + real(kind_phys), intent(inout) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) !liquid water (kg/m2) + + !out: + + real(kind_phys), intent(out) :: z(1,-nlevsnow+1:nlevsoil) !layer thickness (m) + + + + ! OTHER LOCAL VARIABLES: + + integer :: j, c, fc ! indices + real(kind_phys) :: drr ! thickness of the combined [m] + integer :: msno ! number of snow layer 1 (top) to msno (bottom) + real(kind_phys) :: dzsno(lbc:ubc,nlevsnow) ! Snow layer thickness [m] + real(kind_phys) :: swice(lbc:ubc,nlevsnow) ! Partial volume of ice [m3/m3] + real(kind_phys) :: swliq(lbc:ubc,nlevsnow) ! Partial volume of liquid water [m3/m3] + real(kind_phys) :: tsno(lbc:ubc ,nlevsnow) ! Nodel temperature [K] + real(kind_phys) :: zwice ! temporary + real(kind_phys) :: zwliq ! temporary + real(kind_phys) :: propor ! temporary + !----------------------------------------------------------------------- + + ! Begin calculation - note that the following column loops are only invoked + ! for snow-covered columns + + do j = 1,nlevsnow + !dir$ concurrent + !cdir nodep + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j <= abs(snl(c))) then + dzsno(c,j) = dz(c,j+snl(c)) + swice(c,j) = h2osoi_ice(c,j+snl(c)) + swliq(c,j) = h2osoi_liq(c,j+snl(c)) + tsno(c,j) = t_soisno(c,j+snl(c)) + end if + end do + end do + + !dir$ concurrent + !cdir nodep + do fc = 1, num_snowc + c = filter_snowc(fc) + + msno = abs(snl(c)) + + if (msno == 1) then + ! Specify a new snow layer + if (dzsno(c,1) > 0.03) then + msno = 2 + dzsno(c,1) = dzsno(c,1)/2. + swice(c,1) = swice(c,1)/2. + swliq(c,1) = swliq(c,1)/2. + dzsno(c,2) = dzsno(c,1) + swice(c,2) = swice(c,1) + swliq(c,2) = swliq(c,1) + tsno(c,2) = tsno(c,1) + end if + end if + + if (msno > 1) then + if (dzsno(c,1) > 0.02) then + drr = dzsno(c,1) - 0.02 + propor = drr/dzsno(c,1) + zwice = propor*swice(c,1) + zwliq = propor*swliq(c,1) + propor = 0.02/dzsno(c,1) + swice(c,1) = propor*swice(c,1) + swliq(c,1) = propor*swliq(c,1) + dzsno(c,1) = 0.02 + + call Combo (dzsno(c,2), swliq(c,2), swice(c,2), tsno(c,2), drr, & + zwliq, zwice, tsno(c,1)) + + ! Subdivide a new layer + if (msno <= 2 .and. dzsno(c,2) > 0.07) then + msno = 3 + dzsno(c,2) = dzsno(c,2)/2. + swice(c,2) = swice(c,2)/2. + swliq(c,2) = swliq(c,2)/2. + dzsno(c,3) = dzsno(c,2) + swice(c,3) = swice(c,2) + swliq(c,3) = swliq(c,2) + tsno(c,3) = tsno(c,2) + end if + end if + end if + + if (msno > 2) then + if (dzsno(c,2) > 0.05) then + drr = dzsno(c,2) - 0.05 + propor = drr/dzsno(c,2) + zwice = propor*swice(c,2) + zwliq = propor*swliq(c,2) + propor = 0.05/dzsno(c,2) + swice(c,2) = propor*swice(c,2) + swliq(c,2) = propor*swliq(c,2) + dzsno(c,2) = 0.05 + + call Combo (dzsno(c,3), swliq(c,3), swice(c,3), tsno(c,3), drr, & + zwliq, zwice, tsno(c,2)) + + ! Subdivided a new layer + if (msno <= 3 .and. dzsno(c,3) > 0.18) then + msno = 4 + dzsno(c,3) = dzsno(c,3)/2. + swice(c,3) = swice(c,3)/2. + swliq(c,3) = swliq(c,3)/2. + dzsno(c,4) = dzsno(c,3) + swice(c,4) = swice(c,3) + swliq(c,4) = swliq(c,3) + tsno(c,4) = tsno(c,3) + end if + end if + end if + + if (msno > 3) then + if (dzsno(c,3) > 0.11) then + drr = dzsno(c,3) - 0.11 + propor = drr/dzsno(c,3) + zwice = propor*swice(c,3) + zwliq = propor*swliq(c,3) + propor = 0.11/dzsno(c,3) + swice(c,3) = propor*swice(c,3) + swliq(c,3) = propor*swliq(c,3) + dzsno(c,3) = 0.11 + + call Combo (dzsno(c,4), swliq(c,4), swice(c,4), tsno(c,4), drr, & + zwliq, zwice, tsno(c,3)) + + ! Subdivided a new layer + if (msno <= 4 .and. dzsno(c,4) > 0.41) then + msno = 5 + dzsno(c,4) = dzsno(c,4)/2. + swice(c,4) = swice(c,4)/2. + swliq(c,4) = swliq(c,4)/2. + dzsno(c,5) = dzsno(c,4) + swice(c,5) = swice(c,4) + swliq(c,5) = swliq(c,4) + tsno(c,5) = tsno(c,4) + end if + end if + end if + + if (msno > 4) then + if (dzsno(c,4) > 0.23) then + drr = dzsno(c,4) - 0.23 + propor = drr/dzsno(c,4) + zwice = propor*swice(c,4) + zwliq = propor*swliq(c,4) + propor = 0.23/dzsno(c,4) + swice(c,4) = propor*swice(c,4) + swliq(c,4) = propor*swliq(c,4) + dzsno(c,4) = 0.23 + + call Combo (dzsno(c,5), swliq(c,5), swice(c,5), tsno(c,5), drr, & + zwliq, zwice, tsno(c,4)) + end if + end if + + snl(c) = -msno + + end do + + do j = -nlevsnow+1,0 + !dir$ concurrent + !cdir nodep + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j >= snl(c)+1) then + dz(c,j) = dzsno(c,j-snl(c)) + h2osoi_ice(c,j) = swice(c,j-snl(c)) + h2osoi_liq(c,j) = swliq(c,j-snl(c)) + t_soisno(c,j) = tsno(c,j-snl(c)) + end if + end do + end do + + do j = 0, -nlevsnow+1, -1 + !dir$ concurrent + !cdir nodep + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j >= snl(c)+1) then + z(c,j) = zi(c,j) - 0.5*dz(c,j) + zi(c,j-1) = zi(c,j) - dz(c,j) + end if + end do + end do + + end subroutine DivideSnowLayers + + subroutine Combo(dz, wliq, wice, t, dz2, wliq2, wice2, t2) + ! + ! !DESCRIPTION: + ! Combines two elements and returns the following combined + ! variables: dz, t, wliq, wice. + ! The combined temperature is based on the equation: + ! the sum of the enthalpies of the two elements = + ! that of the combined element. + ! + ! !USES: + ! + ! !ARGUMENTS: + implicit none + real(kind_phys), intent(in) :: dz2 ! nodal thickness of 2 elements being combined [m] + real(kind_phys), intent(in) :: wliq2 ! liquid water of element 2 [kg/m2] + real(kind_phys), intent(in) :: wice2 ! ice of element 2 [kg/m2] + real(kind_phys), intent(in) :: t2 ! nodal temperature of element 2 [K] + real(kind_phys), intent(inout) :: dz ! nodal thickness of 1 elements being combined [m] + real(kind_phys), intent(inout) :: wliq ! liquid water of element 1 + real(kind_phys), intent(inout) :: wice ! ice of element 1 [kg/m2] + real(kind_phys), intent(inout) :: t ! nodel temperature of elment 1 [K] + ! + ! !CALLED FROM: + ! subroutine CombineSnowLayers in this module + ! subroutine DivideSnowLayers in this module + ! + ! !REVISION HISTORY: + ! 15 September 1999: Yongjiu Dai; Initial code + ! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision + ! June 2022: Sam Trahan; modified for CCPP + ! + !EOP + ! + ! !LOCAL VARIABLES: + ! + real(kind_phys) :: dzc ! Total thickness of nodes 1 and 2 (dzc=dz+dz2). + real(kind_phys) :: wliqc ! Combined liquid water [kg/m2] + real(kind_phys) :: wicec ! Combined ice [kg/m2] + real(kind_phys) :: tc ! Combined node temperature [K] + real(kind_phys) :: h ! enthalpy of element 1 [J/m2] + real(kind_phys) :: h2 ! enthalpy of element 2 [J/m2] + real(kind_phys) :: hc ! temporary + !----------------------------------------------------------------------- + + dzc = dz+dz2 + wicec = (wice+wice2) + wliqc = (wliq+wliq2) + h = (cpice*wice+cpliq*wliq) * (t-tfrz)+hfus*wliq + h2= (cpice*wice2+cpliq*wliq2) * (t2-tfrz)+hfus*wliq2 + + hc = h + h2 + if(hc < 0.)then + tc = tfrz + hc/(cpice*wicec + cpliq*wliqc) + else if (hc.le.hfus*wliqc) then + tc = tfrz + else + tc = tfrz + (hc - hfus*wliqc) / (cpice*wicec + cpliq*wliqc) + end if + + dz = dzc + wice = wicec + wliq = wliqc + t = tc + + end subroutine Combo + + subroutine BuildSnowFilter(lbc, ubc, num_nolakec, filter_nolakec,snl, & !i + num_snowc, filter_snowc, & !o + num_nosnowc, filter_nosnowc) !o + ! + ! !DESCRIPTION: + ! Constructs snow filter for use in vectorized loops for snow hydrology. + ! + ! !USES: + ! use clmtype + ! + ! !ARGUMENTS: + implicit none + integer, intent(in) :: lbc, ubc ! column bounds + integer, intent(in) :: num_nolakec ! number of column non-lake points in column filter + integer, intent(in) :: filter_nolakec(ubc-lbc+1) ! column filter for non-lake points + integer, intent(in) :: snl(1) ! number of snow layers + integer, intent(out) :: num_snowc ! number of column snow points in column filter + integer, intent(out) :: filter_snowc(ubc-lbc+1) ! column filter for snow points + integer, intent(out) :: num_nosnowc ! number of column non-snow points in column filter + integer, intent(out) :: filter_nosnowc(ubc-lbc+1) ! column filter for non-snow points + ! + ! !CALLED FROM: + ! subroutine Hydrology2 in Hydrology2Mod + ! subroutine CombineSnowLayers in this module + ! + ! !REVISION HISTORY: + ! 2003 July 31: Forrest Hoffman + ! 2022 June: Sam Trahan modified for CCPP + ! + ! !LOCAL VARIABLES: + ! local pointers to implicit in arguments + ! + !EOP + ! + ! !OTHER LOCAL VARIABLES: + integer :: fc, c + !----------------------------------------------------------------------- + + + ! Build snow/no-snow filters for other subroutines + + num_snowc = 0 + num_nosnowc = 0 + do fc = 1, num_nolakec + c = filter_nolakec(fc) + if (snl(c) < 0) then + num_snowc = num_snowc + 1 + filter_snowc(num_snowc) = c + else + num_nosnowc = num_nosnowc + 1 + filter_nosnowc(num_nosnowc) = c + end if + end do + + end subroutine BuildSnowFilter + + + +subroutine FrictionVelocity(pgridcell,forc_hgt,forc_hgt_u, & !i + forc_hgt_t,forc_hgt_q, & !i + lbp, ubp, fn, filterp, & !i + displa, z0m, z0h, z0q, & !i + obu, iter, ur, um, & !i + ustar,temp1, temp2, temp12m, temp22m, & !o + u10,fv, & !o + fm) !i&o + + !============================================================================= + ! !DESCRIPTION: + ! Calculation of the friction velocity, relation for potential + ! temperature and humidity profiles of surface boundary layer. + ! The scheme is based on the work of Zeng et al. (1998): + ! Intercomparison of bulk aerodynamic algorithms for the computation + ! of sea surface fluxes using TOGA CORE and TAO data. J. Climate, + ! Vol. 11, 2628-2644. + ! + ! !REVISION HISTORY: + ! 15 September 1999: Yongjiu Dai; Initial code + ! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision + ! 12/19/01, Peter Thornton + ! Added arguments to eliminate passing clm derived type into this function. + ! Created by Mariana Vertenstein + ! June 2022: Sam Trahan modified for CCPP + !============================================================================ + ! !USES: + ! use clmtype + !!use clm_atmlnd, only : clm_a2l + ! + ! !ARGUMENTS: + implicit none + + !in: + + integer , intent(in) :: pgridcell(1) ! pft's gridcell index + real(kind_phys), intent(in) :: forc_hgt(1) ! atmospheric reference height (m) + real(kind_phys), intent(in) :: forc_hgt_u(1) ! observational height of wind [m] + real(kind_phys), intent(in) :: forc_hgt_t(1) ! observational height of temperature [m] + real(kind_phys), intent(in) :: forc_hgt_q(1) ! observational height of humidity [m] + integer , intent(in) :: lbp, ubp ! pft array bounds + integer , intent(in) :: fn ! number of filtered pft elements + integer , intent(in) :: filterp(fn) ! pft filter + real(kind_phys), intent(in) :: displa(lbp:ubp) ! displacement height (m) + real(kind_phys), intent(in) :: z0m(lbp:ubp) ! roughness length over vegetation, momentum [m] + real(kind_phys), intent(in) :: z0h(lbp:ubp) ! roughness length over vegetation, sensible heat [m] + real(kind_phys), intent(in) :: z0q(lbp:ubp) ! roughness length over vegetation, latent heat [m] + real(kind_phys), intent(in) :: obu(lbp:ubp) ! monin-obukhov length (m) + integer, intent(in) :: iter ! iteration number + real(kind_phys), intent(in) :: ur(lbp:ubp) ! wind speed at reference height [m/s] + real(kind_phys), intent(in) :: um(lbp:ubp) ! wind speed including the stablity effect [m/s] + + !out: + + real(kind_phys), intent(out) :: ustar(lbp:ubp) ! friction velocity [m/s] + real(kind_phys), intent(out) :: temp1(lbp:ubp) ! relation for potential temperature profile + real(kind_phys), intent(out) :: temp12m(lbp:ubp) ! relation for potential temperature profile applied at 2-m + real(kind_phys), intent(out) :: temp2(lbp:ubp) ! relation for specific humidity profile + real(kind_phys), intent(out) :: temp22m(lbp:ubp) ! relation for specific humidity profile applied at 2-m + real(kind_phys), intent(out) :: u10(1) ! 10-m wind (m/s) (for dust model) + real(kind_phys), intent(out) :: fv(1) ! friction velocity (m/s) (for dust model) + + !inout: + real(kind_phys), intent(inout) :: fm(lbp:ubp) ! needed for DGVM only to diagnose 10m wind + + ! OTHER LOCAL VARIABLES: + + real(kind_phys), parameter :: zetam = 1.574_kind_phys ! transition point of flux-gradient relation (wind profile) + real(kind_phys), parameter :: zetat = 0.465_kind_phys ! transition point of flux-gradient relation (temp. profile) + integer :: f ! pft-filter index + integer :: p ! pft index + integer :: g ! gridcell index + real(kind_phys):: zldis(lbp:ubp) ! reference height "minus" zero displacement heght [m] + real(kind_phys):: zeta(lbp:ubp) ! dimensionless height used in Monin-Obukhov theory + + !------------------------------------------------------------------------------ + + + ! Adjustment factors for unstable (moz < 0) or stable (moz > 0) conditions. + + if_not_pergro: if(.not.PERGRO) then + + !dir$ concurrent + !cdir nodep + do f = 1, fn + p = filterp(f) + g = pgridcell(p) + + ! Wind profile + + zldis(p) = forc_hgt_u(g)-displa(p) + zeta(p) = zldis(p)/obu(p) + if (zeta(p) < -zetam) then + ustar(p) = vkc*um(p)/(log(-zetam*obu(p)/z0m(p))& + - StabilityFunc1(-zetam) & + + StabilityFunc1(z0m(p)/obu(p)) & + + 1.14_kind_phys*((-zeta(p))**0.333_kind_phys-(zetam)**0.333_kind_phys)) + else if (zeta(p) < 0._kind_phys) then + ustar(p) = vkc*um(p)/(log(zldis(p)/z0m(p))& + - StabilityFunc1(zeta(p))& + + StabilityFunc1(z0m(p)/obu(p))) + else if (zeta(p) <= 1._kind_phys) then + ustar(p) = vkc*um(p)/(log(zldis(p)/z0m(p)) + 5._kind_phys*zeta(p) -5._kind_phys*z0m(p)/obu(p)) + else + ustar(p) = vkc*um(p)/(log(obu(p)/z0m(p))+5._kind_phys-5._kind_phys*z0m(p)/obu(p) & + +(5._kind_phys*log(zeta(p))+zeta(p)-1._kind_phys)) + end if + + ! Temperature profile + + zldis(p) = forc_hgt_t(g)-displa(p) + zeta(p) = zldis(p)/obu(p) + if (zeta(p) < -zetat) then + temp1(p) = vkc/(log(-zetat*obu(p)/z0h(p))& + - StabilityFunc2(-zetat) & + + StabilityFunc2(z0h(p)/obu(p)) & + + 0.8_kind_phys*((zetat)**(-0.333_kind_phys)-(-zeta(p))**(-0.333_kind_phys))) + else if (zeta(p) < 0._kind_phys) then + temp1(p) = vkc/(log(zldis(p)/z0h(p)) & + - StabilityFunc2(zeta(p)) & + + StabilityFunc2(z0h(p)/obu(p))) + else if (zeta(p) <= 1._kind_phys) then + temp1(p) = vkc/(log(zldis(p)/z0h(p)) + 5._kind_phys*zeta(p) - 5._kind_phys*z0h(p)/obu(p)) + else + temp1(p) = vkc/(log(obu(p)/z0h(p)) + 5._kind_phys - 5._kind_phys*z0h(p)/obu(p) & + + (5._kind_phys*log(zeta(p))+zeta(p)-1._kind_phys)) + end if + + ! Humidity profile + + if (forc_hgt_q(g) == forc_hgt_t(g) .and. z0q(p) == z0h(p)) then + temp2(p) = temp1(p) + else + zldis(p) = forc_hgt_q(g)-displa(p) + zeta(p) = zldis(p)/obu(p) + if (zeta(p) < -zetat) then + temp2(p) = vkc/(log(-zetat*obu(p)/z0q(p)) & + - StabilityFunc2(-zetat) & + + StabilityFunc2(z0q(p)/obu(p)) & + + 0.8_kind_phys*((zetat)**(-0.333_kind_phys)-(-zeta(p))**(-0.333_kind_phys))) + else if (zeta(p) < 0._kind_phys) then + temp2(p) = vkc/(log(zldis(p)/z0q(p)) & + - StabilityFunc2(zeta(p)) & + + StabilityFunc2(z0q(p)/obu(p))) + else if (zeta(p) <= 1._kind_phys) then + temp2(p) = vkc/(log(zldis(p)/z0q(p)) + 5._kind_phys*zeta(p)-5._kind_phys*z0q(p)/obu(p)) + else + temp2(p) = vkc/(log(obu(p)/z0q(p)) + 5._kind_phys - 5._kind_phys*z0q(p)/obu(p) & + + (5._kind_phys*log(zeta(p))+zeta(p)-1._kind_phys)) + end if + endif + + ! Temperature profile applied at 2-m + + zldis(p) = 2.0_kind_phys + z0h(p) + zeta(p) = zldis(p)/obu(p) + if (zeta(p) < -zetat) then + temp12m(p) = vkc/(log(-zetat*obu(p)/z0h(p))& + - StabilityFunc2(-zetat) & + + StabilityFunc2(z0h(p)/obu(p)) & + + 0.8_kind_phys*((zetat)**(-0.333_kind_phys)-(-zeta(p))**(-0.333_kind_phys))) + else if (zeta(p) < 0._kind_phys) then + temp12m(p) = vkc/(log(zldis(p)/z0h(p)) & + - StabilityFunc2(zeta(p)) & + + StabilityFunc2(z0h(p)/obu(p))) + else if (zeta(p) <= 1._kind_phys) then + temp12m(p) = vkc/(log(zldis(p)/z0h(p)) + 5._kind_phys*zeta(p) - 5._kind_phys*z0h(p)/obu(p)) + else + temp12m(p) = vkc/(log(obu(p)/z0h(p)) + 5._kind_phys - 5._kind_phys*z0h(p)/obu(p) & + + (5._kind_phys*log(zeta(p))+zeta(p)-1._kind_phys)) + end if + + ! Humidity profile applied at 2-m + + if (z0q(p) == z0h(p)) then + temp22m(p) = temp12m(p) + else + zldis(p) = 2.0_kind_phys + z0q(p) + zeta(p) = zldis(p)/obu(p) + if (zeta(p) < -zetat) then + temp22m(p) = vkc/(log(-zetat*obu(p)/z0q(p)) - & + StabilityFunc2(-zetat) + StabilityFunc2(z0q(p)/obu(p)) & + + 0.8_kind_phys*((zetat)**(-0.333_kind_phys)-(-zeta(p))**(-0.333_kind_phys))) + else if (zeta(p) < 0._kind_phys) then + temp22m(p) = vkc/(log(zldis(p)/z0q(p)) - & + StabilityFunc2(zeta(p))+StabilityFunc2(z0q(p)/obu(p))) + else if (zeta(p) <= 1._kind_phys) then + temp22m(p) = vkc/(log(zldis(p)/z0q(p)) + 5._kind_phys*zeta(p)-5._kind_phys*z0q(p)/obu(p)) + else + temp22m(p) = vkc/(log(obu(p)/z0q(p)) + 5._kind_phys - 5._kind_phys*z0q(p)/obu(p) & + + (5._kind_phys*log(zeta(p))+zeta(p)-1._kind_phys)) + end if + end if + end do + endif if_not_pergro + + +if_pergro: if (PERGRO) then + + !=============================================================================== + ! The following only applies when PERGRO is defined + !=============================================================================== + + !dir$ concurrent + !cdir nodep + do f = 1, fn + p = filterp(f) + g = pgridcell(p) + + zldis(p) = forc_hgt_u(g)-displa(p) + zeta(p) = zldis(p)/obu(p) + if (zeta(p) < -zetam) then ! zeta < -1 + ustar(p) = vkc * um(p) / log(-zetam*obu(p)/z0m(p)) + else if (zeta(p) < 0._kind_phys) then ! -1 <= zeta < 0 + ustar(p) = vkc * um(p) / log(zldis(p)/z0m(p)) + else if (zeta(p) <= 1._kind_phys) then ! 0 <= ztea <= 1 + ustar(p)=vkc * um(p)/log(zldis(p)/z0m(p)) + else ! 1 < zeta, phi=5+zeta + ustar(p)=vkc * um(p)/log(obu(p)/z0m(p)) + endif + + zldis(p) = forc_hgt_t(g)-displa(p) + zeta(p) = zldis(p)/obu(p) + if (zeta(p) < -zetat) then + temp1(p)=vkc/log(-zetat*obu(p)/z0h(p)) + else if (zeta(p) < 0._kind_phys) then + temp1(p)=vkc/log(zldis(p)/z0h(p)) + else if (zeta(p) <= 1._kind_phys) then + temp1(p)=vkc/log(zldis(p)/z0h(p)) + else + temp1(p)=vkc/log(obu(p)/z0h(p)) + end if + + zldis(p) = forc_hgt_q(g)-displa(p) + zeta(p) = zldis(p)/obu(p) + if (zeta(p) < -zetat) then + temp2(p)=vkc/log(-zetat*obu(p)/z0q(p)) + else if (zeta(p) < 0._kind_phys) then + temp2(p)=vkc/log(zldis(p)/z0q(p)) + else if (zeta(p) <= 1._kind_phys) then + temp2(p)=vkc/log(zldis(p)/z0q(p)) + else + temp2(p)=vkc/log(obu(p)/z0q(p)) + end if + + zldis(p) = 2.0_kind_phys + z0h(p) + zeta(p) = zldis(p)/obu(p) + if (zeta(p) < -zetat) then + temp12m(p)=vkc/log(-zetat*obu(p)/z0h(p)) + else if (zeta(p) < 0._kind_phys) then + temp12m(p)=vkc/log(zldis(p)/z0h(p)) + else if (zeta(p) <= 1._kind_phys) then + temp12m(p)=vkc/log(zldis(p)/z0h(p)) + else + temp12m(p)=vkc/log(obu(p)/z0h(p)) + end if + + zldis(p) = 2.0_kind_phys + z0q(p) + zeta(p) = zldis(p)/obu(p) + if (zeta(p) < -zetat) then + temp22m(p)=vkc/log(-zetat*obu(p)/z0q(p)) + else if (zeta(p) < 0._kind_phys) then + temp22m(p)=vkc/log(zldis(p)/z0q(p)) + else if (zeta(p) <= 1._kind_phys) then + temp22m(p)=vkc/log(zldis(p)/z0q(p)) + else + temp22m(p)=vkc/log(obu(p)/z0q(p)) + end if + end do + + endif if_pergro + + end subroutine FrictionVelocity + + ! !IROUTINE: StabilityFunc + ! + ! !INTERFACE: + real(kind_phys) function StabilityFunc1(zeta) + ! + ! !DESCRIPTION: + ! Stability function for rib < 0. + ! + ! !USES: + ! use shr_const_mod, only: SHR_CONST_PI + !Zack Subin, 7/8/08 + ! + ! !ARGUMENTS: + implicit none + real(kind_phys), intent(in) :: zeta ! dimensionless height used in Monin-Obukhov theory + ! + ! !CALLED FROM: + ! subroutine FrictionVelocity in this module + ! + ! !REVISION HISTORY: + ! 15 September 1999: Yongjiu Dai; Initial code + ! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision + ! June 2022: Sam Trahan; modified for CCPP + ! + !EOP + ! + ! !LOCAL VARIABLES: + real(kind_phys) :: chik, chik2 + !------------------------------------------------------------------------------ + + chik2 = sqrt(1._kind_phys-16._kind_phys*zeta) + chik = sqrt(chik2) + StabilityFunc1 = 2._kind_phys*log((1._kind_phys+chik)*0.5_kind_phys) & + !Changed to pie, Zack Subin, 7/9/08 + !Spelling corrected, changed to pi, Sam Trahan the Killjoy, 6/2/22 + + log((1._kind_phys+chik2)*0.5_kind_phys)-2._kind_phys*atan(chik)+pi*0.5_kind_phys + + end function StabilityFunc1 + + !------------------------------------------------------------------------------ + !BOP + ! + ! !IROUTINE: StabilityFunc2 + ! + ! !INTERFACE: + real(kind_phys) function StabilityFunc2(zeta) + ! + ! !DESCRIPTION: + ! Stability function for rib < 0. + ! + ! !USES: + !Removed by Zack Subin, 7/9/08 + ! use shr_const_mod, only: SHR_CONST_PI + ! + ! !ARGUMENTS: + implicit none + real(kind_phys), intent(in) :: zeta ! dimensionless height used in Monin-Obukhov theory + ! + ! !CALLED FROM: + ! subroutine FrictionVelocity in this module + ! + ! !REVISION HISTORY: + ! 15 September 1999: Yongjiu Dai; Initial code + ! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision + ! June 2022: Sam Trahan modified for CCPP + ! + !EOP + ! + ! !LOCAL VARIABLES: + real(kind_phys) :: chik2 + !------------------------------------------------------------------------------ + + chik2 = sqrt(1._kind_phys-16._kind_phys*zeta) + StabilityFunc2 = 2._kind_phys*log((1._kind_phys+chik2)*0.5_kind_phys) + + end function StabilityFunc2 + + !----------------------------------------------------------------------- + !BOP + ! + ! !IROUTINE: MoninObukIni + ! + ! !INTERFACE: + subroutine MoninObukIni (ur, thv, dthv, zldis, z0m, um, obu) + ! + ! !DESCRIPTION: + ! Initialization of the Monin-Obukhov length. + ! The scheme is based on the work of Zeng et al. (1998): + ! Intercomparison of bulk aerodynamic algorithms for the computation + ! of sea surface fluxes using TOGA CORE and TAO data. J. Climate, + ! Vol. 11, 2628-2644. + ! + ! !USES: + ! + ! !ARGUMENTS: + implicit none + real(kind_phys), intent(in) :: ur ! wind speed at reference height [m/s] + real(kind_phys), intent(in) :: thv ! virtual potential temperature (kelvin) + real(kind_phys), intent(in) :: dthv ! diff of vir. poten. temp. between ref. height and surface + real(kind_phys), intent(in) :: zldis ! reference height "minus" zero displacement heght [m] + real(kind_phys), intent(in) :: z0m ! roughness length, momentum [m] + real(kind_phys), intent(out) :: um ! wind speed including the stability effect [m/s] + real(kind_phys), intent(out) :: obu ! monin-obukhov length (m) + ! + ! !CALLED FROM: + ! subroutine BareGroundFluxes in module BareGroundFluxesMod.F90 + ! subroutine BiogeophysicsLake in module BiogeophysicsLakeMod.F90 + ! subroutine CanopyFluxes in module CanopyFluxesMod.F90 + ! + ! !REVISION HISTORY: + ! 15 September 1999: Yongjiu Dai; Initial code + ! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision + ! June 2022: Sam Trahan modified for CCPP + ! + !EOP + ! + ! !LOCAL VARIABLES: + ! + real(kind_phys) :: wc ! convective velocity [m/s] + real(kind_phys) :: rib ! bulk Richardson number + real(kind_phys) :: zeta ! dimensionless height used in Monin-Obukhov theory + real(kind_phys) :: ustar ! friction velocity [m/s] + !----------------------------------------------------------------------- + + ! Initial values of u* and convective velocity + + ustar=0.06_kind_phys + wc=0.5_kind_phys + if (dthv >= 0._kind_phys) then + um=max(ur,0.1_kind_phys) + else + um=sqrt(ur*ur+wc*wc) + endif + + rib=grav*zldis*dthv/(thv*um*um) + if (PERGRO) then + rib = 0._kind_phys + endif + + if (rib >= 0._kind_phys) then ! neutral or stable + zeta = rib*log(zldis/z0m)/(1._kind_phys-5._kind_phys*min(rib,0.19_kind_phys)) + zeta = min(2._kind_phys,max(zeta,0.01_kind_phys )) + else ! unstable + zeta=rib*log(zldis/z0m) + zeta = max(-100._kind_phys,min(zeta,-0.01_kind_phys )) + endif + + obu=zldis/zeta + + end subroutine MoninObukIni + +! Some fields in lakeini are not available until runtime, so this cannot be in a CCPP init routine. + SUBROUTINE lakeini( ISLTYP, gt0, SNOW, & !i + restart, lakedepth_default, & + lakedepth2d, savedtke12d, snowdp2d, h2osno2d, & !o + snl2d, t_grnd2d, t_lake3d, lake_icefrac3d, & + z_lake3d, dz_lake3d, t_soisno3d, h2osoi_ice3d, & + h2osoi_liq3d, h2osoi_vol3d, z3d, dz3d, & + zi3d, watsat3d, csol3d, tkmg3d, & + xice, xice_threshold, tsfc, & + use_lake_model, use_lakedepth, con_g, con_rd, & + tkdry3d, tksatu3d, im, prsi, & + clm_lake_initialized, & + sand3d, clay3d, tg3, & + km, me, master, errmsg, errflg) + + !============================================================================== + ! This subroutine was first edited by Hongping Gu for coupling + ! 07/20/2010 + ! Long after, in June 2022, Sam Trahan updated it for CCPP + !============================================================================== + + implicit none + + INTEGER, INTENT(OUT) :: errflg + CHARACTER(*), INTENT(OUT) :: errmsg + + INTEGER , INTENT (IN) :: im, me, master, km + REAL(KIND_PHYS), INTENT(IN) :: xice_threshold, con_g, con_rd + REAL(KIND_PHYS), DIMENSION(IM), INTENT(IN):: XICE,TG3 + REAL(KIND_PHYS), DIMENSION(IM), INTENT(IN):: tsfc + INTEGER, DIMENSION(IM) ,INTENT(INOUT) :: clm_lake_initialized + + integer, dimension(IM), intent(in) :: use_lake_model + !INTEGER , INTENT (IN) :: lakeflag + !INTEGER , INTENT (INOUT) :: lake_depth_flag + LOGICAL, INTENT (IN) :: use_lakedepth + + LOGICAL , INTENT(IN) :: restart + INTEGER, DIMENSION(IM), INTENT(IN) :: ISLTYP + REAL(KIND_PHYS), DIMENSION(IM), INTENT(IN) :: SNOW + REAL(kind_phys), DIMENSION(IM,KM), INTENT(IN) :: gt0, prsi + real(kind_phys), intent(in) :: lakedepth_default + + real(kind_phys), dimension(IM),intent(inout) :: lakedepth2d + real(kind_phys), dimension(IM),intent(out) :: savedtke12d + real(kind_phys), dimension(IM),intent(out) :: snowdp2d, & + h2osno2d, & + snl2d, & + t_grnd2d + + real(kind_phys), dimension(IM,nlevlake),INTENT(out) :: t_lake3d, & + lake_icefrac3d, & + z_lake3d, & + dz_lake3d + real(kind_phys), dimension(IM,-nlevsnow+1:nlevsoil ),INTENT(out) :: t_soisno3d, & + h2osoi_ice3d, & + h2osoi_liq3d, & + h2osoi_vol3d, & + z3d, & + dz3d + real(kind_phys), dimension(IM,nlevsoil),INTENT(out) :: watsat3d, & + csol3d, & + tkmg3d, & + tkdry3d, & + tksatu3d + real(kind_phys), dimension(IM,nlevsoil),INTENT(inout) :: clay3d, & + sand3d + + real(kind_phys), dimension( IM,-nlevsnow+0:nlevsoil ),INTENT(out) :: zi3d + + !LOGICAL, DIMENSION( : ),intent(out) :: lake + !REAL(KIND_PHYS), OPTIONAL, DIMENSION( : ), INTENT(IN) :: lake_depth ! no separate variable for this in CCPP + + real, dimension( 1:im,1:nlevsoil ) :: bsw3d, & + bsw23d, & + psisat3d, & + vwcsat3d, & + watdry3d, & + watopt3d, & + hksat3d, & + sucsat3d + integer :: n,i,j,k,ib,lev,bottom ! indices + real(kind_phys),dimension(1:im ) :: bd2d ! bulk density of dry soil material [kg/m^3] + real(kind_phys),dimension(1:im ) :: tkm2d ! mineral conductivity + real(kind_phys),dimension(1:im ) :: xksat2d ! maximum hydraulic conductivity of soil [mm/s] + real(kind_phys),dimension(1:im ) :: depthratio2d ! ratio of lake depth to standard deep lake depth + real(kind_phys),dimension(1:im ) :: clay2d ! temporary + real(kind_phys),dimension(1:im ) :: sand2d ! temporary + + real(kind_phys),parameter :: scalez = 0.025_kind_phys ! Soil layer thickness discretization (m) + logical,parameter :: arbinit = .false. + real(kind_phys),parameter :: defval = -999.0 + integer :: isl + integer :: numb_lak ! for debug + character*256 :: message + real(kind_phys) :: ht + + integer, parameter :: xcheck=38 + integer, parameter :: ycheck=92 + + integer :: used_lakedepth_default, init_points + + used_lakedepth_default=0 + + if(LAKEDEBUG .and. me==0) then + write(0,*) 'clm_lake_init' + endif + + errmsg = '' + errflg = 0 + + !IF ( RESTART ) RETURN <--- should be handled by clm_lake_initialized + + init_const: if(sum(clm_lake_initialized(1:im))==0 .and. any(use_lake_model/=0)) then + + ! dzlak(1) = 0.1_kind_phys + ! dzlak(2) = 1._kind_phys + ! dzlak(3) = 2._kind_phys + ! dzlak(4) = 3._kind_phys + ! dzlak(5) = 4._kind_phys + ! dzlak(6) = 5._kind_phys + ! dzlak(7) = 7._kind_phys + ! dzlak(8) = 7._kind_phys + ! dzlak(9) = 10.45_kind_phys + ! dzlak(10)= 10.45_kind_phys + ! + ! zlak(1) = 0.05_kind_phys + ! zlak(2) = 0.6_kind_phys + ! zlak(3) = 2.1_kind_phys + ! zlak(4) = 4.6_kind_phys + ! zlak(5) = 8.1_kind_phys + ! zlak(6) = 12.6_kind_phys + ! zlak(7) = 18.6_kind_phys + ! zlak(8) = 25.6_kind_phys + ! zlak(9) = 34.325_kind_phys + ! zlak(10)= 44.775_kind_phys + dzlak(1) = 0.1_kind_phys + dzlak(2) = 0.1_kind_phys + dzlak(3) = 0.1_kind_phys + dzlak(4) = 0.1_kind_phys + dzlak(5) = 0.1_kind_phys + dzlak(6) = 0.1_kind_phys + dzlak(7) = 0.1_kind_phys + dzlak(8) = 0.1_kind_phys + dzlak(9) = 0.1_kind_phys + dzlak(10)= 0.1_kind_phys + + zlak(1) = 0.05_kind_phys + zlak(2) = 0.15_kind_phys + zlak(3) = 0.25_kind_phys + zlak(4) = 0.35_kind_phys + zlak(5) = 0.45_kind_phys + zlak(6) = 0.55_kind_phys + zlak(7) = 0.65_kind_phys + zlak(8) = 0.75_kind_phys + zlak(9) = 0.85_kind_phys + zlak(10)= 0.95_kind_phys + + ! "0" refers to soil surface and "nlevsoil" refers to the bottom of model soil + + do j = 1, nlevsoil + zsoi(j) = scalez*(exp(0.5_kind_phys*(j-0.5_kind_phys))-1._kind_phys) !node depths + enddo + + dzsoi(1) = 0.5_kind_phys*(zsoi(1)+zsoi(2)) !thickness b/n two interfaces + do j = 2,nlevsoil-1 + dzsoi(j)= 0.5_kind_phys*(zsoi(j+1)-zsoi(j-1)) + enddo + dzsoi(nlevsoil) = zsoi(nlevsoil)-zsoi(nlevsoil-1) + + zisoi(0) = 0._kind_phys + do j = 1, nlevsoil-1 + zisoi(j) = 0.5_kind_phys*(zsoi(j)+zsoi(j+1)) !interface depths + enddo + zisoi(nlevsoil) = zsoi(nlevsoil) + 0.5_kind_phys*dzsoi(nlevsoil) + endif init_const + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + DO i=1,im + if(use_lake_model(i)==0 .or. clm_lake_initialized(i)>0) then + cycle + endif + + snowdp2d(i) = snow(i)*0.005 ! SNOW in kg/m^2 and snowdp in m + h2osno2d(i) = snow(i) ! mm + + snl2d(i) = defval + do k = -nlevsnow+1,nlevsoil + h2osoi_liq3d(i,k) = defval + h2osoi_ice3d(i,k) = defval + t_soisno3d(i,k) = defval + z3d(i,k) = defval + dz3d(i,k) = defval + enddo + do k = 1,nlevlake + t_lake3d(i,k) = defval + lake_icefrac3d(i,k) = defval + z_lake3d(i,k) = defval + dz_lake3d(i,k) = defval + enddo + + if(xice(i).gt.xice_threshold) then + lake_icefrac3d(i,1) = xice(i) + endif + + z3d(i,:) = 0.0 + dz3d(i,:) = 0.0 + zi3d(i,:) = 0.0 + h2osoi_liq3d(i,:) = 0.0 + h2osoi_ice3d(i,:) = 0.0 + lake_icefrac3d(i,:) = 0.0 + h2osoi_vol3d(i,:) = 0.0 + snl2d(i) = 0.0 + if ( use_lakedepth ) then + if (lakedepth2d(i) <= 0.0) then + lakedepth2d(i) = lakedepth_default + used_lakedepth_default = used_lakedepth_default+1 + endif + else + lakedepth2d(i) = lakedepth_default + used_lakedepth_default = used_lakedepth_default+1 + endif + + ENDDO + + if(used_lakedepth_default>0) then + print *,'used lakedepth_default: ',used_lakedepth_default + endif + + !!!!!!!!!!!!!!!!!!begin to initialize lake variables!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + init_points=0 + DO i = 1,im + + if(use_lake_model(i)==0 .or. clm_lake_initialized(i)>0) then + cycle + endif + + init_points = init_points+1 + + ! Soil hydraulic and thermal properties + isl = ISLTYP(i) + if (isl == 0 ) isl = 14 + if (isl == 14 ) isl = isl + 1 + do k = 1,nlevsoil + sand3d(i,k) = sand(isl) + clay3d(i,k) = clay(isl) + if(clay3d(i,k)>0 .and. clay3d(i,k)<1) then + write(message,*) 'bad clay3d ',clay3d(i,k) + write(0,'(A)') trim(message) + errmsg = trim(message) + errflg = 1 + return + endif + if(sand3d(i,k)>0 .and. sand3d(i,k)<1) then + write(message,*) 'bad sand3d ',sand3d(i,k) + write(0,'(A)') trim(message) + errmsg = trim(message) + errflg = 1 + return + endif + enddo + + do k = 1,nlevsoil + clay2d(i) = clay3d(i,k) + sand2d(i) = sand3d(i,k) + watsat3d(i,k) = 0.489_kind_phys - 0.00126_kind_phys*sand2d(i) + bd2d(i) = (1._kind_phys-watsat3d(i,k))*2.7e3_kind_phys + xksat2d(i) = 0.0070556_kind_phys *( 10._kind_phys**(-0.884_kind_phys+0.0153_kind_phys*sand2d(i)) ) ! mm/s + tkm2d(i) = (8.80_kind_phys*sand2d(i)+2.92_kind_phys*clay2d(i))/(sand2d(i)+clay2d(i)) ! W/(m K) + + bsw3d(i,k) = 2.91_kind_phys + 0.159_kind_phys*clay2d(i) + bsw23d(i,k) = -(3.10_kind_phys + 0.157_kind_phys*clay2d(i) - 0.003_kind_phys*sand2d(i)) + psisat3d(i,k) = -(exp((1.54_kind_phys - 0.0095_kind_phys*sand2d(i) + 0.0063_kind_phys*(100.0_kind_phys-sand2d(i) & + -clay2d(i)))*log(10.0_kind_phys))*9.8e-5_kind_phys) + vwcsat3d(i,k) = (50.5_kind_phys - 0.142_kind_phys*sand2d(i) - 0.037_kind_phys*clay2d(i))/100.0_kind_phys + hksat3d(i,k) = xksat2d(i) + sucsat3d(i,k) = 10._kind_phys * ( 10._kind_phys**(1.88_kind_phys-0.0131_kind_phys*sand2d(i)) ) + tkmg3d(i,k) = tkm2d(i) ** (1._kind_phys- watsat3d(i,k)) + tksatu3d(i,k) = tkmg3d(i,k)*0.57_kind_phys**watsat3d(i,k) + tkdry3d(i,k) = (0.135_kind_phys*bd2d(i) + 64.7_kind_phys) / (2.7e3_kind_phys - 0.947_kind_phys*bd2d(i)) + csol3d(i,k) = (2.128_kind_phys*sand2d(i)+2.385_kind_phys*clay2d(i)) / (sand2d(i)+clay2d(i))*1.e6_kind_phys ! J/(m3 K) + watdry3d(i,k) = watsat3d(i,k) * (316230._kind_phys/sucsat3d(i,k)) ** (-1._kind_phys/bsw3d(i,k)) + watopt3d(i,k) = watsat3d(i,k) * (158490._kind_phys/sucsat3d(i,k)) ** (-1._kind_phys/bsw3d(i,k)) + end do + if (lakedepth2d(i) == spval) then + if(LAKEDEBUG) then + errmsg='should not get here: lakedepth2d is spval ' + errflg=1 + return + endif + lakedepth2d(i) = zlak(nlevlake) + 0.5_kind_phys*dzlak(nlevlake) + z_lake3d(i,1:nlevlake) = zlak(1:nlevlake) + dz_lake3d(i,1:nlevlake) = dzlak(1:nlevlake) + else + depthratio2d(i) = lakedepth2d(i) / (zlak(nlevlake) + 0.5_kind_phys*dzlak(nlevlake)) + z_lake3d(i,1) = zlak(1) + dz_lake3d(i,1) = dzlak(1) + dz_lake3d(i,2:nlevlake) = dzlak(2:nlevlake)*depthratio2d(i) + z_lake3d(i,2:nlevlake) = zlak(2:nlevlake)*depthratio2d(i) + dz_lake3d(i,1)*(1._kind_phys - depthratio2d(i)) + end if + ! initial t_lake3d here + if(tsfc(i)<160) then + write(errmsg,'(A,F20.12,A)') 'Invalid tsfc value ',tsfc(i),' found. Was tsfc not initialized?' + write(0,'(A)') trim(errmsg) + errflg=1 + return + endif + t_soisno3d(i,1) = tsfc(i) + t_lake3d(i,1) = tsfc(i) + t_grnd2d(i) = tsfc(i) + do k = 2, nlevlake + if(z_lake3d(i,k).le.depth_c) then + t_soisno3d(i,k)=tsfc(i)+(277.0-tsfc(i))/depth_c*z_lake3d(i,k) + t_lake3d(i,k)=tsfc(i)+(277.0-tsfc(i))/depth_c*z_lake3d(i,k) + else + t_soisno3d(i,k) = tsfc(i) + t_lake3d(i,k) = tsfc(i) + end if + enddo + !end initial t_lake3d here + z3d(i,1:nlevsoil) = zsoi(1:nlevsoil) + zi3d(i,0:nlevsoil) = zisoi(0:nlevsoil) + dz3d(i,1:nlevsoil) = dzsoi(1:nlevsoil) + savedtke12d(i) = tkwat ! Initialize for first timestep. + + + if (snowdp2d(i) < 0.01_kind_phys) then + snl2d(i) = 0 + dz3d(i,-nlevsnow+1:0) = 0._kind_phys + z3d (i,-nlevsnow+1:0) = 0._kind_phys + zi3d(i,-nlevsnow+0:0) = 0._kind_phys + else + if ((snowdp2d(i) >= 0.01_kind_phys) .and. (snowdp2d(i) <= 0.03_kind_phys)) then + snl2d(i) = -1 + dz3d(i,0) = snowdp2d(i) + else if ((snowdp2d(i) > 0.03_kind_phys) .and. (snowdp2d(i) <= 0.04_kind_phys)) then + snl2d(i) = -2 + dz3d(i,-1) = snowdp2d(i)/2._kind_phys + dz3d(i, 0) = dz3d(i,-1) + else if ((snowdp2d(i) > 0.04_kind_phys) .and. (snowdp2d(i) <= 0.07_kind_phys)) then + snl2d(i) = -2 + dz3d(i,-1) = 0.02_kind_phys + dz3d(i, 0) = snowdp2d(i) - dz3d(i,-1) + else if ((snowdp2d(i) > 0.07_kind_phys) .and. (snowdp2d(i) <= 0.12_kind_phys)) then + snl2d(i) = -3 + dz3d(i,-2) = 0.02_kind_phys + dz3d(i,-1) = (snowdp2d(i) - 0.02_kind_phys)/2._kind_phys + dz3d(i, 0) = dz3d(i,-1) + else if ((snowdp2d(i) > 0.12_kind_phys) .and. (snowdp2d(i) <= 0.18_kind_phys)) then + snl2d(i) = -3 + dz3d(i,-2) = 0.02_kind_phys + dz3d(i,-1) = 0.05_kind_phys + dz3d(i, 0) = snowdp2d(i) - dz3d(i,-2) - dz3d(i,-1) + else if ((snowdp2d(i) > 0.18_kind_phys) .and. (snowdp2d(i) <= 0.29_kind_phys)) then + snl2d(i) = -4 + dz3d(i,-3) = 0.02_kind_phys + dz3d(i,-2) = 0.05_kind_phys + dz3d(i,-1) = (snowdp2d(i) - dz3d(i,-3) - dz3d(i,-2))/2._kind_phys + dz3d(i, 0) = dz3d(i,-1) + else if ((snowdp2d(i) > 0.29_kind_phys) .and. (snowdp2d(i) <= 0.41_kind_phys)) then + snl2d(i) = -4 + dz3d(i,-3) = 0.02_kind_phys + dz3d(i,-2) = 0.05_kind_phys + dz3d(i,-1) = 0.11_kind_phys + dz3d(i, 0) = snowdp2d(i) - dz3d(i,-3) - dz3d(i,-2) - dz3d(i,-1) + else if ((snowdp2d(i) > 0.41_kind_phys) .and. (snowdp2d(i) <= 0.64_kind_phys)) then + snl2d(i) = -5 + dz3d(i,-4) = 0.02_kind_phys + dz3d(i,-3) = 0.05_kind_phys + dz3d(i,-2) = 0.11_kind_phys + dz3d(i,-1) = (snowdp2d(i) - dz3d(i,-4) - dz3d(i,-3) - dz3d(i,-2))/2._kind_phys + dz3d(i, 0) = dz3d(i,-1) + else if (snowdp2d(i) > 0.64_kind_phys) then + snl2d(i) = -5 + dz3d(i,-4) = 0.02_kind_phys + dz3d(i,-3) = 0.05_kind_phys + dz3d(i,-2) = 0.11_kind_phys + dz3d(i,-1) = 0.23_kind_phys + dz3d(i, 0)=snowdp2d(i)-dz3d(i,-4)-dz3d(i,-3)-dz3d(i,-2)-dz3d(i,-1) + endif + end if + + do k = 0, snl2d(i)+1, -1 + z3d(i,k) = zi3d(i,k) - 0.5_kind_phys*dz3d(i,k) + zi3d(i,k-1) = zi3d(i,k) - dz3d(i,k) + end do + + ! 3:subroutine makearbinit + + if (snl2d(i) < 0) then + do k = snl2d(i)+1, 0 + ! Be careful because there may be new snow layers with bad temperatures like 0 even if + ! coming from init. con. file. + if(t_soisno3d(i,k) > 300 .or. t_soisno3d(i,k) < 200) t_soisno3d(i,k) = tsfc(i) + enddo + end if + + ! initial t_lake3d here + t_lake3d(i,1) = tsfc(i) + t_grnd2d(i) = tsfc(i) + do k = 2, nlevlake + if(z_lake3d(i,k).le.depth_c) then + t_lake3d(i,k) = tsfc(i)+(277.0-tsfc(i))/depth_c*z_lake3d(i,k) + else + t_lake3d(i,k) = 277.0 + end if + enddo + + ! initial t_soisno3d + t_soisno3d(i,1) = t_lake3d(i,nlevlake) + t_soisno3d(i,nlevsoil) = tg3(i) + do k = 2, nlevsoil-1 + t_soisno3d(i,k)=t_soisno3d(i,1)+(t_soisno3d(i,nlevsoil)-t_soisno3d(i,1))*dzsoi(k) + enddo + + do k = 1,nlevsoil + h2osoi_vol3d(i,k) = 1.0_kind_phys + h2osoi_vol3d(i,k) = min(h2osoi_vol3d(i,k),watsat3d(i,k)) + + ! soil layers + if (t_soisno3d(i,k) <= tfrz) then + h2osoi_ice3d(i,k) = dz3d(i,k)*denice*h2osoi_vol3d(i,k) + h2osoi_liq3d(i,k) = 0._kind_phys + else + h2osoi_ice3d(i,k) = 0._kind_phys + h2osoi_liq3d(i,k) = dz3d(i,k)*denh2o*h2osoi_vol3d(i,k) + endif + enddo + + do k = -nlevsnow+1, 0 + if (k > snl2d(i)) then + h2osoi_ice3d(i,k) = dz3d(i,k)*bdsno + h2osoi_liq3d(i,k) = 0._kind_phys + end if + end do + + clm_lake_initialized(i) = 1 + ENDDO + + + if(LAKEDEBUG .and. init_points>0) then + print *,'points initialized in clm_lake',init_points + end if + +END SUBROUTINE lakeini + +END MODULE clm_lake diff --git a/physics/clm_lake.meta b/physics/clm_lake.meta new file mode 100644 index 000000000..5f2f6db3f --- /dev/null +++ b/physics/clm_lake.meta @@ -0,0 +1,680 @@ +[ccpp-table-properties] + name = clm_lake + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = clm_lake_run + type = scheme +[tg3] + standard_name = deep_soil_temperature + long_name = deep soil temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[kdt] + standard_name = index_of_timestep + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = in +[first_time_step] + standard_name = flag_for_first_timestep + long_name = flag for first time step for time integration loop (cold/warmstart) + units = flag + dimensions = () + type = logical + intent = in +[flag_iter] + standard_name = flag_for_iteration + long_name = flag for iteration + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in +[zlvl] + standard_name = height_above_ground_at_lowest_model_layer + long_name = layer 1 height above ground (not MSL) + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[gt0] + standard_name = air_temperature_of_new_state + long_name = temperature updated by physics + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[prsi] + standard_name = air_pressure_at_interface + long_name = air pressure at model layer interfaces + units = Pa + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in +[con_rd] + standard_name = gas_constant_of_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[qvcurr] + standard_name = specific_humidity_of_new_state_at_surface_adjacent_layer + long_name = water vapor specific humidity at lowest model layer updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[rho0] + standard_name = air_pressure_at_surface_adjacent_layer + long_name = mean pressure at lowest model layer + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[gu0] + standard_name = x_wind_of_new_state + long_name = zonal wind updated by physics + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[gv0] + standard_name = y_wind_of_new_state + long_name = meridional wind updated by physics + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[dlwsfci] + standard_name = surface_downwelling_longwave_flux + long_name = surface downwelling longwave flux at current time + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[emiss] + standard_name = surface_longwave_emissivity + long_name = surface lw emissivity in fraction + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[rain] + standard_name = lwe_thickness_of_precipitation_amount_on_dynamics_timestep + long_name = total rain at this time step + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[dtp] + standard_name = timestep_for_physics + long_name = physics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[dswsfci] + standard_name = surface_downwelling_shortwave_flux + long_name = surface downwelling shortwave flux at current time + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[albedo] + standard_name = mid_day_surface_albedo_over_lake + long_name = mid day surface albedo over lake + units = fraction + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[xlat_d] + standard_name = latitude_in_degree + long_name = latitude in degree north + units = degree_north + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[z_lake3d] + standard_name = depth_of_lake_interface_layers + long_name = depth of lake interface layers + units = fraction + dimensions = (horizontal_loop_extent, lake_vertical_dimension_for_clm_lake_model) + type = real + kind = kind_phys + intent = inout +[dz_lake3d] + standard_name = thickness_of_lake_layers + long_name = thickness of lake layers + units = fraction + dimensions = (horizontal_loop_extent, lake_vertical_dimension_for_clm_lake_model) + type = real + kind = kind_phys + intent = inout +[lakedepth2d] + standard_name = lake_depth + long_name = lake depth + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[watsat3d] + standard_name = saturated_volumetric_soil_water_in_lake_model + long_name = saturated volumetric soil water in lake model + units = m + dimensions = (horizontal_loop_extent, lake_vertical_dimension_for_clm_lake_model) + type = real + kind = kind_phys + intent = inout +[csol3d] + standard_name = soil_heat_capacity_in_lake_model + long_name = soil heat capacity in lake model + units = m + dimensions = (horizontal_loop_extent, lake_vertical_dimension_for_clm_lake_model) + type = real + kind = kind_phys + intent = inout +[tkmg3d] + standard_name = soil_mineral_thermal_conductivity_in_lake_model + long_name = soil mineral thermal conductivity in lake model + units = m + dimensions = (horizontal_loop_extent, lake_vertical_dimension_for_clm_lake_model) + type = real + kind = kind_phys + intent = inout +[tkdry3d] + standard_name = dry_soil_thermal_conductivity_in_lake_model + long_name = dry soil thermal conductivity in lake model + units = m + dimensions = (horizontal_loop_extent, lake_vertical_dimension_for_clm_lake_model) + type = real + kind = kind_phys + intent = inout +[tksatu3d] + standard_name = saturated_soil_thermal_conductivity_in_lake_model + long_name = saturated soil thermal conductivity in lake model + units = m + dimensions = (horizontal_loop_extent, lake_vertical_dimension_for_clm_lake_model) + type = real + kind = kind_phys + intent = inout +[phii] + standard_name = geopotential_at_interface + long_name = geopotential at model layer interfaces + units = m2 s-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in +[xice] + standard_name = sea_ice_area_fraction_of_sea_area_fraction + long_name = ice fraction over open water + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[xice_threshold] + standard_name = min_lake_ice_area_fraction + long_name = minimum lake ice value + units = frac + dimensions = () + type = real + kind = kind_phys + intent = in +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[km] + standard_name = vertical_layer_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in +[h2osno2d] + standard_name = water_equivalent_accumulated_snow_depth_in_clm_lake_model + long_name = water equiv of acc snow depth over lake in clm lake model + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[snowdp2d] + standard_name = actual_snow_depth_in_clm_lake_model + long_name = actual acc snow depth over lake in clm lake model + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[snl2d] + standard_name = snow_layers_in_clm_lake_model + long_name = snow layers in clm lake model (treated as integer) + units = count + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[z3d] + standard_name = snow_level_depth_in_clm_lake_model + long_name = snow level depth in clm lake model + units = m + dimensions = (horizontal_loop_extent,snow_plus_soil_minus_one_vertical_dimension_for_clm_lake_model) + type = real + kind = kind_phys + intent = inout +[dz3d] + standard_name = snow_level_thickness_in_clm_lake_model + long_name = snow level thickness in clm lake model + units = m + dimensions = (horizontal_loop_extent,snow_plus_soil_minus_one_vertical_dimension_for_clm_lake_model) + type = real + kind = kind_phys + intent = inout +[zi3d] + standard_name = snow_interface_depth_in_clm_lake_model + long_name = snow interface_depth in clm lake model + units = m + dimensions = (horizontal_loop_extent,snow_plus_soil_vertical_dimension_for_clm_lake_model) + type = real + kind = kind_phys + intent = inout +[h2osoi_vol3d] + standard_name = volumetric_soil_water_in_clm_lake_model + long_name = volumetric soil water in clm lake model + units = m3 m-3 + dimensions = (horizontal_loop_extent,snow_plus_soil_minus_one_vertical_dimension_for_clm_lake_model) + type = real + kind = kind_phys + intent = inout +[h2osoi_liq3d] + standard_name = soil_liquid_water_content_in_clm_lake_model + long_name = soil liquid water content in clm lake model + units = kg m-3 + dimensions = (horizontal_loop_extent,snow_plus_soil_minus_one_vertical_dimension_for_clm_lake_model) + type = real + kind = kind_phys + intent = inout +[h2osoi_ice3d] + standard_name = soil_ice_water_content_in_clm_lake_model + long_name = soil ice water content in clm lake model + units = kg m-3 + dimensions = (horizontal_loop_extent,snow_plus_soil_minus_one_vertical_dimension_for_clm_lake_model) + type = real + kind = kind_phys + intent = inout +[t_grnd2d] + standard_name = skin_temperature_from_clm_lake_model + long_name = skin_temperature_from_clm_lake_model + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[t_soisno3d] + standard_name = soil_or_snow_layer_temperature_from_clm_lake_model + long_name = soil or snow layer temperature from clm lake model + units = K + dimensions = (horizontal_loop_extent,snow_plus_soil_minus_one_vertical_dimension_for_clm_lake_model) + type = real + kind = kind_phys + intent = inout +[t_lake3d] + standard_name = lake_layer_temperature_from_clm_lake_model + long_name = lake layer temperature from clm lake model + units = K + dimensions = (horizontal_loop_extent,lake_vertical_dimension_for_clm_lake_model) + type = real + kind = kind_phys + intent = inout +[savedtke12d] + standard_name = top_level_eddy_conductivity_from_previous_timestep_in_clm_lake_model + long_name = top level eddy conductivity from previous timestep in clm lake model + units = kg m-3 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[lake_icefrac3d] + standard_name = lake_fractional_ice_cover_on_clm_lake_levels + long_name = lake fractional ice cover on clm lake levels + units = kg m-3 + dimensions = (horizontal_loop_extent,lake_vertical_dimension_for_clm_lake_model) + type = real + kind = kind_phys + intent = inout +[con_cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[hflx] + standard_name = kinematic_surface_upward_sensible_heat_flux_over_water + long_name = kinematic surface upward sensible heat flux over water + units = K m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[evap] + standard_name = kinematic_surface_upward_latent_heat_flux_over_water + long_name = kinematic surface upward latent heat flux over water + units = kg kg-1 m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[grdflx] + standard_name = upward_heat_flux_in_soil_over_water + long_name = soil heat flux over water + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[tsfc] + standard_name = surface_skin_temperature + long_name = surface skin temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[lake_t2m] + standard_name = temperature_at_2m_from_clm_lake + long_name = temperature at 2m from clm lake + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[lake_q2m] + standard_name = specific_humidity_at_2m_from_clm_lake + long_name = specific humidity at 2m from clm lake + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[clm_lake_initialized] + standard_name = flag_for_clm_lake_initialization + long_name = set to true in clm_lake_run after likeini is called, as a workaround for ccpp limitation + units = flag + dimensions = (horizontal_loop_extent) + type = integer + intent = inout +[isltyp] + standard_name = soil_type_classification + long_name = soil type at each grid cell + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = inout +[snow] + standard_name = surface_snow_thickness_water_equivalent_over_land + long_name = water equivalent snow depth over land + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[use_lakedepth] + standard_name = flag_for_initializing_clm_lake_depth_from_lake_depth + long_name = flag for initializing clm lake depth from lake depth + units = flag + dimensions = () + type = logical + intent = in +[restart] + standard_name = flag_for_restart + long_name = flag for restart (warmstart) or coldstart + units = flag + dimensions = () + type = logical + intent = in +[lakedepth_default] + standard_name = default_lake_depth_in_clm_lake_model + long_name = default lake depth in clm lake model + units = m + dimensions = () + type = real + kind = kind_phys + intent = in +[use_lake_model] + standard_name = flag_for_using_lake_model + long_name = flag indicating lake points using a lake model + units = flag + dimensions = (horizontal_loop_extent) + type = integer + intent = inout +[iopt_lake] + standard_name = control_for_lake_model_selection + long_name = control for lake model selection + units = 1 + dimensions = () + type = integer + intent = in +[iopt_lake_clm] + standard_name = clm_lake_model_control_selection_value + long_name = value that indicates clm lake model in the control for lake model selection + units = 1 + dimensions = () + type = integer + intent = in +[clay3d] + standard_name = clm_lake_percent_clay + long_name = percent clay in clm lake model + units = percent + dimensions = (horizontal_loop_extent,soil_vertical_dimension_for_clm_lake_model) + type = integer + intent = inout +[sand3d] + standard_name = clm_lake_percent_sand + long_name = percent sand in clm lake model + units = percent + dimensions = (horizontal_loop_extent,soil_vertical_dimension_for_clm_lake_model) + type = integer + intent = inout +[weasd] + standard_name = water_equivalent_accumulated_snow_depth_over_ice + long_name = water equiv of acc snow depth over ice + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[snwdph] + standard_name = surface_snow_thickness_water_equivalent_over_ice + long_name = water equivalent snow depth over ice + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[hice] + standard_name = sea_ice_thickness + long_name = sea ice thickness + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[tsurf] + standard_name = surface_skin_temperature_after_iteration_over_water + long_name = surface skin temperature after iteration over water + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[t_sfc] + standard_name = surface_skin_temperature_over_water + long_name = surface skin temperature over water + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[lflx] + standard_name = surface_upward_potential_latent_heat_flux_over_water + long_name = surface upward potential latent heat flux over water + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[ustar] + standard_name = surface_friction_velocity_over_water + long_name = surface friction velocity over water + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[qsfc] + standard_name = surface_specific_humidity_over_water + long_name = surface air saturation specific humidity over water + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[ch] + standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air_over_water + long_name = surface exchange coeff heat surface exchange coeff heat & moisture over ocean moisture over water + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[cm] + standard_name = surface_drag_coefficient_for_momentum_in_air_over_water + long_name = surface exchange coeff for momentum over water + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[chh] + standard_name = surface_drag_mass_flux_for_heat_and_moisture_in_air_over_water + long_name = thermal exchange coefficient over water + units = kg m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[cmm] + standard_name = surface_drag_wind_speed_for_momentum_in_air_over_water + long_name = momentum exchange coefficient over water + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[T_snow] + standard_name = temperature_of_snow_on_lake + long_name = the temperature of snow on a lake + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[T_ice] + standard_name = surface_skin_temperature_over_ice + long_name = surface skin temperature over ice + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[tsurf_ice] + standard_name = surface_skin_temperature_after_iteration_over_ice + long_name = surface skin temperature after iteration over ice + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[wind] + standard_name = wind_speed_at_lowest_model_layer + long_name = wind speed at lowest model level + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[xlon_d] + standard_name = longitude_in_degree + long_name = longitude in degree east + units = degree_east + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[me] + standard_name = mpi_rank + long_name = current MPI-rank + units = index + dimensions = () + type = integer + intent = in +[master] + standard_name = mpi_root + long_name = master MPI-rank + units = index + dimensions = () + type = integer + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out diff --git a/physics/flake_driver.F90 b/physics/flake_driver.F90 index a78c6acf6..e27d32ff3 100644 --- a/physics/flake_driver.F90 +++ b/physics/flake_driver.F90 @@ -51,7 +51,7 @@ SUBROUTINE flake_driver_run ( & ! ---- Inputs im, ps, t1, q1, wind, min_lakeice, & dlwflx, dswsfc, lakedepth, lakefrac, & - use_flake, snow, xlat, delt, zlvl, elev, & + use_lake_model, snow, xlat, delt, zlvl, elev, & wet, yearlen, julian, imon, & flag_iter, first_time_step, flag_restart, & weasd, & @@ -103,7 +103,7 @@ SUBROUTINE flake_driver_run ( & real (kind=kind_phys), intent(in) :: julian logical, dimension(:), intent(in) :: flag_iter, wet - integer, dimension(:), intent(in) :: use_flake + integer, dimension(:), intent(in) :: use_lake_model logical, intent(in) :: flag_restart, first_time_step character(len=*), intent(out) :: errmsg @@ -223,7 +223,7 @@ SUBROUTINE flake_driver_run ( & do_flake = .false. do i = 1, im - flag(i) = flag_iter(i) .and. use_flake(i) .gt. 0 + flag(i) = flag_iter(i) .and. use_lake_model(i) .gt. 0 do_flake = flag(i) .or. do_flake enddo if (.not. do_flake) return @@ -308,13 +308,13 @@ SUBROUTINE flake_driver_run ( & ! w_extinc(i) = 3.0 ! write(0,1002) julian,xlat(i),w_albedo(I),w_extinc(i),elev(i),tsurf(i),T_sfc(i),t_bot1(i) -! write(0,1003) use_flake(i),i,lakefrac(i),lakedepth(i), snwdph(i), hice(i), fice(i) +! write(0,1003) use_lake_model(i),i,lakefrac(i),lakedepth(i), snwdph(i), hice(i), fice(i) ! write(0,1004) ps(i), wind(i), t1(i), q1(i), dlwflx(i), dswsfc(i), zlvl(i) endif !flag enddo 1002 format ( 'julian=',F6.2,1x,F8.3,1x,2(E7.2,1x),E7.2,1x,3(E7.2,1x)) - 1003 format ( 'use_flake=',I2,1x,I3,1x,F6.4,1x,F9.4,1x,2(F8.4,1x),F7.4) + 1003 format ( 'use_lake_model=',I2,1x,I3,1x,F6.4,1x,F9.4,1x,2(F8.4,1x),F7.4) 1004 format ( 'pressure',F12.2,1x,F6.2,1x,F7.2,1x,F7.4,1x,2(F8.2,1x),F8.4) ! ! call lake interface @@ -429,7 +429,7 @@ SUBROUTINE flake_driver_run ( & ! fice(i) = 1.0 ! endif enddo !iter loop -! endif !endif use_flake +! endif !endif use_lake_model endif !endif of flag @@ -462,8 +462,8 @@ end subroutine flake_driver_post_finalize !> \section arg_table_flake_driver_post Argument Table !! \htmlinclude flake_driver_post.html !! -subroutine flake_driver_post_run (im, use_flake, h_ML, T_wML, Tsurf, & - lakedepth, xz, zm, tref, tsfco, & +subroutine flake_driver_post_run (im, use_lake_model, h_ML, T_wML, & + Tsurf, lakedepth, xz, zm, tref, tsfco, & errmsg, errflg) !use machine , only : kind_phys @@ -479,7 +479,7 @@ subroutine flake_driver_post_run (im, use_flake, h_ML, T_wML, Tsurf, & real (kind=kind_phys),dimension(:),intent(inout) :: & & xz, zm, tref, tsfco - integer, dimension(:), intent(in) :: use_flake + integer, dimension(:), intent(in) :: use_lake_model character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -490,8 +490,8 @@ subroutine flake_driver_post_run (im, use_flake, h_ML, T_wML, Tsurf, & errflg = 0 do I=1, im - if(use_flake(i).eq.2) then - write(0,*)'flake-post-use-flake= ',use_flake(i) + if(use_lake_model(i).eq.2) then + write(0,*)'flake-post-use-lake-model= ',use_lake_model(i) xz(i) = lakedepth(i) zm(i) = h_ML(i) tref(i) = tsurf(i) diff --git a/physics/flake_driver.meta b/physics/flake_driver.meta index 67822df05..834bfd0a4 100644 --- a/physics/flake_driver.meta +++ b/physics/flake_driver.meta @@ -126,9 +126,9 @@ type = real kind = kind_phys intent = in -[use_flake] - standard_name = flag_for_using_flake - long_name = flag indicating lake points using flake model +[use_lake_model] + standard_name = flag_for_using_lake_model + long_name = flag indicating lake points using a lake model units = flag dimensions = (horizontal_loop_extent) type = integer diff --git a/physics/radiation_surface.f b/physics/radiation_surface.f index ffda6fd89..559009850 100644 --- a/physics/radiation_surface.f +++ b/physics/radiation_surface.f @@ -27,7 +27,7 @@ ! (sfcalb) ! ! ! ! 'setemis' -- set up surface emissivity for lw radiation ! -! ( lsm,lsm_noahmp,lsm_ruc,frac_grid,cplice,use_flake, ! +! ( lsm,lsm_noahmp,lsm_ruc,frac_grid,cplice,use_lake_model, ! ! --- inputs: ! lakefrac,xlon,xlat,slmsk,snodl,snodi,sncovr,sncovr_ice, ! ! zorlf,tsknf,tairf,hprif, ! @@ -731,7 +731,7 @@ end subroutine setalb !! @{ !----------------------------------- subroutine setemis & - & ( lsm,lsm_noahmp,lsm_ruc,frac_grid,cplice,use_flake, & ! --- inputs: + & ( lsm,lsm_noahmp,lsm_ruc,frac_grid,cplice,use_lake_model, & ! --- inputs: & lakefrac,xlon,xlat,slmsk,snodl,snodi,sncovr,sncovr_ice, & & zorlf,tsknf,tairf,hprif, & & semis_lnd,semis_ice,semis_wat,IMAX,fracl,fraco,fraci,icy, & @@ -794,7 +794,7 @@ subroutine setemis & integer, intent(in) :: IMAX integer, intent(in) :: lsm, lsm_noahmp, lsm_ruc logical, intent(in) :: frac_grid, cplice - integer, dimension(:), intent(in) :: use_flake + integer, dimension(:), intent(in) :: use_lake_model real (kind=kind_phys), dimension(:), intent(in) :: lakefrac real (kind=kind_phys), dimension(:), intent(in) :: & @@ -959,7 +959,7 @@ subroutine setemis & sfcemis_ice = semis_ice(i) ! output from CICE endif elseif (lsm == lsm_ruc) then - if (use_flake(i)>0) then + if (use_lake_model(i)>0) then if (sncovr_ice(i) > f_zero) then sfcemis_ice = emsref(7) * (f_one-sncovr_ice(i)) & & + emsref(8) * sncovr_ice(i) diff --git a/physics/scm_sfc_flux_spec.F90 b/physics/scm_sfc_flux_spec.F90 index bb2c47f48..5dfec59b1 100644 --- a/physics/scm_sfc_flux_spec.F90 +++ b/physics/scm_sfc_flux_spec.F90 @@ -55,7 +55,7 @@ end subroutine scm_sfc_flux_spec_finalize subroutine scm_sfc_flux_spec_run (im, u1, v1, z1, t1, q1, p1, roughness_length, spec_sh_flux, spec_lh_flux, & exner_inverse, T_surf, cp, grav, hvap, rd, fvirt, vonKarman, tgice, islmsk, dry, frland, cice, icy, tisfc,& oceanfrac, min_seaice, cplflx, cplice, flag_cice, wet, min_lakeice, tsfcl, tsfc_wat, slmsk, lakefrac, lkm,& - lakedepth, use_flake, sh_flux, lh_flux, sh_flux_chs, u_star, sfc_stress, cm, ch, & + lakedepth, use_lake_model, sh_flux, lh_flux, sh_flux_chs, u_star, sfc_stress, cm, ch, & fm, fh, rb, u10m, v10m, wind1, qss, t2m, q2m, errmsg, errflg) use machine, only: kind_phys @@ -63,7 +63,7 @@ subroutine scm_sfc_flux_spec_run (im, u1, v1, z1, t1, q1, p1, roughness_length, integer, intent(in) :: im, lkm integer, intent(inout) :: islmsk(:) logical, intent(in) :: cplflx, cplice - logical, intent(inout) :: dry(:), icy(:), flag_cice(:), wet(:), use_flake(:) + logical, intent(inout) :: dry(:), icy(:), flag_cice(:), wet(:), use_lake_model(:) real(kind=kind_phys), intent(in) :: cp, grav, hvap, rd, fvirt, vonKarman, min_seaice, tgice, min_lakeice real(kind=kind_phys), intent(in) :: u1(:), v1(:), z1(:), t1(:), q1(:), p1(:), roughness_length(:), & spec_sh_flux(:), spec_lh_flux(:), exner_inverse(:), T_surf(:), oceanfrac(:), lakefrac(:), lakedepth(:) @@ -215,12 +215,12 @@ subroutine scm_sfc_flux_spec_run (im, u1, v1, z1, t1, q1, p1, roughness_length, do i = 1, im if ((wet(i) .or. icy(i)) .and. lakefrac(i) > 0.0_kind_phys) then if (lkm == 1 .and. lakefrac(i) >= 0.15 .and. lakedepth(i) > 1.0_kind_phys) then - use_flake(i) = .true. + use_lake_model(i) = .true. else - use_flake(i) = .false. + use_lake_model(i) = .false. endif else - use_flake(i) = .false. + use_lake_model(i) = .false. endif enddo ! diff --git a/physics/scm_sfc_flux_spec.meta b/physics/scm_sfc_flux_spec.meta index 03e3205f5..52722f1c4 100644 --- a/physics/scm_sfc_flux_spec.meta +++ b/physics/scm_sfc_flux_spec.meta @@ -315,8 +315,8 @@ kind = kind_phys intent = in [lkm] - standard_name = control_for_lake_surface_scheme - long_name = flag for lake surface model + standard_name = control_for_lake_model_execution_method + long_name = control for lake model execution: 0=no lake, 1=lake, 2=lake+nsst units = flag dimensions = () type = integer @@ -329,12 +329,12 @@ type = real kind = kind_phys intent = in -[use_flake] - standard_name = flag_for_using_flake - long_name = flag indicating lake points using flake model +[use_lake_model] + standard_name = flag_for_using_lake_model + long_name = flag indicating lake points using a lake model units = flag dimensions = (horizontal_loop_extent) - type = logical + type = integer intent = inout [sh_flux] standard_name = surface_upward_temperature_flux diff --git a/physics/sfc_diff.f b/physics/sfc_diff.f index 7a7a4496c..89941e79f 100644 --- a/physics/sfc_diff.f +++ b/physics/sfc_diff.f @@ -84,7 +84,8 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) & fm10_wat, fm10_lnd, fm10_ice, & !intent(inout) & fh2_wat, fh2_lnd, fh2_ice, & !intent(inout) & ztmax_wat, ztmax_lnd, ztmax_ice, & !intent(inout) - & zvfun, use_flake, & !intent(out) + & zvfun, & !intent(out) + & use_lake_model, & !intent(in) & errmsg, errflg) !intent(out) ! implicit none @@ -94,7 +95,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) integer, intent(in) :: sfc_z0_type ! option for calculating surface roughness length over ocean integer, dimension(:), intent(in) :: vegtype - integer, dimension(:), intent(in) :: use_flake + integer, dimension(:), intent(in) :: use_lake_model logical, intent(in) :: redrag ! reduced drag coeff. flag for high wind over sea (j.han) logical, dimension(:), intent(in) :: flag_iter, dry, icy @@ -174,7 +175,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! surface roughness length is converted to m from cm ! do i=1,im - if(use_flake(i) > 0) wet(i) = .true. + if(use_lake_model(i) > 0) wet(i) = .true. enddo ! write(0,*)'in sfc_diff, sfc_z0_type=',sfc_z0_type diff --git a/physics/sfc_diff.meta b/physics/sfc_diff.meta index 33149eb16..e0fedfa45 100644 --- a/physics/sfc_diff.meta +++ b/physics/sfc_diff.meta @@ -565,9 +565,9 @@ type = real kind = kind_phys intent = inout -[use_flake] - standard_name = flag_for_using_flake - long_name = flag indicating lake points using flake model +[use_lake_model] + standard_name = flag_for_using_lake_model + long_name = flag indicating lake points using a lake model units = flag dimensions = (horizontal_loop_extent) type = integer diff --git a/physics/sfc_nst.f b/physics/sfc_nst.f index e8e3627c5..0795be00c 100644 --- a/physics/sfc_nst.f +++ b/physics/sfc_nst.f @@ -17,7 +17,7 @@ subroutine sfc_nst_run & & ( im, hvap, cp, hfus, jcal, eps, epsm1, rvrdm1, rd, rhw0, & ! --- inputs: & pi, tgice, sbc, ps, u1, v1, t1, q1, tref, cm, ch, & & lseaspray, fm, fm10, & - & prsl1, prslki, prsik1, prslk1, wet, use_flake, xlon, & + & prsl1, prslki, prsik1, prslk1, wet, use_lake_model, xlon, & & sinlat, stress, & & sfcemis, dlwflx, sfcnsw, rain, timestep, kdt, solhr,xcosz, & & wind, flag_iter, flag_guess, nstf_name1, nstf_name4, & @@ -37,7 +37,7 @@ subroutine sfc_nst_run & ! inputs: ! ! ( im, ps, u1, v1, t1, q1, tref, cm, ch, ! ! lseaspray, fm, fm10, ! -! prsl1, prslki, wet, use_flake, xlon, sinlat, stress, ! +! prsl1, prslki, wet, use_lake_model, xlon, sinlat, stress, ! ! sfcemis, dlwflx, sfcnsw, rain, timestep, kdt,solhr,xcosz, ! ! wind, flag_iter, flag_guess, nstf_name1, nstf_name4, ! ! nstf_name5, lprnt, ipr, thsfc_loc, ! @@ -88,7 +88,7 @@ subroutine sfc_nst_run & ! prsik1 - real, im ! ! prslk1 - real, im ! ! wet - logical, =T if any ocn/lake water (F otherwise) im ! -! use_flake- logical, =T if flake model is used for lake im ! +! use_lake_model- logical, =T if flake model is used for lake im ! ! icy - logical, =T if any ice im ! ! xlon - real, longitude (radians) im ! ! sinlat - real, sin of latitude im ! @@ -194,7 +194,7 @@ subroutine sfc_nst_run & logical, intent(in) :: lseaspray ! logical, dimension(:), intent(in) :: flag_iter, flag_guess, wet - integer, dimension(:), intent(in) :: use_flake + integer, dimension(:), intent(in) :: use_lake_model ! &, icy logical, intent(in) :: lprnt logical, intent(in) :: thsfc_loc @@ -276,7 +276,7 @@ subroutine sfc_nst_run & do_nst = .false. do i = 1, im ! flag(i) = wet(i) .and. .not.icy(i) .and. flag_iter(i) - flag(i) = wet(i) .and. flag_iter(i) .and. use_flake(i)/=1 + flag(i) = wet(i) .and. flag_iter(i) .and. use_lake_model(i)/=1 do_nst = do_nst .or. flag(i) enddo if (.not. do_nst) return @@ -285,7 +285,7 @@ subroutine sfc_nst_run & ! do i=1, im ! if(wet(i) .and. .not.icy(i) .and. flag_guess(i)) then - if(wet(i) .and. flag_guess(i) .and. use_flake(i)/=1) then + if(wet(i) .and. flag_guess(i) .and. use_lake_model(i)/=1) then xt_old(i) = xt(i) xs_old(i) = xs(i) xu_old(i) = xu(i) @@ -604,7 +604,7 @@ subroutine sfc_nst_run & ! restore nst-related prognostic fields for guess run do i=1, im ! if (wet(i) .and. .not.icy(i)) then - if (wet(i) .and. use_flake(i)/=1) then + if (wet(i) .and. use_lake_model(i)/=1) then if (flag_guess(i)) then ! when it is guess of xt(i) = xt_old(i) xs(i) = xs_old(i) diff --git a/physics/sfc_nst.meta b/physics/sfc_nst.meta index 3f281231c..dc35ec959 100644 --- a/physics/sfc_nst.meta +++ b/physics/sfc_nst.meta @@ -236,9 +236,9 @@ dimensions = (horizontal_loop_extent) type = logical intent = in -[use_flake] - standard_name = flag_for_using_flake - long_name = flag indicating lake points using flake model +[use_lake_model] + standard_name = flag_for_using_lake_model + long_name = flag indicating lake points using a lake model units = flag dimensions = (horizontal_loop_extent) type = integer diff --git a/physics/sfc_nst_post.f b/physics/sfc_nst_post.f index b316dccd0..83bc2f273 100644 --- a/physics/sfc_nst_post.f +++ b/physics/sfc_nst_post.f @@ -15,8 +15,8 @@ module sfc_nst_post ! \section NSST_detailed_post_algorithm Detailed Algorithm ! @{ subroutine sfc_nst_post_run & - & ( im, kdt, rlapse, tgice, wet, use_flake, icy, oro, oro_uf, & - & nstf_name1, & + & ( im, kdt, rlapse, tgice, wet, use_lake_model, icy, oro, & + & oro_uf, nstf_name1, & & nstf_name4, nstf_name5, xt, xz, dt_cool, z_c, tref, xlon, & & tsurf_wat, tsfc_wat, nthreads, dtzm, errmsg, errflg & & ) @@ -31,7 +31,7 @@ subroutine sfc_nst_post_run & ! --- inputs: integer, intent(in) :: im, kdt, nthreads logical, dimension(:), intent(in) :: wet, icy - integer, dimension(:), intent(in) :: use_flake + integer, dimension(:), intent(in) :: use_lake_model real (kind=kind_phys), intent(in) :: rlapse, tgice real (kind=kind_phys), dimension(:), intent(in) :: oro, oro_uf integer, intent(in) :: nstf_name1, nstf_name4, nstf_name5 @@ -76,7 +76,7 @@ subroutine sfc_nst_post_run & do i = 1, im ! if (wet(i) .and. .not.icy(i)) then ! if (wet(i) .and. (frac_grid .or. .not. icy(i))) then - if (wet(i) .and. use_flake(i) /=1) then + if (wet(i) .and. use_lake_model(i) /=1) then tsfc_wat(i) = max(tgice, tref(i) + dtzm(i)) ! tsfc_wat(i) = max(271.2, tref(i) + dtzm(i)) - & ! (oro(i)-oro_uf(i))*rlapse diff --git a/physics/sfc_nst_post.meta b/physics/sfc_nst_post.meta index 45257fe41..7f66118e9 100644 --- a/physics/sfc_nst_post.meta +++ b/physics/sfc_nst_post.meta @@ -45,9 +45,9 @@ dimensions = (horizontal_loop_extent) type = logical intent = in -[use_flake] - standard_name = flag_for_using_flake - long_name = flag indicating lake points using flake model +[use_lake_model] + standard_name = flag_for_using_lake_model + long_name = flag indicating lake points using a lake model units = flag dimensions = (horizontal_loop_extent) type = integer diff --git a/physics/sfc_ocean.F b/physics/sfc_ocean.F index 574388317..97934e9a7 100644 --- a/physics/sfc_ocean.F +++ b/physics/sfc_ocean.F @@ -28,7 +28,7 @@ subroutine sfc_ocean_run & ! --- inputs: & ( im, hvap, cp, rd, eps, epsm1, rvrdm1, ps, u1, v1, t1, q1, & & tskin, cm, ch, lseaspray, fm, fm10, & - & prsl1, prslki, wet, use_flake, wind, &, ! --- inputs + & prsl1, prslki, wet, use_lake_model, wind, &, ! --- inputs & flag_iter, use_med_flux, dqsfc_med, dtsfc_med, & & qsurf, cmm, chh, gflux, evap, hflx, ep, & ! --- outputs & errmsg, errflg & @@ -42,7 +42,7 @@ subroutine sfc_ocean_run & ! call sfc_ocean ! ! inputs: ! ! ( im, ps, u1, v1, t1, q1, tskin, cm, ch, lseaspray, fm, fm10, ! -! prsl1, prslki, wet, use_flake, wind, flag_iter, ! +! prsl1, prslki, wet, use_lake_model, wind, flag_iter, ! ! use_med_flux, ! ! outputs: ! ! qsurf, cmm, chh, gflux, evap, hflx, ep ) ! @@ -118,7 +118,7 @@ subroutine sfc_ocean_run & logical, intent(in) :: lseaspray ! logical, dimension(:), intent(in) :: flag_iter, wet - integer, dimension(:), intent(in) :: use_flake + integer, dimension(:), intent(in) :: use_lake_model ! logical, intent(in) :: use_med_flux @@ -167,7 +167,7 @@ subroutine sfc_ocean_run & ! ! --- ... flag for open water do i = 1, im - flag(i) = (wet(i) .and. flag_iter(i) .and. use_flake(i) /=1) + flag(i) = (wet(i) .and. flag_iter(i) .and. use_lake_model(i)/=1) ! --- ... initialize variables. all units are supposedly m.k.s. unless specified ! ps is in pascals, wind is wind speed, ! rho is density, qss is sat. hum. at surface diff --git a/physics/sfc_ocean.meta b/physics/sfc_ocean.meta index f30be6ea8..15812e723 100644 --- a/physics/sfc_ocean.meta +++ b/physics/sfc_ocean.meta @@ -172,9 +172,9 @@ dimensions = (horizontal_loop_extent) type = logical intent = in -[use_flake] - standard_name = flag_for_using_flake - long_name = flag indicating lake points using flake model +[use_lake_model] + standard_name = flag_for_using_lake_model + long_name = flag indicating lake points using a lake model units = flag dimensions = (horizontal_loop_extent) type = integer diff --git a/physics/sfc_sice.f b/physics/sfc_sice.f index 195ebec80..64b457283 100644 --- a/physics/sfc_sice.f +++ b/physics/sfc_sice.f @@ -45,7 +45,7 @@ subroutine sfc_sice_run & & t0c, rd, ps, t1, q1, delt, & & sfcemis, dlwflx, sfcnsw, sfcdsw, srflag, & & cm, ch, prsl1, prslki, prsik1, prslk1, wind, & - & flag_iter, use_flake, lprnt, ipr, thsfc_loc, & + & flag_iter, use_lake_model, lprnt, ipr, thsfc_loc, & & hice, fice, tice, weasd, tsfc_wat, tprcp, tiice, ep, & ! --- input/outputs: & snwdph, qss_i, qss_w, snowmt, gflux, cmm, chh, & & evapi, evapw, hflxi, hflxw, islmsk, & @@ -111,7 +111,7 @@ subroutine sfc_sice_run & ! islimsk - integer, sea/land/ice mask (=0/1/2) im ! ! wind - real, im ! ! flag_iter- logical, im ! -! use_flake- logical, true for lakes when when lkm > 0 im ! +! use_lake_model- logical, true for lakes when when lkm > 0 im ! ! thsfc_loc- logical, reference pressure for potential temp im ! ! ! ! input/outputs: ! @@ -168,7 +168,7 @@ subroutine sfc_sice_run & real (kind=kind_phys), intent(in) :: delt logical, dimension(im), intent(in) :: flag_iter - integer, dimension(im), intent(in) :: use_flake + integer, dimension(im), intent(in) :: use_lake_model ! --- input/outputs: real (kind=kind_phys), dimension(:), intent(inout) :: hice, & @@ -216,7 +216,7 @@ subroutine sfc_sice_run & do_sice = .false. do i = 1, im flag(i) = islmsk(i) == 2 .and. flag_iter(i) & - & .and. use_flake(i) /=1 + & .and. use_lake_model(i) /=1 do_sice = do_sice .or. flag(i) ! if (flag_iter(i) .and. islmsk(i) < 2) then ! hice(i) = zero diff --git a/physics/sfc_sice.meta b/physics/sfc_sice.meta index 489c3758b..75aab21a4 100644 --- a/physics/sfc_sice.meta +++ b/physics/sfc_sice.meta @@ -236,9 +236,9 @@ dimensions = (horizontal_loop_extent) type = logical intent = in -[use_flake] - standard_name = flag_for_using_flake - long_name = flag indicating lake points using flake model +[use_lake_model] + standard_name = flag_for_using_lake_model + long_name = flag indicating lake points using a lake model units = flag dimensions = (horizontal_loop_extent) type = integer From 72711368a8b93e7e8523baf4cf2bd4ae0ded8587 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Thu, 11 Aug 2022 20:56:55 +0000 Subject: [PATCH 008/380] Issue 886 --- ...odule_sf_noahmp_glacier.f90 => module_sf_noahmp_glacier.F90} | 2 +- physics/{module_sf_noahmplsm.f90 => module_sf_noahmplsm.F90} | 2 +- physics/noahmpdrv.meta | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) rename physics/{module_sf_noahmp_glacier.f90 => module_sf_noahmp_glacier.F90} (99%) rename physics/{module_sf_noahmplsm.f90 => module_sf_noahmplsm.F90} (99%) diff --git a/physics/module_sf_noahmp_glacier.f90 b/physics/module_sf_noahmp_glacier.F90 similarity index 99% rename from physics/module_sf_noahmp_glacier.f90 rename to physics/module_sf_noahmp_glacier.F90 index ee57e336f..40202a827 100644 --- a/physics/module_sf_noahmp_glacier.f90 +++ b/physics/module_sf_noahmp_glacier.F90 @@ -1,5 +1,5 @@ #define CCPP -!> \file module_sf_noahmp_glacier.f90 +!> \file module_sf_noahmp_glacier.F90 !! This file contains the NoahMP Glacier scheme. !>\ingroup NoahMP_LSM diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.F90 similarity index 99% rename from physics/module_sf_noahmplsm.f90 rename to physics/module_sf_noahmplsm.F90 index 652db602d..57e047c3e 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.F90 @@ -1,5 +1,5 @@ #define CCPP -!> \file module_sf_noahmplsm.f90 +!> \file module_sf_noahmplsm.F90 !! This file contains the NoahMP land surface model. !>\ingroup NoahMP_LSM diff --git a/physics/noahmpdrv.meta b/physics/noahmpdrv.meta index 9ad9092ec..ddf16f65d 100644 --- a/physics/noahmpdrv.meta +++ b/physics/noahmpdrv.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = noahmpdrv type = scheme - dependencies = funcphys.f90,machine.F,sfc_diff.f,module_sf_noahmp_glacier.f90,module_sf_noahmplsm.f90,noahmp_tables.f90,set_soilveg.f + dependencies = funcphys.f90,machine.F,sfc_diff.f,module_sf_noahmp_glacier.F90,module_sf_noahmplsm.F90,noahmp_tables.f90,set_soilveg.f ######################################################################## [ccpp-arg-table] From 8329e07281c33832c0fd334b7c023f2bf9177e5b Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Thu, 11 Aug 2022 22:24:11 +0000 Subject: [PATCH 009/380] Issue 764 --- physics/drag_suite.F90 | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/physics/drag_suite.F90 b/physics/drag_suite.F90 index 09ee621bd..ec8bf2f5e 100644 --- a/physics/drag_suite.F90 +++ b/physics/drag_suite.F90 @@ -7,6 +7,11 @@ module drag_suite contains +!>\brief This subroutine initializes the GFS_ogwd GFS Orographic Gravity Wave Drag scheme. +!! +!> \section arg_table_drag_suite_init Argument Table +!! \htmlinclude drag_suite_init.html +!! subroutine drag_suite_init(gwd_opt, errmsg, errflg) integer, intent(in) :: gwd_opt From a282821eb995c7780b066af5f34b55f50119144d Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Thu, 11 Aug 2022 22:39:14 +0000 Subject: [PATCH 010/380] Issue 672 --- physics/GFS_phys_time_vary.fv3.F90 | 5 +++-- physics/GFS_phys_time_vary.fv3.meta | 8 ++++++++ physics/gcycle.F90 | 13 +++++++------ 3 files changed, 18 insertions(+), 8 deletions(-) diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index 3c5a5af9b..3cfa9e956 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -713,7 +713,7 @@ subroutine GFS_phys_time_vary_timestep_init ( imfdeepcnv, cal_pre, random_clds, nscyc, ntoz, h2o_phys, iaerclm, iccn, clstp, & jindx1_o3, jindx2_o3, ddy_o3, ozpl, jindx1_h, jindx2_h, ddy_h, h2opl, iflip, & jindx1_aer, jindx2_aer, ddy_aer, iindx1_aer, iindx2_aer, ddx_aer, aer_nm, & - jindx1_ci, jindx2_ci, ddy_ci, iindx1_ci, iindx2_ci, ddx_ci, in_nm, ccn_nm, & + jindx1_ci, jindx2_ci, ddy_ci, iindx1_ci, iindx2_ci, ddx_ci, in_nm, ccn_nm, fn_nml, & imap, jmap, prsl, seed0, rann, nthrds, nx, ny, nsst, tile_num, nlunit, lsoil, lsoil_lsm,& kice, ialb, isot, ivegsrc, input_nml_file, use_ufo, nst_anl, frac_grid, fhcyc, phour, & lakefrac, min_seaice, min_lakeice, smc, slc, stc, smois, sh2o, tslb, tiice, tg3, tref, & @@ -754,6 +754,7 @@ subroutine GFS_phys_time_vary_timestep_init ( integer, intent(in) :: nthrds, nx, ny, nsst, tile_num, nlunit, lsoil integer, intent(in) :: lsoil_lsm, kice, ialb, isot, ivegsrc character(len=*), intent(in) :: input_nml_file(:) + character(len=*), intent(in) :: fn_nml logical, intent(in) :: use_ufo, nst_anl, frac_grid real(kind_phys), intent(in) :: fhcyc, phour, lakefrac(:), min_seaice, min_lakeice, & xlat_d(:), xlon_d(:), landfrac(:) @@ -894,7 +895,7 @@ subroutine GFS_phys_time_vary_timestep_init ( !> - Call gcycle() to repopulate specific time-varying surface properties for AMIP/forecast runs if (nscyc > 0) then if (mod(kdt,nscyc) == 1) THEN - call gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & + call gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, fn_nml, & input_nml_file, lsoil, lsoil_lsm, kice, idate, ialb, isot, ivegsrc, & use_ufo, nst_anl, fhcyc, phour, landfrac, lakefrac, min_seaice, min_lakeice,& frac_grid, smc, slc, stc, smois, sh2o, tslb, tiice, tg3, tref, tsfc, & diff --git a/physics/GFS_phys_time_vary.fv3.meta b/physics/GFS_phys_time_vary.fv3.meta index f37235975..ce350a7b2 100644 --- a/physics/GFS_phys_time_vary.fv3.meta +++ b/physics/GFS_phys_time_vary.fv3.meta @@ -1285,6 +1285,14 @@ type = real kind = kind_phys intent = inout +[fn_nml] + standard_name = filename_of_namelist + long_name = namelist filename + units = none + dimensions = () + type = character + kind = len=* + intent = in [imap] standard_name = map_of_block_column_number_to_global_i_index long_name = map of local index ix to global index i for this block diff --git a/physics/gcycle.F90 b/physics/gcycle.F90 index 5f4f959c6..7e301c480 100644 --- a/physics/gcycle.F90 +++ b/physics/gcycle.F90 @@ -15,7 +15,7 @@ module gcycle_mod !>\ingroup mod_GFS_phys_time_vary !! This subroutine repopulates specific time-varying surface properties for !! atmospheric forecast runs. - subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & + subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, fn_nml, & input_nml_file, lsoil, lsoil_lsm, kice, idate, ialb, isot, ivegsrc, & use_ufo, nst_anl, fhcyc, phour, landfrac, lakefrac, min_seaice, min_lakeice, & frac_grid, smc, slc, stc, smois, sh2o, tslb, tiice, tg3, tref, tsfc, & @@ -31,6 +31,7 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, integer, intent(in) :: me, nthrds, nx, ny, isc, jsc, nsst, & tile_num, nlunit, lsoil, lsoil_lsm, kice integer, intent(in) :: idate(:), ialb, isot, ivegsrc + character(len = 64), intent(in) :: fn_nml character(len=*), intent(in) :: input_nml_file(:) logical, intent(in) :: use_ufo, nst_anl, frac_grid real(kind=kind_phys), intent(in) :: fhcyc, phour, landfrac(:), lakefrac(:), & @@ -210,13 +211,13 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, enddo ! #ifndef INTERNAL_FILE_NML - inquire (file=trim(Model%fn_nml),exist=exists) + inquire (file=trim(fn_nml),exist=exists) if (.not. exists) then - write(6,*) 'gcycle:: namelist file: ',trim(Model%fn_nml),' does not exist' + write(6,*) 'gcycle:: namelist file: ',trim(fn_nml),' does not exist' stop else - open (unit=Model%nlunit, file=trim(Model%fn_nml), action='READ', status='OLD', iostat=ios) - rewind (Model%nlunit) + open (unit=nlunit, file=trim(fn_nml), action='READ', status='OLD', iostat=ios) + rewind (nlunit) endif #endif CALL SFCCYCLE (9998, npts, max(lsoil,lsoil_lsm), sig1t, fhcyc, & @@ -233,7 +234,7 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, min_ice, ialb, isot, ivegsrc, & trim(tile_num_ch), i_indx, j_indx) #ifndef INTERNAL_FILE_NML - close (Model%nlunit) + close (nlunit) #endif ! if ( nsst > 0 ) then From 7c37906f8997a1e7311c74a4a3cee66908c54ab9 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Fri, 12 Aug 2022 16:43:44 -0600 Subject: [PATCH 011/380] Cleanup to radiation_aerosols. Related to #923. Made changes to made radiation_aerosols.f ccpp compliant --- physics/GFS_phys_time_vary.fv3.F90 | 5 +- physics/GFS_phys_time_vary.fv3.meta | 7 + physics/GFS_rad_time_vary.fv3.F90 | 2 +- physics/GFS_rad_time_vary.scm.F90 | 2 +- physics/GFS_rrtmg_pre.F90 | 17 +- physics/GFS_rrtmg_pre.meta | 23 +- physics/GFS_rrtmg_setup.F90 | 60 +++-- physics/GFS_rrtmg_setup.meta | 51 ++++ physics/GFS_rrtmgp_setup.F90 | 21 +- physics/GFS_rrtmgp_setup.meta | 44 ++++ physics/GFS_time_vary_pre.scm.F90 | 2 +- physics/physparam.f | 17 -- physics/radiation_aerosols.f | 345 +++++++++++++++++++--------- physics/rrtmgp_aerosol_optics.F90 | 12 +- physics/rrtmgp_aerosol_optics.meta | 21 ++ 15 files changed, 455 insertions(+), 174 deletions(-) diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index 3cfa9e956..2803212b7 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -35,7 +35,6 @@ module GFS_phys_time_vary !--- variables needed for calculating 'sncovr' use namelist_soilveg, only: salp_data, snupx use set_soilveg_mod, only: set_soilveg - use physparam, only : iaermdl ! --- needed for Noah MP init use noahmp_tables, only: laim_table,saim_table,sla_table, & @@ -68,7 +67,7 @@ module GFS_phys_time_vary !>\section gen_GFS_phys_time_vary_init GFS_phys_time_vary_init General Algorithm !! @{ subroutine GFS_phys_time_vary_init ( & - me, master, ntoz, h2o_phys, iaerclm, iccn, iflip, im, levs, & + me, master, ntoz, h2o_phys, iaerclm, iccn, iaermdl, iflip, im, levs, & nx, ny, idate, xlat_d, xlon_d, & jindx1_o3, jindx2_o3, ddy_o3, ozpl, jindx1_h, jindx2_h, ddy_h, h2opl,fhour, & jindx1_aer, jindx2_aer, ddy_aer, iindx1_aer, iindx2_aer, ddx_aer, aer_nm, & @@ -87,7 +86,7 @@ subroutine GFS_phys_time_vary_init ( implicit none ! Interface variables - integer, intent(in) :: me, master, ntoz, iccn, iflip, im, nx, ny, levs + integer, intent(in) :: me, master, ntoz, iccn, iflip, im, nx, ny, levs, iaermdl logical, intent(in) :: h2o_phys, iaerclm, lsm_cold_start integer, intent(in) :: idate(:) real(kind_phys), intent(in) :: fhour diff --git a/physics/GFS_phys_time_vary.fv3.meta b/physics/GFS_phys_time_vary.fv3.meta index ce350a7b2..36ac38ab9 100644 --- a/physics/GFS_phys_time_vary.fv3.meta +++ b/physics/GFS_phys_time_vary.fv3.meta @@ -44,6 +44,13 @@ dimensions = () type = logical intent = in +[iaermdl] + standard_name = flag_for_aerosol_radiation_scheme + long_name = flag for aerosol scheme to use in radiation + units = flag + dimensions = () + type = integer + intent = in [iccn] standard_name = control_for_ice_cloud_condensation_nuclei_forcing long_name = flag for IN and CCN forcing for morrison gettelman microphysics diff --git a/physics/GFS_rad_time_vary.fv3.F90 b/physics/GFS_rad_time_vary.fv3.F90 index 8dd070b12..24d18d3f7 100644 --- a/physics/GFS_rad_time_vary.fv3.F90 +++ b/physics/GFS_rad_time_vary.fv3.F90 @@ -20,7 +20,7 @@ subroutine GFS_rad_time_vary_timestep_init ( imap, jmap, sec, kdt, imp_physics, imp_physics_zhao_carr, ps_2delt, & ps_1delt, t_2delt, t_1delt, qv_2delt, qv_1delt, t, qv, ps, errmsg, errflg) - use physparam, only: ipsd0, ipsdlim, iaerflg + use physparam, only: ipsd0, ipsdlim use mersenne_twister, only: random_setseed, random_index, random_stat use machine, only: kind_phys use radcons, only: qmin, con_100 diff --git a/physics/GFS_rad_time_vary.scm.F90 b/physics/GFS_rad_time_vary.scm.F90 index d7d4cda26..db1e7e290 100644 --- a/physics/GFS_rad_time_vary.scm.F90 +++ b/physics/GFS_rad_time_vary.scm.F90 @@ -20,7 +20,7 @@ subroutine GFS_rad_time_vary_timestep_init ( imap, jmap, sec, kdt, imp_physics, imp_physics_zhao_carr, ps_2delt, & ps_1delt, t_2delt, t_1delt, qv_2delt, qv_1delt, t, qv, ps, errmsg, errflg) - use physparam, only: ipsd0, ipsdlim, iaerflg + use physparam, only: ipsd0, ipsdlim use mersenne_twister, only: random_setseed, random_index, random_stat use machine, only: kind_phys use radcons, only: qmin, con_100 diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index c75278a33..b4b69d447 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -33,7 +33,8 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & lmfdeep2, fhswr, fhlwr, solhr, sup, con_eps, epsm1, fvirt, & rog, rocp, con_rd, xlat_d, xlat, xlon, coslat, sinlat, tsfc, slmsk, & prsi, prsl, prslk, tgrs, sfc_wts, mg_cld, effrr_in, pert_clds, & - sppt_wts, sppt_amp, cnvw_in, cnvc_in, qgrs, aer_nm, dx, icloud, & !inputs from here and above + sppt_wts, sppt_amp, cnvw_in, cnvc_in, qgrs, aer_nm, dx, icloud, & + iaermdl, iaerflg, & !inputs from here and above coszen, coszdg, effrl_inout, effri_inout, effrs_inout, & clouds1, clouds2, clouds3, clouds4, clouds5, qci_conv, & !in/out from here and above kd, kt, kb, mtopa, mbota, raddt, tsfg, tsfa, de_lgth, alb1d, delp, dz, & !output from here and below @@ -43,7 +44,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & clouds9, cldsa, cldfra, cldfra2d, lwp_ex,iwp_ex, lwp_fc,iwp_fc, & faersw1, faersw2, faersw3, faerlw1, faerlw2, faerlw3, alpha, & aero_dir_fdb, smoke_ext, dust_ext, & - spp_wts_rad, spp_rad, rrfs_smoke_band, errmsg, errflg) + spp_wts_rad, spp_rad, rrfs_smoke_band, top_at_1, errmsg, errflg) use machine, only: kind_phys @@ -80,7 +81,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & make_IceNumber, & make_DropletNumber, & make_RainNumber - use physparam, only : iaermdl implicit none integer, intent(in) :: im, levs, lm, lmk, lmp, n_var_lndp, & @@ -100,7 +100,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & imp_physics_mg, imp_physics_wsm6, & imp_physics_nssl, & imp_physics_fer_hires, & - yearlen, icloud + yearlen, icloud, iaermdl, iaerflg integer, intent(in) :: & iovr_rand, & ! Flag for random cloud overlap method @@ -200,7 +200,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & faerlw2,& faerlw3 real(kind=kind_phys), dimension(:,:), intent(out) :: alpha - + logical, intent(out) :: top_at_1 character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -257,6 +257,9 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & errmsg = '' errflg = 0 + ! Vertical ordering + top_at_1 = (prsi(1,1) .lt. prsi(1, lm)) + if (.not. (lsswr .or. lslwr)) return !--- set commonly used integers @@ -634,8 +637,8 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & call setaer (plvl, plyr, prslk1, tvly, rhly, slmsk, & ! --- inputs tracer1, aer_nm, xlon, xlat, IM, LMK, LMP,& - lsswr,lslwr, & - faersw,faerlw,aerodp) ! --- outputs + lsswr,lslwr,iaermdl,iaerflg,top_at_1, & + faersw,faerlw,aerodp,errflg,errmsg) ! --- outputs ! CCPP do j = 1,NBDSW diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index b98512c7d..e15ca3730 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -2,7 +2,7 @@ name = GFS_rrtmg_pre type = scheme dependencies = funcphys.f90,iounitdef.f,machine.F,module_bfmicrophysics.f,module_mp_radar.F90,module_mp_thompson.F90 - dependencies = module_mp_thompson_make_number_concentrations.F90,physcons.F90,physparam.f,radcons.f90,radiation_aerosols.f + dependencies = module_mp_thompson_make_number_concentrations.F90,physparam.f,physcons.F90,radcons.f90,radiation_aerosols.f dependencies = radiation_astronomy.f,radiation_clouds.f,radiation_gases.f,radlw_param.f,radsw_param.f,surface_perturbation.F90,radiation_cloud_overlap.F90 ######################################################################## @@ -205,6 +205,20 @@ dimensions = () type = integer intent = in +[iaermdl] + standard_name = flag_for_aerosol_radiation_scheme + long_name = flag for aerosol scheme to use in radiation + units = flag + dimensions = () + type = integer + intent = in +[iaerflg] + standard_name = flag_for_aerosol_effects_in_radiation + long_name = flag for aerosol effects to include in radiation + units = flag + dimensions = () + type = integer + intent = in [nssl_ccn_on] standard_name = nssl_ccn_on long_name = CCN activation flag in NSSL micro @@ -1306,6 +1320,13 @@ type = real kind = kind_phys intent = out +[top_at_1] + standard_name = flag_for_vertical_ordering_in_RRTMGP + long_name = flag for vertical ordering in RRTMGP + units = flag + dimensions = () + type = logical + intent = out [aero_dir_fdb] standard_name = do_smoke_aerosol_direct_feedback long_name = flag for smoke and dust radiation feedback diff --git a/physics/GFS_rrtmg_setup.F90 b/physics/GFS_rrtmg_setup.F90 index 0e2d87feb..ebe34a705 100644 --- a/physics/GFS_rrtmg_setup.F90 +++ b/physics/GFS_rrtmg_setup.F90 @@ -4,8 +4,8 @@ !> \defgroup GFS_rrtmg_setup_mod GFS RRTMG Scheme Setup module GFS_rrtmg_setup - use physparam, only : isolar , ictmflg, ico2flg, ioznflg, iaerflg, & - & iaermdl, icldflg, & + use physparam, only : isolar , ictmflg, ico2flg, ioznflg, & + & icldflg, & & iovrRad=>iovr, lcrick , lcnorm , lnoprec, & & isubcsw, isubclw, ivflip , ipsd0, & & iswcliq, & @@ -48,7 +48,8 @@ subroutine GFS_rrtmg_setup_init ( & icliq_sw, crick_proof, ccnorm, & imp_physics, & norad_precip, idate, iflip, & - do_RRTMGP, me, errmsg, errflg) + do_RRTMGP, me, lalw1bd, iaermdl, iaerflg, & + aeros_file, errmsg, errflg) ! ================= subprogram documentation block ================ ! ! ! ! subprogram: GFS_rrtmg_setup_init - a subprogram to initialize radiation ! @@ -167,10 +168,12 @@ subroutine GFS_rrtmg_setup_init ( & logical, intent(in) :: norad_precip integer, intent(in) :: idate(:) integer, intent(in) :: iflip - logical, intent(in) :: do_RRTMGP + logical, intent(in) :: do_RRTMGP, lalw1bd integer, intent(in) :: me + character(len=26), intent(in) :: aeros_file character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg + integer, intent(out) :: iaermdl, iaerflg ! Initialize the CCPP error handling variables errmsg = '' @@ -241,7 +244,8 @@ subroutine GFS_rrtmg_setup_init ( & call radinit & ! --- inputs: - & ( si, levr, imp_physics, me ) + & ( si, levr, imp_physics, me, iaermdl, iaerflg, lalw1bd, & + & aeros_file, errmsg, errflg ) ! --- outputs: ! ( none ) @@ -261,8 +265,8 @@ end subroutine GFS_rrtmg_setup_init !! \htmlinclude GFS_rrtmg_setup_timestep_init.html !! subroutine GFS_rrtmg_setup_timestep_init ( & - idate, jdate, deltsw, deltim, lsswr, me, & - slag, sdec, cdec, solcon, errmsg, errflg) + idate, jdate, deltsw, deltim, lsswr, me, iaermdl, & + iaerflg, aeros_file, slag, sdec, cdec, solcon, errmsg, errflg) implicit none @@ -273,6 +277,8 @@ subroutine GFS_rrtmg_setup_timestep_init ( & real(kind=kind_phys), intent(in) :: deltim logical, intent(in) :: lsswr integer, intent(in) :: me + integer, intent(in) :: iaermdl, iaerflg + character(len=26), intent(in) :: aeros_file real(kind=kind_phys), intent(out) :: slag real(kind=kind_phys), intent(out) :: sdec real(kind=kind_phys), intent(out) :: cdec @@ -291,8 +297,8 @@ subroutine GFS_rrtmg_setup_timestep_init ( & errmsg = '' errflg = 0 - call radupdate(idate,jdate,deltsw,deltim,lsswr,me, & - slag,sdec,cdec,solcon) + call radupdate(idate,jdate,deltsw,deltim,lsswr,me, iaermdl,& + iaerflg, aeros_file, slag,sdec,cdec,solcon,errflg,errmsg) end subroutine GFS_rrtmg_setup_timestep_init @@ -322,13 +328,14 @@ end subroutine GFS_rrtmg_setup_finalize ! Private functions - subroutine radinit( si, NLAY, imp_physics, me ) + subroutine radinit( si, NLAY, imp_physics, me, iaermdl, iaerflg, lalw1bd, & + aeros_file, errmsg, errflg) !................................... ! --- inputs: -! & ( si, NLAY, imp_physics, me ) +! & ( si, NLAY, imp_physics, me, iaermdl, iaerflg) ! --- outputs: -! ( none ) +! ( errmsg, errflg ) ! ================= subprogram documentation block ================ ! ! ! @@ -435,12 +442,14 @@ subroutine radinit( si, NLAY, imp_physics, me ) implicit none ! --- inputs: - integer, intent(in) :: NLAY, me, imp_physics - + integer, intent(in) :: NLAY, me, imp_physics, iaermdl, iaerflg + logical, intent(in) :: lalw1bd real (kind=kind_phys), intent(in) :: si(:) + character(len=26), intent(in) :: aeros_file -! --- outputs: (none, to module variables) - +! --- outputs: (ccpp error handling) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg ! --- locals: ! @@ -525,7 +534,7 @@ subroutine radinit( si, NLAY, imp_physics, me ) call sol_init ( me ) ! --- ... astronomy initialization routine - call aer_init ( NLAY, me ) ! --- ... aerosols initialization routine + call aer_init ( NLAY, me, iaermdl, iaerflg, lalw1bd, aeros_file, errflg, errmsg) ! --- ... aerosols initialization routine call gas_init ( me ) ! --- ... co2 and other gases initialization routine @@ -561,8 +570,9 @@ end subroutine radinit !> \section gen_radupdate General Algorithm !> @{ !----------------------------------- - subroutine radupdate( idate,jdate,deltsw,deltim,lsswr, me, & - & slag,sdec,cdec,solcon) + subroutine radupdate( idate,jdate,deltsw,deltim,lsswr,me, iaermdl,& + & iaerflg, aeros_file, slag,sdec,cdec,solcon, & + & errflg,errmsg) !................................... ! ================= subprogram documentation block ================ ! @@ -630,13 +640,16 @@ subroutine radupdate( idate,jdate,deltsw,deltim,lsswr, me, & implicit none ! --- inputs: - integer, intent(in) :: idate(:), jdate(:), me + integer, intent(in) :: idate(:), jdate(:), me, iaermdl, iaerflg logical, intent(in) :: lsswr + character(len=26),intent(in) :: aeros_file real (kind=kind_phys), intent(in) :: deltsw, deltim ! --- outputs: real (kind=kind_phys), intent(out) :: slag, sdec, cdec, solcon + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg ! --- locals: integer :: iyear, imon, iday, ihour @@ -648,6 +661,11 @@ subroutine radupdate( idate,jdate,deltsw,deltim,lsswr, me, & ! !===> ... begin here ! + + ! Initialize the CCPP error handling variables + errmsg = '' + errflg = 0 + !> -# Set up time stamp at fcst time and that for green house gases !! (currently co2 only) ! --- ... time stamp at fcst time @@ -703,7 +721,7 @@ subroutine radupdate( idate,jdate,deltsw,deltim,lsswr, me, & !> -# Call module_radiation_aerosols::aer_update(), monthly update, no !! time interpolation if ( lmon_chg ) then - call aer_update ( iyear, imon, me ) + call aer_update ( iyear, imon, me, iaermdl, aeros_file, errflg, errmsg ) endif !> -# Call co2 and other gases update routine: diff --git a/physics/GFS_rrtmg_setup.meta b/physics/GFS_rrtmg_setup.meta index ae0da3a5e..09068b6a6 100644 --- a/physics/GFS_rrtmg_setup.meta +++ b/physics/GFS_rrtmg_setup.meta @@ -163,6 +163,35 @@ dimensions = () type = integer intent = in +[aeros_file] + standard_name = aerosol_data_file + long_name = aerosol data file + units = none + dimensions = () + type = character + kind = len=26 + intent = in +[lalw1bd] + standard_name = flag_for_longwave_aerosol_band_properties + long_name = flag for band or multiband longwave aerosol properties + units = flag + dimensions = () + type = logical + intent = in +[iaermdl] + standard_name = flag_for_aerosol_radiation_scheme + long_name = flag for aerosol scheme to use in radiation + units = flag + dimensions = () + type = integer + intent = out +[iaerflg] + standard_name = flag_for_aerosol_effects_in_radiation + long_name = flag for aerosol effects to include in radiation + units = flag + dimensions = () + type = integer + intent = out [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -227,6 +256,28 @@ dimensions = () type = integer intent = in +[iaermdl] + standard_name = flag_for_aerosol_radiation_scheme + long_name = flag for aerosol scheme to use in radiation + units = flag + dimensions = () + type = integer + intent = in +[iaerflg] + standard_name = flag_for_aerosol_effects_in_radiation + long_name = flag for aerosol effects to include in radiation + units = flag + dimensions = () + type = integer + intent = in +[aeros_file] + standard_name = aerosol_data_file + long_name = aerosol data file + units = none + dimensions = () + type = character + kind = len=26 + intent = in [slag] standard_name = equation_of_time long_name = equation of time (radian) diff --git a/physics/GFS_rrtmgp_setup.F90 b/physics/GFS_rrtmgp_setup.F90 index f7f657b50..54a40d505 100644 --- a/physics/GFS_rrtmgp_setup.F90 +++ b/physics/GFS_rrtmgp_setup.F90 @@ -8,8 +8,7 @@ module GFS_rrtmgp_setup ! use GFS_cloud_diagnostics, only : hml_cloud_diagnostics_initialize ! *NOTE* These parameters below are required radiation_****** modules. They are not ! directly used by the RRTMGP routines. - use physparam, only : isolar, ictmflg, ico2flg, ioznflg, iaerflg, & - iaermdl, ivflip + use physparam, only : isolar, ictmflg, ico2flg, ioznflg, ivflip implicit none public GFS_rrtmgp_setup_init, GFS_rrtmgp_setup_timestep_init, GFS_rrtmgp_setup_finalize @@ -43,7 +42,7 @@ subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, imp_physics_zhao_carr, & imp_physics_zhao_carr_pdf, imp_physics_mg, si, levr, ictm, isol, ico2, iaer, & ntcw, num_p3d, ntoz, iovr, isubc_sw, isubc_lw, icliq_sw, crick_proof, ccnorm, & - norad_precip, idate, iflip, me, errmsg, errflg) + norad_precip, lalw1bd, idate, iflip, me, aeros_file, iaermdl, iaerflg, errmsg, errflg) ! Inputs logical, intent(in) :: do_RRTMGP @@ -60,15 +59,17 @@ subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires, si integer, intent(in) :: levr, ictm, isol, ico2, iaer, & ntcw, num_p3d, ntoz, iovr, isubc_sw, isubc_lw, & - icliq_sw, iflip, me + icliq_sw, iflip, me logical, intent(in) :: & - crick_proof, ccnorm, norad_precip + crick_proof, ccnorm, norad_precip, lalw1bd integer, intent(in), dimension(:) :: & idate + character(len=26),intent(in) :: aeros_file ! Outputs character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg + integer, intent(out) :: iaermdl, iaerflg ! Initialize the CCPP error handling variables errmsg = '' @@ -128,7 +129,7 @@ subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires, ! Call initialization routines.. call sol_init ( me ) - call aer_init ( levr, me ) + call aer_init ( levr, me, iaermdl, iaerflg, lalw1bd, aeros_file, errflg, errmsg) call gas_init ( me ) !call hml_cloud_diagnostics_initialize(imp_physics, imp_physics_fer_hires, & ! imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, & @@ -150,8 +151,8 @@ end subroutine GFS_rrtmgp_setup_init !> \section arg_table_GFS_rrtmgp_setup_timestep_init !! \htmlinclude GFS_rrtmgp_setup_timestep_init.html !! - subroutine GFS_rrtmgp_setup_timestep_init (idate, jdate, deltsw, deltim, lsswr, me, & - slag, sdec, cdec, solcon, errmsg, errflg) + subroutine GFS_rrtmgp_setup_timestep_init (idate, jdate, deltsw, deltim, lsswr, me, iaermdl,& + iaerflg, aeros_file, slag, sdec, cdec, solcon, errmsg, errflg) ! Inputs integer, intent(in) :: idate(:) @@ -160,6 +161,8 @@ subroutine GFS_rrtmgp_setup_timestep_init (idate, jdate, deltsw, deltim, lsswr, real(kind_phys), intent(in) :: deltim logical, intent(in) :: lsswr integer, intent(in) :: me + integer, intent(in) :: iaermdl, iaerflg + character(len=26), intent(in) :: aeros_file ! Outputs real(kind_phys), intent(out) :: slag @@ -230,7 +233,7 @@ subroutine GFS_rrtmgp_setup_timestep_init (idate, jdate, deltsw, deltim, lsswr, ! Update aerosols... if ( lmon_chg ) then - call aer_update ( iyear, imon, me ) + call aer_update ( iyear, imon, me, iaermdl, aeros_file, errflg, errmsg) endif ! Update trace gases (co2 only)... diff --git a/physics/GFS_rrtmgp_setup.meta b/physics/GFS_rrtmgp_setup.meta index 41bf63ac8..ea4fdcb88 100644 --- a/physics/GFS_rrtmgp_setup.meta +++ b/physics/GFS_rrtmgp_setup.meta @@ -185,6 +185,13 @@ dimensions = () type = logical intent = in +[lalw1bd] + standard_name = flag_for_longwave_aerosol_band_properties + long_name = flag for band or multiband longwave aerosol properties + units = flag + dimensions = () + type = logical + intent = in [idate] standard_name = date_and_time_at_model_initialization_in_united_states_order long_name = initialization date and time @@ -206,6 +213,28 @@ dimensions = () type = integer intent = in +[aeros_file] + standard_name = aerosol_data_file + long_name = aerosol data file + units = none + dimensions = () + type = character + kind = len=26 + intent = in +[iaermdl] + standard_name = flag_for_aerosol_radiation_scheme + long_name = flag for aerosol scheme to use in radiation + units = flag + dimensions = () + type = integer + intent = out +[iaerflg] + standard_name = flag_for_aerosol_effects_in_radiation + long_name = flag for aerosol effects to include in radiation + units = flag + dimensions = () + type = integer + intent = out [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -270,6 +299,21 @@ dimensions = () type = integer intent = in +[aeros_file] + standard_name = aerosol_data_file + long_name = aerosol data file + units = none + dimensions = () + type = character + kind = len=26 + intent = in +[iaermdl] + standard_name = flag_for_aerosol_radiation_scheme + long_name = flag for aerosol scheme to use in radiation + units = flag + dimensions = () + type = integer + intent = in [slag] standard_name = equation_of_time long_name = equation of time (radian) diff --git a/physics/GFS_time_vary_pre.scm.F90 b/physics/GFS_time_vary_pre.scm.F90 index 2bb6b3ceb..17cf09ca9 100644 --- a/physics/GFS_time_vary_pre.scm.F90 +++ b/physics/GFS_time_vary_pre.scm.F90 @@ -122,7 +122,7 @@ subroutine GFS_time_vary_pre_timestep_init (jdat, idat, dtp, nsswr, & else if (w3kindreal == 4) then rinc4(1:5) = 0 call w3difdat(jdat,idat,4,rinc4) - sec = rina4c(4) + sec = rinc4(4) else write(0,*)' FATAL ERROR: Invalid w3kindreal' call abort diff --git a/physics/physparam.f b/physics/physparam.f index 5518c6163..0e6a6f663 100644 --- a/physics/physparam.f +++ b/physics/physparam.f @@ -157,23 +157,6 @@ module physparam !> \name 2.2 For module radiation_aerosols ! ............................................. ! -!> aerosol model scheme control flag -!!\n =0:seasonal global distributed OPAC aerosol climatology -!!\n =1:monthly global distributed GOCART aerosol climatology -!!\n =2: GOCART prognostic aerosol model -!!\n =5: OPAC climatoloy with new band mapping -!!\n Opr GFS=0; Opr CFS=n/a - integer, save :: iaermdl = 0 - -!> aerosol effect control flag -!!\n 3-digit flag 'abc': -!!\n a-stratospheric volcanic aerols -!!\n b-tropospheric aerosols for LW -!!\n c-tropospheric aerosols for SW -!!\n =0:aerosol effect is not included; =1:aerosol effect is included -!!\n Opr GFS/CFS =111; see IAER in run scripts - integer, save :: iaerflg = 0 - !> external aerosols data file: aerosol.dat character, save :: aeros_file*26 ! data aeros_file / 'climaeropac_global.txt ' / diff --git a/physics/radiation_aerosols.f b/physics/radiation_aerosols.f index e7fd3631b..20a456cf4 100644 --- a/physics/radiation_aerosols.f +++ b/physics/radiation_aerosols.f @@ -15,20 +15,20 @@ ! inputs: ! ! ( NLAY, me ) ! ! outputs: ! -! ( none ) ! +! ( errflg, errmsg ) ! ! ! ! 'aer_update' -- updating aerosol data ! ! inputs: ! ! ( iyear, imon, me ) ! ! outputs: ! -! ( none ) ! +! ( errflg, errmsg ) ! ! ! ! 'setaer' -- mapping aeros profile, compute aeros opticals ! ! inputs: ! ! (prsi,prsl,prslk,tvly,rhlay,slmsk,tracer,aerfld,xlon,xlat, ! ! IMAX,NLAY,NLP1, lsswr,lslwr, ! ! outputs: ! -! (aerosw,aerolw,aerodp) ! +! (aerosw,aerolw,aerodp,errmsg,errflg) ! ! ! ! ! ! external modules referenced: ! @@ -157,8 +157,7 @@ module module_radiation_aerosols ! !........................................! ! - use physparam,only : iaermdl, iaerflg, lalw1bd, aeros_file, & - & ivflip, kind_phys, kind_io4, kind_io8 + use machine, only : kind_phys, kind_io4, kind_io8 use physcons, only : con_pi, con_rd, con_g, con_t0c, con_c, & & con_boltz, con_plnk, con_amd @@ -500,7 +499,8 @@ module module_radiation_aerosols ! !! @{ !----------------------------------- subroutine aer_init & - & ( NLAY, me ) ! --- inputs + & ( NLAY, me, iaermdl, iaerflg, lalw1bd, aeros_file, & + & errflg, errmsg) ! --- outputs: ( to module variables ) ! ================================================================== ! @@ -512,7 +512,9 @@ subroutine aer_init & ! NLAY - number of model vertical layers (not used) ! ! me - print message control flag ! ! ! -! outputs: (to module variables) ! +! outputs: (CCPP error handling) ! +! errmsg - CCPP error message ! +! errflg - CCPP error flag ! ! ! ! external module variables: (in physparam) ! ! iaermdl - tropospheric aerosol model scheme flag ! @@ -543,9 +545,12 @@ subroutine aer_init & ! ================================================================== ! ! --- inputs: - integer, intent(in) :: NLAY, me - -! --- output: ( none ) + integer, intent(in) :: NLAY, me, iaermdl, iaerflg + logical, intent(in) :: lalw1bd + character(len=26),intent(in) :: aeros_file +! --- output: + integer, intent(out) :: errflg + character(len=*), intent(out) :: errmsg ! --- locals: real (kind=kind_phys), dimension(NWVTOT) :: solfwv ! one wvn sol flux @@ -553,6 +558,11 @@ subroutine aer_init & ! !===> ... begin here ! + +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + kyrstr = 1 kyrend = 1 kyrsav = 1 @@ -566,9 +576,9 @@ subroutine aer_init & if ( me == 0 ) then - call wrt_aerlog ! write aerosol param info to log file + call wrt_aerlog(iaermdl, iaerflg, lalw1bd, errflg, errmsg) ! write aerosol param info to log file ! --- inputs: (in scope variables) -! --- outputs: ( none ) +! --- outputs: (CCPP error handling) endif @@ -618,9 +628,9 @@ subroutine aer_init & !> -# Call set_spectrum() to set up spectral one wavenumber solar/IR !! fluxes. - call set_spectrum + call set_spectrum(errflg, errmsg) ! --- inputs: (module constants) -! --- outputs: (in-scope variables) +! --- outputs: (ccpp error handling) !> -# Call clim_aerinit() to invoke tropospheric aerosol initialization. @@ -628,23 +638,26 @@ subroutine aer_init & call clim_aerinit & ! --- inputs: - & ( solfwv, eirfwv, me & + & ( solfwv, eirfwv, me, aeros_file, & ! --- outputs: - & ) + & errflg, errmsg) elseif ( iaermdl==1 .or. iaermdl==2 ) then ! gocart clim/prog scheme call gocart_aerinit & ! --- inputs: - & ( solfwv, eirfwv, me & + & ( solfwv, eirfwv, me, & ! --- outputs: - & ) + & errflg, errmsg) else if ( me == 0 ) then print *,' !!! ERROR in aerosol model scheme selection', & & ' iaermdl =',iaermdl - stop + errflg = 1 + errmsg = 'ERROR(aer_init): aerosol model scheme selected'// & + & 'is invalid' + return endif endif @@ -655,9 +668,9 @@ subroutine aer_init & if ( lavoflg ) then - call set_volcaer + call set_volcaer(errflg, errmsg) ! --- inputs: (module variables) -! --- outputs: (module variables) +! --- outputs: (module variables: ccpp error handling) endif ! end if_lavoflg_block @@ -668,10 +681,10 @@ subroutine aer_init & !> This subroutine writes aerosol parameter configuration to run log file. !-------------------------------- - subroutine wrt_aerlog + subroutine wrt_aerlog(iaermdl, iaerflg, lalw1bd, errflg, errmsg) !................................ ! --- inputs: (in scope variables) -! --- outputs: ( none ) +! --- outputs: (CCPP error handling) ! ================================================================== ! ! ! @@ -682,14 +695,14 @@ subroutine wrt_aerlog ! ==================== defination of variables =================== ! ! ! ! external module variables: (in physparam) ! -! iaermdl - aerosol scheme flag: 0:opac-clm; 1:gocart-clim; ! -! 2:gocart-prog; 5:opac-clim+new mapping ! ! iaerflg - aerosol effect control flag: 3-digits (volc,lw,sw) ! ! lalwflg - toposphere lw aerosol effect: =f:no; =t:yes ! ! laswflg - toposphere sw aerosol effect: =f:no; =t:yes ! ! lavoflg - stratospherer volcanic aeros effect: =f:no; =t:yes ! ! ! -! outputs: ( none ) ! +! outputs: ! +! errmsg - CCPP error message ! +! errflg - CCPP error flag ! ! ! ! subroutines called: none ! ! ! @@ -697,13 +710,22 @@ subroutine wrt_aerlog ! ! ! ================================================================== ! -! --- inputs: ( none ) -! --- output: ( none ) +! --- inputs: () + integer, intent(in) :: iaermdl, iaerflg + logical, intent(in) :: lalw1bd +! --- output: (CCPP error handling) + integer, intent(out) :: errflg + character(len=*), intent(out) :: errmsg ! --- locals: ! !===> ... begin here ! + +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + print *, VTAGAER ! print out version tag if ( iaermdl==0 .or. iaermdl==5 ) then @@ -718,7 +740,10 @@ subroutine wrt_aerlog else print *,' !!! ERROR in selection of aerosol model scheme', & & ' IAER_MDL =',iaermdl - stop + errflg = 1 + errmsg = 'ERROR(wrt_aerlog): Selected aerosol model scheme is'//& + & 'is invalid' + return endif ! end_if_iaermdl_block print *,' IAER=',iaerflg,' LW-trop-aer=',lalwflg, & @@ -765,10 +790,10 @@ end subroutine wrt_aerlog !> This subroutine defines the one wavenumber solar fluxes based on toa !! solar spectral distribution, and define the one wavenumber IR fluxes !! based on black-body emission distribution at a predefined temperature. - subroutine set_spectrum + subroutine set_spectrum(errflg, errmsg) !................................ ! --- inputs: (module constants) -! --- outputs: (in-scope variables) +! --- outputs: (ccpp error handling) ! ================================================================== ! ! ! @@ -789,6 +814,8 @@ subroutine set_spectrum !! (\f$W/m^2\f$) !! - eirfwv(NWVTIR): ir flux(273k) for each individual wavenumber !! (\f$W/m^2\f$) +!! - errflg: CCPP error flag +!! - errmsg: CCPP error message ! ! ! subroutines called: none ! ! ! @@ -802,11 +829,16 @@ subroutine set_spectrum ! --- output: (in-scope variables) ! real (kind=kind_phys), dimension(NWVTOT) :: solfwv ! one wvn sol flux ! real (kind=kind_phys), dimension(NWVTIR) :: eirfwv ! one wvn ir flux - + integer, intent(out) :: errflg + character(len=*), intent(out) :: errmsg ! --- locals: real (kind=kind_phys) :: soltot, tmp1, tmp2, tmp3 integer :: nb, nw, nw1, nw2, nmax, nmin + +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 ! !===> ... begin here ! @@ -858,11 +890,12 @@ end subroutine set_spectrum !> The initialization program for stratospheric volcanic aerosols. !----------------------------- - subroutine set_volcaer + subroutine set_volcaer(errflg, errmsg) !............................. -! --- inputs: ( none ) -! --- outputs: (module variables) - +! --- inputs: ( none ) ! +! outputs: (CCPP error handling) ! +! errflg - CCPP error flag ! +! errmsg - CCPP error message ! ! ================================================================== ! ! ! ! subprogram : set_volcaer ! @@ -878,13 +911,19 @@ subroutine set_volcaer ! --- inputs: (none) -! --- output: (module variables) +! --- output: (CCPP error handling) ! integer :: ivolae(:,:,:) - + integer, intent(out) :: errflg + character(len=*), intent(out) :: errmsg ! --- locals: ! !===> ... begin here ! + +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! --- allocate data space if ( .not. allocated(ivolae) ) then @@ -913,8 +952,8 @@ end subroutine aer_init !!\section gen_clim_aerinit General Algorithm !!@{ subroutine clim_aerinit & - & ( solfwv, eirfwv, me & ! --- inputs - & ) ! --- outputs + & ( solfwv, eirfwv, me, aeros_file, & ! --- inputs + & errflg, errmsg) ! --- outputs ! ================================================================== ! ! ! @@ -926,7 +965,9 @@ subroutine clim_aerinit & ! eirfwv(NWVTIR) - ir flux(273k) for each individual wavenum (w/m2)! ! me - print message control flag ! ! ! -! outputs: (to module variables) ! +! outputs: (CCPP error handling) ! +! errflg - CCPP error flag ! +! errmsg - CCPP error message ! ! ! ! external module variables: (in physparam) ! ! iaerflg - abc 3-digit integer aerosol flag (abc:volc,lw,sw) ! @@ -965,8 +1006,10 @@ subroutine clim_aerinit & real (kind=kind_phys), dimension(:) :: eirfwv ! one wvn ir flux integer, intent(in) :: me - -! --- output: ( none ) + character(len=26), intent(in) :: aeros_file +! --- output: (CCPP error handling) + integer, intent(out) :: errflg + character(len=*), intent(out) :: errmsg ! --- locals: real (kind=kind_phys), dimension(NAERBND,NCM1) :: & @@ -985,10 +1028,14 @@ subroutine clim_aerinit & ! !===> ... begin here ! +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! --- ... invoke tropospheric aerosol initialization !> - call set_aercoef() to invoke tropospheric aerosol initialization. - call set_aercoef + call set_aercoef(aeros_file, errflg, errmsg) ! --- inputs: (in-scope variables, module constants) ! --- outputs: (module variables) @@ -1003,10 +1050,10 @@ subroutine clim_aerinit & !!\section det_set_aercoef General Algorithm !! @{ !-------------------------------- - subroutine set_aercoef + subroutine set_aercoef(aeros_file,errflg, errmsg) !................................ ! --- inputs: (in-scope variables, module constants) -! --- outputs: (module variables) +! --- outputs: (CCPP error handling) ! ================================================================== ! ! ! @@ -1025,6 +1072,9 @@ subroutine set_aercoef ! me - integer, select cpu number as print control flag ! ! ! ! outputs: (to the module variables) ! +! outputs: (CCPP error handling) ! +! errflg - CCPP error flag ! +! errmsg - CCPP error message ! ! ! ! external module variables: (in physparam) ! ! lalwflg - module control flag for lw trop-aer: =f:no; =t:yes ! @@ -1080,7 +1130,10 @@ subroutine set_aercoef ! ================================================================== ! ! ! --- inputs: ( none ) -! --- output: ( none ) + character(len=26),intent(in) :: aeros_file +! --- output: (CCPP error handling) + integer, intent(out) :: errflg + character(len=*), intent(out) :: errmsg ! --- locals: integer, dimension(NAERBND) :: iendwv @@ -1094,6 +1147,11 @@ subroutine set_aercoef ! !===> ... begin here ! + +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + !> -# Reading climatological aerosols optical data from aeros_file, !! including: @@ -1108,7 +1166,10 @@ subroutine set_aercoef print *,' Requested aerosol data file "',aeros_file, & & '" not found!' print *,' *** Stopped in subroutine aero_init !!' - stop + errflg = 1 + errmsg = 'ERROR(set_aercoef): Requested aerosol data file '// & + & aeros_file//' not found' + return endif ! end if_file_exist_block ! --- ... skip monthly global distribution @@ -1712,8 +1773,8 @@ end subroutine clim_aerinit !! @{ !----------------------------------- subroutine aer_update & - & ( iyear, imon, me ) ! --- inputs: -! --- outputs: ( to module variables ) + & ( iyear, imon, me, iaermdl, aeros_file, errflg, errmsg ) ! --- inputs: +! --- outputs: ( CCPP error handling ) ! ================================================================== ! ! ! @@ -1725,7 +1786,9 @@ subroutine aer_update & ! imon - month of the year 1 ! ! me - print message control flag 1 ! ! ! -! outputs: ( none ) ! +! outputs: (CCPP error handling) ! +! errmsg - CCPP error message ! +! errflg - CCPP error flag ! ! ! ! external module variables: (in physparam) ! ! lalwflg - control flag for tropospheric lw aerosol ! @@ -1739,33 +1802,41 @@ subroutine aer_update & ! ================================================================== ! ! --- inputs: - integer, intent(in) :: iyear, imon, me - + integer, intent(in) :: iyear, imon, me, iaermdl + character(len=26),intent(in) :: aeros_file ! --- output: ( none ) - + integer, intent(out) :: errflg + character(len=*), intent(out) :: errmsg ! --- locals: ( none ) ! !===> ... begin here ! + +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + if ( imon < 1 .or. imon > 12 ) then print *,' ***** ERROR in specifying requested month !!! ', & & 'imon=', imon print *,' ***** STOPPED in subroutinte aer_update !!!' - stop + errflg = 1 + errmsg = 'ERROR(aer_update): Requested month not valid' + return endif !> -# Call trop_update() to update monthly tropospheric aerosol data. if ( lalwflg .or. laswflg ) then if ( iaermdl == 0 .or. iaermdl==5 ) then ! opac-climatology scheme - call trop_update + call trop_update(aeros_file, errflg, errmsg) endif endif !> -# Call volc_update() to update yearly stratospheric volcanic aerosol data. if ( lavoflg ) then - call volc_update + call volc_update(errflg, errmsg) endif @@ -1776,10 +1847,10 @@ subroutine aer_update & !> This subroutine updates the monthly global distribution of aerosol !! profiles in five degree horizontal resolution. !-------------------------------- - subroutine trop_update + subroutine trop_update(aeros_file, errflg, errmsg) !................................ ! --- inputs: (in scope variables, module variables) -! --- outputs: (module variables) +! --- outputs: (CCPP error handling) ! ================================================================== ! ! ! @@ -1814,7 +1885,10 @@ subroutine trop_update ! ================================================================== ! ! --- inputs: ( none ) -! --- output: ( none ) + character(len=26),intent(in) :: aeros_file +! --- output: (CCPP error handling) + integer, intent(out) :: errflg + character(len=*), intent(out) :: errmsg ! --- locals: ! real (kind=kind_io8) :: cmix(NXC), denn, tem @@ -1828,6 +1902,11 @@ subroutine trop_update ! !===> ... begin here ! + +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! --- ... reading climatological aerosols data inquire (file=aeros_file, exist=file_exist) @@ -1845,7 +1924,10 @@ subroutine trop_update print *,' Requested aerosol data file "',aeros_file, & & '" not found!' print *,' *** Stopped in subroutine trop_update !!' - stop + errflg = 1 + errmsg = 'ERROR(trop_update):Requested aerosol data file '// & + & aeros_file // ' not found.' + return endif ! end if_file_exist_block !$omp parallel do private(i,j,m) @@ -1937,10 +2019,10 @@ end subroutine trop_update !> This subroutine searches historical volcanic data sets to find and !! read in monthly 45-degree lat-zone band of optical depth. !-------------------------------- - subroutine volc_update + subroutine volc_update(errflg, errmsg) !................................ ! --- inputs: (in scope variables, module variables) -! --- outputs: (module variables) +! --- outputs: (CCPP error handling) ! ================================================================== ! ! ! @@ -1975,6 +2057,8 @@ subroutine volc_update ! --- output: (module variables) ! integer :: ivolae(:,:,:), kyrstr, kyrend, kyrsav, kmonsav + integer, intent(out) :: errflg + character(len=*), intent(out) :: errmsg ! --- locals: integer :: i, j, k @@ -1985,6 +2069,11 @@ subroutine volc_update ! !===> ... begin here ! + +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + kmonsav = imon if ( kyrstr<=iyear .and. iyear<=kyrend ) then ! use previously input data @@ -2039,7 +2128,10 @@ subroutine volc_update print *,' Requested volcanic data file "', & & volcano_file,'" not found!' print *,' *** Stopped in subroutine VOLC_AERINIT !!' - stop + errflg = 1 + errmsg = 'ERROR(volc_update): Requested volcanic data '// & + & 'file '//volcano_file//' not found!' + return endif ! end if_file_exist_block endif ! end if_iyear_block @@ -2093,9 +2185,9 @@ end subroutine aer_update !----------------------------------- subroutine setaer & & ( prsi,prsl,prslk,tvly,rhlay,slmsk,tracer,aerfld,xlon,xlat, & ! --- inputs - & IMAX,NLAY,NLP1, lsswr,lslwr, & - & aerosw,aerolw & ! --- outputs - &, aerodp & + & IMAX,NLAY,NLP1, lsswr,lslwr,iaermdl,iaerflg,top_at_1, & + & aerosw,aerolw, & ! --- outputs + & aerodp, errflg, errmsg & & ) ! ================================================================== ! @@ -2132,6 +2224,9 @@ subroutine setaer & ! tau_gocart - 550nm aeros opt depth IMAX*NLAY*MAX_NUM_GRIDCOMP! !! aerodp - vertically integrated optical depth IMAX*NSPC1 ! ! ! +! errflg - CCPP error flag ! +! errmsg - CCPP error message ! +! ! ! external module variable: (in physparam) ! ! iaerflg - aerosol effect control flag (volc,lw,sw, 3-dig) ! ! laswflg - tropospheric aerosol control flag for sw radiation ! @@ -2140,10 +2235,6 @@ subroutine setaer & ! =f: no lw aeros calc. =t: do lw aeros calc. ! ! lavoflg - control flag for stratospheric vocanic aerosols ! ! =t: add volcanic aerosols to the background aerosols ! -! ivflip - control flag for direction of vertical index ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! ! ! internal module variable: (set by subroutine aer_init) ! ! ivolae - stratosphere volcanic aerosol optical depth (fac 1.e4) ! ! 12*4*10 ! @@ -2154,7 +2245,7 @@ subroutine setaer & ! ================================================================== ! ! --- inputs: - integer, intent(in) :: IMAX, NLAY, NLP1 + integer, intent(in) :: IMAX, NLAY, NLP1, iaermdl, iaerflg real (kind=kind_phys), dimension(:,:), intent(in) :: prsi, prsl, & & prslk, tvly, rhlay @@ -2163,7 +2254,7 @@ subroutine setaer & real (kind=kind_phys), dimension(:,:,:),intent(in):: tracer real (kind=kind_phys), dimension(:,:,:),intent(in):: aerfld - logical, intent(in) :: lsswr, lslwr + logical, intent(in) :: lsswr, lslwr, top_at_1 ! --- outputs: @@ -2171,6 +2262,8 @@ subroutine setaer & & aerosw, aerolw real (kind=kind_phys), dimension(:,:) , intent(out) :: aerodp + integer, intent(out) :: errflg + character(len=*), intent(out) :: errmsg ! --- locals: real (kind=kind_phys), parameter :: psrfh = 5.0 ! ref press (mb) for upper bound @@ -2192,6 +2285,10 @@ subroutine setaer & !===> ... begin here +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + do m = 1, NF_AESW do j = 1, NBDSW do k = 1, NLAY @@ -2245,7 +2342,7 @@ subroutine setaer & lab_do_IMAX : do i = 1, IMAX - lab_if_flip : if (ivflip == 1) then ! input from sfc to toa + lab_if_flip : if (.not. top_at_1) then ! input from sfc to toa do k = 1, NLAY prsln(k) = log(prsi(i,k)) @@ -2300,10 +2397,10 @@ subroutine setaer & ! --- inputs: & ( prsi,prsl,prslk,tvly,rhlay,dz,hz,tracer, & & alon,alat,slmsk, laersw,laerlw, & - & IMAX,NLAY,NLP1, & + & IMAX,NLAY,NLP1,top_at_1, & ! & IMAX,NLAY,NLP1,NSPC1, & ! --- outputs: - & aerosw,aerolw,aerodp & + & aerosw,aerolw,aerodp,errflg,errmsg & & ) ! @@ -2315,7 +2412,7 @@ subroutine setaer & & alon,alat,slmsk,laersw,laerlw, & & IMAX,NLAY,NLP1, & ! --- outputs: - & aerosw,aerolw,aerodp & + & aerosw,aerolw,aerodp,errflg,errmsg & & ) endif ! end if_iaerflg_block @@ -2402,7 +2499,7 @@ subroutine setaer & endif enddo - if ( ivflip == 0 ) then ! input data from toa to sfc + if (top_at_1) then ! input data from toa to sfc ! --- find lower boundary of stratosphere @@ -2637,7 +2734,7 @@ subroutine setaer & endif ! end if_NLWBND_block endif ! end if_laddlw_block - endif ! end if_ivflip_block + endif ! end if_top_at_1_block endif ! end if_lavoflg_block ! @@ -2680,8 +2777,8 @@ end subroutine setaer subroutine aer_property & & ( prsi,prsl,prslk,tvly,rhlay,dz,hz,tracer, & ! --- inputs: & alon,alat,slmsk, laersw,laerlw, & - & IMAX,NLAY,NLP1, & - & aerosw,aerolw,aerodp & ! --- outputs: + & IMAX,NLAY,NLP1,top_at_1, & + & aerosw,aerolw,aerodp,errflg,errmsg & ! --- outputs: & ) ! ================================================================== ! @@ -2724,11 +2821,6 @@ subroutine aer_property & ! NLWBND - total number of actual lw spectral bands computed ! ! NSWLWBD - total number of sw+lw bands computed ! ! ! -! external module variables: (in physparam) ! -! ivflip - control flag for direction of vertical index ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! ! ! module variable: (set by subroutine aer_init) ! ! kprfg - aerosols profile index IMXAE*JMXAE ! ! 1:ant 2:arc 3:cnt 4:mar 5:des 6:marme 7:cntme ! @@ -2748,7 +2840,7 @@ subroutine aer_property & ! --- inputs: integer, intent(in) :: IMAX, NLAY, NLP1 ! integer, intent(in) :: IMAX, NLAY, NLP1, NSPC - logical, intent(in) :: laersw, laerlw + logical, intent(in) :: laersw, laerlw, top_at_1 real (kind=kind_phys), dimension(:,:), intent(in) :: prsi, prsl, & & prslk, tvly, rhlay, dz, hz @@ -2760,6 +2852,8 @@ subroutine aer_property & real (kind=kind_phys), dimension(:,:,:,:), intent(out) :: & & aerosw, aerolw real (kind=kind_phys), dimension(:,:) , intent(out) :: aerodp + integer, intent(out) :: errflg + character(len=*), intent(out) :: errmsg ! --- locals: real (kind=kind_phys), dimension(NCM) :: cmix @@ -2786,6 +2880,11 @@ subroutine aer_property & ! !===> ... begin here ! + +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + !> -# Map aerosol data to model grids !! - Map grid in longitude direction, lon from 0 to 355 deg resolution !! - Map grid in latitude direction, lat from 90n to 90s in 5 deg resolution @@ -2811,7 +2910,9 @@ subroutine aer_property & if ( i3 > IMXAE ) then print *,' ERROR! In setclimaer alon>360. ipt =',i, & & ', dltg,alon,tlon,dlon =',dltg,alon(i),tmp1,dtmp - stop + errflg = 1 + errmsg = 'ERROR(aer_property)' + return endif elseif ( dtmp >= f_zero ) then i1 = i3 @@ -2829,7 +2930,9 @@ subroutine aer_property & if ( i3 < 1 ) then print *,' ERROR! In setclimaer alon< 0. ipt =',i, & & ', dltg,alon,tlon,dlon =',dltg,alon(i),tmp1,dtmp - stop + errflg = 1 + errmsg = 'ERROR(aer_property)' + return endif endif enddo lab_do_IMXAE @@ -2848,7 +2951,9 @@ subroutine aer_property & if ( j3 >= JMXAE ) then print *,' ERROR! In setclimaer alat<-90. ipt =',i, & & ', dltg,alat,tlat,dlat =',dltg,alat(i),tmp2,dtmp - stop + errflg = 1 + errmsg = 'ERROR(aer_property)' + return endif elseif ( dtmp >= f_zero ) then j1 = j3 @@ -2866,7 +2971,9 @@ subroutine aer_property & if ( j3 < 1 ) then print *,' ERROR! In setclimaer alat>90. ipt =',i, & & ', dltg,alat,tlat,dlat =',dltg,alat(i),tmp2,dtmp - stop + errflg = 1 + errmsg = 'ERROR(aer_property)' + return endif endif enddo lab_do_JMXAE @@ -2963,14 +3070,16 @@ subroutine aer_property & dz1(k) = dz (i,k) enddo - lab_if_flip : if (ivflip == 1) then ! input from sfc to toa + lab_if_flip : if (.not. top_at_1) then ! input from sfc to toa if ( prsi(i,1) > 100.0 ) then rps = f_one / prsi(i,1) else print *,' !!! (1) Error in subr radiation_aerosols:', & & ' unrealistic surface pressure =', i,prsi(i,1) - stop + errflg = 1 + errmsg = 'ERROR(aer_property): Unrealistic surface pressure' + return endif ii = 1 @@ -3043,7 +3152,7 @@ subroutine aer_property & !> -# Call radclimaer() to calculate SW/LW aerosol optical properties !! for the corresponding frequency bands. - call radclimaer + call radclimaer(top_at_1) ! --- inputs: (in-scope variables) ! --- outputs: (in-scope variables) @@ -3104,7 +3213,7 @@ subroutine aer_property & !! troposphere, aerosol distribution at each grid point is composed !! from up to six components out of ten different substances. !-------------------------------- - subroutine radclimaer + subroutine radclimaer(top_at_1) !................................ ! --- inputs: (in scope variables) @@ -3140,6 +3249,7 @@ subroutine radclimaer parameter (crt1=30.0, crt2=0.03333) ! --- inputs: + logical, intent(in) :: top_at_1 ! --- outputs: ! --- locals: @@ -3342,7 +3452,7 @@ subroutine radclimaer ! !===> ... smooth profile at domain boundaries ! - if ( ivflip == 0 ) then ! input from toa to sfc + if (top_at_1) then ! input from toa to sfc do ib = 1, NSWLWBD do kk = 2, NLAY @@ -3419,8 +3529,8 @@ end subroutine aer_property !! @{ !----------------------------------- subroutine gocart_aerinit & - & ( solfwv, eirfwv, me & - & ) + & ( solfwv, eirfwv, me, & + & errflg, errmsg) ! ================================================================== ! ! ! @@ -3434,7 +3544,9 @@ subroutine gocart_aerinit & ! eirfwv(NWVTIR) - ir flux(273k) for each individual wavenum (w/m2)! ! me - print message control flag ! ! ! -! outputs: (to module variables) ! +! outputs: (CCPP error handling) ! +! errflg - CCPP error flag ! +! errmsg - CCPP error message ! ! ! ! module variables: ! ! NWVSOL - num of wvnum regions where solar flux is constant ! @@ -3460,7 +3572,9 @@ subroutine gocart_aerinit & integer, intent(in) :: me -! --- output: ( none ) +! --- output: (CCPP error handling) + integer, intent(out) :: errflg + character(len=*), intent(out) :: errmsg ! --- locals: real (kind=kind_phys), dimension(kaerbndi,kcm1) :: & @@ -3491,13 +3605,20 @@ subroutine gocart_aerinit & ! !===> ... begin here + +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! ! --- ... invoke gocart aerosol initialization if (KCM /= ntrcaerm ) then print *, 'ERROR in # of gocart aer species',KCM - stop 3000 + errflg = 1 + errmsg = 'ERROR(gocart_init): Incorrect # of species' + return endif ! --- ... aloocate and input aerosol optical data @@ -3814,7 +3935,9 @@ subroutine rd_gocart_luts else print *,' Requested luts file ',trim(fin),' not found' print *,' ** Stopped in rd_gocart_luts ** ' - stop 1220 + errflg = 1 + errmsg = 'Requested luts file '//trim(fin)//' not found' + return endif ! end if_file_exist_block iradius = 5 @@ -3876,7 +3999,9 @@ subroutine rd_gocart_luts else print *,' Requested luts file ',trim(fin),' not found' print *,' ** Stopped in rd_gocart_luts ** ' - stop 1222 + errflg = 1 + errmsg = 'Requested luts file '//trim(fin)//' not found' + return endif ! end if_file_exist_block ibeg = radius_lower(ib) - kcm1 @@ -4199,7 +4324,7 @@ subroutine aer_property_gocart & & alon,alat,slmsk, laersw,laerlw, & & imax,nlay,nlp1, & ! --- outputs: - & aerosw,aerolw,aerodp & + & aerosw,aerolw,aerodp,errflg,errmsg & & ) ! ================================================================== ! @@ -4242,11 +4367,6 @@ subroutine aer_property_gocart & ! NLWBND - total number of actual lw spectral bands computed ! ! NSWLWBD - total number of sw+lw bands computed ! ! ! -! external module variables: (in physparam) ! -! ivflip - control flag for direction of vertical index ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! ! ! module variable: (set by subroutine aer_init) ! ! ! ! usage: call aer_property_gocart ! @@ -4268,6 +4388,8 @@ subroutine aer_property_gocart & real (kind=kind_phys), dimension(:,:,:,:), intent(out) :: & & aerosw, aerolw real (kind=kind_phys), dimension(:,:) , intent(out) :: aerodp + integer, intent(out) :: errflg + character(len=*), intent(out) :: errmsg ! --- locals: real (kind=kind_phys), dimension(nlay,nswlwbd):: tauae,ssaae,asyae @@ -4281,6 +4403,11 @@ subroutine aer_property_gocart & ! !===> ... begin here ! + +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + lab_do_IMAXg : do i = 1, IMAX ! --- initialize tauae, ssaae, asyae diff --git a/physics/rrtmgp_aerosol_optics.F90 b/physics/rrtmgp_aerosol_optics.F90 index eb7797125..977594d6c 100644 --- a/physics/rrtmgp_aerosol_optics.F90 +++ b/physics/rrtmgp_aerosol_optics.F90 @@ -26,18 +26,22 @@ module rrtmgp_aerosol_optics !! subroutine rrtmgp_aerosol_optics_run(doSWrad, doLWrad, nCol, nLev, nTracer, nTracerAer, & nDay, idxday, p_lev, p_lay, p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, & - aerodp, sw_optical_props_aerosol, lw_optical_props_aerosol, errmsg, errflg ) + iaermdl, iaerflg, top_at_1, aerodp, sw_optical_props_aerosol, & + lw_optical_props_aerosol, errmsg, errflg ) ! Inputs logical, intent(in) :: & doSWrad, & ! Logical flag for shortwave radiation call - doLWrad ! Logical flag for longwave radiation call + doLWrad, & ! Logical flag for longwave radiation call + top_at_1 ! Logical flag for vertical grid direcetion integer, intent(in) :: & nCol, & ! Number of horizontal grid points nDay, & ! Number of daylit points nLev, & ! Number of vertical layers nTracer, & ! Number of tracers - nTracerAer ! Number of aerosol tracers + nTracerAer, & ! Number of aerosol tracers + iaermdl, & ! Aerosol model scheme flag + iaerflg ! Aerosol effects to include integer,intent(in),dimension(:) :: & idxday ! Indices for daylit points. real(kind_phys), dimension(:), intent(in) :: & @@ -83,7 +87,7 @@ subroutine rrtmgp_aerosol_optics_run(doSWrad, doLWrad, nCol, nLev, nTracer, nTra ! Call module_radiation_aerosols::setaer(),to setup aerosols property profile call setaer(p_lev*0.01, p_lay*0.01, p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, nCol, nLev, & - nLev+1, .true., .true., aerosolssw2, aerosolslw, aerodp) + nLev+1, .true., .true., iaermdl, iaerflg, top_at_1, aerosolssw2, aerosolslw, aerodp, errflg, errmsg) ! Shortwave if (nDay .gt. 0) then diff --git a/physics/rrtmgp_aerosol_optics.meta b/physics/rrtmgp_aerosol_optics.meta index f0c37edc0..516943d49 100644 --- a/physics/rrtmgp_aerosol_optics.meta +++ b/physics/rrtmgp_aerosol_optics.meta @@ -21,6 +21,13 @@ dimensions = () type = logical intent = in +[top_at_1] + standard_name = flag_for_vertical_ordering_in_RRTMGP + long_name = flag for vertical ordering in RRTMGP + units = flag + dimensions = () + type = logical + intent = in [ncol] standard_name = horizontal_loop_extent long_name = horizontal dimension @@ -143,6 +150,20 @@ type = real kind = kind_phys intent = in +[iaermdl] + standard_name = flag_for_aerosol_radiation_scheme + long_name = flag for aerosol scheme to use in radiation + units = flag + dimensions = () + type = integer + intent = in +[iaerflg] + standard_name = flag_for_aerosol_effects_in_radiation + long_name = flag for aerosol effects to include in radiation + units = flag + dimensions = () + type = integer + intent = in [aerodp] standard_name = atmosphere_optical_thickness_due_to_ambient_aerosol_particles long_name = vertical integrated optical depth for various aerosol species From 11f1ef0351411e6b05160458c7b7ebe60fabf588 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Mon, 15 Aug 2022 12:27:19 -0600 Subject: [PATCH 012/380] Remove dependency on physcons and physparam in radiation_aerosols.f. Provided as ccpp interstitials. --- physics/GFS_rrtmg_pre.F90 | 28 +++-- physics/GFS_rrtmg_pre.meta | 34 +++++-- physics/GFS_rrtmg_setup.F90 | 28 ++--- physics/GFS_rrtmg_setup.meta | 42 +++++++- physics/GFS_rrtmgp_setup.F90 | 8 +- physics/GFS_rrtmgp_setup.meta | 40 ++++++++ physics/physparam.f | 18 ---- physics/radiation_aerosols.f | 158 ++++++++++++++++------------- physics/rrtmgp_aerosol_optics.F90 | 10 +- physics/rrtmgp_aerosol_optics.meta | 24 +++++ 10 files changed, 258 insertions(+), 132 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index b4b69d447..3387e7d40 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -34,7 +34,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & rog, rocp, con_rd, xlat_d, xlat, xlon, coslat, sinlat, tsfc, slmsk, & prsi, prsl, prslk, tgrs, sfc_wts, mg_cld, effrr_in, pert_clds, & sppt_wts, sppt_amp, cnvw_in, cnvc_in, qgrs, aer_nm, dx, icloud, & - iaermdl, iaerflg, & !inputs from here and above + iaermdl, iaerflg, con_pi, con_g, & !inputs from here and above coszen, coszdg, effrl_inout, effri_inout, effrs_inout, & clouds1, clouds2, clouds3, clouds4, clouds5, qci_conv, & !in/out from here and above kd, kt, kb, mtopa, mbota, raddt, tsfg, tsfa, de_lgth, alb1d, delp, dz, & !output from here and below @@ -48,8 +48,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & use machine, only: kind_phys - use physparam - use radcons, only: itsfc,ltp, lextop, qmin, & qme5, qme6, epsq, prsmin use funcphys, only: fpvs @@ -130,7 +128,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & real(kind_phys), intent(in) :: spp_wts_rad(:,:) real(kind=kind_phys), intent(in) :: fhswr, fhlwr, solhr, sup, julian, sppt_amp - real(kind=kind_phys), intent(in) :: con_eps, epsm1, fvirt, rog, rocp, con_rd + real(kind=kind_phys), intent(in) :: con_eps, epsm1, fvirt, rog, rocp, con_rd, con_pi, con_g real(kind=kind_phys), dimension(:), intent(in) :: xlat_d, xlat, xlon, & coslat, sinlat, tsfc, & @@ -258,7 +256,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & errflg = 0 ! Vertical ordering - top_at_1 = (prsi(1,1) .lt. prsi(1, lm)) + top_at_1 = (prsi(1,1) .lt. prsi(1, LMP)) if (.not. (lsswr .or. lslwr)) return @@ -285,7 +283,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & ! variables if ( lextop ) then - if ( ivflip == 1 ) then ! vertical from sfc upward + if (.not. top_at_1) then ! vertical from sfc upward kd = 0 ! index diff between in/out and local kt = 1 ! index diff between lyr and upper bound kb = 0 ! index diff between lyr and lower bound @@ -301,16 +299,16 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & llb = 1 ! local index at toa level lya = 2 ! local index for the 2nd layer from top lyb = 1 ! local index for the top layer - endif ! end if_ivflip_block + endif ! end if_top_at_1_block else kd = 0 - if ( ivflip == 1 ) then ! vertical from sfc upward + if (.not. top_at_1) then ! vertical from sfc upward kt = 1 ! index diff between lyr and upper bound kb = 0 ! index diff between lyr and lower bound else ! vertical from toa downward kt = 0 ! index diff between lyr and upper bound kb = 1 ! index diff between lyr and lower bound - endif ! end if_ivflip_block + endif ! end if_top_at_1_block endif ! end if_lextop_block raddt = min(fhswr, fhlwr) @@ -337,7 +335,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & ! lsk = 0 - if (ivflip == 0 .and. lm < levs) lsk = levs - lm + if (top_at_1 .and. lm < levs) lsk = levs - lm ! convert pressure unit from pa to mb do k = 1, LM @@ -366,7 +364,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo enddo ! - if (ivflip == 0) then ! input data from toa to sfc + if (top_at_1) then ! input data from toa to sfc if (lsk > 0) then k1 = 1 + kd k2 = k1 + kb @@ -475,7 +473,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo enddo - if (ivflip == 0) then ! input data from toa to sfc + if (top_at_1) then ! input data from toa to sfc do i = 1, IM tem1d (i) = QME6 tem2da(i,1) = log( plyr(i,1) ) @@ -605,7 +603,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & dzb(i,1) = hzb(i,1) - hz(i,1) enddo - endif ! end_if_ivflip + endif ! end_if_top_at_1 !> - Call module_radiation_aerosols::setaer(),to setup aerosols !! property profile for radiation. @@ -637,8 +635,8 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & call setaer (plvl, plyr, prslk1, tvly, rhly, slmsk, & ! --- inputs tracer1, aer_nm, xlon, xlat, IM, LMK, LMP,& - lsswr,lslwr,iaermdl,iaerflg,top_at_1, & - faersw,faerlw,aerodp,errflg,errmsg) ! --- outputs + lsswr, lslwr, iaermdl, iaerflg, top_at_1, con_pi, & + con_rd, con_g, faersw, faerlw, aerodp, errflg, errmsg) ! --- outputs ! CCPP do j = 1,NBDSW diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index e15ca3730..0c2240720 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -2,7 +2,7 @@ name = GFS_rrtmg_pre type = scheme dependencies = funcphys.f90,iounitdef.f,machine.F,module_bfmicrophysics.f,module_mp_radar.F90,module_mp_thompson.F90 - dependencies = module_mp_thompson_make_number_concentrations.F90,physparam.f,physcons.F90,radcons.f90,radiation_aerosols.f + dependencies = module_mp_thompson_make_number_concentrations.F90,radcons.f90,radiation_aerosols.f dependencies = radiation_astronomy.f,radiation_clouds.f,radiation_gases.f,radlw_param.f,radsw_param.f,surface_perturbation.F90,radiation_cloud_overlap.F90 ######################################################################## @@ -639,6 +639,30 @@ type = real kind = kind_phys intent = in +[con_pi] + standard_name = pi + long_name = ratio of a circle's circumference to its diameter + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rd] + standard_name = gas_constant_of_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in [epsm1] standard_name = ratio_of_dry_air_to_water_vapor_gas_constants_minus_one long_name = (rd/rv) - 1 @@ -671,14 +695,6 @@ type = real kind = kind_phys intent = in -[con_rd] - standard_name = gas_constant_of_dry_air - long_name = ideal gas constant for dry air - units = J kg-1 K-1 - dimensions = () - type = real - kind = kind_phys - intent = in [xlat_d] standard_name = latitude_in_degree long_name = latitude in degree north diff --git a/physics/GFS_rrtmg_setup.F90 b/physics/GFS_rrtmg_setup.F90 index ebe34a705..8fb417f61 100644 --- a/physics/GFS_rrtmg_setup.F90 +++ b/physics/GFS_rrtmg_setup.F90 @@ -4,13 +4,11 @@ !> \defgroup GFS_rrtmg_setup_mod GFS RRTMG Scheme Setup module GFS_rrtmg_setup - use physparam, only : isolar , ictmflg, ico2flg, ioznflg, & - & icldflg, & + use physparam, only : isolar , ictmflg, ico2flg, ioznflg, icldflg, & & iovrRad=>iovr, lcrick , lcnorm , lnoprec, & & isubcsw, isubclw, ivflip , ipsd0, & - & iswcliq, & - & kind_phys - + & iswcliq + use machine, only: kind_phys use radcons, only: ltp, lextop implicit none @@ -49,7 +47,8 @@ subroutine GFS_rrtmg_setup_init ( & imp_physics, & norad_precip, idate, iflip, & do_RRTMGP, me, lalw1bd, iaermdl, iaerflg, & - aeros_file, errmsg, errflg) + aeros_file, con_pi, con_t0c, con_c, con_boltz, & + con_plnk, errmsg, errflg) ! ================= subprogram documentation block ================ ! ! ! ! subprogram: GFS_rrtmg_setup_init - a subprogram to initialize radiation ! @@ -170,7 +169,8 @@ subroutine GFS_rrtmg_setup_init ( & integer, intent(in) :: iflip logical, intent(in) :: do_RRTMGP, lalw1bd integer, intent(in) :: me - character(len=26), intent(in) :: aeros_file + character(len=26),intent(in) :: aeros_file + real(kind_phys), intent(in) :: con_pi,con_t0c,con_c,con_boltz,con_plnk character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg integer, intent(out) :: iaermdl, iaerflg @@ -245,7 +245,8 @@ subroutine GFS_rrtmg_setup_init ( & call radinit & ! --- inputs: & ( si, levr, imp_physics, me, iaermdl, iaerflg, lalw1bd, & - & aeros_file, errmsg, errflg ) + & aeros_file, con_pi, con_t0c, con_c, con_boltz, con_plnk, & + & errmsg, errflg ) ! --- outputs: ! ( none ) @@ -297,8 +298,8 @@ subroutine GFS_rrtmg_setup_timestep_init ( & errmsg = '' errflg = 0 - call radupdate(idate,jdate,deltsw,deltim,lsswr,me, iaermdl,& - iaerflg, aeros_file, slag,sdec,cdec,solcon,errflg,errmsg) + call radupdate(idate,jdate,deltsw,deltim,lsswr,me,iaermdl,& + iaerflg,aeros_file,slag,sdec,cdec,solcon,errflg,errmsg) end subroutine GFS_rrtmg_setup_timestep_init @@ -329,7 +330,7 @@ end subroutine GFS_rrtmg_setup_finalize subroutine radinit( si, NLAY, imp_physics, me, iaermdl, iaerflg, lalw1bd, & - aeros_file, errmsg, errflg) + aeros_file, con_pi, con_t0c, con_c, con_boltz, con_plnk, errmsg, errflg) !................................... ! --- inputs: @@ -444,7 +445,7 @@ subroutine radinit( si, NLAY, imp_physics, me, iaermdl, iaerflg, lalw1bd, & ! --- inputs: integer, intent(in) :: NLAY, me, imp_physics, iaermdl, iaerflg logical, intent(in) :: lalw1bd - real (kind=kind_phys), intent(in) :: si(:) + real (kind=kind_phys), intent(in) :: si(:), con_pi,con_t0c, con_c, con_boltz, con_plnk character(len=26), intent(in) :: aeros_file ! --- outputs: (ccpp error handling) @@ -534,7 +535,8 @@ subroutine radinit( si, NLAY, imp_physics, me, iaermdl, iaerflg, lalw1bd, & call sol_init ( me ) ! --- ... astronomy initialization routine - call aer_init ( NLAY, me, iaermdl, iaerflg, lalw1bd, aeros_file, errflg, errmsg) ! --- ... aerosols initialization routine + call aer_init ( NLAY, me, iaermdl, iaerflg, lalw1bd, aeros_file, con_pi, & + con_t0c, con_c, con_boltz, con_plnk, errflg, errmsg) ! --- ... aerosols initialization routine call gas_init ( me ) ! --- ... co2 and other gases initialization routine diff --git a/physics/GFS_rrtmg_setup.meta b/physics/GFS_rrtmg_setup.meta index 09068b6a6..6ca7552cc 100644 --- a/physics/GFS_rrtmg_setup.meta +++ b/physics/GFS_rrtmg_setup.meta @@ -2,7 +2,7 @@ name = GFS_rrtmg_setup type = scheme dependencies = iounitdef.f,module_bfmicrophysics.f,physparam.f,radcons.f90,radiation_aerosols.f,radiation_astronomy.f,radiation_clouds.f - dependencies = module_mp_thompson.F90,radiation_gases.f,radlw_main.F90,radlw_param.f,radsw_main.F90,radsw_param.f + dependencies = module_mp_thompson.F90,radiation_gases.f,radlw_main.F90,radlw_param.f,radsw_main.F90,radsw_param.f,machine.F ######################################################################## [ccpp-arg-table] @@ -171,6 +171,46 @@ type = character kind = len=26 intent = in +[con_pi] + standard_name = pi + long_name = ratio of a circle's circumference to its diameter + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[con_c] + standard_name = speed_of_light_in_vacuum + long_name = speed of light in vacuum + units = m s-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_plnk] + standard_name = planck_constant + long_name = Planck constant + units = J s-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_boltz] + standard_name = boltzmann_constant + long_name = Boltzmann constant + units = J K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_t0c] + standard_name = temperature_at_zero_celsius + long_name = temperature at 0 degree Celsius + units = K + dimensions = () + type = real + kind = kind_phys + intent = in [lalw1bd] standard_name = flag_for_longwave_aerosol_band_properties long_name = flag for band or multiband longwave aerosol properties diff --git a/physics/GFS_rrtmgp_setup.F90 b/physics/GFS_rrtmgp_setup.F90 index 54a40d505..b8e5d4fd7 100644 --- a/physics/GFS_rrtmgp_setup.F90 +++ b/physics/GFS_rrtmgp_setup.F90 @@ -42,7 +42,8 @@ subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, imp_physics_zhao_carr, & imp_physics_zhao_carr_pdf, imp_physics_mg, si, levr, ictm, isol, ico2, iaer, & ntcw, num_p3d, ntoz, iovr, isubc_sw, isubc_lw, icliq_sw, crick_proof, ccnorm, & - norad_precip, lalw1bd, idate, iflip, me, aeros_file, iaermdl, iaerflg, errmsg, errflg) + norad_precip, lalw1bd, idate, iflip, me, aeros_file, iaermdl, iaerflg, con_pi, & + con_t0c, con_c, con_boltz, con_plnk, errmsg, errflg) ! Inputs logical, intent(in) :: do_RRTMGP @@ -55,6 +56,8 @@ subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires, imp_physics_zhao_carr, & ! Flag for zhao-carr scheme imp_physics_zhao_carr_pdf, & ! Flag for zhao-carr+PDF scheme imp_physics_mg ! Flag for MG scheme + real(kind_phys), intent(in) :: & + con_pi, con_t0c, con_c, con_boltz, con_plnk real(kind_phys), dimension(:), intent(in) :: & si integer, intent(in) :: levr, ictm, isol, ico2, iaer, & @@ -129,7 +132,8 @@ subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires, ! Call initialization routines.. call sol_init ( me ) - call aer_init ( levr, me, iaermdl, iaerflg, lalw1bd, aeros_file, errflg, errmsg) + call aer_init ( levr, me, iaermdl, iaerflg, lalw1bd, aeros_file, con_pi, con_t0c, & + con_c, con_boltz, con_plnk, errflg, errmsg) call gas_init ( me ) !call hml_cloud_diagnostics_initialize(imp_physics, imp_physics_fer_hires, & ! imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, & diff --git a/physics/GFS_rrtmgp_setup.meta b/physics/GFS_rrtmgp_setup.meta index ea4fdcb88..028495f14 100644 --- a/physics/GFS_rrtmgp_setup.meta +++ b/physics/GFS_rrtmgp_setup.meta @@ -221,6 +221,46 @@ type = character kind = len=26 intent = in +[con_pi] + standard_name = pi + long_name = ratio of a circle's circumference to its diameter + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[con_c] + standard_name = speed_of_light_in_vacuum + long_name = speed of light in vacuum + units = m s-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_plnk] + standard_name = planck_constant + long_name = Planck constant + units = J s-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_boltz] + standard_name = boltzmann_constant + long_name = Boltzmann constant + units = J K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_t0c] + standard_name = temperature_at_zero_celsius + long_name = temperature at 0 degree Celsius + units = K + dimensions = () + type = real + kind = kind_phys + intent = in [iaermdl] standard_name = flag_for_aerosol_radiation_scheme long_name = flag for aerosol scheme to use in radiation diff --git a/physics/physparam.f b/physics/physparam.f index 0e6a6f663..b6dd84c99 100644 --- a/physics/physparam.f +++ b/physics/physparam.f @@ -119,15 +119,6 @@ module physparam !! \cite fu_et_al_1998 method integer,save :: ilwcice = 3 -! ............................................. ! -!>\name 1.3 Control flag for LW aerosol property - -!> selects 1 band or multi bands for LW aerosol properties -!!\n =.true.:aerosol properties calculated in 1 broad LW band -!!\n =.false.:aerosol properties calculated in all LW bands -!!\n variable names diff in Opr CFS - logical,parameter :: lalw1bd =.false. - !================================================================================== ! Section - 2 - ! values of control flags might be re-set in initialization subroutines @@ -153,15 +144,6 @@ module physparam ! data solar_file / 'solarconstantdata.txt ' / data solar_file / 'solarconstant_noaa_a0.txt ' / -! ............................................. ! -!> \name 2.2 For module radiation_aerosols -! ............................................. ! - -!> external aerosols data file: aerosol.dat - character, save :: aeros_file*26 -! data aeros_file / 'climaeropac_global.txt ' / - data aeros_file / 'aerosol.dat ' / - ! ............................................. ! !> \name 2.3 For module radiation_gases ! ............................................. ! diff --git a/physics/radiation_aerosols.f b/physics/radiation_aerosols.f index 20a456cf4..a96b1d942 100644 --- a/physics/radiation_aerosols.f +++ b/physics/radiation_aerosols.f @@ -32,8 +32,6 @@ ! ! ! ! ! external modules referenced: ! -! 'module physparam' in 'physparam.f' ! -! 'module physcons' in 'physcons.f' ! ! 'module module_radsw_parameters' in 'radsw_xxxx#_param.f' ! ! 'module module_radlw_parameters' in 'radlw_xxxx#_param.f' ! ! 'module module_radlw_cntr_para' in 'radsw_xxxx#_param.f' ! @@ -158,9 +156,6 @@ module module_radiation_aerosols ! !........................................! ! use machine, only : kind_phys, kind_io4, kind_io8 - use physcons, only : con_pi, con_rd, con_g, con_t0c, con_c, & - & con_boltz, con_plnk, con_amd - use module_iounitdef, only : NIAERCM use module_radsw_parameters, only : NBDSW, wvnsw1=>wvnum1, & & NSWSTR, wvnsw2=>wvnum2 @@ -499,9 +494,8 @@ module module_radiation_aerosols ! !! @{ !----------------------------------- subroutine aer_init & - & ( NLAY, me, iaermdl, iaerflg, lalw1bd, aeros_file, & - & errflg, errmsg) -! --- outputs: ( to module variables ) + & ( NLAY, me, iaermdl, iaerflg, lalw1bd, aeros_file, con_pi, & + & con_t0c, con_c, con_boltz, con_plnk, errflg, errmsg) ! ================================================================== ! ! ! @@ -511,26 +505,26 @@ subroutine aer_init & ! inputs: ! ! NLAY - number of model vertical layers (not used) ! ! me - print message control flag ! +! iaermdl - tropospheric aerosol model scheme flag ! +! =0 opac-clim; =1 gocart-clim, =2 gocart-prognostic ! +! =5 opac-clim new spectral mapping ! +! lalw1bd = logical lw aeros propty 1 band vs multi-band cntl flag ! +! =t use 1 broad band optical property ! +! =f use multi bands optical property ! ! ! ! outputs: (CCPP error handling) ! ! errmsg - CCPP error message ! ! errflg - CCPP error flag ! ! ! -! external module variables: (in physparam) ! -! iaermdl - tropospheric aerosol model scheme flag ! -! =0 opac-clim; =1 gocart-clim, =2 gocart-prognostic ! -! =5 opac-clim new spectral mapping ! +! internal module variables: ! ! lalwflg - logical lw aerosols effect control flag ! ! =t compute lw aerosol optical prop ! ! laswflg - logical sw aerosols effect control flag ! ! =t compute sw aerosol optical prop ! ! lavoflg - logical stratosphere volcanic aerosol control flag ! ! =t include volcanic aerosol effect ! -! lalw1bd = logical lw aeros propty 1 band vs multi-band cntl flag ! -! =t use 1 broad band optical property ! -! =f use multi bands optical property ! ! ! -! module constants: ! +! internal module constants: ! ! NWVSOL - num of wvnum regions where solar flux is constant ! ! NWVTOT - total num of wave numbers used in sw spectrum ! ! NWVTIR - total num of wave numbers used in the ir region ! @@ -548,6 +542,8 @@ subroutine aer_init & integer, intent(in) :: NLAY, me, iaermdl, iaerflg logical, intent(in) :: lalw1bd character(len=26),intent(in) :: aeros_file + real(kind_phys), intent(in) :: con_pi,con_t0c, con_c, con_boltz, & + & con_plnk ! --- output: integer, intent(out) :: errflg character(len=*), intent(out) :: errmsg @@ -628,14 +624,14 @@ subroutine aer_init & !> -# Call set_spectrum() to set up spectral one wavenumber solar/IR !! fluxes. - call set_spectrum(errflg, errmsg) + call set_spectrum(con_pi, con_t0c, con_c, con_boltz, con_plnk, & + & errflg, errmsg) ! --- inputs: (module constants) ! --- outputs: (ccpp error handling) !> -# Call clim_aerinit() to invoke tropospheric aerosol initialization. if ( iaermdl==0 .or. iaermdl==5 ) then ! opac-climatology scheme - call clim_aerinit & ! --- inputs: & ( solfwv, eirfwv, me, aeros_file, & @@ -682,10 +678,6 @@ subroutine aer_init & !> This subroutine writes aerosol parameter configuration to run log file. !-------------------------------- subroutine wrt_aerlog(iaermdl, iaerflg, lalw1bd, errflg, errmsg) -!................................ -! --- inputs: (in scope variables) -! --- outputs: (CCPP error handling) - ! ================================================================== ! ! ! ! subprogram : wrt_aerlog ! @@ -694,11 +686,14 @@ subroutine wrt_aerlog(iaermdl, iaerflg, lalw1bd, errflg, errmsg) ! ! ! ==================== defination of variables =================== ! ! ! -! external module variables: (in physparam) ! -! iaerflg - aerosol effect control flag: 3-digits (volc,lw,sw) ! +! internal module variables: ! ! lalwflg - toposphere lw aerosol effect: =f:no; =t:yes ! ! laswflg - toposphere sw aerosol effect: =f:no; =t:yes ! -! lavoflg - stratospherer volcanic aeros effect: =f:no; =t:yes ! +! lavoflg - stratosphere volcanic aeros effect: =f:no; =t:yes ! +! ! +! inputs: ! +! iaerflg - aerosol effect control flag: 3-digits (volc,lw,sw) ! +! iaermdl - tropospheric aerosol model scheme flag ! ! ! ! outputs: ! ! errmsg - CCPP error message ! @@ -790,10 +785,8 @@ end subroutine wrt_aerlog !> This subroutine defines the one wavenumber solar fluxes based on toa !! solar spectral distribution, and define the one wavenumber IR fluxes !! based on black-body emission distribution at a predefined temperature. - subroutine set_spectrum(errflg, errmsg) -!................................ -! --- inputs: (module constants) -! --- outputs: (ccpp error handling) + subroutine set_spectrum(con_pi, con_t0c, con_c, con_boltz, & + & con_plnk, errflg, errmsg) ! ================================================================== ! ! ! @@ -805,7 +798,14 @@ subroutine set_spectrum(errflg, errmsg) ! ! ! ==================== defination of variables =================== ! ! ! -!> - inputs: (module constants) +!> - inputs: (CCPP Interstitials) +!! - con_pi: Physical constant (pi) +!! - con_t0c: Physical constant (temperature kelvin at zero celcius) +!! - con_c: Physical constant (speed of light) +!! - con_boltz: Physical constant (Boltzmann constant) +!! - con_plnk: Physical constant (Planck constant) +!! +!> - inputs: (in-scope variables) !! - NWVTOT: total num of wave numbers used in sw spectrum !! - NWVTIR: total num of wave numbers used in the ir region !! @@ -814,6 +814,8 @@ subroutine set_spectrum(errflg, errmsg) !! (\f$W/m^2\f$) !! - eirfwv(NWVTIR): ir flux(273k) for each individual wavenumber !! (\f$W/m^2\f$) +!! +!> - outputs: (CCPP error-handling) !! - errflg: CCPP error flag !! - errmsg: CCPP error message ! ! @@ -825,10 +827,14 @@ subroutine set_spectrum(errflg, errmsg) ! --- inputs: (module constants) ! integer :: NWVTOT, NWVTIR +! --- inputs: (CCPP Interstitials) + real(kind_phys),intent(in) :: con_pi, con_t0c, con_c, con_boltz, & + & con_plnk ! --- output: (in-scope variables) ! real (kind=kind_phys), dimension(NWVTOT) :: solfwv ! one wvn sol flux ! real (kind=kind_phys), dimension(NWVTIR) :: eirfwv ! one wvn ir flux +! --- output: (CCPP error-handling) integer, intent(out) :: errflg character(len=*), intent(out) :: errmsg ! --- locals: @@ -964,26 +970,17 @@ subroutine clim_aerinit & ! solfwv(NWVTOT) - solar flux for each individual wavenumber (w/m2)! ! eirfwv(NWVTIR) - ir flux(273k) for each individual wavenum (w/m2)! ! me - print message control flag ! +! aeros_file - external aerosol data file name ! ! ! ! outputs: (CCPP error handling) ! ! errflg - CCPP error flag ! ! errmsg - CCPP error message ! ! ! -! external module variables: (in physparam) ! -! iaerflg - abc 3-digit integer aerosol flag (abc:volc,lw,sw) ! -! a: =0 use background stratospheric aerosol ! -! =1 incl stratospheric vocanic aeros (MINVYR-MAXVYR) ! -! b: =0 no topospheric aerosol in lw radiation ! -! =1 include tropspheric aerosols for lw radiation ! -! c: =0 no topospheric aerosol in sw radiation ! -! =1 include tropspheric aerosols for sw radiation ! +! internal module variables: ! ! lalwflg - logical lw aerosols effect control flag ! ! =t compute lw aerosol optical prop ! ! laswflg - logical sw aerosols effect control flag ! ! =t compute sw aerosol optical prop ! -! lalw1bd = logical lw aeros propty 1 band vs multi-band cntl flag ! -! =t use 1 broad band optical property ! -! =f use multi bands optical property ! ! ! ! module constants: ! ! NWVSOL - num of wvnum regions where solar flux is constant ! @@ -1004,7 +1001,6 @@ subroutine clim_aerinit & ! --- inputs: real (kind=kind_phys), dimension(:) :: solfwv ! one wvn sol flux real (kind=kind_phys), dimension(:) :: eirfwv ! one wvn ir flux - integer, intent(in) :: me character(len=26), intent(in) :: aeros_file ! --- output: (CCPP error handling) @@ -1076,7 +1072,7 @@ subroutine set_aercoef(aeros_file,errflg, errmsg) ! errflg - CCPP error flag ! ! errmsg - CCPP error message ! ! ! -! external module variables: (in physparam) ! +! external module variables: ! ! lalwflg - module control flag for lw trop-aer: =f:no; =t:yes ! ! laswflg - module control flag for sw trop-aer: =f:no; =t:yes ! ! aeros_file- external aerosol data file name ! @@ -1536,7 +1532,7 @@ subroutine optavg ! NSWBND - total number of sw spectral bands ! ! NLWBND - total number of lw spectral bands ! ! ! -! external module variables: (in physparam) ! +! external module variables: ! ! laswflg - control flag for sw spectral region ! ! lalwflg - control flag for lw spectral region ! ! ! @@ -1773,24 +1769,25 @@ end subroutine clim_aerinit !! @{ !----------------------------------- subroutine aer_update & - & ( iyear, imon, me, iaermdl, aeros_file, errflg, errmsg ) ! --- inputs: -! --- outputs: ( CCPP error handling ) + & ( iyear, imon, me, iaermdl, aeros_file, errflg, errmsg ) ! ================================================================== ! ! ! ! aer_update checks and update time varying climatology aerosol ! ! data sets. ! ! ! -! inputs: size ! -! iyear - 4-digit calender year 1 ! -! imon - month of the year 1 ! -! me - print message control flag 1 ! +! inputs: size ! +! iyear - 4-digit calender year 1 ! +! imon - month of the year 1 ! +! me - print message control flag 1 ! +! iaermdl - tropospheric aerosol model scheme flag 1 ! +! aeros_file - external aerosol data file name len=26 ! ! ! -! outputs: (CCPP error handling) ! -! errmsg - CCPP error message ! +! outputs: (CCPP error handling) len=* ! +! errmsg - CCPP error message 1 ! ! errflg - CCPP error flag ! ! ! -! external module variables: (in physparam) ! +! internal module variables: ! ! lalwflg - control flag for tropospheric lw aerosol ! ! laswflg - control flag for tropospheric sw aerosol ! ! lavoflg - control flag for stratospheric volcanic aerosol ! @@ -1804,7 +1801,7 @@ subroutine aer_update & ! --- inputs: integer, intent(in) :: iyear, imon, me, iaermdl character(len=26),intent(in) :: aeros_file -! --- output: ( none ) +! --- output: (CCPP error-handling) integer, intent(out) :: errflg character(len=*), intent(out) :: errmsg ! --- locals: ( none ) @@ -1848,9 +1845,6 @@ subroutine aer_update & !! profiles in five degree horizontal resolution. !-------------------------------- subroutine trop_update(aeros_file, errflg, errmsg) -!................................ -! --- inputs: (in scope variables, module variables) -! --- outputs: (CCPP error handling) ! ================================================================== ! ! ! @@ -1864,11 +1858,14 @@ subroutine trop_update(aeros_file, errflg, errmsg) ! inputs: (in-scope variables, module constants) ! ! imon - integer, month of the year ! ! me - integer, print message control flag ! +! inputs: (CCPP Interstitials) ! +! aeros_file - external aerosol data file name ! ! ! ! outputs: (module variables) ! -! ! -! external module variables: (in physparam) ! -! aeros_file - external aerosol data file name ! +! +! outputs: (CCPP error-handling) ! +! errmsg - Error message ! +! errflg - Error flag ! ! ! ! internal module variables: ! ! kprfg ( IMXAE*JMXAE) - aeros profile index ! @@ -1884,7 +1881,7 @@ subroutine trop_update(aeros_file, errflg, errmsg) ! ! ! ================================================================== ! -! --- inputs: ( none ) +! --- inputs: (CCPP Interstitials) character(len=26),intent(in) :: aeros_file ! --- output: (CCPP error handling) integer, intent(out) :: errflg @@ -2046,6 +2043,10 @@ subroutine volc_update(errflg, errmsg) ! kyrsav - integer, the year of data in use in the input file ! ! kmonsav - integer, the month of data in use in the input file ! ! ! +! outputs: (CCPP error-handling) ! +! errmsg - Error message ! +! errflg - Error flag ! +! ! ! subroutines called: none ! ! ! ! usage: call volc_aerinit ! @@ -2057,6 +2058,7 @@ subroutine volc_update(errflg, errmsg) ! --- output: (module variables) ! integer :: ivolae(:,:,:), kyrstr, kyrend, kyrsav, kmonsav +! --- output: (CCPP error-handling) integer, intent(out) :: errflg character(len=*), intent(out) :: errmsg @@ -2186,7 +2188,7 @@ end subroutine aer_update subroutine setaer & & ( prsi,prsl,prslk,tvly,rhlay,slmsk,tracer,aerfld,xlon,xlat, & ! --- inputs & IMAX,NLAY,NLP1, lsswr,lslwr,iaermdl,iaerflg,top_at_1, & - & aerosw,aerolw, & ! --- outputs + & con_pi,con_rd,con_g,aerosw,aerolw, & ! --- outputs & aerodp, errflg, errmsg & & ) @@ -2211,6 +2213,12 @@ subroutine setaer & ! NLAY,NLP1-vertical dimensions of arrays 1 ! ! lsswr,lslwr ! ! - logical flags for sw/lw radiation calls 1 ! +! con_pi - Physical constant (pi) ! +! con_t0c - Physical constant (temperature kelvin at zero celcius) ! +! con_c - Physical constant (speed of light) ! +! iaermdl - tropospheric aerosol model scheme flag ! +! iaerflg - aerosol effect control flag ! +! top_at_1 - Vertical ordering convection flag ! ! ! ! outputs: ! ! aerosw - aeros opt properties for sw IMAX*NLAY*NBDSW*NF_AESW! @@ -2227,8 +2235,7 @@ subroutine setaer & ! errflg - CCPP error flag ! ! errmsg - CCPP error message ! ! ! -! external module variable: (in physparam) ! -! iaerflg - aerosol effect control flag (volc,lw,sw, 3-dig) ! +! internal module variable: ! ! laswflg - tropospheric aerosol control flag for sw radiation ! ! =f: no sw aeros calc. =t: do sw aeros calc. ! ! lalwflg - tropospheric aerosol control flag for lw radiation ! @@ -2246,7 +2253,7 @@ subroutine setaer & ! --- inputs: integer, intent(in) :: IMAX, NLAY, NLP1, iaermdl, iaerflg - + real (kind=kind_phys), intent(in) :: con_pi, con_rd, con_g real (kind=kind_phys), dimension(:,:), intent(in) :: prsi, prsl, & & prslk, tvly, rhlay real (kind=kind_phys), dimension(:), intent(in) :: xlon, xlat, & @@ -2280,10 +2287,12 @@ subroutine setaer & logical :: laddlw=.false., laerlw=.false. ! --- conversion constants - real (kind=kind_phys), parameter :: rdg = 180.0 / con_pi - real (kind=kind_phys), parameter :: rovg = 0.001 * con_rd / con_g + real (kind=kind_phys) :: rdg + real (kind=kind_phys) :: rovg !===> ... begin here + rdg = 180._kind_phys / con_pi + rovg = 0.001_kind_phys * con_rd / con_g ! Initialize CCPP error handling variables errmsg = '' @@ -2409,7 +2418,7 @@ subroutine setaer & call aer_property_gocart & ! --- inputs: & ( prsi,prsl,prslk,tvly,rhlay,dz,hz,tracer,aerfld, & - & alon,alat,slmsk,laersw,laerlw, & + & alon,alat,slmsk,laersw,laerlw,con_rd, & & IMAX,NLAY,NLP1, & ! --- outputs: & aerosw,aerolw,aerodp,errflg,errmsg & @@ -2804,6 +2813,7 @@ subroutine aer_property & ! IMAX - horizontal dimension of arrays 1 ! ! NLAY,NLP1-vertical dimensions of arrays 1 ! !! NSPC - num of species for optional aod output fields 1 ! +! top_at_1 - vertical ordering flag ! ! ! ! outputs: ! ! aerosw - aeros opt properties for sw IMAX*NLAY*NBDSW*NF_AESW! @@ -2816,6 +2826,9 @@ subroutine aer_property & ! (:,:,:,3): asymmetry parameter ! !! aerodp - vertically integrated aer-opt-depth IMAX*NSPC+1 ! ! ! +! errflg - CCPP error flag ! +! errmsg - CCPP error message ! +! ! ! module parameters and constants: ! ! NSWBND - total number of actual sw spectral bands computed ! ! NLWBND - total number of actual lw spectral bands computed ! @@ -4109,7 +4122,7 @@ subroutine optavg_gocart ! nswbnd - total number of sw spectral bands ! ! nlwbnd - total number of lw spectral bands ! ! ! -! external module variables: (in physparam) ! +! external module variables: ! ! laswflg - control flag for sw spectral region ! ! lalwflg - control flag for lw spectral region ! ! ! @@ -4321,7 +4334,7 @@ subroutine aer_property_gocart & ! --- inputs: & ( prsi,prsl,prslk,tvly,rhlay,dz,hz,tracer,aerfld, & - & alon,alat,slmsk, laersw,laerlw, & + & alon,alat,slmsk, laersw,laerlw,con_rd, & & imax,nlay,nlp1, & ! --- outputs: & aerosw,aerolw,aerodp,errflg,errmsg & @@ -4350,6 +4363,7 @@ subroutine aer_property_gocart & ! - logical flag for sw/lw aerosol calculations ! ! IMAX - horizontal dimension of arrays 1 ! ! NLAY,NLP1-vertical dimensions of arrays 1 ! +! con_rd - Physical constant (gas constant for dry air) ! ! ! ! outputs: ! ! aerosw - aeros opt properties for sw IMAX*NLAY*NBDSW*NF_AESW! @@ -4361,6 +4375,8 @@ subroutine aer_property_gocart & ! (:,:,:,2): single scattering albedo ! ! (:,:,:,3): asymmetry parameter ! ! aerodp - vertically integrated aer-opt-depth IMAX*NSPC+1 ! +! errflg - CCPP error flag ! +! errmsg - CCPP error message ! ! ! ! module parameters and constants: ! ! NSWBND - total number of actual sw spectral bands computed ! @@ -4376,7 +4392,7 @@ subroutine aer_property_gocart & ! --- inputs: integer, intent(in) :: IMAX, NLAY, NLP1 logical, intent(in) :: laersw, laerlw - + real (kind=kind_phys), intent(in) :: con_rd real (kind=kind_phys), dimension(:,:), intent(in) :: prsi, prsl, & & prslk, tvly, rhlay, dz, hz real (kind=kind_phys), dimension(:), intent(in) :: alon, alat, & diff --git a/physics/rrtmgp_aerosol_optics.F90 b/physics/rrtmgp_aerosol_optics.F90 index 977594d6c..d53f3ffb8 100644 --- a/physics/rrtmgp_aerosol_optics.F90 +++ b/physics/rrtmgp_aerosol_optics.F90 @@ -26,7 +26,7 @@ module rrtmgp_aerosol_optics !! subroutine rrtmgp_aerosol_optics_run(doSWrad, doLWrad, nCol, nLev, nTracer, nTracerAer, & nDay, idxday, p_lev, p_lay, p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, & - iaermdl, iaerflg, top_at_1, aerodp, sw_optical_props_aerosol, & + iaermdl, iaerflg, top_at_1, con_pi, con_rd, con_g, aerodp, sw_optical_props_aerosol, & lw_optical_props_aerosol, errmsg, errflg ) ! Inputs @@ -43,7 +43,11 @@ subroutine rrtmgp_aerosol_optics_run(doSWrad, doLWrad, nCol, nLev, nTracer, nTra iaermdl, & ! Aerosol model scheme flag iaerflg ! Aerosol effects to include integer,intent(in),dimension(:) :: & - idxday ! Indices for daylit points. + idxday ! Indices for daylit points. + real(kind_phys),intent(in) :: & + con_pi, & ! Physical constant (pi) + con_rd, & ! Physical constant (gas constant for dry-air) + con_g ! Physical constant (gravitational constant) real(kind_phys), dimension(:), intent(in) :: & lon, & ! Longitude lat, & ! Latitude @@ -87,7 +91,7 @@ subroutine rrtmgp_aerosol_optics_run(doSWrad, doLWrad, nCol, nLev, nTracer, nTra ! Call module_radiation_aerosols::setaer(),to setup aerosols property profile call setaer(p_lev*0.01, p_lay*0.01, p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, nCol, nLev, & - nLev+1, .true., .true., iaermdl, iaerflg, top_at_1, aerosolssw2, aerosolslw, aerodp, errflg, errmsg) + nLev+1, .true., .true., iaermdl, iaerflg, top_at_1, con_pi, con_rd, con_g, aerosolssw2, aerosolslw, aerodp, errflg, errmsg) ! Shortwave if (nDay .gt. 0) then diff --git a/physics/rrtmgp_aerosol_optics.meta b/physics/rrtmgp_aerosol_optics.meta index 516943d49..f2fc09be6 100644 --- a/physics/rrtmgp_aerosol_optics.meta +++ b/physics/rrtmgp_aerosol_optics.meta @@ -28,6 +28,30 @@ dimensions = () type = logical intent = in +[con_pi] + standard_name = pi + long_name = ratio of a circle's circumference to its diameter + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rd] + standard_name = gas_constant_of_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in [ncol] standard_name = horizontal_loop_extent long_name = horizontal dimension From 063e15d3f9380416ae04a76424274380f2316660 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Mon, 15 Aug 2022 12:55:02 -0600 Subject: [PATCH 013/380] bug fix in argument list. --- physics/GFS_rrtmgp_setup.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/GFS_rrtmgp_setup.F90 b/physics/GFS_rrtmgp_setup.F90 index b8e5d4fd7..3339d64ae 100644 --- a/physics/GFS_rrtmgp_setup.F90 +++ b/physics/GFS_rrtmgp_setup.F90 @@ -156,7 +156,7 @@ end subroutine GFS_rrtmgp_setup_init !! \htmlinclude GFS_rrtmgp_setup_timestep_init.html !! subroutine GFS_rrtmgp_setup_timestep_init (idate, jdate, deltsw, deltim, lsswr, me, iaermdl,& - iaerflg, aeros_file, slag, sdec, cdec, solcon, errmsg, errflg) + aeros_file, slag, sdec, cdec, solcon, errmsg, errflg) ! Inputs integer, intent(in) :: idate(:) @@ -165,7 +165,7 @@ subroutine GFS_rrtmgp_setup_timestep_init (idate, jdate, deltsw, deltim, lsswr, real(kind_phys), intent(in) :: deltim logical, intent(in) :: lsswr integer, intent(in) :: me - integer, intent(in) :: iaermdl, iaerflg + integer, intent(in) :: iaermdl character(len=26), intent(in) :: aeros_file ! Outputs From 225f5b566a7a96c9782e6dc856f217088106d929 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Mon, 15 Aug 2022 15:10:40 -0600 Subject: [PATCH 014/380] Remove dependency on physcons and physparam in radiation_astronomy.f. Provided as ccpp interstitials. --- physics/GFS_rrtmg_setup.F90 | 50 +++++++++++------------ physics/GFS_rrtmg_setup.meta | 39 ++++++++++++++++++ physics/GFS_rrtmgp_setup.F90 | 23 +++++------ physics/GFS_rrtmgp_setup.meta | 39 ++++++++++++++++++ physics/physparam.f | 19 --------- physics/radiation_astronomy.f | 74 ++++++++++++++++++++--------------- 6 files changed, 159 insertions(+), 85 deletions(-) diff --git a/physics/GFS_rrtmg_setup.F90 b/physics/GFS_rrtmg_setup.F90 index 8fb417f61..1960ff11e 100644 --- a/physics/GFS_rrtmg_setup.F90 +++ b/physics/GFS_rrtmg_setup.F90 @@ -4,7 +4,7 @@ !> \defgroup GFS_rrtmg_setup_mod GFS RRTMG Scheme Setup module GFS_rrtmg_setup - use physparam, only : isolar , ictmflg, ico2flg, ioznflg, icldflg, & + use physparam, only : ictmflg, ico2flg, ioznflg, icldflg, & & iovrRad=>iovr, lcrick , lcnorm , lnoprec, & & isubcsw, isubclw, ivflip , ipsd0, & & iswcliq @@ -41,14 +41,14 @@ module GFS_rrtmg_setup !! \htmlinclude GFS_rrtmg_setup_init.html !! subroutine GFS_rrtmg_setup_init ( & - si, levr, ictm, isol, ico2, iaer, ntcw, & + si, levr, ictm, isol, solar_file, ico2, iaer, ntcw, & num_p3d, npdf3d, ntoz, iovr, isubc_sw, isubc_lw, & icliq_sw, crick_proof, ccnorm, & imp_physics, & norad_precip, idate, iflip, & do_RRTMGP, me, lalw1bd, iaermdl, iaerflg, & aeros_file, con_pi, con_t0c, con_c, con_boltz, & - con_plnk, errmsg, errflg) + con_plnk, con_solr_2008, con_solr_2002, errmsg, errflg) ! ================= subprogram documentation block ================ ! ! ! ! subprogram: GFS_rrtmg_setup_init - a subprogram to initialize radiation ! @@ -169,8 +169,8 @@ subroutine GFS_rrtmg_setup_init ( & integer, intent(in) :: iflip logical, intent(in) :: do_RRTMGP, lalw1bd integer, intent(in) :: me - character(len=26),intent(in) :: aeros_file - real(kind_phys), intent(in) :: con_pi,con_t0c,con_c,con_boltz,con_plnk + character(len=26),intent(in) :: aeros_file, solar_file + real(kind_phys), intent(in) :: con_pi,con_t0c,con_c,con_boltz,con_plnk,con_solr_2008,con_solr_2002 character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg integer, intent(out) :: iaermdl, iaerflg @@ -187,7 +187,6 @@ subroutine GFS_rrtmg_setup_init ( & return end if - isolar = isol ! solar constant control flag ictmflg= ictm ! data ic time/date control flag ico2flg= ico2 ! co2 data source control flag ioznflg= ntoz ! ozone data source control flag @@ -246,7 +245,7 @@ subroutine GFS_rrtmg_setup_init ( & ! --- inputs: & ( si, levr, imp_physics, me, iaermdl, iaerflg, lalw1bd, & & aeros_file, con_pi, con_t0c, con_c, con_boltz, con_plnk, & - & errmsg, errflg ) + & isol, solar_file, con_solr_2008, con_solr_2002, errmsg, errflg ) ! --- outputs: ! ( none ) @@ -267,7 +266,7 @@ end subroutine GFS_rrtmg_setup_init !! subroutine GFS_rrtmg_setup_timestep_init ( & idate, jdate, deltsw, deltim, lsswr, me, iaermdl, & - iaerflg, aeros_file, slag, sdec, cdec, solcon, errmsg, errflg) + iaerflg, isol, aeros_file, slag, sdec, cdec, solcon, con_pi, errmsg, errflg) implicit none @@ -276,9 +275,10 @@ subroutine GFS_rrtmg_setup_timestep_init ( & integer, intent(in) :: jdate(:) real(kind=kind_phys), intent(in) :: deltsw real(kind=kind_phys), intent(in) :: deltim + real(kind=kind_phys), intent(in) :: con_pi logical, intent(in) :: lsswr integer, intent(in) :: me - integer, intent(in) :: iaermdl, iaerflg + integer, intent(in) :: iaermdl, iaerflg, isol character(len=26), intent(in) :: aeros_file real(kind=kind_phys), intent(out) :: slag real(kind=kind_phys), intent(out) :: sdec @@ -299,7 +299,7 @@ subroutine GFS_rrtmg_setup_timestep_init ( & errflg = 0 call radupdate(idate,jdate,deltsw,deltim,lsswr,me,iaermdl,& - iaerflg,aeros_file,slag,sdec,cdec,solcon,errflg,errmsg) + iaerflg,isol,aeros_file,slag,sdec,cdec,solcon,con_pi,errflg,errmsg) end subroutine GFS_rrtmg_setup_timestep_init @@ -330,7 +330,8 @@ end subroutine GFS_rrtmg_setup_finalize subroutine radinit( si, NLAY, imp_physics, me, iaermdl, iaerflg, lalw1bd, & - aeros_file, con_pi, con_t0c, con_c, con_boltz, con_plnk, errmsg, errflg) + aeros_file, con_pi, con_t0c, con_c, con_boltz, con_plnk, isol, & + solar_file, con_solr_2008, con_solr_2002, errmsg, errflg) !................................... ! --- inputs: @@ -443,10 +444,11 @@ subroutine radinit( si, NLAY, imp_physics, me, iaermdl, iaerflg, lalw1bd, & implicit none ! --- inputs: - integer, intent(in) :: NLAY, me, imp_physics, iaermdl, iaerflg + integer, intent(in) :: NLAY, me, imp_physics, iaermdl, iaerflg, isol logical, intent(in) :: lalw1bd - real (kind=kind_phys), intent(in) :: si(:), con_pi,con_t0c, con_c, con_boltz, con_plnk - character(len=26), intent(in) :: aeros_file + real (kind=kind_phys), intent(in) :: si(:), con_pi,con_t0c, con_c, & + con_boltz, con_plnk, con_solr_2008, con_solr_2002 + character(len=26), intent(in) :: aeros_file, solar_file ! --- outputs: (ccpp error handling) character(len=*), intent(out) :: errmsg @@ -469,7 +471,7 @@ subroutine radinit( si, NLAY, imp_physics, me, iaermdl, iaerflg, lalw1bd, & & ' May 01 2007' print *, VTAGRAD !print out version tag print *,' - Selected Control Flag settings: ICTMflg=',ictmflg, & - & ' ISOLar =',isolar, ' ICO2flg=',ico2flg,' IAERflg=',iaerflg, & + & ' ISOLar =',isol, ' ICO2flg=',ico2flg,' IAERflg=',iaerflg, & & ' ICLDflg=',icldflg, & & ' IMP_PHYSICS=',imp_physics,' IOZNflg=',ioznflg print *,' IVFLIP=',ivflip,' IOVR=',iovrRad, & @@ -533,7 +535,7 @@ subroutine radinit( si, NLAY, imp_physics, me, iaermdl, iaerflg, lalw1bd, & !! call module_radsw_main::rswinit() ! Initialization - call sol_init ( me ) ! --- ... astronomy initialization routine + call sol_init ( me, isol, solar_file, con_solr_2008, con_solr_2002, con_pi ) ! --- ... astronomy initialization routine call aer_init ( NLAY, me, iaermdl, iaerflg, lalw1bd, aeros_file, con_pi, & con_t0c, con_c, con_boltz, con_plnk, errflg, errmsg) ! --- ... aerosols initialization routine @@ -573,8 +575,8 @@ end subroutine radinit !> @{ !----------------------------------- subroutine radupdate( idate,jdate,deltsw,deltim,lsswr,me, iaermdl,& - & iaerflg, aeros_file, slag,sdec,cdec,solcon, & - & errflg,errmsg) + & iaerflg, isol, aeros_file, slag,sdec,cdec,solcon, & + & con_pi, errflg,errmsg) !................................... ! ================= subprogram documentation block ================ ! @@ -607,7 +609,7 @@ subroutine radupdate( idate,jdate,deltsw,deltim,lsswr,me, iaermdl,& ! solcon : sun-earth distance adjusted solar constant (w/m2) ! ! ! ! external module variables: ! -! isolar : solar constant cntrl (in module physparam) ! +! iso : solar constant cntrl (in module physparam) ! ! = 0: use the old fixed solar constant in "physcon" ! ! =10: use the new fixed solar constant in "physcon" ! ! = 1: use noaa ann-mean tsi tbl abs-scale with cycle apprx! @@ -642,11 +644,11 @@ subroutine radupdate( idate,jdate,deltsw,deltim,lsswr,me, iaermdl,& implicit none ! --- inputs: - integer, intent(in) :: idate(:), jdate(:), me, iaermdl, iaerflg + integer, intent(in) :: idate(:), jdate(:), me, iaermdl, iaerflg, isol logical, intent(in) :: lsswr character(len=26),intent(in) :: aeros_file - real (kind=kind_phys), intent(in) :: deltsw, deltim + real (kind=kind_phys), intent(in) :: deltsw, deltim, con_pi ! --- outputs: real (kind=kind_phys), intent(out) :: slag, sdec, cdec, solcon @@ -702,12 +704,12 @@ subroutine radupdate( idate,jdate,deltsw,deltim,lsswr,me, iaermdl,& !! time interpolation. if (lsswr) then - if ( isolar == 0 .or. isolar == 10 ) then + if ( isol == 0 .or. isol == 10 ) then lsol_chg = .false. elseif ( iyear0 /= iyear ) then lsol_chg = .true. else - lsol_chg = ( isolar==4 .and. lmon_chg ) + lsol_chg = ( isol==4 .and. lmon_chg ) endif iyear0 = iyear @@ -715,7 +717,7 @@ subroutine radupdate( idate,jdate,deltsw,deltim,lsswr,me, iaermdl,& ! --- inputs: & ( jdate,kyear,deltsw,deltim,lsol_chg, me, & ! --- outputs: - & slag,sdec,cdec,solcon & + & slag,sdec,cdec,solcon,con_pi,errmsg,errflg & & ) endif ! end_if_lsswr_block diff --git a/physics/GFS_rrtmg_setup.meta b/physics/GFS_rrtmg_setup.meta index 6ca7552cc..71f1e2ff7 100644 --- a/physics/GFS_rrtmg_setup.meta +++ b/physics/GFS_rrtmg_setup.meta @@ -37,6 +37,30 @@ dimensions = () type = integer intent = in +[solar_file] + standard_name = solar_constant_file + long_name = external solar constant data table file + units = none + dimensions = () + type = character + kind = len=26 + intent = in +[con_solr_2008] + standard_name = solar_constant_2008 + long_name = solar constant Tim 2008 + units = W m-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_solr_2002] + standard_name = solar_constant_2002 + long_name= solar constant Liu 2002 + units = W m-2 + dimensions = () + type = real + kind = kind_phys + intent = in [ico2] standard_name = control_for_co2 long_name = prescribed global mean value (old opernl) @@ -310,6 +334,13 @@ dimensions = () type = integer intent = in +[isol] + standard_name = control_for_solar_constant + long_name = use prescribed solar constant + units = flag + dimensions = () + type = integer + intent = in [aeros_file] standard_name = aerosol_data_file long_name = aerosol data file @@ -318,6 +349,14 @@ type = character kind = len=26 intent = in +[con_pi] + standard_name = pi + long_name = ratio of a circle's circumference to its diameter + units = none + dimensions = () + type = real + kind = kind_phys + intent = in [slag] standard_name = equation_of_time long_name = equation of time (radian) diff --git a/physics/GFS_rrtmgp_setup.F90 b/physics/GFS_rrtmgp_setup.F90 index 3339d64ae..0cec892ba 100644 --- a/physics/GFS_rrtmgp_setup.F90 +++ b/physics/GFS_rrtmgp_setup.F90 @@ -8,7 +8,7 @@ module GFS_rrtmgp_setup ! use GFS_cloud_diagnostics, only : hml_cloud_diagnostics_initialize ! *NOTE* These parameters below are required radiation_****** modules. They are not ! directly used by the RRTMGP routines. - use physparam, only : isolar, ictmflg, ico2flg, ioznflg, ivflip + use physparam, only : ictmflg, ico2flg, ioznflg, ivflip implicit none public GFS_rrtmgp_setup_init, GFS_rrtmgp_setup_timestep_init, GFS_rrtmgp_setup_finalize @@ -43,7 +43,8 @@ subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires, imp_physics_zhao_carr_pdf, imp_physics_mg, si, levr, ictm, isol, ico2, iaer, & ntcw, num_p3d, ntoz, iovr, isubc_sw, isubc_lw, icliq_sw, crick_proof, ccnorm, & norad_precip, lalw1bd, idate, iflip, me, aeros_file, iaermdl, iaerflg, con_pi, & - con_t0c, con_c, con_boltz, con_plnk, errmsg, errflg) + con_t0c, con_c, con_boltz, con_plnk, solar_file, con_solr_2008, con_solr_2002, & + errmsg, errflg) ! Inputs logical, intent(in) :: do_RRTMGP @@ -57,7 +58,7 @@ subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires, imp_physics_zhao_carr_pdf, & ! Flag for zhao-carr+PDF scheme imp_physics_mg ! Flag for MG scheme real(kind_phys), intent(in) :: & - con_pi, con_t0c, con_c, con_boltz, con_plnk + con_pi, con_t0c, con_c, con_boltz, con_plnk, con_solr_2008, con_solr_2002 real(kind_phys), dimension(:), intent(in) :: & si integer, intent(in) :: levr, ictm, isol, ico2, iaer, & @@ -67,7 +68,7 @@ subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires, crick_proof, ccnorm, norad_precip, lalw1bd integer, intent(in), dimension(:) :: & idate - character(len=26),intent(in) :: aeros_file + character(len=26),intent(in) :: aeros_file, solar_file ! Outputs character(len=*), intent(out) :: errmsg @@ -88,7 +89,6 @@ subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires, end if ! Set radiation parameters - isolar = isol ! solar constant control flag ictmflg = ictm ! data ic time/date control flag ico2flg = ico2 ! co2 data source control flag ioznflg = ntoz ! ozone data source control flag @@ -131,7 +131,7 @@ subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires, monthd = 0 ! Call initialization routines.. - call sol_init ( me ) + call sol_init ( me, isol, solar_file, con_solr_2008, con_solr_2002, con_pi ) call aer_init ( levr, me, iaermdl, iaerflg, lalw1bd, aeros_file, con_pi, con_t0c, & con_c, con_boltz, con_plnk, errflg, errmsg) call gas_init ( me ) @@ -156,16 +156,17 @@ end subroutine GFS_rrtmgp_setup_init !! \htmlinclude GFS_rrtmgp_setup_timestep_init.html !! subroutine GFS_rrtmgp_setup_timestep_init (idate, jdate, deltsw, deltim, lsswr, me, iaermdl,& - aeros_file, slag, sdec, cdec, solcon, errmsg, errflg) + aeros_file, isol, slag, sdec, cdec, solcon, con_pi, errmsg, errflg) ! Inputs integer, intent(in) :: idate(:) integer, intent(in) :: jdate(:) real(kind_phys), intent(in) :: deltsw real(kind_phys), intent(in) :: deltim + real(kind_phys), intent(in) :: con_pi logical, intent(in) :: lsswr integer, intent(in) :: me - integer, intent(in) :: iaermdl + integer, intent(in) :: iaermdl,isol character(len=26), intent(in) :: aeros_file ! Outputs @@ -224,15 +225,15 @@ subroutine GFS_rrtmgp_setup_timestep_init (idate, jdate, deltsw, deltim, lsswr, ! Update solar forcing... if (lsswr) then - if ( isolar == 0 .or. isolar == 10 ) then + if ( isol == 0 .or. isol == 10 ) then lsol_chg = .false. elseif ( iyear0 /= iyear ) then lsol_chg = .true. else - lsol_chg = ( isolar==4 .and. lmon_chg ) + lsol_chg = ( isol==4 .and. lmon_chg ) endif iyear0 = iyear - call sol_update(jdate, kyear, deltsw, deltim, lsol_chg, me, slag, sdec, cdec, solcon) + call sol_update(jdate, kyear, deltsw, deltim, lsol_chg, me, slag, sdec, cdec, solcon, con_pi, errmsg, errflg) endif ! Update aerosols... diff --git a/physics/GFS_rrtmgp_setup.meta b/physics/GFS_rrtmgp_setup.meta index 028495f14..6e8d296e3 100644 --- a/physics/GFS_rrtmgp_setup.meta +++ b/physics/GFS_rrtmgp_setup.meta @@ -101,6 +101,30 @@ dimensions = () type = integer intent = in +[solar_file] + standard_name = solar_constant_file + long_name = external solar constant data table file + units = none + dimensions = () + type = character + kind = len=26 + intent = in +[con_solr_2008] + standard_name = solar_constant_2008 + long_name = solar constant Tim 2008 + units = W m-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_solr_2002] + standard_name = solar_constant_2002 + long_name= solar constant Liu 2002 + units = W m-2 + dimensions = () + type = real + kind = kind_phys + intent = in [ico2] standard_name = control_for_co2 long_name = prescribed global mean value (old opernl) @@ -354,6 +378,21 @@ dimensions = () type = integer intent = in +[isol] + standard_name = control_for_solar_constant + long_name = use prescribed solar constant + units = flag + dimensions = () + type = integer + intent = in +[con_pi] + standard_name = pi + long_name = ratio of a circle's circumference to its diameter + units = none + dimensions = () + type = real + kind = kind_phys + intent = in [slag] standard_name = equation_of_time long_name = equation of time (radian) diff --git a/physics/physparam.f b/physics/physparam.f index b6dd84c99..b84bdd42f 100644 --- a/physics/physparam.f +++ b/physics/physparam.f @@ -125,25 +125,6 @@ module physparam ! (may be adjusted at run time based on namelist input or run condition) !================================================================================== -! ............................................. ! -!>\name 2.1 For module radiation_astronomy -! ............................................. ! - -!> solar constant scheme control flag -!!\n =0:fixed value=1366.0\f$W/m^2\f$(old standard) -!!\n =10:fixed value=1360.8\f$W/m^2\f$(new standard) -!!\n =1:NOAA ABS-scale TSI table (yearly) w 11-yr cycle approx -!!\n =2:NOAA TIM-scale TSI table (yearly) w 11-yr cycle approx -!!\n =3:CMIP5 TIM-scale TSI table (yearly) w 11-yr cycle approx -!!\n =4:CMIP5 TIM-scale TSI table (monthly) w 11-yr cycle approx -!!\n see ISOL in run scripts: Opr GFS=2; Opr CFS=1 - integer, save :: isolar = 0 - -!> external solar constant data table,solarconstant_noaa_a0.txt - character, save :: solar_file*26 -! data solar_file / 'solarconstantdata.txt ' / - data solar_file / 'solarconstant_noaa_a0.txt ' / - ! ............................................. ! !> \name 2.3 For module radiation_gases ! ............................................. ! diff --git a/physics/radiation_astronomy.f b/physics/radiation_astronomy.f index f1651ca84..693274009 100644 --- a/physics/radiation_astronomy.f +++ b/physics/radiation_astronomy.f @@ -21,7 +21,7 @@ ! input: ! ! ( jdate,kyear,deltsw,deltim,lsol_chg, me ) ! ! output: ! -! ( slag,sdec,cdec,solcon ) ! +! ( slag,sdec,cdec,solcon,errmsg,errflg) ! ! ! ! 'coszmn' -- compute cosin of zenith angles ! ! input: ! @@ -29,11 +29,6 @@ ! output: ! ! ( coszen,coszdg ) ! ! ! -! ! -! external modules referenced: ! -! 'module physparam' in 'physparam.f' ! -! 'module physcons' in 'physcons.f' ! -! ! ! program history log: ! ! - a collection of programs to track solar-earth position ! ! may 1977 --- ray orzol (gfdl) created program compjd to ! @@ -93,8 +88,7 @@ !> This module sets up astronomy quantities for solar radiation calculations. module module_radiation_astronomy ! - use physparam, only : isolar, solar_file, kind_phys - use physcons, only : con_solr, con_solr_old, con_pi + use machine, only : kind_phys use module_iounitdef, only : NIRADSF ! implicit none @@ -107,17 +101,17 @@ module module_radiation_astronomy ! & VTAGAST='NCEP-Radiation_astronomy v5.1 Nov 2012 ' ! Parameter constants - real (kind=kind_phys), parameter :: degrad = 180.0/con_pi - real (kind=kind_phys), parameter :: tpi = 2.0 * con_pi - real (kind=kind_phys), parameter :: hpi = 0.5 * con_pi + real (kind=kind_phys) :: degrad + real (kind=kind_phys) :: tpi + real (kind=kind_phys) :: hpi + real (kind=kind_phys) :: pid12 real (kind=kind_phys), parameter :: f12 = 12.0 real (kind=kind_phys), parameter :: f3600 = 3600.0 real (kind=kind_phys), parameter :: czlimt = 0.0001 ! ~ cos(89.99427) - real (kind=kind_phys), parameter :: pid12 = con_pi/f12 ! angle per hour ! real (kind=kind_phys), parameter :: pid12 = (2.0*asin(1.0))/f12 ! Module variable (to be set in module_radiation_astronomy::sol_init): - real (kind=kind_phys), public :: solc0 = con_solr + real (kind=kind_phys), public :: solc0 integer :: isolflg = 10 character(26) :: solar_fname = ' ' @@ -133,7 +127,6 @@ module module_radiation_astronomy real (kind=kind_phys) :: anginc=0.0 ! saved monthly solar constants (isolflg=4 only) real (kind=kind_phys) :: smon_sav(12) - data smon_sav(1:12) / 12*con_solr / ! saved year of data used integer :: iyr_sav =0 @@ -154,7 +147,7 @@ module module_radiation_astronomy !>\section sol_init_gen sol_init General Algorithm !! @{ subroutine sol_init & - & ( me ) ! --- inputs + & ( me, isolar, solar_file, con_solr, con_solr_old, con_pi ) ! --- inputs ! --- outputs: ( none ) ! =================================================================== ! @@ -163,18 +156,16 @@ subroutine sol_init & ! ! ! inputs: ! ! me - print message control flag ! -! ! -! outputs: (to module variable) ! -! ( none ) ! -! ! -! external module variable: (in physparam) ! -! isolar - = 0: use the old fixed solar constant in "physcon" ! -! =10: use the new fixed solar constant in "physcon" ! +! isolar - = 0: use the old fixed solar constant in "GFS_typedefs" ! +! =10: use the new fixed solar constant in "GFS_typedefs" ! ! = 1: use noaa ann-mean tsi tbl abs-scale with cyc apprx ! ! = 2: use noaa ann-mean tsi tbl tim-scale with cyc apprx ! ! = 3: use cmip5 ann-mean tsi tbl tim-scale with cyc apprx! ! = 4: use cmip5 mon-mean tsi tbl tim-scale with cyc apprx! -! solar_file- external solar constant data table ! +! solar_file - external solar constant data table ! +! ! +! outputs: (to module variable) ! +! ( none ) ! ! ! ! internal module variable: ! ! isolflg - internal solar constant scheme control flag ! @@ -191,23 +182,33 @@ subroutine sol_init & implicit none ! --- input: - integer, intent(in) :: me - + integer, intent(in) :: me, isolar + character(len=26), intent(in) :: solar_file + real(kind=kind_phys), intent(in) :: con_solr, con_solr_old, con_pi ! --- output: ( none ) ! --- local: logical :: file_exist + integer :: imonth ! !===> ... begin here ! if ( me == 0 ) print *, VTAGAST !print out version tag + degrad = 180.0/con_pi + tpi = 2.0 * con_pi + hpi = 0.5 * con_pi + pid12 = con_pi/f12 + ! --- initialization isolflg = isolar solc0 = con_solr solar_fname = solar_file iyr_sav = 0 nstp = 6 + do imonth = 1,12 + smon_sav(imonth) = con_solr + enddo if ( isolar == 0 ) then solc0 = con_solr_old @@ -331,7 +332,7 @@ end subroutine sol_init !----------------------------------- subroutine sol_update & & ( jdate,kyear,deltsw,deltim,lsol_chg, me, & ! --- inputs - & slag, sdec, cdec, solcon & ! --- outputs + & slag, sdec, cdec, solcon, con_pi, errmsg, errflg & ! --- outputs & ) ! =================================================================== ! @@ -353,6 +354,8 @@ subroutine sol_update & ! slag - equation of time in radians ! ! sdec, cdec - sin and cos of the solar declination angle ! ! solcon - sun-earth distance adjusted solar constant (w/m2) ! +! errmsg - CCPP error message ! +! errflg - CCPP error flag ! ! ! ! ! ! module variable: ! @@ -386,10 +389,12 @@ subroutine sol_update & integer, intent(in) :: jdate(:), kyear, me logical, intent(in) :: lsol_chg - real (kind=kind_phys), intent(in) :: deltsw, deltim + real (kind=kind_phys), intent(in) :: deltsw, deltim, con_pi ! --- output: real (kind=kind_phys), intent(out) :: slag, sdec, cdec, solcon + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg ! --- locals: real (kind=kind_phys), parameter :: hrday = 1.0/24.0 ! frc day/hour @@ -408,6 +413,10 @@ subroutine sol_update & ! !===> ... begin here ! +! Initialize the CCPP error handling variables + errmsg = '' + errflg = 0 + ! --- ... forecast time iyear = jdate(1) imon = jdate(2) @@ -430,7 +439,10 @@ subroutine sol_update & inquire (file=solar_fname, exist=file_exist) if ( .not. file_exist ) then print *,' !!! ERROR! Can not find solar constant file!!!' - stop + errflg = 1 + errmsg = "ERROR(radiation_astronomy): solar constant file"//& + & " not found" + return else iyr = iyear @@ -585,7 +597,7 @@ subroutine sol_update & !> -# Call solar() call solar & ! --- inputs: - & ( jd, fjd, & + & ( jd, fjd, con_pi, & ! --- outputs: & r1, dlt, alp & & ) @@ -652,7 +664,7 @@ end subroutine sol_update !! @{ !----------------------------------- subroutine solar & - & ( jd, fjd, & ! --- inputs + & ( jd, fjd, con_pi, & ! --- inputs & r1, dlt, alp & ! --- outputs & ) @@ -684,7 +696,7 @@ subroutine solar & implicit none ! --- inputs: - real (kind=kind_phys), intent(in) :: fjd + real (kind=kind_phys), intent(in) :: fjd, con_pi integer, intent(in) :: jd ! --- outputs: From da57e02e35d74e14993360d3ce4ddcc7aec470cb Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Mon, 15 Aug 2022 16:22:52 -0600 Subject: [PATCH 015/380] Replaced stop statements with ccpp error handling --- physics/GFS_phys_time_vary.fv3.F90 | 2 +- physics/GFS_phys_time_vary.scm.F90 | 2 +- physics/GFS_rrtmg_setup.F90 | 6 +-- physics/GFS_rrtmgp_setup.F90 | 4 +- physics/cires_ugwpv1_oro.F90 | 4 +- physics/lsm_noah.f | 5 +- physics/noahmpdrv.F90 | 2 +- physics/radiation_clouds.f | 30 +++++++---- physics/radiation_gases.f | 87 ++++++++++++++++++++---------- physics/set_soilveg.f | 22 +++++--- physics/sfc_diff.f | 4 +- physics/sflx.f | 36 ++++++++++--- 12 files changed, 138 insertions(+), 66 deletions(-) diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index 2803212b7..e3d95e5a3 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -288,7 +288,7 @@ subroutine GFS_phys_time_vary_init ( !$OMP section !> - Initialize soil vegetation (needed for sncovr calculation further down) - call set_soilveg(me, isot, ivegsrc, nlunit) + call set_soilveg(me, isot, ivegsrc, nlunit, errmsg, errflg) !$OMP end sections diff --git a/physics/GFS_phys_time_vary.scm.F90 b/physics/GFS_phys_time_vary.scm.F90 index c70e3232a..74b34e974 100644 --- a/physics/GFS_phys_time_vary.scm.F90 +++ b/physics/GFS_phys_time_vary.scm.F90 @@ -264,7 +264,7 @@ subroutine GFS_phys_time_vary_init ( endif !> - Initialize soil vegetation (needed for sncovr calculation further down) - call set_soilveg(me, isot, ivegsrc, nlunit) + call set_soilveg(me, isot, ivegsrc, nlunit, errmsg, errflg) !> - Call setindxoz() to initialize ozone data if (ntoz > 0) then diff --git a/physics/GFS_rrtmg_setup.F90 b/physics/GFS_rrtmg_setup.F90 index 1960ff11e..331ecbd1e 100644 --- a/physics/GFS_rrtmg_setup.F90 +++ b/physics/GFS_rrtmg_setup.F90 @@ -540,9 +540,9 @@ subroutine radinit( si, NLAY, imp_physics, me, iaermdl, iaerflg, lalw1bd, & call aer_init ( NLAY, me, iaermdl, iaerflg, lalw1bd, aeros_file, con_pi, & con_t0c, con_c, con_boltz, con_plnk, errflg, errmsg) ! --- ... aerosols initialization routine - call gas_init ( me ) ! --- ... co2 and other gases initialization routine + call gas_init ( me, errflg, errmsg ) ! --- ... co2 and other gases initialization routine - call cld_init ( si, NLAY, imp_physics, me) ! --- ... cloud initialization routine + call cld_init ( si, NLAY, imp_physics, me, errflg, errmsg) ! --- ... cloud initialization routine call rlwinit ( me ) ! --- ... lw radiation initialization routine @@ -737,7 +737,7 @@ subroutine radupdate( idate,jdate,deltsw,deltim,lsswr,me, iaermdl,& lco2_chg = .false. endif - call gas_update ( kyear,kmon,kday,khour,loz1st,lco2_chg, me ) + call gas_update ( kyear,kmon,kday,khour,loz1st,lco2_chg, me, errflg, errmsg ) if ( loz1st ) loz1st = .false. diff --git a/physics/GFS_rrtmgp_setup.F90 b/physics/GFS_rrtmgp_setup.F90 index 0cec892ba..517e88d85 100644 --- a/physics/GFS_rrtmgp_setup.F90 +++ b/physics/GFS_rrtmgp_setup.F90 @@ -134,7 +134,7 @@ subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires, call sol_init ( me, isol, solar_file, con_solr_2008, con_solr_2002, con_pi ) call aer_init ( levr, me, iaermdl, iaerflg, lalw1bd, aeros_file, con_pi, con_t0c, & con_c, con_boltz, con_plnk, errflg, errmsg) - call gas_init ( me ) + call gas_init ( me, errflg, errmsg ) !call hml_cloud_diagnostics_initialize(imp_physics, imp_physics_fer_hires, & ! imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, & ! imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, imp_physics_mg, levr, me, si,& @@ -248,7 +248,7 @@ subroutine GFS_rrtmgp_setup_timestep_init (idate, jdate, deltsw, deltim, lsswr, else lco2_chg = .false. endif - call gas_update (kyear, kmon, kday, khour, loz1st, lco2_chg, me ) + call gas_update (kyear, kmon, kday, khour, loz1st, lco2_chg, me, errflg, errmsg ) if ( loz1st ) loz1st = .false. diff --git a/physics/cires_ugwpv1_oro.F90 b/physics/cires_ugwpv1_oro.F90 index 959bbd6c5..7e050fc83 100644 --- a/physics/cires_ugwpv1_oro.F90 +++ b/physics/cires_ugwpv1_oro.F90 @@ -999,7 +999,9 @@ subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & ! enddo print * - stop + errflg = 1 + errmsg = 'ERROR(orogw_v1): ' + return endif endif diff --git a/physics/lsm_noah.f b/physics/lsm_noah.f index 7a8e17bf8..d99b9d39d 100644 --- a/physics/lsm_noah.f +++ b/physics/lsm_noah.f @@ -62,7 +62,7 @@ subroutine lsm_noah_init(lsm, lsm_noah, me, isot, ivegsrc, nlunit, end if !--- initialize soil vegetation - call set_soilveg(me, isot, ivegsrc, nlunit) + call set_soilveg(me, isot, ivegsrc, nlunit, errmsg, errflg) pores (:) = maxsmc (:) resid (:) = drysmc (:) @@ -544,7 +544,8 @@ subroutine lsm_noah_run & & edir, et, ett, esnow, drip, dew, beta, etp, ssoil, & & flx1, flx2, flx3, runoff1, runoff2, runoff3, & & snomlt, sncovr, rc, pc, rsmin, xlai, rcs, rct, rcq, & - & rcsoil, soilw, soilm, smcwlt, smcdry, smcref, smcmax) + & rcsoil, soilw, soilm, smcwlt, smcdry, smcref, smcmax, & + & errmsg, errflg ) !> - Noah LSM: prepare variables for return to parent model and unit conversion. !> - 6. output (o): diff --git a/physics/noahmpdrv.F90 b/physics/noahmpdrv.F90 index a4f5b5226..faa6eb5d7 100644 --- a/physics/noahmpdrv.F90 +++ b/physics/noahmpdrv.F90 @@ -93,7 +93,7 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, me, isot, ivegsrc, & !--- initialize soil vegetation - call set_soilveg(me, isot, ivegsrc, nlunit) + call set_soilveg(me, isot, ivegsrc, nlunit, errmsg, errflg) ! initialize psih and psim diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index 16ea93d26..d77b39735 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -16,7 +16,7 @@ ! inputs: ! ! ( si, NLAY, imp_physics, me ) ! ! outputs: ! -! ( none ) ! +! ( errflg, errmsg ) ! ! ! ! 'radiation_clouds_prop' --- radiation cloud properties ! ! obtained from various cloud schemes ! @@ -278,10 +278,7 @@ module module_radiation_clouds !>\section cld_init General Algorithm !! @{ subroutine cld_init & - & ( si, NLAY, imp_physics, me ) ! --- inputs -! --- outputs: -! ( none ) - + & ( si, NLAY, imp_physics, me, errflg, errmsg ) ! =================================================================== ! ! ! ! abstract: cld_init is an initialization program for cloud-radiation ! @@ -294,8 +291,9 @@ subroutine cld_init & ! imp_physics : MP identifier ! ! me : print control flag ! ! ! -! outputs: (none) ! -! to module variables ! +! outputs: ! +! errflg : CCPP error flag ! +! errmsg : CCPP error message ! ! ! ! external module variables: (in physparam) ! ! icldflg : cloud optical property scheme control flag ! @@ -331,7 +329,9 @@ subroutine cld_init & real (kind=kind_phys), intent(in) :: si(:) -! --- outputs: (none) +! --- outputs: + integer, intent(out) :: errflg + character(len=*), intent(out) :: errmsg ! --- locals: integer :: k, kl, ier @@ -339,14 +339,20 @@ subroutine cld_init & ! !===> ... begin here ! +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! --- set up module variables if (me == 0) print *, VTAGCLD !print out version tag if ( icldflg == 0 ) then print *,' - Diagnostic Cloud Method has been discontinued' - stop - + errflg = 1 + errmsg = 'ERROR(cld_init): Diagnostic Cloud Method has been '// & + & 'discontinued' + return else if (me == 0) then print *,' - Using Prognostic Cloud Method' @@ -369,6 +375,10 @@ subroutine cld_init & else print *,' !!! ERROR in cloud microphysc specification!!!', & & ' imp_physics (NP3D) =',imp_physics + errflg = 1 + errmsg = 'ERROR(cld_init): cloud mp specification is not'// & + & ' valid' + return stop endif endif diff --git a/physics/radiation_gases.f b/physics/radiation_gases.f index 157da8e09..d015c1ac9 100644 --- a/physics/radiation_gases.f +++ b/physics/radiation_gases.f @@ -19,13 +19,13 @@ ! input: ! ! ( me ) ! ! output: ! -! ( none ) ! +! ( errflg, errmsg ) ! ! ! ! 'gas_update' -- read in data and update with time ! ! input: ! ! ( iyear, imon, iday, ihour, loz1st, ldoco2, me ) ! ! output: ! -! ( none ) ! +! ( errflg, errmsg ) ! ! ! ! 'getozn' -- setup climatological ozone profile ! ! input: ! @@ -232,8 +232,7 @@ module module_radiation_gases !! @{ !----------------------------------- subroutine gas_init & - & ( me )! --- inputs: -! --- outputs: ( none ) + & ( me , errflg, errmsg) ! =================================================================== ! ! ! @@ -243,8 +242,8 @@ subroutine gas_init & ! inputs: dimemsion ! ! me - print message control flag 1 ! ! ! -! outputs: (to the module variables) ! -! ( none ) ! +! outputs: (CCPP error handling) ! +! (errflg, errmsg) ! ! ! ! external module variables: (in physparam) ! ! ico2flg - co2 data source control flag ! @@ -285,7 +284,9 @@ subroutine gas_init & ! --- inputs: integer, intent(in) :: me -! --- output: ( none ) +! --- output: + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg ! --- locals: real (kind=kind_phys), dimension(IMXCO2,JMXCO2) :: co2dat @@ -301,6 +302,11 @@ subroutine gas_init & ! !===> ... begin here ! + +! Initialize the CCPP error handling variables + errmsg = '' + errflg = 0 + if ( me == 0 ) print *, VTAGGAS ! print out version tag kyrsav = 0 @@ -317,7 +323,10 @@ subroutine gas_init & print *,' - Using climatology ozone distribution' print *,' timeozc=',timeozc, ' is not monthly mean', & & ' - job aborting in subroutin gas_init!!!' - stop + errflg = 1 + errmsg = 'ERROR(gas_init): Climatological o3 distribution '// & + & 'is not monthly mean' + return endif allocate (pkstr(LOZ), o3r(JMR,LOZ,12)) @@ -392,9 +401,10 @@ subroutine gas_init & inquire (file=co2usr_file, exist=file_exist) if ( .not. file_exist ) then - print *,' Can not find user CO2 data file: ',co2usr_file, & - & ' - Stopped in subroutine gas_init !!' - stop + print *,' Can not find user CO2 data file: ',co2usr_file + errflg = 1 + errmsg = 'ERROR(gas_init): Can not find user CO2 data file' + return else close (NICO2CN) open(NICO2CN,file=co2usr_file,form='formatted',status='old') @@ -435,9 +445,10 @@ subroutine gas_init & enddo endif else - print *,' ICO2=',ico2flg,' is not a valid selection', & - & ' - Stoped in subroutine gas_init!!!' - stop + print *,' ICO2=',ico2flg,' is not a valid selection' + errflg = 1 + errmsg = 'ERROR(gas_init): ICO2 is not valid' + return endif ! endif_ico2flg_block close (NICO2CN) @@ -456,9 +467,10 @@ subroutine gas_init & print *,' - Using observed co2 monthly 2-d data' endif else - print *,' ICO2=',ico2flg,' is not a valid selection', & - & ' - Stoped in subroutine gas_init!!!' - stop + print *,' ICO2=',ico2flg,' is not a valid selection' + errflg = 1 + errmsg = 'ERROR(gas_init): ICO2 is not valid' + return endif if ( ictmflg == -2 ) then @@ -466,9 +478,12 @@ subroutine gas_init & if ( .not. file_exist ) then if ( me == 0 ) then print *,' Can not find seasonal cycle CO2 data: ', & - & co2cyc_file,' - Stopped in subroutine gas_init !!' + & co2cyc_file endif - stop + errflg = 1 + errmsg = 'ERROR(gas_init): Can not find seasonal cycle '//& + & 'CO2 data' + return else allocate( co2cyc_sav(IMXCO2,JMXCO2,12) ) @@ -531,8 +546,8 @@ end subroutine gas_init !! @{ !----------------------------------- subroutine gas_update & - & ( iyear, imon, iday, ihour, loz1st, ldoco2, me )! --- inputs -! --- outputs: ( none ) + & ( iyear, imon, iday, ihour, loz1st, ldoco2, me, & + & errflg, errmsg ) ! =================================================================== ! ! ! @@ -549,7 +564,8 @@ subroutine gas_update & ! me - print message control flag 1 ! ! ! ! outputs: (to the module variables) ! -! ( none ) ! +! errflg - CCPP error flag ! +! errmsg - CCPP error message ! ! ! ! external module variables: (in physparam) ! ! ico2flg - co2 data source control flag ! @@ -597,7 +613,9 @@ subroutine gas_update & logical, intent(in) :: loz1st, ldoco2 -! --- output: ( none ) +! --- output: + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg ! --- locals: real (kind=kind_phys), dimension(IMXCO2,JMXCO2) :: co2dat, co2ann @@ -614,6 +632,10 @@ subroutine gas_update & ! !===> ... begin here ! +! Initialize the CCPP error handling variables + errmsg = '' + errflg = 0 + !> - Ozone data section if ( ioznflg == 0 ) then @@ -684,8 +706,11 @@ subroutine gas_update & inquire (file=co2gbl_file, exist=file_exist) if ( .not. file_exist ) then print *,' Requested co2 data file "',co2gbl_file, & - & '" not found - Stopped in subroutine gas_update!!' - stop + & '" not found' + errflg = 1 + errmsg = 'ERROR(gas_update): Requested co2 data file not '// & + & 'found' + return else close(NICO2CN) open (NICO2CN,file=co2gbl_file,form='formatted',status='old') @@ -752,9 +777,11 @@ subroutine gas_update & if ( me == 0 ) then print *,' Specified co2 data for year',idyr, & & ' not found !! Need to change namelist ICTM !!' - print *,' *** Stopped in subroutine gas_update !!' endif - stop + errflg = 1 + errmsg = 'ERROR(gas_update): Specified co2 data for year '//& + & 'not found' + return else Lab_if_ictm ! looking for latest available data if ( me == 0 ) then print *,' Requested co2 data for year',idyr, & @@ -778,9 +805,11 @@ subroutine gas_update & if ( .not. file_exist ) then if ( me == 0 ) then print *,' Can not find co2 data source file' - print *,' *** Stopped in subroutine gas_update !!' endif - stop + errflg = 1 + errmsg = 'ERROR(gas_update): Can not find co2 data '// & + & 'source file' + return endif endif Lab_if_ictm endif ! end if_file_exist_block diff --git a/physics/set_soilveg.f b/physics/set_soilveg.f index efef0f24b..37f2c2a73 100644 --- a/physics/set_soilveg.f +++ b/physics/set_soilveg.f @@ -13,11 +13,13 @@ module set_soilveg_mod !> \ingroup Noah_LSM !! This subroutine initializes soil and vegetation. - subroutine set_soilveg(me,isot,ivet,nlunit) + subroutine set_soilveg(me,isot,ivet,nlunit,errmsg,errflg) use namelist_soilveg implicit none integer, intent(in) :: me,isot,ivet,nlunit + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg !my begin locals !for 20 igbp veg type and 19 stasgo soil type integer i @@ -385,16 +387,22 @@ subroutine set_soilveg(me,isot,ivet,nlunit) ! CLOSE(59) IF (DEFINED_SOIL .GT. MAX_SOILTYP) THEN - WRITE(0,*) 'Warning: DEFINED_SOIL too large in namelist' - STOP 222 + errflg = 222 + errmsg = 'ERROR(set_soilveg): DEFINED_SOIL too large in '// & + & 'namelist' + return ENDIF IF (DEFINED_VEG .GT. MAX_VEGTYP) THEN - WRITE(0,*) 'Warning: DEFINED_VEG too large in namelist' - STOP 222 + errflg = 222 + errmsg = 'ERROR(set_soilveg): DEFINED_VEG too large in '// & + & 'namelist' + return ENDIF IF (DEFINED_SLOPE .GT. MAX_SLOPETYP) THEN - WRITE(0,*) 'Warning: DEFINED_SLOPE too large in namelist' - STOP 222 + errflg = 222 + errmsg = 'ERROR(set_soilveg): DEFINED_SLOPE too large in '//& + & 'namelist' + return ENDIF SMLOW = SMLOW_DATA diff --git a/physics/sfc_diff.f b/physics/sfc_diff.f index 59c6d2d60..150735106 100644 --- a/physics/sfc_diff.f +++ b/physics/sfc_diff.f @@ -383,7 +383,9 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) call znot_t_v7(wind10m, ztmax_wat(i)) ! 10-m wind,m/s, ztmax(m) else if (sfc_z0_type > 0) then write(0,*)'no option for sfc_z0_type=',sfc_z0_type - stop + errflg = 1 + errmsg = 'ERROR(sfc_diff_run): no option for sfc_z0_type' + return endif ! call stability diff --git a/physics/sflx.f b/physics/sflx.f index 026e2b854..cd1adfe75 100644 --- a/physics/sflx.f +++ b/physics/sflx.f @@ -124,7 +124,8 @@ subroutine gfssflx &! --- input & edir, et, ett, esnow, drip, dew, beta, etp, ssoil, & & flx1, flx2, flx3, runoff1, runoff2, runoff3, & & snomlt, sncovr, rc, pc, rsmin, xlai, rcs, rct, rcq, & - & rcsoil, soilw, soilm, smcwlt, smcdry, smcref, smcmax) + & rcsoil, soilw, soilm, smcwlt, smcdry, smcref, smcmax, & + & errmsg, errflg ) ! ===================================================================== ! ! description: ! @@ -328,6 +329,8 @@ subroutine gfssflx &! --- input & runoff1, runoff2, runoff3, rc, pc, rsmin, xlai, rcs, & & rct, rcq, rcsoil, soilw, soilm, smcwlt, smcdry, smcref, & & smcmax + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg ! --- locals: ! real (kind=kind_phys) :: df1h, @@ -347,6 +350,10 @@ subroutine gfssflx &! --- input ! !===> ... begin here ! +! Initialize CCPP error-handling + errflg = 0 + errmsg = '' + ! --- ... initialization runoff1 = 0.0 @@ -412,7 +419,7 @@ subroutine gfssflx &! --- input !> - Call redprm() to set the land-surface paramters, !! including soil-type and veg-type dependent parameters. - call redprm + call redprm(errmsg, errflg) if(ivegsrc == 1) then !only igbp type has urban !urban @@ -1673,7 +1680,7 @@ end subroutine penman !> This subroutine internally sets default values or optionally read-in !! via namelist i/o, all soil and vegetation parateters requied for the execusion !! of the Noah LSM. - subroutine redprm + subroutine redprm(errmsg, errflg) !................................... ! --- inputs: ! & ( nsoil, vegtyp, soiltyp, slopetyp, sldpth, zsoil, & @@ -1860,7 +1867,8 @@ subroutine redprm ! & frzx, psisat, slope, snup, salp, bexp, dksat, dwsat, & ! & smcmax, smcwlt, smcref, smcdry, f1, quartz, fxexp, z0, & ! & czil, xlai, csoil, rtdis(nsoil) - + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg ! integer, intent(out) :: nroot ! --- locals: @@ -1871,20 +1879,30 @@ subroutine redprm ! !===> ... begin here ! +! Initialize CCPP error-handling + errflg = 0 + errmsg = '' + if (soiltyp > defined_soil) then write(*,*) 'warning: too many soil types,soiltyp=',soiltyp, & & 'defined_soil=',defined_soil - stop 333 + errflg = 1 + errmsg = 'ERROR(sflx.f): too many soil types' + return endif if (vegtyp > defined_veg) then write(*,*) 'warning: too many veg types' - stop 333 + errflg = 1 + errmsg = 'ERROR(sflx.f): too many veg types' + return endif if (slopetyp > defined_slope) then write(*,*) 'warning: too many slope types' - stop 333 + errflg = 1 + errmsg = 'ERROR(sflx.f): too many slope types' + return endif ! --- ... set-up universal parameters (not dependent on soiltyp, vegtyp @@ -1941,7 +1959,9 @@ subroutine redprm if (nroot > nsoil) then write(*,*) 'warning: too many root layers' - stop 333 + errflg = 1 + errmsg = 'ERROR(sflx.f): too many root layers' + return endif ! --- ... calculate root distribution. present version assumes uniform From 1dbed67e964bf108ac4f5c7b8544497fad074973 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Tue, 16 Aug 2022 11:31:22 -0600 Subject: [PATCH 016/380] Replaced all remaing stop statements with ccpp error handling. --- physics/GFS_phys_time_vary.fv3.F90 | 2 +- physics/GFS_rrtmg_setup.F90 | 30 +++++++++++++------------ physics/gcycle.F90 | 14 ++++++++++-- physics/gfdl_cloud_microphys.F90 | 2 +- physics/gfdl_sfc_layer.F90 | 6 ++--- physics/lsm_ruc.F90 | 8 ++++--- physics/m_micro.F90 | 4 +++- physics/module_SF_JSFC.F90 | 23 +++++++++++++++---- physics/module_gfdl_cloud_microphys.F90 | 13 +++++++++-- physics/module_sf_exchcoef.f90 | 13 +++++++++-- physics/module_sf_mynn.F90 | 21 ++++++++++++++--- physics/module_sf_ruclsm.F90 | 29 +++++++++++++++++------- physics/radiation_clouds.f | 1 - physics/radlw_main.F90 | 28 +++++++++++++++++------ physics/radsw_main.F90 | 23 ++++++++++++++----- physics/set_soilveg_ruc.F90 | 20 +++++++++++++---- 16 files changed, 176 insertions(+), 61 deletions(-) diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index e3d95e5a3..8ffd56b0e 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -901,7 +901,7 @@ subroutine GFS_phys_time_vary_timestep_init ( tsfco, tisfc, hice, fice, facsf, facwf, alvsf, alvwf, alnsf, alnwf, & zorli, zorll, zorlo, weasd, slope, snoalb, canopy, vfrac, vtype, & stype, shdmin, shdmax, snowd, cv, cvb, cvt, oro, oro_uf, & - xlat_d, xlon_d, slmsk, imap, jmap) + xlat_d, xlon_d, slmsk, imap, jmap, errmsg, errflg) endif endif diff --git a/physics/GFS_rrtmg_setup.F90 b/physics/GFS_rrtmg_setup.F90 index 331ecbd1e..eb6a94578 100644 --- a/physics/GFS_rrtmg_setup.F90 +++ b/physics/GFS_rrtmg_setup.F90 @@ -199,7 +199,9 @@ subroutine GFS_rrtmg_setup_init ( & iaermdl = iaer/1000 ! control flag for aerosol scheme selection if ( iaermdl < 0 .or. (iaermdl>2 .and. iaermdl/=5) ) then print *, ' Error -- IAER flag is incorrect, Abort' - stop 7777 + errflg = 1 + errmsg = 'ERROR(GFS_rrtmg_setup): IAER flag is incorrect' + return endif ! if ( ntcw > 0 ) then @@ -496,7 +498,9 @@ subroutine radinit( si, NLAY, imp_physics, me, iaermdl, iaerflg, lalw1bd, & else print *,' - ERROR!!! ISUBCLW=',isubclw,' is not a ', & & 'valid option ' - stop + errflg = 1 + errmsg = 'ERROR(GFS_rrtmg_setup): ISUBCLW flag is invalid' + return endif if ( isubcsw == 0 ) then @@ -511,7 +515,9 @@ subroutine radinit( si, NLAY, imp_physics, me, iaermdl, iaerflg, lalw1bd, & else print *,' - ERROR!!! ISUBCSW=',isubcsw,' is not a ', & & 'valid option ' - stop + errflg = 1 + errmsg = 'ERROR(GFS_rrtmg_setup): ISUBCSW flag is invalid' + return endif if ( isubcsw /= isubclw ) then @@ -535,18 +541,14 @@ subroutine radinit( si, NLAY, imp_physics, me, iaermdl, iaerflg, lalw1bd, & !! call module_radsw_main::rswinit() ! Initialization - call sol_init ( me, isol, solar_file, con_solr_2008, con_solr_2002, con_pi ) ! --- ... astronomy initialization routine - + call sol_init ( me, isol, solar_file, con_solr_2008, con_solr_2002,& + con_pi ) ! astronomy initialization routine call aer_init ( NLAY, me, iaermdl, iaerflg, lalw1bd, aeros_file, con_pi, & - con_t0c, con_c, con_boltz, con_plnk, errflg, errmsg) ! --- ... aerosols initialization routine - - call gas_init ( me, errflg, errmsg ) ! --- ... co2 and other gases initialization routine - - call cld_init ( si, NLAY, imp_physics, me, errflg, errmsg) ! --- ... cloud initialization routine - - call rlwinit ( me ) ! --- ... lw radiation initialization routine - - call rswinit ( me ) ! --- ... sw radiation initialization routine + con_t0c, con_c, con_boltz, con_plnk, errflg, errmsg) ! aerosols initialization routine + call gas_init ( me, errflg, errmsg ) ! co2 and other gases initialization routine + call cld_init ( si, NLAY, imp_physics, me, errflg, errmsg) ! cloud initialization routine + call rlwinit ( me, errflg, errmsg ) ! lw RRTMG initialization routine + call rswinit ( me, errflg, errmsg ) ! sw RRTMG initialization routine ! return ! diff --git a/physics/gcycle.F90 b/physics/gcycle.F90 index 7e301c480..16e446b27 100644 --- a/physics/gcycle.F90 +++ b/physics/gcycle.F90 @@ -22,7 +22,7 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, fn_nml, tsfco, tisfc, hice, fice, facsf, facwf, alvsf, alvwf, alnsf, alnwf, & zorli, zorll, zorlo, weasd, slope, snoalb, canopy, vfrac, vtype, & stype, shdmin, shdmax, snowd, cv, cvb, cvt, oro, oro_uf, & - xlat_d, xlon_d, slmsk, imap, jmap) + xlat_d, xlon_d, slmsk, imap, jmap, errmsg, errflg) ! ! use machine, only: kind_phys, kind_io8 @@ -78,6 +78,9 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, fn_nml, slope(:) integer, intent(in) :: imap(:), jmap(:) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + ! ! Local variables ! --------------- @@ -104,6 +107,11 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, fn_nml, real(kind=kind_phys) :: sig1t integer :: npts, nb, ix, jx, ls, ios, ll logical :: exists + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! !@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ ! @@ -214,7 +222,9 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, fn_nml, inquire (file=trim(fn_nml),exist=exists) if (.not. exists) then write(6,*) 'gcycle:: namelist file: ',trim(fn_nml),' does not exist' - stop + errflg = 1 + errmsg = 'ERROR(gcycle): namelist file: ',trim(fn_nml),' does not exist.' + return else open (unit=nlunit, file=trim(fn_nml), action='READ', status='OLD', iostat=ios) rewind (nlunit) diff --git a/physics/gfdl_cloud_microphys.F90 b/physics/gfdl_cloud_microphys.F90 index 309cbac92..e2c71c960 100644 --- a/physics/gfdl_cloud_microphys.F90 +++ b/physics/gfdl_cloud_microphys.F90 @@ -63,7 +63,7 @@ subroutine gfdl_cloud_microphys_init (me, master, nlunit, input_nml_file, loguni return endif - call gfdl_cloud_microphys_mod_init(me, master, nlunit, input_nml_file, logunit, fn_nml) + call gfdl_cloud_microphys_mod_init(me, master, nlunit, input_nml_file, logunit, fn_nml, errmsg, errflg) is_initialized = .true. diff --git a/physics/gfdl_sfc_layer.F90 b/physics/gfdl_sfc_layer.F90 index 379c9c856..44e2fa254 100644 --- a/physics/gfdl_sfc_layer.F90 +++ b/physics/gfdl_sfc_layer.F90 @@ -1140,7 +1140,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m land(i) = 0.0 windmks=wind10p(i)*.01 if ( iwavecpl .eq. 1 ) then - call znot_wind10m(windmks,znott,znotm,icoef_sf) + call znot_wind10m(windmks,znott,znotm,icoef_sf,errmsg,errflg) !Check if Charnock parameter ratio is received in a proper range. if ( alpha(i) .ge. 0.2 .and. alpha(i) .le. 5. ) then znotm = znotm*alpha(i) @@ -1148,7 +1148,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m zoc(i) = -100.*znotm zot(i) = -100* znott else - call znot_wind10m(windmks,znott,znotm,icoef_sf) + call znot_wind10m(windmks,znott,znotm,icoef_sf,errmsg,errflg) zoc(i) = -100.*znotm zot(i) = -100* znott endif @@ -1785,7 +1785,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m !!! if ( iwavecpl .eq. 1 .and. zoc(i) .le. 0.0 ) then windmks = wind10(i) * 0.01 - call znot_wind10m(windmks,znott,znotm,icoef_sf) + call znot_wind10m(windmks,znott,znotm,icoef_sf,errmsg,errflg) !Check if Charnock parameter ratio is received in a proper range. if ( alpha(i) .ge. 0.2 .and. alpha(i) .le. 5. ) then znotm = znotm*alpha(i) diff --git a/physics/lsm_ruc.F90 b/physics/lsm_ruc.F90 index 3ca78ad04..48bb281da 100644 --- a/physics/lsm_ruc.F90 +++ b/physics/lsm_ruc.F90 @@ -159,7 +159,7 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & endif !--- initialize soil vegetation - call set_soilveg_ruc(me, isot, ivegsrc, nlunit) + call set_soilveg_ruc(me, isot, ivegsrc, nlunit, errmsg, errflg) pores (:) = maxsmc (:) resid (:) = drysmc (:) @@ -1135,7 +1135,8 @@ subroutine lsm_ruc_run & ! inputs & smfrsoil(i,:,j),keepfrsoil(i,:,j), .false., & & shdmin1d(i,j), shdmax1d(i,j), rdlai2d, & & ims,ime, jms,jme, kms,kme, & - & its,ite, jts,jte, kts,kte ) + & its,ite, jts,jte, kts,kte, & + & errmsg, errflg) if(debug_print) then write (0,*)'after LSMRUC for land' write (0,*)'after sneqv(i,j) =',i,j,sneqv_lnd(i,j) @@ -1396,7 +1397,8 @@ subroutine lsm_ruc_run & ! inputs & smfrice(i,:,j),keepfrice(i,:,j), .false., & & shdmin1d(i,j), shdmax1d(i,j), rdlai2d, & & ims,ime, jms,jme, kms,kme, & - & its,ite, jts,jte, kts,kte ) + & its,ite, jts,jte, kts,kte, & + & errmsg, errflg) ! Interstitial evap_ice(i) = qfx_ice(i,j) / rho(i) ! kinematic diff --git a/physics/m_micro.F90 b/physics/m_micro.F90 index 15e30b0a6..200f906ee 100644 --- a/physics/m_micro.F90 +++ b/physics/m_micro.F90 @@ -123,7 +123,9 @@ subroutine m_micro_init(imp_physics, imp_physics_mg, fprcp, gravit, rair, rh2o, mg_ngcons, mg_ngnst) else write(0,*)' fprcp = ',fprcp,' is not a valid option - aborting' - stop + errflg = 1 + errmsg = 'ERROR(m_micro_init): fprcp is not a valid option' + return endif call aer_cloud_init () diff --git a/physics/module_SF_JSFC.F90 b/physics/module_SF_JSFC.F90 index 8d67a81cd..fdf188b96 100644 --- a/physics/module_SF_JSFC.F90 +++ b/physics/module_SF_JSFC.F90 @@ -122,7 +122,7 @@ SUBROUTINE JSFC(FLAG_ITER,ITER,ME & & ,A1U,A1T,A1Q & & ,IDS,IDE,JDS,JDE,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & - & ,ITS,ITE,JTS,JTE,KTS,LM) + & ,ITS,ITE,JTS,JTE,KTS,LM,errmsg,errflg) ! !----------------------------------------------------------------------- ! SUBROUTINE JSFC(NTSD,EPSQ2,HT,DZ & @@ -182,6 +182,8 @@ SUBROUTINE JSFC(FLAG_ITER,ITER,ME & REAL(kind=kfpt),DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: CM,CH,STRESS,FFM & & ,FFH,WIND,FM10,FH2 & & ,A1U,A1T,A1Q + character(len=*),intent(out) :: errmsg + integer, intent(out) :: errflg ! ! REAL(kind=kfpt),DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: CHS,CHS2,CQS2 & ! & ,CPM,CT,FLHC,FLQC & @@ -215,6 +217,9 @@ SUBROUTINE JSFC(FLAG_ITER,ITER,ME & ! !---------------------------------------------------------------------- !********************************************************************** + ! Initialize error-handling + errflg = 0 + errmsg = '' !---------------------------------------------------------------------- ! !*** MAKE PREPARATIONS @@ -390,7 +395,8 @@ SUBROUTINE JSFC(FLAG_ITER,ITER,ME & & ,A1U(I,J),A1T(I,J),A1Q(I,J) & & ,IDS,IDE,JDS,JDE,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & - & ,ITS,ITE,JTS,JTE,KTS,LM,I,J,ZHK(LMH+1),RIB(I,J)) ! Added Bulk Richardson No. + & ,ITS,ITE,JTS,JTE,KTS,LM,I,J,ZHK(LMH+1),RIB(I,J) & ! Added Bulk Richardson No. + & ,errmsg, errflg) ! !*** REMOVE SUPERATURATION AT 2M AND 10M ! @@ -454,7 +460,8 @@ SUBROUTINE SFCDIF(NTSD,SEAMASK,THS,QS,PSFC & & ,FFM,FFH,FM10,FH2,A1U,A1T,A1Q & & ,IDS,IDE,JDS,JDE,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & - & ,ITS,ITE,JTS,JTE,KTS,LM,I,J,ZSFC,RIB) ! Added Bulk Richardson No. + & ,ITS,ITE,JTS,JTE,KTS,LM,I,J,ZSFC,RIB & ! Added Bulk Richardson No. + & ,errmsg, errflg) ! **************************************************************** ! * * ! * SURFACE LAYER * @@ -481,6 +488,8 @@ SUBROUTINE SFCDIF(NTSD,SEAMASK,THS,QS,PSFC & REAL(kind=kfpt),INTENT(OUT) :: FFM,FFH,FM10,FH2,A1U,A1T,A1Q ! REAL(kind=kfpt),INTENT(INOUT) :: AKHS,AKMS,QZ0,THZ0,USTAR,UZ0,VZ0,Z0,QS + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg !---------------------------------------------------------------------- !*** !*** LOCAL VARIABLES @@ -507,6 +516,10 @@ SUBROUTINE SFCDIF(NTSD,SEAMASK,THS,QS,PSFC & !---------------------------------------------------------------------- !********************************************************************** !---------------------------------------------------------------------- + ! Initialize error-handling + errflg = 0 + errmsg = '' + RDZ=1./ZSL CXCHL=EXCML*RDZ CXCHS=EXCMS*RDZ @@ -701,7 +714,9 @@ SUBROUTINE SFCDIF(NTSD,SEAMASK,THS,QS,PSFC & print*,'PSIH1(1,2),RDZT=',PSIH1(K+1),PSIH1(K+2),RDZT print*,'ZSLU,ZSLT,RLMO,ZU,ZT=',ZSLU,ZSLT,RLMO,ZU,ZT print*,'A,B,DTHV,DU2,RIB=',A,B,DTHV,DU2,RIB - stop + errflg = 1 + errmsg = 'ERROR(SFCDIF): ' + return end if diff --git a/physics/module_gfdl_cloud_microphys.F90 b/physics/module_gfdl_cloud_microphys.F90 index 7f00d9bca..ebd3b93ff 100644 --- a/physics/module_gfdl_cloud_microphys.F90 +++ b/physics/module_gfdl_cloud_microphys.F90 @@ -3575,7 +3575,8 @@ end subroutine setupm !>\ingroup mod_gfdl_cloud_mp !! The subroutine 'gfdl_cloud_microphys_init' initializes the GFDL !! cloud microphysics. -subroutine gfdl_cloud_microphys_mod_init (me, master, nlunit, input_nml_file, logunit, fn_nml) +subroutine gfdl_cloud_microphys_mod_init (me, master, nlunit, input_nml_file, logunit, & + fn_nml, errmsg, errflg) implicit none @@ -3586,6 +3587,8 @@ subroutine gfdl_cloud_microphys_mod_init (me, master, nlunit, input_nml_file, lo character (len = 64), intent (in) :: fn_nml character (len = *), intent (in) :: input_nml_file(:) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg integer :: ios logical :: exists @@ -3600,13 +3603,19 @@ subroutine gfdl_cloud_microphys_mod_init (me, master, nlunit, input_nml_file, lo ! master = (mpp_pe () .eq.mpp_root_pe ()) + ! Initialize CCPP error-handling + errflg = 0 + errmsg = '' + #ifdef INTERNAL_FILE_NML read (input_nml_file, nml = gfdl_cloud_microphysics_nml) #else inquire (file = trim (fn_nml), exist = exists) if (.not. exists) then write (6, *) 'gfdl - mp :: namelist file: ', trim (fn_nml), ' does not exist' - stop + errflg = 1 + errmsg = 'ERROR(gfdl_cloud_microphys_mod_init): namelist file '//trim (fn_nml)//' does not exist' + return else open (unit = nlunit, file = fn_nml, action = 'read' , status = 'old', iostat = ios) endif diff --git a/physics/module_sf_exchcoef.f90 b/physics/module_sf_exchcoef.f90 index 0e3dae80c..6ec9ed835 100644 --- a/physics/module_sf_exchcoef.f90 +++ b/physics/module_sf_exchcoef.f90 @@ -636,7 +636,7 @@ SUBROUTINE znot_t_v8(uref,znott) END SUBROUTINE znot_t_v8 - SUBROUTINE znot_wind10m(w10m,znott,znotm,icoef_sf) + SUBROUTINE znot_wind10m(w10m,znott,znotm,icoef_sf,errmsg,errflg) IMPLICIT NONE ! w10m(m/s) : 10-m wind speed @@ -647,8 +647,15 @@ SUBROUTINE znot_wind10m(w10m,znott,znotm,icoef_sf) REAL, INTENT(IN) :: w10m INTEGER, INTENT(IN) :: icoef_sf REAL, INTENT(OUT):: znott, znotm + character(len=*),intent(out) :: errmsg + integer, intent(out) :: errflg real :: zm,zt,windmks, zlev,z10, tmp, zlevt, aaa, zm1,zt1 + + ! Initialize error-handling + errflg = 0 + errmsg = '' + zlev=20.0 zlevt=10.0 z10=10.0 @@ -722,7 +729,9 @@ SUBROUTINE znot_wind10m(w10m,znott,znotm,icoef_sf) call znot_t_v8(windmks,zt1) else write(0,*)'stop, icoef_sf must be one of 0,1,2,3,4,5,6,7,8' - stop + errflg = 1 + errmsg = 'ERROR(znot_wind10m): icoef_sf must be one of 0,1,2,3,4,5,6,7,8' + return endif znott=zt1 znotm=zm1 diff --git a/physics/module_sf_mynn.F90 b/physics/module_sf_mynn.F90 index 0d81e145a..a6f32430d 100644 --- a/physics/module_sf_mynn.F90 +++ b/physics/module_sf_mynn.F90 @@ -378,6 +378,10 @@ SUBROUTINE SFCLAY_mynn( & INTEGER :: I,J,K,itf,ktf !----------------------------------------------------------- + ! Initialize error-handling + errflg = 0 + errmsg = '' + IF (debug_code >= 1) THEN write(*,*)"======= printing of constants:" write(*,*)"cp=", cp," g=", g @@ -671,6 +675,9 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & REAL :: FLUXC,VSGD REAL :: restar,VISC,DQG,OLDUST,OLDTST + ! Initialize error-handling + errflg = 0 + errmsg = '' !------------------------------------------------------------------- DO I=its,ite @@ -1179,7 +1186,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ENDIF ELSEIF ( ISFTCFLX .EQ. 4 ) THEN !GFS zt formulation - CALL GFS_zt_wat(ZT_wat(i),ZNTstoch_wat(i),restar,WSPD(i),ZA(i),sfc_z0_type) + CALL GFS_zt_wat(ZT_wat(i),ZNTstoch_wat(i),restar,WSPD(i),ZA(i),sfc_z0_type,errmsg,errflg) ZQ_wat(i)=ZT_wat(i) ENDIF ELSE @@ -2749,14 +2756,20 @@ SUBROUTINE GFS_z0_wat(z0rl_wat,ustar_wat,WSPD,z1,sfc_z0_type,redrag) END SUBROUTINE GFS_z0_wat !-------------------------------------------------------------------- !>\ingroup mynn_sfc - SUBROUTINE GFS_zt_wat(ztmax,z0rl_wat,restar,WSPD,z1,sfc_z0_type) + SUBROUTINE GFS_zt_wat(ztmax,z0rl_wat,restar,WSPD,z1,sfc_z0_type,errmsg,errflg) REAL, INTENT(OUT) :: ztmax REAL, INTENT(IN) :: wspd,z1,z0rl_wat,restar INTEGER, INTENT(IN):: sfc_z0_type + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg REAL :: z0,z0max,wind10m,rat,ustar_wat REAL, PARAMETER :: charnock = 0.014, z0s_max=.317e-2 + ! Initialize error-handling + errflg = 0 + errmsg = '' + ! z0 = 0.01 * z0rl_wat !Already converted to meters in the wrapper z0 = z0rl_wat @@ -2786,7 +2799,9 @@ SUBROUTINE GFS_zt_wat(ztmax,z0rl_wat,restar,WSPD,z1,sfc_z0_type) call znot_t_v7(wind10m, ztmax) ! 10-m wind,m/s, ztmax(m) else if (sfc_z0_type > 0) then write(0,*)'no option for sfc_z0_type=',sfc_z0_type - stop + errflg = 1 + errmsg = 'ERROR(GFS_zt_wat): sfc_z0_type not valid.' + return endif END SUBROUTINE GFS_zt_wat diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 0cf820303..f86eb54fe 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -81,7 +81,8 @@ SUBROUTINE LSMRUC( & SMFR3D,KEEPFR3DFLAG, & myj,shdmin,shdmax,rdlai2d, & ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) + its,ite, jts,jte, kts,kte, & + errmsg, errflg) !----------------------------------------------------------------- IMPLICIT NONE !----------------------------------------------------------------- @@ -334,7 +335,6 @@ SUBROUTINE LSMRUC( & KICE, & KWT - REAL, DIMENSION(1:NSL) :: ZSMAIN, & ZSHALF, & DTDZS2 @@ -390,9 +390,14 @@ SUBROUTINE LSMRUC( & INTEGER :: I,J,K,NZS,NZS1,NDDZS INTEGER :: k1,k2 logical :: debug_print - + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg !----------------------------------------------------------------- ! + ! Initialize error-handling + errflg = 0 + errmsg = '' + debug_print = .false. ! rovcp = rd/cp @@ -713,7 +718,7 @@ SUBROUTINE LSMRUC( & soilfrac,nscat,shdmin(i,j),shdmax(i,j),mosaic_lu, mosaic_soil,& NLCAT,ILAND,ISOIL,iswater,MYJ,IFOREST,lufrac,VEGFRA(I,J), & EMISSL(I,J),PC(I,J),ZNT(I,J),LAI(I,J),RDLAI2D, & - QWRTZ,RHOCS,BCLH,DQM,KSAT,PSIS,QMIN,REF,WILT,i,j ) + QWRTZ,RHOCS,BCLH,DQM,KSAT,PSIS,QMIN,REF,WILT,i,j,errmsg, errflg) !-- update background emissivity for land points, can have vegetation mosaic effect EMISBCK(I,J) = EMISSL(I,J) @@ -6557,7 +6562,8 @@ SUBROUTINE SOILVEGIN ( debug_print, & mosaic_lu, mosaic_soil, & NLCAT,IVGTYP,ISLTYP,iswater,MYJ, & IFOREST,lufrac,vegfrac,EMISS,PC,ZNT,LAI,RDLAI2D,& - QWRTZ,RHOCS,BCLH,DQM,KSAT,PSIS,QMIN,REF,WILT,I,J) + QWRTZ,RHOCS,BCLH,DQM,KSAT,PSIS,QMIN,REF,WILT,I,J,& + errmsg, errflg) !************************************************************************ ! Set-up soil and vegetation Parameters in the case when @@ -6819,7 +6825,8 @@ SUBROUTINE SOILVEGIN ( debug_print, & REF, & WILT INTEGER, INTENT ( OUT) :: iforest - + character(len=*),intent(out) :: errmsg + integer, intent(out) :: errflg ! INTEGER, DIMENSION( 1:(lucats) ) , & ! INTENT ( OUT) :: iforest @@ -6840,7 +6847,11 @@ SUBROUTINE SOILVEGIN ( debug_print, & ! iforest(k)=if1(k) ! enddo - iforest = IFORTBL(IVGTYP) + ! Initialize error-handling + errflg = 0 + errmsg = '' + + iforest = IFORTBL(IVGTYP) IF (debug_print ) THEN print *,'ifortbl(ivgtyp),ivgtyp,laitbl(ivgtyp),z0tbl(ivgtyp)', & @@ -6914,7 +6925,9 @@ SUBROUTINE SOILVEGIN ( debug_print, & if (area.gt.1.) area=1. if (area <= 0.) then print *,'Bad area of grid box', area - stop + errflg = 1 + errmsg = 'ERROR(SOILVEGIN): Bad area of grid box' + return endif IF (debug_print ) THEN diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index d77b39735..dc6535e3d 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -379,7 +379,6 @@ subroutine cld_init & errmsg = 'ERROR(cld_init): cloud mp specification is not'// & & ' valid' return - stop endif endif endif diff --git a/physics/radlw_main.F90 b/physics/radlw_main.F90 index aeb626007..2f51b09f4 100644 --- a/physics/radlw_main.F90 +++ b/physics/radlw_main.F90 @@ -1325,8 +1325,7 @@ end subroutine rrtmg_lw_finalize !!\section rlwinit_gen rlwinit General Algorithm !! @{ subroutine rlwinit & - & ( me ) ! --- inputs -! --- outputs: (none) + & ( me, errflg, errmsg ) ! =================== program usage description =================== ! ! ! @@ -1397,7 +1396,9 @@ subroutine rlwinit & ! --- inputs: integer, intent(in) :: me -! --- outputs: none +! --- outputs: + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg ! --- locals: real (kind=kind_phys), parameter :: expeps = 1.e-20 @@ -1409,10 +1410,16 @@ subroutine rlwinit & ! !===> ... begin here ! + ! Initialize error-handling + errflg = 0 + errmsg = '' + if ( iovr<0 .or. iovr>5 ) then print *,' *** Error in specification of cloud overlap flag', & & ' IOVR=',iovr,' in RLWINIT !!' - stop + errflg = 1 + errmsg = 'ERROR(rlwinit): cloud-overlap (iovr) scheme selected not valid.' + return elseif ( (iovr==2 .or. iovr==3) .and. isubclw==0 ) then if (me == 0) then print *,' *** IOVR=',iovr,' is not available for', & @@ -1446,7 +1453,9 @@ subroutine rlwinit & else print *,' *** Error in specification of sub-column cloud ', & & ' control flag isubclw =',isubclw,' !!' - stop + errflg = 1 + errmsg = 'ERROR(rlwinit): sub-column scheme (isubclw) selected not valid.' + return endif endif @@ -1456,7 +1465,10 @@ subroutine rlwinit & & (icldflg == 1 .and. ilwcliq == 0)) then print *,' *** Model cloud scheme inconsistent with LW', & & ' radiation cloud radiative property setup !!' - stop + errflg = 1 + errmsg = 'ERROR(rlwinit): Model cloud scheme inconsistent with LW'//& + & ' radiation cloud radiative property setup' + return endif !> -# Setup default surface emissivity for each band. @@ -7668,7 +7680,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & return elseif(inflag .eq. 1) then - stop 'INFLAG = 1 OPTION NOT AVAILABLE WITH MCICA' + errflg = 1 + errmsg = 'ERROR(rlwinit): INFLAG = 1 OPTION NOT AVAILABLE WITH MCICA' + return ! cwp = ciwpmc(ig,lay) + clwpmc(ig,lay) ! taucmc(ig,lay) = abscld1 * cwp diff --git a/physics/radsw_main.F90 b/physics/radsw_main.F90 index 5d7d62dcc..f6c6b9a1e 100644 --- a/physics/radsw_main.F90 +++ b/physics/radsw_main.F90 @@ -1397,7 +1397,7 @@ end subroutine rrtmg_sw_finalize !! @{ !----------------------------------- subroutine rswinit & - & ( me ) ! --- inputs: + & ( me, errflg, errmsg ) ! --- inputs: ! --- outputs: (none) ! =================== program usage description =================== ! @@ -1457,7 +1457,9 @@ subroutine rswinit & ! --- inputs: integer, intent(in) :: me -! --- outputs: none +! --- outputs: + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg ! --- locals: real (kind=kind_phys), parameter :: expeps = 1.e-20 @@ -1469,10 +1471,16 @@ subroutine rswinit & ! !===> ... begin here ! + ! Initialize error-handling + errflg = 0 + errmsg = '' + if ( iovr<0 .or. iovr>5 ) then print *,' *** Error in specification of cloud overlap flag', & & ' IOVR=',iovr,' in RSWINIT !!' - stop + errflg = 1 + errmsg = 'ERROR(rswinit): cloud-overlap (iovr) scheme selected not valid.' + return endif if (me == 0) then @@ -1505,7 +1513,9 @@ subroutine rswinit & else print *,' *** Error in specification of sub-column cloud ', & & ' control flag isubcsw =',isubcsw,' !!' - stop + errflg = 1 + errmsg = 'ERROR(rswinit): sub-column scheme (isubcsw) selected not valid.' + return endif endif @@ -1515,7 +1525,10 @@ subroutine rswinit & & (icldflg == 1 .and. iswcliq == 0)) then print *,' *** Model cloud scheme inconsistent with SW', & & ' radiation cloud radiative property setup !!' - stop + errflg = 1 + errmsg = 'ERROR(rswinit): Model cloud scheme inconsistent with SW'//& + & ' radiation cloud radiative property setup' + return endif if ( isubcsw==0 .and. iovr>2 ) then diff --git a/physics/set_soilveg_ruc.F90 b/physics/set_soilveg_ruc.F90 index cac4fd1e7..c03e6fc5f 100644 --- a/physics/set_soilveg_ruc.F90 +++ b/physics/set_soilveg_ruc.F90 @@ -17,9 +17,11 @@ module set_soilveg_ruc_mod !>\ingroup lsm_ruc_group !! This subroutine specifies vegetation and soil parameters for a given !! soil and land-use classification. - subroutine set_soilveg_ruc(me,isot,ivet,nlunit) + subroutine set_soilveg_ruc(me,isot,ivet,nlunit,errmsg,errflg) integer, intent(in) :: isot,ivet,nlunit + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg integer me integer i @@ -35,6 +37,10 @@ subroutine set_soilveg_ruc(me,isot,ivet,nlunit) & WLTSMC, QTZ, mosaic_soil, mosaic_lu, & & REFSMCnoah, WLTSMCnoah, MAXSMCnoah + ! Initialize error-handling + errflg = 0 + errmsg = '' + if(ivet.eq.2) then ! Using umd veg classification slope_data =(/0.1, 0.6, 1.0, 0.35, 0.55, 0.8, & @@ -415,15 +421,21 @@ subroutine set_soilveg_ruc(me,isot,ivet,nlunit) IF (DEFINED_SOIL .GT. MAX_SOILTYP) THEN WRITE(0,*) 'Warning: DEFINED_SOIL too large in namelist' - STOP 222 + errflg = 1 + errmsg = 'ERROR(set_soilveg_ruc): DEFINED_SOIL too large in namelist' + return ENDIF IF (DEFINED_VEG .GT. MAX_VEGTYP) THEN WRITE(0,*) 'Warning: DEFINED_VEG too large in namelist' - STOP 222 + errflg = 1 + errmsg = 'ERROR(set_soilveg_ruc): DEFINED_VEG too large in namelist' + return ENDIF IF (DEFINED_SLOPE .GT. MAX_SLOPETYP) THEN WRITE(0,*) 'Warning: DEFINED_SLOPE too large in namelist' - STOP 222 + errflg = 1 + errmsg = 'ERROR(set_soilveg_ruc): DEFINED_SLOPE too large in namelist' + return ENDIF ! if (me == 0) write(6,soil_veg_ruc) From e02f1dde91715f1fcb4937f43ee58d35c0c0db74 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Tue, 16 Aug 2022 18:19:28 +0000 Subject: [PATCH 017/380] Bug fix in html include location. --- physics/drag_suite.F90 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/physics/drag_suite.F90 b/physics/drag_suite.F90 index c1c6fc8f4..5bb90b5e0 100644 --- a/physics/drag_suite.F90 +++ b/physics/drag_suite.F90 @@ -9,8 +9,12 @@ module drag_suite !> \defgroup gfs_drag_suite_mod GSL drag_suite Module !> This module contains the CCPP-compliant GSL orographic gravity wave dray scheme. !> @{ +!! +!> \brief This subroutine initializes the orographic gravity wave drag scheme. +!! !> \section arg_table_drag_suite_init Argument Table -!! \htmlinclude drag_suite_init.html +!! \htmlinclude drag_suite_init.html +!! subroutine drag_suite_init(gwd_opt, errmsg, errflg) integer, intent(in) :: gwd_opt From 0f2b5a7d8463f76b30870f71c3b7b8f82f550d79 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Tue, 16 Aug 2022 22:47:50 +0000 Subject: [PATCH 018/380] bug fixes --- physics/clm_lake.f90 | 472 ++++++++++++++++++++++++------------------ physics/clm_lake.meta | 138 +++++++++++- physics/physcons.F90 | 1 + physics/sfc_diag.f | 54 +++-- physics/sfc_diag.meta | 37 ++++ 5 files changed, 469 insertions(+), 233 deletions(-) diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90 index 384faf419..a07f48d40 100644 --- a/physics/clm_lake.f90 +++ b/physics/clm_lake.f90 @@ -31,22 +31,18 @@ MODULE clm_lake implicit none - logical, parameter :: LAKEDEBUG = .true. ! Enable lots of checks and debug prints + logical, parameter :: LAKEDEBUG = .true. ! Enable lots of checks and debug prints and errors - real(kind_phys), parameter :: zero_h2o = 1e-12 - - ! FIXME: REMOVE OR DOCUMENT PERGRO logical, parameter :: PERGRO = .false. - ! FIXME: REMOVE OR DOCUMENT ETALAKE logical, parameter :: USE_ETALAKE = .false. real, parameter :: ETALAKE = 1.1925*50**(-0.424) ! Set this to your desired value if USE_ETALAKE=.true. - real(kind_phys), parameter :: snow_bd = 250._kind_phys !constant snow bulk density (only used in special case here) [kg/m^3] - + ! Level counts must be consistent with model (GFS_Typedefs.F90) integer, parameter :: nlevsoil = 10 ! number of soil layers integer, parameter :: nlevlake = 10 ! number of lake layers integer, parameter :: nlevsnow = 5 ! maximum number of snow layers + real(kind_phys), parameter :: scalez = 0.025_kind_phys ! Soil layer thickness discretization (m) integer,parameter :: lbp = 1 ! pft-index bounds integer,parameter :: ubp = 1 @@ -73,70 +69,56 @@ MODULE clm_lake integer,parameter :: column =1 logical,parameter :: lakpoi(1) = .true. - - - - !Initialize physical constants: - ! FIXME: GET THESE FROM THE MODEL - real(kind_phys), parameter :: vkc = 0.4_kind_phys !von Karman constant [-] - real(kind_phys), parameter :: pi = 3.141592653589793_kind_phys ! pi - real(kind_phys), parameter :: grav = 9.80616_kind_phys !gravity constant [m/s2] - real(kind_phys), parameter :: sb = 5.67e-8_kind_phys !stefan-boltzmann constant [W/m2/K4] - real(kind_phys), parameter :: tfrz = 273.16_kind_phys !freezing temperature [K] - real(kind_phys), parameter :: denh2o = 1.000e3_kind_phys !density of liquid water [kg/m3] - real(kind_phys), parameter :: denice = 0.917e3_kind_phys !density of ice [kg/m3] - real(kind_phys), parameter :: cpice = 2.11727e3_kind_phys !Specific heat of ice [J/kg-K] - real(kind_phys), parameter :: cpliq = 4.188e3_kind_phys !Specific heat of water [J/kg-K] - real(kind_phys), parameter :: hfus = 3.337e5_kind_phys !Latent heat of fusion for ice [J/kg] - real(kind_phys), parameter :: hvap = 2.501e6_kind_phys !Latent heat of evap for water [J/kg] - real(kind_phys), parameter :: hsub = 2.501e6_kind_phys+3.337e5_kind_phys !Latent heat of sublimation [J/kg] - real(kind_phys), parameter :: rair = 287.0423_kind_phys !gas constant for dry air [J/kg/K] - real(kind_phys), parameter :: cpair = 1.00464e3_kind_phys !specific heat of dry air [J/kg/K] + !Initialize physical constants not available from model: real(kind_phys), parameter :: tcrit = 2.5 !critical temperature to determine rain or snow real(kind_phys), parameter :: tkwat = 0.6 !thermal conductivity of water [W/m/k] real(kind_phys), parameter :: tkice = 2.290 !thermal conductivity of ice [W/m/k] real(kind_phys), parameter :: tkairc = 0.023 !thermal conductivity of air [W/m/k] - real(kind_phys), parameter :: bdsno = 250. !bulk density snow (kg/m**3) + real(kind_phys), parameter :: snow_bd = 250 !constant snow bulk density (only used in special case here) [kg/m^3] + + ! Constants that are copied from model values by clm_lake_init: + real(kind_phys) :: pi !ratio of the circumference of a circle to its diameter + real(kind_phys) :: vkc !von Karman constant [-] + real(kind_phys) :: grav !gravity constant [m/s2] + real(kind_phys) :: sb !stefan-boltzmann constant [W/m2/K4] + real(kind_phys) :: tfrz !freezing temperature [K] + real(kind_phys) :: denh2o !density of liquid water [kg/m3] + real(kind_phys) :: denice !density of ice [kg/m3] + real(kind_phys) :: cpice !Specific heat of ice [J/kg-K] + real(kind_phys) :: cpliq !Specific heat of water [J/kg-K] + real(kind_phys) :: hfus !Latent heat of fusion for ice [J/kg] + real(kind_phys) :: hvap !Latent heat of evap for water [J/kg] + real(kind_phys) :: hsub !Latent heat of sublimation [J/kg] + real(kind_phys) :: rair !gas constant for dry air [J/kg/K] + real(kind_phys) :: cpair !specific heat of dry air [J/kg/K] - real(kind_phys), public, parameter :: spval = 1.e36 !special value for missing data (ocean) - - real(kind_phys), parameter :: depth_c = 50. ! below the level t_lake3d will be 277.0 !mchen - + real(kind_phys), public, parameter :: spval = 1.e36 !special value for missing data (ocean) + real(kind_phys), parameter :: depth_c = 50. !below the level t_lake3d will be 277.0 !mchen + real(kind_phys), parameter :: zero_h2o = 1e-12 !lower mixing ratio is is treated as zero ! These are tunable constants real(kind_phys), parameter :: wimp = 0.05 !Water impermeable if porosity less than wimp real(kind_phys), parameter :: ssi = 0.033 !Irreducible water saturation of snow real(kind_phys), parameter :: cnfac = 0.5 !Crank Nicholson factor between 0 and 1 - ! Initialize water type constants integer,parameter :: istsoil = 1 !soil "water" type - integer, private :: i ! loop index - real(kind_phys) :: dtime ! land model time step (sec) + ! percent sand + real(kind_phys), parameter :: sand(19) = & + (/92.,80.,66.,20.,5.,43.,60.,10.,32.,51., 6.,22.,39.7,0.,100.,54.,17.,100.,92./) + + ! percent clay + real(kind_phys), parameter :: clay(19) = & + (/ 3., 5.,10.,15.,5.,18.,27.,33.,33.,41.,47.,58.,14.7,0., 0., 8.5,54., 0., 3./) + + ! These are initialized in clm_lake_init and are not modified elsewhere real(kind_phys) :: zlak(1:nlevlake) !lake z (layers) real(kind_phys) :: dzlak(1:nlevlake) !lake dz (thickness) real(kind_phys) :: zsoi(1:nlevsoil) !soil z (layers) real(kind_phys) :: dzsoi(1:nlevsoil) !soil dz (thickness) real(kind_phys) :: zisoi(0:nlevsoil) !soil zi (interfaces) - - real(kind_phys) :: sand(19) ! percent sand - real(kind_phys) :: clay(19) ! percent clay - - data(sand(i), i=1,19)/92.,80.,66.,20.,5.,43.,60.,& - 10.,32.,51., 6.,22.,39.7,0.,100.,54.,17.,100.,92./ - - data(clay(i), i=1,19)/ 3., 5.,10.,15.,5.,18.,27.,& - 33.,33.,41.,47.,58.,14.7,0., 0., 8.5,54., 0., 3./ - - - ! real(kind_phys) :: dtime ! land model time step (sec) - real(kind_phys) :: watsat(1,nlevsoil) ! volumetric soil water at saturation (porosity) - real(kind_phys) :: tksatu(1,nlevsoil) ! thermal conductivity, saturated soil [W/m-K] - real(kind_phys) :: tkmg(1,nlevsoil) ! thermal conductivity, soil minerals [W/m-K] - real(kind_phys) :: tkdry(1,nlevsoil) ! thermal conductivity, dry soil (W/m/Kelvin) - real(kind_phys) :: csol(1,nlevsoil) ! heat capacity, soil solids (J/m**3/Kelvin) CONTAINS !> \section arg_table_clm_lake_run Argument Table @@ -155,7 +137,7 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& h2osoi_ice3d ,t_grnd2d ,t_soisno3d ,t_lake3d ,& savedtke12d ,lake_icefrac3d ,use_lake_model ,& iopt_lake ,iopt_lake_clm ,& - con_cp ,& + con_cp ,icy ,& hflx ,evap ,grdflx ,tsfc ,& !o lake_t2m ,lake_q2m ,clm_lake_initialized ,& isltyp ,snow ,use_lakedepth ,& @@ -165,7 +147,7 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& weasd ,snwdph ,hice ,tsurf ,& t_sfc ,lflx ,ustar ,qsfc ,& ch ,cm ,chh ,cmm ,& - T_snow ,T_ice ,tsurf_ice ,wind ,& + lake_t_snow ,tisfc ,tsurf_ice ,wind ,& ! xlon_d ,kdt ,tg3 ,& me ,master ,errmsg ,errflg ) @@ -185,8 +167,9 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& CHARACTER(*), INTENT(OUT) :: errmsg INTEGER , INTENT (IN) :: im,km,me,master LOGICAL, INTENT(IN) :: restart,use_lakedepth,first_time_step - INTEGER, INTENT(INOUT) :: clm_lake_initialized(:) + REAL(KIND_PHYS), INTENT(INOUT) :: clm_lake_initialized(:) REAL(KIND_PHYS), INTENT(IN) :: xice_threshold, con_rd,con_g,con_cp,lakedepth_default + logical, intent(inout) :: icy(:) REAL(KIND_PHYS), DIMENSION( : ), INTENT(INOUT):: XICE REAL(KIND_PHYS), DIMENSION( : ), INTENT(IN):: tg3 REAL(KIND_PHYS), DIMENSION( : ), INTENT(IN) :: SNOW, ZLVL @@ -197,7 +180,7 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& REAL(KIND_PHYS), DIMENSION( : ), INTENT(INOUT) :: & weasd ,snwdph ,hice ,tsurf ,& t_sfc ,lflx ,ustar ,qsfc ,& - chh ,cmm ,T_snow ,T_ice ,& + chh ,cmm ,lake_t_snow ,tisfc ,& tsurf_ice ,wind LOGICAL, DIMENSION(:), INTENT(IN) :: flag_iter REAL(KIND_PHYS), DIMENSION( :, : ),INTENT(IN) :: gt0 @@ -254,7 +237,7 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& !local variable: - REAL(kind_phys) :: SFCTMP,PBOT,PSFC,Q2K,LWDN,PRCP,SOLDN,SOLNET + REAL(kind_phys) :: SFCTMP,PBOT,PSFC,Q2K,LWDN,PRCP,SOLDN,SOLNET,dtime INTEGER :: C,i,j,k @@ -315,24 +298,49 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& real(kind_phys) :: discard1, discard2, discard3 ! for unused temporary data + real(kind_phys) :: watsat(1,nlevsoil) ! volumetric soil water at saturation (porosity) + real(kind_phys) :: tksatu(1,nlevsoil) ! thermal conductivity, saturated soil [W/m-K] + real(kind_phys) :: tkmg(1,nlevsoil) ! thermal conductivity, soil minerals [W/m-K] + real(kind_phys) :: tkdry(1,nlevsoil) ! thermal conductivity, dry soil (W/m/Kelvin) + real(kind_phys) :: csol(1,nlevsoil) ! heat capacity, soil solids (J/m**3/Kelvin) + integer :: lake_points character*255 :: message logical, parameter :: feedback_to_atmosphere = .true. ! FIXME: REMOVE + + ! Functionality to print extra values at problematic points specified by user logical :: was_unhappy,is_unhappy + ! Points come from this file + character(*), parameter :: unhappy_txt = "unhappy.txt" + + ! Special values of the unhappy_count to indicate data is unavailable integer, parameter :: HAVE_NOT_READ_UNHAPPY_POINTS_YET = -1 integer, parameter :: FAILED_TO_READ_UNHAPPY_POINTS = -2 + ! These "save" variables are protected by an OMP CRITICAL to + ! ensure they're only initialized once. + + ! Number of unhappy points integer, save :: unhappy_count = HAVE_NOT_READ_UNHAPPY_POINTS_YET + + ! The latitude and longitude of unhappy points. real(kind_phys), allocatable, save :: unhappy_lat(:),unhappy_lon(:) - character(*), parameter :: unhappy_txt = "unhappy.txt" errmsg = ' ' errflg = 0 + dtime=dtp + if(LAKEDEBUG) then + ! Have we read the unhappy points? + ! The first "if" ensures we don't initiate an OMP CRITICAL unless we have to. if(unhappy_count==HAVE_NOT_READ_UNHAPPY_POINTS_YET) then !$OMP CRITICAL + + ! Check unhappy_count again since it probably changed + ! during the setup of the omp critical, when another + ! thread read in the unhappy points. if(unhappy_count==HAVE_NOT_READ_UNHAPPY_POINTS_YET) then call read_unhappy_points if(unhappy_count>0) then @@ -346,16 +354,14 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& endif !$OMP END CRITICAL endif - if(unhappy_count==FAILED_TO_READ_UNHAPPY_POINTS) then - write(message,'(A)') "ERROR: Could not read unhappy points" - errmsg=message - errflg=1 - return + ! At this point, at least one thread should have read in the unhappy points. + if(unhappy_count==FAILED_TO_READ_UNHAPPY_POINTS .and. kdt<2) then + write(0,'(A)') "ERROR: Could not read unhappy points" endif endif ! Still have some points to initialize - call lakeini( ISLTYP, gt0, SNOW, & !i + call lakeini(kdt, ISLTYP, gt0, SNOW, & !i restart, lakedepth_default, & lakedepth2d, savedtke12d, snowdp2d, h2osno2d, & !o snl2d, t_grnd2d, t_lake3d, lake_icefrac3d, & @@ -386,8 +392,6 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& lake_points=0 - dtime = dtp - lake_top_loop: DO I = 1,im if_lake_is_here: if (flag_iter(i) .and. use_lake_model(i)/=0) THEN @@ -397,7 +401,7 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& PSFC = prsi(i,1) Q2K = qvcurr(i) LWDN = DLWSFCI(I)*EMISS(I) - PRCP = RAIN(i)*1000.0_kind_phys/dtp ! use physics timestep since PRCP comes from non-surface schemes + PRCP = RAIN(i)*1000.0_kind_phys/dtime ! use physics timestep since PRCP comes from non-surface schemes SOLDN = DSWSFCI(I) ! SOLDN is total incoming solar SOLNET = SOLDN*(1.-ALBEDO(I)) ! use mid-day albedo to determine net downward solar ! (no solar zenith angle correction) @@ -472,7 +476,8 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& savedtke1,lake_icefrac, & eflx_lwrad_net,eflx_gnet, & !O eflx_sh_tot,eflx_lh_tot, & - t_ref2m,q_ref2m, & + t_ref2m,q_ref2m, dtime, & + watsat, tksatu, tkmg, tkdry, csol, & taux,tauy,ram1,z0mg,ustar_out,errmsg,errflg, & xlat_d(i),xlon_d(i),is_unhappy) if(LAKEDEBUG) then @@ -540,11 +545,12 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& albedo(i) = ( 0.6 * lake_icefrac3d(i,1) ) + ( (1.0-lake_icefrac3d(i,1)) * 0.08) xice(i) = lake_icefrac3d(i,1) - if(xice(i)>0) then + if(xice(i)>xice_threshold) then weasd(i) = h2osno(c) ! water_equivalent_accumulated_snow_depth_over_ice snwdph(i) = h2osno(c)/snow_bd*1000 ! surface_snow_thickness_water_equivalent_over_ice - T_ice(i) = t_grnd(c) ! surface_skin_temperature_over_ice + tisfc(i) = t_grnd(c) ! surface_skin_temperature_over_ice tsurf_ice(i) = t_grnd(c) ! surface_skin_temperature_after_iteration_over_ice + icy(i)=.true. ! Assume that, if a layer has ice, the entire layer thickness is ice. hice(I) = 0 @@ -556,13 +562,14 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& else weasd(i) = 0 snwdph(i) = 0 - T_ice(i) = tsurf(i) - tsurf_ice(i) = T_ice(i) + tisfc(i) = tsurf(i) + tsurf_ice(i) = tisfc(i) hice(i) = 0 endif if(snl2d(i)>0) then - T_snow(i) = t_grnd(c) ! temperature_of_snow_on_lake + lake_t_snow(i) = t_grnd(c) + tisfc(i) = lake_t_snow(i) endif ustar = ustar_out(1) ! surface_friction_velocity_over_water @@ -661,8 +668,8 @@ subroutine read_unhappy_points 1001 continue ! Error handler, whether file was opened or not write(0,'(A)') message - errmsg=message - errflg=1 + ! errmsg=message + ! errflg=1 if(allocated(unhappy_lat)) deallocate(unhappy_lat) if(allocated(unhappy_lon)) deallocate(unhappy_lon) unhappy_count=FAILED_TO_READ_UNHAPPY_POINTS @@ -682,7 +689,8 @@ SUBROUTINE LakeMain(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, & !I savedtke1,lake_icefrac, & eflx_lwrad_net,eflx_gnet, & !O eflx_sh_tot,eflx_lh_tot, & - t_ref2m,q_ref2m, & + t_ref2m,q_ref2m, dtime, & + watsat, tksatu, tkmg, tkdry, csol, & taux,tauy,ram1,z0mg,ustar_out,errmsg,errflg, xlat_d,xlon_d,unhappy) implicit none !in: @@ -690,7 +698,8 @@ SUBROUTINE LakeMain(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, & !I logical :: unhappy integer, intent(inout) :: errflg character(*), intent(inout) :: errmsg - real(kind_phys),intent(in) :: xlat_d, xlon_d ! grid location for debugging + real(kind_phys),intent(in) :: dtime ! timestep + real(kind_phys),intent(in) :: xlat_d, xlon_d ! grid location for debugging real(kind_phys),intent(in) :: forc_t(1) ! atmospheric temperature (Kelvin) real(kind_phys),intent(in) :: forc_pbot(1) ! atm bottom level pressure (Pa) real(kind_phys),intent(in) :: forc_psrf(1) ! atmospheric surface pressure (Pa) @@ -714,6 +723,11 @@ SUBROUTINE LakeMain(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, & !I ! real(kind_phys), intent(in) :: watsat(1,1:nlevsoil) ! volumetric soil water at saturation (porosity) !!!!!!!!!!!!!!!!hydro logical , intent(in) :: do_capsnow(1) ! true => do snow capping + real(kind_phys), intent(in) :: watsat(1,nlevsoil) ! volumetric soil water at saturation (porosity) + real(kind_phys), intent(in) :: tksatu(1,nlevsoil) ! thermal conductivity, saturated soil [W/m-K] + real(kind_phys), intent(in) :: tkmg(1,nlevsoil) ! thermal conductivity, soil minerals [W/m-K] + real(kind_phys), intent(in) :: tkdry(1,nlevsoil) ! thermal conductivity, dry soil (W/m/Kelvin) + real(kind_phys), intent(in) :: csol(1,nlevsoil) ! heat capacity, soil solids (J/m**3/Kelvin) @@ -830,7 +844,7 @@ SUBROUTINE LakeMain(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, & !I eflx_lh_grnd,t_veg,t_ref2m,q_ref2m,taux,tauy, & ram1,ws,ks,eflx_gnet,z0mg,ustar_out,errmsg,errflg,xlat_d,xlon_d,unhappy) if(errflg/=0) then - !return ! State is invalid now, so pass error to caller. + return ! State is invalid now, so pass error to caller. endif CALL ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & !i @@ -839,9 +853,10 @@ SUBROUTINE LakeMain(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, & !I eflx_sh_grnd,eflx_sh_tot,eflx_soil_grnd, & !o t_lake,t_soisno,h2osoi_liq, & h2osoi_ice,savedtke1, & + watsat, tksatu, tkmg, tkdry, csol, dtime, & frac_iceold,qflx_snomelt,imelt,errmsg,errflg) if(errflg/=0) then - !return ! State is invalid now, so pass error to caller. + return ! State is invalid now, so pass error to caller. endif CALL ShalLakeHydrology(dz_lake,forc_rain,forc_snow, & !i @@ -858,9 +873,10 @@ SUBROUTINE LakeMain(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, & !I qflx_evap_tot_col,soilalpha,zwt,fcov, & rootr_column,qflx_evap_grnd,qflx_sub_snow, & qflx_dew_snow,qflx_dew_grnd,qflx_rain_grnd_col, & - errmsg,errflg) + watsat, tksatu, tkmg, tkdry, csol, & + dtime,errmsg,errflg) if(errflg/=0) then - !return ! State is invalid now, so pass error to caller. + return ! State is invalid now, so pass error to caller. endif !================================================================================== @@ -981,7 +997,6 @@ SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, integer :: iter ! iteration index integer :: nmozsgn(lbp:ubp) ! number of times moz changes sign integer :: jtop(lbc:ubc) ! top level for each column (no longer all 1) - ! real(kind_phys) :: dtime ! land model time step (sec) real(kind_phys) :: ax ! used in iteration loop for calculating t_grnd (numerator of NR solution) real(kind_phys) :: bx ! used in iteration loop for calculating t_grnd (denomin. of NR solution) real(kind_phys) :: degdT ! d(eg)/dT @@ -1044,8 +1059,6 @@ SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, unhappy=.false. - ! dtime = get_step_size() - ! Begin calculations !dir$ concurrent @@ -1368,8 +1381,9 @@ SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, .or. abs(t_grnd(c)-288)>200 ) then 840 format('CLM_Lake ShalLakeFluxes: t_grnd is out of range: eflx_sh_tot(p)=',G20.12,' eflx_lh_tot(p)=',G20.12,' t_grnd(c)=',G20.12,' at p=',I0,' c=',I0,' xlat_d=',F10.3,' xlon_d=',F10.3) write(message,840) eflx_sh_tot(p),eflx_lh_tot(p),t_grnd(c),p,c,xlat_d,xlon_d - errmsg=message - errflg=1 + ! errmsg=message + ! errflg=1 + write(0,'(A)') trim(message) unhappy = .true. endif endif @@ -1433,6 +1447,7 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! eflx_sh_grnd,eflx_sh_tot,eflx_soil_grnd, & !o t_lake,t_soisno,h2osoi_liq, & h2osoi_ice,savedtke1, & + watsat, tksatu, tkmg, tkdry, csol, dtime, & frac_iceold,qflx_snomelt,imelt,errmsg,errflg) !======================================================================================================= ! !DESCRIPTION: @@ -1522,6 +1537,11 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! !in: integer, intent(inout) :: errflg + real(kind_phys), intent(in) :: watsat(1,nlevsoil) ! volumetric soil water at saturation (porosity) + real(kind_phys), intent(in) :: tksatu(1,nlevsoil) ! thermal conductivity, saturated soil [W/m-K] + real(kind_phys), intent(in) :: tkmg(1,nlevsoil) ! thermal conductivity, soil minerals [W/m-K] + real(kind_phys), intent(in) :: tkdry(1,nlevsoil) ! thermal conductivity, dry soil (W/m/Kelvin) + real(kind_phys), intent(in) :: csol(1,nlevsoil) ! heat capacity, soil solids (J/m**3/Kelvin) character(*), intent(inout) :: errmsg real(kind_phys), intent(in) :: t_grnd(1) ! ground temperature (Kelvin) real(kind_phys), intent(inout) :: h2osno(1) ! snow water (mm H2O) @@ -1541,6 +1561,7 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! ! real(kind_phys), intent(in) :: watsat(1,nlevsoil) ! volumetric soil water at saturation (porosity) real(kind_phys), intent(inout) :: snowdp(1) !snow height (m) + real(kind_phys), intent(in) :: dtime !timestep !out: real(kind_phys), intent(out) :: eflx_sh_grnd(1) ! sensible heat flux from ground (W/m**2) [+ to atm] @@ -1565,7 +1586,6 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! integer , parameter :: islak = 2 ! index of lake, 1 = deep lake, 2 = shallow lake real(kind_phys), parameter :: p0 = 1._kind_phys ! neutral value of turbulent prandtl number integer :: i,j,fc,fp,g,c,p ! do loop or array index - ! real(kind_phys) :: dtime ! land model time step (sec) real(kind_phys) :: beta(2) ! fraction solar rad absorbed at surface: depends on lake type real(kind_phys) :: za(2) ! base of surface absorption layer (m): depends on lake type real(kind_phys) :: eta(2) ! light extinction coefficient (/m): depends on lake type @@ -1648,8 +1668,6 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! ! 1!) Initialization ! Determine step size - ! dtime = get_step_size() - ! Initialize constants cwat = cpliq*denh2o ! water heat capacity per unit volume cice_eff = cpice*denh2o !use water density because layer depth is not adjusted @@ -1860,7 +1878,7 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! ! For snow / soil call SoilThermProp_Lake (snl,dz,zi,z,t_soisno,h2osoi_liq,h2osoi_ice, & - tk, cv, tktopsoillay,errmsg,errflg) + watsat, tksatu, tkmg, tkdry, csol, tk, cv, tktopsoillay,errmsg,errflg) if(errflg/=0) then ! State is no longer valid, so return error to caller ! FIXME: PUT THIS BACK return @@ -1903,8 +1921,9 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! if(abs(t_soisno(c,j)-288) > 150) then 48 format('WARNING: At c=',I0,' level=',I0,' extreme t_soisno = ',F15.10) WRITE(message,48) c,j,t_soisno(c,j) - errmsg=trim(message) - errflg=1 + ! errmsg=trim(message) + ! errflg=1 + write(0,'(A)') trim(message) endif end if end do @@ -2115,6 +2134,7 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! column during Tridiagonal Solution,', 'error (W/m^2):', c, errsoi(c) errmsg=trim(message) errflg=1 + return end if end do ! This has to be done before convective mixing because the heat capacities for each layer @@ -2176,6 +2196,7 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! c, errsoi(c) errmsg=trim(message) errflg=1 + return end if end do @@ -2194,6 +2215,7 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! 'column, error (kg/m^2):', c, wsum_end(c)-wsum(c) errmsg=trim(message) errflg=1 + return end if end if end do @@ -2328,7 +2350,7 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! ! For snow / soil ! call SoilThermProp_Lake(lbc, ubc, num_shlakec, filter_shlakec, tk, cv, tktopsoillay) call SoilThermProp_Lake (snl,dz,zi,z,t_soisno,h2osoi_liq,h2osoi_ice, & - tk, cv, tktopsoillay,errmsg,errflg) + watsat, tksatu, tkmg, tkdry, csol, tk, cv, tktopsoillay,errmsg,errflg) ! Do as above to sum energy content @@ -2400,7 +2422,7 @@ end subroutine ShalLakeTemperature ! ! !INTERFACE: subroutine SoilThermProp_Lake (snl,dz,zi,z,t_soisno,h2osoi_liq,h2osoi_ice, & - tk, cv, tktopsoillay,errmsg,errflg) + watsat, tksatu, tkmg, tkdry, csol, tk, cv, tktopsoillay,errmsg,errflg) ! ! !DESCRIPTION: @@ -2428,11 +2450,11 @@ subroutine SoilThermProp_Lake (snl,dz,zi,z,t_soisno,h2osoi_liq,h2osoi_ice, & character(*), intent(inout) :: errmsg integer , intent(in) :: snl(1) ! number of snow layers ! real(kind_phys), intent(in) :: h2osno(1) ! snow water (mm H2O) - ! real(kind_phys), intent(in) :: watsat(1,nlevsoil) ! volumetric soil water at saturation (porosity) - ! real(kind_phys), intent(in) :: tksatu(1,nlevsoil) ! thermal conductivity, saturated soil [W/m-K] - ! real(kind_phys), intent(in) :: tkmg(1,nlevsoil) ! thermal conductivity, soil minerals [W/m-K] - ! real(kind_phys), intent(in) :: tkdry(1,nlevsoil) ! thermal conductivity, dry soil (W/m/Kelvin) - ! real(kind_phys), intent(in) :: csol(1,nlevsoil) ! heat capacity, soil solids (J/m**3/Kelvin) + real(kind_phys), intent(in) :: watsat(1,nlevsoil) ! volumetric soil water at saturation (porosity) + real(kind_phys), intent(in) :: tksatu(1,nlevsoil) ! thermal conductivity, saturated soil [W/m-K] + real(kind_phys), intent(in) :: tkmg(1,nlevsoil) ! thermal conductivity, soil minerals [W/m-K] + real(kind_phys), intent(in) :: tkdry(1,nlevsoil) ! thermal conductivity, dry soil (W/m/Kelvin) + real(kind_phys), intent(in) :: csol(1,nlevsoil) ! heat capacity, soil solids (J/m**3/Kelvin) real(kind_phys), intent(in) :: dz(1,-nlevsnow+1:nlevsoil) ! layer thickness (m) real(kind_phys), intent(in) :: zi(1,-nlevsnow+0:nlevsoil) ! interface level below a "z" level (m) real(kind_phys), intent(in) :: z(1,-nlevsnow+1:nlevsoil) ! layer depth (m) @@ -2500,8 +2522,9 @@ subroutine SoilThermProp_Lake (snl,dz,zi,z,t_soisno,h2osoi_liq,h2osoi_ice, & ! satw = min(1._kind_phys, satw) if (satw < 0.999_kind_phys) then write(message,*)'WARNING: soil layer unsaturated in SoilThermProp_Lake, satw, j = ', satw, j - errmsg=trim(message) - errflg=1 + ! errmsg=trim(message) + ! errflg=1 + write(0,'(A)') trim(message) end if ! Could use denice because if it starts out frozen, the volume of water will go below sat., ! since we're not yet doing excess ice. @@ -2513,9 +2536,10 @@ subroutine SoilThermProp_Lake (snl,dz,zi,z,t_soisno,h2osoi_liq,h2osoi_ice, & fl = h2osoi_liq(c,j)/denom else write(message,'(A,I0)') 'WARNING: zero h2osoi_ice+h2osoi_liq at j = ', j - errmsg=trim(message) - errflg=1 + ! errmsg=trim(message) + ! errflg=1 fl = 0 + write(0,'(A)') trim(message) endif if (t_soisno(c,j) >= tfrz) then ! Unfrozen soil dke = max(0._kind_phys, log10(satw) + 1.0_kind_phys) @@ -2675,7 +2699,6 @@ subroutine PhaseChange_Lake (snl,h2osno,dz,dz_lake, & !i integer :: j,c,g !do loop index integer :: fc !lake filtered column indices - ! real(kind_phys) :: dtime !land model time step (sec) real(kind_phys) :: heatavail !available energy for melting or freezing (J/m^2) real(kind_phys) :: heatrem !energy residual or loss after melting or freezing real(kind_phys) :: melt !actual melting (+) or freezing (-) [kg/m2] @@ -2683,8 +2706,6 @@ subroutine PhaseChange_Lake (snl,h2osno,dz,dz_lake, & !i logical :: dophasechangeflag !----------------------------------------------------------------------- - ! dtime = get_step_size() - ! Initialization !dir$ concurrent @@ -2846,7 +2867,8 @@ subroutine ShalLakeHydrology(dz_lake,forc_rain,forc_snow, & qflx_evap_tot_col,soilalpha,zwt,fcov, & rootr_column,qflx_evap_grnd,qflx_sub_snow, & qflx_dew_snow,qflx_dew_grnd,qflx_rain_grnd_col, & - errmsg,errflg) + watsat, tksatu, tkmg, tkdry, csol, & + dtime,errmsg,errflg) !================================================================================== ! !DESCRIPTION: @@ -2892,9 +2914,15 @@ subroutine ShalLakeHydrology(dz_lake,forc_rain,forc_snow, & integer, intent(inout) :: errflg character(*), intent(inout) :: errmsg + real(kind_phys) :: watsat(1,nlevsoil) ! volumetric soil water at saturation (porosity) + real(kind_phys) :: tksatu(1,nlevsoil) ! thermal conductivity, saturated soil [W/m-K] + real(kind_phys) :: tkmg(1,nlevsoil) ! thermal conductivity, soil minerals [W/m-K] + real(kind_phys) :: tkdry(1,nlevsoil) ! thermal conductivity, dry soil (W/m/Kelvin) + real(kind_phys) :: csol(1,nlevsoil) ! heat capacity, soil solids (J/m**3/Kelvin) + ! integer , intent(in) :: clandunit(1) ! column's landunit ! integer , intent(in) :: ityplun(1) ! landunit type - ! real(kind_phys), intent(in) :: watsat(1,1:nlevsoil) ! volumetric soil water at saturation (porosity) + real(kind_phys), intent(in) :: dtime ! timestep real(kind_phys), intent(in) :: dz_lake(1,nlevlake) ! layer thickness for lake (m) real(kind_phys), intent(in) :: forc_rain(1) ! rain rate [mm/s] real(kind_phys), intent(in) :: forc_snow(1) ! snow rate [mm/s] @@ -2976,7 +3004,6 @@ subroutine ShalLakeHydrology(dz_lake,forc_rain,forc_snow, & integer :: filter_shlakesnowc(ubc-lbc+1) ! column filter for snow points integer :: num_shlakenosnowc ! number of column non-snow points integer :: filter_shlakenosnowc(ubc-lbc+1) ! column filter for non-snow points - ! real(kind_phys) :: dtime ! land model time step (sec) integer :: newnode ! flag when new snow node is set, (1=yes, 0=no) real(kind_phys) :: dz_snowf ! layer thickness rate change due to precipitation [mm/s] real(kind_phys) :: bifall ! bulk density of newly fallen dry snow [kg/m3] @@ -2998,8 +3025,6 @@ subroutine ShalLakeHydrology(dz_lake,forc_rain,forc_snow, & ! Determine step size - ! dtime = get_step_size() - ! Add soil water to water balance. do j = 1, nlevsoil !dir$ concurrent @@ -3215,7 +3240,7 @@ subroutine ShalLakeHydrology(dz_lake,forc_rain,forc_snow, & num_shlakenosnowc, filter_shlakenosnowc, & !i snl,do_capsnow,qflx_snomelt,qflx_rain_grnd, & !i qflx_sub_snow,qflx_evap_grnd, & !i - qflx_dew_snow,qflx_dew_grnd,dz, & !i + qflx_dew_snow,qflx_dew_grnd,dz,dtime, & !i h2osoi_ice,h2osoi_liq, & !i&o qflx_top_soil) !o @@ -3249,7 +3274,7 @@ subroutine ShalLakeHydrology(dz_lake,forc_rain,forc_snow, & call SnowCompaction(lbc, ubc, num_shlakesnowc, filter_shlakesnowc, &!i snl,imelt,frac_iceold,t_soisno, &!i - h2osoi_ice,h2osoi_liq, &!i + h2osoi_ice,h2osoi_liq,dtime, &!i dz) !&o ! Combine thin snow elements @@ -3457,9 +3482,9 @@ subroutine ShalLakeHydrology(dz_lake,forc_rain,forc_snow, & if(j == 0 .and. abs(snow_water(c)-h2osno(c))>1.e-7_kind_phys) then write(message,*)'h2osno does not equal sum of snow layers in ShalLakeHydrology:', & 'column, h2osno, sum of snow layers =', c, h2osno(c), snow_water(c) - errmsg=trim(message) - errflg=1 - ! FIXME: PUT THIS BACK: return + ! errmsg=trim(message) + ! errflg=1 + write(0,'(A)') trim(message) end if end if end do @@ -3700,7 +3725,7 @@ subroutine SnowWater(lbc, ubc, num_snowc, filter_snowc, & !i num_nosnowc, filter_nosnowc, & !i snl,do_capsnow,qflx_snomelt,qflx_rain_grnd, & !i qflx_sub_snow,qflx_evap_grnd, & !i - qflx_dew_snow,qflx_dew_grnd,dz, & !i + qflx_dew_snow,qflx_dew_grnd,dz,dtime, & !i h2osoi_ice,h2osoi_liq, & !i&o qflx_top_soil) !o !=============================================================================== @@ -3736,6 +3761,7 @@ subroutine SnowWater(lbc, ubc, num_snowc, filter_snowc, & !i integer , intent(in) :: snl(1) !number of snow layers logical , intent(in) :: do_capsnow(1) !true => do snow capping + real(kind_phys), intent(in) :: dtime !timestep real(kind_phys), intent(in) :: qflx_snomelt(1) !snow melt (mm H2O /s) real(kind_phys), intent(in) :: qflx_rain_grnd(1) !rain on ground after interception (mm H2O/s) [+] real(kind_phys), intent(in) :: qflx_sub_snow(1) !sublimation rate from snow pack (mm H2O /s) [+] @@ -3862,7 +3888,7 @@ end subroutine SnowWater subroutine SnowCompaction(lbc, ubc, num_snowc, filter_snowc, &!i snl,imelt,frac_iceold,t_soisno, &!i - h2osoi_ice,h2osoi_liq, &!i + h2osoi_ice,h2osoi_liq,dtime, &!i dz) !i&o @@ -3896,6 +3922,7 @@ subroutine SnowCompaction(lbc, ubc, num_snowc, filter_snowc, &!i integer, intent(in) :: filter_snowc(ubc-lbc+1) ! column filter for snow points integer, intent(in) :: snl(1) !number of snow layers integer, intent(in) :: imelt(1,-nlevsnow+1:nlevsoil) !flag for melting (=1), freezing (=2), Not=0 + real(kind_phys), intent(in) :: dtime real(kind_phys), intent(in) :: frac_iceold(1,-nlevsnow+1:nlevsoil) !fraction of ice relative to the tot water real(kind_phys), intent(in) :: t_soisno(1,-nlevsnow+1:nlevsoil) !soil temperature (Kelvin) real(kind_phys), intent(in) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) !ice lens (kg/m2) @@ -4990,8 +5017,105 @@ subroutine MoninObukIni (ur, thv, dthv, zldis, z0m, um, obu) end subroutine MoninObukIni + !> \section arg_table_clm_lake_init Argument Table + !! \htmlinclude clm_lake_init.html + !! + subroutine clm_lake_init(con_pi,karman,con_g,con_sbc,con_t0c,rhowater,con_csol,con_cliq, & + con_hfus,con_hvap,con_rd,con_cp,rhoice,errmsg,errflg) + implicit none + real(kind_phys), intent(in) :: con_pi,karman,con_g,con_sbc,con_t0c, & + rhowater,con_csol,con_cliq, con_hfus,con_hvap,con_rd,con_cp,rhoice + INTEGER, INTENT(OUT) :: errflg + CHARACTER(*), INTENT(OUT) :: errmsg + integer :: i, j + + if(LAKEDEBUG) then + write(0,*) 'clm_lake_init' + endif + + errflg=0 + errmsg='' + + pi = con_pi + vkc = karman + grav = con_g + sb = con_sbc + tfrz = con_t0c + denh2o = rhowater + denice = rhoice + cpice = con_csol + cpliq = con_cliq + hfus = con_hfus + hvap = con_hvap + hsub = con_hfus+con_hvap + rair = con_rd + cpair = con_cp + + ! dzlak(1) = 0.1_kind_phys + ! dzlak(2) = 1._kind_phys + ! dzlak(3) = 2._kind_phys + ! dzlak(4) = 3._kind_phys + ! dzlak(5) = 4._kind_phys + ! dzlak(6) = 5._kind_phys + ! dzlak(7) = 7._kind_phys + ! dzlak(8) = 7._kind_phys + ! dzlak(9) = 10.45_kind_phys + ! dzlak(10)= 10.45_kind_phys + ! + ! zlak(1) = 0.05_kind_phys + ! zlak(2) = 0.6_kind_phys + ! zlak(3) = 2.1_kind_phys + ! zlak(4) = 4.6_kind_phys + ! zlak(5) = 8.1_kind_phys + ! zlak(6) = 12.6_kind_phys + ! zlak(7) = 18.6_kind_phys + ! zlak(8) = 25.6_kind_phys + ! zlak(9) = 34.325_kind_phys + ! zlak(10)= 44.775_kind_phys + dzlak(1) = 0.1_kind_phys + dzlak(2) = 0.1_kind_phys + dzlak(3) = 0.1_kind_phys + dzlak(4) = 0.1_kind_phys + dzlak(5) = 0.1_kind_phys + dzlak(6) = 0.1_kind_phys + dzlak(7) = 0.1_kind_phys + dzlak(8) = 0.1_kind_phys + dzlak(9) = 0.1_kind_phys + dzlak(10)= 0.1_kind_phys + + zlak(1) = 0.05_kind_phys + zlak(2) = 0.15_kind_phys + zlak(3) = 0.25_kind_phys + zlak(4) = 0.35_kind_phys + zlak(5) = 0.45_kind_phys + zlak(6) = 0.55_kind_phys + zlak(7) = 0.65_kind_phys + zlak(8) = 0.75_kind_phys + zlak(9) = 0.85_kind_phys + zlak(10)= 0.95_kind_phys + + ! "0" refers to soil surface and "nlevsoil" refers to the bottom of model soil + + do j = 1, nlevsoil + zsoi(j) = scalez*(exp(0.5_kind_phys*(j-0.5_kind_phys))-1._kind_phys) !node depths + enddo + + dzsoi(1) = 0.5_kind_phys*(zsoi(1)+zsoi(2)) !thickness b/n two interfaces + do j = 2,nlevsoil-1 + dzsoi(j)= 0.5_kind_phys*(zsoi(j+1)-zsoi(j-1)) + enddo + dzsoi(nlevsoil) = zsoi(nlevsoil)-zsoi(nlevsoil-1) + + zisoi(0) = 0._kind_phys + do j = 1, nlevsoil-1 + zisoi(j) = 0.5_kind_phys*(zsoi(j)+zsoi(j+1)) !interface depths + enddo + zisoi(nlevsoil) = zsoi(nlevsoil) + 0.5_kind_phys*dzsoi(nlevsoil) + + end subroutine clm_lake_init + ! Some fields in lakeini are not available until runtime, so this cannot be in a CCPP init routine. - SUBROUTINE lakeini( ISLTYP, gt0, SNOW, & !i + SUBROUTINE lakeini(kdt, ISLTYP, gt0, SNOW, & !i restart, lakedepth_default, & lakedepth2d, savedtke12d, snowdp2d, h2osno2d, & !o snl2d, t_grnd2d, t_lake3d, lake_icefrac3d, & @@ -5016,11 +5140,11 @@ SUBROUTINE lakeini( ISLTYP, gt0, SNOW, INTEGER, INTENT(OUT) :: errflg CHARACTER(*), INTENT(OUT) :: errmsg - INTEGER , INTENT (IN) :: im, me, master, km + INTEGER , INTENT (IN) :: im, me, master, km, kdt REAL(KIND_PHYS), INTENT(IN) :: xice_threshold, con_g, con_rd REAL(KIND_PHYS), DIMENSION(IM), INTENT(IN):: XICE,TG3 REAL(KIND_PHYS), DIMENSION(IM), INTENT(IN):: tsfc - INTEGER, DIMENSION(IM) ,INTENT(INOUT) :: clm_lake_initialized + REAL(KIND_PHYS), DIMENSION(IM) ,INTENT(INOUT) :: clm_lake_initialized integer, dimension(IM), intent(in) :: use_lake_model !INTEGER , INTENT (IN) :: lakeflag @@ -5079,7 +5203,6 @@ SUBROUTINE lakeini( ISLTYP, gt0, SNOW, real(kind_phys),dimension(1:im ) :: clay2d ! temporary real(kind_phys),dimension(1:im ) :: sand2d ! temporary - real(kind_phys),parameter :: scalez = 0.025_kind_phys ! Soil layer thickness discretization (m) logical,parameter :: arbinit = .false. real(kind_phys),parameter :: defval = -999.0 integer :: isl @@ -5094,83 +5217,30 @@ SUBROUTINE lakeini( ISLTYP, gt0, SNOW, used_lakedepth_default=0 - if(LAKEDEBUG .and. me==0) then - write(0,*) 'clm_lake_init' - endif - errmsg = '' errflg = 0 - !IF ( RESTART ) RETURN <--- should be handled by clm_lake_initialized - - init_const: if(sum(clm_lake_initialized(1:im))==0 .and. any(use_lake_model/=0)) then - - ! dzlak(1) = 0.1_kind_phys - ! dzlak(2) = 1._kind_phys - ! dzlak(3) = 2._kind_phys - ! dzlak(4) = 3._kind_phys - ! dzlak(5) = 4._kind_phys - ! dzlak(6) = 5._kind_phys - ! dzlak(7) = 7._kind_phys - ! dzlak(8) = 7._kind_phys - ! dzlak(9) = 10.45_kind_phys - ! dzlak(10)= 10.45_kind_phys - ! - ! zlak(1) = 0.05_kind_phys - ! zlak(2) = 0.6_kind_phys - ! zlak(3) = 2.1_kind_phys - ! zlak(4) = 4.6_kind_phys - ! zlak(5) = 8.1_kind_phys - ! zlak(6) = 12.6_kind_phys - ! zlak(7) = 18.6_kind_phys - ! zlak(8) = 25.6_kind_phys - ! zlak(9) = 34.325_kind_phys - ! zlak(10)= 44.775_kind_phys - dzlak(1) = 0.1_kind_phys - dzlak(2) = 0.1_kind_phys - dzlak(3) = 0.1_kind_phys - dzlak(4) = 0.1_kind_phys - dzlak(5) = 0.1_kind_phys - dzlak(6) = 0.1_kind_phys - dzlak(7) = 0.1_kind_phys - dzlak(8) = 0.1_kind_phys - dzlak(9) = 0.1_kind_phys - dzlak(10)= 0.1_kind_phys - - zlak(1) = 0.05_kind_phys - zlak(2) = 0.15_kind_phys - zlak(3) = 0.25_kind_phys - zlak(4) = 0.35_kind_phys - zlak(5) = 0.45_kind_phys - zlak(6) = 0.55_kind_phys - zlak(7) = 0.65_kind_phys - zlak(8) = 0.75_kind_phys - zlak(9) = 0.85_kind_phys - zlak(10)= 0.95_kind_phys - - ! "0" refers to soil surface and "nlevsoil" refers to the bottom of model soil - - do j = 1, nlevsoil - zsoi(j) = scalez*(exp(0.5_kind_phys*(j-0.5_kind_phys))-1._kind_phys) !node depths - enddo - - dzsoi(1) = 0.5_kind_phys*(zsoi(1)+zsoi(2)) !thickness b/n two interfaces - do j = 2,nlevsoil-1 - dzsoi(j)= 0.5_kind_phys*(zsoi(j+1)-zsoi(j-1)) - enddo - dzsoi(nlevsoil) = zsoi(nlevsoil)-zsoi(nlevsoil-1) - - zisoi(0) = 0._kind_phys - do j = 1, nlevsoil-1 - zisoi(j) = 0.5_kind_phys*(zsoi(j)+zsoi(j+1)) !interface depths - enddo - zisoi(nlevsoil) = zsoi(nlevsoil) + 0.5_kind_phys*dzsoi(nlevsoil) - endif init_const - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DO i=1,im - if(use_lake_model(i)==0 .or. clm_lake_initialized(i)>0) then + if(use_lake_model(i)==0) then + cycle + endif + + if(kdt<2) then + ! To handle restarts with bad lakedepth2d + if ( use_lakedepth ) then + if (lakedepth2d(i) <= 0.0) then + lakedepth2d(i) = lakedepth_default + used_lakedepth_default = used_lakedepth_default+1 + endif + else + lakedepth2d(i) = lakedepth_default + used_lakedepth_default = used_lakedepth_default+1 + endif + endif + + if(clm_lake_initialized(i)>0) then cycle endif @@ -5204,15 +5274,6 @@ SUBROUTINE lakeini( ISLTYP, gt0, SNOW, lake_icefrac3d(i,:) = 0.0 h2osoi_vol3d(i,:) = 0.0 snl2d(i) = 0.0 - if ( use_lakedepth ) then - if (lakedepth2d(i) <= 0.0) then - lakedepth2d(i) = lakedepth_default - used_lakedepth_default = used_lakedepth_default+1 - endif - else - lakedepth2d(i) = lakedepth_default - used_lakedepth_default = used_lakedepth_default+1 - endif ENDDO @@ -5238,6 +5299,8 @@ SUBROUTINE lakeini( ISLTYP, gt0, SNOW, do k = 1,nlevsoil sand3d(i,k) = sand(isl) clay3d(i,k) = clay(isl) + + ! Cannot continue if either of these checks fail. if(clay3d(i,k)>0 .and. clay3d(i,k)<1) then write(message,*) 'bad clay3d ',clay3d(i,k) write(0,'(A)') trim(message) @@ -5277,11 +5340,6 @@ SUBROUTINE lakeini( ISLTYP, gt0, SNOW, watopt3d(i,k) = watsat3d(i,k) * (158490._kind_phys/sucsat3d(i,k)) ** (-1._kind_phys/bsw3d(i,k)) end do if (lakedepth2d(i) == spval) then - if(LAKEDEBUG) then - errmsg='should not get here: lakedepth2d is spval ' - errflg=1 - return - endif lakedepth2d(i) = zlak(nlevlake) + 0.5_kind_phys*dzlak(nlevlake) z_lake3d(i,1:nlevlake) = zlak(1:nlevlake) dz_lake3d(i,1:nlevlake) = dzlak(1:nlevlake) @@ -5423,7 +5481,7 @@ SUBROUTINE lakeini( ISLTYP, gt0, SNOW, do k = -nlevsnow+1, 0 if (k > snl2d(i)) then - h2osoi_ice3d(i,k) = dz3d(i,k)*bdsno + h2osoi_ice3d(i,k) = dz3d(i,k)*snow_bd h2osoi_liq3d(i,k) = 0._kind_phys end if end do diff --git a/physics/clm_lake.meta b/physics/clm_lake.meta index 5f2f6db3f..9fd286afd 100644 --- a/physics/clm_lake.meta +++ b/physics/clm_lake.meta @@ -439,7 +439,8 @@ long_name = set to true in clm_lake_run after likeini is called, as a workaround for ccpp limitation units = flag dimensions = (horizontal_loop_extent) - type = integer + type = real + kind = kind_phys intent = inout [isltyp] standard_name = soil_type_classification @@ -609,7 +610,7 @@ type = real kind = kind_phys intent = inout -[T_snow] +[lake_t_snow] standard_name = temperature_of_snow_on_lake long_name = the temperature of snow on a lake units = K @@ -617,7 +618,7 @@ type = real kind = kind_phys intent = inout -[T_ice] +[tisfc] standard_name = surface_skin_temperature_over_ice long_name = surface skin temperature over ice units = K @@ -663,6 +664,137 @@ dimensions = () type = integer intent = in +[icy] + standard_name = flag_nonzero_sea_ice_surface_fraction + long_name = flag indicating presence of some sea ice surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = inout +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out + +######################################################################## +[ccpp-arg-table] + name = clm_lake_init + type = scheme +[con_pi] + standard_name = pi + long_name = ratio of a circle's circumference to its diameter + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[karman] + standard_name = von_karman_constant + long_name = Von Karman constant + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_sbc] + standard_name = stefan_boltzmann_constant + long_name = Stefan-Boltzmann constant + units = W m-2 K-4 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_t0c] + standard_name = temperature_at_zero_celsius + long_name = temperature at 0 degree Celsius + units = K + dimensions = () + type = real + kind = kind_phys + intent = in +[rhowater] + standard_name = fresh_liquid_water_density_at_0c + long_name = density of liquid water + units = kg m-3 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_csol] + standard_name = specific_heat_of_ice_at_constant_pressure + long_name = specific heat of ice at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_cliq] + standard_name = specific_heat_of_liquid_water_at_constant_pressure + long_name = specific heat of liquid water at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_hfus] + standard_name = latent_heat_of_fusion_of_water_at_0C + long_name = latent heat of fusion + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_hvap] + standard_name = latent_heat_of_vaporization_of_water_at_0C + long_name = latent heat of evaporation/sublimation + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rd] + standard_name = gas_constant_of_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[rhoice] + standard_name = density_of_ice_on_lake + long_name = density of ice on a lake + units = kg m-3 + dimensions = () + type = real + kind = kind_phys + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/physcons.F90 b/physics/physcons.F90 index 41d37491a..a8792eed3 100644 --- a/physics/physcons.F90 +++ b/physics/physcons.F90 @@ -139,6 +139,7 @@ module physcons real(kind=kind_phys),parameter:: rhowater = 1000._kind_phys !< density of water (kg/m^3) real(kind=kind_phys),parameter:: rhosnow = 100._kind_phys !< density of snow (kg/m^3) real(kind=kind_phys),parameter:: rhoair = 1.28_kind_phys !< density of air near surface (kg/m^3) + real(kind=kind_phys),parameter:: rhoice = 0.917e3_kind_phys !< density of ice on lake (kg/m^3) ! Decorrelation length constant (km) for iovr = 4 or 5 and idcor = 0 real(kind=kind_phys),parameter:: decorr_con = 2.50_kind_phys diff --git a/physics/sfc_diag.f b/physics/sfc_diag.f index c21d3a989..31bd4aaf2 100644 --- a/physics/sfc_diag.f +++ b/physics/sfc_diag.f @@ -24,6 +24,8 @@ end subroutine sfc_diag_finalize subroutine sfc_diag_run & & (im,grav,cp,eps,epsm1,ps,u1,v1,t1,q1,prslki, & & evap,fm,fh,fm10,fh2,tskin,qsurf,thsfc_loc, & + & use_lake_model,iopt_lake,iopt_lake_clm, & + & lake_t2m,lake_q2m, & & f10m,u10m,v10m,t2m,q2m,errmsg,errflg & & ) ! @@ -31,14 +33,16 @@ subroutine sfc_diag_run & use funcphys, only : fpvs implicit none ! - integer, intent(in) :: im + integer, intent(in) :: im, iopt_lake, iopt_lake_clm logical, intent(in) :: thsfc_loc ! Flag for reference pot. temp. real(kind=kind_phys), intent(in) :: grav,cp,eps,epsm1 real(kind=kind_phys), dimension(:), intent(in) :: & & ps, u1, v1, t1, q1, tskin, & & qsurf, prslki, evap, fm, fh, fm10, fh2 real(kind=kind_phys), dimension(:), intent(out) :: & - & f10m, u10m, v10m, t2m, q2m + & f10m, u10m, v10m, t2m, q2m, lake_t2m, & + & lake_q2m + integer, dimension(:), intent(in) :: use_lake_model character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg ! @@ -48,6 +52,7 @@ subroutine sfc_diag_run & integer :: k,i ! real(kind=kind_phys) :: fhi, qss, wrk + ! real(kind=kind_phys) sig2k, fhi, qss ! ! real, parameter :: g=grav @@ -69,29 +74,32 @@ subroutine sfc_diag_run & ! f10m(i) = min(f10m(i),1.) u10m(i) = f10m(i) * u1(i) v10m(i) = f10m(i) * v1(i) - fhi = fh2(i) / fh(i) -! t2m(i) = tskin(i)*(1. - fhi) + t1(i) * prslki(i) * fhi -! sig2k = 1. - (grav+grav) / (cp * t2m(i)) -! t2m(i) = t2m(i) * sig2k - wrk = 1.0 - fhi - - - if(thsfc_loc) then ! Use local potential temperature - t2m(i) = tskin(i)*wrk + t1(i)*prslki(i)*fhi - (grav+grav)/cp - else ! Use potential temperature referenced to 1000 hPa - t2m(i) = tskin(i)*wrk + t1(i)*fhi - (grav+grav)/cp - endif + if(use_lake_model(i)>0 .and. iopt_lake==iopt_lake_clm) then + t2m(i) = lake_t2m(i) + q2m(i) = lake_q2m(i) + else + fhi = fh2(i) / fh(i) +! t2m(i) = tskin(i)*(1. - fhi) + t1(i) * prslki(i) * fhi +! sig2k = 1. - (grav+grav) / (cp * t2m(i)) +! t2m(i) = t2m(i) * sig2k + wrk = 1.0 - fhi + if(thsfc_loc) then ! Use local potential temperature + t2m(i) = tskin(i)*wrk + t1(i)*prslki(i)*fhi - (grav+grav)/cp + else ! Use potential temperature referenced to 1000 hPa + t2m(i) = tskin(i)*wrk + t1(i)*fhi - (grav+grav)/cp + endif - if(evap(i) >= 0.) then ! for evaporation>0, use inferred qsurf to deduce q2m - q2m(i) = qsurf(i)*wrk + max(qmin,q1(i))*fhi - else ! for dew formation, use saturated q at tskin - qss = fpvs(tskin(i)) - qss = eps * qss / (ps(i) + epsm1 * qss) - q2m(i) = qss*wrk + max(qmin,q1(i))*fhi + if(evap(i) >= 0.) then ! for evaporation>0, use inferred qsurf to deduce q2m + q2m(i) = qsurf(i)*wrk + max(qmin,q1(i))*fhi + else ! for dew formation, use saturated q at tskin + qss = fpvs(tskin(i)) + qss = eps * qss / (ps(i) + epsm1 * qss) + q2m(i) = qss*wrk + max(qmin,q1(i))*fhi + endif + qss = fpvs(t2m(i)) + qss = eps * qss / (ps(i) + epsm1 * qss) + q2m(i) = min(q2m(i),qss) endif - qss = fpvs(t2m(i)) - qss = eps * qss / (ps(i) + epsm1 * qss) - q2m(i) = min(q2m(i),qss) enddo return diff --git a/physics/sfc_diag.meta b/physics/sfc_diag.meta index dd3bf79b8..3bbb5de03 100644 --- a/physics/sfc_diag.meta +++ b/physics/sfc_diag.meta @@ -157,6 +157,43 @@ dimensions = () type = logical intent = in +[use_lake_model] + standard_name = flag_for_using_lake_model + long_name = flag indicating lake points using a lake model + units = flag + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[iopt_lake] + standard_name = control_for_lake_model_selection + long_name = control for lake model selection + units = 1 + dimensions = () + type = integer + intent = in +[iopt_lake_clm] + standard_name = clm_lake_model_control_selection_value + long_name = value that indicates clm lake model in the control for lake model selection + units = 1 + dimensions = () + type = integer + intent = in +[lake_t2m] + standard_name = temperature_at_2m_from_clm_lake + long_name = temperature at 2m from clm lake + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[lake_q2m] + standard_name = specific_humidity_at_2m_from_clm_lake + long_name = specific humidity at 2m from clm lake + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [f10m] standard_name = ratio_of_wind_at_surface_adjacent_layer_to_wind_at_10m long_name = ratio of fm10 and fm From f885b9cdc92b78765afbdae66c04ca48603607a7 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Wed, 17 Aug 2022 10:32:10 -0600 Subject: [PATCH 019/380] Remove dependency on physcons and physparam in radiation_surface.f. Provided as ccpp interstitials. --- CMakeLists.txt | 2 +- physics/GFS_cloud_diagnostics.F90 | 1 - physics/GFS_cloud_diagnostics.meta | 1 + physics/GFS_radiation_surface.F90 | 20 +++++------ physics/GFS_radiation_surface.meta | 31 +++++++++++++++++ physics/GFS_surface_composites_pre.F90 | 1 - physics/GFS_surface_composites_pre.meta | 2 +- physics/physparam.f | 19 ---------- physics/radiation_surface.f | 46 ++++++++++++------------- 9 files changed, 66 insertions(+), 57 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index d14778b06..242275411 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -195,7 +195,7 @@ set_target_properties(ccpp_physics PROPERTIES VERSION ${PROJECT_VERSION} target_include_directories(ccpp_physics PUBLIC $) -target_link_libraries(ccpp_physics PUBLIC w3emc::w3emc_d NetCDF::NetCDF_Fortran) +target_link_libraries(ccpp_physics PUBLIC w3nco::w3nco_d NetCDF::NetCDF_Fortran) # Define where to install the library install(TARGETS ccpp_physics diff --git a/physics/GFS_cloud_diagnostics.F90 b/physics/GFS_cloud_diagnostics.F90 index 0e3f730e5..01ecd7452 100644 --- a/physics/GFS_cloud_diagnostics.F90 +++ b/physics/GFS_cloud_diagnostics.F90 @@ -3,7 +3,6 @@ module GFS_cloud_diagnostics use machine, only: kind_phys - use physparam, only: icldflg use module_radiation_clouds, only: gethml ! Module parameters (imported directly from radiation_cloud.f) diff --git a/physics/GFS_cloud_diagnostics.meta b/physics/GFS_cloud_diagnostics.meta index dd88bbc46..ded38a1e7 100644 --- a/physics/GFS_cloud_diagnostics.meta +++ b/physics/GFS_cloud_diagnostics.meta @@ -1,6 +1,7 @@ [ccpp-table-properties] name = GFS_cloud_diagnostics type = scheme + dependencies = machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_radiation_surface.F90 b/physics/GFS_radiation_surface.F90 index ec7795c10..01c37156d 100644 --- a/physics/GFS_radiation_surface.F90 +++ b/physics/GFS_radiation_surface.F90 @@ -17,14 +17,15 @@ module GFS_radiation_surface !> \section arg_table_GFS_radiation_surface_init Argument Table !! \htmlinclude GFS_radiation_surface_init.html !! - subroutine GFS_radiation_surface_init (me, ialb, iems, errmsg, errflg) + subroutine GFS_radiation_surface_init (me, ialb, iems, semis_file, con_pi, errmsg, errflg) - use physparam, only: ialbflg, iemsflg use module_radiation_surface, only: sfc_init implicit none integer, intent(in) :: me, ialb, iems + character(len=26), intent(in) :: semis_file + real(kind_phys), intent(in) :: con_pi character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -32,16 +33,13 @@ subroutine GFS_radiation_surface_init (me, ialb, iems, errmsg, errflg) errmsg = '' errflg = 0 - ialbflg= ialb ! surface albedo control flag - iemsflg= iems ! surface emissivity control flag - if ( me == 0 ) then print *,'In GFS_radiation_surface_init, before calling sfc_init' print *,'ialb=',ialb,' iems=',iems end if ! Call surface initialization routine - call sfc_init ( me, errmsg, errflg ) + call sfc_init ( me, ialb, iems, semis_file, con_pi, errmsg, errflg ) end subroutine GFS_radiation_surface_init @@ -50,13 +48,13 @@ end subroutine GFS_radiation_surface_init !! \htmlinclude GFS_radiation_surface_run.html !! subroutine GFS_radiation_surface_run ( & - im, frac_grid, lslwr, lsswr, lsm, lsm_noahmp, lsm_ruc, & + ialb, im, frac_grid, lslwr, lsswr, lsm, lsm_noahmp, lsm_ruc, & xlat, xlon, slmsk, lndp_type, n_var_lndp, sfc_alb_pert, & lndp_var_list, lndp_prt_list, landfrac, snodl, snodi, sncovr, & sncovr_ice, fice, zorl, hprime, tsfg, tsfa, tisfc, coszen, & cplice, min_seaice, min_lakeice, lakefrac, use_flake, & alvsf, alnsf, alvwf, alnwf, facsf, facwf, & - semis_lnd, semis_ice, semis_wat, snoalb, use_cice_alb, & + semis_lnd, semis_ice, semis_wat, snoalb, use_cice_alb, con_ttp, & albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, & albdvis_ice, albdnir_ice, albivis_ice, albinir_ice, & semisbase, semis, sfcalb, sfc_alb_dif, errmsg, errflg) @@ -67,10 +65,10 @@ subroutine GFS_radiation_surface_run ( & implicit none - integer, intent(in) :: im + integer, intent(in) :: im, ialb logical, intent(in) :: frac_grid, lslwr, lsswr, use_cice_alb, cplice integer, intent(in) :: lsm, lsm_noahmp, lsm_ruc, lndp_type, n_var_lndp - real(kind=kind_phys), intent(in) :: min_seaice, min_lakeice + real(kind=kind_phys), intent(in) :: min_seaice, min_lakeice, con_ttp logical, dimension(:), intent(in) :: use_flake real(kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, slmsk, & @@ -184,7 +182,7 @@ subroutine GFS_radiation_surface_run ( & alvsf, alnsf, alvwf, alnwf, facsf, facwf, fice, tisfc, & albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, & albdvis_ice, albdnir_ice, albivis_ice, albinir_ice, & - IM, sfc_alb_pert, lndp_alb, fracl, fraco, fraci, icy, & ! --- inputs + IM, sfc_alb_pert, lndp_alb, fracl, fraco, fraci, icy, ialb, con_ttp, & ! --- inputs sfcalb ) ! --- outputs !> -# Approximate mean surface albedo from vis- and nir- diffuse values. diff --git a/physics/GFS_radiation_surface.meta b/physics/GFS_radiation_surface.meta index 3fd851a40..8ad848446 100644 --- a/physics/GFS_radiation_surface.meta +++ b/physics/GFS_radiation_surface.meta @@ -28,6 +28,22 @@ dimensions = () type = integer intent = in +[semis_file] + standard_name = surface_emissivity_data_file + long_name = surface emissivity data file for radiation + units = none + dimensions = () + type = character + kind = len=26 + intent = in +[con_pi] + standard_name = pi + long_name = ratio of a circle's circumference to its diameter + units = none + dimensions = () + type = real + kind = kind_phys + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -55,6 +71,13 @@ dimensions = () type = integer intent = in +[ialb] + standard_name = control_for_surface_albedo + long_name = flag for using climatology alb, based on sfc type + units = flag + dimensions = () + type = integer + intent = in [frac_grid] standard_name = flag_for_fractional_landmask long_name = flag for fractional grid @@ -380,6 +403,14 @@ dimensions = () type = logical intent = in +[con_ttp] + standard_name = triple_point_temperature_of_water + long_name = triple point temperature of water + units = K + dimensions = () + type = real + kind = kind_phys + intent = in [albdvis_lnd] standard_name = surface_albedo_direct_visible_over_land long_name = direct surface albedo visible band over land diff --git a/physics/GFS_surface_composites_pre.F90 b/physics/GFS_surface_composites_pre.F90 index 734f1965b..a8b0a3112 100644 --- a/physics/GFS_surface_composites_pre.F90 +++ b/physics/GFS_surface_composites_pre.F90 @@ -4,7 +4,6 @@ module GFS_surface_composites_pre use machine, only: kind_phys - use physparam, only : iemsflg implicit none diff --git a/physics/GFS_surface_composites_pre.meta b/physics/GFS_surface_composites_pre.meta index e87af3e28..a0e30055f 100644 --- a/physics/GFS_surface_composites_pre.meta +++ b/physics/GFS_surface_composites_pre.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_surface_composites_pre type = scheme - dependencies = machine.F,physparam.f + dependencies = machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/physparam.f b/physics/physparam.f index b84bdd42f..880ed47f3 100644 --- a/physics/physparam.f +++ b/physics/physparam.f @@ -211,25 +211,6 @@ module physparam !> shallow convetion flag logical, save :: lsashal =.false. -! ............................................. ! -!>\name 2.5 For module radiation_surface -! ............................................. ! - -!> surface albedo scheme control flag -!!\n =0:vegetation type based climatological albedo scheme -!!\n =1:seasonal albedo derived from MODIS measurements - integer, save :: ialbflg = 0 - -!> surface emissivity scheme control flag -!!\n =0:black-body surface emissivity(=1.0) -!!\n =1:vegetation type based climatology emissivity(<1.0) -!!\n Opr GFS/CFS=1; see IEMS in run scripts - integer, save :: iemsflg = 0 - -!> external sfc emissivity data table: sfc_emissivity_idx.txt - character, save :: semis_file*26 - data semis_file / 'sfc_emissivity_idx.txt ' / - ! ............................................. ! !> \name 2.6 general purpose ! ............................................. ! diff --git a/physics/radiation_surface.f b/physics/radiation_surface.f index 664e7d453..dba4450e2 100644 --- a/physics/radiation_surface.f +++ b/physics/radiation_surface.f @@ -107,9 +107,7 @@ module module_radiation_surface !! \section arg_table_module_radiation_surface !! \htmlinclude module_radiation_surface.html !! - use physparam, only : ialbflg, iemsflg, semis_file, & - & kind_phys - use physcons, only : con_t0c, con_ttp, con_pi, con_tice + use machine, only : kind_phys use module_iounitdef, only : NIRADSF use surface_perturbation, only : ppfbet ! @@ -129,7 +127,7 @@ module module_radiation_surface real (kind=kind_phys), parameter :: f_zero = 0.0 real (kind=kind_phys), parameter :: f_one = 1.0 real (kind=kind_phys), parameter :: epsln = 1.0e-6 - real (kind=kind_phys), parameter :: rad2dg = 180.0 / con_pi + real (kind=kind_phys) :: rad2dg integer, allocatable :: idxems(:,:) ! global surface emissivity index array integer :: iemslw = 1 ! global surface emissivity control flag set up in 'sfc_init' ! @@ -146,7 +144,7 @@ module module_radiation_surface !>\section gen_sfc_init sfc_init General Algorithm !----------------------------------- subroutine sfc_init & - & ( me, errmsg, errflg )! --- inputs/outputs: + & ( me, ialbflg, iemsflg, semis_file, con_pi, errmsg, errflg )! --- inputs/outputs: ! ! =================================================================== ! ! ! @@ -160,11 +158,7 @@ subroutine sfc_init & ! ==================== defination of variables ==================== ! ! ! ! inputs: ! -! me - print control flag ! -! ! -! outputs: (none) to module variables only ! -! ! -! external module variables: ! +! me - print control flag ! ! ialbflg - control flag for surface albedo schemes ! ! =1: use modis based surface albedo ! ! =2: use surface albedo from land model ! @@ -174,13 +168,18 @@ subroutine sfc_init & ! b:=1 use varying climtology sfc emiss (veg based) ! ! =2 use surface emissivity from land model ! ! ! +! outputs: (CCPP error handling) ! +! errmsg - CCPP error message ! +! errflg - CCPP error flag ! +! ! ! ==================== end of description ===================== ! ! implicit none ! --- inputs: - integer, intent(in) :: me - + integer, intent(in) :: me, ialbflg, iemsflg + real(kind=kind_phys), intent(in) :: con_pi + character(len=26), intent(in) :: semis_file ! --- outputs: ( none ) character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -196,10 +195,13 @@ subroutine sfc_init & errmsg = '' errflg = 0 ! + ! Module + rad2dg = 180.0 / con_pi + if ( me == 0 ) print *, VTAGSFC ! print out version tag !> - Initialization of surface albedo section -!! \n physparam::ialbflg +!! \n GFS_typedefs::ialbflg !! - = 1: using MODIS based land surface albedo for SW !! - = 2: using albedo from land model @@ -224,7 +226,7 @@ subroutine sfc_init & endif ! end if_ialbflg_block !> - Initialization of surface emissivity section -!! \n physparam::iemsflg +!! \n GFS_typedefs::iemsflg !! - = 1: input SFC emissivity type map from "semis_file" !! - = 2: input SFC emissivity from land model @@ -339,8 +341,8 @@ subroutine setalb & & alvsf,alnsf,alvwf,alnwf,facsf,facwf,fice,tisfc, & & lsmalbdvis, lsmalbdnir, lsmalbivis, lsmalbinir, & & icealbdvis, icealbdnir, icealbivis, icealbinir, & - & IMAX, albPpert, pertalb, fracl, fraco, fraci, icy, & - & sfcalb & ! --- outputs: + & IMAX, albPpert, pertalb, fracl, fraco, fraci, icy, ialbflg,& + & con_ttp, sfcalb & ! --- outputs: & ) ! =================================================================== ! @@ -387,6 +389,9 @@ subroutine setalb & ! fice (IMAX) - sea-ice fraction ! ! tisfc (IMAX) - sea-ice surface temperature ! ! IMAX - array horizontal dimension ! +! ialbflg - control flag for surface albedo schemes ! +! =1: use modis based surface albedo ! +! =2: use surface albedo from land model ! ! ! ! outputs: ! ! sfcalb(IMAX,NF_ALBD) ! @@ -395,17 +400,12 @@ subroutine setalb & ! ( :, 3) - uv+vis direct beam albedo ! ! ( :, 4) - uv+vis diffused albedo ! ! ! -! module internal control variables: ! -! ialbflg - =0 use the default climatology surface albedo ! -! =1 use modis retrieved albedo and input snow cover! -! for land areas ! -! ! ! ==================== end of description ===================== ! ! implicit none ! --- inputs - integer, intent(in) :: IMAX + integer, intent(in) :: IMAX, ialbflg integer, intent(in) :: lsm, lsm_noahmp, lsm_ruc logical, intent(in) :: use_cice_alb, frac_grid @@ -415,7 +415,7 @@ subroutine setalb & & alvsf, alnsf, alvwf, alnwf, facsf, facwf, fice, tisfc, & & icealbdvis, icealbdnir, icealbivis, icealbinir, & & sncovr, sncovr_ice, snoalb, albPpert ! sfc-perts, mgehne - real (kind=kind_phys), intent(in) :: pertalb ! sfc-perts, mgehne + real (kind=kind_phys), intent(in) :: pertalb, con_ttp! sfc-perts, mgehne real (kind=kind_phys), dimension(:), intent(in) :: & & fracl, fraco, fraci real (kind=kind_phys), dimension(:),intent(inout) :: & From 9f9ed2ab0f4c4ab054b8999697f57beff4af6219 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Wed, 17 Aug 2022 13:56:02 -0600 Subject: [PATCH 020/380] Remove dependency on physcons and physparam in radiation_gases.f. Provided as ccpp interstitials. --- physics/GFS_rrtmg_pre.F90 | 13 +-- physics/GFS_rrtmg_pre.meta | 7 ++ physics/GFS_rrtmg_setup.F90 | 85 ++++++++------- physics/GFS_rrtmg_setup.meta | 53 ++++++++++ physics/GFS_rrtmgp_pre.F90 | 10 +- physics/GFS_rrtmgp_pre.meta | 15 +++ physics/GFS_rrtmgp_setup.F90 | 29 +++--- physics/GFS_rrtmgp_setup.meta | 53 ++++++++++ physics/physparam.f | 13 --- physics/radiation_gases.f | 188 ++++++---------------------------- 10 files changed, 228 insertions(+), 238 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 9fd2a092c..57e0b4347 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -45,7 +45,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & clouds9, cldsa, cldfra, cldfra2d, lwp_ex,iwp_ex, lwp_fc,iwp_fc, & faersw1, faersw2, faersw3, faerlw1, faerlw2, faerlw3, alpha, & aero_dir_fdb, smoke_ext, dust_ext, & - spp_wts_rad, spp_rad, rrfs_smoke_band, top_at_1, errmsg, errflg) + spp_wts_rad, spp_rad, rrfs_smoke_band, top_at_1, ico2, errmsg, errflg) use machine, only: kind_phys @@ -111,7 +111,8 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & idcor_con, & idcor_hogan, & idcor_oreopoulos, & - rrfs_smoke_band ! Band number for rrfs-smoke dust and smoke + rrfs_smoke_band, & ! Band number for rrfs-smoke dust and smoke + ico2 ! Flag for co2 source used in radiation integer, intent(in) :: ntdu1, ntdu2, ntdu3, ntdu4, ntdu5, ntss1, ntss2, ntss3, & ntss4, ntss5, ntsu, ntbcb, ntbcl, ntocb, ntocl, ntchm @@ -422,8 +423,8 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo enddo else ! climatological ozone - call getozn (prslk1, xlat, im, lmk, & ! --- inputs - olyr) ! --- outputs + call getozn (prslk1, xlat, im, lmk, top_at_1, & ! --- inputs + olyr) ! --- outputs endif ! end_if_ntoz !> - Call coszmn(), to compute cosine of zenith angle (only when SW is called) @@ -447,8 +448,8 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & ! --- ... set up non-prognostic gas volume mixing ratioes - call getgases (plvl, xlon, xlat, IM, LMK, & ! --- inputs - gasvmr) ! --- outputs + call getgases (plvl, xlon, xlat, IM, LMK, ico2, top_at_1,& ! --- inputs + con_pi, gasvmr) ! --- outputs !CCPP: re-assign gasvmr(:,:,NF_VGAS) to gasvmr_X(:,:) do k = 1, LMK diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 0c2240720..8fa020ec5 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -1343,6 +1343,13 @@ dimensions = () type = logical intent = out +[ico2] + standard_name = control_for_co2 + long_name = prescribed global mean value (old opernl) + units = flag + dimensions = () + type = integer + intent = in [aero_dir_fdb] standard_name = do_smoke_aerosol_direct_feedback long_name = flag for smoke and dust radiation feedback diff --git a/physics/GFS_rrtmg_setup.F90 b/physics/GFS_rrtmg_setup.F90 index a8d829e12..f83f53f01 100644 --- a/physics/GFS_rrtmg_setup.F90 +++ b/physics/GFS_rrtmg_setup.F90 @@ -6,7 +6,7 @@ !> @{ module GFS_rrtmg_setup - use physparam, only : ictmflg, ico2flg, ioznflg, icldflg, & + use physparam, only : icldflg, & & iovrRad=>iovr, lcrick , lcnorm , lnoprec, & & isubcsw, isubclw, ivflip , ipsd0, & & iswcliq @@ -34,7 +34,7 @@ module GFS_rrtmg_setup !> control flag for the first time of reading climatological ozone data !! (set/reset in subroutines radinit/radupdate, it is used only if the - !! control parameter ioznflg=0) + !! control parameter ntoz=0) logical :: loz1st = .true. contains @@ -50,7 +50,8 @@ subroutine GFS_rrtmg_setup_init ( & norad_precip, idate, iflip, & do_RRTMGP, me, lalw1bd, iaermdl, iaerflg, & aeros_file, con_pi, con_t0c, con_c, con_boltz, & - con_plnk, con_solr_2008, con_solr_2002, errmsg, errflg) + con_plnk, con_solr_2008, con_solr_2002, co2usr_file,& + co2cyc_file, errmsg, errflg) ! ================= subprogram documentation block ================ ! ! ! ! subprogram: GFS_rrtmg_setup_init - a subprogram to initialize radiation ! @@ -171,7 +172,7 @@ subroutine GFS_rrtmg_setup_init ( & integer, intent(in) :: iflip logical, intent(in) :: do_RRTMGP, lalw1bd integer, intent(in) :: me - character(len=26),intent(in) :: aeros_file, solar_file + character(len=26),intent(in) :: aeros_file, solar_file, co2usr_file, co2cyc_file real(kind_phys), intent(in) :: con_pi,con_t0c,con_c,con_boltz,con_plnk,con_solr_2008,con_solr_2002 character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -189,10 +190,6 @@ subroutine GFS_rrtmg_setup_init ( & return end if - ictmflg= ictm ! data ic time/date control flag - ico2flg= ico2 ! co2 data source control flag - ioznflg= ntoz ! ozone data source control flag - if ( ictm==0 .or. ictm==-2 ) then iaerflg = mod(iaer, 100) ! no volcanic aerosols for clim hindcast else @@ -246,12 +243,11 @@ subroutine GFS_rrtmg_setup_init ( & endif call radinit & -! --- inputs: & ( si, levr, imp_physics, me, iaermdl, iaerflg, lalw1bd, & & aeros_file, con_pi, con_t0c, con_c, con_boltz, con_plnk, & - & isol, solar_file, con_solr_2008, con_solr_2002, errmsg, errflg ) -! --- outputs: -! ( none ) + & isol, solar_file, con_solr_2008, con_solr_2002, & + & co2usr_file, co2cyc_file, ico2, ictm, ntoz, errmsg, errflg ) + if ( me == 0 ) then print *,' Radiation sub-cloud initial seed =',ipsd0, & @@ -268,9 +264,9 @@ end subroutine GFS_rrtmg_setup_init !> \section arg_table_GFS_rrtmg_setup_timestep_init Argument Table !! \htmlinclude GFS_rrtmg_setup_timestep_init.html !! - subroutine GFS_rrtmg_setup_timestep_init ( & - idate, jdate, deltsw, deltim, lsswr, me, iaermdl, & - iaerflg, isol, aeros_file, slag, sdec, cdec, solcon, con_pi, errmsg, errflg) + subroutine GFS_rrtmg_setup_timestep_init (idate, jdate, deltsw, deltim, & + lsswr, me, iaermdl, iaerflg, isol, aeros_file, slag, sdec, cdec, & + solcon, con_pi, co2dat_file, co2gbl_file, ictm, ico2, ntoz, errmsg, errflg) implicit none @@ -282,8 +278,8 @@ subroutine GFS_rrtmg_setup_timestep_init ( & real(kind=kind_phys), intent(in) :: con_pi logical, intent(in) :: lsswr integer, intent(in) :: me - integer, intent(in) :: iaermdl, iaerflg, isol - character(len=26), intent(in) :: aeros_file + integer, intent(in) :: iaermdl, iaerflg, isol, ictm, ico2, ntoz + character(len=26), intent(in) :: aeros_file, co2dat_file, co2gbl_file real(kind=kind_phys), intent(out) :: slag real(kind=kind_phys), intent(out) :: sdec real(kind=kind_phys), intent(out) :: cdec @@ -302,8 +298,8 @@ subroutine GFS_rrtmg_setup_timestep_init ( & errmsg = '' errflg = 0 - call radupdate(idate,jdate,deltsw,deltim,lsswr,me,iaermdl,& - iaerflg,isol,aeros_file,slag,sdec,cdec,solcon,con_pi,errflg,errmsg) + call radupdate(idate,jdate,deltsw,deltim,lsswr,me,iaermdl, iaerflg,isol,aeros_file,& + slag,sdec,cdec,solcon,con_pi,co2dat_file,co2gbl_file,ictm,ico2,ntoz,errflg,errmsg) end subroutine GFS_rrtmg_setup_timestep_init @@ -335,7 +331,8 @@ end subroutine GFS_rrtmg_setup_finalize subroutine radinit( si, NLAY, imp_physics, me, iaermdl, iaerflg, lalw1bd, & aeros_file, con_pi, con_t0c, con_c, con_boltz, con_plnk, isol, & - solar_file, con_solr_2008, con_solr_2002, errmsg, errflg) + solar_file, con_solr_2008, con_solr_2002, co2usr_file, co2cyc_file, & + ico2, ictm, ntoz, errmsg, errflg) !................................... ! --- inputs: @@ -379,11 +376,11 @@ subroutine radinit( si, NLAY, imp_physics, me, iaermdl, iaerflg, lalw1bd, & ! =2 compute tropspheric aero in multi bands for lw ! ! c:=0 no topospheric aerosol in sw radiation ! ! =1 include tropspheric aerosols for sw ! -! ico2flg : co2 data source control flag ! +! ico2 : co2 data source control flag ! ! =0: use prescribed global mean co2 (old oper) ! ! =1: use observed co2 annual mean value only ! ! =2: use obs co2 monthly data with 2-d variation ! -! ictmflg : =yyyy#, external data ic time/date control flag ! +! ictm : =yyyy#, external data ic time/date control flag ! ! = -2: same as 0, but superimpose seasonal cycle ! ! from climatology data set. ! ! = -1: use user provided external data for the ! @@ -448,11 +445,11 @@ subroutine radinit( si, NLAY, imp_physics, me, iaermdl, iaerflg, lalw1bd, & implicit none ! --- inputs: - integer, intent(in) :: NLAY, me, imp_physics, iaermdl, iaerflg, isol + integer, intent(in) :: NLAY, me, imp_physics, iaermdl, iaerflg, isol, ico2, ictm, ntoz logical, intent(in) :: lalw1bd real (kind=kind_phys), intent(in) :: si(:), con_pi,con_t0c, con_c, & con_boltz, con_plnk, con_solr_2008, con_solr_2002 - character(len=26), intent(in) :: aeros_file, solar_file + character(len=26), intent(in) :: aeros_file, solar_file,co2usr_file, co2cyc_file ! --- outputs: (ccpp error handling) character(len=*), intent(out) :: errmsg @@ -464,7 +461,7 @@ subroutine radinit( si, NLAY, imp_physics, me, iaermdl, iaerflg, lalw1bd, & ! !> -# Set up control variables and external module variables in !! module physparam - loz1st = (ioznflg == 0) ! first-time clim ozone data read flag + loz1st = (ntoz == 0) ! first-time clim ozone data read flag month0 = 0 iyear0 = 0 monthd = 0 @@ -474,16 +471,16 @@ subroutine radinit( si, NLAY, imp_physics, me, iaermdl, iaerflg, lalw1bd, & print *,' NEW RADIATION PROGRAM STRUCTURES BECAME OPER. ', & & ' May 01 2007' print *, VTAGRAD !print out version tag - print *,' - Selected Control Flag settings: ICTMflg=',ictmflg, & - & ' ISOLar =',isol, ' ICO2flg=',ico2flg,' IAERflg=',iaerflg, & + print *,' - Selected Control Flag settings: ICTMflg=',ictm, & + & ' ISOLar =',isol, ' ICO2flg=',ico2,' IAERflg=',iaerflg, & & ' ICLDflg=',icldflg, & - & ' IMP_PHYSICS=',imp_physics,' IOZNflg=',ioznflg + & ' IMP_PHYSICS=',imp_physics,' IOZNflg=',ntoz print *,' IVFLIP=',ivflip,' IOVR=',iovrRad, & & ' ISUBCSW=',isubcsw,' ISUBCLW=',isubclw print *,' LCRICK=',lcrick,' LCNORM=',lcnorm,' LNOPREC=',lnoprec print *,' LTP =',ltp,', add extra top layer =',lextop - if ( ictmflg==0 .or. ictmflg==-2 ) then + if ( ictm==0 .or. ictm==-2 ) then print *,' Data usage is limited by initial condition!' print *,' No volcanic aerosols' endif @@ -544,13 +541,14 @@ subroutine radinit( si, NLAY, imp_physics, me, iaermdl, iaerflg, lalw1bd, & ! Initialization call sol_init ( me, isol, solar_file, con_solr_2008, con_solr_2002,& - con_pi ) ! astronomy initialization routine + con_pi ) ! astronomy initialization routine call aer_init ( NLAY, me, iaermdl, iaerflg, lalw1bd, aeros_file, con_pi, & - con_t0c, con_c, con_boltz, con_plnk, errflg, errmsg) ! aerosols initialization routine - call gas_init ( me, errflg, errmsg ) ! co2 and other gases initialization routine - call cld_init ( si, NLAY, imp_physics, me, errflg, errmsg) ! cloud initialization routine - call rlwinit ( me, errflg, errmsg ) ! lw RRTMG initialization routine - call rswinit ( me, errflg, errmsg ) ! sw RRTMG initialization routine + con_t0c, con_c, con_boltz, con_plnk, errflg, errmsg) ! aerosols initialization routine + call gas_init ( me, co2usr_file, co2cyc_file, ico2, ictm, ntoz, con_pi, & + errflg, errmsg) ! co2 and other gases initialization routine + call cld_init ( si, NLAY, imp_physics, me, errflg, errmsg) ! cloud initialization routine + call rlwinit ( me, errflg, errmsg ) ! lw RRTMG initialization routine + call rswinit ( me, errflg, errmsg ) ! sw RRTMG initialization routine ! return ! @@ -578,8 +576,8 @@ end subroutine radinit !> \section gen_radupdate General Algorithm !----------------------------------- subroutine radupdate( idate,jdate,deltsw,deltim,lsswr,me, iaermdl,& - & iaerflg, isol, aeros_file, slag,sdec,cdec,solcon, & - & con_pi, errflg,errmsg) + iaerflg, isol, aeros_file, slag,sdec,cdec,solcon, con_pi, & + co2dat_file,co2gbl_file, ictm, ico2, ntoz, errflg, errmsg) !................................... ! ================= subprogram documentation block ================ ! @@ -619,7 +617,7 @@ subroutine radupdate( idate,jdate,deltsw,deltim,lsswr,me, iaermdl,& ! = 2: use noaa ann-mean tsi tbl tim-scale with cycle apprx! ! = 3: use cmip5 ann-mean tsi tbl tim-scale with cycl apprx! ! = 4: use cmip5 mon-mean tsi tbl tim-scale with cycl apprx! -! ictmflg : =yyyy#, external data ic time/date control flag ! +! ictm : =yyyy#, external data ic time/date control flag ! ! = -2: same as 0, but superimpose seasonal cycle ! ! from climatology data set. ! ! = -1: use user provided external data for the ! @@ -647,9 +645,9 @@ subroutine radupdate( idate,jdate,deltsw,deltim,lsswr,me, iaermdl,& implicit none ! --- inputs: - integer, intent(in) :: idate(:), jdate(:), me, iaermdl, iaerflg, isol + integer, intent(in) :: idate(:), jdate(:), me, iaermdl, iaerflg, isol, ictm, ntoz, ico2 logical, intent(in) :: lsswr - character(len=26),intent(in) :: aeros_file + character(len=26),intent(in) :: aeros_file,co2dat_file,co2gbl_file real (kind=kind_phys), intent(in) :: deltsw, deltim, con_pi @@ -684,7 +682,7 @@ subroutine radupdate( idate,jdate,deltsw,deltim,lsswr,me, iaermdl,& ! --- ... set up time stamp used for green house gases (** currently co2 only) - if ( ictmflg==0 .or. ictmflg==-2 ) then ! get external data at initial condition time + if ( ictm==0 .or. ictm==-2 ) then ! get external data at initial condition time kyear = idate(1) kmon = idate(2) kday = idate(3) @@ -694,7 +692,7 @@ subroutine radupdate( idate,jdate,deltsw,deltim,lsswr,me, iaermdl,& kmon = imon kday = iday khour = ihour - endif ! end if_ictmflg_block + endif ! end if_ictm_block if ( month0 /= imon ) then lmon_chg = .true. @@ -740,7 +738,8 @@ subroutine radupdate( idate,jdate,deltsw,deltim,lsswr,me, iaermdl,& lco2_chg = .false. endif - call gas_update ( kyear,kmon,kday,khour,loz1st,lco2_chg, me, errflg, errmsg ) + call gas_update ( kyear,kmon,kday,khour,loz1st,lco2_chg, me, co2dat_file, & + co2gbl_file, ictm, ico2, ntoz, errflg, errmsg ) if ( loz1st ) loz1st = .false. diff --git a/physics/GFS_rrtmg_setup.meta b/physics/GFS_rrtmg_setup.meta index 71f1e2ff7..e65795887 100644 --- a/physics/GFS_rrtmg_setup.meta +++ b/physics/GFS_rrtmg_setup.meta @@ -195,6 +195,22 @@ type = character kind = len=26 intent = in +[co2usr_file] + standard_name = co2_user_data_table_file + long_name = co2 user defined data table file + units = none + dimensions = () + type = character + kind = len=26 + intent = in +[co2cyc_file] + standard_name = co2_clim_monthly_cycle_data_table_file + long_name = co2 climotological monthly cycle data table file + units = none + dimensions = () + type = character + kind = len=26 + intent = in [con_pi] standard_name = pi long_name = ratio of a circle's circumference to its diameter @@ -349,6 +365,43 @@ type = character kind = len=26 intent = in +[co2dat_file] + standard_name = co2_monthly_obs_data_table_file + long_name = co2 monthly observation data table + units = none + dimensions = () + type = character + kind = len=26 + intent = in +[co2gbl_file] + standard_name = co2_global_annual_mean_data_table_file + long_name = co2 global annual mean data file + units = none + dimensions = () + type = character + kind = len=26 + intent = in +[ictm] + standard_name = flag_for_initial_time_date_control + long_name = flag for initial conditions and forcing + units = flag + dimensions = () + type = integer + intent = in +[ico2] + standard_name = control_for_co2 + long_name = prescribed global mean value (old opernl) + units = flag + dimensions = () + type = integer + intent = in +[ntoz] + standard_name = index_of_ozone_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for ozone mixing ratio + units = index + dimensions = () + type = integer + intent = in [con_pi] standard_name = pi long_name = ratio of a circle's circumference to its diameter diff --git a/physics/GFS_rrtmgp_pre.F90 b/physics/GFS_rrtmgp_pre.F90 index 755b977b3..9822aaf74 100644 --- a/physics/GFS_rrtmgp_pre.F90 +++ b/physics/GFS_rrtmgp_pre.F90 @@ -116,14 +116,15 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw con_eps, con_epsm1, con_fvirt, con_epsqs, solhr, minGPpres, maxGPpres, minGPtemp, & maxGPtemp, raddt, p_lay, t_lay, p_lev, t_lev, tsfg, tsfa, qs_lay, q_lay, tv_lay, & relhum, tracer, deltaZ, deltaZc, deltaP, active_gases_array, gas_concentrations, & - tsfc_radtime, coszen, coszdg, top_at_1, iSFC, iTOA, errmsg, errflg) + tsfc_radtime, coszen, coszdg, top_at_1, iSFC, iTOA, ico2, con_pi, errmsg, errflg) ! Inputs integer, intent(in) :: & nCol, & ! Number of horizontal grid points nLev, & ! Number of vertical layers nTracers, & ! Number of tracers from model. - i_o3 ! Index into tracer array for ozone + i_o3, & ! Index into tracer array for ozone + ico2 ! Flag for co2 radiation scheme logical, intent(in) :: & lsswr, & ! Call SW radiation? lslwr ! Call LW radiation @@ -141,6 +142,7 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw con_epsm1, & ! Physical constant: Epsilon (Rd/Rv) minus one con_fvirt, & ! Physical constant: Inverse of epsilon minus one con_epsqs, & ! Physical constant: Minimum saturation mixing-ratio (kg/kg) + con_pi, & ! Physical constant: Pi solhr ! Time in hours after 00z at the current timestep real(kind_phys), dimension(:), intent(in) :: & xlon, & ! Longitude @@ -350,14 +352,14 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw enddo ! OR Use climatological ozone data else - call getozn (prslk(1:NCOL,:), xlat, nCol, nLev, o3_lay) + call getozn (prslk(1:NCOL,:), xlat, nCol, nLev, top_at_1, o3_lay) endif ! ####################################################################################### ! Set gas concentrations for RRTMGP ! ####################################################################################### ! Call getgases(), to set up non-prognostic gas volume mixing ratios (gas_vmr). - call getgases (p_lev/100., xlon, xlat, nCol, nLev, gas_vmr) + call getgases (p_lev/100., xlon, xlat, nCol, nLev, ico2, top_at_1, con_pi, gas_vmr) ! Compute volume mixing-ratios for ozone (mmr) and specific-humidity. vmr_h2o = merge((q_lay/(1-q_lay))*amdw, 0., q_lay .ne. 1.) diff --git a/physics/GFS_rrtmgp_pre.meta b/physics/GFS_rrtmgp_pre.meta index 88face855..86645cb1a 100644 --- a/physics/GFS_rrtmgp_pre.meta +++ b/physics/GFS_rrtmgp_pre.meta @@ -252,6 +252,14 @@ type = real kind = kind_phys intent = in +[con_pi] + standard_name = pi + long_name = ratio of a circle's circumference to its diameter + units = none + dimensions = () + type = real + kind = kind_phys + intent = in [minGPpres] standard_name = minimum_pressure_in_RRTMGP long_name = minimum pressure allowed in RRTMGP @@ -284,6 +292,13 @@ type = real kind = kind_phys intent = in +[ico2] + standard_name = control_for_co2 + long_name = prescribed global mean value (old opernl) + units = flag + dimensions = () + type = integer + intent = in [raddt] standard_name = time_step_for_radiation long_name = radiation time step diff --git a/physics/GFS_rrtmgp_setup.F90 b/physics/GFS_rrtmgp_setup.F90 index baaf2fcdc..935500739 100644 --- a/physics/GFS_rrtmgp_setup.F90 +++ b/physics/GFS_rrtmgp_setup.F90 @@ -9,7 +9,7 @@ module GFS_rrtmgp_setup ! use GFS_cloud_diagnostics, only : hml_cloud_diagnostics_initialize ! *NOTE* These parameters below are required radiation_****** modules. They are not ! directly used by the RRTMGP routines. - use physparam, only : ictmflg, ico2flg, ioznflg, ivflip + use physparam, only : ivflip implicit none public GFS_rrtmgp_setup_init, GFS_rrtmgp_setup_timestep_init, GFS_rrtmgp_setup_finalize @@ -27,7 +27,7 @@ module GFS_rrtmgp_setup is_initialized = .false. ! Control flag for the first time of reading climatological ozone data ! (set/reset in subroutines GFS_rrtmgp_setup_init/GFS_rrtmgp_setup_timestep_init, it is used only if - ! the control parameter ioznflg=0) + ! the control parameter ntoz=0) logical :: loz1st = .true. contains @@ -42,7 +42,7 @@ subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires, ntcw, num_p3d, ntoz, iovr, isubc_sw, isubc_lw, icliq_sw, crick_proof, ccnorm, & norad_precip, lalw1bd, idate, iflip, me, aeros_file, iaermdl, iaerflg, con_pi, & con_t0c, con_c, con_boltz, con_plnk, solar_file, con_solr_2008, con_solr_2002, & - errmsg, errflg) + co2usr_file, co2cyc_file, errmsg, errflg) ! Inputs logical, intent(in) :: do_RRTMGP @@ -66,7 +66,7 @@ subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires, crick_proof, ccnorm, norad_precip, lalw1bd integer, intent(in), dimension(:) :: & idate - character(len=26),intent(in) :: aeros_file, solar_file + character(len=26),intent(in) :: aeros_file, solar_file, co2usr_file, co2cyc_file ! Outputs character(len=*), intent(out) :: errmsg @@ -87,9 +87,6 @@ subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires, end if ! Set radiation parameters - ictmflg = ictm ! data ic time/date control flag - ico2flg = ico2 ! co2 data source control flag - ioznflg = ntoz ! ozone data source control flag ivflip = iflip ! vertical index direction control flag if ( ictm==0 .or. ictm==-2 ) then @@ -123,7 +120,7 @@ subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires, ' me = ',me endif - loz1st = (ioznflg == 0) ! first-time clim ozone data read flag + loz1st = (ntoz == 0) ! first-time clim ozone data read flag month0 = 0 iyear0 = 0 monthd = 0 @@ -140,7 +137,7 @@ subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires, call sol_init ( me, isol, solar_file, con_solr_2008, con_solr_2002, con_pi ) call aer_init ( levr, me, iaermdl, iaerflg, lalw1bd, aeros_file, con_pi, con_t0c, & con_c, con_boltz, con_plnk, errflg, errmsg) - call gas_init ( me, errflg, errmsg ) + call gas_init ( me, co2usr_file, co2cyc_file, ictm, ntoz, ico2, con_pi, errflg, errmsg ) !call hml_cloud_diagnostics_initialize(imp_physics, imp_physics_fer_hires, & ! imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, & ! imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, imp_physics_mg, levr, me, si,& @@ -161,8 +158,9 @@ end subroutine GFS_rrtmgp_setup_init !> \section arg_table_GFS_rrtmgp_setup_timestep_init !! \htmlinclude GFS_rrtmgp_setup_timestep_init.html !! - subroutine GFS_rrtmgp_setup_timestep_init (idate, jdate, deltsw, deltim, lsswr, me, iaermdl,& - aeros_file, isol, slag, sdec, cdec, solcon, con_pi, errmsg, errflg) + subroutine GFS_rrtmgp_setup_timestep_init (idate, jdate, deltsw, deltim, lsswr, me, & + iaermdl, aeros_file, isol, slag, sdec, cdec, solcon, con_pi, co2dat_file, & + co2gbl_file, ictm, ico2, ntoz, errmsg, errflg) ! Inputs integer, intent(in) :: idate(:) @@ -172,8 +170,8 @@ subroutine GFS_rrtmgp_setup_timestep_init (idate, jdate, deltsw, deltim, lsswr, real(kind_phys), intent(in) :: con_pi logical, intent(in) :: lsswr integer, intent(in) :: me - integer, intent(in) :: iaermdl,isol - character(len=26), intent(in) :: aeros_file + integer, intent(in) :: iaermdl,isol,ictm,ico2,ntoz + character(len=26), intent(in) :: aeros_file,co2dat_file,co2gbl_file ! Outputs real(kind_phys), intent(out) :: slag @@ -209,7 +207,7 @@ subroutine GFS_rrtmgp_setup_timestep_init (idate, jdate, deltsw, deltim, lsswr, ! Set up time stamp used for green house gases (** currently co2 only) ! get external data at initial condition time - if ( ictmflg==0 .or. ictmflg==-2 ) then + if ( ictm==0 .or. ictm==-2 ) then kyear = idate(1) kmon = idate(2) kday = idate(3) @@ -254,7 +252,8 @@ subroutine GFS_rrtmgp_setup_timestep_init (idate, jdate, deltsw, deltim, lsswr, else lco2_chg = .false. endif - call gas_update (kyear, kmon, kday, khour, loz1st, lco2_chg, me, errflg, errmsg ) + call gas_update (kyear, kmon, kday, khour, loz1st, lco2_chg, me, co2dat_file, & + co2gbl_file, ictm, ico2, ntoz, errflg, errmsg ) if ( loz1st ) loz1st = .false. diff --git a/physics/GFS_rrtmgp_setup.meta b/physics/GFS_rrtmgp_setup.meta index 6e8d296e3..4f8fe1db4 100644 --- a/physics/GFS_rrtmgp_setup.meta +++ b/physics/GFS_rrtmgp_setup.meta @@ -285,6 +285,22 @@ type = real kind = kind_phys intent = in +[co2usr_file] + standard_name = co2_user_data_table_file + long_name = co2 user defined data table file + units = none + dimensions = () + type = character + kind = len=26 + intent = in +[co2cyc_file] + standard_name = co2_clim_monthly_cycle_data_table_file + long_name = co2 climotological monthly cycle data table file + units = none + dimensions = () + type = character + kind = len=26 + intent = in [iaermdl] standard_name = flag_for_aerosol_radiation_scheme long_name = flag for aerosol scheme to use in radiation @@ -371,6 +387,43 @@ type = character kind = len=26 intent = in +[co2dat_file] + standard_name = co2_monthly_obs_data_table_file + long_name = co2 monthly observation data table + units = none + dimensions = () + type = character + kind = len=26 + intent = in +[co2gbl_file] + standard_name = co2_global_annual_mean_data_table_file + long_name = co2 global annual mean data file + units = none + dimensions = () + type = character + kind = len=26 + intent = in +[ictm] + standard_name = flag_for_initial_time_date_control + long_name = flag for initial conditions and forcing + units = flag + dimensions = () + type = integer + intent = in +[ico2] + standard_name = control_for_co2 + long_name = prescribed global mean value (old opernl) + units = flag + dimensions = () + type = integer + intent = in +[ntoz] + standard_name = index_of_ozone_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for ozone mixing ratio + units = index + dimensions = () + type = integer + intent = in [iaermdl] standard_name = flag_for_aerosol_radiation_scheme long_name = flag for aerosol scheme to use in radiation diff --git a/physics/physparam.f b/physics/physparam.f index 880ed47f3..0dd53a304 100644 --- a/physics/physparam.f +++ b/physics/physparam.f @@ -153,19 +153,6 @@ module physparam !! variable at initial time) integer, save :: ioznflg = 1 -!> external co2 2d monthly obsv data table: co2historicaldata_2004.txt - character, save :: co2dat_file*26 -!> external co2 global annual mean data tb: co2historicaldata_glob.txt - character, save :: co2gbl_file*26 -!> external co2 user defined data table: co2userdata.txt - character, save :: co2usr_file*26 -!> external co2 clim monthly cycle data tb: co2monthlycyc.txt - character, save :: co2cyc_file*26 - data co2dat_file / 'co2historicaldata_2004.txt' / !year is run-time selected - data co2gbl_file / 'co2historicaldata_glob.txt' / - data co2usr_file / 'co2userdata.txt ' / - data co2cyc_file / 'co2monthlycyc.txt ' / - ! ............................................. ! !>\name 2.4 For module radiation_clouds ! ............................................. ! diff --git a/physics/radiation_gases.f b/physics/radiation_gases.f index 01048c5eb..b5eb8ffb9 100644 --- a/physics/radiation_gases.f +++ b/physics/radiation_gases.f @@ -44,7 +44,6 @@ ! external modules referenced: ! ! 'module machine' in 'machine.f' ! ! 'module funcphys' in 'funcphys.f' ! -! 'module physcons' in 'physcons.f ! ! 'module module_iounitdef' in 'iounitdef.f' ! ! ! ! unit used for radiative active gases: ! @@ -141,13 +140,8 @@ !> This module sets up ozone climatological profiles and other constant gas !! profiles, such as co2, ch4, n2o, o2, and those of cfc gases. module module_radiation_gases -! - use physparam, only : ico2flg, ictmflg, ioznflg, ivflip, & - & co2dat_file, co2gbl_file, & - & co2usr_file, co2cyc_file, & - & kind_phys, kind_io4 + use machine, only : kind_phys, kind_io4 use funcphys, only : fpkapx - use physcons, only : con_pi use ozne_def, only : JMR => latsozc, LOZ => levozc, & & blte => blatc, dlte=> dphiozc, & & timeozc => timeozc @@ -168,9 +162,9 @@ module module_radiation_gases integer, parameter :: MINYEAR = 1957 ! earlist year 2D CO2 data available real (kind=kind_phys), parameter :: resco2=15.0 ! horizontal resolution in degree - real (kind=kind_phys), parameter :: raddeg=180.0/con_pi ! rad->deg conversion real (kind=kind_phys), parameter :: prsco2=788.0 ! pressure limitation for 2D CO2 (mb) - real (kind=kind_phys), parameter :: hfpi =0.5*con_pi ! half of pi + real (kind=kind_phys) :: raddeg ! rad->deg conversion + real (kind=kind_phys) :: hfpi ! half of pi real (kind=kind_phys), parameter :: co2vmr_def = 350.0e-6 ! parameter constant for CO2 volume mixing ratio real (kind=kind_phys), parameter :: n2ovmr_def = 0.31e-6 ! parameter constant for N2O volume mixing ratio @@ -230,45 +224,22 @@ module module_radiation_gases !!\param me print message control flag !>\section gas_init_gen gas_init General Algorithm !----------------------------------- - subroutine gas_init & - & ( me , errflg, errmsg) + subroutine gas_init( me, co2usr_file, co2cyc_file, ico2flg, & + & ictmflg, ioznflg, con_pi, errflg, errmsg) ! =================================================================== ! ! ! ! gas_init sets up ozone, co2, etc. parameters. if climatology ozone ! ! then read in monthly ozone data. ! ! ! -! inputs: dimemsion ! -! me - print message control flag 1 ! +! inputs: ! +! me - print message control flag ! +! co2usr_file - external co2 user defined data table ! +! co2cyc_file - external co2 climotology monthly cycle data table ! ! ! ! outputs: (CCPP error handling) ! ! (errflg, errmsg) ! ! ! -! external module variables: (in physparam) ! -! ico2flg - co2 data source control flag ! -! =0: use prescribed co2 global mean value ! -! =1: use input global mean co2 value (co2_glb) ! -! =2: use input 2-d monthly co2 value (co2vmr_sav) ! -! ictmflg - =yyyy#, data ic time/date control flag ! -! = -2: same as 0, but superimpose seasonal cycle ! -! from climatology data set. ! -! = -1: use user provided external data for the fcst ! -! time, no extrapolation. ! -! = 0: use data at initial cond time, if not existed! -! then use latest, without extrapolation. ! -! = 1: use data at the forecast time, if not existed! -! then use latest and extrapolate to fcst time.! -! =yyyy0: use yyyy data for the forecast time, no ! -! further data extrapolation. ! -! =yyyy1: use yyyy data for the fcst. if needed, do ! -! extrapolation to match the fcst time. ! -! ioznflg - ozone data control flag ! -! =0: use climatological ozone profile ! -! >0: use interactive ozone profile ! -! ivflip - vertical profile indexing flag ! -! co2usr_file- external co2 user defined data table ! -! co2cyc_file- external co2 climotology monthly cycle data table ! -! ! ! internal module variables: ! ! pkstr, o3r - arrays for climatology ozone data ! ! ! @@ -281,8 +252,9 @@ subroutine gas_init & implicit none ! --- inputs: - integer, intent(in) :: me - + integer, intent(in) :: me, ictmflg, ioznflg, ico2flg + character(len=26),intent(in) :: co2usr_file,co2cyc_file + real(kind=kind_phys), intent(in) :: con_pi ! --- output: character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -306,6 +278,10 @@ subroutine gas_init & errmsg = '' errflg = 0 +! Initiailize module parameters + raddeg = 180.0/con_pi + hfpi = 0.5*con_pi + if ( me == 0 ) print *, VTAGGAS ! print out version tag kyrsav = 0 @@ -541,8 +517,8 @@ end subroutine gas_init !!\param me print message control flag !>\section gen_gas_update gas_update General Algorithm !----------------------------------- - subroutine gas_update & - & ( iyear, imon, iday, ihour, loz1st, ldoco2, me, & + subroutine gas_update(iyear, imon, iday, ihour, loz1st, ldoco2, & + & me, co2dat_file, co2gbl_file, ictmflg, ico2flg, ioznflg, & & errflg, errmsg ) ! =================================================================== ! @@ -550,52 +526,6 @@ subroutine gas_update & ! gas_update reads in 2-d monthly co2 data set for a specified year. ! ! data are in a 15 degree lat/lon horizontal resolution. ! ! ! -! inputs: dimemsion ! -! iyear - year of the requested data for fcst 1 ! -! imon - month of the year 1 ! -! iday - day of the month 1 ! -! ihour - hour of the day 1 ! -! loz1st - clim ozone 1st time update control flag 1 ! -! ldoco2 - co2 update control flag 1 ! -! me - print message control flag 1 ! -! ! -! outputs: (to the module variables) ! -! errflg - CCPP error flag ! -! errmsg - CCPP error message ! -! ! -! external module variables: (in physparam) ! -! ico2flg - co2 data source control flag ! -! =0: use prescribed co2 global mean value ! -! =1: use input global mean co2 value (co2_glb) ! -! =2: use input 2-d monthly co2 value (co2vmr_sav) ! -! ictmflg - =yyyy#, data ic time/date control flag ! -! = -2: same as 0, but superimpose seasonal cycle ! -! from climatology data set. ! -! = -1: use user provided external data for the fcst ! -! time, no extrapolation. ! -! = 0: use data at initial cond time, if not existed! -! then use latest, without extrapolation. ! -! = 1: use data at the forecast time, if not existed! -! then use latest and extrapolate to fcst time.! -! =yyyy0: use yyyy data for the forecast time, no ! -! further data extrapolation. ! -! =yyyy1: use yyyy data for the fcst. if needed, do ! -! extrapolation to match the fcst time. ! -! ioznflg - ozone data control flag ! -! =0: use climatological ozone profile ! -! >0: use interactive ozone profile ! -! ivflip - vertical profile indexing flag ! -! co2dat_file- external co2 2d monthly obsv data table ! -! co2gbl_file- external co2 global annual mean data table ! -! ! -! internal module variables: ! -! co2vmr_sav - monthly co2 volume mixing ratio IMXCO2*JMXCO2*12 ! -! co2cyc_sav - monthly cycle co2 vol mixing ratio IMXCO2*JMXCO2*12 ! -! co2_glb - global annual mean co2 mixing ratio ! -! gco2cyc - global monthly mean co2 variation 12 ! -! k1oz,k2oz,facoz ! -! - climatology ozone parameters 1 ! -! ! ! usage: call gas_update ! ! ! ! subprograms called: none ! @@ -605,8 +535,9 @@ subroutine gas_update & implicit none ! --- inputs: - integer, intent(in) :: iyear, imon, iday, ihour, me - + integer, intent(in) :: iyear,imon,iday,ihour,me,ictmflg,ico2flg + integer, intent(in) :: ioznflg + character(len=26),intent(in) :: co2dat_file, co2gbl_file logical, intent(in) :: loz1st, ldoco2 ! --- output: @@ -760,6 +691,7 @@ subroutine gas_update & ! --- ... set up input data file name + print*,"co2dat_file: ",co2dat_file cfile1 = co2dat_file write(cfile1(19:22),34) idyr 34 format(i4.4) @@ -948,11 +880,8 @@ end subroutine gas_update !!\n (:,:,10) - cfc113 !>\section gen_getgases getgases General Algorithm !----------------------------------- - subroutine getgases & - & ( plvl, xlon, xlat, & ! --- inputs - & IMAX, LMAX, & - & gasdat & ! --- outputs - & ) + subroutine getgases( plvl, xlon, xlat, IMAX, LMAX, ico2flg, & + & top_at_1, con_pi, gasdat) ! =================================================================== ! ! ! ! getgases set up global distribution of radiation absorbing gases ! @@ -960,45 +889,6 @@ subroutine getgases & ! observed values, all other gases are asigned to the climatological ! ! values. ! ! ! -! inputs: ! -! plvl(IMAX,LMAX+1)- pressure at model layer interfaces (mb) ! -! xlon(IMAX) - grid longitude in radians, ok both 0->2pi or ! -! -pi -> +pi arrangements ! -! xlat(IMAX) - grid latitude in radians, default range to ! -! pi/2 -> -pi/2, otherwise see in-line comment ! -! IMAX, LMAX - horiz, vert dimensions for output data ! -! ! -! outputs: ! -! gasdat(IMAX,LMAX,NF_VGAS) - gases volume mixing ratioes ! -! (:,:,1) - co2 ! -! (:,:,2) - n2o ! -! (:,:,3) - ch4 ! -! (:,:,4) - o2 ! -! (:,:,5) - co ! -! (:,:,6) - cfc11 ! -! (:,:,7) - cfc12 ! -! (:,:,8) - cfc22 ! -! (:,:,9) - ccl4 ! -! (:,:,10) - cfc113 ! -! ! -!> - External module variables: (in physparam) -!!\n ico2flg - co2 data source control flag -!!\n =0: use prescribed co2 global mean value -!!\n =1: use input global mean co2 value (co2_glb) -!!\n =2: use input 2-d monthly co2 value (co2vmr_sav) -!!\n ivflip - vertical profile indexing flag -!! -!> - Internal module variables : -!!\n co2vmr_sav - saved monthly co2 concentration from sub gas_update -!!\n co2_glb - saved global annual mean co2 value from gas_update -!!\n gco2cyc - saved global seasonal variation of co2 climatology -!! in 12-month form -!note: for lower atmos co2vmr_sav may have clim monthly deviations ! -! superimposed on init-cond co2 value, while co2_glb only ! -! contains the global mean value, thus needs to add the ! -! monthly dglobal mean deviation gco2cyc at upper atmos. for ! -! ictmflg/=-2, this value will be zero. ! -! ! ! usage: call getgases ! ! ! ! subprograms called: none ! @@ -1008,8 +898,10 @@ subroutine getgases & implicit none ! --- input: - integer, intent(in) :: IMAX, LMAX + integer, intent(in) :: IMAX, LMAX, ico2flg real (kind=kind_phys), intent(in) :: plvl(:,:), xlon(:), xlat(:) + logical, intent(in) :: top_at_1 + real(kind=kind_phys), intent(in) :: con_pi ! --- output: real (kind=kind_phys), intent(out) :: gasdat(:,:,:) @@ -1063,7 +955,7 @@ subroutine getgases & ilon = min( IMXCO2, int( xlon1*tmp + 1 )) ilat = min( JMXCO2, int( xlat1*tmp + 1 )) - if ( ivflip == 0 ) then ! index from toa to sfc + if (top_at_1) then ! index from toa to sfc do k = 1, LMAX if ( plvl(i,k) >= prsco2 ) then gasdat(i,k,1) = co2vmr_sav(ilon,ilat,kmonsav) @@ -1099,11 +991,7 @@ end subroutine getgases !! ratio (g/g) !>\section getozn_gen getozn General Algorithm !----------------------------------- - subroutine getozn & - & ( prslk,xlat, & ! --- inputs - & IMAX, LM, & - & o3mmr & ! --- outputs - & ) + subroutine getozn( prslk,xlat, IMAX, LM, top_at_1, o3mmr) ! =================================================================== ! ! ! @@ -1111,20 +999,6 @@ subroutine getozn & ! ! ! this code is originally written By Shrinivas Moorthi ! ! ! -! inputs: ! -! prslk (IMAX,LM) - exner function = (p/p0)**rocp ! -! xlat (IMAX) - latitude in radians, default to pi/2 -> -pi/2 ! -! range, otherwise see in-line comment ! -! IMAX, LM - horizontal and vertical dimensions ! -! ! -! outputs: ! -! o3mmr (IMAX,LM) - output ozone profile in mass mixing ratio (g/g)! -! ! -! module variables: ! -! k1oz, k2oz - ozone data interpolation indices ! -! facoz - ozone data interpolation factor ! -! ivflip - control flag for direction of vertical index ! -! ! ! usage: call getozn ! ! ! ! =================================================================== ! @@ -1133,7 +1007,7 @@ subroutine getozn & ! --- inputs: integer, intent(in) :: IMAX, LM - + logical, intent(in) :: top_at_1 real (kind=kind_phys), intent(in) :: prslk(:,:), xlat(:) ! --- outputs: @@ -1177,7 +1051,7 @@ subroutine getozn & do l = 1, LM ll = l - if (ivflip == 1) ll = LM -l + 1 + if (.not. top_at_1) ll = LM -l + 1 do i = 1, IMAX wk1(i) = prslk(i,ll) From c0d2d20b4f5c50a9766dc4d4fb5e95c805b7b716 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Thu, 18 Aug 2022 11:51:14 -0600 Subject: [PATCH 021/380] Remove dependency on physparam in radlw_main/radsw_main.F90. Provided as ccpp interstitials. --- physics/GFS_radiation_surface.meta | 2 +- physics/GFS_rrtmg_setup.F90 | 74 ++++----- physics/GFS_rrtmg_setup.meta | 39 ++++- physics/radiation_cloud_overlap.F90 | 2 +- physics/radiation_clouds.f | 42 ++--- physics/radlw_datatb.f | 38 ++--- physics/radlw_main.F90 | 169 ++++++++------------ physics/radlw_main.meta | 42 +++++ physics/radlw_param.f | 2 +- physics/radsw_datatb.f | 34 ++-- physics/radsw_main.F90 | 234 +++++++++++----------------- physics/radsw_main.meta | 51 +++++- physics/radsw_param.f | 2 +- 13 files changed, 363 insertions(+), 368 deletions(-) diff --git a/physics/GFS_radiation_surface.meta b/physics/GFS_radiation_surface.meta index 8ad848446..56303f995 100644 --- a/physics/GFS_radiation_surface.meta +++ b/physics/GFS_radiation_surface.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_radiation_surface type = scheme - dependencies = iounitdef.f,machine.F,physparam.f,radiation_surface.f,set_soilveg_ruc.F90,namelist_soilveg_ruc.F90 + dependencies = iounitdef.f,machine.F,radiation_surface.f,set_soilveg_ruc.F90,namelist_soilveg_ruc.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_rrtmg_setup.F90 b/physics/GFS_rrtmg_setup.F90 index f83f53f01..6891b0f24 100644 --- a/physics/GFS_rrtmg_setup.F90 +++ b/physics/GFS_rrtmg_setup.F90 @@ -6,10 +6,9 @@ !> @{ module GFS_rrtmg_setup - use physparam, only : icldflg, & - & iovrRad=>iovr, lcrick , lcnorm , lnoprec, & - & isubcsw, isubclw, ivflip , ipsd0, & - & iswcliq + use physparam, only : lcrick , lcnorm , lnoprec, & + & ivflip , ipsd0, & + & iswcliq,iovrRad=>iovr use machine, only: kind_phys use radcons, only: ltp, lextop @@ -44,14 +43,15 @@ module GFS_rrtmg_setup !! subroutine GFS_rrtmg_setup_init ( & si, levr, ictm, isol, solar_file, ico2, iaer, ntcw, & - num_p3d, npdf3d, ntoz, iovr, isubc_sw, isubc_lw, & + num_p3d, npdf3d, ntoz, iovr, & icliq_sw, crick_proof, ccnorm, & imp_physics, & norad_precip, idate, iflip, & do_RRTMGP, me, lalw1bd, iaermdl, iaerflg, & aeros_file, con_pi, con_t0c, con_c, con_boltz, & con_plnk, con_solr_2008, con_solr_2002, co2usr_file,& - co2cyc_file, errmsg, errflg) + co2cyc_file, rad_hr_units, inc_minor_gas, ilwcliq, & + iswcliq, isubcsw, isubclw, iswmode, errmsg, errflg) ! ================= subprogram documentation block ================ ! ! ! ! subprogram: GFS_rrtmg_setup_init - a subprogram to initialize radiation ! @@ -128,8 +128,8 @@ subroutine GFS_rrtmg_setup_init ( & ! =1: max/ran overlapping clouds ! ! =2: maximum overlap clouds (mcica only) ! ! =3: decorrelation-length overlap (mcica only) ! -! =4: exponential overlap clouds -! isubc_sw/isubc_lw: sub-column cloud approx control flag (sw/lw rad) ! +! =4: exponential overlap clouds ! +! isubcsw/isubclw: sub-column cloud approx control flag (sw/lw rad) ! ! =0: with out sub-column cloud approximation ! ! =1: mcica sub-col approx. prescribed random seed ! ! =2: mcica sub-col approx. provided random seed ! @@ -161,8 +161,6 @@ subroutine GFS_rrtmg_setup_init ( & integer, intent(in) :: npdf3d integer, intent(in) :: ntoz integer, intent(in) :: iovr - integer, intent(in) :: isubc_sw - integer, intent(in) :: isubc_lw integer, intent(in) :: icliq_sw logical, intent(in) :: crick_proof logical, intent(in) :: ccnorm @@ -170,10 +168,13 @@ subroutine GFS_rrtmg_setup_init ( & logical, intent(in) :: norad_precip integer, intent(in) :: idate(:) integer, intent(in) :: iflip - logical, intent(in) :: do_RRTMGP, lalw1bd - integer, intent(in) :: me - character(len=26),intent(in) :: aeros_file, solar_file, co2usr_file, co2cyc_file - real(kind_phys), intent(in) :: con_pi,con_t0c,con_c,con_boltz,con_plnk,con_solr_2008,con_solr_2002 + logical, intent(in) :: do_RRTMGP, lalw1bd, inc_minor_gas + integer, intent(in) :: me, rad_hr_units, ilwcliq, iswcliq, isubcsw, & + isubclw, iswmode + character(len=26),intent(in) :: aeros_file, solar_file, co2usr_file,& + co2cyc_file + real(kind_phys), intent(in) :: con_pi, con_t0c, con_c, con_boltz, & + con_plnk, con_solr_2008, con_solr_2002 character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg integer, intent(out) :: iaermdl, iaerflg @@ -203,28 +204,14 @@ subroutine GFS_rrtmg_setup_init ( & return endif -! if ( ntcw > 0 ) then - icldflg = 1 ! prognostic cloud optical prop scheme -! else -! icldflg = 0 ! no support for diag cloud opt prop scheme -! endif - - iswcliq = icliq_sw ! optical property for liquid clouds for sw - - ! iovr comes from the model. In the RRTMG implementation this is stored in phyrparam.f, - ! it comes in from the host-model and is set here. - ! In GP, iovr is passed directly into the routines. iovrRAD = iovr lcrick = crick_proof ! control flag for eliminating CRICK lcnorm = ccnorm ! control flag for in-cld condensate lnoprec = norad_precip ! precip effect on radiation flag (ferrier microphysics) - isubcsw = isubc_sw ! sub-column cloud approx flag in sw radiation - isubclw = isubc_lw ! sub-column cloud approx flag in lw radiation - ivflip = iflip ! vertical index direction control flag ! --- assign initial permutation seed for mcica cloud-radiation - if ( isubc_sw>0 .or. isubc_lw>0 ) then + if ( isubcsw>0 .or. isubclw>0 ) then ! ipsd0 = 17*idate(1)+43*idate(2)+37*idate(3)+23*idate(4) + ipsd0 ipsd0 = 17*idate(1)+43*idate(2)+37*idate(3)+23*idate(4) endif @@ -235,8 +222,8 @@ subroutine GFS_rrtmg_setup_init ( & print *,' levr=',levr,' ictm=',ictm,' isol=',isol,' ico2=',ico2,& & ' iaermdl=',iaermdl,' iaerflg=',iaerflg print *,' np3d=',num_p3d,' ntoz=',ntoz, & - & ' iovr=',iovr,' isubc_sw=',isubc_sw, & - & ' isubc_lw=',isubc_lw,' icliq_sw=',icliq_sw, & + & ' iovr=',iovr,' isubcsw=',isubcsw, & + & ' isubclw=',isubclw,' icliq_sw=',icliq_sw, & & ' iflip=',iflip,' me=',me print *,' crick_proof=',crick_proof, & & ' ccnorm=',ccnorm,' norad_precip=',norad_precip @@ -246,7 +233,9 @@ subroutine GFS_rrtmg_setup_init ( & & ( si, levr, imp_physics, me, iaermdl, iaerflg, lalw1bd, & & aeros_file, con_pi, con_t0c, con_c, con_boltz, con_plnk, & & isol, solar_file, con_solr_2008, con_solr_2002, & - & co2usr_file, co2cyc_file, ico2, ictm, ntoz, errmsg, errflg ) + & co2usr_file, co2cyc_file, ico2, ictm, ntoz, rad_hr_units, & + & inc_minor_gas, ilwcliq, iswcliq, isubcsw, isubclw, iovr, & + & iswmode, errmsg, errflg ) if ( me == 0 ) then @@ -332,7 +321,8 @@ end subroutine GFS_rrtmg_setup_finalize subroutine radinit( si, NLAY, imp_physics, me, iaermdl, iaerflg, lalw1bd, & aeros_file, con_pi, con_t0c, con_c, con_boltz, con_plnk, isol, & solar_file, con_solr_2008, con_solr_2002, co2usr_file, co2cyc_file, & - ico2, ictm, ntoz, errmsg, errflg) + ico2, ictm, rad_hr_units, ntoz, inc_minor_gas, ilwcliq, iswcliq, & + isubcsw, isubclw, iovr, iswmode, errmsg, errflg) !................................... ! --- inputs: @@ -396,9 +386,6 @@ subroutine radinit( si, NLAY, imp_physics, me, iaermdl, iaerflg, lalw1bd, & ! ioznflg : ozone data source control flag ! ! =0: use climatological ozone profile ! ! =1: use interactive ozone profile ! -! icldflg : cloud optical property scheme control flag ! -! =0: use diagnostic cloud scheme ! -! =1: use prognostic cloud scheme (default) ! ! imp_physics : cloud microphysics scheme control flag ! ! =99 zhao/carr/sundqvist microphysics scheme ! ! =98 zhao/carr/sundqvist microphysics+pdf cloud&cnvc,cnvw ! @@ -445,8 +432,10 @@ subroutine radinit( si, NLAY, imp_physics, me, iaermdl, iaerflg, lalw1bd, & implicit none ! --- inputs: - integer, intent(in) :: NLAY, me, imp_physics, iaermdl, iaerflg, isol, ico2, ictm, ntoz - logical, intent(in) :: lalw1bd + integer, intent(in) :: NLAY, me, imp_physics, iaermdl, iaerflg, & + isol, ico2, ictm, ntoz, rad_hr_units, ilwcliq, iswcliq, isubcsw,& + isubclw, iovr, iswmode + logical, intent(in) :: lalw1bd, inc_minor_gas real (kind=kind_phys), intent(in) :: si(:), con_pi,con_t0c, con_c, & con_boltz, con_plnk, con_solr_2008, con_solr_2002 character(len=26), intent(in) :: aeros_file, solar_file,co2usr_file, co2cyc_file @@ -472,10 +461,9 @@ subroutine radinit( si, NLAY, imp_physics, me, iaermdl, iaerflg, lalw1bd, & & ' May 01 2007' print *, VTAGRAD !print out version tag print *,' - Selected Control Flag settings: ICTMflg=',ictm, & - & ' ISOLar =',isol, ' ICO2flg=',ico2,' IAERflg=',iaerflg, & - & ' ICLDflg=',icldflg, & + & ' ISOLar =',isol, ' ICO2flg=',ico2,' IAERflg=',iaerflg, & & ' IMP_PHYSICS=',imp_physics,' IOZNflg=',ntoz - print *,' IVFLIP=',ivflip,' IOVR=',iovrRad, & + print *,' IVFLIP=',ivflip,' IOVR=',iovr, & & ' ISUBCSW=',isubcsw,' ISUBCLW=',isubclw print *,' LCRICK=',lcrick,' LCNORM=',lcnorm,' LNOPREC=',lnoprec print *,' LTP =',ltp,', add extra top layer =',lextop @@ -547,8 +535,8 @@ subroutine radinit( si, NLAY, imp_physics, me, iaermdl, iaerflg, lalw1bd, & call gas_init ( me, co2usr_file, co2cyc_file, ico2, ictm, ntoz, con_pi, & errflg, errmsg) ! co2 and other gases initialization routine call cld_init ( si, NLAY, imp_physics, me, errflg, errmsg) ! cloud initialization routine - call rlwinit ( me, errflg, errmsg ) ! lw RRTMG initialization routine - call rswinit ( me, errflg, errmsg ) ! sw RRTMG initialization routine + call rlwinit ( me, rad_hr_units, inc_minor_gas, ilwcliq, isubcsw, iovr, errflg, errmsg ) ! lw RRTMG initialization routine + call rswinit ( me, rad_hr_units, inc_minor_gas, iswcliq, isubclw, iovr, iswmode, errflg, errmsg ) ! sw RRTMG initialization routine ! return ! diff --git a/physics/GFS_rrtmg_setup.meta b/physics/GFS_rrtmg_setup.meta index e65795887..2355b91c2 100644 --- a/physics/GFS_rrtmg_setup.meta +++ b/physics/GFS_rrtmg_setup.meta @@ -110,20 +110,27 @@ dimensions = () type = integer intent = in -[isubc_sw] +[isubcsw] standard_name = flag_for_sw_clouds_grid_approximation long_name = flag for sw clouds sub-grid approximation units = flag dimensions = () type = integer intent = in -[isubc_lw] +[isubclw] standard_name = flag_for_lw_clouds_sub_grid_approximation long_name = flag for lw clouds sub-grid approximation units = flag dimensions = () type = integer intent = in +[iswmode] + standard_name = flag_for_sw_scattering_choice + long_name = flag for rrtmg shortwave scattering choice + units = flag + dimensions = () + type = integer + intent = in [icliq_sw] standard_name = control_for_shortwave_radiation_liquid_clouds long_name = sw optical property for liquid clouds @@ -211,6 +218,34 @@ type = character kind = len=26 intent = in +[rad_hr_units] + standard_name = flag_for_radiation_heating_rate_units + long_name = flag to control heating rate units + units = count + dimensions = () + type = integer + intent = in +[inc_minor_gas] + standard_name = flag_to_include_minor_gases_in_rrtmg + long_name = flag to include minor trace gases in rrtmg + units = flag + dimensions = () + type = logical + intent = in +[ilwcliq] + standard_name = flag_for_rrtmg_lw_cloud_optics + long_name = flag for rrtmg longwave cloud optics + units = flag + dimensions = () + type = integer + intent = in +[iswcliq] + standard_name = flag_for_rrtmg_sw_cloud_optics + long_name = flag for rrtmg shortwave cloud optics + units = flag + dimensions = () + type = integer + intent = in [con_pi] standard_name = pi long_name = ratio of a circle's circumference to its diameter diff --git a/physics/radiation_cloud_overlap.F90 b/physics/radiation_cloud_overlap.F90 index d6169b3e5..737b9be61 100644 --- a/physics/radiation_cloud_overlap.F90 +++ b/physics/radiation_cloud_overlap.F90 @@ -4,7 +4,7 @@ !>\defgroup rad_cld_ovr_mod Radiation Cloud Overlap Module !! This module contains the calculation of cloud overlap parameters for both RRTMG and RRTMGP. module module_radiation_cloud_overlap - use physparam, only : kind_phys + use machine, only : kind_phys implicit none public :: cmp_dcorr_lgth diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index 4b75cb4c0..ee7922c99 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -173,7 +173,7 @@ !> This module computes cloud related quantities for radiation computations. module module_radiation_clouds ! - use physparam, only : icldflg, iovr, idcor, & + use physparam, only : iovr, idcor, & & lcrick, lcnorm, lnoprec, & & ivflip use physcons, only : con_fvirt, con_ttp, con_rocp, & @@ -287,9 +287,6 @@ subroutine cld_init & ! errmsg : CCPP error message ! ! ! ! external module variables: (in physparam) ! -! icldflg : cloud optical property scheme control flag ! -! =0: abort! diagnostic cloud method discontinued ! -! =1: model use prognostic cloud method ! ! imp_physics : cloud microphysics scheme control flag ! ! =99: zhao/carr/sundqvist microphysics cloud ! ! =98: zhao/carr/sundqvist microphysics cloud+pdfcld! @@ -334,44 +331,33 @@ subroutine cld_init & errmsg = '' errflg = 0 -! --- set up module variables - - if (me == 0) print *, VTAGCLD !print out version tag - - if ( icldflg == 0 ) then - print *,' - Diagnostic Cloud Method has been discontinued' - errflg = 1 - errmsg = 'ERROR(cld_init): Diagnostic Cloud Method has been '// & - & 'discontinued' - return - else - if (me == 0) then - print *,' - Using Prognostic Cloud Method' - if (imp_physics == 99) then + if (me == 0) then + print *, VTAGCLD !print out version tag + print *,' - Using Prognostic Cloud Method' + if (imp_physics == 99) then print *,' --- Zhao/Carr/Sundqvist microphysics' - elseif (imp_physics == 98) then + elseif (imp_physics == 98) then print *,' --- zhao/carr/sundqvist + pdf cloud' - elseif (imp_physics == 11) then + elseif (imp_physics == 11) then print *,' --- GFDL Lin cloud microphysics' - elseif (imp_physics == 8) then + elseif (imp_physics == 8) then print *,' --- Thompson cloud microphysics' - elseif (imp_physics == 6) then + elseif (imp_physics == 6) then print *,' --- WSM6 cloud microphysics' - elseif (imp_physics == 10) then + elseif (imp_physics == 10) then print *,' --- MG cloud microphysics' - elseif (imp_physics == 15) then + elseif (imp_physics == 15) then print *,' --- Ferrier-Aligo cloud microphysics' - elseif (imp_physics == 17) then + elseif (imp_physics == 17) then print *,' --- NSSL cloud microphysics' - else + else print *,' !!! ERROR in cloud microphysc specification!!!', & & ' imp_physics (NP3D) =',imp_physics errflg = 1 errmsg = 'ERROR(cld_init): cloud mp specification is not'// & & ' valid' return - endif - endif + endif endif !> - Compute the top of BL cld (llyr), which is the topmost non diff --git a/physics/radlw_datatb.f b/physics/radlw_datatb.f index f297c8e4c..da0f5eaa3 100644 --- a/physics/radlw_datatb.f +++ b/physics/radlw_datatb.f @@ -66,7 +66,7 @@ module module_radlw_avplank ! !........................................! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radlw_parameters, only : NPLNK, NBANDS ! implicit none @@ -747,7 +747,7 @@ end module module_radlw_avplank ! module module_radlw_ref ! !........................................! ! - use physparam, only : kind_phys + use machine, only : kind_phys ! implicit none ! @@ -924,7 +924,7 @@ end module module_radlw_ref ! module module_radlw_cldprlw ! !........................................! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radlw_parameters, only : NBANDS ! implicit none @@ -1607,7 +1607,7 @@ end module module_radlw_cldprlw ! module module_radlw_kgb01 ! !........................................! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radlw_parameters, only : NG01 ! implicit none @@ -2421,7 +2421,7 @@ end module module_radlw_kgb01 ! module module_radlw_kgb02 ! !........................................! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radlw_parameters, only : NG02 ! implicit none @@ -3278,7 +3278,7 @@ end module module_radlw_kgb02 ! module module_radlw_kgb03 ! !........................................! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radlw_parameters, only : NG03 ! implicit none @@ -10152,7 +10152,7 @@ end module module_radlw_kgb03 ! module module_radlw_kgb04 ! !........................................! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radlw_parameters, only : NG04 ! implicit none @@ -15352,7 +15352,7 @@ end module module_radlw_kgb04 ! module module_radlw_kgb05 ! !........................................! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radlw_parameters, only : NG05 ! implicit none @@ -21849,7 +21849,7 @@ end module module_radlw_kgb05 ! module module_radlw_kgb06 ! !........................................! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radlw_parameters, only : NG06 ! implicit none @@ -22109,7 +22109,7 @@ end module module_radlw_kgb06 ! module module_radlw_kgb07 ! !........................................! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radlw_parameters, only : NG07 ! implicit none @@ -24756,7 +24756,7 @@ end module module_radlw_kgb07 ! module module_radlw_kgb08 ! !........................................! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radlw_parameters, only : NG08 ! implicit none @@ -25553,7 +25553,7 @@ end module module_radlw_kgb08 ! module module_radlw_kgb09 ! !........................................! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radlw_parameters, only : NG09 ! implicit none @@ -28231,7 +28231,7 @@ end module module_radlw_kgb09 ! module module_radlw_kgb10 ! !........................................! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radlw_parameters, only : NG10 ! implicit none @@ -28705,7 +28705,7 @@ end module module_radlw_kgb10 ! module module_radlw_kgb11 ! !........................................! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radlw_parameters, only : NG11 ! implicit none @@ -29404,7 +29404,7 @@ end module module_radlw_kgb11 ! module module_radlw_kgb12 ! !........................................! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radlw_parameters, only : NG12 ! implicit none @@ -30475,7 +30475,7 @@ end module module_radlw_kgb12 ! module module_radlw_kgb13 ! !........................................! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radlw_parameters, only : NG13 ! implicit none @@ -31381,7 +31381,7 @@ end module module_radlw_kgb13 ! module module_radlw_kgb14 ! !........................................! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radlw_parameters, only : NG14 ! implicit none @@ -31605,7 +31605,7 @@ end module module_radlw_kgb14 ! module module_radlw_kgb15 ! !........................................! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radlw_parameters, only : NG15 ! implicit none @@ -32010,7 +32010,7 @@ end module module_radlw_kgb15 ! module module_radlw_kgb16 ! !........................................! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radlw_parameters, only : NG16 ! implicit none diff --git a/physics/radlw_main.F90 b/physics/radlw_main.F90 index 8612e33db..341ca47ed 100644 --- a/physics/radlw_main.F90 +++ b/physics/radlw_main.F90 @@ -79,7 +79,6 @@ ! ! ! external modules referenced: ! ! ! -! 'module physparam' ! ! 'module physcons' ! ! 'mersenne_twister' ! ! ! @@ -278,8 +277,6 @@ !! rrtmg-lw radiation code from aer inc. module rrtmg_lw ! - use physparam, only : ilwrate, ilwrgas, ilwcliq, ilwcice, & - & isubclw, icldflg, iovr, ivflip use physcons, only : con_g, con_cp, con_avgd, con_amd, & & con_amw, con_amo3 use mersenne_twister, only : random_setseed, random_number, & @@ -425,7 +422,8 @@ subroutine rrtmg_lw_run & & gasvmr_cfc12, gasvmr_cfc22, gasvmr_ccl4, & & icseed,aeraod,aerssa,sfemis,sfgtmp, & & dzlyr,delpin,de_lgth,alpha, & - & npts, nlay, nlp1, lprnt, cld_cf, lslwr, & + & npts, nlay, nlp1, lprnt, cld_cf, lslwr, top_at_1, iovr, & + & inc_minor_gas, ilwcliq, ilwcice, isubclw, & & hlwc,topflx,sfcflx,cldtau, & ! --- outputs & HLW0,HLWB,FLXPRF, & ! --- optional & cld_lwp, cld_ref_liq, cld_iwp, cld_ref_ice, & @@ -483,6 +481,27 @@ subroutine rrtmg_lw_run & ! npts : total number of horizontal points ! ! nlay, nlp1 : total number of vertical layers, levels ! ! lprnt : cntl flag for diagnostic print out ! +! inc_minor_gas - control flag for rare gases (ch4,n2o,o2,cfcs, etc.) ! +! =0: do not include rare gases ! +! >0: include all rare gases ! +! ilwcliq - control flag for liq-cloud optical properties ! +! =1: input cld liqp & reliq, hu & stamnes (1993) ! +! =2: not used ! +! ilwcice - control flag for ice-cloud optical properties ! +! =1: input cld icep & reice, ebert & curry (1997) ! +! =2: input cld icep & reice, streamer (1996) ! +! =3: input cld icep & reice, fu (1998) ! +! isubclw - sub-column cloud approximation control flag ! +! =0: no sub-col cld treatment, use grid-mean cld quantities ! +! =1: mcica sub-col, prescribed seeds to get random numbers ! +! =2: mcica sub-col, providing array icseed for random numbers! +! iovr - cloud overlapping control flag ! +! =0: random overlapping clouds ! +! =1: maximum/random overlapping clouds ! +! =2: maximum overlap cloud (used for isubclw>0 only) ! +! =3: decorrelation-length overlap (for isubclw>0 only) ! +! =4: exponential cloud overlap (AER) ! +! =5: exponential-random cloud overlap (AER) ! ! ! ! output variables: ! ! hlwc (npts,nlay): total sky heating rate (k/day or k/sec) ! @@ -508,32 +527,6 @@ subroutine rrtmg_lw_run & ! upfx0 - clear sky upward flux ! ! dnfx0 - clear sky dnward flux ! ! ! -! external module variables: (in physparam) ! -! ilwrgas - control flag for rare gases (ch4,n2o,o2,cfcs, etc.) ! -! =0: do not include rare gases ! -! >0: include all rare gases ! -! ilwcliq - control flag for liq-cloud optical properties ! -! =1: input cld liqp & reliq, hu & stamnes (1993) ! -! =2: not used ! -! ilwcice - control flag for ice-cloud optical properties ! -! =1: input cld icep & reice, ebert & curry (1997) ! -! =2: input cld icep & reice, streamer (1996) ! -! =3: input cld icep & reice, fu (1998) ! -! isubclw - sub-column cloud approximation control flag ! -! =0: no sub-col cld treatment, use grid-mean cld quantities ! -! =1: mcica sub-col, prescribed seeds to get random numbers ! -! =2: mcica sub-col, providing array icseed for random numbers! -! iovr - cloud overlapping control flag ! -! =0: random overlapping clouds ! -! =1: maximum/random overlapping clouds ! -! =2: maximum overlap cloud (used for isubclw>0 only) ! -! =3: decorrelation-length overlap (for isubclw>0 only) ! -! =4: exponential cloud overlap (AER) ! -! =5: exponential-random cloud overlap (AER) ! -! ivflip - control flag for vertical index direction ! -! =0: vertical index from toa to surface ! -! =1: vertical index from surface to toa ! -! ! ! module parameters, control variables: ! ! nbands - number of longwave spectral bands ! ! maxgas - maximum number of absorbing gaseous ! @@ -605,10 +598,11 @@ subroutine rrtmg_lw_run & ! ====================== end of definitions =================== ! ! --- inputs: - integer, intent(in) :: npts, nlay, nlp1 + integer, intent(in) :: npts, nlay, nlp1, ilwcliq, ilwcice, & + isubclw, iovr integer, intent(in) :: icseed(npts) - logical, intent(in) :: lprnt + logical, intent(in) :: lprnt, inc_minor_gas real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, & & tlvl @@ -631,6 +625,7 @@ subroutine rrtmg_lw_run & real (kind=kind_phys), dimension(:,:,:),intent(in):: & & aeraod, aerssa + logical, intent(in) :: lslwr, top_at_1 ! --- outputs: real (kind=kind_phys), dimension(:,:), intent(inout) :: hlwc @@ -650,7 +645,6 @@ subroutine rrtmg_lw_run & & intent(inout) :: hlw0 type (proflw_type), dimension(:,:), optional, & & intent(inout) :: flxprf - logical, intent(in) :: lslwr ! --- locals: real (kind=kind_phys), dimension(0:nlp1) :: cldfrc @@ -801,7 +795,7 @@ subroutine rrtmg_lw_run & ! layer pressure thickness (in mb), based on the hydrostatic equation ! --- ... and includes a correction to account for h2o in the layer. - if (ivflip == 0) then ! input from toa to sfc + if (top_at_1) then ! input from toa to sfc tem1 = 100.0 * con_g tem2 = 1.0e-20 * 1.0e3 * con_avgd @@ -841,7 +835,7 @@ subroutine rrtmg_lw_run & !! cf22, convert from volume mixing ratio to molec/cm2 based on !! coldry (scaled to 1.0e-20). - if (ilwrgas > 0) then + if (inc_minor_gas) then do k = 1, nlay k1 = nlp1 - k colamt(k,4)=max(temcol(k), coldry(k)*gasvmr_n2o(iplon,k1)) ! n2o @@ -952,7 +946,7 @@ subroutine rrtmg_lw_run & ! --- ... set up col amount for rare gases, convert from volume mixing ratio ! to molec/cm2 based on coldry (scaled to 1.0e-20) - if (ilwrgas > 0) then + if (inc_minor_gas) then do k = 1, nlay colamt(k,4)=max(temcol(k), coldry(k)*gasvmr_n2o(iplon,k)) ! n2o colamt(k,5)=max(temcol(k), coldry(k)*gasvmr_ch4(iplon,k)) ! ch4 @@ -1021,7 +1015,7 @@ subroutine rrtmg_lw_run & tem0 = 10.0 * tem2 / (amdw * tem1 * con_g) pwvcm = tem0 * plvl(iplon,1) - endif ! if_ivflip + endif ! top_at_1 !> -# Compute column amount for broadening gases. @@ -1078,6 +1072,7 @@ subroutine rrtmg_lw_run & ! --- inputs: & ( cldfrc,clwp,relw,ciwp,reiw,cda1,cda2,cda3,cda4, & & nlay, nlp1, ipseed(iplon), dz, delgth, iovr, alph, & + & ilwcliq, ilwcice, isubclw, & ! --- outputs: & cldfmc, taucld & & ) @@ -1085,7 +1080,7 @@ subroutine rrtmg_lw_run & ! --- ... save computed layer cloud optical depth for output ! rrtm band-7 is apprx 10mu channel (or use spectral mean of bands 6-8) - if (ivflip == 0) then ! input from toa to sfc + if (top_at_1) then ! input from toa to sfc do k = 1, nlay k1 = nlp1 - k cldtau(iplon,k1) = taucld( 7,k) @@ -1094,7 +1089,7 @@ subroutine rrtmg_lw_run & do k = 1, nlay cldtau(iplon,k) = taucld( 7,k) enddo - endif ! end if_ivflip_block + endif ! end if_top_at_1_block else cldfmc = f_zero @@ -1229,7 +1224,7 @@ subroutine rrtmg_lw_run & sfcflx(iplon)%dnfxc = totdflux(0) sfcflx(iplon)%dnfx0 = totdclfl(0) - if (ivflip == 0) then ! output from toa to sfc + if (top_at_1) then ! output from toa to sfc !! --- ... optional fluxes if ( lflxprf ) then @@ -1297,7 +1292,7 @@ subroutine rrtmg_lw_run & enddo endif - endif ! if_ivflip + endif ! if_top_at_1 enddo lab_do_iplon @@ -1315,8 +1310,8 @@ end subroutine rrtmg_lw_run !! spectral band are reduced from 256 g-point intervals to 140. !!\param me print control for parallel process !!\section rlwinit_gen rlwinit General Algorithm - subroutine rlwinit & - & ( me, errflg, errmsg ) + subroutine rlwinit( me, rad_hr_units, inc_minor_gas, ilwcliq, & + isubclw, iovr, errflg, errmsg ) ! =================== program usage description =================== ! ! ! @@ -1328,17 +1323,9 @@ subroutine rlwinit & ! ==================== defination of variables ==================== ! ! ! ! inputs: ! -! me - print control for parallel process ! -! ! -! outputs: (none) ! -! ! -! external module variables: (in physparam) ! -! ilwrate - heating rate unit selections ! -! =1: output in k/day ! -! =2: output in k/second ! -! ilwrgas - control flag for rare gases (ch4,n2o,o2,cfcs, etc.) ! -! =0: do not include rare gases ! -! >0: include all rare gases ! +! me - print control for parallel process ! +! rad_hr_units - 1 for heating rates in units K/day. 2 for K/s ! +! inc_minor_gas - flag to turn on/off minor gases in rrtmg ! ! ilwcliq - liquid cloud optical properties contrl flag ! ! =0: input cloud opt depth from diagnostic scheme ! ! >0: input cwp,rew, and other cloud content parameters ! @@ -1346,9 +1333,6 @@ subroutine rlwinit & ! =0: no sub-col cld treatment, use grid-mean cld quantities ! ! =1: mcica sub-col, prescribed seeds to get random numbers ! ! =2: mcica sub-col, providing array icseed for random numbers! -! icldflg - cloud scheme control flag ! -! =0: diagnostic scheme gives cloud tau, omiga, and g. ! -! =1: prognostic scheme gives cloud liq/ice path, etc. ! ! iovr - clouds vertical overlapping control flag ! ! =0: random overlapping clouds ! ! =1: maximum/random overlapping clouds ! @@ -1357,6 +1341,10 @@ subroutine rlwinit & ! =4: exponential cloud overlap (AER) ! ! =5: exponential-random cloud overlap (AER) ! ! ! +! outputs: ! +! errflg - error flag ! +! errmsg - error message ! +! ! ! ******************************************************************* ! ! original code description ! ! ! @@ -1385,7 +1373,8 @@ subroutine rlwinit & ! ====================== end of description block ================= ! ! --- inputs: - integer, intent(in) :: me + integer, intent(in) :: me, rad_hr_units, ilwcliq, isubclw, iovr + logical, intent(in) :: inc_minor_gas ! --- outputs: character(len=*), intent(out) :: errmsg @@ -1405,27 +1394,10 @@ subroutine rlwinit & errflg = 0 errmsg = '' - if ( iovr<0 .or. iovr>5 ) then - print *,' *** Error in specification of cloud overlap flag', & - & ' IOVR=',iovr,' in RLWINIT !!' - errflg = 1 - errmsg = 'ERROR(rlwinit): cloud-overlap (iovr) scheme selected not valid.' - return - elseif ( (iovr==2 .or. iovr==3) .and. isubclw==0 ) then - if (me == 0) then - print *,' *** IOVR=',iovr,' is not available for', & - & ' ISUBCLW=0 setting!!' - print *,' The program uses maximum/random overlap', & - & ' instead.' - endif - - iovr = 1 - endif - if (me == 0) then print *,' - Using AER Longwave Radiation, Version: ', VTAGLW - if (ilwrgas > 0) then + if (inc_minor_gas) then print *,' --- Include rare gases N2O, CH4, O2, CFCs ', & & 'absorptions in LW' else @@ -1441,27 +1413,9 @@ subroutine rlwinit & elseif ( isubclw == 2 ) then print *,' --- Using MCICA sub-colum clouds approximation ', & & 'with provided input array of permutation seeds' - else - print *,' *** Error in specification of sub-column cloud ', & - & ' control flag isubclw =',isubclw,' !!' - errflg = 1 - errmsg = 'ERROR(rlwinit): sub-column scheme (isubclw) selected not valid.' - return endif endif -!> -# Check cloud flags for consistency. - - if ((icldflg == 0 .and. ilwcliq /= 0) .or. & - & (icldflg == 1 .and. ilwcliq == 0)) then - print *,' *** Model cloud scheme inconsistent with LW', & - & ' radiation cloud radiative property setup !!' - errflg = 1 - errmsg = 'ERROR(rlwinit): Model cloud scheme inconsistent with LW'//& - & ' radiation cloud radiative property setup' - return - endif - !> -# Setup default surface emissivity for each band. semiss0(:) = f_one @@ -1473,7 +1427,7 @@ subroutine rlwinit & fluxfac = pival * 2.0d4 ! fluxfac = 62831.85307179586 ! = 2 * pi * 1.0e4 - if (ilwrate == 1) then + if (rad_hr_units == 1) then ! heatfac = 8.4391 ! heatfac = con_g * 86400. * 1.0e-2 / con_cp ! (in k/day) heatfac = con_g * 864.0 / con_cp ! (in k/day) @@ -1559,8 +1513,8 @@ end subroutine rlwinit !!\section gen_cldprop cldprop General Algorithm subroutine cldprop & & ( cfrac,cliqp,reliq,cicep,reice,cdat1,cdat2,cdat3,cdat4, & ! --- inputs - & nlay, nlp1, ipseed, dz, de_lgth, iovr, alpha, & - & cldfmc, taucld & ! --- outputs + & nlay, nlp1, ipseed, dz, de_lgth, iovr, alpha, ilwcliq, & + & ilwcice, isubclw, cldfmc, taucld & ! --- outputs & ) ! =================== program usage description =================== ! @@ -1660,7 +1614,8 @@ subroutine cldprop & use module_radlw_cldprlw ! --- inputs: - integer, intent(in) :: nlay, nlp1, ipseed, iovr + integer, intent(in) :: nlay, nlp1, ipseed, iovr, ilwcliq, ilwcice,& + isubclw real (kind=kind_phys), dimension(0:nlp1), intent(in) :: cfrac real (kind=kind_phys), dimension(nlay), intent(in) :: cliqp, & @@ -1825,7 +1780,7 @@ subroutine cldprop & endif lab_if_ilwcliq -!> -# if physparam::isubclw > 0, call mcica_subcol() to distribute +!> -# if GFS_typedefs::isubclw > 0, call mcica_subcol() to distribute !! cloud properties to each g-point. if ( isubclw > 0 ) then ! mcica sub-col clouds approx @@ -1841,7 +1796,7 @@ subroutine cldprop & call mcica_subcol & ! --- inputs: - & ( cldf, nlay, ipseed, dz, de_lgth, alpha, & + & ( cldf, nlay, ipseed, dz, de_lgth, alpha, iovr, & ! --- output: & lcloudy & & ) @@ -1874,7 +1829,7 @@ end subroutine cldprop !!\param lcloudy sub-colum cloud profile flag array !!\section mcica_subcol_gen mcica_subcol General Algorithm subroutine mcica_subcol & - & ( cldf, nlay, ipseed, dz, de_lgth, alpha, & ! --- inputs + & ( cldf, nlay, ipseed, dz, de_lgth, alpha, iovr, & ! --- inputs & lcloudy & ! --- outputs & ) @@ -1889,22 +1844,20 @@ subroutine mcica_subcol & ! for lw and sw, use values differ by the number of g-pts. ! ! dz - real, layer thickness (km) nlay ! ! de_lgth - real, layer cloud decorrelation length (km) 1 ! -! alpha - real, EXP/ER decorrelation parameter nlay ! +! alpha - real, EXP/ER decorrelation parameter nlay ! +! iovr - control flag for cloud overlapping method 1 ! +! =0:random; =1:maximum/random: =2:maximum; =3:decorr ! +! =4:exponential; =5:exponential-random ! ! ! ! output variables: ! ! lcloudy - logical, sub-colum cloud profile flag array ngptlw*nlay! ! ! -! other control flags from module variables: ! -! iovr : control flag for cloud overlapping method ! -! =0:random; =1:maximum/random: =2:maximum; =3:decorr ! -! =4:exponential; =5:exponential-random ! -! ! ! ===================== end of definitions ==================== ! implicit none ! --- inputs: - integer, intent(in) :: nlay, ipseed + integer, intent(in) :: nlay, ipseed, iovr real (kind=kind_phys), dimension(nlay), intent(in) :: cldf, dz real (kind=kind_phys), intent(in) :: de_lgth diff --git a/physics/radlw_main.meta b/physics/radlw_main.meta index 9286c45cb..8dc1db046 100644 --- a/physics/radlw_main.meta +++ b/physics/radlw_main.meta @@ -241,6 +241,48 @@ dimensions = () type = logical intent = in +[top_at_1] + standard_name = flag_for_vertical_ordering_in_RRTMGP + long_name = flag for vertical ordering in RRTMGP + units = flag + dimensions = () + type = logical + intent = in +[iovr] + standard_name = flag_for_cloud_overlap_method_for_radiation + long_name = flag for cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[inc_minor_gas] + standard_name = flag_to_include_minor_gases_in_rrtmg + long_name = flag to include minor trace gases in rrtmg + units = flag + dimensions = () + type = logical + intent = in +[ilwcliq] + standard_name = flag_for_rrtmg_lw_cloud_optics + long_name = flag for rrtmg longwave cloud optics + units = flag + dimensions = () + type = integer + intent = in +[ilwcice] + standard_name = flag_for_rrtmg_lw_ice_cloud_optics + long_name = flag for rrtmg longwave ice cloud optics + units = flag + dimensions = () + type = integer + intent = in +[isubclw] + standard_name = flag_for_lw_clouds_sub_grid_approximation + long_name = flag for lw clouds sub-grid approximation + units = flag + dimensions = () + type = integer + intent = in [hlwc] standard_name = tendency_of_air_temperature_due_to_longwave_heating_on_radiation_time_step_and_radiation_levels long_name = longwave total sky heating rate diff --git a/physics/radlw_param.f b/physics/radlw_param.f index fa7ceecb0..bc2aae224 100644 --- a/physics/radlw_param.f +++ b/physics/radlw_param.f @@ -65,7 +65,7 @@ module module_radlw_parameters ! !! \htmlinclude module_radlw_parameters.html !! - use physparam, only : kind_phys + use machine, only : kind_phys implicit none ! diff --git a/physics/radsw_datatb.f b/physics/radsw_datatb.f index 6d88f1989..e0bb651e9 100644 --- a/physics/radsw_datatb.f +++ b/physics/radsw_datatb.f @@ -73,7 +73,7 @@ module module_radsw_ref ! !........................................! ! - use physparam, only : kind_phys + use machine, only : kind_phys ! implicit none ! @@ -217,7 +217,7 @@ module module_radsw_cldprtb ! ! ! ! ************************* end description ************************ ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radsw_parameters, only : nblow, nbhgh ! implicit none @@ -2503,7 +2503,7 @@ module module_radsw_sflux ! ! ! ! ************************* end description ************************ ! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radsw_parameters, only : NGMAX, NG16, NG17, NG18, NG19,& & NG20, NG21, NG22, NG23, NG24, & & NG25, NG26, NG27, NG28, NG29, & @@ -2838,7 +2838,7 @@ module module_radsw_kgb16 ! ! ! ! ************************ end description ************************ ! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radsw_parameters, only : NG16 ! @@ -4031,7 +4031,7 @@ module module_radsw_kgb17 ! ! ! ! ********* ********* end description ********* ********* ! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radsw_parameters, only : NG17 ! @@ -8640,7 +8640,7 @@ module module_radsw_kgb18 ! ! ! ! ********* ********* end description ********* ********* ! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radsw_parameters, only : NG18 ! @@ -10158,7 +10158,7 @@ module module_radsw_kgb19 ! ! ! ! ********* ********* end description ********* ********* ! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radsw_parameters, only : NG19 ! @@ -11677,7 +11677,7 @@ module module_radsw_kgb20 ! ! ! ! ********* ********* end description ********* ********* ! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radsw_parameters, only : NG20 ! @@ -12461,7 +12461,7 @@ module module_radsw_kgb21 ! ! ! ! ********* ********* end description ********* ********* ! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radsw_parameters, only : NG21 ! @@ -16319,7 +16319,7 @@ module module_radsw_kgb22 ! ! ! ! ********* ********* end description ********* ********* ! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radsw_parameters, only : NG22 ! @@ -16766,7 +16766,7 @@ module module_radsw_kgb23 ! ! ! ! ********* ********* end description ********* ********* ! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radsw_parameters, only : NG23 ! @@ -17023,7 +17023,7 @@ module module_radsw_kgb24 ! ! ! ! ********* ********* end description ********* ********* ! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radsw_parameters, only : NG24 ! @@ -18588,7 +18588,7 @@ module module_radsw_kgb25 ! ! ! ! ********* ********* end description ********* ********* ! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radsw_parameters, only : NG25 ! @@ -18748,7 +18748,7 @@ module module_radsw_kgb26 ! ! ! ! ********* ********* end description ********* ********* ! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radsw_parameters, only : NG26 ! @@ -18784,7 +18784,7 @@ module module_radsw_kgb27 ! ! ! ! ********* ********* end description ********* ********* ! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radsw_parameters, only : NG27 ! @@ -19387,7 +19387,7 @@ module module_radsw_kgb28 ! ! ! ! ********* ********* end description ********* ********* ! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radsw_parameters, only : NG28 ! @@ -21701,7 +21701,7 @@ module module_radsw_kgb29 ! ! ! ! ********* ********* end description ********* ********* ! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radsw_parameters, only : NG29 ! diff --git a/physics/radsw_main.F90 b/physics/radsw_main.F90 index f24dcff86..cf6c37346 100644 --- a/physics/radsw_main.F90 +++ b/physics/radsw_main.F90 @@ -90,7 +90,6 @@ ! ! ! external modules referenced: ! ! ! -! 'module physparam' ! ! 'module physcons' ! ! 'mersenne_twister' ! ! ! @@ -304,9 +303,6 @@ !! rrtmg-sw radiation code from aer inc. module rrtmg_sw ! - use physparam, only : iswrate, iswrgas, iswcliq, iswcice, & - & isubcsw, icldflg, iovr, ivflip, & - & iswmode use physcons, only : con_g, con_cp, con_avgd, con_amd, & & con_amw, con_amo3 use machine, only : rb => kind_phys, im => kind_io4, & @@ -503,7 +499,8 @@ subroutine rrtmg_sw_run & & sfcalb_uvis_dir, sfcalb_uvis_dif, & & dzlyr,delpin,de_lgth,alpha, & & cosz,solcon,NDAY,idxday, & - & npts, nlay, nlp1, lprnt, & + & npts, nlay, nlp1, lprnt, inc_minor_gas, iswcliq, iswcice, & + & isubcsw, iovr, top_at_1, iswmode, & & cld_cf, lsswr, & & hswc,topflx,sfcflx,cldtau, & ! --- outputs & HSW0,HSWB,FLXPRF,FDNCMP, & ! --- optional @@ -570,6 +567,30 @@ subroutine rrtmg_sw_run & ! npts : number of horizontal points ! ! nlay,nlp1 : vertical layer/lavel numbers ! ! lprnt : logical check print flag ! +! iswcliq - control flag for liq-cloud optical properties ! +! =0: input cloud optical depth, fixed ssa, asy ! +! =1: use hu and stamnes(1993) method for liq cld ! +! =2: use updated coeffs for hu and stamnes scheme ! +! iswcice - control flag for ice-cloud optical properties ! +! *** if iswcliq==0, iswcice is ignored ! +! =1: use ebert and curry (1992) scheme for ice clouds ! +! =2: use streamer v3.0 (2001) method for ice clouds ! +! =3: use fu's method (1996) for ice clouds ! +! iswmode - control flag for 2-stream transfer scheme ! +! =1; delta-eddington (joseph et al., 1976) ! +! =2: pifm (zdunkowski et al., 1980) ! +! =3: discrete ordinates (liou, 1973) ! +! isubcsw - sub-column cloud approximation control flag ! +! =0: no sub-col cld treatment, use grid-mean cld quantities ! +! =1: mcica sub-col, prescribed seeds to get random numbers ! +! =2: mcica sub-col, providing array icseed for random numbers! +! iovr - cloud overlapping control flag ! +! =0: random overlapping clouds ! +! =1: maximum/random overlapping clouds ! +! =2: maximum overlap cloud ! +! =3: decorrelation-length overlap clouds ! +! =4: exponential cloud overlap (AER) ! +! =5: exponential-random cloud overlap (AER) ! ! ! ! output variables: ! ! hswc (npts,nlay): total sky heating rates (k/sec or k/day) ! @@ -604,38 +625,6 @@ subroutine rrtmg_sw_run & ! visbm - downward surface uv+vis direct beam flux ! ! visdf - downward surface uv+vis diffused flux ! ! ! -! external module variables: (in physparam) ! -! iswrgas - control flag for rare gases (ch4,n2o,o2, etc.) ! -! =0: do not include rare gases ! -! >0: include all rare gases ! -! iswcliq - control flag for liq-cloud optical properties ! -! =0: input cloud optical depth, fixed ssa, asy ! -! =1: use hu and stamnes(1993) method for liq cld ! -! =2: use updated coeffs for hu and stamnes scheme ! -! iswcice - control flag for ice-cloud optical properties ! -! *** if iswcliq==0, iswcice is ignored ! -! =1: use ebert and curry (1992) scheme for ice clouds ! -! =2: use streamer v3.0 (2001) method for ice clouds ! -! =3: use fu's method (1996) for ice clouds ! -! iswmode - control flag for 2-stream transfer scheme ! -! =1; delta-eddington (joseph et al., 1976) ! -! =2: pifm (zdunkowski et al., 1980) ! -! =3: discrete ordinates (liou, 1973) ! -! isubcsw - sub-column cloud approximation control flag ! -! =0: no sub-col cld treatment, use grid-mean cld quantities ! -! =1: mcica sub-col, prescribed seeds to get random numbers ! -! =2: mcica sub-col, providing array icseed for random numbers! -! iovr - cloud overlapping control flag ! -! =0: random overlapping clouds ! -! =1: maximum/random overlapping clouds ! -! =2: maximum overlap cloud ! -! =3: decorrelation-length overlap clouds ! -! =4: exponential cloud overlap (AER) ! -! =5: exponential-random cloud overlap (AER) ! -! ivflip - control flg for direction of vertical index ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! ! ! module parameters, control variables: ! ! nblow,nbhgh - lower and upper limits of spectral bands ! ! maxgas - maximum number of absorbing gaseous ! @@ -690,11 +679,12 @@ subroutine rrtmg_sw_run & ! ===================== end of definitions ==================== ! ! --- inputs: - integer, intent(in) :: npts, nlay, nlp1, NDAY + integer, intent(in) :: npts, nlay, nlp1, NDAY, iswcliq, iswcice, & + isubcsw, iovr, iswmode integer, dimension(:), intent(in) :: idxday, icseed - logical, intent(in) :: lprnt, lsswr + logical, intent(in) :: lprnt, lsswr, inc_minor_gas, top_at_1 real (kind=kind_phys), dimension(:,:), intent(in) :: & & plvl, tlvl @@ -910,7 +900,7 @@ subroutine rrtmg_sw_run & !> - Prepare atmospheric profile for use in rrtm. ! the vertical index of internal array is from surface to top - if (ivflip == 0) then ! input from toa to sfc + if (top_at_1) then ! input from toa to sfc tem1 = 100.0 * con_g tem2 = 1.0e-20 * 1.0e3 * con_avgd @@ -950,7 +940,7 @@ subroutine rrtmg_sw_run & ! --- ... set up gas column amount, convert from volume mixing ratio ! to molec/cm2 based on coldry (scaled to 1.0e-20) - if (iswrgas > 0) then + if (inc_minor_gas) then do k = 1, nlay kk = nlp1 - k colamt(k,4) = max(temcol(k), coldry(k)*gasvmr_n2o(j1,kk)) ! n2o @@ -1047,7 +1037,7 @@ subroutine rrtmg_sw_run & ! --- ... set up gas column amount, convert from volume mixing ratio ! to molec/cm2 based on coldry (scaled to 1.0e-20) - if (iswrgas > 0) then + if (inc_minor_gas) then do k = 1, nlay colamt(k,4) = max(temcol(k), coldry(k)*gasvmr_n2o(j1,k)) ! n2o colamt(k,5) = max(temcol(k), coldry(k)*gasvmr_ch4(j1,k)) ! ch4 @@ -1094,7 +1084,7 @@ subroutine rrtmg_sw_run & enddo endif ! end if_iswcliq - endif ! if_ivflip + endif ! if_top_at_1 !> - Compute fractions of clear sky view: !! - random overlapping @@ -1135,7 +1125,8 @@ subroutine rrtmg_sw_run & call cldprop & ! --- inputs: & ( cfrac,cliqp,reliq,cicep,reice,cdat1,cdat2,cdat3,cdat4, & - & zcf1, nlay, ipseed(j1), dz, delgth, alph, & + & zcf1, nlay, ipseed(j1), dz, delgth, alph, iswcliq, iswcice,& + & isubcsw, iovr, & ! --- outputs: & taucw, ssacw, asycw, cldfrc, cldfmc & & ) @@ -1143,7 +1134,7 @@ subroutine rrtmg_sw_run & ! --- ... save computed layer cloud optical depth for output ! rrtm band 10 is approx to the 0.55 mu spectrum - if (ivflip == 0) then ! input from toa to sfc + if (top_at_1) then ! input from toa to sfc do k = 1, nlay kk = nlp1 - k cldtau(j1,kk) = taucw(k,10) @@ -1152,7 +1143,7 @@ subroutine rrtmg_sw_run & do k = 1, nlay cldtau(j1,k) = taucw(k,10) enddo - endif ! end if_ivflip_block + endif ! end if_top_at_1_block else ! clear sky column cldfrc(:) = f_zero @@ -1187,9 +1178,9 @@ subroutine rrtmg_sw_run & & ) !> - Call the 2-stream radiation transfer model: -!! - if physparam::isubcsw .le.0, using standard cloud scheme, +!! - if GFS_typedefs::isubcsw .le.0, using standard cloud scheme, !! call spcvrtc(). -!! - if physparam::isubcsw .gt.0, using mcica cloud scheme, +!! - if GFS_typedefs::isubcsw .gt.0, using mcica cloud scheme, !! call spcvrtm(). if ( isubcsw <= 0 ) then ! use standard cloud scheme @@ -1198,7 +1189,7 @@ subroutine rrtmg_sw_run & ! --- inputs: & ( ssolar,cosz1,sntz1,albbm,albdf,sfluxzen,cldfrc, & & zcf1,zcf0,taug,taur,tauae,ssaae,asyae,taucw,ssacw,asycw, & - & nlay, nlp1, & + & nlay, nlp1, iswmode, & ! --- outputs: & fxupc,fxdnc,fxup0,fxdn0, & & ftoauc,ftoau0,ftoadc,fsfcuc,fsfcu0,fsfcdc,fsfcd0, & @@ -1211,7 +1202,7 @@ subroutine rrtmg_sw_run & ! --- inputs: & ( ssolar,cosz1,sntz1,albbm,albdf,sfluxzen,cldfmc, & & zcf1,zcf0,taug,taur,tauae,ssaae,asyae,taucw,ssacw,asycw, & - & nlay, nlp1, & + & nlay, nlp1, iswmode, & ! --- outputs: & fxupc,fxdnc,fxup0,fxdn0, & & ftoauc,ftoau0,ftoadc,fsfcuc,fsfcu0,fsfcdc,fsfcd0, & @@ -1276,7 +1267,7 @@ subroutine rrtmg_sw_run & sfcflx(j1)%upfx0 = fsfcu0 sfcflx(j1)%dnfx0 = fsfcd0 - if (ivflip == 0) then ! output from toa to sfc + if (top_at_1) then ! output from toa to sfc ! --- ... compute heating rates @@ -1372,7 +1363,7 @@ subroutine rrtmg_sw_run & enddo endif - endif ! if_ivflip + endif ! if_top_at_1 enddo lab_do_ipt @@ -1387,9 +1378,8 @@ end subroutine rrtmg_sw_run !!\param me print control for parallel process !>\section rswinit_gen rswinit General Algorithm !----------------------------------- - subroutine rswinit & - & ( me, errflg, errmsg ) ! --- inputs: -! --- outputs: (none) + subroutine rswinit( me, rad_hr_units, inc_minor_gas, iswcliq, & + isubcsw, iovr, iswmode, errflg, errmsg ) ! =================== program usage description =================== ! ! ! @@ -1401,17 +1391,8 @@ subroutine rswinit & ! ==================== defination of variables ==================== ! ! ! ! inputs: ! -! me - print control for parallel process ! -! ! -! outputs: (none) ! -! ! -! external module variables: (in physparam) ! -! iswrate - heating rate unit selections ! -! =1: output in k/day ! -! =2: output in k/second ! -! iswrgas - control flag for rare gases (ch4,n2o,o2, etc.) ! -! =0: do not include rare gases ! -! >0: include all rare gases ! +! me - print control for parallel process ! +! rad_hr_units - ! ! iswcliq - liquid cloud optical properties contrl flag ! ! =0: input cloud opt depth from diagnostic scheme ! ! >0: input cwp,rew, and other cloud content parameters ! @@ -1419,9 +1400,6 @@ subroutine rswinit & ! =0: no sub-col cld treatment, use grid-mean cld quantities ! ! =1: mcica sub-col, prescribed seeds to get random numbers ! ! =2: mcica sub-col, providing array icseed for random numbers! -! icldflg - cloud scheme control flag ! -! =0: diagnostic scheme gives cloud tau, omiga, and g. ! -! =1: prognostic scheme gives cloud liq/ice path, etc. ! ! iovr - clouds vertical overlapping control flag ! ! =0: random overlapping clouds ! ! =1: maximum/random overlapping clouds ! @@ -1434,6 +1412,9 @@ subroutine rswinit & ! =2: pifm (zdunkowski et al., 1980) ! ! =3: discrete ordinates (liou, 1973) ! ! ! +! outputs: ! +! errflg - error flag ! +! errmsg - error message ! ! ******************************************************************* ! ! ! ! definitions: ! @@ -1446,8 +1427,9 @@ subroutine rswinit & ! ====================== end of description block ================= ! ! --- inputs: - integer, intent(in) :: me - + integer, intent(in) :: me, rad_hr_units, iswcliq, isubcsw, iovr, & + iswmode + logical, intent(in) :: inc_minor_gas ! --- outputs: character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -1466,14 +1448,6 @@ subroutine rswinit & errflg = 0 errmsg = '' - if ( iovr<0 .or. iovr>5 ) then - print *,' *** Error in specification of cloud overlap flag', & - & ' IOVR=',iovr,' in RSWINIT !!' - errflg = 1 - errmsg = 'ERROR(rswinit): cloud-overlap (iovr) scheme selected not valid.' - return - endif - if (me == 0) then print *,' - Using AER Shortwave Radiation, Version: ',VTAGSW @@ -1485,7 +1459,7 @@ subroutine rswinit & print *,' --- Discrete ordinates 2-stream transfer scheme' endif - if (iswrgas <= 0) then + if (.not. inc_minor_gas) then print *,' --- Rare gases absorption is NOT included in SW' else print *,' --- Include rare gases N2O, CH4, O2, absorptions',& @@ -1501,42 +1475,13 @@ subroutine rswinit & elseif ( isubcsw == 2 ) then print *,' --- Using MCICA sub-colum clouds approximation ', & & 'with provided input array of permutation seeds' - else - print *,' *** Error in specification of sub-column cloud ', & - & ' control flag isubcsw =',isubcsw,' !!' - errflg = 1 - errmsg = 'ERROR(rswinit): sub-column scheme (isubcsw) selected not valid.' - return endif endif -!> - Check cloud flags for consistency. - - if ((icldflg == 0 .and. iswcliq /= 0) .or. & - & (icldflg == 1 .and. iswcliq == 0)) then - print *,' *** Model cloud scheme inconsistent with SW', & - & ' radiation cloud radiative property setup !!' - errflg = 1 - errmsg = 'ERROR(rswinit): Model cloud scheme inconsistent with SW'//& - & ' radiation cloud radiative property setup' - return - endif - - if ( isubcsw==0 .and. iovr>2 ) then - if (me == 0) then - print *,' *** IOVR=',iovr,' is not available for', & - & ' ISUBCSW=0 setting!!' - print *,' The program will use maximum/random overlap', & - & ' instead.' - endif - - iovr = 1 - endif - !> - Setup constant factors for heating rate !! the 1.0e-2 is to convert pressure from mb to \f$N/m^2\f$ . - if (iswrate == 1) then + if (rad_hr_units == 1) then ! heatfac = 8.4391 ! heatfac = con_g * 86400. * 1.0e-2 / con_cp ! (in k/day) heatfac = con_g * 864.0 / con_cp ! (in k/day) @@ -1573,7 +1518,7 @@ end subroutine rswinit !> This subroutine computes the cloud optical properties for each !! cloudy layer and g-point interval. !!\param cfrac layer cloud fraction -!!\n for physparam::iswcliq > 0 (prognostic cloud scheme) - - - +!!\n for GFS_typedefs::iswcliq > 0 (prognostic cloud scheme) - - - !!\param cliqp layer in-cloud liq water path (\f$g/m^2\f$) !!\param reliq mean eff radius for liq cloud (micron) !!\param cicep layer in-cloud ice water path (\f$g/m^2\f$) @@ -1582,7 +1527,7 @@ end subroutine rswinit !!\param cdat2 effective radius for rain drop (micron) !!\param cdat3 layer snow flake water path(\f$g/m^2\f$) !!\param cdat4 mean eff radius for snow flake(micron) -!!\n for physparam::iswcliq = 0 (diagnostic cloud scheme) - - - +!!\n for GFS_typedefs::iswcliq = 0 (diagnostic cloud scheme) - - - !!\param cliqp not used !!\param cicep not used !!\param reliq not used @@ -1609,8 +1554,8 @@ end subroutine rswinit !----------------------------------- subroutine cldprop & & ( cfrac,cliqp,reliq,cicep,reice,cdat1,cdat2,cdat3,cdat4, & ! --- inputs - & cf1, nlay, ipseed, dz, delgth, alpha, & - & taucw, ssacw, asycw, cldfrc, cldfmc & ! --- output + & cf1, nlay, ipseed, dz, delgth, alpha, iswcliq, iswcice, & + & isubcsw, iovr, taucw, ssacw, asycw, cldfrc, cldfmc & ! --- output & ) ! =================== program usage description =================== ! @@ -1661,7 +1606,7 @@ subroutine cldprop & ! ! ! ! ! explanation of the method for each value of iswcliq, and iswcice. ! -! set up in module "physparam" ! +! provided by host-model ! ! ! ! iswcliq=0 : input cloud optical property (tau, ssa, asy). ! ! (used for diagnostic cloud method) ! @@ -1696,7 +1641,8 @@ subroutine cldprop & use module_radsw_cldprtb ! --- inputs: - integer, intent(in) :: nlay, ipseed + integer, intent(in) :: nlay, ipseed, iswcliq, iswcice, isubcsw, & + iovr real (kind=kind_phys), intent(in) :: cf1, delgth real (kind=kind_phys), dimension(nlay), intent(in) :: cliqp, & @@ -1954,7 +1900,7 @@ subroutine cldprop & call mcica_subcol & ! --- inputs: - & ( cldf, nlay, ipseed, dz, delgth, alpha, & + & ( cldf, nlay, ipseed, dz, delgth, alpha, iovr, & ! --- outputs: & lcloudy & & ) @@ -1993,7 +1939,7 @@ end subroutine cldprop !!\section mcica_sw_gen mcica_subcol General Algorithm ! ---------------------------------- subroutine mcica_subcol & - & ( cldf, nlay, ipseed, dz, de_lgth, alpha, & ! --- inputs + & ( cldf, nlay, ipseed, dz, de_lgth, alpha, iovr, & ! --- inputs & lcloudy & ! --- outputs & ) @@ -2006,15 +1952,10 @@ subroutine mcica_subcol & ! ** note : if the cloud generator is called multiple times, need ! ! to permute the seed between each call; if between calls ! ! for lw and sw, use values differ by the number of g-pts. ! -! dz - real, layer thickness (km) nlay ! -! de_lgth-real, layer cloud decorrelation length (km) 1 ! -! alpha - real, EXP/ER decorrelation parameter nlay ! -! ! -! output variables: ! -! lcloudy - logical, sub-colum cloud profile flag array nlay*ngptsw! -! ! -! other control flags from module variables: ! -! iovr : control flag for cloud overlapping method ! +! dz - real, layer thickness (km) nlay ! +! de_lgth - real, layer cloud decorrelation length (km) 1 ! +! alpha - real, EXP/ER decorrelation parameter nlay ! +! iovr - control flag for cloud overlapping method 1 ! ! =0: random ! ! =1: maximum/random overlapping clouds ! ! =2: maximum overlap cloud ! @@ -2022,12 +1963,15 @@ subroutine mcica_subcol & ! =4: exponential cloud overlap method (AER) ! ! =5: exponential-random cloud overlap method (AER) ! ! ! +! output variables: ! +! lcloudy - logical, sub-colum cloud profile flag array nlay*ngptsw! +! ! ! ===================== end of definitions ==================== ! implicit none ! --- inputs: - integer, intent(in) :: nlay, ipseed + integer, intent(in) :: nlay, ipseed, iovr real (kind=kind_phys), dimension(nlay), intent(in) :: cldf, dz real (kind=kind_phys), intent(in) :: de_lgth @@ -2477,7 +2421,7 @@ end subroutine setcoef subroutine spcvrtc & & ( ssolar,cosz,sntz,albbm,albdf,sfluxzen,cldfrc, & ! --- inputs & cf1,cf0,taug,taur,tauae,ssaae,asyae,taucw,ssacw,asycw, & - & nlay, nlp1, & + & nlay, nlp1, iswmode, & & fxupc,fxdnc,fxup0,fxdn0, & ! --- outputs & ftoauc,ftoau0,ftoadc,fsfcuc,fsfcu0,fsfcdc,fsfcd0, & & sfbmc,sfdfc,sfbm0,sfdf0,suvbfc,suvbf0 & @@ -2539,7 +2483,7 @@ subroutine spcvrtc & ! zldbt - real, layer beam transmittance for clear/cloudy nlp1 ! ! ztdbt - real, lev total beam transmittance for clr/cld nlp1 ! ! ! -! control parameters in module "physparam" ! +! control parameters in module "GFS_typedefs" ! ! iswmode - control flag for 2-stream transfer schemes ! ! = 1 delta-eddington (joseph et al., 1976) ! ! = 2 pifm (zdunkowski et al., 1980) ! @@ -2580,7 +2524,7 @@ subroutine spcvrtc & real (kind=kind_phys), parameter :: eps1 = 1.0e-8 ! --- inputs: - integer, intent(in) :: nlay, nlp1 + integer, intent(in) :: nlay, nlp1, iswmode real (kind=kind_phys), dimension(nlay,ngptsw), intent(in) :: & & taug, taur @@ -2685,7 +2629,7 @@ subroutine spcvrtc & !! transmittance. ! - Set up toa direct beam and surface values (beam and diff). ! - Delta scaling for clear-sky condition. -! - General two-stream expressions for physparam::iswmode . +! - General two-stream expressions. ! - Compute homogeneous reflectance and transmittance for both ! conservative and non-conservative scattering. ! - Pre-delta-scaling clear and cloudy direct beam transmittance. @@ -2717,7 +2661,7 @@ subroutine spcvrtc & zasy3 = 0.75 * zasy1 !> - Perform general two-stream expressions: -!!\n control parameters in module "physparam" +!!\n control parameters provided by host-model !!\n iswmode - control flag for 2-stream transfer schemes !!\n = 1 delta-eddington (joseph et al., 1976) !!\n = 2 pifm (zdunkowski et al., 1980) @@ -2911,7 +2855,7 @@ subroutine spcvrtc & !! transmittance. ! - Set up toa direct beam and surface values (beam and diff) ! - Delta scaling for total-sky condition -! - General two-stream expressions for physparam::iswmode +! - General two-stream expressions ! - Compute homogeneous reflectance and transmittance for ! conservative scattering and non-conservative scattering ! - Pre-delta-scaling clear and cloudy direct beam transmittance @@ -2946,7 +2890,7 @@ subroutine spcvrtc & zasy3 = 0.75 * zasy1 !> - Perform general two-stream expressions: -!!\n control parameters in module "physparam" +!!\n control parameters provided by host-model !!\n iswmode - control flag for 2-stream transfer schemes !!\n = 1 delta-eddington (joseph et al., 1976) !!\n = 2 pifm (zdunkowski et al., 1980) @@ -3273,7 +3217,7 @@ end subroutine spcvrtc subroutine spcvrtm & & ( ssolar,cosz,sntz,albbm,albdf,sfluxzen,cldfmc, & ! --- inputs & cf1,cf0,taug,taur,tauae,ssaae,asyae,taucw,ssacw,asycw, & - & nlay, nlp1, & + & nlay, nlp1, iswmode, & & fxupc,fxdnc,fxup0,fxdn0, & ! --- outputs & ftoauc,ftoau0,ftoadc,fsfcuc,fsfcu0,fsfcdc,fsfcd0, & & sfbmc,sfdfc,sfbm0,sfdf0,suvbfc,suvbf0 & @@ -3309,6 +3253,10 @@ subroutine spcvrtm & ! ssacw - real, weighted cloud single scat albedo nlay*nbdsw ! ! asycw - real, weighted cloud asymmetry factor nlay*nbdsw ! ! nlay,nlp1 - integer, number of layers/levels 1 ! +! iswmode - control flag for 2-stream transfer schemes ! +! = 1 delta-eddington (joseph et al., 1976) ! +! = 2 pifm (zdunkowski et al., 1980) ! +! = 3 discrete ordinates (liou, 1973) ! ! ! ! output variables: ! ! fxupc - real, tot sky upward flux nlp1*nbdsw ! @@ -3337,12 +3285,6 @@ subroutine spcvrtm & ! zldbt - real, layer beam transmittance for clear/cloudy nlp1 ! ! ztdbt - real, lev total beam transmittance for clr/cld nlp1 ! ! ! -! control parameters in module "physparam" ! -! iswmode - control flag for 2-stream transfer schemes ! -! = 1 delta-eddington (joseph et al., 1976) ! -! = 2 pifm (zdunkowski et al., 1980) ! -! = 3 discrete ordinates (liou, 1973) ! -! ! ! ******************************************************************* ! ! original code description ! ! ! @@ -3378,7 +3320,7 @@ subroutine spcvrtm & real (kind=kind_phys), parameter :: eps1 = 1.0e-8 ! --- inputs: - integer, intent(in) :: nlay, nlp1 + integer, intent(in) :: nlay, nlp1, iswmode real (kind=kind_phys), dimension(nlay,ngptsw), intent(in) :: & & taug, taur, cldfmc @@ -3482,7 +3424,7 @@ subroutine spcvrtm & !! transmittance. ! - Set up toa direct beam and surface values (beam and diff) ! - Delta scaling for clear-sky condition -! - General two-stream expressions for physparam::iswmode +! - General two-stream expressions ! - Compute homogeneous reflectance and transmittance for both ! conservative and non-conservative scattering ! - Pre-delta-scaling clear and cloudy direct beam transmittance @@ -3513,7 +3455,7 @@ subroutine spcvrtm & zasy3 = 0.75 * zasy1 !> - Perform general two-stream expressions: -!!\n control parameters in module "physparam" +!!\n control parameters provided by host-model !!\n iswmode - control flag for 2-stream transfer schemes !!\n = 1 delta-eddington (joseph et al., 1976) !!\n = 2 pifm (zdunkowski et al., 1980) @@ -3706,7 +3648,7 @@ subroutine spcvrtm & !! transmittance. ! - Set up toa direct beam and surface values (beam and diff) ! - Delta scaling for total-sky condition -! - General two-stream expressions for physparam::iswmode +! - General two-stream expressions ! - Compute homogeneous reflectance and transmittance for ! conservative scattering and non-conservative scattering ! - Pre-delta-scaling clear and cloudy direct beam transmittance diff --git a/physics/radsw_main.meta b/physics/radsw_main.meta index 506e2edf0..222f3ce9e 100644 --- a/physics/radsw_main.meta +++ b/physics/radsw_main.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = rrtmg_sw type = scheme - dependencies = machine.F,mersenne_twister.f,physcons.F90,physparam.f,radsw_datatb.f,radsw_param.f + dependencies = machine.F,mersenne_twister.f,physcons.F90,radsw_datatb.f,radsw_param.f ######################################################################## [ccpp-arg-table] @@ -280,6 +280,55 @@ dimensions = () type = logical intent = in +[inc_minor_gas] + standard_name = flag_to_include_minor_gases_in_rrtmg + long_name = flag to include minor trace gases in rrtmg + units = flag + dimensions = () + type = logical + intent = in +[top_at_1] + standard_name = flag_for_vertical_ordering_in_RRTMGP + long_name = flag for vertical ordering in RRTMGP + units = flag + dimensions = () + type = logical + intent = in +[iswcice] + standard_name = flag_for_rrtmg_sw_ice_cloud_optics + long_name = flag for rrtmg shortwave ice cloud optics + units = flag + dimensions = () + type = integer + intent = in +[iswcliq] + standard_name = flag_for_rrtmg_sw_cloud_optics + long_name = flag for rrtmg shortwave cloud optics + units = flag + dimensions = () + type = integer + intent = in +[isubcsw] + standard_name = flag_for_sw_clouds_grid_approximation + long_name = flag for sw clouds sub-grid approximation + units = flag + dimensions = () + type = integer + intent = in +[iovr] + standard_name = flag_for_cloud_overlap_method_for_radiation + long_name = max-random overlap clouds + units = flag + dimensions = () + type = integer + intent = in +[iswmode] + standard_name = flag_for_sw_scattering_choice + long_name = flag for rrtmg shortwave scattering choice + units = flag + dimensions = () + type = integer + intent = in [cld_cf] standard_name = total_cloud_fraction long_name = total cloud fraction diff --git a/physics/radsw_param.f b/physics/radsw_param.f index 69c8c2446..2086f5df8 100644 --- a/physics/radsw_param.f +++ b/physics/radsw_param.f @@ -66,7 +66,7 @@ module module_radsw_parameters ! !! \htmlinclude module_radsw_parameters.html !! - use physparam, only : kind_phys + use machine, only : kind_phys implicit none ! From ab90e244ec689589d16bc0cd3e33547466af3124 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 18 Aug 2022 22:03:27 +0000 Subject: [PATCH 022/380] lsm_ruc bugfix: flag_for_using_flake => flag_for_using_lake_model --- physics/lsm_ruc.meta | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/lsm_ruc.meta b/physics/lsm_ruc.meta index 9e56e2941..067e13424 100644 --- a/physics/lsm_ruc.meta +++ b/physics/lsm_ruc.meta @@ -780,8 +780,8 @@ type = logical intent = in [use_lake] - standard_name = flag_for_using_flake - long_name = flag indicating lake points using flake model + standard_name = flag_for_using_lake_model + long_name = flag indicating lake points using a lake model units = flag dimensions = (horizontal_loop_extent) type = integer From 98cf6d2e6b68e4717f6e56889c6e7b0fd41ad7dd Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Thu, 18 Aug 2022 16:29:01 -0600 Subject: [PATCH 023/380] Adios physparam.f --- physics/GFS_cloud_diagnostics.F90 | 21 +- physics/GFS_cloud_diagnostics.meta | 22 ++ physics/GFS_rad_time_vary.fv3.F90 | 8 +- physics/GFS_rad_time_vary.fv3.meta | 16 +- physics/GFS_rad_time_vary.scm.F90 | 8 +- physics/GFS_rad_time_vary.scm.meta | 16 +- physics/GFS_rrtmg_pre.F90 | 38 +-- physics/GFS_rrtmg_pre.meta | 59 ++++ physics/GFS_rrtmg_setup.F90 | 341 +++------------------- physics/GFS_rrtmg_setup.meta | 15 +- physics/GFS_rrtmgp_cloud_overlap.F90 | 1 - physics/GFS_rrtmgp_setup.F90 | 20 +- physics/GFS_rrtmgp_setup.meta | 2 +- physics/physparam.f | 214 -------------- physics/radiation_clouds.f | 415 +++++++++++---------------- physics/radiation_gases.f | 2 +- physics/radlw_main.meta | 2 +- 17 files changed, 368 insertions(+), 832 deletions(-) delete mode 100644 physics/physparam.f diff --git a/physics/GFS_cloud_diagnostics.F90 b/physics/GFS_cloud_diagnostics.F90 index 01ecd7452..49cb992de 100644 --- a/physics/GFS_cloud_diagnostics.F90 +++ b/physics/GFS_cloud_diagnostics.F90 @@ -18,10 +18,6 @@ module GFS_cloud_diagnostics ! Version tag and last revision date character(40), parameter :: VTAGCLD='UFS-cloud-diagnostics vX.x May 2020 ' - - ! Module variables - integer :: & - llyr = 2 ! Upper limit of boundary layer clouds public GFS_cloud_diagnostics_run @@ -35,10 +31,10 @@ module GFS_cloud_diagnostics !> \section arg_table_GFS_cloud_diagnostics_run !! \htmlinclude GFS_cloud_diagnostics_run.html !! - subroutine GFS_cloud_diagnostics_run(nCol, nLev, iovr_rand, iovr_maxrand, iovr_max, & - iovr_dcorr, iovr_exp, iovr_exprand, lsswr, lslwr, lat, de_lgth, p_lay, & + subroutine GFS_cloud_diagnostics_run(nCol, nLev, iovr, iovr_rand, iovr_maxrand, & + iovr_max, iovr_dcorr, iovr_exp, iovr_exprand, lsswr, lslwr, lat, de_lgth, p_lay, & cld_frac, p_lev, deltaZ, cloud_overlap_param, precip_overlap_param, con_pi, & - mtopa, mbota, cldsa, errmsg, errflg) + top_at_1, si, mtopa, mbota, cldsa, errmsg, errflg) implicit none ! Inputs @@ -46,6 +42,7 @@ subroutine GFS_cloud_diagnostics_run(nCol, nLev, iovr_rand, iovr_maxrand, iovr_m nCol, & ! Number of horizontal grid-points nLev ! Number of vertical-layers integer, intent(in) :: & + iovr, & ! iovr_rand, & ! Flag for random cloud overlap method iovr_maxrand, & ! Flag for maximum-random cloud overlap method iovr_max, & ! Flag for maximum cloud overlap method @@ -54,12 +51,14 @@ subroutine GFS_cloud_diagnostics_run(nCol, nLev, iovr_rand, iovr_maxrand, iovr_m iovr_exprand ! Flag for exponential-random cloud overlap method logical, intent(in) :: & lsswr, & ! Call SW radiation? - lslwr ! Call LW radiation + lslwr, & ! Call LW radiation + top_at_1 real(kind_phys), intent(in) :: & con_pi ! Physical constant: pi real(kind_phys), dimension(:), intent(in) :: & lat, & ! Latitude - de_lgth ! Decorrelation length + de_lgth, & ! Decorrelation length + si real(kind_phys), dimension(:,:), intent(in) :: & p_lay, & ! Pressure at model-layer cld_frac ! Total cloud fraction @@ -110,8 +109,8 @@ subroutine GFS_cloud_diagnostics_run(nCol, nLev, iovr_rand, iovr_maxrand, iovr_m ! defined by ptopc. The cloud overlapping method is defined by control flag 'iovr', which may ! be different for lw and sw radiation programs. call gethml(p_lay*0.01, ptop1, cld_frac, cldcnv, deltaZ, de_lgth, cloud_overlap_param,& - nCol, nLev, iovr_rand, iovr_maxrand, iovr_max, iovr_dcorr, iovr_exp, & - iovr_exprand, cldsa, mtopa, mbota) + nCol, nLev, iovr, iovr_rand, iovr_maxrand, iovr_max, iovr_dcorr, iovr_exp, & + iovr_exprand, top_at_1, si, cldsa, mtopa, mbota) end subroutine GFS_cloud_diagnostics_run !> @} diff --git a/physics/GFS_cloud_diagnostics.meta b/physics/GFS_cloud_diagnostics.meta index ded38a1e7..2408397d6 100644 --- a/physics/GFS_cloud_diagnostics.meta +++ b/physics/GFS_cloud_diagnostics.meta @@ -21,6 +21,13 @@ dimensions = () type = integer intent = in +[iovr] + standard_name = flag_for_cloud_overlap_method_for_radiation + long_name = max-random overlap clouds + units = flag + dimensions = () + type = integer + intent = in [iovr_rand] standard_name = flag_for_random_cloud_overlap_method long_name = choice of random cloud overlap method @@ -149,6 +156,21 @@ type = real kind = kind_phys intent = in +[top_at_1] + standard_name = flag_for_vertical_ordering_in_RRTMGP + long_name = flag for vertical ordering in RRTMGP + units = flag + dimensions = () + type = logical + intent = in +[si] + standard_name = sigma_pressure_hybrid_vertical_coordinate + long_name = vertical sigma coordinate for radiation initialization + units = none + dimensions = (vertical_interface_dimension) + type = real + kind = kind_phys + intent = in [mtopa] standard_name = model_layer_number_at_cloud_top long_name = vertical indices for low, middle and high cloud tops diff --git a/physics/GFS_rad_time_vary.fv3.F90 b/physics/GFS_rad_time_vary.fv3.F90 index 61685e74f..c2f3540a6 100644 --- a/physics/GFS_rad_time_vary.fv3.F90 +++ b/physics/GFS_rad_time_vary.fv3.F90 @@ -18,10 +18,10 @@ module GFS_rad_time_vary !! subroutine GFS_rad_time_vary_timestep_init ( & lslwr, lsswr, isubc_lw, isubc_sw, icsdsw, icsdlw, cnx, cny, isc, jsc, & - imap, jmap, sec, kdt, imp_physics, imp_physics_zhao_carr, ps_2delt, & - ps_1delt, t_2delt, t_1delt, qv_2delt, qv_1delt, t, qv, ps, errmsg, errflg) + imap, jmap, sec, kdt, imp_physics, imp_physics_zhao_carr, ipsd0, ipsdlim,& + ps_2delt, ps_1delt, t_2delt, t_1delt, qv_2delt, qv_1delt, t, qv, ps, & + errmsg, errflg) - use physparam, only: ipsd0, ipsdlim use mersenne_twister, only: random_setseed, random_index, random_stat use machine, only: kind_phys use radcons, only: qmin, con_100 @@ -30,7 +30,7 @@ subroutine GFS_rad_time_vary_timestep_init ( ! Interface variables integer, intent(in) :: isubc_lw, isubc_sw, cnx, cny, isc, jsc, kdt - integer, intent(in) :: imp_physics, imp_physics_zhao_carr + integer, intent(in) :: imp_physics, imp_physics_zhao_carr, ipsd0, ipsdlim logical, intent(in) :: lslwr, lsswr integer, intent(inout) :: icsdsw(:), icsdlw(:) integer, intent(in) :: imap(:), jmap(:) diff --git a/physics/GFS_rad_time_vary.fv3.meta b/physics/GFS_rad_time_vary.fv3.meta index 0e7c7c024..561b2ade0 100644 --- a/physics/GFS_rad_time_vary.fv3.meta +++ b/physics/GFS_rad_time_vary.fv3.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_rad_time_vary type = scheme - dependencies = machine.F,mersenne_twister.f,physparam.f,radcons.f90 + dependencies = machine.F,mersenne_twister.f,radcons.f90 ######################################################################## [ccpp-arg-table] @@ -120,6 +120,20 @@ dimensions = () type = integer intent = in +[ipsd0] + standard_name = initial_seed_for_mcica + long_name = initial permutaion seed for mcica radiation + units = none + dimensions = () + type = integer + intent = in +[ipsdlim] + standard_name = limit_for_initial_seed_for_mcica + long_name = limit for initial permutaion seed for mcica radiation + units = none + dimensions = () + type = integer + intent = in [ps_2delt] standard_name = surface_air_pressure_two_timesteps_back long_name = surface air pressure two timesteps back diff --git a/physics/GFS_rad_time_vary.scm.F90 b/physics/GFS_rad_time_vary.scm.F90 index db1e7e290..c8e782ebb 100644 --- a/physics/GFS_rad_time_vary.scm.F90 +++ b/physics/GFS_rad_time_vary.scm.F90 @@ -17,10 +17,10 @@ module GFS_rad_time_vary !! subroutine GFS_rad_time_vary_timestep_init ( & lslwr, lsswr, isubc_lw, isubc_sw, icsdsw, icsdlw, cnx, cny, isc, jsc, & - imap, jmap, sec, kdt, imp_physics, imp_physics_zhao_carr, ps_2delt, & - ps_1delt, t_2delt, t_1delt, qv_2delt, qv_1delt, t, qv, ps, errmsg, errflg) + imap, jmap, sec, kdt, imp_physics, imp_physics_zhao_carr, ipsd0, ipsdlim,& + ps_2delt, ps_1delt, t_2delt, t_1delt, qv_2delt, qv_1delt, t, qv, ps, & + errmsg, errflg) - use physparam, only: ipsd0, ipsdlim use mersenne_twister, only: random_setseed, random_index, random_stat use machine, only: kind_phys use radcons, only: qmin, con_100 @@ -29,7 +29,7 @@ subroutine GFS_rad_time_vary_timestep_init ( ! Interface variables integer, intent(in) :: isubc_lw, isubc_sw, cnx, cny, isc, jsc, kdt - integer, intent(in) :: imp_physics, imp_physics_zhao_carr + integer, intent(in) :: imp_physics, imp_physics_zhao_carr, ipsd0, ipsdlim logical, intent(in) :: lslwr, lsswr integer, intent(inout) :: icsdsw(:), icsdlw(:) integer, intent(in) :: imap(:), jmap(:) diff --git a/physics/GFS_rad_time_vary.scm.meta b/physics/GFS_rad_time_vary.scm.meta index 0e7c7c024..561b2ade0 100644 --- a/physics/GFS_rad_time_vary.scm.meta +++ b/physics/GFS_rad_time_vary.scm.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_rad_time_vary type = scheme - dependencies = machine.F,mersenne_twister.f,physparam.f,radcons.f90 + dependencies = machine.F,mersenne_twister.f,radcons.f90 ######################################################################## [ccpp-arg-table] @@ -120,6 +120,20 @@ dimensions = () type = integer intent = in +[ipsd0] + standard_name = initial_seed_for_mcica + long_name = initial permutaion seed for mcica radiation + units = none + dimensions = () + type = integer + intent = in +[ipsdlim] + standard_name = limit_for_initial_seed_for_mcica + long_name = limit for initial permutaion seed for mcica radiation + units = none + dimensions = () + type = integer + intent = in [ps_2delt] standard_name = surface_air_pressure_two_timesteps_back long_name = surface air pressure two timesteps back diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 57e0b4347..9de3cb16c 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -27,15 +27,15 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & imp_physics,imp_physics_nssl, nssl_ccn_on, nssl_invertccn, & imp_physics_thompson, imp_physics_gfdl, imp_physics_zhao_carr, & imp_physics_zhao_carr_pdf, imp_physics_mg, imp_physics_wsm6, & - imp_physics_fer_hires, iovr_rand, iovr_maxrand, iovr_max, iovr_dcorr, & - iovr_exp, iovr_exprand, idcor_con, idcor_hogan, idcor_oreopoulos, & - julian, yearlen, lndp_var_list, lsswr, lslwr, & - ltaerosol, lgfdlmprad, uni_cld, effr_in, do_mynnedmf, lmfshal, & - lmfdeep2, fhswr, fhlwr, solhr, sup, con_eps, epsm1, fvirt, & - rog, rocp, con_rd, xlat_d, xlat, xlon, coslat, sinlat, tsfc, slmsk, & - prsi, prsl, prslk, tgrs, sfc_wts, mg_cld, effrr_in, pert_clds, & + imp_physics_fer_hires, iovr, iovr_rand, iovr_maxrand, iovr_max, & + iovr_dcorr, iovr_exp, iovr_exprand, idcor, idcor_con, idcor_hogan, & + idcor_oreopoulos, dcorr_con, julian, yearlen, lndp_var_list, lsswr, & + lslwr, ltaerosol, lgfdlmprad, uni_cld, effr_in, do_mynnedmf, lmfshal, & + lcnorm, lmfdeep2, lcrick, fhswr, fhlwr, solhr, sup, con_eps, epsm1, & + fvirt, rog, rocp, con_rd, xlat_d, xlat, xlon, coslat, sinlat, tsfc, & + slmsk, prsi, prsl, prslk, tgrs, sfc_wts, mg_cld, effrr_in, pert_clds, & sppt_wts, sppt_amp, cnvw_in, cnvc_in, qgrs, aer_nm, dx, icloud, & - iaermdl, iaerflg, con_pi, con_g, & !inputs from here and above + iaermdl, iaerflg, con_pi, con_g, con_ttp, con_thgni, si, & !inputs from here and above coszen, coszdg, effrl_inout, effri_inout, effrs_inout, & clouds1, clouds2, clouds3, clouds4, clouds5, qci_conv, & !in/out from here and above kd, kt, kb, mtopa, mbota, raddt, tsfg, tsfa, de_lgth, alb1d, delp, dz, & !output from here and below @@ -102,6 +102,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & yearlen, icloud, iaermdl, iaerflg integer, intent(in) :: & + iovr, & ! choice of cloud-overlap method iovr_rand, & ! Flag for random cloud overlap method iovr_maxrand, & ! Flag for maximum-random cloud overlap method iovr_max, & ! Flag for maximum cloud overlap method @@ -109,6 +110,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & iovr_exp, & ! Flag for exponential cloud overlap method iovr_exprand, & ! Flag for exponential-random cloud overlap method idcor_con, & + idcor, & idcor_hogan, & idcor_oreopoulos, & rrfs_smoke_band, & ! Band number for rrfs-smoke dust and smoke @@ -121,7 +123,8 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & logical, intent(in) :: lsswr, lslwr, ltaerosol, lgfdlmprad, & uni_cld, effr_in, do_mynnedmf, & - lmfshal, lmfdeep2, pert_clds + lmfshal, lmfdeep2, pert_clds, lcrick,& + lcnorm logical, intent(in) :: aero_dir_fdb real(kind=kind_phys), dimension(:,:), intent(in) :: smoke_ext, dust_ext @@ -129,12 +132,12 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & integer, intent(in) :: spp_rad real(kind_phys), intent(in) :: spp_wts_rad(:,:) - real(kind=kind_phys), intent(in) :: fhswr, fhlwr, solhr, sup, julian, sppt_amp - real(kind=kind_phys), intent(in) :: con_eps, epsm1, fvirt, rog, rocp, con_rd, con_pi, con_g + real(kind=kind_phys), intent(in) :: fhswr, fhlwr, solhr, sup, julian, sppt_amp, dcorr_con + real(kind=kind_phys), intent(in) :: con_eps, epsm1, fvirt, rog, rocp, con_rd, con_pi, con_g, con_ttp, con_thgni real(kind=kind_phys), dimension(:), intent(in) :: xlat_d, xlat, xlon, & coslat, sinlat, tsfc, & - slmsk, dx + slmsk, dx, si real(kind=kind_phys), dimension(:,:), intent(in) :: prsi, prsl, prslk, & tgrs, sfc_wts, & @@ -951,20 +954,21 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & & ( plyr, plvl, tlyr, tvly, qlyr, qstl, rhly, & ! --- inputs: & ccnd, ncndl, cnvw, cnvc, tracer1, & & xlat, xlon, slmsk, dz, delp, IM, LM, LMK, LMP, & - & deltaq, sup, me, icloud, kdt, & + & deltaq, sup, dcorr_con, me, icloud, kdt, & & ntrac, ntcw, ntiw, ntrw, ntsw, ntgl, ntclamt, & & imp_physics, imp_physics_nssl, imp_physics_fer_hires, & & imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, & & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & - & imp_physics_mg, iovr_rand, iovr_maxrand, iovr_max, & - & iovr_dcorr, iovr_exp, iovr_exprand, idcor_con, & - & idcor_hogan, idcor_oreopoulos, & + & imp_physics_mg, iovr, iovr_rand, iovr_maxrand, iovr_max, & + & iovr_dcorr, iovr_exp, iovr_exprand, idcor, idcor_con, & + & idcor_hogan, idcor_oreopoulos, lcrick, lcnorm, & & imfdeepcnv, imfdeepcnv_gf, do_mynnedmf, lgfdlmprad, & & uni_cld, lmfshal, lmfdeep2, cldcov, clouds1, & & effrl, effri, effrr, effrs, effr_in, & & effrl_inout, effri_inout, effrs_inout, & & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & - & dzb, xlat_d, julian, yearlen, gridkm, & + & dzb, xlat_d, julian, yearlen, gridkm, top_at_1, si, & + & con_ttp, con_pi, con_g, con_rd, con_thgni, & & cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, & ! --- outputs: & cld_rwp, cld_rerain, cld_swp, cld_resnow, & ! --- outputs: & cldsa, mtopa, mbota, de_lgth, alpha & ! --- outputs: diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 8fa020ec5..cb158346a 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -450,6 +450,13 @@ dimensions = () type = integer intent = in +[iovr] + standard_name = flag_for_cloud_overlap_method_for_radiation + long_name = max-random overlap clouds + units = flag + dimensions = () + type = integer + intent = in [iovr_rand] standard_name = flag_for_random_cloud_overlap_method long_name = choice of random cloud overlap method @@ -492,6 +499,20 @@ dimensions = () type = integer intent = in +[dcorr_con] + standard_name = decorrelation_length_used_by_overlap_method + long_name = decorrelation length (default) used by cloud overlap method (iovr) + units = km + dimensions = () + type = real + intent = in +[idcor] + standard_name = flag_for_decorrelation_length_method + long_name = flag for decorrelation length method used in cloud overlap method (iovr) + units = flag + dimensions = () + type = integer + intent = in [idcor_con] standard_name = flag_for_constant_decorrelation_length_method long_name = choice of decorrelation length computation (costant) @@ -599,6 +620,20 @@ dimensions = () type = logical intent = in +[lcrick] + standard_name = flag_for_CRICK_proof_cloud_water + long_name = flag for CRICK-Proof cloud water + units = flag + dimensions = () + type = logical + intent = in +[lcnorm] + standard_name = flag_for_in_cloud_condensate + long_name = flag for cloud condensate normalized by cloud cover + units = flag + dimensions = () + type = logical + intent = in [fhswr] standard_name = period_of_shortwave_radiation_calls long_name = frequency for shortwave radiation @@ -663,6 +698,22 @@ type = real kind = kind_phys intent = in +[con_ttp] + standard_name = triple_point_temperature_of_water + long_name = triple point temperature of water + units = K + dimensions = () + type = real + kind = kind_phys + intent = in +[con_thgni] + standard_name = temperature_ice_nucleation_starts + long_name = temperature the H.G.Nuc. ice starts + units = K + dimensions = () + type = real + kind = kind_phys + intent = in [epsm1] standard_name = ratio_of_dry_air_to_water_vapor_gas_constants_minus_one long_name = (rd/rv) - 1 @@ -1343,6 +1394,14 @@ dimensions = () type = logical intent = out +[si] + standard_name = sigma_pressure_hybrid_vertical_coordinate + long_name = vertical sigma coordinate for radiation initialization + units = none + dimensions = (vertical_interface_dimension) + type = real + kind = kind_phys + intent = in [ico2] standard_name = control_for_co2 long_name = prescribed global mean value (old opernl) diff --git a/physics/GFS_rrtmg_setup.F90 b/physics/GFS_rrtmg_setup.F90 index 6891b0f24..543776e80 100644 --- a/physics/GFS_rrtmg_setup.F90 +++ b/physics/GFS_rrtmg_setup.F90 @@ -6,9 +6,6 @@ !> @{ module GFS_rrtmg_setup - use physparam, only : lcrick , lcnorm , lnoprec, & - & ivflip , ipsd0, & - & iswcliq,iovrRad=>iovr use machine, only: kind_phys use radcons, only: ltp, lextop @@ -26,7 +23,7 @@ module GFS_rrtmg_setup ! & VTAGRAD='NCEP-Radiation_driver v5.1 Nov 2012 ' ! & VTAGRAD='NCEP-Radiation_driver v5.0 Aug 2012 ' - !> new data input control variables (set/reset in subroutines radinit/radupdate): + !> new data input control variables (set/reset in subroutine radupdate): integer :: month0 = 0 integer :: iyear0 = 0 integer :: monthd = 0 @@ -41,17 +38,13 @@ module GFS_rrtmg_setup !> \section arg_table_GFS_rrtmg_setup_init Argument Table !! \htmlinclude GFS_rrtmg_setup_init.html !! - subroutine GFS_rrtmg_setup_init ( & - si, levr, ictm, isol, solar_file, ico2, iaer, ntcw, & - num_p3d, npdf3d, ntoz, iovr, & - icliq_sw, crick_proof, ccnorm, & - imp_physics, & - norad_precip, idate, iflip, & - do_RRTMGP, me, lalw1bd, iaermdl, iaerflg, & - aeros_file, con_pi, con_t0c, con_c, con_boltz, & - con_plnk, con_solr_2008, con_solr_2002, co2usr_file,& - co2cyc_file, rad_hr_units, inc_minor_gas, ilwcliq, & - iswcliq, isubcsw, isubclw, iswmode, errmsg, errflg) + subroutine GFS_rrtmg_setup_init ( si, levr, ictm, isol, solar_file, ico2, & + iaer, ntcw, num_p3d, npdf3d, ntoz, iovr, icliq_sw, lcrick, lcnorm, & + imp_physics, lnoprec, idate, iflip, do_RRTMGP, me, lalw1bd, iaermdl, & + iaerflg, aeros_file, con_pi, con_t0c, con_c, con_boltz, con_plnk, & + con_solr_2008, con_solr_2002, co2usr_file, co2cyc_file, rad_hr_units,& + inc_minor_gas, ilwcliq, iswcliq, isubcsw, isubclw, iswmode, ipsd0, & + errmsg, errflg) ! ================= subprogram documentation block ================ ! ! ! ! subprogram: GFS_rrtmg_setup_init - a subprogram to initialize radiation ! @@ -133,9 +126,9 @@ subroutine GFS_rrtmg_setup_init ( & ! =0: with out sub-column cloud approximation ! ! =1: mcica sub-col approx. prescribed random seed ! ! =2: mcica sub-col approx. provided random seed ! -! crick_proof : control flag for eliminating CRICK ! -! ccnorm : control flag for in-cloud condensate mixing ratio! -! norad_precip : control flag for not using precip in radiation ! +! lcrick : control flag for eliminating CRICK ! +! lcnorm : control flag for in-cloud condensate mixing ratio! +! lnoprec : control flag for not using precip in radiation ! ! idate(4) : ncep absolute date and time of initial condition ! ! (hour, month, day, year) ! ! iflip : control flag for direction of vertical index ! @@ -147,34 +140,27 @@ subroutine GFS_rrtmg_setup_init ( & ! ! ! =================================================================== ! ! + use module_radiation_astronomy, only : sol_init + use module_radiation_aerosols, only : aer_init + use module_radiation_gases, only : gas_init + use module_radiation_clouds, only : cld_init + use rrtmg_lw, only : rlwinit + use rrtmg_sw, only : rswinit implicit none ! interface variables real (kind=kind_phys), intent(in) :: si(:) - integer, intent(in) :: levr - integer, intent(in) :: ictm - integer, intent(in) :: isol - integer, intent(in) :: ico2 - integer, intent(in) :: iaer - integer, intent(in) :: ntcw - integer, intent(in) :: num_p3d - integer, intent(in) :: npdf3d - integer, intent(in) :: ntoz - integer, intent(in) :: iovr - integer, intent(in) :: icliq_sw - logical, intent(in) :: crick_proof - logical, intent(in) :: ccnorm - integer, intent(in) :: imp_physics - logical, intent(in) :: norad_precip + integer, intent(in) :: levr, ictm, isol, ico2, iaer, ntcw, num_p3d, & + npdf3d, ntoz, iovr, icliq_sw, imp_physics, iflip, me, & + rad_hr_units, ilwcliq, iswcliq, isubcsw, isubclw, iswmode integer, intent(in) :: idate(:) - integer, intent(in) :: iflip - logical, intent(in) :: do_RRTMGP, lalw1bd, inc_minor_gas - integer, intent(in) :: me, rad_hr_units, ilwcliq, iswcliq, isubcsw, & - isubclw, iswmode + logical, intent(in) :: lcrick, lcnorm, lnoprec, do_RRTMGP, lalw1bd, & + inc_minor_gas character(len=26),intent(in) :: aeros_file, solar_file, co2usr_file,& co2cyc_file real(kind_phys), intent(in) :: con_pi, con_t0c, con_c, con_boltz, & con_plnk, con_solr_2008, con_solr_2002 + integer, intent(inout) :: ipsd0 character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg integer, intent(out) :: iaermdl, iaerflg @@ -204,12 +190,6 @@ subroutine GFS_rrtmg_setup_init ( & return endif - iovrRAD = iovr - lcrick = crick_proof ! control flag for eliminating CRICK - lcnorm = ccnorm ! control flag for in-cld condensate - lnoprec = norad_precip ! precip effect on radiation flag (ferrier microphysics) - ivflip = iflip ! vertical index direction control flag - ! --- assign initial permutation seed for mcica cloud-radiation if ( isubcsw>0 .or. isubclw>0 ) then ! ipsd0 = 17*idate(1)+43*idate(2)+37*idate(3)+23*idate(4) + ipsd0 @@ -225,18 +205,19 @@ subroutine GFS_rrtmg_setup_init ( & & ' iovr=',iovr,' isubcsw=',isubcsw, & & ' isubclw=',isubclw,' icliq_sw=',icliq_sw, & & ' iflip=',iflip,' me=',me - print *,' crick_proof=',crick_proof, & - & ' ccnorm=',ccnorm,' norad_precip=',norad_precip + print *,' lcrick=',lcrick, & + & ' lcnorm=',lcnorm,' lnoprec=',lnoprec endif - call radinit & - & ( si, levr, imp_physics, me, iaermdl, iaerflg, lalw1bd, & - & aeros_file, con_pi, con_t0c, con_c, con_boltz, con_plnk, & - & isol, solar_file, con_solr_2008, con_solr_2002, & - & co2usr_file, co2cyc_file, ico2, ictm, ntoz, rad_hr_units, & - & inc_minor_gas, ilwcliq, iswcliq, isubcsw, isubclw, iovr, & - & iswmode, errmsg, errflg ) - + call sol_init ( me, isol, solar_file, con_solr_2008, con_solr_2002,& + con_pi ) ! astronomy initialization routine + call aer_init ( levr, me, iaermdl, iaerflg, lalw1bd, aeros_file, con_pi, & + con_t0c, con_c, con_boltz, con_plnk, errflg, errmsg) ! aerosols initialization routine + call gas_init ( me, co2usr_file, co2cyc_file, ico2, ictm, ntoz, con_pi, & + errflg, errmsg) ! co2 and other gases initialization routine + call cld_init ( si, levr, imp_physics, me, errflg, errmsg) ! cloud initialization routine + call rlwinit ( me, rad_hr_units, inc_minor_gas, ilwcliq, isubcsw, iovr, errflg, errmsg ) ! lw RRTMG initialization routine + call rswinit ( me, rad_hr_units, inc_minor_gas, iswcliq, isubclw, iovr, iswmode, errflg, errmsg ) ! sw RRTMG initialization routine if ( me == 0 ) then print *,' Radiation sub-cloud initial seed =',ipsd0, & @@ -314,235 +295,6 @@ subroutine GFS_rrtmg_setup_finalize (errmsg, errflg) end subroutine GFS_rrtmg_setup_finalize - -! Private functions - - - subroutine radinit( si, NLAY, imp_physics, me, iaermdl, iaerflg, lalw1bd, & - aeros_file, con_pi, con_t0c, con_c, con_boltz, con_plnk, isol, & - solar_file, con_solr_2008, con_solr_2002, co2usr_file, co2cyc_file, & - ico2, ictm, rad_hr_units, ntoz, inc_minor_gas, ilwcliq, iswcliq, & - isubcsw, isubclw, iovr, iswmode, errmsg, errflg) -!................................... - -! --- inputs: -! & ( si, NLAY, imp_physics, me, iaermdl, iaerflg) -! --- outputs: -! ( errmsg, errflg ) - -! ================= subprogram documentation block ================ ! -! ! -! subprogram: radinit initialization of radiation calculations ! -! ! -! usage: call radinit ! -! ! -! attributes: ! -! language: fortran 90 ! -! machine: wcoss ! -! ! -! ==================== definition of variables ==================== ! -! ! -! input parameters: ! -! si : model vertical sigma interface ! -! NLAY : number of model vertical layers ! -! imp_physics : MP identifier ! -! me : print control flag ! -! ! -! outputs: (none) ! -! ! -! external module variables: (in module physparam) ! -! isolar : solar constant cntrol flag ! -! = 0: use the old fixed solar constant in "physcon" ! -! =10: use the new fixed solar constant in "physcon" ! -! = 1: use noaa ann-mean tsi tbl abs-scale with cycle apprx! -! = 2: use noaa ann-mean tsi tbl tim-scale with cycle apprx! -! = 3: use cmip5 ann-mean tsi tbl tim-scale with cycl apprx! -! = 4: use cmip5 mon-mean tsi tbl tim-scale with cycl apprx! -! iaerflg : 3-digit aerosol flag (abc for volc, lw, sw) ! -! a:=0 use background stratospheric aerosol ! -! =1 include stratospheric vocanic aeros ! -! b:=0 no topospheric aerosol in lw radiation ! -! =1 compute tropspheric aero in 1 broad band for lw ! -! =2 compute tropspheric aero in multi bands for lw ! -! c:=0 no topospheric aerosol in sw radiation ! -! =1 include tropspheric aerosols for sw ! -! ico2 : co2 data source control flag ! -! =0: use prescribed global mean co2 (old oper) ! -! =1: use observed co2 annual mean value only ! -! =2: use obs co2 monthly data with 2-d variation ! -! ictm : =yyyy#, external data ic time/date control flag ! -! = -2: same as 0, but superimpose seasonal cycle ! -! from climatology data set. ! -! = -1: use user provided external data for the ! -! forecast time, no extrapolation. ! -! = 0: use data at initial cond time, if not ! -! available, use latest, no extrapolation. ! -! = 1: use data at the forecast time, if not ! -! available, use latest and extrapolation. ! -! =yyyy0: use yyyy data for the forecast time, ! -! no further data extrapolation. ! -! =yyyy1: use yyyy data for the fcst. if needed, do ! -! extrapolation to match the fcst time. ! -! ioznflg : ozone data source control flag ! -! =0: use climatological ozone profile ! -! =1: use interactive ozone profile ! -! imp_physics : cloud microphysics scheme control flag ! -! =99 zhao/carr/sundqvist microphysics scheme ! -! =98 zhao/carr/sundqvist microphysics+pdf cloud&cnvc,cnvw ! -! =11 GFDL cloud microphysics ! -! =8 Thompson microphysics scheme ! -! =6 WSM6 microphysics scheme ! -! =10 MG microphysics scheme ! -! iovr : control flag for cloud overlap in radiation ! -! =0: random overlapping clouds ! -! =1: max/ran overlapping clouds ! -! isubcsw : sub-column cloud approx control flag in sw radiation ! -! isubclw : sub-column cloud approx control flag in lw radiation ! -! =0: with out sub-column cloud approximation ! -! =1: mcica sub-col approx. prescribed random seed ! -! =2: mcica sub-col approx. provided random seed ! -! lcrick : control flag for eliminating CRICK ! -! =t: apply layer smoothing to eliminate CRICK ! -! =f: do not apply layer smoothing ! -! lcnorm : control flag for in-cld condensate ! -! =t: normalize cloud condensate ! -! =f: not normalize cloud condensate ! -! lnoprec : precip effect in radiation flag (ferrier microphysics) ! -! =t: snow/rain has no impact on radiation ! -! =f: snow/rain has impact on radiation ! -! ivflip : vertical index direction control flag ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! ! -! subroutines called: sol_init, aer_init, gas_init, cld_init, ! -! rlwinit, rswinit ! -! ! -! usage: call radinit ! -! ! -! =================================================================== ! -! - - use module_radiation_astronomy, only : sol_init - use module_radiation_aerosols, only : aer_init - use module_radiation_gases, only : gas_init - use module_radiation_clouds, only : cld_init - use rrtmg_lw, only : rlwinit - use rrtmg_sw, only : rswinit - - implicit none - -! --- inputs: - integer, intent(in) :: NLAY, me, imp_physics, iaermdl, iaerflg, & - isol, ico2, ictm, ntoz, rad_hr_units, ilwcliq, iswcliq, isubcsw,& - isubclw, iovr, iswmode - logical, intent(in) :: lalw1bd, inc_minor_gas - real (kind=kind_phys), intent(in) :: si(:), con_pi,con_t0c, con_c, & - con_boltz, con_plnk, con_solr_2008, con_solr_2002 - character(len=26), intent(in) :: aeros_file, solar_file,co2usr_file, co2cyc_file - -! --- outputs: (ccpp error handling) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg -! --- locals: - -! -!===> ... begin here -! -!> -# Set up control variables and external module variables in -!! module physparam - loz1st = (ntoz == 0) ! first-time clim ozone data read flag - month0 = 0 - iyear0 = 0 - monthd = 0 - - if (me == 0) then -! print *,' NEW RADIATION PROGRAM STRUCTURES -- SEP 01 2004' - print *,' NEW RADIATION PROGRAM STRUCTURES BECAME OPER. ', & - & ' May 01 2007' - print *, VTAGRAD !print out version tag - print *,' - Selected Control Flag settings: ICTMflg=',ictm, & - & ' ISOLar =',isol, ' ICO2flg=',ico2,' IAERflg=',iaerflg, & - & ' IMP_PHYSICS=',imp_physics,' IOZNflg=',ntoz - print *,' IVFLIP=',ivflip,' IOVR=',iovr, & - & ' ISUBCSW=',isubcsw,' ISUBCLW=',isubclw - print *,' LCRICK=',lcrick,' LCNORM=',lcnorm,' LNOPREC=',lnoprec - print *,' LTP =',ltp,', add extra top layer =',lextop - - if ( ictm==0 .or. ictm==-2 ) then - print *,' Data usage is limited by initial condition!' - print *,' No volcanic aerosols' - endif - - if ( isubclw == 0 ) then - print *,' - ISUBCLW=',isubclw,' No McICA, use grid ', & - & 'averaged cloud in LW radiation' - elseif ( isubclw == 1 ) then - print *,' - ISUBCLW=',isubclw,' Use McICA with fixed ', & - & 'permutation seeds for LW random number generator' - elseif ( isubclw == 2 ) then - print *,' - ISUBCLW=',isubclw,' Use McICA with random ', & - & 'permutation seeds for LW random number generator' - else - print *,' - ERROR!!! ISUBCLW=',isubclw,' is not a ', & - & 'valid option ' - errflg = 1 - errmsg = 'ERROR(GFS_rrtmg_setup): ISUBCLW flag is invalid' - return - endif - - if ( isubcsw == 0 ) then - print *,' - ISUBCSW=',isubcsw,' No McICA, use grid ', & - & 'averaged cloud in SW radiation' - elseif ( isubcsw == 1 ) then - print *,' - ISUBCSW=',isubcsw,' Use McICA with fixed ', & - & 'permutation seeds for SW random number generator' - elseif ( isubcsw == 2 ) then - print *,' - ISUBCSW=',isubcsw,' Use McICA with random ', & - & 'permutation seeds for SW random number generator' - else - print *,' - ERROR!!! ISUBCSW=',isubcsw,' is not a ', & - & 'valid option ' - errflg = 1 - errmsg = 'ERROR(GFS_rrtmg_setup): ISUBCSW flag is invalid' - return - endif - - if ( isubcsw /= isubclw ) then - print *,' - *** Notice *** ISUBCSW /= ISUBCLW !!!', & - & isubcsw, isubclw - endif - endif - -!> -# Initialization -!! - astronomy initialization routine: -!! call module_radiation_astronomy::sol_init() -!! - aerosols initialization routine: -!! call module_radiation_aerosols::aer_init() -!! - CO2 and other gases intialization routine: -!! call module_radiation_gases::gas_init() -!! - cloud initialization routine: -!! call module_radiation_clouds::cld_init() -!! - LW radiation initialization routine: -!! call module_radlw_main::rlwinit() -!! - SW radiation initialization routine: -!! call module_radsw_main::rswinit() -! Initialization - - call sol_init ( me, isol, solar_file, con_solr_2008, con_solr_2002,& - con_pi ) ! astronomy initialization routine - call aer_init ( NLAY, me, iaermdl, iaerflg, lalw1bd, aeros_file, con_pi, & - con_t0c, con_c, con_boltz, con_plnk, errflg, errmsg) ! aerosols initialization routine - call gas_init ( me, co2usr_file, co2cyc_file, ico2, ictm, ntoz, con_pi, & - errflg, errmsg) ! co2 and other gases initialization routine - call cld_init ( si, NLAY, imp_physics, me, errflg, errmsg) ! cloud initialization routine - call rlwinit ( me, rad_hr_units, inc_minor_gas, ilwcliq, isubcsw, iovr, errflg, errmsg ) ! lw RRTMG initialization routine - call rswinit ( me, rad_hr_units, inc_minor_gas, iswcliq, isubclw, iovr, iswmode, errflg, errmsg ) ! sw RRTMG initialization routine -! - return -! - end subroutine radinit - !----------------------------------- - !> This subroutine checks and updates time sensitive data used by !! radiation computations. This subroutine needs to be placed inside !! the time advancement loop but outside of the horizontal grid loop. @@ -597,31 +349,6 @@ subroutine radupdate( idate,jdate,deltsw,deltim,lsswr,me, iaermdl,& ! sdec, cdec : sin and cos of the solar declination angle ! ! solcon : sun-earth distance adjusted solar constant (w/m2) ! ! ! -! external module variables: ! -! iso : solar constant cntrl (in module physparam) ! -! = 0: use the old fixed solar constant in "physcon" ! -! =10: use the new fixed solar constant in "physcon" ! -! = 1: use noaa ann-mean tsi tbl abs-scale with cycle apprx! -! = 2: use noaa ann-mean tsi tbl tim-scale with cycle apprx! -! = 3: use cmip5 ann-mean tsi tbl tim-scale with cycl apprx! -! = 4: use cmip5 mon-mean tsi tbl tim-scale with cycl apprx! -! ictm : =yyyy#, external data ic time/date control flag ! -! = -2: same as 0, but superimpose seasonal cycle ! -! from climatology data set. ! -! = -1: use user provided external data for the ! -! forecast time, no extrapolation. ! -! = 0: use data at initial cond time, if not ! -! available, use latest, no extrapolation. ! -! = 1: use data at the forecast time, if not ! -! available, use latest and extrapolation. ! -! =yyyy0: use yyyy data for the forecast time, ! -! no further data extrapolation. ! -! =yyyy1: use yyyy data for the fcst. if needed, do ! -! extrapolation to match the fcst time. ! -! ! -! module variables: ! -! loz1st : first-time clim ozone data read flag ! -! ! ! subroutines called: sol_update, aer_update, gas_update ! ! ! ! =================================================================== ! diff --git a/physics/GFS_rrtmg_setup.meta b/physics/GFS_rrtmg_setup.meta index 2355b91c2..b6d3520bf 100644 --- a/physics/GFS_rrtmg_setup.meta +++ b/physics/GFS_rrtmg_setup.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_rrtmg_setup type = scheme - dependencies = iounitdef.f,module_bfmicrophysics.f,physparam.f,radcons.f90,radiation_aerosols.f,radiation_astronomy.f,radiation_clouds.f + dependencies = iounitdef.f,module_bfmicrophysics.f,radcons.f90,radiation_aerosols.f,radiation_astronomy.f,radiation_clouds.f dependencies = module_mp_thompson.F90,radiation_gases.f,radlw_main.F90,radlw_param.f,radsw_main.F90,radsw_param.f,machine.F ######################################################################## @@ -138,14 +138,14 @@ dimensions = () type = integer intent = in -[crick_proof] +[lcrick] standard_name = flag_for_CRICK_proof_cloud_water long_name = flag for CRICK-Proof cloud water units = flag dimensions = () type = logical intent = in -[ccnorm] +[lcnorm] standard_name = flag_for_in_cloud_condensate long_name = flag for cloud condensate normalized by cloud cover units = flag @@ -159,7 +159,7 @@ dimensions = () type = integer intent = in -[norad_precip] +[lnoprec] standard_name = flag_for_turning_off_precipitation_radiative_effect long_name = radiation precip flag for Ferrier/Moorthi units = flag @@ -293,6 +293,13 @@ dimensions = () type = logical intent = in +[ipsd0] + standard_name = initial_seed_for_mcica + long_name = initial permutaion seed for mcica radiation + units = none + dimensions = () + type = integer + intent = inout [iaermdl] standard_name = flag_for_aerosol_radiation_scheme long_name = flag for aerosol scheme to use in radiation diff --git a/physics/GFS_rrtmgp_cloud_overlap.F90 b/physics/GFS_rrtmgp_cloud_overlap.F90 index b294b4a99..28c925600 100644 --- a/physics/GFS_rrtmgp_cloud_overlap.F90 +++ b/physics/GFS_rrtmgp_cloud_overlap.F90 @@ -127,7 +127,6 @@ subroutine GFS_rrtmgp_cloud_overlap_run(nCol, nLev, yearlen, doSWrad, doLWrad, if (iovr_convcld == iovr_dcorr .or. iovr_convcld == iovr_exp .or. iovr_convcld == iovr_exprand) then call get_alpha_exper(nCol, nLev, iovr_convcld, iovr_exprand, deltaZc*0.001, de_lgth, cld_cnv_frac, cnv_cloud_overlap_param) else - de_lgth(:) = 0. cnv_cloud_overlap_param(:,:) = 0. endif endif diff --git a/physics/GFS_rrtmgp_setup.F90 b/physics/GFS_rrtmgp_setup.F90 index 935500739..842d8e983 100644 --- a/physics/GFS_rrtmgp_setup.F90 +++ b/physics/GFS_rrtmgp_setup.F90 @@ -6,10 +6,6 @@ module GFS_rrtmgp_setup use module_radiation_astronomy, only : sol_init, sol_update use module_radiation_aerosols, only : aer_init, aer_update use module_radiation_gases, only : gas_init, gas_update - ! use GFS_cloud_diagnostics, only : hml_cloud_diagnostics_initialize - ! *NOTE* These parameters below are required radiation_****** modules. They are not - ! directly used by the RRTMGP routines. - use physparam, only : ivflip implicit none public GFS_rrtmgp_setup_init, GFS_rrtmgp_setup_timestep_init, GFS_rrtmgp_setup_finalize @@ -87,8 +83,6 @@ subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires, end if ! Set radiation parameters - ivflip = iflip ! vertical index direction control flag - if ( ictm==0 .or. ictm==-2 ) then iaerflg = mod(iaer, 100) ! no volcanic aerosols for clim hindcast else @@ -125,23 +119,11 @@ subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires, iyear0 = 0 monthd = 0 -!> -# Initialization -!! - astronomy initialization routine: -!! call module_radiation_astronomy::sol_init() -!! - aerosols initialization routine: -!! call module_radiation_aerosols::aer_init() -!! - CO2 and other gases intialization routine: -!! call module_radiation_gases::gas_init() - ! Call initialization routines.. call sol_init ( me, isol, solar_file, con_solr_2008, con_solr_2002, con_pi ) call aer_init ( levr, me, iaermdl, iaerflg, lalw1bd, aeros_file, con_pi, con_t0c, & con_c, con_boltz, con_plnk, errflg, errmsg) - call gas_init ( me, co2usr_file, co2cyc_file, ictm, ntoz, ico2, con_pi, errflg, errmsg ) - !call hml_cloud_diagnostics_initialize(imp_physics, imp_physics_fer_hires, & - ! imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, & - ! imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, imp_physics_mg, levr, me, si,& - ! errflg) + call gas_init ( me, co2usr_file, co2cyc_file, ico2, ntoz, ictm, con_pi, errflg, errmsg ) if ( me == 0 ) then print *,' return from rad_initialize (GFS_rrtmgp_setup_init) - after calling radinit' diff --git a/physics/GFS_rrtmgp_setup.meta b/physics/GFS_rrtmgp_setup.meta index 4f8fe1db4..8a9fd4ef6 100644 --- a/physics/GFS_rrtmgp_setup.meta +++ b/physics/GFS_rrtmgp_setup.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_rrtmgp_setup type = scheme - dependencies = iounitdef.f,machine.F,module_bfmicrophysics.f,physparam.f,radiation_aerosols.f,radiation_astronomy.f + dependencies = iounitdef.f,machine.F,module_bfmicrophysics.f,radiation_aerosols.f,radiation_astronomy.f dependencies = module_mp_thompson.F90,radiation_clouds.f,radiation_gases.f ######################################################################## diff --git a/physics/physparam.f b/physics/physparam.f deleted file mode 100644 index 0dd53a304..000000000 --- a/physics/physparam.f +++ /dev/null @@ -1,214 +0,0 @@ -!> \file physparam.f -!! This file contains module physparam. - -! ========================================================== !!!!! -! module physparam description !!!!! -! ========================================================== !!!!! -! ! -! This module defines commonly used control variables/parameters ! -! in physics related programs. ! -! ! -! Section 1 contains control variables defined in the form of ! -! parameter. They are pre-determined choices and not adjustable ! -! during model's run-time. ! -! ! -! Section 2 contains control variables defined as module variables.! -! They are more flexible to be changed during run-time by either ! -! through input namelist, or through model environment condition. ! -! They are preassigned here as the default values. ! -! ! -!!!!! ========================================================== !!!!! - -!> \defgroup phy_sparam GFS Physics Parameter Module -!! Those variables are grouped together in accordance with functionaity -!! and are given brief descriptions and value specifications. There are -!! two types of attributes (parameters vs. save) designated for the -!! control variables. Those with a "parameter" attribute are prescribed -!! with a preferred option value, while the ones with a "save" attribute -!! are given a default value but could be changed at the model's -!! execution-time (usually through an input of name-list file or through -!! run scripts). - -!> This module defines commonly used control variables and parameters -!! in physics related programs. - module physparam -! -! implicit none - -! --- ... define kind parameters here - -! ** if already exist, use the module containing kind definitions - use machine - -! ** otherwise, define kind parameter here -! implicit none -! integer, public, parameter :: kind_io4 = 4 -! integer, public, parameter :: kind_io8 = 8 -! integer, public, parameter :: kind_phys= selected_real_kind(13,60) ! the '60' maps to 64-bit real -! ..... - -! implicit none -! - public - -!================================================================================== -! Section - 1 - -! control flags are pre-set as run-time non-adjuztable parameters. -!================================================================================== - -! ............................................. ! -!> \name 1.1 Control flags for SW radiation -! ............................................. ! - -!> SW heating rate unit control flag: =1:k/day; =2:k/second. - integer,parameter :: iswrate = 2 - -!> SW minor gases effect control flag (CH4 and O2): =0:no; =1:yes. -!!\n =0: minor gases' effects are not included in calculations -!!\n =1: minor gases' effects are included in calculations - integer,parameter :: iswrgas = 1 - -!> SW optical property for liquid clouds -!!\n =0:input cld opt depth, ignoring iswcice setting -!!\n =1:cloud optical property scheme based on Hu and Stamnes(1993) \cite hu_and_stamnes_1993 method -!!\n =2:cloud optical property scheme based on Hu and Stamnes(1993) -updated - integer,save :: iswcliq = 1 - -!> SW optical property for ice clouds (only iswcliq>0) -!!\n =1:optical property scheme based on Ebert and Curry (1992) -!! \cite ebert_and_curry_1992 method -!!\n =2:optical property scheme based on Streamer v3.0 -!! \cite key_2002 method -!!\n =3:optical property scheme based on Fu's method (1996) -!! \cite fu_1996 method - integer,save :: iswcice = 3 - -!> SW control flag for scattering process approximation -!!\n =1:two-stream delta-eddington (Joseph et al. 1976 -!! \cite joseph_et_al_1976) -!!\n =2:two-stream PIFM (Zdunkowski et al. 1980 -!! \cite zdunkowski_et_al_1980) -!!\n =3:discrete ordinates (Liou, 1973 -!! \cite liou_1973) - integer,parameter :: iswmode = 2 - -! ............................................. ! -!> \name 1.2 Control flags for LW radiation -! ............................................. ! - -!> LW heating rate unit: =1:k/day; =2:k/second. - integer,parameter :: ilwrate = 2 - -!> LW minor gases effect control flag (CH4,N2O,O2,and some CFCs): -!!\n =0: minor gases' effects are not included in calculations -!!\n =1: minor gases' effects are included in calculations - integer,parameter :: ilwrgas = 1 - -!> LW optical property scheme for liquid clouds -!!\n =0:input cloud optical properties directly, not computed within -!!\n =1:input cwp,rew, use Hu and Stamnes(1993) -!! \cite hu_and_stamnes_1993 method - integer,save :: ilwcliq = 1 - -!> LW optical property scheme for ice clouds (only ilwcliq>0) -!!\n =1:optical property scheme based on Ebert and Curry (1992) -!! \cite ebert_and_curry_1992 method -!!\n =2:optical property scheme based on Streamer v3 -!! \cite key_2002 method -!!\n =3:optical property scheme use Fu's method (1998) -!! \cite fu_et_al_1998 method - integer,save :: ilwcice = 3 - -!================================================================================== -! Section - 2 - -! values of control flags might be re-set in initialization subroutines -! (may be adjusted at run time based on namelist input or run condition) -!================================================================================== - -! ............................................. ! -!> \name 2.3 For module radiation_gases -! ............................................. ! - -!> co2 data source control flag -!!\n =0:prescribed value(380 ppmv) -!!\n =1:yearly global averaged annual mean from observations -!!\n =2:monthly 15 degree horizontal resolution from observations -!!\n Opr GFS/CFS=2; see ICO2 in run scripts - integer, save :: ico2flg = 0 - -!> controls external data at initial time and data usage during -!! forecast time -!!\n =-2:as in 0,but superimpose with seasonal climatology cycle -!!\n =-1:use user data,no extrapolation in overtime -!!\n =0:use IC time to select data,no extrapolation in overtime -!!\n =1:use forecast time to select data,extrapolate when necessary -!!\n =yyyy0:use yyyy year of data, no extrapolation -!!\n =yyyy1:use yyyy year of data, extrapolate when necessary -!!\n Opr GFS/CFS=1; see ICTM in run scripts - integer, save :: ictmflg = 0 - -!> ozone data source control flag -!!\n =0:use seasonal climatology ozone data -!!\n >0:use prognostic ozone scheme (also depend on other model control -!! variable at initial time) - integer, save :: ioznflg = 1 - -! ............................................. ! -!>\name 2.4 For module radiation_clouds -! ............................................. ! - -!> cloud optical property scheme control flag -!!\n =0:use diagnostic cloud scheme for cloud cover and mean optical properties -!!\n =1:use prognostic cloud scheme for cloud cover and cloud properties - integer, save :: icldflg = 1 - -!> cloud overlapping control flag for Radiation -!!\n =0:use random cloud overlapping method -!!\n =1:use maximum-random cloud overlapping method -!!\n =2:use maximum cloud overlapping method -!!\n =3:use decorrelation length overlapping method -!!\n =4:use exponential overlapping method -!!\n =5:use exponential-random overlapping method -!!\n Opr GFS/CFS=1; see IOVR in run scripts - integer, save :: iovr = 1 -!!\n Decorrelation length type for iovr = 4 or 5 -!!\n =0:use constant decorrelation length defined by decorr_con (in module physcons) -!!\n =1:use day-of-year and latitude-varying decorrelation length - integer, save :: idcor = 1 - -!> sub-column cloud approx flag in SW radiation -!!\n =0:no McICA approximation in SW radiation -!!\n =1:use McICA with precribed permutation seeds (test mode) -!!\n =2:use McICA with randomly generated permutation seeds -!!\n Opr GFS/CFS=2; see ISUBC_SW in run scripts - integer, save :: isubcsw = 0 -!> sub-column cloud approx flag in LW radiation -!!\n =0:no McICA approximation in LW radiation -!!\n =1:use McICA with prescribed permutation seeds (test mode) -!!\n =2:use McICA with randomly generatedo -!!\n Opr GFS/CFS=2; see ISUBC_LW in run scripts - integer, save :: isubclw = 0 - -!> eliminating CRICK control flag - logical, save :: lcrick =.false. -!> in-cld condensate control flag - logical, save :: lcnorm =.false. -!> precip effect on radiation flag (Ferrier microphysics) - logical, save :: lnoprec =.false. -!> shallow convetion flag - logical, save :: lsashal =.false. - -! ............................................. ! -!> \name 2.6 general purpose -! ............................................. ! - -!> vertical profile indexing flag - integer, save :: ivflip = 1 - -!> initial permutaion seed for mcica radiation - integer, save :: ipsd0 = 0 - integer, save :: ipsdlim = 1e8 -! -!...................................! - end module physparam ! -!===================================! diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index ee7922c99..2266dca09 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -29,8 +29,8 @@ ! imp_physics, imp_physics_nssl, imp_physics_fer_hires, ! ! imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, ! ! imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, ! -! imp_physics_mg, iovr_rand, iovr_maxrand, iovr_max, ! -! iovr_dcorr, iovr_exp, iovr_exprand, idcor_con, ! +! imp_physics_mg, iovr, iovr_rand, iovr_maxrand, iovr_max, ! +! iovr_dcorr, iovr_exp, iovr_exprand, idcor, idcor_con, ! ! idcor_hogan, idcor_oreopoulos, ! ! imfdeepcnv, imfdeepcnv_gf, do_mynnedmf, lgfdlmprad, ! ! uni_cld, lmfshal, lmfdeep2, cldcov, clouds1, ! @@ -68,12 +68,8 @@ ! ** fu's scheme need to be normalized by snow density (g/m**3/1.0e6)! ! ! ! external modules referenced: ! -! ! -! 'module physparam' in 'physparam.f' ! -! 'module physcons' in 'physcons.f' ! ! 'module module_microphysics' in 'module_bfmicrophysics.f' ! ! ! -! ! ! program history log: ! ! nov 1992, y.h., k.a.c, a.k. - cloud parameterization ! ! 'cldjms' patterned after slingo and slingo's work (jgr, ! @@ -173,13 +169,6 @@ !> This module computes cloud related quantities for radiation computations. module module_radiation_clouds ! - use physparam, only : iovr, idcor, & - & lcrick, lcnorm, lnoprec, & - & ivflip - use physcons, only : con_fvirt, con_ttp, con_rocp, & - & con_t0c, con_pi, con_g, con_rd, & - & con_thgni, decorr_con - use module_microphysics, only : rsipath2 use module_iounitdef, only : NICLTUN use module_radiation_cloud_overlap, only: cmp_dcorr_lgth, & & get_alpha_exper @@ -195,9 +184,7 @@ module module_radiation_clouds ! & VTAGCLD='NCEP-Radiation_clouds v5.0 Aug 2012 ' ! --- set constant parameters - real (kind=kind_phys), parameter :: gfac=1.0e5/con_g & - &, gord=con_g/con_rd - + real (kind=kind_phys) :: gfac,gord integer, parameter, public :: NF_CLDS = 9 !< number of fields in cloud array integer, parameter, public :: NK_CLDS = 3 !< number of cloud vertical domains @@ -281,29 +268,12 @@ subroutine cld_init & ! NLAY : vertical layer number ! ! imp_physics : MP identifier ! ! me : print control flag ! +! imp_physics : cloud microphysics scheme control flag ! ! ! ! outputs: ! ! errflg : CCPP error flag ! ! errmsg : CCPP error message ! ! ! -! external module variables: (in physparam) ! -! imp_physics : cloud microphysics scheme control flag ! -! =99: zhao/carr/sundqvist microphysics cloud ! -! =98: zhao/carr/sundqvist microphysics cloud+pdfcld! -! =11: GFDL microphysics cloud ! -! =8: Thompson microphysics ! -! =6: WSM6 microphysics ! -! =10: MG microphysics ! -! iovr : control flag for cloud overlapping scheme ! -! =0: random overlapping clouds ! -! =1: max/ran overlapping clouds ! -! =2: maximum overlap clouds (mcica only) ! -! =3: decorrelation-length overlap (mcica only) ! -! =4: exponential cloud overlap (AER; mcica only) ! -! =5: exponential-random overlap (AER; mcica only) ! -! ivflip : control flag for direction of vertical index ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! ! usage: call cld_init ! ! ! ! subroutines called: rhtable ! @@ -321,9 +291,6 @@ subroutine cld_init & integer, intent(out) :: errflg character(len=*), intent(out) :: errmsg -! --- locals: - integer :: k, kl, ier - ! !===> ... begin here ! @@ -359,27 +326,6 @@ subroutine cld_init & return endif endif - -!> - Compute the top of BL cld (llyr), which is the topmost non -!! cld(low) layer for stratiform (at or above lowest 0.1 of the -!! atmosphere). - - if ( ivflip == 0 ) then ! data from toa to sfc - lab_do_k0 : do k = NLAY, 2, -1 - kl = k - if (si(k) < 0.9e0) exit lab_do_k0 - enddo lab_do_k0 - - llyr = kl - else ! data from sfc to top - lab_do_k1 : do k = 2, NLAY - kl = k - if (si(k) < 0.9e0) exit lab_do_k1 - enddo lab_do_k1 - - llyr = kl - 1 - endif ! end_if_ivflip - ! return !................................... @@ -393,20 +339,21 @@ subroutine radiation_clouds_prop & & ( plyr, plvl, tlyr, tvly, qlyr, qstl, rhly, & ! --- inputs: & ccnd, ncndl, cnvw, cnvc, tracer1, & & xlat, xlon, slmsk, dz, delp, IX, LM, NLAY, NLP1, & - & deltaq, sup, me, icloud, kdt, & + & deltaq, sup, dcorr_con, me, icloud, kdt, & & ntrac, ntcw, ntiw, ntrw, ntsw, ntgl, ntclamt, & & imp_physics, imp_physics_nssl, imp_physics_fer_hires, & & imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, & & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & - & imp_physics_mg, iovr_rand, iovr_maxrand, iovr_max, & - & iovr_dcorr, iovr_exp, iovr_exprand, idcor_con, & - & idcor_hogan, idcor_oreopoulos, & + & imp_physics_mg, iovr, iovr_rand, iovr_maxrand, iovr_max, & + & iovr_dcorr, iovr_exp, iovr_exprand, idcor, idcor_con, & + & idcor_hogan, idcor_oreopoulos, lcrick, lcnorm, & & imfdeepcnv, imfdeepcnv_gf, do_mynnedmf, lgfdlmprad, & & uni_cld, lmfshal, lmfdeep2, cldcov, clouds1, & & effrl, effri, effrr, effrs, effr_in, & & effrl_inout, effri_inout, effrs_inout, & & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & - & dzlay, latdeg, julian, yearlen, gridkm, & + & dzlay, latdeg, julian, yearlen, gridkm, top_at_1, si, & + & con_ttp, con_pi, con_g, con_rd, con_thgni, & & cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, & ! --- outputs: & cld_rwp, cld_rerain, cld_swp, cld_resnow, & & clds, mtop, mbot, de_lgth, alpha & @@ -489,15 +436,17 @@ subroutine radiation_clouds_prop & ! imp_physics_zhao_carr : Zhao-Carr microphysics scheme ! ! imp_physics_zhao_carr_pdf : Zhao-Carr microphysics scheme with PDF clouds ! imp_physics_mg : Morrison-Gettelman microphysics scheme ! -! iovr_rand : choice of cloud-overlap: random (=0) -! iovr_maxrand : choice of cloud-overlap: maximum random (=1) -! iovr_max : choice of cloud-overlap: maximum (=2) -! iovr_dcorr : choice of cloud-overlap: decorrelation length (=3) -! iovr_exp : choice of cloud-overlap: exponential (=4) -! iovr_exprand : choice of cloud-overlap: exponential random (=5) -! idcor_con : choice for decorrelation-length: Use constant value (=0) -! idcor_hogan : choice for decorrelation-length: (=1) -! idcor_oreopoulos: choice for decorrelation-length: (=2) +! iovr : choice of cloud-overlap ! +! iovr_rand : flag of cloud-overlap: random (=0) ! +! iovr_maxrand : flag of cloud-overlap: maximum random (=1) ! +! iovr_max : flag of cloud-overlap: maximum (=2) ! +! iovr_dcorr : flag of cloud-overlap: decorrelation length(=3) ! +! iovr_exp : flag of cloud-overlap: exponential (=4) ! +! iovr_exprand : flag of cloud-overlap: exponential random (=5) ! +! idcor : choice for decorrelation-length ! +! idcor_con : flag for decorrelation-length: Use constant value (=0) +! idcor_hogan : flag for decorrelation-length: (=1) ! +! idcor_oreopoulos: flag for decorrelation-length: (=2) ! ! imfdeepcnv : flag for mass-flux deep convection scheme ! ! imfdeepcnv_gf : flag for scale- & aerosol-aware Grell-Freitas scheme (GSD) ! do_mynnedmf : flag for MYNN-EDMF ! @@ -505,6 +454,7 @@ subroutine radiation_clouds_prop & ! uni_cld : logical - true for cloud fraction from shoc ! ! lmfshal : logical - true for mass flux shallow convection ! ! lmfdeep2 : logical - true for mass flux deep convection ! +! top_at_1 : logical - true if ordered from toa-2-sfc ! ! cldcov : layer cloud fraction (used when uni_cld=.true. ! ! clouds1 : layer total cloud fraction ! effrl, : effective radius for liquid water @@ -523,7 +473,15 @@ subroutine radiation_clouds_prop & ! latdeg(ix) : latitude (in degrees 90 -> -90) ! ! julian : day of the year (fractional julian day) ! ! yearlen : current length of the year (365/366 days) ! -! gridkm : grid length in km +! gridkm : grid length in km ! +! lmfshal : mass-flux shallow conv scheme flag ! +! lmfdeep2 : scale-aware mass-flux deep conv scheme flag ! +! lcrick : control flag for eliminating CRICK ! +! =t: apply layer smoothing to eliminate CRICK ! +! =f: do not apply layer smoothing ! +! lcnorm : control flag for in-cld condensate ! +! =t: normalize cloud condensate ! +! =f: not normalize cloud condensate ! ! ! ! output variables: ! ! cloud profiles: ! @@ -541,20 +499,7 @@ subroutine radiation_clouds_prop & ! mtop (IX,3) : vertical indices for low, mid, hi cloud tops ! ! mbot (IX,3) : vertical indices for low, mid, hi cloud bases ! ! de_lgth(ix) : clouds decorrelation length (km) ! -! alpha(ix,nlay) : alpha decorrelation parameter -! ! -! module variables: ! -! ivflip : control flag of vertical index direction ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! lmfshal : mass-flux shallow conv scheme flag ! -! lmfdeep2 : scale-aware mass-flux deep conv scheme flag ! -! lcrick : control flag for eliminating CRICK ! -! =t: apply layer smoothing to eliminate CRICK ! -! =f: do not apply layer smoothing ! -! lcnorm : control flag for in-cld condensate ! -! =t: normalize cloud condensate ! -! =f: not normalize cloud condensate ! +! alpha(ix,nlay) : alpha decorrelation parameter ! ! ! ! ==================== end of description ===================== ! implicit none @@ -576,19 +521,21 @@ subroutine radiation_clouds_prop & & imp_physics_mg ! Flag for MG scheme integer, intent(in) :: & + & iovr, ! & iovr_rand, ! Flag for random cloud overlap method & iovr_maxrand, ! Flag for maximum-random cloud overlap method & iovr_max, ! Flag for maximum cloud overlap method & iovr_dcorr, ! Flag for decorrelation-length cloud overlap method & iovr_exp, ! Flag for exponential cloud overlap method & iovr_exprand, ! Flag for exponential-random cloud overlap method + & idcor, & idcor_con, & idcor_hogan, & idcor_oreopoulos - logical, intent(in) :: uni_cld, lmfshal, lmfdeep2, effr_in - logical, intent(in) :: do_mynnedmf, lgfdlmprad + logical, intent(in) :: uni_cld, lmfshal, lmfdeep2, effr_in, & + & do_mynnedmf, lgfdlmprad, top_at_1, lcrick, lcnorm real (kind=kind_phys), dimension(:,:,:), intent(in) :: ccnd, & & tracer1 @@ -596,9 +543,10 @@ subroutine radiation_clouds_prop & & tlyr, tvly, qlyr, qstl, rhly, cnvw, cnvc, cldcov, & & delp, dz, effrl, effri, effrr, effrs, dzlay, clouds1 - real (kind=kind_phys), intent(in) :: sup + real (kind=kind_phys), intent(in) :: sup, dcorr_con, con_ttp, & + & con_pi, con_g, con_rd, con_thgni real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & - & slmsk + & slmsk, si real(kind=kind_phys), dimension(:), intent(in) :: latdeg, gridkm real(kind=kind_phys), intent(in) :: julian @@ -644,6 +592,10 @@ subroutine radiation_clouds_prop & print*, 'in radiation_clouds_prop=', imp_physics, uni_cld, & & ncndl, lgfdlmprad, do_mynnedmf, imfdeepcnv, kdt end if + + ! + gfac = 1.0e5/con_g + gord = con_g/con_rd do k = 1, NLAY do i = 1, IX @@ -676,7 +628,7 @@ subroutine radiation_clouds_prop & & IX, NLAY, NLP1, cldcov, & & effrl, effri, effrr, effrs, effr_in, & & dzlay, & - & cldtot, cldcnv, & ! inout + & cldtot, cldcnv, lcrick, lcnorm, con_ttp, & ! inout & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs & cld_reice,cld_rwp, cld_rerain,cld_swp, & & cld_resnow) @@ -687,7 +639,7 @@ subroutine radiation_clouds_prop & & lmfshal, lmfdeep2, & & cldcov, effrl, effri, effrr, effrs, effr_in, & & dzlay, & - & cldtot, cldcnv, & ! inout + & cldtot, cldcnv, lcrick, lcnorm, con_ttp, & ! inout & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs & cld_reice,cld_rwp, cld_rerain,cld_swp, & & cld_resnow) @@ -699,8 +651,8 @@ subroutine radiation_clouds_prop & & qstl, rhly, ccnd(1:IX,1:NLAY,1), cnvw, cnvc, & & xlat, xlon, slmsk, dz, delp, IX, NLAY, NLP1, & & deltaq, sup, kdt, me, dzlay, & - & cldtot, cldcnv, & ! inout - & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs + & cldtot, cldcnv, lcrick, lcnorm, con_thgni, & ! inout + & con_ttp, cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs & cld_reice,cld_rwp, cld_rerain,cld_swp, & & cld_resnow) @@ -711,7 +663,7 @@ subroutine radiation_clouds_prop & & qstl, rhly, ccnd(1:IX,1:NLAY,1), cnvw, cnvc, & & xlat, xlon, slmsk, cldcov, dz, delp, & & IX, NLAY, NLP1, dzlay, & - & cldtot, cldcnv, & ! inout + & cldtot, cldcnv, lcrick, lcnorm, con_ttp, & ! inout & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs & cld_reice,cld_rwp, cld_rerain,cld_swp, & & cld_resnow) @@ -721,7 +673,7 @@ subroutine radiation_clouds_prop & & xlon, slmsk, dz,delp, IX, NLAY, NLP1, cldcov, & & effrl, effri, effrr, effrs, effr_in, & & dzlay, & - & cldtot, cldcnv, & ! inout + & cldtot, cldcnv, lcrick, lcnorm, con_ttp, & ! inout & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs & cld_reice,cld_rwp, cld_rerain,cld_swp, & & cld_resnow) @@ -743,7 +695,7 @@ subroutine radiation_clouds_prop & & cldcov(:,1:NLAY),effrl_inout(:,:), & & effri_inout(:,:), effrs_inout(:,:), & & dzlay, & - & cldtot, cldcnv, & ! inout + & cldtot, cldcnv, lcnorm, & ! inout & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs & cld_reice,cld_rwp, cld_rerain,cld_swp, & & cld_resnow) @@ -766,7 +718,7 @@ subroutine radiation_clouds_prop & & cld_frac, & & effrl, effri, effrr, effrs, effr_in , & & dzlay, & - & cldtot, cldcnv, & ! inout + & cldtot, cldcnv, lcrick, lcnorm, con_ttp, & ! inout & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs & cld_reice,cld_rwp, cld_rerain,cld_swp, & & cld_resnow) @@ -781,7 +733,7 @@ subroutine radiation_clouds_prop & & effri_inout, effrs_inout, & & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & & dzlay, & - & cldtot, cldcnv, & ! inout + & cldtot, cldcnv, lcnorm, & ! inout & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs & cld_reice,cld_rwp, cld_rerain,cld_swp, & & cld_resnow) @@ -799,7 +751,7 @@ subroutine radiation_clouds_prop & & IX, LM, NLP1, uni_cld, lmfshal, lmfdeep2, & & cldcov(:,1:LM), effrl, effri, effrs, & & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & - & dzlay, gridkm, & + & dzlay, gridkm, top_at_1, & & cldtot, cldcnv, & ! inout & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs & cld_reice,cld_rwp, cld_rerain,cld_swp, & @@ -821,7 +773,7 @@ subroutine radiation_clouds_prop & & cld_frac, & & effrl, effri, effrr, effrs, effr_in , & & dzlay, & - & cldtot, cldcnv, & ! inout + & cldtot, cldcnv, lcrick, lcnorm, con_ttp, & ! inout & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs & cld_reice,cld_rwp, cld_rerain,cld_swp, & & cld_resnow) @@ -838,7 +790,7 @@ subroutine radiation_clouds_prop & & IX, LM, NLP1, uni_cld, lmfshal, lmfdeep2, & & cldcov(:,1:LM), effrl, effri, effrs, & & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & - & dzlay, gridkm, & + & dzlay, gridkm, top_at_1, & & cldtot, cldcnv, & ! inout & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs & cld_reice,cld_rwp, cld_rerain,cld_swp, & @@ -853,7 +805,7 @@ subroutine radiation_clouds_prop & & cldcov(:,1:NLAY), cnvw, effrl, effri, effrs, & & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & & dzlay, & - & cldtot, cldcnv, & ! inout + & cldtot, cldcnv, lcnorm, & ! inout & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs & cld_reice,cld_rwp, cld_rerain,cld_swp, & & cld_resnow) @@ -888,7 +840,7 @@ subroutine radiation_clouds_prop & call cmp_dcorr_lgth(ix, latdeg, julian, yearlen, de_lgth) endif if (idcor == idcor_con) then - de_lgth(:) = decorr_con + de_lgth(:) = dcorr_con endif ! Call subroutine get_alpha_exper to define alpha parameter for exponential cloud overlap options @@ -913,8 +865,8 @@ subroutine radiation_clouds_prop & call gethml & ! --- inputs: & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, alpha, & - & IX, NLAY, iovr_rand, iovr_maxrand, iovr_max, & - & iovr_dcorr, iovr_exp, iovr_exprand, & + & IX, NLAY, iovr, iovr_rand, iovr_maxrand, iovr_max, & + & iovr_dcorr, iovr_exp, iovr_exprand, top_at_1, si, & ! --- outputs: & clds, mtop, mbot & & ) @@ -931,7 +883,7 @@ subroutine progcld_zhao_carr & & xlat,xlon,slmsk,dz,delp, IX, NLAY, NLP1, & & uni_cld, lmfshal, lmfdeep2, cldcov, & & effrl,effri,effrr,effrs,effr_in, & - & dzlay, cldtot, cldcnv, & + & dzlay, cldtot, cldcnv, lcrick, lcnorm, con_ttp, & & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs & cld_reice,cld_rwp, cld_rerain,cld_swp, cld_resnow & & ) @@ -948,9 +900,7 @@ subroutine progcld_zhao_carr & ! top and base. the three vertical cloud domains are set up in the ! ! initial subroutine "cld_init". ! ! ! -! usage: call progcld_zhao_carr ! -! ! -! subprograms called: gethml ! +! usage: call progcld_zhao_carr ! ! ! ! attributes: ! ! language: fortran 90 ! @@ -986,6 +936,14 @@ subroutine progcld_zhao_carr & ! effrs : effective radius for snow water ! effr_in : logical, if .true. use input effective radii ! dzlay(ix,nlay) : thickness between model layer centers (km) ! +! lmfshal : mass-flux shallow conv scheme flag ! +! lmfdeep2 : scale-aware mass-flux deep conv scheme flag ! +! lcrick : control flag for eliminating CRICK ! +! =t: apply layer smoothing to eliminate CRICK ! +! =f: do not apply layer smoothing ! +! lcnorm : control flag for in-cld condensate ! +! =t: normalize cloud condensate ! +! =f: not normalize cloud condensate ! ! ! ! output variables: ! ! cloud profiles: ! @@ -999,19 +957,6 @@ subroutine progcld_zhao_carr & ! *** cld_swp (:,:) - layer snow flake water path not assigned ! ! cld_resnow(:,:) - mean eff radius for snow flake (micron) ! ! ! -! module variables: ! -! ivflip : control flag of vertical index direction ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! lmfshal : mass-flux shallow conv scheme flag ! -! lmfdeep2 : scale-aware mass-flux deep conv scheme flag ! -! lcrick : control flag for eliminating CRICK ! -! =t: apply layer smoothing to eliminate CRICK ! -! =f: do not apply layer smoothing ! -! lcnorm : control flag for in-cld condensate ! -! =t: normalize cloud condensate ! -! =f: not normalize cloud condensate ! -! ! ! ==================== end of description ===================== ! ! implicit none @@ -1019,7 +964,8 @@ subroutine progcld_zhao_carr & ! --- inputs integer, intent(in) :: IX, NLAY, NLP1 - logical, intent(in) :: uni_cld, lmfshal, lmfdeep2, effr_in + logical, intent(in) :: uni_cld, lmfshal, lmfdeep2, effr_in, & + & lcrick, lcnorm real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & & tlyr, tvly, qlyr, qstl, rhly, clw, cldcov, delp, dz, & @@ -1027,6 +973,7 @@ subroutine progcld_zhao_carr & real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & & slmsk + real (kind=kind_phys), intent(in) :: con_ttp ! --- inputs/outputs @@ -1235,7 +1182,7 @@ subroutine progcld_zhao_carr_pdf & & xlat,xlon,slmsk, dz, delp, & & ix, nlay, nlp1, & & deltaq,sup,kdt,me, & - & dzlay, cldtot, cldcnv, & + & dzlay, cldtot, cldcnv, lcrick, lcnorm, con_thgni, con_ttp, & & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs & cld_reice,cld_rwp, cld_rerain,cld_swp, cld_resnow & & ) @@ -1252,9 +1199,7 @@ subroutine progcld_zhao_carr_pdf & ! top and base. the three vertical cloud domains are set up in the ! ! initial subroutine "cld_init". ! ! ! -! usage: call progcld_zhao_carr_pdf ! -! ! -! subprograms called: gethml ! +! usage: call progcld_zhao_carr_pdf ! ! ! ! attributes: ! ! language: fortran 90 ! @@ -1285,6 +1230,12 @@ subroutine progcld_zhao_carr_pdf & ! deltaq(ix,nlay) : half total water distribution width ! ! sup : supersaturation ! ! dzlay(ix,nlay) : thickness between model layer centers (km) ! +! lcrick : control flag for eliminating crick ! +! =t: apply layer smoothing to eliminate crick ! +! =f: do not apply layer smoothing ! +! lcnorm : control flag for in-cld condensate ! +! =t: normalize cloud condensate ! +! =f: not normalize cloud condensate ! ! ! ! output variables: ! ! cloud profiles: ! @@ -1298,28 +1249,18 @@ subroutine progcld_zhao_carr_pdf & ! *** cld_swp (:,:) - layer snow flake water path not assigned ! ! cld_resnow(:,:) - mean eff radius for snow flake (micron) ! ! ! -! module variables: ! -! ivflip : control flag of vertical index direction ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! lcrick : control flag for eliminating crick ! -! =t: apply layer smoothing to eliminate crick ! -! =f: do not apply layer smoothing ! -! lcnorm : control flag for in-cld condensate ! -! =t: normalize cloud condensate ! -! =f: not normalize cloud condensate ! -! ! ! ==================== end of description ===================== ! ! implicit none ! --- inputs integer, intent(in) :: ix, nlay, nlp1,kdt - + logical, intent(in) :: lcrick, lcnorm real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & & tlyr, tvly, qlyr, qstl, rhly, clw, dz, delp, dzlay ! & tlyr, tvly, qlyr, qstl, rhly, clw, cnvw, cnvc ! real (kind=kind_phys), dimension(:,:), intent(in) :: deltaq + real (kind=kind_phys), intent(in) :: con_thgni, con_ttp real (kind=kind_phys), dimension(:,:) :: deltaq, cnvw, cnvc real (kind=kind_phys) qtmp,qsc,rhs real (kind=kind_phys), intent(in) :: sup @@ -1415,7 +1356,7 @@ subroutine progcld_zhao_carr_pdf & do k = 1, nlay do i = 1, ix tem1 = tlyr(i,k) - 273.16 - if(tem1 < con_thgni) then ! for pure ice, has to be consistent with gscond + if(tem1 < (con_thgni - 273.16)) then ! for pure ice, has to be consistent with gscond qsc = sup * qstl(i,k) rhs = sup else @@ -1535,7 +1476,7 @@ subroutine progcld_gfdl_lin & & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw,cnvw,cnvc, & ! --- inputs: & xlat,xlon,slmsk,cldtot, dz, delp, & & IX, NLAY, NLP1, & - & dzlay, cldtot1, cldcnv, & + & dzlay, cldtot1, cldcnv, lcrick, lcnorm, con_ttp, & & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs & cld_reice,cld_rwp, cld_rerain,cld_swp, cld_resnow & & ) @@ -1552,9 +1493,7 @@ subroutine progcld_gfdl_lin & ! top and base. the three vertical cloud domains are set up in the ! ! initial subroutine "cld_init". ! ! ! -! usage: call progcld_gfdl_lin ! -! ! -! subprograms called: gethml ! +! usage: call progcld_gfdl_lin ! ! ! ! attributes: ! ! language: fortran 90 ! @@ -1583,6 +1522,12 @@ subroutine progcld_gfdl_lin & ! IX : horizontal dimention ! ! NLAY,NLP1 : vertical layer/level dimensions ! ! dzlay(ix,nlay) : thickness between model layer centers (km) ! +! lcrick : control flag for eliminating CRICK ! +! =t: apply layer smoothing to eliminate CRICK ! +! =f: do not apply layer smoothing ! +! lcnorm : control flag for in-cld condensate ! +! =t: normalize cloud condensate ! +! =f: not normalize cloud condensate ! ! ! ! output variables: ! ! cloud profiles: ! @@ -1596,28 +1541,17 @@ subroutine progcld_gfdl_lin & ! *** cld_swp (:,:) - layer snow flake water path not assigned ! ! cld_resnow(:,:) - mean eff radius for snow flake (micron) ! ! ! -! module variables: ! -! ivflip : control flag of vertical index direction ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! lsashal : control flag for shallow convection ! -! lcrick : control flag for eliminating CRICK ! -! =t: apply layer smoothing to eliminate CRICK ! -! =f: do not apply layer smoothing ! -! lcnorm : control flag for in-cld condensate ! -! =t: normalize cloud condensate ! -! =f: not normalize cloud condensate ! -! ! ! ==================== end of description ===================== ! ! implicit none ! --- inputs integer, intent(in) :: IX, NLAY, NLP1 - + logical, intent(in) :: lcrick, lcnorm real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & & tlyr, tvly, qlyr, qstl, rhly, clw, cldtot, cnvw, cnvc, & & delp, dz, dzlay + real (kind=kind_phys) :: con_ttp real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & & slmsk @@ -1785,7 +1719,7 @@ subroutine progcld_fer_hires & & IX, NLAY, NLP1, icloud, & & uni_cld, lmfshal, lmfdeep2, cldcov, & & re_cloud,re_ice,re_snow, & - & dzlay, cldtot, cldcnv, & + & dzlay, cldtot, cldcnv, lcnorm, & & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs & cld_reice,cld_rwp, cld_rerain,cld_swp, cld_resnow & & ) @@ -1802,9 +1736,7 @@ subroutine progcld_fer_hires & ! top and base. the three vertical cloud domains are set up in the ! ! initial subroutine "cld_init". ! ! ! -! usage: call progcld_fer_hires ! -! ! -! subprograms called: gethml ! +! usage: call progcld_fer_hires ! ! ! ! attributes: ! ! language: fortran 90 ! @@ -1836,6 +1768,14 @@ subroutine progcld_fer_hires & ! lmfdeep2 : logical - true for mass flux deep convection ! ! cldcov : layer cloud fraction (used when uni_cld=.true. ! ! dzlay(ix,nlay) : thickness between model layer centers (km) ! +! lmfshal : mass-flux shallow conv scheme flag ! +! lmfdeep2 : scale-aware mass-flux deep conv scheme flag ! +! lcrick : control flag for eliminating CRICK ! +! =t: apply layer smoothing to eliminate CRICK ! +! =f: do not apply layer smoothing ! +! lcnorm : control flag for in-cld condensate ! +! =t: normalize cloud condensate ! +! =f: not normalize cloud condensate ! ! ! ! output variables: ! ! cloud profiles: ! @@ -1849,19 +1789,6 @@ subroutine progcld_fer_hires & ! *** cld_swp (:,:) - layer snow flake water path not assigned ! ! cld_resnow(:,:) - mean eff radius for snow flake (micron) ! ! ! -! module variables: ! -! ivflip : control flag of vertical index direction ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! lmfshal : mass-flux shallow conv scheme flag ! -! lmfdeep2 : scale-aware mass-flux deep conv scheme flag ! -! lcrick : control flag for eliminating CRICK ! -! =t: apply layer smoothing to eliminate CRICK ! -! =f: do not apply layer smoothing ! -! lcnorm : control flag for in-cld condensate ! -! =t: normalize cloud condensate ! -! =f: not normalize cloud condensate ! -! ! ! ==================== end of description ===================== ! ! implicit none @@ -1870,7 +1797,7 @@ subroutine progcld_fer_hires & integer, intent(in) :: IX, NLAY, NLP1, ICLOUD integer, intent(in) :: ntrac, ntcw, ntiw, ntrw - logical, intent(in) :: uni_cld, lmfshal, lmfdeep2 + logical, intent(in) :: uni_cld, lmfshal, lmfdeep2, lcnorm real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & & tlyr, tvly, qlyr, qstl, rhly, cldcov, delp, dz, dzlay @@ -2040,7 +1967,7 @@ subroutine progcld_thompson_wsm6 & & uni_cld, lmfshal, lmfdeep2, cldcov, cnvw, & & re_cloud,re_ice,re_snow, & & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & - & dzlay, cldtot, cldcnv, & + & dzlay, cldtot, cldcnv, lcnorm, & & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs & cld_reice,cld_rwp, cld_rerain,cld_swp, cld_resnow & & ) @@ -2058,9 +1985,7 @@ subroutine progcld_thompson_wsm6 & ! top and base. the three vertical cloud domains are set up in the ! ! initial subroutine "cld_init". ! ! ! -! usage: call progcld_thompson_wsm6 ! -! ! -! subprograms called: gethml ! +! usage: call progcld_thompson_wsm6 ! ! ! ! attributes: ! ! language: fortran 90 ! @@ -2091,6 +2016,14 @@ subroutine progcld_thompson_wsm6 & ! lmfshal : logical - true for mass flux shallow convection ! ! lmfdeep2 : logical - true for mass flux deep convection ! ! cldcov : layer cloud fraction (used when uni_cld=.true. ! +! lmfshal : mass-flux shallow conv scheme flag ! +! lmfdeep2 : scale-aware mass-flux deep conv scheme flag ! +! lcrick : control flag for eliminating CRICK ! +! =t: apply layer smoothing to eliminate CRICK ! +! =f: do not apply layer smoothing ! +! lcnorm : control flag for in-cld condensate ! +! =t: normalize cloud condensate ! +! =f: not normalize cloud condensate ! ! ! ! output variables: ! ! cloud profiles: ! @@ -2109,19 +2042,6 @@ subroutine progcld_thompson_wsm6 & ! mbot (IX,3) : vertical indices for low, mid, hi cloud bases ! ! de_lgth(ix) : clouds decorrelation length (km) ! ! ! -! module variables: ! -! ivflip : control flag of vertical index direction ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! lmfshal : mass-flux shallow conv scheme flag ! -! lmfdeep2 : scale-aware mass-flux deep conv scheme flag ! -! lcrick : control flag for eliminating CRICK ! -! =t: apply layer smoothing to eliminate CRICK ! -! =f: do not apply layer smoothing ! -! lcnorm : control flag for in-cld condensate ! -! =t: normalize cloud condensate ! -! =f: not normalize cloud condensate ! -! ! ! ==================== end of description ===================== ! ! implicit none @@ -2130,7 +2050,7 @@ subroutine progcld_thompson_wsm6 & integer, intent(in) :: IX, NLAY, NLP1 integer, intent(in) :: ntrac, ntcw, ntiw, ntrw, ntsw, ntgl - logical, intent(in) :: uni_cld, lmfshal, lmfdeep2 + logical, intent(in) :: uni_cld, lmfshal, lmfdeep2, lcnorm real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & & tlyr, qlyr, qstl, rhly, cldcov, delp, dz, dzlay, & @@ -2335,7 +2255,7 @@ subroutine progcld_thompson & & uni_cld, lmfshal, lmfdeep2, cldcov, & & re_cloud,re_ice,re_snow, & & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & - & dzlay, gridkm, cldtot, cldcnv, & + & dzlay, gridkm, top_at_1, cldtot, cldcnv, & & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs & cld_reice,cld_rwp, cld_rerain,cld_swp, cld_resnow & & ) @@ -2354,8 +2274,6 @@ subroutine progcld_thompson & ! ! ! usage: call progcld_thompson ! ! ! -! subprograms called: gethml ! -! ! ! attributes: ! ! language: fortran 90 ! ! machine: ibm-sp, sgi ! @@ -2385,7 +2303,16 @@ subroutine progcld_thompson & ! uni_cld : logical - true for cloud fraction from shoc ! ! lmfshal : logical - true for mass flux shallow convection ! ! lmfdeep2 : logical - true for mass flux deep convection ! +! top_at_1 : logical - true if vertical ordereing is toa-2-sfc ! ! cldcov : layer cloud fraction (used when uni_cld=.true. ! +! lmfshal : mass-flux shallow conv scheme flag ! +! lmfdeep2 : scale-aware mass-flux deep conv scheme flag ! +! lcrick : control flag for eliminating CRICK ! +! =t: apply layer smoothing to eliminate CRICK ! +! =f: do not apply layer smoothing ! +! lcnorm : control flag for in-cld condensate ! +! =t: normalize cloud condensate ! +! =f: not normalize cloud condensate ! ! ! ! output variables: ! ! cloud profiles: ! @@ -2399,19 +2326,6 @@ subroutine progcld_thompson & ! *** cld_swp (:,:) - layer snow flake water path not assigned ! ! cld_resnow(:,:) - mean eff radius for snow flake (micron) ! ! ! -! module variables: ! -! ivflip : control flag of vertical index direction ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! lmfshal : mass-flux shallow conv scheme flag ! -! lmfdeep2 : scale-aware mass-flux deep conv scheme flag ! -! lcrick : control flag for eliminating CRICK ! -! =t: apply layer smoothing to eliminate CRICK ! -! =f: do not apply layer smoothing ! -! lcnorm : control flag for in-cld condensate ! -! =t: normalize cloud condensate ! -! =f: not normalize cloud condensate ! -! ! ! ==================== end of description ===================== ! ! implicit none @@ -2420,7 +2334,7 @@ subroutine progcld_thompson & integer, intent(in) :: IX, NLAY, NLP1 integer, intent(in) :: ntrac, ntcw, ntiw, ntrw, ntsw, ntgl - logical, intent(in) :: uni_cld, lmfshal, lmfdeep2 + logical, intent(in) :: uni_cld, lmfshal, lmfdeep2, top_at_1 real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & & tlyr, qlyr, qstl, rhly, cldcov, delp, dz, dzlay, & @@ -2524,7 +2438,7 @@ subroutine progcld_thompson & cldfra1d(:) = 0.0 - if (ivflip .eq. 1) then + if (.not. top_at_1) then do k = 1, NLAY qv1d(k) = qlyr(i,k) qc1d(k) = max(0.0, clw(i,k,ntcw)) @@ -2618,7 +2532,7 @@ subroutine progclduni & & ( plyr,plvl,tlyr,tvly,ccnd,ncnd, & ! --- inputs: & xlat,xlon,slmsk,dz,delp, IX, NLAY, NLP1, cldtot, & & effrl,effri,effrr,effrs,effr_in, & - & dzlay, cldtot1, cldcnv, & + & dzlay, cldtot1, cldcnv, lcrick, lcnorm, con_ttp, & & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs & cld_reice,cld_rwp, cld_rerain,cld_swp, cld_resnow & & ) @@ -2640,8 +2554,6 @@ subroutine progclduni & ! ! ! usage: call progclduni ! ! ! -! subprograms called: gethml ! -! ! ! attributes: ! ! language: fortran 90 ! ! machine: ibm-sp, sgi ! @@ -2672,6 +2584,14 @@ subroutine progclduni & ! dz (ix,nlay) : layer thickness (km) ! ! delp (ix,nlay) : model layer pressure thickness in mb (100Pa) ! ! dzlay(ix,nlay) : thickness between model layer centers (km) ! +! lmfshal : mass-flux shallow conv scheme flag ! +! lmfdeep2 : scale-aware mass-flux deep conv scheme flag ! +! lcrick : control flag for eliminating CRICK ! +! =t: apply layer smoothing to eliminate CRICK ! +! =f: do not apply layer smoothing ! +! lcnorm : control flag for in-cld condensate ! +! =t: normalize cloud condensate ! +! =f: not normalize cloud condensate ! ! ! ! output variables: ! ! cloud profiles: ! @@ -2689,20 +2609,7 @@ subroutine progclduni & ! mtop (IX,3) : vertical indices for low, mid, hi cloud tops ! ! mbot (IX,3) : vertical indices for low, mid, hi cloud bases ! ! de_lgth(ix) : clouds decorrelation length (km) ! -! alpha(ix,nlay) : alpha decorrelation parameter -! ! -! module variables: ! -! ivflip : control flag of vertical index direction ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! lmfshal : mass-flux shallow conv scheme flag ! -! lmfdeep2 : scale-aware mass-flux deep conv scheme flag ! -! lcrick : control flag for eliminating CRICK ! -! =t: apply layer smoothing to eliminate CRICK ! -! =f: do not apply layer smoothing ! -! lcnorm : control flag for in-cld condensate ! -! =t: normalize cloud condensate ! -! =f: not normalize cloud condensate ! +! alpha(ix,nlay) : alpha decorrelation parameter ! ! ! ! ==================== end of description ===================== ! ! @@ -2710,8 +2617,9 @@ subroutine progclduni & ! --- inputs integer, intent(in) :: IX, NLAY, NLP1, ncnd - logical, intent(in) :: effr_in + logical, intent(in) :: effr_in, lcrick, lcnorm + real (kind=kind_phys), intent(in) :: con_ttp real (kind=kind_phys), dimension(:,:,:), intent(in) :: ccnd real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr,& & tlyr, tvly, cldtot, effrl, effri, effrr, effrs, dz, delp, & @@ -2923,8 +2831,8 @@ end subroutine progclduni !>\section detail Detailed Algorithm subroutine gethml & & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, alpha, & ! --- inputs: - & IX, NLAY, iovr_rand, iovr_maxrand, iovr_max, & - & iovr_dcorr, iovr_exp, iovr_exprand, & + & IX, NLAY, iovr, iovr_rand, iovr_maxrand, iovr_max, & + & iovr_dcorr, iovr_exp, iovr_exprand, top_at_1, si, & & clds, mtop, mbot & ! --- outputs: & ) @@ -2962,13 +2870,7 @@ subroutine gethml & ! output variables: ! ! clds (IX,5) : fraction of clouds for low, mid, hi, tot, bl ! ! mtop (IX,3) : vertical indices for low, mid, hi cloud tops ! -! mbot (IX,3) : vertical indices for low, mid, hi cloud bases ! -! ! -! external module variables: (in physparam) ! -! ivflip : control flag of vertical index direction ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! ! +! mbot (IX,3) : vertical indices for low, mid, hi cloud bases ! ! ! internal module variables: ! ! iovr : control flag for cloud overlap ! ! =0 random overlapping clouds ! @@ -2983,8 +2885,10 @@ subroutine gethml & implicit none! ! --- inputs: + logical, intent(in) :: top_at_1 integer, intent(in) :: IX, NLAY integer, intent(in) :: & + & iovr, ! & iovr_rand, ! Flag for random cloud overlap method & iovr_maxrand, ! Flag for maximum-random cloud overlap method & iovr_max, ! Flag for maximum cloud overlap method @@ -2994,7 +2898,7 @@ subroutine gethml & real (kind=kind_phys), dimension(:,:), intent(in) :: plyr, ptop1, & & cldtot, cldcnv, dz - real (kind=kind_phys), dimension(:), intent(in) :: de_lgth + real (kind=kind_phys), dimension(:), intent(in) :: de_lgth, si real (kind=kind_phys), dimension(:,:), intent(in) :: alpha ! --- outputs @@ -3007,11 +2911,30 @@ subroutine gethml & real (kind=kind_phys) :: pcur, pnxt, ccur, cnxt, alfa integer, dimension(IX):: idom, kbt1, kth1, kbt2, kth2 - integer :: i, k, id, id1, kstr, kend, kinc + integer :: i, k, id, id1, kstr, kend, kinc,kl ! !===> ... begin here ! +!> - Compute the top of BL cld (llyr), which is the topmost non +!! cld(low) layer for stratiform (at or above lowest 0.1 of the +!! atmosphere). + + if (top_at_1) then ! data from toa to sfc + lab_do_k0 : do k = NLAY, 2, -1 + kl = k + if (si(k) < 0.9e0) exit lab_do_k0 + enddo lab_do_k0 + llyr = kl + else ! data from sfc to top + lab_do_k1 : do k = 2, NLAY + kl = k + if (si(k) < 0.9e0) exit lab_do_k1 + enddo lab_do_k1 + + llyr = kl - 1 + endif ! end_if_top_at_1 + clds(:,:) = 0.0 do i = 1, IX @@ -3025,7 +2948,7 @@ subroutine gethml & !> - Calculate total and BL cloud fractions (maximum-random cloud !! overlapping is operational). - if ( ivflip == 0 ) then ! input data from toa to sfc + if (top_at_1) then ! input data from toa to sfc kstr = NLAY kend = 1 kinc = -1 @@ -3033,7 +2956,7 @@ subroutine gethml & kstr = 1 kend = NLAY kinc = 1 - endif ! end_if_ivflip + endif ! end_if_top_at_1 if ( iovr == iovr_rand ) then ! random overlap @@ -3167,7 +3090,7 @@ subroutine gethml & !> - Calculte high, mid, low cloud fractions and vertical indices of !! cloud tops/bases. - if ( ivflip == 0 ) then ! input data from toa to sfc + if (top_at_1) then ! input data from toa to sfc do i = 1, IX cl1 (i) = 0.0 @@ -3331,7 +3254,7 @@ subroutine gethml & enddo ! end_do_i_loop enddo ! end_do_k_loop - endif ! end_if_ivflip + endif ! end_if_top_at_1 ! return diff --git a/physics/radiation_gases.f b/physics/radiation_gases.f index b5eb8ffb9..85204e5ab 100644 --- a/physics/radiation_gases.f +++ b/physics/radiation_gases.f @@ -80,7 +80,7 @@ ! nov 2008 - y-t hou fix bugs in superimposing climatology ! ! seasonal cycle calculations ! ! aug 2011 - y-t hou fix a bug in subr getgases doing vertical ! -! co2 mapping. (for iflip=0 case, not affact opr). ! +! co2 mapping. (for top_at_1 case, not affact opr). ! ! aug 2012 - y-t hou modified subr getozn. moved the if-first ! ! block to subr gas_init to ensure threading safe in ! ! climatology ozone applications. (not affect gfs) ! diff --git a/physics/radlw_main.meta b/physics/radlw_main.meta index 8dc1db046..e336e6011 100644 --- a/physics/radlw_main.meta +++ b/physics/radlw_main.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = rrtmg_lw type = scheme - dependencies = machine.F,mersenne_twister.f,physcons.F90,physparam.f,radlw_datatb.f,radlw_param.f + dependencies = machine.F,mersenne_twister.f,physcons.F90,radlw_datatb.f,radlw_param.f ######################################################################## [ccpp-arg-table] From 79eb46965dd50b0a8b1c544862e1cc6cc67d0380 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Wed, 24 Aug 2022 20:08:42 +0000 Subject: [PATCH 024/380] Changes for refactor --- physics/GFS_rrtmgp_cloud_mp.F90 | 176 ++++--- physics/GFS_rrtmgp_pre.F90 | 71 ++- physics/GFS_rrtmgp_pre.meta | 82 ++- physics/GFS_rrtmgp_setup.F90 | 6 +- physics/GFS_rrtmgp_setup.meta | 2 +- physics/rrtmgp_lw_main.F90 | 442 ++++++++-------- physics/rrtmgp_lw_main.meta | 77 ++- physics/rrtmgp_sw_cloud_optics.F90 | 44 +- physics/rrtmgp_sw_cloud_optics.meta | 393 --------------- physics/rrtmgp_sw_cloud_sampling.F90 | 174 ------- physics/rrtmgp_sw_cloud_sampling.meta | 240 --------- physics/rrtmgp_sw_gas_optics.meta | 201 -------- physics/rrtmgp_sw_main.F90 | 695 ++++++++++++++------------ physics/rrtmgp_sw_main.meta | 21 +- physics/rrtmgp_sw_rte.F90 | 219 -------- physics/rrtmgp_sw_rte.meta | 240 --------- 16 files changed, 898 insertions(+), 2185 deletions(-) delete mode 100644 physics/rrtmgp_sw_cloud_optics.meta delete mode 100644 physics/rrtmgp_sw_cloud_sampling.F90 delete mode 100644 physics/rrtmgp_sw_cloud_sampling.meta delete mode 100644 physics/rrtmgp_sw_gas_optics.meta delete mode 100644 physics/rrtmgp_sw_rte.F90 delete mode 100644 physics/rrtmgp_sw_rte.meta diff --git a/physics/GFS_rrtmgp_cloud_mp.F90 b/physics/GFS_rrtmgp_cloud_mp.F90 index ca9457b4c..966c9f2e9 100644 --- a/physics/GFS_rrtmgp_cloud_mp.F90 +++ b/physics/GFS_rrtmgp_cloud_mp.F90 @@ -1,10 +1,5 @@ -!> \file GFS_rrtmgp_cloud_mp.F90 -!! -!> \defgroup GFS_rrtmgp_cloud_mp GFS_rrtmgp_cloud_mp.F90 -!! -!! \brief This module contains the interface for ALL cloud microphysics assumptions and -!! the RRTMGP radiation scheme. Specific details below in subroutines. -!! +! ######################################################################################## +! ######################################################################################## module GFS_rrtmgp_cloud_mp use machine, only: kind_phys use radiation_tools, only: check_error_msg @@ -27,21 +22,15 @@ module GFS_rrtmgp_cloud_mp reice_min = 10.0, & ! Minimum ice size allowed by GFDL MP scheme reice_max = 150.0 ! Maximum ice size allowed by GFDL MP scheme - public GFS_rrtmgp_cloud_mp_run + public GFS_rrtmgp_cloud_mp_init, GFS_rrtmgp_cloud_mp_run, GFS_rrtmgp_cloud_mp_finalize contains -!>\defgroup gfs_rrtmgp_cloud_mp_mod GFS RRTMGP Cloud MP Module !! \section arg_table_GFS_rrtmgp_cloud_mp_run !! \htmlinclude GFS_rrtmgp_cloud_mp_run_html !! -!> \ingroup GFS_rrtmgp_cloud_mp -!! -!! Here the cloud-radiative properties (optical-path, particle-size and sometimes cloud- -!! fraction) are computed for cloud producing physics schemes (e.g GFDL-MP, Thompson-MP, -!! MYNN-EDMF-pbl, GF-convective, and SAMF-convective clouds). -!! -!! \section GFS_rrtmgp_cloud_mp_run + ! ###################################################################################### + ! ###################################################################################### subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, & i_cldrain, i_cldsnow, i_cldgrpl, i_cldtot, i_cldliq_nc, i_cldice_nc, i_twa, kdt, & imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_samf, doSWrad, doLWrad, effr_in, lmfshal, & @@ -296,22 +285,22 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic end subroutine GFS_rrtmgp_cloud_mp_run -!> \ingroup GFS_rrtmgp_cloud_mp -!! Compute cloud radiative properties for Grell-Freitas convective cloud scheme. -!! (Adopted from module_SGSCloud_RadPre) -!! -!! - The total convective cloud condensate is partitoned by phase, using temperature, into -!! liquid/ice convective cloud mixing-ratios. Compute convective cloud LWP and IWP's. -!! -!! - The liquid and ice cloud effective particle sizes are assigned reference values*. -!! *TODO* Find references, include DOIs, parameterize magic numbers, etc... -!! -!! - The convective cloud-fraction is computed using Xu-Randall (1996). -!! (DJS asks: Does the GF scheme produce a cloud-fraction? If so, maybe use instead of -!! Xu-Randall? Xu-Randall is consistent with the Thompson MP scheme, but -!! not GFDL-EMC) -!! -!! \section cloud_mp_GF_gen General Algorithm + ! ###################################################################################### + ! Compute cloud radiative properties for Grell-Freitas convective cloud scheme. + ! (Adopted from module_SGSCloud_RadPre) + ! + ! - The total convective cloud condensate is partitoned by phase, using temperature, into + ! liquid/ice convective cloud mixing-ratios. Compute convective cloud LWP and IWP's. + ! + ! - The liquid and ice cloud effective particle sizes are assigned reference values*. + ! *TODO* Find references, include DOIs, parameterize magic numbers, etc... + ! + ! - The convective cloud-fraction is computed using Xu-Randall (1996). + ! (DJS asks: Does the GF scheme produce a cloud-fraction? If so, maybe use instead of + ! Xu-Randall? Xu-Randall is consistent with the Thompson MP scheme, but + ! not GFDL-EMC) + ! + ! ###################################################################################### subroutine cloud_mp_GF(nCol, nLev, lsmask, t_lay, p_lev, p_lay, qs_lay, relhum, & qci_conv, con_ttp, con_g, alpha0, cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, & cld_cnv_reice, cld_cnv_frac) @@ -376,17 +365,17 @@ subroutine cloud_mp_GF(nCol, nLev, lsmask, t_lay, p_lev, p_lay, qs_lay, relhum, enddo end subroutine cloud_mp_GF -!> \ingroup GFS_rrtmgp_cloud_mp -!! Compute cloud radiative properties for MYNN-EDMF PBL cloud scheme. -!! (Adopted from module_SGSCloud_RadPre) -!! -!! - Cloud-fraction, liquid, and ice condensate mixing-ratios from MYNN-EDMF cloud scheme -!! are provided as inputs. Cloud LWP and IWP are computed. -!! -!! - The liquid and ice cloud effective particle sizes are assigned reference values*. -!! *TODO* Find references, include DOIs, parameterize magic numbers, etc... -!! -!! \section cloud_mp_MYNN_gen General Algorithm + ! ###################################################################################### + ! Compute cloud radiative properties for MYNN-EDMF PBL cloud scheme. + ! (Adopted from module_SGSCloud_RadPre) + ! + ! - Cloud-fraction, liquid, and ice condensate mixing-ratios from MYNN-EDMF cloud scheme + ! are provided as inputs. Cloud LWP and IWP are computed. + ! + ! - The liquid and ice cloud effective particle sizes are assigned reference values*. + ! *TODO* Find references, include DOIs, parameterize magic numbers, etc... + ! + ! ###################################################################################### subroutine cloud_mp_MYNN(nCol, nLev, lsmask, t_lay, p_lev, p_lay, qs_lay, relhum, & qc_mynn, qi_mynn, con_ttp, con_g, cld_pbl_lwp, cld_pbl_reliq, cld_pbl_iwp, & cld_pbl_reice, cld_pbl_frac) @@ -448,18 +437,18 @@ subroutine cloud_mp_MYNN(nCol, nLev, lsmask, t_lay, p_lev, p_lay, qs_lay, relhum enddo end subroutine cloud_mp_MYNN -!> \ingroup GFS_rrtmgp_cloud_mp -!! Compute cloud radiative properties for SAMF convective cloud scheme. -!! -!! - The total-cloud convective mixing-ratio is partitioned by phase into liquid/ice -!! cloud properties. LWP and IWP are computed. -!! -!! - The liquid and ice cloud effective particle sizes are assigned reference values. -!! -!! - The convective cloud-fraction is computed using Xu-Randall (1996). -!! (DJS asks: Does the SAMF scheme produce a cloud-fraction?) -!! -!! \section cloud_mp_SAMF_gen General Algorithm + ! ###################################################################################### + ! Compute cloud radiative properties for SAMF convective cloud scheme. + ! + ! - The total-cloud convective mixing-ratio is partitioned by phase into liquid/ice + ! cloud properties. LWP and IWP are computed. + ! + ! - The liquid and ice cloud effective particle sizes are assigned reference values. + ! + ! - The convective cloud-fraction is computed using Xu-Randall (1996). + ! (DJS asks: Does the SAMF scheme produce a cloud-fraction?) + ! + ! ###################################################################################### subroutine cloud_mp_SAMF(nCol, nLev, t_lay, p_lev, p_lay, qs_lay, relhum, & cnv_mixratio, con_ttp, con_g, alpha0, cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, & cld_cnv_reice, cld_cnv_frac) @@ -489,14 +478,15 @@ subroutine cloud_mp_SAMF(nCol, nLev, t_lay, p_lev, p_lay, qs_lay, relhum, cld_cnv_frac ! Convective cloud-fraction (1) ! Local integer :: iCol, iLay - real(kind_phys) :: tem1, deltaP, clwc + real(kind_phys) :: tem0, tem1, deltaP, clwc + tem0 = 1.0e5/con_g do iLay = 1, nLev do iCol = 1, nCol if (cnv_mixratio(iCol,iLay) > 0._kind_phys) then tem1 = min(1.0, max(0.0, (con_ttp-t_lay(iCol,iLay))*0.05)) deltaP = abs(p_lev(iCol,iLay+1)-p_lev(iCol,iLay))*0.01 - clwc = max(0.0, cnv_mixratio(iCol,iLay)) * con_g * deltaP + clwc = max(0.0, cnv_mixratio(iCol,iLay)) * tem0 * deltaP cld_cnv_iwp(iCol,iLay) = clwc * tem1 cld_cnv_lwp(iCol,iLay) = clwc - cld_cnv_iwp(iCol,iLay) cld_cnv_reliq(iCol,iLay) = reliq_def @@ -510,13 +500,17 @@ subroutine cloud_mp_SAMF(nCol, nLev, t_lay, p_lev, p_lay, qs_lay, relhum, enddo end subroutine cloud_mp_SAMF - -!> \ingroup GFS_rrtmgp_cloud_mp -!! This routine computes the cloud radiative properties for a "unified cloud". -!! - "unified cloud" implies that the cloud-fraction is PROVIDED. -!! - The cloud water path is computed for all provided cloud mixing-ratios and hydrometeors. -!! - If particle sizes are provided, they are used. If not, default values are assigned. -!! \section cloud_mp_uni_gen General Algorithm + + ! ###################################################################################### + ! This routine computes the cloud radiative properties for a "unified cloud". + ! + ! - "unified cloud" implies that the cloud-fraction is PROVIDED. + ! + ! - The cloud water path is computed for all provided cloud mixing-ratios and hydrometeors. + ! + ! - If particle sizes are provided, they are used. If not, default values are assigned. + ! + ! ###################################################################################### subroutine cloud_mp_uni(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_cldrain, & i_cldsnow, i_cldgrpl, i_cldtot, effr_in, kdt, lsmask, p_lev, p_lay, t_lay, tv_lay,& effrin_cldliq, effrin_cldice, effrin_cldsnow, tracer, con_g, con_rd, con_ttp, & @@ -642,20 +636,19 @@ subroutine cloud_mp_uni(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_cldrai enddo ! nLev end subroutine cloud_mp_uni - -!> \ingroup GFS_rrtmgp_cloud_mp -!! This routine computes the cloud radiative properties for the Thompson cloud micro- -!! physics scheme. -!! -!! - The cloud water path is computed for all provided cloud mixing-ratios and hydrometeors. -!! -!! - There are no assumptions about particle size applied here. Effective particle sizes -!! are updated prior to this routine, see cmp_reff_Thompson(). -!! -!! - The cloud-fraction is computed using Xu-Randall** (1996). -!! **Additionally, Conditioned on relative-humidity** -!! -!! \section cloud_mp_thompson_gen General Algorithm + ! ###################################################################################### + ! This routine computes the cloud radiative properties for the Thompson cloud micro- + ! physics scheme. + ! + ! - The cloud water path is computed for all provided cloud mixing-ratios and hydrometeors. + ! + ! - There are no assumptions about particle size applied here. Effective particle sizes + ! are updated prior to this routine, see cmp_reff_Thompson(). + ! + ! - The cloud-fraction is computed using Xu-Randall** (1996). + ! **Additionally, Conditioned on relative-humidity** + ! + ! ###################################################################################### subroutine cloud_mp_thompson(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_cldrain,& i_cldsnow, i_cldgrpl, p_lev, p_lay, tv_lay, t_lay, tracer, qs_lay, q_lay, relhum, & con_g, con_rd, con_eps, alpha0, lwp_ex, iwp_ex, lwp_fc, iwp_fc, cld_frac, cld_lwp,& @@ -768,14 +761,14 @@ subroutine cloud_mp_thompson(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_c end subroutine cloud_mp_thompson -!> \ingroup GFS_rrtmgp_cloud_mp -!! This function computes the cloud-fraction following. -!! Xu-Randall(1996) A Semiempirical Cloudiness Parameterization for Use in Climate Models -!! https://doi.org/10.1175/1520-0469(1996)053<3084:ASCPFU>2.0.CO;2 -!! -!! cld_frac = {1-exp[-alpha*cld_mr/((1-relhum)*qs_lay)**lambda]}*relhum**P -!! -!! \section cld_frac_XuRandall_gen General Algorithm + ! ###################################################################################### + ! This function computes the cloud-fraction following. + ! Xu-Randall(1996) A Semiempirical Cloudiness Parameterization for Use in Climate Models + ! https://doi.org/10.1175/1520-0469(1996)053<3084:ASCPFU>2.0.CO;2 + ! + ! cld_frac = {1-exp[-alpha*cld_mr/((1-relhum)*qs_lay)**lambda]}*relhum**P + ! + ! ###################################################################################### function cld_frac_XuRandall(p_lay, qs_lay, relhum, cld_mr, alpha) implicit none ! Inputs @@ -812,11 +805,11 @@ function cld_frac_XuRandall(p_lay, qs_lay, relhum, cld_mr, alpha) return end function -!> \ingroup GFS_rrtmgp_cloud_mp -!! This routine is a wrapper to update the Thompson effective particle sizes used by the -!! RRTMGP radiation scheme. -!! -!! \section cmp_reff_Thompson_gen General Algorithm + ! ###################################################################################### + ! This routine is a wrapper to update the Thompson effective particle sizes used by the + ! RRTMGP radiation scheme. + ! + ! ###################################################################################### subroutine cmp_reff_Thompson(nLev, nCol, i_cldliq, i_cldice, i_cldsnow, i_cldice_nc, & i_cldliq_nc, i_twa, q_lay, p_lay, t_lay, tracer, con_eps, con_rd, ltaerosol, & effrin_cldliq, effrin_cldice, effrin_cldsnow) @@ -887,4 +880,5 @@ subroutine cmp_reff_Thompson(nLev, nCol, i_cldliq, i_cldice, i_cldsnow, i_cldice enddo end subroutine cmp_reff_Thompson + end module GFS_rrtmgp_cloud_mp diff --git a/physics/GFS_rrtmgp_pre.F90 b/physics/GFS_rrtmgp_pre.F90 index d46f60af1..5b4bb025e 100644 --- a/physics/GFS_rrtmgp_pre.F90 +++ b/physics/GFS_rrtmgp_pre.F90 @@ -15,10 +15,9 @@ module GFS_rrtmgp_pre NF_VGAS, & !< Number of active gas species getgases, & !< Routine to setup trace gases getozn !< Routine to setup ozone - ! RRTMGP types - use mo_gas_concentrations, only: ty_gas_concs use radiation_tools, only: check_error_msg,cmp_tlev use rrtmgp_lw_gas_optics, only: lw_gas_props + implicit none real(kind_phys), parameter :: & amd = 28.9644_kind_phys, & !< Molecular weight of dry-air (g/mol) @@ -112,23 +111,24 @@ end subroutine GFS_rrtmgp_pre_init !! !! \section GFS_rrtmgp_pre_run ! ######################################################################################### - subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhswr, fhlwr, & + subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, doSWrad, doLWrad, fhswr, fhlwr, & xlat, xlon, prsl, tgrs, prslk, prsi, qgrs, tsfc, coslat, sinlat, con_g, con_rd, & con_eps, con_epsm1, con_fvirt, con_epsqs, solhr, minGPpres, maxGPpres, minGPtemp, & - maxGPtemp, raddt, p_lay, t_lay, p_lev, t_lev, tsfg, tsfa, qs_lay, q_lay, tv_lay, & - relhum, tracer, deltaZ, deltaZc, deltaP, active_gases_array, gas_concentrations, & - tsfc_radtime, coszen, coszdg, top_at_1, iSFC, iTOA, semis, sfc_emiss_byband, errmsg, & - errflg) + maxGPtemp, raddt, p_lay, t_lay, p_lev, t_lev, vmr_o2, vmr_h2o, vmr_o3, vmr_ch4, & + vmr_n2o, vmr_co2, tsfg, tsfa, qs_lay, q_lay, tv_lay, & + relhum, deltaZ, deltaZc, deltaP, active_gases_array, & + tsfc_radtime, coszen, coszdg, top_at_1, iSFC, iTOA, nDay, idxday, semis, & + sfc_emiss_byband, errmsg, errflg) ! Inputs integer, intent(in) :: & + me, & ! MPI rank nCol, & ! Number of horizontal grid points nLev, & ! Number of vertical layers - nTracers, & ! Number of tracers from model. i_o3 ! Index into tracer array for ozone logical, intent(in) :: & - lsswr, & ! Call SW radiation? - lslwr ! Call LW radiation + doSWrad, & ! Call SW radiation? + doLWrad ! Call LW radiation real(kind_phys), intent(in) :: & minGPtemp, & ! Minimum temperature allowed in RRTMGP. maxGPtemp, & ! Maximum ... @@ -167,7 +167,8 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw integer, intent(out) :: & errflg, & ! Error flag iSFC, & ! Vertical index for surface - iTOA ! Vertical index for TOA + iTOA, & ! Vertical index for TOA + nDay logical, intent(out) :: & top_at_1 ! Vertical ordering flag real(kind_phys), intent(inout) :: & @@ -178,6 +179,8 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw tsfc_radtime, & ! Surface temperature at radiation timestep coszen, & ! Cosine of SZA coszdg ! Cosine of SZA, daytime + integer, dimension(:), intent(inout) :: & + idxday ! Indices for daylit points real(kind_phys), dimension(:,:), intent(inout) :: & p_lay, & ! Pressure at model-layer t_lay, & ! Temperature at model layer @@ -190,15 +193,11 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw deltaP, & ! Layer thickness (Pa) p_lev, & ! Pressure at model-interface sfc_emiss_byband, & ! - t_lev ! Temperature at model-interface - real(kind_phys), dimension(:,:,:),intent(inout) :: & - tracer ! Array containing trace gases - type(ty_gas_concs), intent(inout) :: & - gas_concentrations ! RRTMGP DDT: gas volumne mixing ratios + t_lev, & ! Temperature at model-interface + vmr_o2, vmr_h2o, vmr_o3, vmr_ch4, vmr_n2o, vmr_co2 ! Local variables integer :: i, j, iCol, iBand, iLay, iLev, iSFC_ilev - real(kind_phys),dimension(nCol,nLev) :: vmr_o3, vmr_h2o real(kind_phys) :: es, tem1, tem2, pfac real(kind_phys), dimension(nLev+1) :: hgtb real(kind_phys), dimension(nLev) :: hgtc @@ -210,7 +209,7 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw errmsg = '' errflg = 0 - if (.not. (lsswr .or. lslwr)) return + if (.not. (doSWrad .or. doLWrad)) return ! ####################################################################################### ! What is vertical ordering? @@ -340,16 +339,11 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw ! ####################################################################################### ! Get layer ozone mass mixing ratio ! ####################################################################################### - ! First recast remaining all tracers (except sphum) forcing them all to be positive - do j = 2, nTracers - tracer(1:NCOL,:,j) = qgrs(1:NCOL,:,j) - where(tracer(:,:,j) .lt. 0.0) tracer(:,:,j) = 0._kind_phys - enddo if (i_o3 > 0) then do iLay=1,nlev do iCol=1,NCOL - o3_lay(iCol,iLay) = max( con_epsqs, tracer(iCol,iLay,i_o3) ) + o3_lay(iCol,iLay) = max( con_epsqs, qgrs(iCol,iLay,i_o3) ) enddo enddo ! OR Use climatological ozone data @@ -362,21 +356,14 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw ! ####################################################################################### ! Call getgases(), to set up non-prognostic gas volume mixing ratios (gas_vmr). call getgases (p_lev/100., xlon, xlat, nCol, nLev, gas_vmr) + vmr_o2 = gas_vmr(:,:,4) + vmr_ch4 = gas_vmr(:,:,3) + vmr_n2o = gas_vmr(:,:,2) + vmr_co2 = gas_vmr(:,:,1) ! Compute volume mixing-ratios for ozone (mmr) and specific-humidity. vmr_h2o = merge((q_lay/(1-q_lay))*amdw, 0., q_lay .ne. 1.) vmr_o3 = merge(o3_lay*amdo3, 0., o3_lay .gt. 0.) - - ! Populate RRTMGP DDT w/ gas-concentrations - gas_concentrations%ncol = nCol - gas_concentrations%nlay = nLev - gas_concentrations%gas_name(:) = active_gases_array(:) - gas_concentrations%concs(istr_o2)%conc(:,:) = gas_vmr(:,:,4) - gas_concentrations%concs(istr_co2)%conc(:,:) = gas_vmr(:,:,1) - gas_concentrations%concs(istr_ch4)%conc(:,:) = gas_vmr(:,:,3) - gas_concentrations%concs(istr_n2o)%conc(:,:) = gas_vmr(:,:,2) - gas_concentrations%concs(istr_h2o)%conc(:,:) = vmr_h2o(:,:) - gas_concentrations%concs(istr_o3)%conc(:,:) = vmr_o3(:,:) ! ####################################################################################### ! Radiation time step (output) (Is this really needed?) (Used by some diagnostics) @@ -392,8 +379,20 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw ! ####################################################################################### ! Compute cosine of zenith angle (only when SW is called) ! ####################################################################################### - if (lsswr) then + if (doSWrad) then call coszmn (xlon, sinlat, coslat, solhr, nCol, me, coszen, coszdg) + ! For SW gather daylit points + nday = 0 + idxday = 0 + do iCol = 1, nCol + if (coszen(iCol) >= 0.0001) then + nday = nday + 1 + idxday(nday) = iCol + endif + enddo + else + nday = 0 + idxday = 0 endif ! ####################################################################################### diff --git a/physics/GFS_rrtmgp_pre.meta b/physics/GFS_rrtmgp_pre.meta index 4992f4ef8..2eb9a92b4 100644 --- a/physics/GFS_rrtmgp_pre.meta +++ b/physics/GFS_rrtmgp_pre.meta @@ -72,21 +72,14 @@ dimensions = () type = integer intent = in -[nTracers] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in -[lsswr] +[doSWrad] standard_name = flag_for_calling_shortwave_radiation long_name = logical flags for sw radiation calls units = flag dimensions = () type = logical intent = in -[lslwr] +[doLWrad] standard_name = flag_for_calling_longwave_radiation long_name = logical flags for lw radiation calls units = flag @@ -425,11 +418,51 @@ type = real kind = kind_phys intent = inout -[tracer] - standard_name = chemical_tracers - long_name = chemical tracers - units = g g-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) +[vmr_o2] + standard_name = volume_mixing_ratio_for_o2 + long_name = molar mixing ratio of o2 in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[vmr_h2o] + standard_name = volume_mixing_ratio_for_h2o + long_name = molar mixing ratio of h2o in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[vmr_o3] + standard_name = volume_mixing_ratio_for_o3 + long_name = molar mixing ratio of o3 in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[vmr_ch4] + standard_name = volume_mixing_ratio_for_ch4 + long_name = molar mixing ratio of ch4 in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[vmr_n2o] + standard_name = volume_mixing_ratio_for_n2o + long_name = molar mixing ratio of n2o in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[vmr_co2] + standard_name = volume_mixing_ratio_for_co2 + long_name = molar mixing ratio of co2 in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -441,13 +474,6 @@ type = character kind = len=* intent = in -[gas_concentrations] - standard_name = Gas_concentrations_for_RRTMGP_suite - long_name = DDT containing gas concentrations for RRTMGP radiation scheme - units = DDT - dimensions = () - type = ty_gas_concs - intent = inout [coszdg] standard_name = cosine_of_solar_zenith_angle_on_radiation_timestep long_name = daytime mean cosz over rad call period @@ -480,6 +506,20 @@ type = real kind = kind_phys intent = inout +[nday] + standard_name = daytime_points_dimension + long_name = daytime points dimension + units = count + dimensions = () + type = integer + intent = inout +[idxday] + standard_name = daytime_points + long_name = daytime points + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = inout [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/GFS_rrtmgp_setup.F90 b/physics/GFS_rrtmgp_setup.F90 index 3cd8af019..f028acca2 100644 --- a/physics/GFS_rrtmgp_setup.F90 +++ b/physics/GFS_rrtmgp_setup.F90 @@ -156,7 +156,7 @@ end subroutine GFS_rrtmgp_setup_init !> \section arg_table_GFS_rrtmgp_setup_timestep_init !! \htmlinclude GFS_rrtmgp_setup_timestep_init.html !! - subroutine GFS_rrtmgp_setup_timestep_init (idate, jdate, deltsw, deltim, lsswr, me, & + subroutine GFS_rrtmgp_setup_timestep_init (idate, jdate, deltsw, deltim, doSWrad, me, & slag, sdec, cdec, solcon, errmsg, errflg) ! Inputs @@ -164,7 +164,7 @@ subroutine GFS_rrtmgp_setup_timestep_init (idate, jdate, deltsw, deltim, lsswr, integer, intent(in) :: jdate(:) real(kind_phys), intent(in) :: deltsw real(kind_phys), intent(in) :: deltim - logical, intent(in) :: lsswr + logical, intent(in) :: doSWrad integer, intent(in) :: me ! Outputs @@ -222,7 +222,7 @@ subroutine GFS_rrtmgp_setup_timestep_init (idate, jdate, deltsw, deltim, lsswr, endif ! Update solar forcing... - if (lsswr) then + if (doSWrad) then if ( isolar == 0 .or. isolar == 10 ) then lsol_chg = .false. elseif ( iyear0 /= iyear ) then diff --git a/physics/GFS_rrtmgp_setup.meta b/physics/GFS_rrtmgp_setup.meta index 41bf63ac8..160430765 100644 --- a/physics/GFS_rrtmgp_setup.meta +++ b/physics/GFS_rrtmgp_setup.meta @@ -256,7 +256,7 @@ type = real kind = kind_phys intent = in -[lsswr] +[doSWrad] standard_name = flag_for_calling_shortwave_radiation long_name = logical flags for sw radiation calls units = flag diff --git a/physics/rrtmgp_lw_main.F90 b/physics/rrtmgp_lw_main.F90 index b58e5a45d..0277b276a 100644 --- a/physics/rrtmgp_lw_main.F90 +++ b/physics/rrtmgp_lw_main.F90 @@ -102,48 +102,58 @@ end subroutine rrtmgp_lw_main_init !> @{ ! ###################################################################################### subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, & - use_LW_jacobian, doGP_sgs_cnv, doGP_sgs_pbl, nCol, nLay, nGauss_angles, icseed_lw,& - iovr, iovr_convcld, iovr_max, iovr_maxrand, iovr_rand, iovr_dcorr, iovr_exp, & - iovr_exprand, isubc_lw, semis, tsfg, p_lay, p_lev, t_lay, t_lev, cld_frac, & - cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, cld_rerain, & - precip_frac, cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, cld_cnv_reice, cld_pbl_lwp, & - cld_pbl_reliq, cld_pbl_iwp, cld_pbl_reice, cloud_overlap_param, sfc_emiss_byband, & - active_gases_array, lw_optical_props_aerosol, gas_concentrations, fluxlwUP_allsky,& - fluxlwDOWN_allsky, fluxlwUP_clrsky, fluxlwDOWN_clrsky, fluxlwUP_jac, & - fluxlwUP_radtime, fluxlwDOWN_radtime, errmsg, errflg) + use_LW_jacobian, doGP_sgs_cnv, doGP_sgs_pbl, nCol, nLay, nGases,rrtmgp_phys_blksz,& + nGauss_angles, icseed_lw, iovr, iovr_convcld, iovr_max, iovr_maxrand, iovr_rand, & + iovr_dcorr, iovr_exp, iovr_exprand, isubc_lw, semis, tsfg, p_lay, p_lev, t_lay, & + t_lev, vmr_o2, vmr_h2o, vmr_o3, vmr_ch4, vmr_n2o, vmr_co2, & + cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, & + cld_rwp, cld_rerain, precip_frac, cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, & + cld_cnv_reice, cld_pbl_lwp, cld_pbl_reliq, cld_pbl_iwp, cld_pbl_reice, & + cloud_overlap_param, active_gases_array, & + lw_optical_props_aerosol, fluxlwUP_allsky, fluxlwDOWN_allsky, & + fluxlwUP_clrsky, fluxlwDOWN_clrsky, fluxlwUP_jac, fluxlwUP_radtime, & + fluxlwDOWN_radtime, errmsg, errflg) ! Inputs logical, intent(in) :: & - doLWrad, & ! Flag to calculate LW irradiances - doLWclrsky, & ! Flag to compute clear-sky fluxes (diagnostic) - top_at_1, & ! Vertical ordering flag - use_LW_jacobian, & ! Compute Jacobian of LW to update radiative fluxes between radiation calls? - doGP_sgs_pbl, & ! Flag for sgs MYNN-EDMF PBL cloud scheme - doGP_sgs_cnv, & ! Flag for sgs convective cloud scheme - doGP_lwscat ! Include scattering in LW cloud-optics? + doLWrad, & ! Flag to perform longwave calculation + doLWclrsky, & ! Flag to compute clear-sky fluxes + top_at_1, & ! Flag for vertical ordering convention + use_LW_jacobian, & ! Flag to compute Jacobian of longwave surface flux + doGP_sgs_pbl, & ! Flag to include sgs PBL clouds + doGP_sgs_cnv, & ! Flag to include sgs convective clouds + doGP_lwscat ! Flag to include scattering in clouds integer,intent(in) :: & - nCol, & ! Number of horizontal points - nLay, & ! Number of vertical grid points. - nGauss_angles, & ! - iovr, & ! Choice of cloud-overlap method - iovr_convcld, & ! Choice of convective cloud-overlap - iovr_max, & ! Flag for maximum cloud overlap method - iovr_maxrand, & ! Flag for maximum-random cloud overlap method - iovr_rand, & ! Flag for random cloud overlap method - iovr_dcorr, & ! Flag for decorrelation-length cloud overlap method - iovr_exp, & ! Flag for exponential cloud overlap method - iovr_exprand, & ! Flag for exponential-random cloud overlap method - isubc_lw ! + nCol, & ! Number of horizontal points + nLay, & ! Number of vertical grid points. + nGases, & ! Number of active gases + rrtmgp_phys_blksz, & ! Number of horizontal points to process at once. + nGauss_angles, & ! Number of gaussian quadrature angles used + iovr, & ! Choice of cloud-overlap method + iovr_convcld, & ! Choice of convective cloud-overlap + iovr_max, & ! Flag for maximum cloud overlap method + iovr_maxrand, & ! Flag for maximum-random cloud overlap method + iovr_rand, & ! Flag for random cloud overlap method + iovr_dcorr, & ! Flag for decorrelation-length cloud overlap method + iovr_exp, & ! Flag for exponential cloud overlap method + iovr_exprand, & ! Flag for exponential-random cloud overlap method + isubc_lw ! Flag for cloud-seeding (rng) for cloud-sampling integer,intent(in),dimension(:) :: & - icseed_lw ! Seed for random number generation for longwave radiation + icseed_lw ! Seed for random number generation for longwave radiation real(kind_phys), dimension(:), intent(in) :: & - semis, & ! Surface-emissivity - tsfg ! + semis, & ! Surface-emissivity (1) + tsfg ! Skin temperature (K) real(kind_phys), dimension(:,:), intent(in) :: & p_lay, & ! Pressure @ model layer-centers (Pa) t_lay, & ! Temperature (K) p_lev, & ! Pressure @ model layer-interfaces (Pa) t_lev, & ! Temperature @ model levels (K) + vmr_o2, & ! Molar-mixing ratio oxygen + vmr_h2o, & ! Molar-mixing ratio water vapor + vmr_o3, & ! Molar-mixing ratio ozone + vmr_ch4, & ! Molar-mixing ratio methane + vmr_n2o, & ! Molar-mixing ratio nitrous oxide + vmr_co2, & ! Molar-mixing ratio carbon dioxide cld_frac, & ! Cloud-fraction for stratiform clouds cld_lwp, & ! Water path for stratiform liquid cloud-particles cld_reliq, & ! Effective radius for stratiform liquid cloud-particles @@ -153,23 +163,21 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, cld_resnow, & ! Effective radius for snow hydrometeors cld_rwp, & ! Water path for rain hydrometeors cld_rerain, & ! Effective radius for rain hydrometeors - precip_frac, & ! Precipitation fraction + precip_frac, & ! Precipitation fraction (not active, currently precipitation optics uses cloud-fraction) cld_cnv_lwp, & ! Water path for convective liquid cloud-particles cld_cnv_reliq, & ! Effective radius for convective liquid cloud-particles cld_cnv_iwp, & ! Water path for convective ice cloud-particles cld_cnv_reice, & ! Effective radius for convective ice cloud-particles - cld_pbl_lwp, & ! Water path for SGS PBL liquid cloud-particles - cld_pbl_reliq, & ! Effective radius for SGS PBL liquid cloud-particles - cld_pbl_iwp, & ! Water path for SGS PBL ice cloud-particles - cld_pbl_reice, & ! Effective radius for SGS PBL ice cloud-particles - sfc_emiss_byband, & ! - cloud_overlap_param + cld_pbl_lwp, & ! Water path for PBL liquid cloud-particles + cld_pbl_reliq, & ! Effective radius for PBL liquid cloud-particles + cld_pbl_iwp, & ! Water path for PBL ice cloud-particles + cld_pbl_reice, & ! Effective radius for PBL ice cloud-particles + cloud_overlap_param ! Cloud overlap parameter character(len=*), dimension(:), intent(in) :: & active_gases_array ! List of active gases from namelist as array type(ty_optical_props_1scl),intent(inout) :: & lw_optical_props_aerosol ! RRTMGP DDT: Longwave aerosol optical properties (tau) - type(ty_gas_concs), intent(in) :: & - gas_concentrations ! RRTMGP DDT: + ! Outputs real(kind_phys), dimension(:,:), intent(inout) :: & fluxlwUP_jac, & ! Jacobian of upwelling LW surface radiation (W/m2/K) @@ -185,91 +193,87 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, errflg ! CCPP error flag ! Local variables - type(ty_gas_concs) :: & - gas_concs ! RRTMGP DDT: trace gas concentrations (vmr) - type(ty_optical_props_1scl) :: & - lw_optical_props_clrsky, & ! RRTMGP DDT: longwave clear-sky radiative properties - lw_optical_props_aerosol_local ! RRTMGP DDT: longwave aerosol radiative properties - type(ty_optical_props_2str) :: & - lw_optical_props_clouds, & ! RRTMGP DDT: Longwave optical properties in each band (sampled clouds) - lw_optical_props_cloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (clouds) - lw_optical_props_cnvcloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (convective cloud) - lw_optical_props_pblcloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (PBL cloud) - lw_optical_props_precipByBand ! RRTMGP DDT: Longwave optical properties in each band (precipitation) - type(ty_source_func_lw) :: & - sources ! RRTMGP DDT: longwave source functions - type(ty_fluxes_byband) :: & - flux_allsky, flux_clrsky ! RRTMGP DDT: Longwave flux profiles - integer :: iCol, iLay, iGas, iBand, ipseed_lw + type(ty_gas_concs) :: gas_concs + type(ty_optical_props_1scl) :: lw_optical_props_clrsky, lw_optical_props_aerosol_local + type(ty_optical_props_2str) :: lw_optical_props_clouds, lw_optical_props_cloudsByBand, & + lw_optical_props_cnvcloudsByBand, lw_optical_props_pblcloudsByBand, & + lw_optical_props_precipByBand + type(ty_source_func_lw) :: sources + type(ty_fluxes_byband) :: flux_allsky, flux_clrsky + integer :: iCol, iLay, iGas, iBand, iCol2, ix, iblck + integer, dimension(rrtmgp_phys_blksz) :: ipseed_lw type(random_stat) :: rng_stat - real(kind_phys) :: tau_rain, tau_snow + logical, dimension(rrtmgp_phys_blksz,nLay,lw_gas_props%get_ngpt()) :: maskMCICA + real(kind_phys), dimension(rrtmgp_phys_blksz) :: tau_rain, tau_snow real(kind_phys), dimension(lw_gas_props%get_ngpt()) :: rng1D - real(kind_phys), dimension(lw_gas_props%get_ngpt(),nLay,1) :: rng3D,rng3D2 + real(kind_phys), dimension(lw_gas_props%get_ngpt(),nLay,rrtmgp_phys_blksz) :: rng3D,rng3D2 real(kind_phys), dimension(lw_gas_props%get_ngpt()*nLay) :: rng2D - logical, dimension(1,nLay,lw_gas_props%get_ngpt()) :: maskMCICA - real(kind_phys), dimension(1,nLay+1,lw_gas_props%get_nband()),target :: & + real(kind_phys), dimension(rrtmgp_phys_blksz,nLay+1,lw_gas_props%get_nband()),target :: & fluxLW_up_allsky, fluxLW_up_clrsky, fluxLW_dn_allsky, fluxLW_dn_clrsky - real(kind_phys), dimension(1,lw_gas_props%get_ngpt()) :: lw_Ds - real(kind_phys), dimension(nCol, nLay,gas_concentrations%get_num_gases()) :: vmrTemp - + real(kind_phys), dimension(rrtmgp_phys_blksz,lw_gas_props%get_ngpt()) :: lw_Ds + real(kind_phys), dimension(lw_gas_props%get_nband(),rrtmgp_phys_blksz) :: sfc_emiss_byband ! Initialize CCPP error handling variables errmsg = '' errflg = 0 if (.not. doLWrad) return - fluxlwUP_clrsky(:,:) = 0._kind_phys - fluxlwDOWN_clrsky(:,:) = 0._kind_phys ! ###################################################################################### ! ! Allocate/initialize RRTMGP DDT's ! ! ###################################################################################### - ! + ! ty_gas_concs - ! - gas_concs%ncol = 1 + gas_concs%ncol = rrtmgp_phys_blksz gas_concs%nlay = nLay - allocate(gas_concs%gas_name(gas_concentrations%get_num_gases())) - allocate(gas_concs%concs(gas_concentrations%get_num_gases())) - do iGas=1,gas_concentrations%get_num_gases() - allocate(gas_concs%concs(iGas)%conc(1, nLay)) + allocate(gas_concs%gas_name(nGases)) + allocate(gas_concs%concs(nGases)) + do iGas=1,ngases + allocate(gas_concs%concs(iGas)%conc(rrtmgp_phys_blksz, nLay)) enddo gas_concs%gas_name(:) = active_gases_array(:) - do iGas=1,gas_concentrations%get_num_gases() - call check_error_msg('rrtmgp_lw_main_get_vmr',& - gas_concentrations%get_vmr(trim(gas_concentrations%gas_name(iGas)),vmrTemp(:,:,iGas))) - enddo - ! + ! ty_optical_props - ! call check_error_msg('rrtmgp_lw_main_gas_optics_init',& - lw_optical_props_clrsky%alloc_1scl(1, nLay, lw_gas_props)) + lw_optical_props_clrsky%alloc_1scl(rrtmgp_phys_blksz, nLay, lw_gas_props)) call check_error_msg('rrtmgp_lw_main_sources_init',& - sources%alloc(1, nLay, lw_gas_props)) + sources%alloc(rrtmgp_phys_blksz, nLay, lw_gas_props)) call check_error_msg('rrtmgp_lw_main_cloud_optics_init',& - lw_optical_props_cloudsByBand%alloc_2str(1, nLay, lw_gas_props%get_band_lims_wavenumber())) + lw_optical_props_cloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) call check_error_msg('rrtmgp_lw_main_precip_optics_init',& - lw_optical_props_precipByBand%alloc_2str(1, nLay, lw_gas_props%get_band_lims_wavenumber())) + lw_optical_props_precipByBand%alloc_2str(rrtmgp_phys_blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) call check_error_msg('rrtmgp_lw_mian_cloud_sampling_init', & - lw_optical_props_clouds%alloc_2str(1, nLay, lw_gas_props)) + lw_optical_props_clouds%alloc_2str(rrtmgp_phys_blksz, nLay, lw_gas_props)) call check_error_msg('rrtmgp_lw_main_aerosol_optics_init',& - lw_optical_props_aerosol_local%alloc_1scl(1, nLay, lw_gas_props%get_band_lims_wavenumber())) + lw_optical_props_aerosol_local%alloc_1scl(rrtmgp_phys_blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) if (doGP_sgs_cnv) then call check_error_msg('rrtmgp_lw_main_cnv_cloud_optics_init',& - lw_optical_props_cnvcloudsByBand%alloc_2str(1, nLay, lw_gas_props%get_band_lims_wavenumber())) + lw_optical_props_cnvcloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) endif if (doGP_sgs_pbl) then call check_error_msg('rrtmgp_lw_main_pbl_cloud_optics_init',& - lw_optical_props_pblcloudsByBand%alloc_2str(1, nLay, lw_gas_props%get_band_lims_wavenumber())) + lw_optical_props_pblcloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) endif + ! ###################################################################################### + ! ! Loop over all columns... - do iCol=1,nCol + ! + ! ###################################################################################### + do iCol=1,nCol,rrtmgp_phys_blksz + iCol2 = iCol + rrtmgp_phys_blksz - 1 + + ! ################################################################################### + ! ! Initialize/reset - do iGas=1,gas_concentrations%get_num_gases() - gas_concs%concs(iGas)%conc(1,:) = 0._kind_phys + ! + ! ################################################################################### + ! ty_gas_concs + do iGas=1,nGases + gas_concs%concs(iGas)%conc(:,:) = 0._kind_phys end do + ! ty_optical_props lw_optical_props_clrsky%tau = 0._kind_phys lw_optical_props_precipByBand%tau = 0._kind_phys lw_optical_props_precipByBand%ssa = 0._kind_phys @@ -291,6 +295,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, fluxLW_dn_clrsky = 0._kind_phys if (doGP_sgs_cnv) lw_optical_props_cnvcloudsByBand%tau = 0._kind_phys if (doGP_sgs_pbl) lw_optical_props_pblcloudsByBand%tau = 0._kind_phys + ! ty_fluxes_byband flux_allsky%bnd_flux_up => fluxLW_up_allsky flux_allsky%bnd_flux_dn => fluxLW_dn_allsky flux_clrsky%bnd_flux_up => fluxLW_up_clrsky @@ -301,147 +306,183 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, ! Set gas-concentrations ! ! ################################################################################### - do iGas=1,gas_concentrations%get_num_gases() - call check_error_msg('rrtmgp_sw_gas_optics_run_set_vmr',& - gas_concs%set_vmr(trim(gas_concentrations%gas_name(iGas)),vmrTemp(iCol,:,iGas))) + gas_concs%concs(istr_o2)%conc(:,:) = vmr_o2(iCol:iCol2,:) + gas_concs%concs(istr_co2)%conc(:,:) = vmr_co2(iCol:iCol2,:) + gas_concs%concs(istr_ch4)%conc(:,:) = vmr_ch4(iCol:iCol2,:) + gas_concs%concs(istr_n2o)%conc(:,:) = vmr_n2o(iCol:iCol2,:) + gas_concs%concs(istr_h2o)%conc(:,:) = vmr_h2o(iCol:iCol2,:) + gas_concs%concs(istr_o3)%conc(:,:) = vmr_o3(iCol:iCol2,:) + + ! ################################################################################### + ! + ! Surface emissity in each band + ! + ! ################################################################################### + ! Assign same emissivity to all band + do iblck=1,rrtmgp_phys_blksz + if (semis(iCol+iblck-1) > 1e-6 .and. semis(iCol+iblck-1) <= 1.0) then + do iBand=1,lw_gas_props%get_nband() + sfc_emiss_byband(iBand,iblck) = semis(iCol+iblck-1) + enddo + else + sfc_emiss_byband(1:lw_gas_props%get_nband(),iblck) = 1.0 + endif enddo ! ################################################################################### ! - ! Gas-optics + ! Compute gas-optics... ! ! ################################################################################### call check_error_msg('rrtmgp_lw_main_gas_optics',lw_gas_props%gas_optics(& - p_lay(iCol:iCol,:), & ! IN - Pressure @ layer-centers (Pa) - p_lev(iCol:iCol,:), & ! IN - Pressure @ layer-interfaces (Pa) - t_lay(iCol:iCol,:), & ! IN - Temperature @ layer-centers (K) - tsfg(iCol:iCol), & ! IN - Skin-temperature (K) + p_lay(iCol:iCol2,:), & ! IN - Pressure @ layer-centers (Pa) + p_lev(iCol:iCol2,:), & ! IN - Pressure @ layer-interfaces (Pa) + t_lay(iCol:iCol2,:), & ! IN - Temperature @ layer-centers (K) + tsfg(iCol:iCol2), & ! IN - Skin-temperature (K) gas_concs, & ! IN - RRTMGP DDT: trace gas volumne mixing-ratios lw_optical_props_clrsky, & ! OUT - RRTMGP DDT: longwave optical properties sources, & ! OUT - RRTMGP DDT: source functions - tlev=t_lev(iCol:iCol,:))) ! IN - Temperature @ layer-interfaces (K) (optional) + tlev=t_lev(iCol:iCol2,:))) ! IN - Temperature @ layer-interfaces (K) (optional) ! ################################################################################### ! - ! Cloud-optics + ! Compute cloud-optics... ! ! ################################################################################### - if (any(cld_frac(iCol,:) .gt. 0.)) then + if (any(cld_frac(iCol:iCol2,:) .gt. 0.)) then + ! Microphysical (gridmean) cloud optics call check_error_msg('rrtmgp_lw_main_cloud_optics',lw_cloud_props%cloud_optics(& - cld_lwp(iCol:iCol,:), & ! IN - Cloud liquid water path (g/m2) - cld_iwp(iCol:iCol,:), & ! IN - Cloud ice water path (g/m2) - cld_reliq(iCol:iCol,:), & ! IN - Cloud liquid effective radius (microns) - cld_reice(iCol:iCol,:), & ! IN - Cloud ice effective radius (microns) - lw_optical_props_cloudsByBand)) ! OUT - RRTMGP DDT containing cloud radiative properties - ! in each band - endif - - ! Convective cloud-optics? - if (doGP_sgs_cnv) then - call check_error_msg('rrtmgp_lw_main_cnv_cloud_optics',lw_cloud_props%cloud_optics(& - cld_cnv_lwp(iCol:iCol,:), & ! IN - Convective cloud liquid water path (g/m2) - cld_cnv_iwp(iCol:iCol,:), & ! IN - Convective cloud ice water path (g/m2) - cld_cnv_reliq(iCol:iCol,:), & ! IN - Convective cloud liquid effective radius (microns) - cld_cnv_reice(iCol:iCol,:), & ! IN - Convective cloud ice effective radius (microns) - lw_optical_props_cnvcloudsByBand)) ! OUT - RRTMGP DDT containing convective cloud radiative properties - ! in each band - !call check_error_msg('rrtmgp_lw_main_increment_cnvclouds_to_clouds',& - ! lw_optical_props_cnvcloudsByBand%increment(lw_optical_props_cloudsByBand)) - endif + cld_lwp(iCol:iCol2,:), & ! IN - Cloud liquid water path (g/m2) + cld_iwp(iCol:iCol2,:), & ! IN - Cloud ice water path (g/m2) + cld_reliq(iCol:iCol2,:), & ! IN - Cloud liquid effective radius (microns) + cld_reice(iCol:iCol2,:), & ! IN - Cloud ice effective radius (microns) + lw_optical_props_cloudsByBand)) ! OUT - RRTMGP DDT containing cloud radiative properties + ! in each band + ! Include convective (subgrid scale) clouds? + if (doGP_sgs_cnv) then + call check_error_msg('rrtmgp_lw_main_cnv_cloud_optics',lw_cloud_props%cloud_optics(& + cld_cnv_lwp(iCol:iCol2,:), & ! IN - Convective cloud liquid water path (g/m2) + cld_cnv_iwp(iCol:iCol2,:), & ! IN - Convective cloud ice water path (g/m2) + cld_cnv_reliq(iCol:iCol2,:), & ! IN - Convective cloud liquid effective radius (microns) + cld_cnv_reice(iCol:iCol2,:), & ! IN - Convective cloud ice effective radius (microns) + lw_optical_props_cnvcloudsByBand)) ! OUT - RRTMGP DDT containing convective cloud radiative properties + ! in each band + call check_error_msg('rrtmgp_lw_main_increment_cnvclouds_to_clouds',& + lw_optical_props_cnvcloudsByBand%increment(lw_optical_props_cloudsByBand)) + endif - ! MYNN PBL cloud-optics? - if (doGP_sgs_pbl) then - call check_error_msg('rrtmgp_lw_main_pbl_cloud_optics',lw_cloud_props%cloud_optics(& - cld_pbl_lwp(iCol:iCol,:), & ! IN - MYNN-EDMF PBL cloud liquid water path (g/m2) - cld_pbl_iwp(iCol:iCol,:), & ! IN - MYNN-EDMF PBL cloud ice water path (g/m2) - cld_pbl_reliq(iCol:iCol,:), & ! IN - MYNN-EDMF PBL cloud liquid effective radius (microns) - cld_pbl_reice(iCol:iCol,:), & ! IN - MYNN-EDMF PBL cloud ice effective radius (microns) - lw_optical_props_pblcloudsByBand)) ! OUT - RRTMGP DDT containing MYNN-EDMF PBL cloud radiative properties - ! in each band - !call check_error_msg('rrtmgp_lw_main_increment_pblclouds_to_clouds',& - ! lw_optical_props_pblcloudsByBand%increment(lw_optical_props_cloudsByBand)) + ! Include PBL (subgrid scale) clouds? + if (doGP_sgs_pbl) then + call check_error_msg('rrtmgp_lw_main_pbl_cloud_optics',lw_cloud_props%cloud_optics(& + cld_pbl_lwp(iCol:iCol2,:), & ! IN - PBL cloud liquid water path (g/m2) + cld_pbl_iwp(iCol:iCol2,:), & ! IN - PBL cloud ice water path (g/m2) + cld_pbl_reliq(iCol:iCol2,:), & ! IN - PBL cloud liquid effective radius (microns) + cld_pbl_reice(iCol:iCol2,:), & ! IN - PBL cloud ice effective radius (microns) + lw_optical_props_pblcloudsByBand)) ! OUT - RRTMGP DDT containing PBL cloud radiative properties + ! in each band + call check_error_msg('rrtmgp_lw_main_increment_pblclouds_to_clouds',& + lw_optical_props_pblcloudsByBand%increment(lw_optical_props_cloudsByBand)) + endif endif + ! ################################################################################### + ! ! Cloud precipitation optics: rain and snow(+groupel) - tau_rain = 0._kind_phys - tau_snow = 0._kind_phys - do iLay=1,nLay - if (cld_frac(iCol,iLay) .gt. 0.) then - ! Rain optical-depth (No band dependence) - tau_rain = absrain*cld_rwp(iCol,iLay) - - ! Snow (+groupel) optical-depth (No band dependence) - if (cld_swp(iCol,iLay) .gt. 0. .and. cld_resnow(iCol,iLay) .gt. 10._kind_phys) then - tau_snow = abssnow0*1.05756*cld_swp(iCol,iLay)/cld_resnow(iCol,iLay) - else - tau_snow = 0.0 + ! + ! ################################################################################### + tau_rain(:) = 0._kind_phys + tau_snow(:) = 0._kind_phys + do ix=1,rrtmgp_phys_blksz + do iLay=1,nLay + if (cld_frac(iCol+ix-1,iLay) .gt. 0.) then + ! Rain optical-depth (No band dependence) + tau_rain(ix) = absrain*cld_rwp(iCol+ix-1,iLay) + + ! Snow (+groupel) optical-depth (No band dependence) + if (cld_swp(iCol+ix-1,iLay) .gt. 0. .and. cld_resnow(iCol+ix-1,iLay) .gt. 10._kind_phys) then + tau_snow(ix) = abssnow0*1.05756*cld_swp(iCol+ix-1,iLay)/cld_resnow(iCol+ix-1,iLay) + else + tau_snow(ix) = 0.0 + endif + do iBand=1,lw_gas_props%get_nband() + lw_optical_props_precipByBand%tau(ix,iLay,iBand) = tau_rain(ix) + tau_snow(ix) + enddo endif - do iBand=1,lw_gas_props%get_nband() - lw_optical_props_precipByBand%tau(1,iLay,iBand) = tau_rain + tau_snow - enddo - endif + enddo enddo - !call check_error_msg('rrtmgp_lw_main_increment_precip_to_clouds',& - ! lw_optical_props_precipByBand%increment(lw_optical_props_cloudsByBand)) + call check_error_msg('rrtmgp_lw_main_increment_precip_to_clouds',& + lw_optical_props_precipByBand%increment(lw_optical_props_cloudsByBand)) ! ################################################################################### ! ! Cloud-sampling + ! *Note* All of the included cloud-types are sampled together, not independently. ! ! ################################################################################### - if (any(cld_frac(iCol,:) .gt. 0.)) then + if (any(cld_frac(iCol:iCol2,:) .gt. 0.)) then ! Change random number seed value for each radiation invocation (isubc_lw =1 or 2). if(isubc_lw == 1) then ! advance prescribed permutation seed - ipseed_lw = lw_gas_props%get_ngpt() + iCol + do ix=1,rrtmgp_phys_blksz + ipseed_lw(ix) = lw_gas_props%get_ngpt() + iCol + ix - 1 + enddo elseif (isubc_lw == 2) then ! use input array of permutaion seeds - ipseed_lw = icseed_lw(iCol) + do ix=1,rrtmgp_phys_blksz + ipseed_lw(ix) = icseed_lw(iCol+ix-1) + enddo endif + ! Call RNG - call random_setseed(ipseed_lw,rng_stat) - ! Use same rng for each layer - if (iovr == iovr_max) then - call random_number(rng1D,rng_stat) - do iLay=1,nLay - rng3D(:,iLay,1) = rng1D - enddo - else - do iLay=1,nLay + do ix=1,rrtmgp_phys_blksz + call random_setseed(ipseed_lw(ix),rng_stat) + ! Use same rng for each layer + if (iovr == iovr_max) then call random_number(rng1D,rng_stat) - rng3D(:,iLay,1) = rng1D - enddo - endif + do iLay=1,nLay + rng3D(:,iLay,ix) = rng1D + enddo + else + do iLay=1,nLay + call random_number(rng1D,rng_stat) + rng3D(:,iLay,ix) = rng1D + enddo + endif + enddo + ! Cloud-overlap. ! Maximum-random, random or maximum. if (iovr == iovr_maxrand .or. iovr == iovr_rand .or. iovr == iovr_max) then - call sampled_mask(rng3D, cld_frac(iCol:iCol,:), maskMCICA) + call sampled_mask(rng3D, cld_frac(iCol:iCol2,:), maskMCICA) endif ! Exponential decorrelation length overlap if (iovr == iovr_dcorr) then - ! Generate second RNG - call random_setseed(ipseed_lw,rng_stat) - call random_number(rng2D,rng_stat) - rng3D2(:,:,1) = reshape(source = rng2D,shape=[lw_gas_props%get_ngpt(),nLay]) + do ix=1,rrtmgp_phys_blksz + ! Generate second RNG + call random_setseed(ipseed_lw(ix),rng_stat) + call random_number(rng2D,rng_stat) + rng3D2(:,:,ix) = reshape(source = rng2D,shape=[lw_gas_props%get_ngpt(),nLay]) + enddo ! - call sampled_mask(rng3D, cld_frac(iCol:iCol,:), maskMCICA, & - overlap_param = cloud_overlap_param(iCol:iCol,1:nLay-1), randoms2 = rng3D2) + call sampled_mask(rng3D, cld_frac(iCol:iCol2,:), maskMCICA, & + overlap_param = cloud_overlap_param(iCol:iCol2,1:nLay-1), randoms2 = rng3D2) endif ! Exponential or Exponential-random if (iovr == iovr_exp .or. iovr == iovr_exprand) then - call sampled_mask(rng3D, cld_frac(iCol:iCol,:), maskMCICA, & - overlap_param = cloud_overlap_param(iCol:iCol,1:nLay-1)) + call sampled_mask(rng3D, cld_frac(iCol:iCol2,:), maskMCICA, & + overlap_param = cloud_overlap_param(iCol:iCol2,1:nLay-1)) endif ! Sampling. Map band optical depth to each g-point using McICA call check_error_msg('rrtmgp_lw_main_cloud_sampling',& draw_samples(maskMCICA, .true., & lw_optical_props_cloudsByBand, lw_optical_props_clouds)) endif + ! ################################################################################### ! ! Compute clear-sky fluxes (gaseous+aerosol) (optional) ! ! ################################################################################### ! Add aerosol optics to gas optics - lw_optical_props_aerosol_local%tau = lw_optical_props_aerosol%tau(iCol:iCol,:,:) + lw_optical_props_aerosol_local%tau = lw_optical_props_aerosol%tau(iCol:iCol2,:,:) call check_error_msg('rrtmgp_lw_main_increment_aerosol_to_clrsky',& lw_optical_props_aerosol_local%increment(lw_optical_props_clrsky)) @@ -454,7 +495,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, lw_optical_props_clrsky, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag sources, & ! IN - source function - sfc_emiss_byband(:,iCol:iCol), & ! IN - surface emissivity in each LW band + sfc_emiss_byband, & ! IN - surface emissivity in each LW band flux_clrsky, & ! OUT - Fluxes n_gauss_angles = nGauss_angles)) ! IN - Number of angles in Gaussian quadrature else @@ -462,41 +503,34 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, lw_optical_props_clrsky, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag sources, & ! IN - source function - sfc_emiss_byband(:,iCol:iCol), & ! IN - surface emissivity in each LW band + sfc_emiss_byband, & ! IN - surface emissivity in each LW band flux_clrsky, & ! OUT - Fluxes lw_Ds = lw_Ds)) endif ! Store fluxes - fluxlwUP_clrsky(iCol:iCol,:) = sum(flux_clrsky%bnd_flux_up, dim=3) - fluxlwDOWN_clrsky(iCol:iCol,:) = sum(flux_clrsky%bnd_flux_dn, dim=3) + fluxlwUP_clrsky(iCol:iCol2,:) = sum(flux_clrsky%bnd_flux_up, dim=3) + fluxlwDOWN_clrsky(iCol:iCol2,:) = sum(flux_clrsky%bnd_flux_dn, dim=3) else - fluxlwUP_clrsky(iCol,:) = 0.0 - fluxlwDOWN_clrsky(iCol,:) = 0.0 + fluxlwUP_clrsky(iCol:iCol2,:) = 0.0 + fluxlwDOWN_clrsky(iCol:iCol2,:) = 0.0 endif ! ################################################################################### ! ! All-sky fluxes (clear-sky + clouds + precipitation) + ! *Note* CCPP does not allow for polymorphic types, they are ambiguous to the CCPP + ! framework. rte-rrtmgp uses polymorphic types extensively, for example, querying the + ! type to determine physics configuration/pathway/etc... ! + ! The logic in the code below is to satisfy the polymorphishm in the rte-rrtmgp code. + ! The rte-rrtmgp "increment" procedures are utilized to provide the correct type to the + ! rte solver (rte_lw). Rte_lw quieries the type determine if scattering is to be + ! included in the calculation. The increment procedures are called so that the correct + ! optical properties are inherited. ugh... + ! ! ################################################################################### - ! Include convective cloud? - if (doGP_sgs_cnv) then - call check_error_msg('rrtmgp_lw_main_increment_cnvclouds_to_clrsky',& - lw_optical_props_cnvcloudsByBand%increment(lw_optical_props_clrsky)) - endif - - ! Include MYNN-EDMF PBL clouds? - if (doGP_sgs_pbl) then - call check_error_msg('rrtmgp_lw_main_increment_pblclouds_to_clrsky',& - lw_optical_props_pblcloudsByBand%increment(lw_optical_props_clrsky)) - endif - - ! Add in precipitation - call check_error_msg('rrtmgp_lw_main_increment_precip_to_clrsky',& - lw_optical_props_precipByBand%increment(lw_optical_props_clouds)) - ! Include LW cloud-scattering? if (doGP_lwscat) then ! Add clear-sky optics to cloud-optics (2-stream) @@ -509,7 +543,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, lw_optical_props_clouds, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag sources, & ! IN - source function - sfc_emiss_byband(:,iCol:iCol), & ! IN - surface emissivity in each LW band + sfc_emiss_byband, & ! IN - surface emissivity in each LW band flux_allsky, & ! OUT - Flxues n_gauss_angles = nGauss_angles, & ! IN - Number of angles in Gaussian quadrature flux_up_Jac = fluxlwUP_jac)) ! OUT - surface temperature flux (upward) Jacobian (W/m2/K) @@ -518,7 +552,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, lw_optical_props_clouds, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag sources, & ! IN - source function - sfc_emiss_byband(:,iCol:iCol), & ! IN - surface emissivity in each LW band + sfc_emiss_byband, & ! IN - surface emissivity in each LW band flux_allsky, & ! OUT - Flxues n_gauss_angles = nGauss_angles)) ! IN - Number of angles in Gaussian quadrature end if @@ -534,7 +568,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, lw_optical_props_clrsky, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag sources, & ! IN - source function - sfc_emiss_byband(:,iCol:iCol), & ! IN - surface emissivity in each LW band + sfc_emiss_byband, & ! IN - surface emissivity in each LW band flux_allsky, & ! OUT - Flxues n_gauss_angles = nGauss_angles, & ! IN - Number of angles in Gaussian quadrature flux_up_Jac = fluxlwUP_jac)) ! OUT - surface temperature flux (upward) Jacobian (W/m2/K) @@ -543,19 +577,19 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, lw_optical_props_clrsky, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag sources, & ! IN - source function - sfc_emiss_byband(:,iCol:iCol), & ! IN - surface emissivity in each LW band + sfc_emiss_byband, & ! IN - surface emissivity in each LW band flux_allsky, & ! OUT - Flxues n_gauss_angles = nGauss_angles)) ! IN - Number of angles in Gaussian quadrature end if endif ! Store fluxes - fluxlwUP_allsky(iCol:iCol,:) = sum(flux_allsky%bnd_flux_up, dim=3) - fluxlwDOWN_allsky(iCol:iCol,:) = sum(flux_allsky%bnd_flux_dn, dim=3) + fluxlwUP_allsky(iCol:iCol2,:) = sum(flux_allsky%bnd_flux_up, dim=3) + fluxlwDOWN_allsky(iCol:iCol2,:) = sum(flux_allsky%bnd_flux_dn, dim=3) ! Save fluxes for coupling - fluxlwUP_radtime(iCol,:) = fluxlwUP_allsky(iCol,:) - fluxlwDOWN_radtime(iCol,:) = fluxlwDOWN_allsky(iCol,:) + fluxlwUP_radtime(iCol:iCol2,:) = fluxlwUP_allsky(iCol:iCol2,:) + fluxlwDOWN_radtime(iCol:iCol2,:) = fluxlwDOWN_allsky(iCol:iCol2,:) enddo diff --git a/physics/rrtmgp_lw_main.meta b/physics/rrtmgp_lw_main.meta index ec352c0a8..334a75607 100644 --- a/physics/rrtmgp_lw_main.meta +++ b/physics/rrtmgp_lw_main.meta @@ -201,6 +201,13 @@ dimensions = () type = integer intent = in +[rrtmgp_phys_blksz] + standard_name = number_of_columns_per_RRTMGP_block + long_name = number of columns to process ata time by RRTMGP + units = count + dimensions = () + type = integer + intent = in [nLay] standard_name = vertical_layer_dimension long_name = number of vertical levels @@ -215,6 +222,13 @@ dimensions = () type = integer intent = in +[nGases] + standard_name = number_of_active_gases_used_by_RRTMGP + long_name = number of gases available used by RRTMGP (Model%nGases) + units = count + dimensions = () + type = integer + intent = in [isubc_lw] standard_name = flag_for_lw_clouds_sub_grid_approximation long_name = flag for lw clouds sub-grid approximation @@ -333,6 +347,54 @@ type = real kind = kind_phys intent = in +[vmr_o2] + standard_name = volume_mixing_ratio_for_o2 + long_name = molar mixing ratio of o2 in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[vmr_h2o] + standard_name = volume_mixing_ratio_for_h2o + long_name = molar mixing ratio of h2o in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[vmr_o3] + standard_name = volume_mixing_ratio_for_o3 + long_name = molar mixing ratio of o3 in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[vmr_ch4] + standard_name = volume_mixing_ratio_for_ch4 + long_name = molar mixing ratio of ch4 in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[vmr_n2o] + standard_name = volume_mixing_ratio_for_n2o + long_name = molar mixing ratio of n2o in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[vmr_co2] + standard_name = volume_mixing_ratio_for_co2 + long_name = molar mixing ratio of co2 in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in [cld_frac] standard_name = total_cloud_fraction long_name = layer total cloud fraction @@ -485,14 +547,6 @@ type = real kind = kind_phys intent = in -[sfc_emiss_byband] - standard_name = surface_emissivity_in_each_RRTMGP_LW_band - long_name = surface emissivity in each RRTMGP LW band - units = none - dimensions = (number_of_longwave_bands,horizontal_loop_extent) - type = real - kind = kind_phys - intent = in [active_gases_array] standard_name = list_of_active_gases_used_by_RRTMGP long_name = list of active gases used by RRTMGP @@ -508,13 +562,6 @@ dimensions = () type = ty_optical_props_1scl intent = in -[gas_concentrations] - standard_name = Gas_concentrations_for_RRTMGP_suite - long_name = DDT containing gas concentrations for RRTMGP radiation scheme - units = DDT - dimensions = () - type = ty_gas_concs - intent = in [fluxlwUP_radtime] standard_name = RRTMGP_lw_flux_profile_upward_allsky_on_radiation_timestep long_name = RRTMGP upward longwave all-sky flux profile diff --git a/physics/rrtmgp_sw_cloud_optics.F90 b/physics/rrtmgp_sw_cloud_optics.F90 index 3aab115cd..a750a549b 100644 --- a/physics/rrtmgp_sw_cloud_optics.F90 +++ b/physics/rrtmgp_sw_cloud_optics.F90 @@ -1,18 +1,8 @@ -!> \file rrtmgp_sw_cloud_optics.F90 -!! -!> \defgroup rrtmgp_sw_cloud_optics rrtmgp_sw_cloud_optics.F90 -!! -!! \brief This module contains two routines: The first initializes data and functions -!! needed to compute the shortwave cloud radiative properteis in RRTMGP. The second routine -!! is a ccpp scheme within the "radiation loop", where the shortwave optical prperties -!! (optical-depth, single-scattering albedo, asymmetry parameter) are computed for ALL -!! cloud types visible to RRTMGP. module rrtmgp_sw_cloud_optics use machine, only: kind_phys use mo_rte_kind, only: wl use mo_cloud_optics, only: ty_cloud_optics use mo_optical_props, only: ty_optical_props_2str - use mo_rrtmg_sw_cloud_optics, only: rrtmg_sw_cloud_optics use rrtmgp_sw_gas_optics, only: sw_gas_props use radiation_tools, only: check_error_msg use netcdf @@ -73,20 +63,12 @@ module rrtmgp_sw_cloud_optics radice_uprSW ! Ice particle size lower bound for LUT interpolation contains - -!>\defgroup rrtmgp_sw_cloud_optics_mod GFS RRTMGP-SW Cloud Optics Module -!> \section arg_table_rrtmgp_sw_cloud_optics_init + ! ###################################################################################### + ! SUBROUTINE sw_cloud_optics_init + ! ###################################################################################### +!! \section arg_table_rrtmgp_sw_cloud_optics_init !! \htmlinclude rrtmgp_lw_cloud_optics.html !! -!> \ingroup rrtmgp_sw_cloud_optics -!! -!! RRTMGP relies heavily on derived-data-types, which contain type-bound procedures -!! that are referenced frequently throughout the RRTMGP shortwave scheme. The data needed -!! to compute the shortwave cloud optical properties are initialized here and loaded into -!! the RRTMGP DDT, ty_cloud_optics. -!! -!! \section rrtmgp_sw_cloud_optics_init - ! ###################################################################################### subroutine rrtmgp_sw_cloud_optics_init(doG_cldoptics, doGP_cldoptics_PADE, & doGP_cldoptics_LUT, nrghice, rrtmgp_root_dir, rrtmgp_sw_file_clouds, mpicomm, & mpirank, mpiroot, errmsg, errflg) @@ -405,16 +387,12 @@ subroutine rrtmgp_sw_cloud_optics_init(doG_cldoptics, doGP_cldoptics_PADE, end subroutine rrtmgp_sw_cloud_optics_init -!> \section arg_table_rrtmgp_sw_cloud_optics_run + ! ######################################################################################### + ! SUBROTUINE rrtmgp_sw_cloud_optics_run() + ! ######################################################################################### +!! \section arg_table_rrtmgp_sw_cloud_optics_run !! \htmlinclude rrtmgp_sw_cloud_optics.html !! -!> \ingroup rrtmgp_sw_cloud_optics -!! -!! Compute shortwave optical prperties (optical-depth, single-scattering albedo, -!! asymmetry parameter) for ALL cloud types visible to RRTMGP. -!! -!! \section rrtmgp_sw_gas_optics_run - ! ###################################################################################### subroutine rrtmgp_sw_cloud_optics_run(doSWrad, doG_cldoptics, icliq_sw, icice_sw, & doGP_cldoptics_PADE, doGP_cldoptics_LUT, do_mynnedmf, imfdeepcnv, imfdeepcnv_gf, & imfdeepcnv_samf, nCol, nLev, nDay, nbndsGPsw, idxday, cld_frac, cld_lwp, cld_reliq, & @@ -582,4 +560,10 @@ subroutine rrtmgp_sw_cloud_optics_run(doSWrad, doG_cldoptics, icliq_sw, icice_sw end subroutine rrtmgp_sw_cloud_optics_run + ! ######################################################################################### + ! SUBROTUINE rrtmgp_sw_cloud_optics_finalize() + ! ######################################################################################### + subroutine rrtmgp_sw_cloud_optics_finalize() + end subroutine rrtmgp_sw_cloud_optics_finalize + end module rrtmgp_sw_cloud_optics diff --git a/physics/rrtmgp_sw_cloud_optics.meta b/physics/rrtmgp_sw_cloud_optics.meta deleted file mode 100644 index 064b7cf80..000000000 --- a/physics/rrtmgp_sw_cloud_optics.meta +++ /dev/null @@ -1,393 +0,0 @@ -[ccpp-table-properties] - name = rrtmgp_sw_cloud_optics - type = scheme - dependencies = machine.F,rrtmg_sw_cloud_optics.F90,radiation_tools.F90 - -######################################################################## -[ccpp-arg-table] - name = rrtmgp_sw_cloud_optics_init - type = scheme -[doG_cldoptics] - standard_name = flag_to_calc_lw_cld_optics_using_RRTMG - long_name = logical flag to control cloud optics scheme. - units = flag - dimensions = () - type = logical - intent = in -[doGP_cldoptics_PADE] - standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_PADE - long_name = logical flag to control cloud optics scheme. - units = flag - dimensions = () - type = logical - intent = in -[doGP_cldoptics_LUT] - standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_LUT - long_name = logical flag to control cloud optics scheme. - units = flag - dimensions = () - type = logical - intent = in -[nrghice] - standard_name = number_of_ice_roughness_categories - long_name = number of ice-roughness categories in RRTMGP calculation - units = count - dimensions = () - type = integer - intent = inout -[rrtmgp_root_dir] - standard_name = directory_for_rte_rrtmgp_source_code - long_name = directory for rte+rrtmgp source code - units = none - dimensions = () - type = character - intent = in - kind = len=128 -[rrtmgp_sw_file_clouds] - standard_name = filename_of_rrtmgp_shortwave_cloud_optics_coefficients - long_name = file containing coefficients for RRTMGP SW cloud optics - units = none - dimensions = () - type = character - intent = in - kind = len=128 -[mpirank] - standard_name = mpi_rank - long_name = current MPI rank - units = index - dimensions = () - type = integer - intent = in -[mpiroot] - standard_name = mpi_root - long_name = master MPI rank - units = index - dimensions = () - type = integer - intent = in -[mpicomm] - standard_name = mpi_communicator - long_name = MPI communicator - units = index - dimensions = () - type = integer - intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out -######################################################################## -[ccpp-arg-table] - name = rrtmgp_sw_cloud_optics_run - type = scheme -[doSWrad] - standard_name = flag_for_calling_shortwave_radiation - long_name = logical flags for sw radiation calls - units = flag - dimensions = () - type = logical - intent = in -[ncol] - standard_name = horizontal_loop_extent - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in -[nLev] - standard_name = vertical_layer_dimension - long_name = number of vertical levels - units = count - dimensions = () - type = integer - intent = in -[doG_cldoptics] - standard_name = flag_to_calc_lw_cld_optics_using_RRTMG - long_name = logical flag to control cloud optics scheme. - units = flag - dimensions = () - type = logical - intent = in -[icliq_sw] - standard_name = control_for_shortwave_radiation_liquid_clouds - long_name = sw optical property for liquid clouds - units = flag - dimensions = () - type = integer - intent = in -[icice_sw] - standard_name = flag_for_optical_property_for_ice_clouds_for_shortwave_radiation - long_name = sw optical property for ice clouds - units = flag - dimensions = () - type = integer - intent = in -[doGP_cldoptics_PADE] - standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_PADE - long_name = logical flag to control cloud optics scheme. - units = flag - dimensions = () - type = logical - intent = in -[doGP_cldoptics_LUT] - standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_LUT - long_name = logical flag to control cloud optics scheme. - units = flag - dimensions = () - type = logical - intent = in -[do_mynnedmf] - standard_name = flag_for_mellor_yamada_nakanishi_niino_pbl_scheme - long_name = flag to activate MYNN-EDMF - units = flag - dimensions = () - type = logical - intent = in -[imfdeepcnv] - standard_name = control_for_deep_convection_scheme - long_name = flag for mass-flux deep convection scheme - units = flag - dimensions = () - type = integer - intent = in -[imfdeepcnv_gf] - standard_name = identifier_for_grell_freitas_deep_convection - long_name = flag for Grell-Freitas deep convection scheme - units = flag - dimensions = () - type = integer - intent = in -[imfdeepcnv_samf] - standard_name = identifer_for_scale_aware_mass_flux_deep_convection - long_name = flag for SAMF deep convection scheme - units = flag - dimensions = () - type = integer - intent = in -[cld_frac] - standard_name = total_cloud_fraction - long_name = layer total cloud fraction - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_lwp] - standard_name = cloud_liquid_water_path - long_name = layer cloud liquid water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_reliq] - standard_name = mean_effective_radius_for_liquid_cloud - long_name = mean effective radius for liquid cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_iwp] - standard_name = cloud_ice_water_path - long_name = layer cloud ice water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_reice] - standard_name = mean_effective_radius_for_ice_cloud - long_name = mean effective radius for ice cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_swp] - standard_name = cloud_snow_water_path - long_name = layer cloud snow water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_resnow] - standard_name = mean_effective_radius_for_snow_flake - long_name = mean effective radius for snow cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_rwp] - standard_name = cloud_rain_water_path - long_name = layer cloud rain water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_rerain] - standard_name = mean_effective_radius_for_rain_drop - long_name = mean effective radius for rain cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[precip_frac] - standard_name = precipitation_fraction_by_layer - long_name = precipitation fraction in each layer - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_cnv_lwp] - standard_name = convective_cloud_liquid_water_path - long_name = layer convective cloud liquid water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_cnv_iwp] - standard_name = convective_cloud_ice_water_path - long_name = layer convective cloud ice water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_cnv_reliq] - standard_name = mean_effective_radius_for_liquid_convective_cloud - long_name = mean effective radius for liquid convective cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_cnv_reice] - standard_name = mean_effective_radius_for_ice_convective_cloud - long_name = mean effective radius for ice convective cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_pbl_lwp] - standard_name = MYNN_SGS_cloud_liquid_water_path - long_name = layer convective cloud liquid water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_pbl_iwp] - standard_name = MYNN_SGS_cloud_ice_water_path - long_name = layer convective cloud ice water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_pbl_reliq] - standard_name = mean_effective_radius_for_liquid_MYNN_SGS_cloud - long_name = mean effective radius for liquid MYNN_SGS cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_pbl_reice] - standard_name = mean_effective_radius_for_ice_MYNN_SGS_cloud - long_name = mean effective radius for ice MYNN_SGS cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[nbndsGPsw] - standard_name = number_of_shortwave_bands - long_name = number of sw bands used in RRTMGP - units = count - dimensions = () - type = integer - intent = in -[nday] - standard_name = daytime_points_dimension - long_name = daytime points dimension - units = count - dimensions = () - type = integer - intent = in -[idxday] - standard_name = daytime_points - long_name = daytime points - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = in -[sw_optical_props_cloudsByBand] - standard_name = shortwave_optical_properties_for_cloudy_atmosphere_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = out -[sw_optical_props_cnvcloudsByBand] - standard_name = shortwave_optical_properties_for_convective_cloudy_atmosphere_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = out -[sw_optical_props_precipByBand] - standard_name = shortwave_optical_properties_for_precipitation_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = out -[sw_optical_props_MYNNcloudsByBand] - standard_name = shortwave_optical_properties_for_MYNN_EDMF_PBL_cloudy_atmosphere_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = out -[cldtausw] - standard_name = cloud_optical_depth_layers_at_0p55mu_band - long_name = approx .55mu band layer cloud optical depth - units = none - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out diff --git a/physics/rrtmgp_sw_cloud_sampling.F90 b/physics/rrtmgp_sw_cloud_sampling.F90 deleted file mode 100644 index 238ed7d1c..000000000 --- a/physics/rrtmgp_sw_cloud_sampling.F90 +++ /dev/null @@ -1,174 +0,0 @@ -!> \file rrtmgp_sw_cloud_sampling.F90 -!! -!> \defgroup rrtmgp_sw_cloud_sampling rrtmgp_sw_cloud_sampling.F90 -!! -module rrtmgp_sw_cloud_sampling - use machine, only: kind_phys, kind_dbl_prec - use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp - use mo_optical_props, only: ty_optical_props_2str - use rrtmgp_sampling, only: sampled_mask, draw_samples - use mersenne_twister, only: random_setseed, random_number, random_stat - use radiation_tools, only: check_error_msg - use rrtmgp_sw_gas_optics, only: sw_gas_props - use netcdf - - implicit none - -contains - -!>\defgroup rrtmgp_sw_cloud_sampling_mod GFS RRTMGP-SW Cloud Sampling Module -!> @{ -!> \section arg_table_rrtmgp_sw_cloud_sampling_run -!! \htmlinclude rrtmgp_sw_cloud_sampling.html -!! -!> \ingroup rrtmgp_sw_cloud_sampling -!! -!! \brief This routine performs the McICA cloud-sampling and maps the shortwave cloud- -!! optical properties, defined for each spectral band, to each spectral point (g-point). -!! -!! \section rrtmgp_sw_cloud_sampling_run - subroutine rrtmgp_sw_cloud_sampling_run(doSWrad, nCol, nDay, nLev, idxday, iovr, & - iovr_convcld, iovr_max, iovr_maxrand, iovr_rand, iovr_dcorr, iovr_exp, iovr_exprand, & - isubc_sw,icseed_sw, cld_frac, precip_frac, cloud_overlap_param, precip_overlap_param,& - imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_samf, cnv_cloud_overlap_param, cld_cnv_frac, & - sw_optical_props_cnvcloudsByBand, sw_optical_props_cloudsByBand, & - sw_optical_props_precipByBand, sw_optical_props_clouds, sw_optical_props_cnvclouds, & - sw_optical_props_precip, errmsg, errflg) - - ! Inputs - logical, intent(in) :: & - doSWrad ! Logical flag for shortwave radiation call - integer, intent(in) :: & - nCol, & ! Number of horizontal gridpoints - nDay, & ! Number of daylit points. - nLev, & ! Number of vertical layers - imfdeepcnv, & ! - imfdeepcnv_gf, & ! - imfdeepcnv_samf, & ! - iovr, & ! Choice of cloud-overlap method - iovr_convcld, & ! Choice of convective cloud-overlap method - iovr_max, & ! Flag for maximum cloud overlap method - iovr_maxrand, & ! Flag for maximum-random cloud overlap method - iovr_rand, & ! Flag for random cloud overlap method - iovr_dcorr, & ! Flag for decorrelation-length cloud overlap method - iovr_exp, & ! Flag for exponential cloud overlap method - iovr_exprand, & ! Flag for exponential-random cloud overlap method - isubc_sw - integer,intent(in),dimension(:) :: & - idxday ! Indices for daylit points. - integer,intent(in),dimension(:) :: & - icseed_sw ! auxiliary special cloud related array when module - ! variable isubc_sw=2, it provides permutation seed - ! for each column profile that are used for generating - ! random numbers. when isubc_sw /=2, it will not be used. - real(kind_phys), dimension(:,:),intent(in) :: & - cld_frac, & ! Total cloud fraction by layer - cld_cnv_frac, & ! Convective cloud fraction by layer - precip_frac ! Precipitation fraction by layer - real(kind_phys), dimension(:,:), intent(in) :: & - cloud_overlap_param, & ! Cloud overlap parameter - cnv_cloud_overlap_param, & ! Convective cloud overlap parameter - precip_overlap_param ! Precipitation overlap parameter - type(ty_optical_props_2str),intent(in) :: & - sw_optical_props_cloudsByBand, & ! RRTMGP DDT: Shortwave optical properties in each band (clouds) - sw_optical_props_cnvcloudsByBand,& ! RRTMGP DDT: Shortwave optical properties in each band (convectivecloud) - sw_optical_props_precipByBand ! RRTMGP DDT: Shortwave optical properties in each band (precipitation) - - ! Outputs - character(len=*), intent(out) :: & - errmsg ! Error message - integer, intent(out) :: & - errflg ! Error flag - type(ty_optical_props_2str),intent(out) :: & - sw_optical_props_clouds, & ! RRTMGP DDT: Shortwave optical properties at each spectral point (clouds) - sw_optical_props_cnvclouds, & ! RRTMGP DDT: Shortwave optical properties at each spectral point (convectivecloud) - sw_optical_props_precip ! RRTMGP DDT: Shortwave optical properties at each spectral point (precipitation) - - ! Local variables - integer :: iday,iLay,iGpt - integer,dimension(nday) :: ipseed_sw - type(random_stat) :: rng_stat - real(kind_phys) :: tauloc,asyloc,ssaloc - real(kind_dbl_prec), dimension(sw_gas_props%get_ngpt(),nLev,nday) :: rng3D,rng3D2 - real(kind_dbl_prec), dimension(sw_gas_props%get_ngpt()*nLev) :: rng2D - real(kind_dbl_prec), dimension(sw_gas_props%get_ngpt()) :: rng1D - logical, dimension(nday,nLev,sw_gas_props%get_ngpt()) :: maskMCICA - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (.not. doSWrad) return - if (nDay .gt. 0) then - ! ################################################################################# - ! First sample the clouds... - ! ################################################################################# - - ! Allocate space RRTMGP DDTs [nday,nLev,nGpt] - call check_error_msg('rrtmgp_sw_cloud_sampling_run', & - sw_optical_props_clouds%alloc_2str(nday, nLev, sw_gas_props)) - - ! Change random number seed value for each radiation invocation (isubc_sw =1 or 2). - if(isubc_sw == 1) then ! advance prescribed permutation seed - do iday = 1, nday - ipseed_sw(iday) = sw_gas_props%get_ngpt() + iday - enddo - elseif (isubc_sw == 2) then ! use input array of permutaion seeds - do iday = 1, nday - ipseed_sw(iday) = icseed_sw(idxday(iday)) - enddo - endif - - ! Call RNG. Mersennse Twister accepts 1D array, so loop over columns and collapse along G-points - ! and layers. ([nGpts,nLev,nDayumn]-> [nGpts*nLev]*nDayumn) - do iday=1,nday - call random_setseed(ipseed_sw(iday),rng_stat) - ! Use same rng for each layer - if (iovr == iovr_max) then - call random_number(rng1D,rng_stat) - do iLay=1,nLev - rng3D(:,iLay,iday) = rng1D - enddo - else - do iLay=1,nLev - call random_number(rng1D,rng_stat) - rng3D(:,iLay,iday) = rng1D - enddo - endif - enddo - - ! Cloud overlap. - ! Maximum-random, random, or maximum cloud overlap - if (iovr == iovr_maxrand .or. iovr == iovr_max .or. iovr == iovr_rand) then - call sampled_mask(real(rng3D, kind=kind_phys), cld_frac(idxday(1:nDay),:), maskMCICA) - endif - ! Decorrelation-length overlap - if (iovr == iovr_dcorr) then - do iday=1,nday - call random_setseed(ipseed_sw(iday),rng_stat) - call random_number(rng2D,rng_stat) - rng3D2(:,:,iday) = reshape(source = rng2D,shape=[sw_gas_props%get_ngpt(),nLev]) - enddo - call sampled_mask(real(rng3D, kind=kind_phys), cld_frac(idxday(1:nDay),:), maskMCICA, & - overlap_param = cloud_overlap_param(idxday(1:nDay),1:nLev-1), & - randoms2 = real(rng3D2, kind=kind_phys)) - endif - ! Exponential or exponential-random cloud overlap - if (iovr == iovr_exp .or. iovr == iovr_exprand) then - call sampled_mask(real(rng3D, kind=kind_phys), cld_frac(idxday(1:nDay),:), maskMCICA, & - overlap_param = cloud_overlap_param(idxday(1:nDay),1:nLev-1)) - endif - - ! - ! Sampling. Map band optical depth to each g-point using McICA - ! - call check_error_msg('rrtmgp_sw_cloud_sampling_run_draw_samples', & - draw_samples(maskMCICA, .true., & - sw_optical_props_cloudsByBand, & - sw_optical_props_clouds)) - endif - - end subroutine rrtmgp_sw_cloud_sampling_run - -!> @} -end module rrtmgp_sw_cloud_sampling diff --git a/physics/rrtmgp_sw_cloud_sampling.meta b/physics/rrtmgp_sw_cloud_sampling.meta deleted file mode 100644 index 1415108f8..000000000 --- a/physics/rrtmgp_sw_cloud_sampling.meta +++ /dev/null @@ -1,240 +0,0 @@ -[ccpp-table-properties] - name = rrtmgp_sw_cloud_sampling - type = scheme - dependencies = machine.F,mersenne_twister.f,rrtmgp_sampling.F90,radiation_tools.F90 - -###################################################### -[ccpp-arg-table] - name = rrtmgp_sw_cloud_sampling_run - type = scheme -[doSWrad] - standard_name = flag_for_calling_shortwave_radiation - long_name = logical flags for sw radiation calls - units = flag - dimensions = () - type = logical - intent = in -[imfdeepcnv] - standard_name = control_for_deep_convection_scheme - long_name = flag for mass-flux deep convection scheme - units = flag - dimensions = () - type = integer - intent = in -[imfdeepcnv_gf] - standard_name = identifier_for_grell_freitas_deep_convection - long_name = flag for Grell-Freitas deep convection scheme - units = flag - dimensions = () - type = integer - intent = in -[imfdeepcnv_samf] - standard_name = identifer_for_scale_aware_mass_flux_deep_convection - long_name = flag for SAMF deep convection scheme - units = flag - dimensions = () - type = integer - intent = in -[iovr_convcld] - standard_name = flag_for_convective_cloud_overlap_method_for_radiation - long_name = flag for convective cloud overlap method - units = flag - dimensions = () - type = integer - intent = in -[ncol] - standard_name = horizontal_loop_extent - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in -[nday] - standard_name = daytime_points_dimension - long_name = daytime points dimension - units = count - dimensions = () - type = integer - intent = in -[nLev] - standard_name = vertical_layer_dimension - long_name = number of vertical levels - units = count - dimensions = () - type = integer - intent = in -[isubc_sw] - standard_name = flag_for_sw_clouds_grid_approximation - long_name = flag for sw clouds sub-grid approximation - units = flag - dimensions = () - type = integer - intent = in -[idxday] - standard_name = daytime_points - long_name = daytime points - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = in -[iovr] - standard_name = flag_for_cloud_overlap_method_for_radiation - long_name = max-random overlap clouds - units = flag - dimensions = () - type = integer - intent = in -[iovr_maxrand] - standard_name = flag_for_maximum_random_cloud_overlap_method - long_name = choice of maximum-random cloud overlap method - units = flag - dimensions = () - type = integer - intent = in -[iovr_dcorr] - standard_name = flag_for_decorrelation_length_cloud_overlap_method - long_name = choice of decorrelation-length cloud overlap method - units = flag - dimensions = () - type = integer - intent = in -[iovr_exp] - standard_name = flag_for_exponential_cloud_overlap_method - long_name = choice of exponential cloud overlap method - units = flag - dimensions = () - type = integer - intent = in -[iovr_exprand] - standard_name = flag_for_exponential_random_cloud_overlap_method - long_name = choice of exponential-random cloud overlap method - units = flag - dimensions = () - type = integer - intent = in -[iovr_rand] - standard_name = flag_for_random_cloud_overlap_method - long_name = choice of random cloud overlap method - units = flag - dimensions = () - type = integer - intent = in -[iovr_max] - standard_name = flag_for_maximum_cloud_overlap_method - long_name = choice of maximum cloud overlap method - units = flag - dimensions = () - type = integer - intent = in -[icseed_sw] - standard_name = random_number_seed_for_mcica_shortwave - long_name = seed for random number generation for shortwave radiation - units = none - dimensions = (horizontal_loop_extent) - type = integer - intent = in -[cld_frac] - standard_name = total_cloud_fraction - long_name = layer total cloud fraction - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[precip_frac] - standard_name = precipitation_fraction_by_layer - long_name = precipitation fraction in each layer - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_cnv_frac] - standard_name = convective_cloud_fraction_for_RRTMGP - long_name = layer convective cloud fraction - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cnv_cloud_overlap_param] - standard_name = convective_cloud_overlap_param - long_name = convective cloud overlap parameter - units = km - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cloud_overlap_param] - standard_name = cloud_overlap_param - long_name = cloud overlap parameter - units = km - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[precip_overlap_param] - standard_name = precip_overlap_param - long_name = precipitation overlap parameter - units = km - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[sw_optical_props_cloudsByBand] - standard_name = shortwave_optical_properties_for_cloudy_atmosphere_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = in -[sw_optical_props_cnvcloudsByBand] - standard_name = shortwave_optical_properties_for_convective_cloudy_atmosphere_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = in -[sw_optical_props_precipByBand] - standard_name = shortwave_optical_properties_for_precipitation_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = in -[sw_optical_props_clouds] - standard_name = shortwave_optical_properties_for_cloudy_atmosphere - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = out -[sw_optical_props_cnvclouds] - standard_name = shortwave_optical_properties_for_convective_cloudy_atmosphere - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = out -[sw_optical_props_precip] - standard_name = shortwave_optical_properties_for_precipitation - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = out -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out diff --git a/physics/rrtmgp_sw_gas_optics.meta b/physics/rrtmgp_sw_gas_optics.meta deleted file mode 100644 index 1fdbc946b..000000000 --- a/physics/rrtmgp_sw_gas_optics.meta +++ /dev/null @@ -1,201 +0,0 @@ -[ccpp-table-properties] - name = rrtmgp_sw_gas_optics - type = scheme - dependencies = machine.F,radiation_tools.F90,GFS_rrtmgp_pre.F90,rte-rrtmgp/rrtmgp/mo_gas_optics_rrtmgp.F90,rte-rrtmgp/rte/mo_rte_kind.F90,rte-rrtmgp/rrtmgp/mo_gas_concentrations.F90,rte-rrtmgp/rte/mo_optical_props.F90 - -######################################################################## -[ccpp-arg-table] - name = rrtmgp_sw_gas_optics_init - type = scheme -[rrtmgp_root_dir] - standard_name = directory_for_rte_rrtmgp_source_code - long_name = directory for rte+rrtmgp source code - units = none - dimensions = () - type = character - intent = in - kind = len=128 -[rrtmgp_sw_file_gas] - standard_name = filename_of_rrtmgp_shortwave_k_distribution - long_name = file containing RRTMGP SW k-distribution - units = none - dimensions = () - type = character - intent = in - kind = len=128 -[active_gases_array] - standard_name = list_of_active_gases_used_by_RRTMGP - long_name = list of active gases used by RRTMGP - units = none - dimensions = (number_of_active_gases_used_by_RRTMGP) - type = character - kind = len=* - intent = in -[mpirank] - standard_name = mpi_rank - long_name = current MPI rank - units = index - dimensions = () - type = integer - intent = in -[mpiroot] - standard_name = mpi_root - long_name = master MPI rank - units = index - dimensions = () - type = integer - intent = in -[mpicomm] - standard_name = mpi_communicator - long_name = MPI communicator - units = index - dimensions = () - type = integer - intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - -######################################################################## -[ccpp-arg-table] - name = rrtmgp_sw_gas_optics_run - type = scheme -[doSWrad] - standard_name = flag_for_calling_shortwave_radiation - long_name = flag to calculate SW irradiances - units = flag - dimensions = () - type = logical - intent = in -[ncol] - standard_name = horizontal_loop_extent - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in -[nLev] - standard_name = vertical_layer_dimension - long_name = number of vertical levels - units = count - dimensions = () - type = integer - intent = in -[nday] - standard_name = daytime_points_dimension - long_name = daytime points dimension - units = count - dimensions = () - type = integer - intent = in -[idxday] - standard_name = daytime_points - long_name = daytime points - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = in -[ngptsGPsw] - standard_name = number_of_shortwave_spectral_points - long_name = number of spectral points in RRTMGP SW calculation - units = count - dimensions = () - type = integer - intent = in -[p_lay] - standard_name = air_pressure_at_layer_for_RRTMGP - long_name = air pressure layer - units = Pa - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[p_lev] - standard_name = air_pressure_at_interface_for_RRTMGP - long_name = air pressure level - units = Pa - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = in -[t_lay] - standard_name = air_temperature_at_layer_for_RRTMGP - long_name = air temperature layer - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[t_lev] - standard_name = air_temperature_at_interface_for_RRTMGP - long_name = air temperature level - units = K - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = in -[toa_src_sw] - standard_name = toa_incident_sw_flux_by_spectral_point - long_name = TOA shortwave incident flux at each spectral points - units = W m-2 - dimensions = (horizontal_loop_extent,number_of_shortwave_spectral_points) - type = real - kind = kind_phys - intent = out -[active_gases_array] - standard_name = list_of_active_gases_used_by_RRTMGP - long_name = list of active gases used by RRTMGP - units = none - dimensions = (number_of_active_gases_used_by_RRTMGP) - type = character - kind = len=* - intent = in -[gas_concentrations] - standard_name = Gas_concentrations_for_RRTMGP_suite - long_name = DDT containing gas concentrations for RRTMGP radiation scheme - units = DDT - dimensions = () - type = ty_gas_concs - intent = inout -[solcon] - standard_name = solar_constant - long_name = solar constant - units = W m-2 - dimensions = () - type = real - kind = kind_phys - intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out -[sw_optical_props_clrsky] - standard_name = shortwave_optical_properties_for_clear_sky - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = out diff --git a/physics/rrtmgp_sw_main.F90 b/physics/rrtmgp_sw_main.F90 index 66f4b7553..a10f899e0 100644 --- a/physics/rrtmgp_sw_main.F90 +++ b/physics/rrtmgp_sw_main.F90 @@ -59,14 +59,13 @@ subroutine rrtmgp_sw_main_init(rrtmgp_root_dir, rrtmgp_sw_file_gas, mpicomm, mpi errflg = 0 ! RRTMGP shortwave gas-optics (k-distribution) initialization - call rrtmgp_sw_gas_optics_init(rrtmgp_root_dir, rrtmgp_sw_file_gas, mpicomm, mpirank, & - mpiroot, active_gases_array, errmsg, errflg) + call rrtmgp_sw_gas_optics_init(rrtmgp_root_dir, rrtmgp_sw_file_gas, active_gases_array, & + mpicomm, mpirank, mpiroot, errmsg, errflg) ! RRTMGP shortwave cloud-optics initialization - call rrtmgp_sw_cloud_optics_init(nrghice, mpicomm, mpirank, mpiroot, doG_cldoptics, & - doGP_cldoptics_PADE, doGP_cldoptics_LUT, rrtmgp_root_dir, rrtmgp_sw_file_clouds, & - errmsg, errflg) - + call rrtmgp_sw_cloud_optics_init(doG_cldoptics, doGP_cldoptics_PADE, doGP_cldoptics_LUT,& + nrghice, rrtmgp_root_dir, rrtmgp_sw_file_clouds, mpicomm, mpirank, mpiroot, errmsg,& + errflg) end subroutine rrtmgp_sw_main_init ! ######################################################################################### @@ -76,28 +75,30 @@ end subroutine rrtmgp_sw_main_init !! \htmlinclude rrtmgp_sw_main_run.html !! subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_sgs_pbl, & - nCol, nDay, nLay, idx, icseed_sw, iovr, iovr_convcld, iovr_max, & - iovr_maxrand, iovr_rand, iovr_dcorr, iovr_exp, iovr_exprand, isubc_sw, iSFC, & - sfc_alb_nir_dir, sfc_alb_nir_dif, sfc_alb_uvvis_dir, sfc_alb_uvvis_dif, coszen, & + nCol, nDay, nLay, nGases, rrtmgp_phys_blksz, idx, icseed_sw, iovr, iovr_convcld, & + iovr_max, iovr_maxrand, iovr_rand, iovr_dcorr, iovr_exp, iovr_exprand, isubc_sw, & + iSFC, sfc_alb_nir_dir, sfc_alb_nir_dif, sfc_alb_uvvis_dir, sfc_alb_uvvis_dif, coszen,& p_lay, p_lev, t_lay, t_lev, vmr_o2, vmr_h2o, vmr_o3, vmr_ch4, vmr_n2o, vmr_co2, & cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, & cld_rerain, precip_frac, cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, cld_cnv_reice, & cld_pbl_lwp, cld_pbl_reliq, cld_pbl_iwp, cld_pbl_reice, cloud_overlap_param, & - active_gases_array, sw_optical_props_aerosol, gas_concentrations, solcon, scmpsw, & + active_gases_array, sw_optical_props_aerosol, solcon, scmpsw, & fluxswUP_allsky, fluxswDOWN_allsky, fluxswUP_clrsky, fluxswDOWN_clrsky, cldtausw, & errmsg, errflg) ! Inputs logical, intent(in) :: & - doSWrad, & ! Flag to calculate SW irradiances - doSWclrsky, & ! Flag to compute clear-sky fluxes (diagnostic) - top_at_1, & ! Vertical ordering flag - doGP_sgs_pbl, & ! Flag for sgs MYNN-EDMF PBL cloud scheme - doGP_sgs_cnv ! Flag for sgs convective cloud scheme + doSWrad, & ! Flag to perform shortwave calculation + doSWclrsky, & ! Flag to compute clear-sky fluxes + top_at_1, & ! Flag for vertical ordering convention + doGP_sgs_pbl, & ! Flag to include sgs PBL clouds + doGP_sgs_cnv ! Flag to include sgs convective clouds integer,intent(in) :: & nCol, & ! Number of horizontal points nDay, & ! Number of daytime points nLay, & ! Number of vertical grid points. + nGases, & ! Number of active gases + rrtmgp_phys_blksz, & ! Number of horizontal points to process at once. iovr, & ! Choice of cloud-overlap method iovr_convcld, & ! Choice of convective cloud-overlap iovr_max, & ! Flag for maximum cloud overlap method @@ -142,72 +143,66 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ cld_cnv_reliq, & ! Effective radius for convective liquid cloud-particles cld_cnv_iwp, & ! Water path for convective ice cloud-particles cld_cnv_reice, & ! Effective radius for convective ice cloud-particles - cld_pbl_lwp, & ! Water path for SGS PBL liquid cloud-particles - cld_pbl_reliq, & ! Effective radius for SGS PBL liquid cloud-particles - cld_pbl_iwp, & ! Water path for SGS PBL ice cloud-particles - cld_pbl_reice, & ! Effective radius for SGS PBL ice cloud-particles + cld_pbl_lwp, & ! Water path for PBL liquid cloud-particles + cld_pbl_reliq, & ! Effective radius for PBL liquid cloud-particles + cld_pbl_iwp, & ! Water path for PBL ice cloud-particles + cld_pbl_reice, & ! Effective radius for PBL ice cloud-particles cloud_overlap_param ! character(len=*), dimension(:), intent(in) :: & active_gases_array ! List of active gases from namelist as array type(ty_optical_props_2str),intent(in) :: & sw_optical_props_aerosol ! RRTMGP DDT: Shortwave aerosol optical properties (tau,ssa,g) - type(ty_gas_concs), intent(in) :: & - gas_concentrations ! RRTMGP DDT: gas concentrations real(kind_phys), intent(in) :: & solcon ! Solar constant ! Outputs character(len=*), intent(out) :: & - errmsg ! CCPP error message + errmsg ! CCPP error message integer, intent(out) :: & - errflg ! CCPP error flag + errflg ! CCPP error flag real(kind_phys), dimension(:,:), intent(out) :: & - cldtausw ! Approx 10.mu band layer cloud optical depth + cldtausw ! Approx 10.mu band layer cloud optical depth real(kind_phys), dimension(:,:), intent(inout) :: & - fluxswUP_allsky, & ! RRTMGP upward all-sky flux profiles (W/m2) - fluxswDOWN_allsky, & ! RRTMGP downward all-sky flux profiles (W/m2) - fluxswUP_clrsky, & ! RRTMGP upward clear-sky flux profiles (W/m2) - fluxswDOWN_clrsky ! RRTMGP downward clear-sky flux profiles (W/m2) + fluxswUP_allsky, & ! RRTMGP upward all-sky flux profiles (W/m2) + fluxswDOWN_allsky, & ! RRTMGP downward all-sky flux profiles (W/m2) + fluxswUP_clrsky, & ! RRTMGP upward clear-sky flux profiles (W/m2) + fluxswDOWN_clrsky ! RRTMGP downward clear-sky flux profiles (W/m2) type(cmpfsw_type), dimension(:), intent(inout) :: & - scmpsw ! 2D surface fluxes, components: - ! uvbfc - total sky downward uv-b flux (W/m2) - ! uvbf0 - clear sky downward uv-b flux (W/m2) - ! nirbm - downward nir direct beam flux (W/m2) - ! nirdf - downward nir diffused flux (W/m2) - ! visbm - downward uv+vis direct beam flux (W/m2) - ! visdf - downward uv+vis diffused flux (W/m2) + scmpsw ! 2D surface fluxes, components: + ! uvbfc - total sky downward uv-b flux (W/m2) + ! uvbf0 - clear sky downward uv-b flux (W/m2) + ! nirbm - downward nir direct beam flux (W/m2) + ! nirdf - downward nir diffused flux (W/m2) + ! visbm - downward uv+vis direct beam flux (W/m2) + ! visdf - downward uv+vis diffused flux (W/m2) ! Local variables - type(ty_gas_concs) :: & - gas_concs ! RRTMGP DDT: trace gas concentrations (vmr) - type(ty_optical_props_2str) :: & - sw_optical_props_clrsky, & ! RRTMGP DDT: Shortwave clear-sky radiative properties - sw_optical_props_aerosol_local, & ! RRTMGP DDT: Shortave aerosol radiative properties - sw_optical_props_cloudsByBand, & ! RRTMGP DDT: Shortwave optical properties in each band (clouds) - sw_optical_props_cnvcloudsByBand, & ! RRTMGP DDT: Shortwave optical properties in each band (convective cloud) - sw_optical_props_pblcloudsByBand, & ! RRTMGP DDT: Shortwave optical properties in each band (PBL cloud) - sw_optical_props_precipByBand, & ! RRTMGP DDT: Shortwave optical properties in each band (precipitation) - sw_optical_props_clouds ! RRTMGP DDT: Shortwave optical properties in each band (sampled clouds) - type(ty_fluxes_byband) :: & - flux_allsky, & ! RRTMGP DDT: All-sky flux (W/m2) - flux_clrsky ! RRTMGP DDT: Clear-sky flux (W/m2) - real(kind_phys) :: & - tau_rain, tau_snow, ssa_rain, ssa_snow, asy_rain, asy_snow, & - tau_prec, asy_prec, ssa_prec, asyw, ssaw, za1, za2 + type(cmpfsw_type), dimension(rrtmgp_phys_blksz) :: scmpsw_clrsky, scmpsw_allsky + type(ty_gas_concs) :: gas_concs + type(ty_optical_props_2str) :: sw_optical_props_accum, sw_optical_props_aerosol_local, & + sw_optical_props_cloudsByBand, sw_optical_props_cnvcloudsByBand, & + sw_optical_props_pblcloudsByBand, sw_optical_props_precipByBand, & + sw_optical_props_clouds + type(ty_fluxes_byband) :: flux_allsky, flux_clrsky + real(kind_phys) :: tau_rain, tau_snow, ssa_rain, ssa_snow, asy_rain, asy_snow, & + tau_prec, asy_prec, ssa_prec, asyw, ssaw, za1, za2, flux_dir, flux_dif real(kind_phys), dimension(sw_gas_props%get_ngpt()) :: rng1D - real(kind_phys), dimension(sw_gas_props%get_ngpt(),nLay,1) :: rng3D,rng3D2 + real(kind_phys), dimension(sw_gas_props%get_ngpt(),nLay,rrtmgp_phys_blksz) :: rng3D,rng3D2 real(kind_phys), dimension(sw_gas_props%get_ngpt()*nLay) :: rng2D - logical, dimension(1,nLay,sw_gas_props%get_ngpt()) :: maskMCICA - real(kind_phys), dimension(sw_gas_props%get_nband(),1) :: & + logical, dimension(rrtmgp_phys_blksz,nLay,sw_gas_props%get_ngpt()) :: maskMCICA + real(kind_phys), dimension(sw_gas_props%get_nband(),rrtmgp_phys_blksz) :: & sfc_alb_dir, sfc_alb_dif - real(kind_phys), dimension(1,nLay+1,sw_gas_props%get_nband()),target :: & - fluxSW_up_allsky, fluxSW_up_clrsky, fluxSW_dn_allsky, fluxSW_dn_clrsky, fluxSW_dn_dir_allsky - integer :: iBand, ibd, iCol, iGas, iLay, ipseed_sw, ix + real(kind_phys), dimension(rrtmgp_phys_blksz,nLay+1,sw_gas_props%get_nband()),target :: & + fluxSW_up_allsky, fluxSW_up_clrsky, fluxSW_dn_dir_clrsky, fluxSW_dn_allsky, & + fluxSW_dn_clrsky, fluxSW_dn_dir_allsky + integer :: iBand, ibd, ibd_uv, iCol, iGas, iLay, ix, ix2, iblck + integer, dimension(rrtmgp_phys_blksz) :: ipseed_sw type(random_stat) :: rng_stat real(kind_phys), dimension(2,sw_gas_props%get_nband()) :: bandlimits - real(kind_phys), dimension(2), parameter :: nIR_uvvis_bnd = (/12850,16000/) - real(kind_phys), dimension(1,sw_gas_props%get_ngpt()) :: toa_src_sw - real(kind_phys), dimension(nCol, nLay, gas_concentrations%get_num_gases()) :: vmrTemp + real(kind_phys), dimension(2), parameter :: & + nIR_uvvis_bnd = (/12850,16000/), & + uvb_bnd = (/29000,38000/) + real(kind_phys), dimension(rrtmgp_phys_blksz,sw_gas_props%get_ngpt()) :: toa_src_sw ! Initialize CCPP error handling variables errmsg = '' @@ -216,51 +211,45 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ if (.not. doSWrad) return if (nDay .gt. 0) then + + bandlimits = sw_gas_props%get_band_lims_wavenumber() ! ###################################################################################### ! ! Allocate/initialize RRTMGP DDT's ! ! ###################################################################################### - bandlimits = sw_gas_props%get_band_lims_wavenumber() - ! + ! ty_gas_concs - ! - gas_concs%ncol = 1 + gas_concs%ncol = rrtmgp_phys_blksz gas_concs%nlay = nLay - allocate(gas_concs%gas_name(gas_concentrations%get_num_gases())) - allocate(gas_concs%concs(gas_concentrations%get_num_gases())) - do iGas=1,gas_concentrations%get_num_gases() - allocate(gas_concs%concs(iGas)%conc(1, nLay)) + allocate(gas_concs%gas_name(nGases)) + allocate(gas_concs%concs(nGases)) + do iGas=1,nGases + allocate(gas_concs%concs(iGas)%conc(rrtmgp_phys_blksz, nLay)) enddo gas_concs%gas_name(:) = active_gases_array(:) - do iGas=1,gas_concentrations%get_num_gases() - call check_error_msg('rrtmgp_sw_main_get_vmr',& - gas_concentrations%get_vmr(trim(gas_concentrations%gas_name(iGas)),vmrTemp(:,:,iGas))) - enddo - ! + ! ty_optical_props - ! - call check_error_msg('rrtmgp_sw_main_gas_optics_init',& - sw_optical_props_clrsky%alloc_2str(1, nLay, sw_gas_props)) + call check_error_msg('rrtmgp_sw_main_accumulated_optics_init',& + sw_optical_props_accum%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props)) call check_error_msg('rrtmgp_sw_main_cloud_optics_init',& - sw_optical_props_cloudsByBand%alloc_2str(1, nLay, sw_gas_props%get_band_lims_wavenumber())) + sw_optical_props_cloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) call check_error_msg('rrtmgp_sw_main_precip_optics_init',& - sw_optical_props_precipByBand%alloc_2str(1, nLay, sw_gas_props%get_band_lims_wavenumber())) + sw_optical_props_precipByBand%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) call check_error_msg('rrtmgp_sw_mian_cloud_sampling_init', & - sw_optical_props_clouds%alloc_2str(1, nLay, sw_gas_props)) + sw_optical_props_clouds%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props)) call check_error_msg('rrtmgp_sw_main_aerosol_optics_init',& - sw_optical_props_aerosol_local%alloc_2str(1, nLay, sw_gas_props%get_band_lims_wavenumber())) + sw_optical_props_aerosol_local%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) if (doGP_sgs_cnv) then call check_error_msg('rrtmgp_sw_main_cnv_cloud_optics_init',& - sw_optical_props_cnvcloudsByBand%alloc_2str(1, nLay, sw_gas_props%get_band_lims_wavenumber())) + sw_optical_props_cnvcloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) endif if (doGP_sgs_pbl) then call check_error_msg('rrtmgp_sw_main_pbl_cloud_optics_init',& - sw_optical_props_pblcloudsByBand%alloc_2str(1, nLay, sw_gas_props%get_band_lims_wavenumber())) + sw_optical_props_pblcloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) endif - ! + ! ty_fluxes_byband - ! flux_allsky%bnd_flux_up => fluxSW_up_allsky flux_allsky%bnd_flux_dn => fluxSW_dn_allsky flux_allsky%bnd_flux_dn_dir => fluxSW_dn_dir_allsky @@ -268,30 +257,31 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ flux_clrsky%bnd_flux_dn => fluxSW_dn_clrsky ! Loop over all (daylit) columns... - do iCol=1,nDay - ix = idx(iCol) - + do iCol=1,nDay,rrtmgp_phys_blksz + ix = idx(iCol) + ix2 = idx(iCol + rrtmgp_phys_blksz - 1) + ! Initialize/reset - fluxSW_up_allsky = 0._kind_phys - fluxSW_dn_allsky = 0._kind_phys - fluxSW_dn_dir_allsky = 0._kind_phys - fluxSW_up_clrsky = 0._kind_phys - fluxSW_dn_clrsky = 0._kind_phys - sw_optical_props_clouds%tau = 0._kind_phys - sw_optical_props_clouds%ssa = 0._kind_phys - sw_optical_props_clouds%g = 0._kind_phys - sw_optical_props_clrsky%tau = 0._kind_phys - sw_optical_props_clrsky%ssa = 0._kind_phys - sw_optical_props_clrsky%g = 0._kind_phys - sw_optical_props_cloudsByBand%tau = 0._kind_phys - sw_optical_props_cloudsByBand%ssa = 0._kind_phys - sw_optical_props_cloudsByBand%g = 0._kind_phys - sw_optical_props_precipByBand%tau = 0._kind_phys - sw_optical_props_precipByBand%ssa = 0._kind_phys - sw_optical_props_precipByBand%g = 0._kind_phys - sw_optical_props_aerosol_local%tau = 0._kind_phys - sw_optical_props_aerosol_local%ssa = 0._kind_phys - sw_optical_props_aerosol_local%g = 0._kind_phys + fluxSW_up_allsky = 0._kind_phys + fluxSW_dn_allsky = 0._kind_phys + fluxSW_dn_dir_allsky = 0._kind_phys + fluxSW_up_clrsky = 0._kind_phys + fluxSW_dn_clrsky = 0._kind_phys + sw_optical_props_clouds%tau = 0._kind_phys + sw_optical_props_clouds%ssa = 0._kind_phys + sw_optical_props_clouds%g = 0._kind_phys + sw_optical_props_accum%tau = 0._kind_phys + sw_optical_props_accum%ssa = 0._kind_phys + sw_optical_props_accum%g = 0._kind_phys + sw_optical_props_cloudsByBand%tau = 0._kind_phys + sw_optical_props_cloudsByBand%ssa = 0._kind_phys + sw_optical_props_cloudsByBand%g = 0._kind_phys + sw_optical_props_precipByBand%tau = 0._kind_phys + sw_optical_props_precipByBand%ssa = 0._kind_phys + sw_optical_props_precipByBand%g = 0._kind_phys + sw_optical_props_aerosol_local%tau = 0._kind_phys + sw_optical_props_aerosol_local%ssa = 0._kind_phys + sw_optical_props_aerosol_local%g = 0._kind_phys if (doGP_sgs_cnv) then sw_optical_props_cnvcloudsByBand%tau = 0._kind_phys sw_optical_props_cnvcloudsByBand%ssa = 0._kind_phys @@ -302,17 +292,20 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ sw_optical_props_pblcloudsByBand%ssa = 0._kind_phys sw_optical_props_pblcloudsByBand%g = 0._kind_phys endif - + scmpsw_clrsky= cmpfsw_type( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 ) + scmpsw_allsky= cmpfsw_type( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 ) + ! ################################################################################### ! ! Set gas-concentrations ! ! ################################################################################### - ! Subset the gas concentrations. - do iGas=1,gas_concentrations%get_num_gases() - call check_error_msg('rrtmgp_sw_gas_optics_run_set_vmr',& - gas_concs%set_vmr(trim(gas_concentrations%gas_name(iGas)),vmrTemp(ix,:,iGas))) - enddo + gas_concs%concs(istr_o2)%conc(:,:) = vmr_o2(ix:ix2,:) + gas_concs%concs(istr_co2)%conc(:,:) = vmr_co2(ix:ix2,:) + gas_concs%concs(istr_ch4)%conc(:,:) = vmr_ch4(ix:ix2,:) + gas_concs%concs(istr_n2o)%conc(:,:) = vmr_n2o(ix:ix2,:) + gas_concs%concs(istr_h2o)%conc(:,:) = vmr_h2o(ix:ix2,:) + gas_concs%concs(istr_o3)%conc(:,:) = vmr_o3(ix:ix2,:) ! ################################################################################### ! @@ -323,243 +316,325 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ ! For overlapping band, average near-IR and us-vis albedos. ! ! ################################################################################### - do iBand=1,sw_gas_props%get_nband() - if (bandlimits(1,iBand) .lt. nIR_uvvis_bnd(1)) then - sfc_alb_dir(iBand,1) = sfc_alb_nir_dir(ix) - sfc_alb_dif(iBand,1) = sfc_alb_nir_dif(ix) - endif - if (bandlimits(1,iBand) .eq. nIR_uvvis_bnd(1)) then - sfc_alb_dir(iBand,1) = 0.5_kind_phys*(sfc_alb_nir_dir(ix) + sfc_alb_uvvis_dir(ix)) - sfc_alb_dif(iBand,1) = 0.5_kind_phys*(sfc_alb_nir_dif(ix) + sfc_alb_uvvis_dif(ix)) - ibd = iBand - endif - if (bandlimits(1,iBand) .ge. nIR_uvvis_bnd(2)) then - sfc_alb_dir(iBand,1) = sfc_alb_uvvis_dir(ix) - sfc_alb_dif(iBand,1) = sfc_alb_uvvis_dif(ix) - endif + do iblck = 1, rrtmgp_phys_blksz + do iBand=1,sw_gas_props%get_nband() + if (bandlimits(1,iBand) .lt. nIR_uvvis_bnd(1)) then + sfc_alb_dir(iBand,iblck) = sfc_alb_nir_dir(ix+iblck-1) + sfc_alb_dif(iBand,iblck) = sfc_alb_nir_dif(ix+iblck-1) + endif + if (bandlimits(1,iBand) .eq. nIR_uvvis_bnd(1)) then + sfc_alb_dir(iBand,iblck) = 0.5_kind_phys*(sfc_alb_nir_dir(ix+iblck-1) + sfc_alb_uvvis_dir(ix+iblck-1)) + sfc_alb_dif(iBand,iblck) = 0.5_kind_phys*(sfc_alb_nir_dif(ix+iblck-1) + sfc_alb_uvvis_dif(ix+iblck-1)) + ibd = iBand + endif + if (bandlimits(1,iBand) .ge. nIR_uvvis_bnd(2)) then + sfc_alb_dir(iBand,iblck) = sfc_alb_uvvis_dir(ix+iblck-1) + sfc_alb_dif(iBand,iblck) = sfc_alb_uvvis_dif(ix+iblck-1) + endif + if (bandlimits(1,iBand) .eq. uvb_bnd(1)) ibd_uv = iBand + enddo enddo ! ################################################################################### ! - ! Gas-optics + ! Compute gas-optics... ! ! ################################################################################### call check_error_msg('rrtmgp_sw_main_gas_optics',sw_gas_props%gas_optics(& - p_lay(ix:ix,:), & ! IN - Pressure @ layer-centers (Pa) - p_lev(ix:ix,:), & ! IN - Pressure @ layer-interfaces (Pa) - t_lay(ix:ix,:), & ! IN - Temperature @ layer-centers (K) + p_lay(ix:ix2,:), & ! IN - Pressure @ layer-centers (Pa) + p_lev(ix:ix2,:), & ! IN - Pressure @ layer-interfaces (Pa) + t_lay(ix:ix2,:), & ! IN - Temperature @ layer-centers (K) gas_concs, & ! IN - RRTMGP DDT: trace gas volumne mixing-ratios - sw_optical_props_clrsky, & ! OUT - RRTMGP DDT: Shortwave optical properties, by + sw_optical_props_accum, & ! OUT - RRTMGP DDT: Shortwave optical properties, by ! spectral point (tau,ssa,g) toa_src_sw)) ! OUT - TOA incident shortwave radiation (spectral) - ! Scale incident flux - toa_src_sw(1,:) = toa_src_sw(1,:)*solcon / sum(toa_src_sw(1,:)) + do iblck = 1, rrtmgp_phys_blksz + toa_src_sw(iblck,:) = toa_src_sw(iblck,:)*solcon / sum(toa_src_sw(iblck,:)) + enddo + ! ################################################################################### ! - ! Cloud-optics + ! Compute optics for cloud(s) and precipitation, sample clouds... ! ! ################################################################################### - call check_error_msg('rrtmgp_sw_main_cloud_optics',sw_cloud_props%cloud_optics(& - cld_lwp(ix:ix,:), & ! IN - Cloud liquid water path - cld_iwp(ix:ix,:), & ! IN - Cloud ice water path - cld_reliq(ix:ix,:), & ! IN - Cloud liquid effective radius - cld_reice(ix:ix,:), & ! IN - Cloud ice effective radius - sw_optical_props_cloudsByBand)) ! OUT - RRTMGP DDT: Shortwave optical properties, - ! in each band (tau,ssa,g) - cldtausw(ix,:) = sw_optical_props_cloudsByBand%tau(1,:,11) + if (any(cld_frac(ix:ix2,:) .gt. 1.e-6_kind_phys)) then + ! Gridmean/mp-clouds + call check_error_msg('rrtmgp_sw_main_cloud_optics',sw_cloud_props%cloud_optics(& + cld_lwp(ix:ix2,:), & ! IN - Cloud liquid water path + cld_iwp(ix:ix2,:), & ! IN - Cloud ice water path + cld_reliq(ix:ix2,:), & ! IN - Cloud liquid effective radius + cld_reice(ix:ix2,:), & ! IN - Cloud ice effective radius + sw_optical_props_cloudsByBand)) ! OUT - RRTMGP DDT: Shortwave optical properties, + ! in each band (tau,ssa,g) + cldtausw(ix:ix2,:) = sw_optical_props_cloudsByBand%tau(:,:,11) - ! Convective cloud-optics? - if (doGP_sgs_cnv) then - call check_error_msg('rrtmgp_sw_main_cnv_cloud_optics',sw_cloud_props%cloud_optics(& - cld_cnv_lwp(ix:ix,:), & ! IN - Convective cloud liquid water path (g/m2) - cld_cnv_iwp(ix:ix,:), & ! IN - Convective cloud ice water path (g/m2) - cld_cnv_reliq(ix:ix,:), & ! IN - Convective cloud liquid effective radius (microns) - cld_cnv_reice(ix:ix,:), & ! IN - Convective cloud ice effective radius (microns) - sw_optical_props_cnvcloudsByBand)) ! OUT - RRTMGP DDT containing convective cloud radiative properties + ! Include convective clouds? + if (doGP_sgs_cnv) then + call check_error_msg('rrtmgp_sw_main_cnv_cloud_optics',sw_cloud_props%cloud_optics(& + cld_cnv_lwp(ix:ix2,:), & ! IN - Convective cloud liquid water path (g/m2) + cld_cnv_iwp(ix:ix2,:), & ! IN - Convective cloud ice water path (g/m2) + cld_cnv_reliq(ix:ix2,:), & ! IN - Convective cloud liquid effective radius (microns) + cld_cnv_reice(ix:ix2,:), & ! IN - Convective cloud ice effective radius (microns) + sw_optical_props_cnvcloudsByBand)) ! OUT - RRTMGP DDT containing convective cloud radiative properties ! in each band - !call check_error_msg('rrtmgp_sw_main_increment_cnvclouds_to_clouds',& - ! sw_optical_props_cnvcloudsByBand%increment(sw_optical_props_cloudsByBand)) - endif + ! + call check_error_msg('rrtmgp_sw_main_increment_cnvclouds_to_clouds',& + sw_optical_props_cnvcloudsByBand%increment(sw_optical_props_cloudsByBand)) + endif - ! MYNN PBL cloud-optics? - if (doGP_sgs_pbl) then - call check_error_msg('rrtmgp_sw_main_pbl_cloud_optics',sw_cloud_props%cloud_optics(& - cld_pbl_lwp(ix:ix,:), & ! IN - MYNN-EDMF PBL cloud liquid water path (g/m2) - cld_pbl_iwp(ix:ix,:), & ! IN - MYNN-EDMF PBL cloud ice water path (g/m2) - cld_pbl_reliq(ix:ix,:), & ! IN - MYNN-EDMF PBL cloud liquid effective radius (microns) - cld_pbl_reice(ix:ix,:), & ! IN - MYNN-EDMF PBL cloud ice effective radius (microns) - sw_optical_props_pblcloudsByBand)) ! OUT - RRTMGP DDT containing MYNN-EDMF PBL cloud radiative properties + ! Include PBL clouds? + if (doGP_sgs_pbl) then + call check_error_msg('rrtmgp_sw_main_pbl_cloud_optics',sw_cloud_props%cloud_optics(& + cld_pbl_lwp(ix:ix2,:), & ! IN - PBL cloud liquid water path (g/m2) + cld_pbl_iwp(ix:ix2,:), & ! IN - PBL cloud ice water path (g/m2) + cld_pbl_reliq(ix:ix2,:), & ! IN - PBL cloud liquid effective radius (microns) + cld_pbl_reice(ix:ix2,:), & ! IN - PBL cloud ice effective radius (microns) + sw_optical_props_pblcloudsByBand)) ! OUT - RRTMGP DDT containing PBL cloud radiative properties ! in each band - !call check_error_msg('rrtmgp_sw_main_increment_pblclouds_to_clouds',& - ! sw_optical_props_pblcloudsByBand%increment(sw_optical_props_cloudsByBand)) - endif + ! + call check_error_msg('rrtmgp_sw_main_increment_pblclouds_to_clouds',& + sw_optical_props_pblcloudsByBand%increment(sw_optical_props_cloudsByBand)) + endif - ! Cloud precipitation optics: rain and snow(+groupel) - do iLay=1,nLay - if (cld_frac(ix,iLay) .gt. 1.e-12_kind_phys) then - ! Rain/Snow optical depth (No band dependence) - tau_rain = cld_rwp(ix,iLay)*a0r - if (cld_swp(ix,iLay) .gt. 0. .and. cld_resnow(ix,iLay) .gt. 10._kind_phys) then - tau_snow = cld_swp(ix,iLay)*1.09087*(a0s + a1s/(1.0315*cld_resnow(ix,iLay))) ! fu's formula + ! Cloud precipitation optics: rain and snow(+groupel) + do iblck = 1, rrtmgp_phys_blksz + do iLay=1,nLay + if (cld_frac(ix+iblck-1,iLay) .gt. 1.e-12_kind_phys) then + ! Rain/Snow optical depth (No band dependence) + tau_rain = cld_rwp(ix+iblck-1,iLay)*a0r + if (cld_swp(ix+iblck-1,iLay) .gt. 0. .and. cld_resnow(ix+iblck-1,iLay) .gt. 10._kind_phys) then + tau_snow = cld_swp(ix+iblck-1,iLay)*1.09087*(a0s + a1s/(1.0315*cld_resnow(ix+iblck-1,iLay))) ! fu's formula + else + tau_snow = 0._kind_phys + endif + + ! Rain/Snow single-scattering albedo and asymmetry (Band dependent) + do iBand=1,sw_gas_props%get_nband() + ! By species + ssa_rain = tau_rain*(1.-b0r(iBand)) + asy_rain = ssa_rain*c0r(iBand) + ssa_snow = tau_snow*(1.-(b0s(iBand)+b1s(iBand)*1.0315*cld_resnow(ix+iblck-1,iLay))) + asy_snow = ssa_snow*c0s(iBand) + ! Combine + tau_prec = max(1.e-12_kind_phys, tau_rain + tau_snow) + ssa_prec = max(1.e-12_kind_phys, ssa_rain + ssa_snow) + asy_prec = max(1.e-12_kind_phys, asy_rain + asy_snow) + asyw = asy_prec/max(1.e-12_kind_phys, ssa_prec) + ssaw = min(1._kind_phys-0.000001, ssa_prec/tau_prec) + za1 = asyw * asyw + za2 = ssaw * za1 + sw_optical_props_precipByBand%tau(iblck,iLay,iBand) = (1._kind_phys - za2) * tau_prec + sw_optical_props_precipByBand%ssa(iblck,iLay,iBand) = (ssaw - za2) / (1._kind_phys - za2) + sw_optical_props_precipByBand%g(iblck,iLay,iBand) = asyw/(1+asyw) + enddo + endif + enddo + enddo + ! + call check_error_msg('rrtmgp_sw_main_increment_precip_to_clouds',& + sw_optical_props_precipByBand%increment(sw_optical_props_cloudsByBand)) + + ! ################################################################################### + ! + ! Cloud-sampling + ! + ! ################################################################################### + ! Change random number seed value for each radiation invocation (isubc_sw =1 or 2). + if(isubc_sw == 1) then ! advance prescribed permutation seed + do iblck = 1, rrtmgp_phys_blksz + ipseed_sw(iblck) = sw_gas_props%get_ngpt() + iCol + iblck - 1 + enddo + elseif (isubc_sw == 2) then ! use input array of permutaion seeds + do iblck = 1, rrtmgp_phys_blksz + ipseed_sw(iblck) = icseed_sw(ix+iblck-1) + enddo + endif + + ! Call RNG + do iblck = 1, rrtmgp_phys_blksz + call random_setseed(ipseed_sw(iblck),rng_stat) + ! Use same rng for each layer + if (iovr == iovr_max) then + call random_number(rng1D,rng_stat) + do iLay=1,nLay + rng3D(:,iLay,iblck) = rng1D + enddo else - tau_snow = 0._kind_phys + do iLay=1,nLay + call random_number(rng1D,rng_stat) + rng3D(:,iLay,iblck) = rng1D + enddo endif - - ! Rain/Snow single-scattering albedo and asymmetry (Band dependent) - do iBand=1,sw_gas_props%get_nband() - ! By species - ssa_rain = tau_rain*(1.-b0r(iBand)) - asy_rain = ssa_rain*c0r(iBand) - ssa_snow = tau_snow*(1.-(b0s(iBand)+b1s(iBand)*1.0315*cld_resnow(ix,iLay))) - asy_snow = ssa_snow*c0s(iBand) - ! Combine - tau_prec = max(1.e-12_kind_phys, tau_rain + tau_snow) - ssa_prec = max(1.e-12_kind_phys, ssa_rain + ssa_snow) - asy_prec = max(1.e-12_kind_phys, asy_rain + asy_snow) - asyw = asy_prec/max(1.e-12_kind_phys, ssa_prec) - ssaw = min(1._kind_phys-0.000001, ssa_prec/tau_prec) - za1 = asyw * asyw - za2 = ssaw * za1 - sw_optical_props_precipByBand%tau(1,iLay,iBand) = (1._kind_phys - za2) * tau_prec - sw_optical_props_precipByBand%ssa(1,iLay,iBand) = (ssaw - za2) / (1._kind_phys - za2) - sw_optical_props_precipByBand%g(1,iLay,iBand) = asyw/(1+asyw) + enddo + + ! Cloud-overlap. + ! Maximum-random, random or maximum. + if (iovr == iovr_maxrand .or. iovr == iovr_rand .or. iovr == iovr_max) then + call sampled_mask(rng3D, cld_frac(ix:ix2,:), maskMCICA) + endif + ! Exponential decorrelation length overlap + if (iovr == iovr_dcorr) then + do iblck = 1, rrtmgp_phys_blksz + ! Generate second RNG + call random_setseed(ipseed_sw(iblck),rng_stat) + call random_number(rng2D,rng_stat) + rng3D2(:,:,iblck) = reshape(source = rng2D,shape=[sw_gas_props%get_ngpt(),nLay]) enddo + ! + call sampled_mask(rng3D, cld_frac(ix:ix2,:), maskMCICA, & + overlap_param = cloud_overlap_param(ix:ix2,1:nLay-1), randoms2 = rng3D2) endif - enddo - + ! Exponential or Exponential-random + if (iovr == iovr_exp .or. iovr == iovr_exprand) then + call sampled_mask(rng3D, cld_frac(ix:ix2,:), maskMCICA, & + overlap_param = cloud_overlap_param(ix:ix2,1:nLay-1)) + endif + ! Sampling. Map band optical depth to each g-point using McICA + call check_error_msg('rrtmgp_sw_main_cloud_sampling',& + draw_samples(maskMCICA, .true., & + sw_optical_props_cloudsByBand, sw_optical_props_clouds)) + endif + ! ################################################################################### ! - ! Cloud-sampling + ! Compute clear-sky fluxes (gaseous+aerosol) (optional) ! ! ################################################################################### - ! Change random number seed value for each radiation invocation (isubc_sw =1 or 2). - if(isubc_sw == 1) then ! advance prescribed permutation seed - ipseed_sw = sw_gas_props%get_ngpt() + iCol - elseif (isubc_sw == 2) then ! use input array of permutaion seeds - ipseed_sw = icseed_sw(ix) - endif - ! Call RNG - call random_setseed(ipseed_sw,rng_stat) - ! Use same rng for each layer - if (iovr == iovr_max) then - call random_number(rng1D,rng_stat) - do iLay=1,nLay - rng3D(:,iLay,1) = rng1D - enddo - else - do iLay=1,nLay - call random_number(rng1D,rng_stat) - rng3D(:,iLay,1) = rng1D + ! Add aerosol optics to gaseous (clear-sky) optical properties + sw_optical_props_aerosol_local%tau = sw_optical_props_aerosol%tau(ix:ix2,:,:) + sw_optical_props_aerosol_local%ssa = sw_optical_props_aerosol%ssa(ix:ix2,:,:) + sw_optical_props_aerosol_local%g = sw_optical_props_aerosol%g(ix:ix2,:,:) + call check_error_msg('rrtmgp_sw_main_increment_aerosol_to_clrsky', & + sw_optical_props_aerosol_local%increment(sw_optical_props_accum)) + + ! Delta-scale + !call check_error_msg('rrtmgp_sw_main_delta_scale',sw_optical_props_accum%delta_scale()) + + ! Compute fluxes + call check_error_msg('rrtmgp_sw_main_rte_sw_clrsky',rte_sw( & + sw_optical_props_accum, & ! IN - optical-properties + top_at_1, & ! IN - veritcal ordering flag + coszen(ix:ix2), & ! IN - Cosine of solar zenith angle + toa_src_sw, & ! IN - incident solar flux at TOA + sfc_alb_dir, & ! IN - Shortwave surface albedo (direct) + sfc_alb_dif, & ! IN - Shortwave surface albedo (diffuse) + flux_clrsky)) ! OUT - Fluxes, clear-sky, 3D (1,nLay,nBand) + + ! Store fluxes + fluxswUP_clrsky(ix:ix2,:) = sum(flux_clrsky%bnd_flux_up, dim=3) + fluxswDOWN_clrsky(ix:ix2,:) = sum(flux_clrsky%bnd_flux_dn, dim=3) + + ! Compute surface downward beam/diffused flux components + do iblck = 1, rrtmgp_phys_blksz + do iBand=1,sw_gas_props%get_nband() + flux_dir = flux_clrsky%bnd_flux_dn(iblck,iSFC,iBand) + flux_dif = 0._kind_phys + ! Near-IR bands + if (iBand < ibd) then + scmpsw_clrsky(iblck)%nirbm = scmpsw_clrsky(iblck)%nirbm + flux_dir + scmpsw_clrsky(iblck)%nirdf = scmpsw_clrsky(iblck)%nirdf + flux_dif + endif + ! Transition band + if (iBand == ibd) then + scmpsw_clrsky(iblck)%nirbm = scmpsw_clrsky(iblck)%nirbm + flux_dir*0.5_kind_phys + scmpsw_clrsky(iblck)%nirdf = scmpsw_clrsky(iblck)%nirdf + flux_dif*0.5_kind_phys + scmpsw_clrsky(iblck)%visbm = scmpsw_clrsky(iblck)%visbm + flux_dir*0.5_kind_phys + scmpsw_clrsky(iblck)%visdf = scmpsw_clrsky(iblck)%visdf + flux_dif*0.5_kind_phys + endif + ! UV-VIS bands + if (iBand > ibd) then + scmpsw_clrsky(iblck)%visbm = scmpsw_clrsky(iblck)%visbm + flux_dir + scmpsw_clrsky(iblck)%visdf = scmpsw_clrsky(iblck)%visdf + flux_dif + endif + ! uv-b surface downward flux + scmpsw_clrsky(iblck)%uvbfc = flux_clrsky%bnd_flux_dn(iblck,iSFC,ibd_uv) enddo - endif - ! Cloud-overlap. - ! Maximum-random, random or maximum. - if (iovr == iovr_maxrand .or. iovr == iovr_rand .or. iovr == iovr_max) then - call sampled_mask(rng3D, cld_frac(ix:ix,:), maskMCICA) - endif - ! Exponential decorrelation length overlap - if (iovr == iovr_dcorr) then - ! Generate second RNG - call random_setseed(ipseed_sw,rng_stat) - call random_number(rng2D,rng_stat) - rng3D2(:,:,1) = reshape(source = rng2D,shape=[sw_gas_props%get_ngpt(),nLay]) - ! - call sampled_mask(rng3D, cld_frac(ix:ix,:), maskMCICA, & - overlap_param = cloud_overlap_param(ix:ix,1:nLay-1), randoms2 = rng3D2) - endif - ! Exponential or Exponential-random - if (iovr == iovr_exp .or. iovr == iovr_exprand) then - call sampled_mask(rng3D, cld_frac(ix:ix,:), maskMCICA, & - overlap_param = cloud_overlap_param(ix:ix,1:nLay-1)) - endif - ! Sampling. Map band optical depth to each g-point using McICA - call check_error_msg('rrtmgp_sw_main_cloud_sampling',& - draw_samples(maskMCICA, .true., & - sw_optical_props_cloudsByBand, sw_optical_props_clouds)) - + enddo + ! ################################################################################### ! - ! Compute clear-sky fluxes (gaseous+aerosol) (optional) + ! All-sky fluxes (clear-sky + clouds + precipitation) ! ! ################################################################################### - ! Add aerosol optics to gas optics - sw_optical_props_aerosol_local%tau = sw_optical_props_aerosol%tau(iCol:iCol,:,:) - sw_optical_props_aerosol_local%ssa = sw_optical_props_aerosol%ssa(iCol:iCol,:,:) - sw_optical_props_aerosol_local%g = sw_optical_props_aerosol%g(iCol:iCol,:,:) - call check_error_msg('rrtmgp_sw_main_increment_aerosol_to_clrsky',& - sw_optical_props_aerosol_local%increment(sw_optical_props_clrsky)) - - ! Delta-scale optical properties - call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_clrsky%delta_scale()) - if (doSWclrsky) then - call check_error_msg('rrtmgp_sw_main_rte_sw_clrsky',rte_sw( & - sw_optical_props_clrsky, & ! IN - optical-properties + if (any(cld_frac(ix:ix2,:) .gt. 1.e-6_kind_phys)) then + ! Delta scale + !call check_error_msg('rrtmgp_sw_main_delta_scale',sw_optical_props_clouds%delta_scale()) + + ! Add clear-sky to cloud-sky + call check_error_msg('rrtmgp_sw_main_increment_clouds_to_clrsky', & + sw_optical_props_clouds%increment(sw_optical_props_accum)) + + ! Compute fluxes + call check_error_msg('rrtmgp_sw_main_rte_sw_allsky',rte_sw( & + sw_optical_props_accum, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag - coszen(ix:ix), & ! IN - Cosine of solar zenith angle + coszen(ix:ix2), & ! IN - Cosine of solar zenith angle toa_src_sw, & ! IN - incident solar flux at TOA sfc_alb_dir, & ! IN - Shortwave surface albedo (direct) sfc_alb_dif, & ! IN - Shortwave surface albedo (diffuse) - flux_clrsky)) ! OUT - Fluxes, clear-sky, 3D (1,nLay,nBand) + flux_allsky)) ! OUT - Fluxes, clear-sky, 3D (1,nLay,nBand) + ! Store fluxes - fluxswUP_clrsky(ix,:) = sum(flux_clrsky%bnd_flux_up(1,:,:),dim=2) - fluxswDOWN_clrsky(ix,:) = sum(flux_clrsky%bnd_flux_dn(1,:,:),dim=2) - else - fluxswUP_clrsky(ix,:) = 0.0 - fluxswDOWN_clrsky(ix,:) = 0.0 + fluxswUP_allsky(ix:ix2,:) = sum(flux_allsky%bnd_flux_up, dim=3) + fluxswDOWN_allsky(ix:ix2,:) = sum(flux_allsky%bnd_flux_dn, dim=3) + + ! Compute and store downward beam/diffused flux components + do iblck = 1, rrtmgp_phys_blksz + ! Loop over bands, sum fluxes... + do iBand=1,sw_gas_props%get_nband() + flux_dir = flux_allsky%bnd_flux_dn_dir(iblck,iSFC,iBand) + flux_dif = flux_allsky%bnd_flux_dn(iblck,iSFC,iBand) - flux_allsky%bnd_flux_dn_dir(iblck,iSFC,iBand) + ! Near-IR bands + if (iBand < ibd) then + scmpsw_allsky(iblck)%nirbm = scmpsw_allsky(iblck)%nirbm + flux_dir + scmpsw_allsky(iblck)%nirdf = scmpsw_allsky(iblck)%nirdf + flux_dif + endif + ! Transition band + if (iBand == ibd) then + scmpsw_allsky(iblck)%nirbm = scmpsw_allsky(iblck)%nirbm + flux_dir*0.5_kind_phys + scmpsw_allsky(iblck)%nirdf = scmpsw_allsky(iblck)%nirdf + flux_dif*0.5_kind_phys + scmpsw_allsky(iblck)%visbm = scmpsw_allsky(iblck)%visbm + flux_dir*0.5_kind_phys + scmpsw_allsky(iblck)%visdf = scmpsw_allsky(iblck)%visdf + flux_dif*0.5_kind_phys + endif + ! UV-VIS bands + if (iBand > ibd) then + scmpsw_allsky(iblck)%visbm = scmpsw_allsky(iblck)%visbm + flux_dir + scmpsw_allsky(iblck)%visdf = scmpsw_allsky(iblck)%visdf + flux_dif + endif + ! uv-b surface downward flux + scmpsw_allsky(iblck)%uvbfc = flux_allsky%bnd_flux_dn(iblck,iSFC,ibd_uv) + enddo + ! Store surface downward beam/diffused flux components + if (cld_frac(ix+iblck-1,iSFC) .gt. 1.e-6_kind_phys) then + scmpsw(ix+iblck-1)%nirbm = scmpsw_allsky(iblck)%nirbm + scmpsw(ix+iblck-1)%nirdf = scmpsw_allsky(iblck)%nirdf + scmpsw(ix+iblck-1)%visbm = scmpsw_allsky(iblck)%visbm + scmpsw(ix+iblck-1)%visdf = scmpsw_allsky(iblck)%visdf + scmpsw(ix+iblck-1)%uvbfc = flux_allsky%bnd_flux_dn(iblck,iSFC,ibd_uv) + else + scmpsw(ix+iblck-1)%nirbm = scmpsw_clrsky(iblck)%nirbm + scmpsw(ix+iblck-1)%nirdf = scmpsw_clrsky(iblck)%nirdf + scmpsw(ix+iblck-1)%visbm = scmpsw_clrsky(iblck)%visbm + scmpsw(ix+iblck-1)%visdf = scmpsw_clrsky(iblck)%visdf + scmpsw(ix+iblck-1)%uvbfc = flux_clrsky%bnd_flux_dn(iblck,iSFC,ibd_uv) + endif + scmpsw(ix+iblck-1)%uvbf0 = flux_clrsky%bnd_flux_dn(iblck,iSFC,ibd_uv) + enddo + else ! No clouds + fluxswUP_allsky(ix:ix2,:) = sum(flux_clrsky%bnd_flux_up, dim=3) + fluxswDOWN_allsky(ix:ix2,:) = sum(flux_clrsky%bnd_flux_dn, dim=3) + do iblck = 1, rrtmgp_phys_blksz + scmpsw(ix+iblck-1)%nirbm = scmpsw_clrsky(iblck)%nirbm + scmpsw(ix+iblck-1)%nirdf = scmpsw_clrsky(iblck)%nirdf + scmpsw(ix+iblck-1)%visbm = scmpsw_clrsky(iblck)%visbm + scmpsw(ix+iblck-1)%visdf = scmpsw_clrsky(iblck)%visdf + scmpsw(ix+iblck-1)%uvbfc = flux_clrsky%bnd_flux_dn(iblck,iSFC,ibd_uv) + scmpsw(ix+iblck-1)%uvbf0 = flux_clrsky%bnd_flux_dn(iblck,iSFC,ibd_uv) + enddo endif - - ! ################################################################################### - ! - ! All-sky fluxes (clear-sky + clouds + precipitation) ! - ! ################################################################################### - - ! Include convective cloud? - if (doGP_sgs_cnv) then - call check_error_msg('rrtmgp_sw_main_increment_cnvclouds_to_clrsky',& - sw_optical_props_cnvcloudsByBand%increment(sw_optical_props_clouds)) - endif - - ! Include MYNN-EDMF PBL clouds? - if (doGP_sgs_pbl) then - call check_error_msg('rrtmgp_sw_main_increment_pblclouds_to_clrsky',& - sw_optical_props_pblcloudsByBand%increment(sw_optical_props_clouds)) - endif - - ! Add in precipitation - call check_error_msg('rrtmgp_sw_main_increment_precip_to_clrsky',& - sw_optical_props_precipByBand%increment(sw_optical_props_clouds)) - - ! Delta-scale optical properties - call check_error_msg('rrtmgp_sw_main_delta_scale',sw_optical_props_clrsky%delta_scale()) - call check_error_msg('rrtmgp_sw_main_rte_sw_allsky',rte_sw( & - sw_optical_props_clouds, & ! IN - optical-properties - top_at_1, & ! IN - veritcal ordering flag - coszen(ix:ix), & ! IN - Cosine of solar zenith angle - toa_src_sw, & ! IN - incident solar flux at TOA - sfc_alb_dir, & ! IN - Shortwave surface albedo (direct) - sfc_alb_dif, & ! IN - Shortwave surface albedo (diffuse) - flux_allsky)) ! OUT - Fluxes, clear-sky, 3D (1,nLay,nBand) - - ! Store fluxes - fluxswUP_allsky(ix,:) = sum(flux_allsky%bnd_flux_up(1,:,:),dim=2) - fluxswDOWN_allsky(ix,:) = sum(flux_allsky%bnd_flux_dn(1,:,:),dim=2) - ! Near IR - scmpsw(ix)%nirbm = sum(flux_allsky%bnd_flux_dn_dir(1,iSFC,1:ibd-1)) + & - flux_allsky%bnd_flux_dn_dir(1,iSFC,ibd)/2. - scmpsw(ix)%nirdf = (sum(flux_allsky%bnd_flux_dn(1,iSFC,1:ibd-1)) + & - flux_allsky%bnd_flux_dn(1,iSFC,ibd)/2.) - & - (sum(flux_allsky%bnd_flux_dn_dir(1,iSFC,1:ibd-1)) + & - flux_allsky%bnd_flux_dn_dir(1,iSFC,ibd)/2.) - ! UV-VIS - scmpsw(ix)%visbm = sum(flux_allsky%bnd_flux_dn_dir(1,iSFC,ibd+1:sw_gas_props%get_nband())) + & - flux_allsky%bnd_flux_dn_dir(1,iSFC,ibd)/2. - scmpsw(ix)%visdf = (sum(flux_allsky%bnd_flux_dn(1,iSFC,ibd+1:sw_gas_props%get_nband())) + & - flux_allsky%bnd_flux_dn(1,iSFC,ibd)/2. ) - & - (sum(flux_allsky%bnd_flux_dn_dir(1,iSFC,ibd+1:sw_gas_props%get_nband())) + & - flux_allsky%bnd_flux_dn_dir(1,iSFC,ibd)/2.) - enddo + enddo ! nday else fluxswUP_allsky(:,:) = 0._kind_phys fluxswDOWN_allsky(:,:) = 0._kind_phys diff --git a/physics/rrtmgp_sw_main.meta b/physics/rrtmgp_sw_main.meta index 634516ea1..956716c80 100644 --- a/physics/rrtmgp_sw_main.meta +++ b/physics/rrtmgp_sw_main.meta @@ -169,6 +169,20 @@ dimensions = () type = integer intent = in +[rrtmgp_phys_blksz] + standard_name = number_of_columns_per_RRTMGP_block + long_name = number of columns to process ata time by RRTMGP + units = count + dimensions = () + type = integer + intent = in +[nGases] + standard_name = number_of_active_gases_used_by_RRTMGP + long_name = number of gases available used by RRTMGP (Model%nGases) + units = count + dimensions = () + type = integer + intent = in [nday] standard_name = daytime_points_dimension long_name = daytime points dimension @@ -540,13 +554,6 @@ dimensions = () type = ty_optical_props_2str intent = in -[gas_concentrations] - standard_name = Gas_concentrations_for_RRTMGP_suite - long_name = DDT containing gas concentrations for RRTMGP radiation scheme - units = DDT - dimensions = () - type = ty_gas_concs - intent = in [solcon] standard_name = solar_constant long_name = solar constant diff --git a/physics/rrtmgp_sw_rte.F90 b/physics/rrtmgp_sw_rte.F90 deleted file mode 100644 index 521aae2c1..000000000 --- a/physics/rrtmgp_sw_rte.F90 +++ /dev/null @@ -1,219 +0,0 @@ -!> \file rrtmgp_sw_rte.F90 -!! -!> \defgroup rrtmgp_sw_rte rrtmgp_sw_rte.F90 -!! -!! \brief This module contains the main rte shortwave driver. -module rrtmgp_sw_rte - use machine, only: kind_phys - use mo_optical_props, only: ty_optical_props_2str - use mo_rte_sw, only: rte_sw - use mo_fluxes_byband, only: ty_fluxes_byband - use module_radsw_parameters, only: cmpfsw_type - use radiation_tools, only: check_error_msg - use rrtmgp_sw_gas_optics, only: sw_gas_props - implicit none - - public rrtmgp_sw_rte_run - -contains -!>\defgroup rrtmgp_sw_rte_mod GFS RRTMGP-SW RTE Module -!> \section arg_table_rrtmgp_sw_rte_run -!! \htmlinclude rrtmgp_sw_rte.html -!! -!> \ingroup rrtmgp_sw_rte -!! -!! \brief This routine takes all of the shortwave optical properties ,ty_optical_props_2str, -!! and computes the shortwave radiative fluxes for cloudy and clear-sky conditions. -!! -!! \section rrtmgp_sw_rte_run Main Driver -!> @{ - ! ###################################################################################### - subroutine rrtmgp_sw_rte_run(doSWrad, doSWclrsky, nCol, nLev, nDay, idxday, coszen, p_lay,& - t_lay, top_at_1, doGP_sgs_cnv, doGP_sgs_mynn, iSFC, sfc_alb_nir_dir, sfc_alb_nir_dif,& - sfc_alb_uvvis_dir, sfc_alb_uvvis_dif, toa_src_sw, sw_optical_props_clrsky, & - sw_optical_props_clouds, sw_optical_props_precipByBand, & - sw_optical_props_cnvcloudsByBand, sw_optical_props_MYNNcloudsByBand, & - sw_optical_props_aerosol, scmpsw, fluxswUP_allsky, fluxswDOWN_allsky, & - fluxswUP_clrsky, fluxswDOWN_clrsky, errmsg, errflg) - - ! Inputs - logical, intent(in) :: & - top_at_1, & ! Vertical ordering flag - doGP_sgs_mynn, & ! Flag for MYNN-EDMF PBL cloud scheme - doGP_sgs_cnv, & ! Flag for sgs convective clouds scheme - doSWrad, & ! Flag to calculate SW irradiances - doSWclrsky ! Compute clear-sky fluxes? - integer, intent(in) :: & - nCol, & ! Number of horizontal gridpoints - nday, & ! Number of daytime points - nLev, & ! Number of vertical levels - iSFC ! Vertical index for surface-level - integer, intent(in), dimension(:) :: & - idxday ! Index array for daytime points - real(kind_phys),intent(in), dimension(:) :: & - sfc_alb_nir_dir, & ! Surface albedo (direct) - sfc_alb_nir_dif, & ! Surface albedo (diffuse) - sfc_alb_uvvis_dir, & ! Surface albedo (direct) - sfc_alb_uvvis_dif, & ! Surface albedo (diffuse) - coszen ! Cosize of SZA - real(kind_phys), dimension(:,:), intent(in) :: & - p_lay, & ! Pressure @ model layer-centers (Pa) - t_lay, & ! Temperature (K) - toa_src_sw ! TOA incident spectral flux (W/m2) - type(ty_optical_props_2str),intent(inout) :: & - sw_optical_props_clrsky ! RRTMGP DDT: shortwave clear-sky radiative properties - type(ty_optical_props_2str),intent(in) :: & - sw_optical_props_clouds, & ! RRTMGP DDT: shortwave cloud optical properties - sw_optical_props_cnvcloudsByBand, & ! RRTMGP DDT: shortwave convecive cloud optical properties - sw_optical_props_MYNNcloudsByBand, & ! RRTMGP DDT: shortwave MYNN-EDMF PBL cloud optical properties - sw_optical_props_precipByBand, & ! RRTMGP DDT: shortwave precipitation optical properties - sw_optical_props_aerosol ! RRTMGP DDT: shortwave aerosol optical properties - - ! Outputs - character(len=*), intent(out) :: & - errmsg ! CCPP error message - integer, intent(out) :: & - errflg ! CCPP error flag - real(kind_phys), dimension(:,:), intent(inout) :: & - fluxswUP_allsky, & ! RRTMGP upward all-sky flux profiles (W/m2) - fluxswDOWN_allsky, & ! RRTMGP downward all-sky flux profiles (W/m2) - fluxswUP_clrsky, & ! RRTMGP upward clear-sky flux profiles (W/m2) - fluxswDOWN_clrsky ! RRTMGP downward clear-sky flux profiles (W/m2) - type(cmpfsw_type), dimension(:), intent(inout) :: & - scmpsw ! 2D surface fluxes, components: - ! uvbfc - total sky downward uv-b flux (W/m2) - ! uvbf0 - clear sky downward uv-b flux (W/m2) - ! nirbm - downward nir direct beam flux (W/m2) - ! nirdf - downward nir diffused flux (W/m2) - ! visbm - downward uv+vis direct beam flux (W/m2) - ! visdf - downward uv+vis diffused flux (W/m2) - - ! Local variables - real(kind_phys), dimension(sw_gas_props%get_nband(),nday) :: & - sfc_alb_dir,sfc_alb_dif - type(ty_fluxes_byband) :: & - flux_allsky, & ! All-sky flux (W/m2) - flux_clrsky ! Clear-sky flux (W/m2) - real(kind_phys), dimension(nday,NLev+1,sw_gas_props%get_nband()),target :: & - fluxSW_up_allsky, fluxSW_up_clrsky, fluxSW_dn_allsky, fluxSW_dn_clrsky, fluxSW_dn_dir_allsky - real(kind_phys), dimension(ncol,NLev) :: vmrTemp - integer :: iBand, iDay,ibd - real(kind_phys), dimension(2,sw_gas_props%get_nband()) :: bandlimits - real(kind_phys), dimension(2), parameter :: nIR_uvvis_bnd = (/12850,16000/) - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (.not. doSWrad) return - - if (nDay .gt. 0) then - - ! Initialize RRTMGP DDT containing 2D(3D) fluxes - flux_allsky%bnd_flux_up => fluxSW_up_allsky - flux_allsky%bnd_flux_dn => fluxSW_dn_allsky - flux_allsky%bnd_flux_dn_dir => fluxSW_dn_dir_allsky - flux_clrsky%bnd_flux_up => fluxSW_up_clrsky - flux_clrsky%bnd_flux_dn => fluxSW_dn_clrsky - - ! Use near-IR albedo for bands with wavenumbers extending to 12850cm-1 - ! Use uv-vis albedo for bands with wavenumbers greater than 16000cm-1 - ! For overlapping band, average near-IR and us-vis albedos. - bandlimits = sw_gas_props%get_band_lims_wavenumber() - do iBand=1,sw_gas_props%get_nband() - if (bandlimits(1,iBand) .lt. nIR_uvvis_bnd(1)) then - sfc_alb_dir(iBand,:) = sfc_alb_nir_dir(idxday(1:nday)) - sfc_alb_dif(iBand,:) = sfc_alb_nir_dif(idxday(1:nday)) - endif - if (bandlimits(1,iBand) .eq. nIR_uvvis_bnd(1)) then - sfc_alb_dir(iBand,:) = 0.5_kind_phys*(sfc_alb_nir_dir(idxday(1:nday)) + sfc_alb_uvvis_dir(idxday(1:nday))) - sfc_alb_dif(iBand,:) = 0.5_kind_phys*(sfc_alb_nir_dif(idxday(1:nday)) + sfc_alb_uvvis_dif(idxday(1:nday))) - ibd = iBand - endif - if (bandlimits(1,iBand) .ge. nIR_uvvis_bnd(2)) then - sfc_alb_dir(iBand,:) = sfc_alb_uvvis_dir(idxday(1:nday)) - sfc_alb_dif(iBand,:) = sfc_alb_uvvis_dif(idxday(1:nday)) - endif - enddo - - ! - ! Compute clear-sky fluxes (if requested) - ! - - ! Clear-sky fluxes (gas+aerosol) - call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_aerosol%increment(sw_optical_props_clrsky)) - ! Delta-scale optical properties - call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_clrsky%delta_scale()) - if (doSWclrsky) then - call check_error_msg('rrtmgp_sw_rte_run',rte_sw( & - sw_optical_props_clrsky, & ! IN - optical-properties - top_at_1, & ! IN - veritcal ordering flag - coszen(idxday(1:nday)), & ! IN - Cosine of solar zenith angle - toa_src_sw(idxday(1:nday),:), & ! IN - incident solar flux at TOA - sfc_alb_dir, & ! IN - Shortwave surface albedo (direct) - sfc_alb_dif, & ! IN - Shortwave surface albedo (diffuse) - flux_clrsky)) ! OUT - Fluxes, clear-sky, 3D (nCol,NLev,nBand) - ! Store fluxes - fluxswUP_clrsky(idxday(1:nday),:) = sum(flux_clrsky%bnd_flux_up,dim=3) - fluxswDOWN_clrsky(idxday(1:nday),:) = sum(flux_clrsky%bnd_flux_dn,dim=3) - endif - - ! - ! Compute all-sky fluxes - ! - - ! Include convective cloud? - if (doGP_sgs_cnv) then - call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_cnvcloudsByBand%increment(sw_optical_props_clrsky)) - endif - - ! Include MYNN-EDMF PBL cloud? - if (doGP_sgs_mynn) then - call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_MYNNcloudsByBand%increment(sw_optical_props_clrsky)) - endif - - ! All-sky fluxes (clear-sky + clouds + precipitation) - call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_precipByBand%increment(sw_optical_props_clrsky)) - call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_clouds%increment(sw_optical_props_clrsky)) - - ! Delta-scale optical properties - call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_clrsky%delta_scale()) - call check_error_msg('rrtmgp_sw_rte_run',rte_sw( & - sw_optical_props_clrsky, & ! IN - optical-properties - top_at_1, & ! IN - veritcal ordering flag - coszen(idxday(1:nday)), & ! IN - Cosine of solar zenith angle - toa_src_sw(idxday(1:nday),:), & ! IN - incident solar flux at TOA - sfc_alb_dir, & ! IN - Shortwave surface albedo (direct) - sfc_alb_dif, & ! IN - Shortwave surface albedo (diffuse) - flux_allsky)) ! OUT - Fluxes, clear-sky, 3D (nCol,NLev,nBand) - - ! Store fluxes - fluxswUP_allsky(idxday(1:nday),:) = sum(flux_allsky%bnd_flux_up,dim=3) - fluxswDOWN_allsky(idxday(1:nday),:) = sum(flux_allsky%bnd_flux_dn,dim=3) - do iDay=1,nDay - ! Near IR - scmpsw(idxday(iDay))%nirbm = sum(flux_allsky%bnd_flux_dn_dir(iDay,iSFC,1:ibd-1)) + & - flux_allsky%bnd_flux_dn_dir(iDay,iSFC,ibd)/2. - scmpsw(idxday(iDay))%nirdf = (sum(flux_allsky%bnd_flux_dn(iDay,iSFC,1:ibd-1)) + & - flux_allsky%bnd_flux_dn(iDay,iSFC,ibd)/2.) - & - (sum(flux_allsky%bnd_flux_dn_dir(iDay,iSFC,1:ibd-1)) + & - flux_allsky%bnd_flux_dn_dir(iDay,iSFC,ibd)/2.) - ! UV-VIS - scmpsw(idxday(iDay))%visbm = sum(flux_allsky%bnd_flux_dn_dir(iDay,iSFC,ibd+1:sw_gas_props%get_nband())) + & - flux_allsky%bnd_flux_dn_dir(iDay,iSFC,ibd)/2. - scmpsw(idxday(iDay))%visdf = (sum(flux_allsky%bnd_flux_dn(iDay,iSFC,ibd+1:sw_gas_props%get_nband())) + & - flux_allsky%bnd_flux_dn(iDay,iSFC,ibd)/2. ) - & - (sum(flux_allsky%bnd_flux_dn_dir(iDay,iSFC,ibd+1:sw_gas_props%get_nband())) + & - flux_allsky%bnd_flux_dn_dir(iDay,iSFC,ibd)/2.) - enddo - else - fluxswUP_allsky(:,:) = 0._kind_phys - fluxswDOWN_allsky(:,:) = 0._kind_phys - fluxswUP_clrsky(:,:) = 0._kind_phys - fluxswDOWN_clrsky(:,:) = 0._kind_phys - scmpsw = cmpfsw_type( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 ) - endif - - end subroutine rrtmgp_sw_rte_run -!> @} -end module rrtmgp_sw_rte diff --git a/physics/rrtmgp_sw_rte.meta b/physics/rrtmgp_sw_rte.meta deleted file mode 100644 index 9ab24c8b3..000000000 --- a/physics/rrtmgp_sw_rte.meta +++ /dev/null @@ -1,240 +0,0 @@ -[ccpp-table-properties] - name = rrtmgp_sw_rte - type = scheme - dependencies = machine.F,radsw_param.f,rte-rrtmgp/rte/mo_rte_sw.F90,rte-rrtmgp/rte/mo_fluxes.F90,rte-rrtmgp/rte/kernels/mo_fluxes_broadband_kernels.F90,radiation_tools.F90 - dependencies = rte-rrtmgp/rte/kernels/mo_rte_solver_kernels.F90,rte-rrtmgp/extensions/mo_fluxes_byband.F90 - -######################################################################## -[ccpp-arg-table] - name = rrtmgp_sw_rte_run - type = scheme -[doSWrad] - standard_name = flag_for_calling_shortwave_radiation - long_name = flag to calculate SW irradiances - units = flag - dimensions = () - type = logical - intent = in -[doSWclrsky] - standard_name = flag_for_output_of_tendency_of_air_temperature_due_to_shortwave_heating_on_radiation_timestep_assuming_clear_sky - long_name = flag to output sw heating rate (Radtend%swhc) - units = flag - dimensions = () - type = logical - intent = in -[ncol] - standard_name = horizontal_loop_extent - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in -[nLev] - standard_name = vertical_layer_dimension - long_name = number of vertical levels - units = count - dimensions = () - type = integer - intent = in -[nday] - standard_name = daytime_points_dimension - long_name = daytime points dimension - units = count - dimensions = () - type = integer - intent = in -[idxday] - standard_name = daytime_points - long_name = daytime points - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = in -[coszen] - standard_name = cosine_of_solar_zenith_angle_for_daytime_points_on_radiation_timestep - long_name = mean cos of zenith angle over rad call period - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[p_lay] - standard_name = air_pressure_at_layer_for_RRTMGP - long_name = air pressure layer - units = Pa - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[top_at_1] - standard_name = flag_for_vertical_ordering_in_RRTMGP - long_name = flag for vertical ordering in RRTMGP - units = flag - dimensions = () - type = logical - intent = in -[doGP_sgs_cnv] - standard_name = flag_to_include_sgs_convective_cloud_in_RRTMGP - long_name = logical flag to control sgs convective cloud in RRTMGP - units = flag - dimensions = () - type = logical - intent = in -[doGP_sgs_mynn] - standard_name = flag_to_include_sgs_MYNN_EDMF_cloud_in_RRTMGP - long_name = logical flag to control MYNN-EDMF PBL cloud in RRTMGP - units = flag - dimensions = () - type = logical - intent = in -[iSFC] - standard_name = vertical_index_for_surface_in_RRTMGP - long_name = index for surface layer in RRTMGP - units = flag - dimensions = () - type = integer - intent = in -[t_lay] - standard_name = air_temperature_at_layer_for_RRTMGP - long_name = air temperature layer - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[sw_optical_props_clrsky] - standard_name = shortwave_optical_properties_for_clear_sky - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = inout -[sw_optical_props_clouds] - standard_name = shortwave_optical_properties_for_cloudy_atmosphere - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = in -[sw_optical_props_precipByBand] - standard_name = shortwave_optical_properties_for_precipitation_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = in -[sw_optical_props_cnvcloudsByBand] - standard_name = shortwave_optical_properties_for_convective_cloudy_atmosphere_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = in -[sw_optical_props_MYNNcloudsByBand] - standard_name = shortwave_optical_properties_for_MYNN_EDMF_PBL_cloudy_atmosphere_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = in -[sw_optical_props_aerosol] - standard_name = shortwave_optical_properties_for_aerosols - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = in -[sfc_alb_nir_dir] - standard_name = surface_albedo_due_to_near_IR_direct - long_name = surface albedo due to near IR direct beam - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[sfc_alb_nir_dif] - standard_name = surface_albedo_due_to_near_IR_diffused - long_name = surface albedo due to near IR diffused beam - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[sfc_alb_uvvis_dir] - standard_name = surface_albedo_due_to_UV_and_VIS_direct - long_name = surface albedo due to UV+VIS direct beam - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[sfc_alb_uvvis_dif] - standard_name = surface_albedo_due_to_UV_and_VIS_diffused - long_name = surface albedo due to UV+VIS diffused beam - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[toa_src_sw] - standard_name = toa_incident_sw_flux_by_spectral_point - long_name = TOA shortwave incident flux at each spectral points - units = W m-2 - dimensions = (horizontal_loop_extent,number_of_shortwave_spectral_points) - type = real - kind = kind_phys - intent = in -[scmpsw] - standard_name = components_of_surface_downward_shortwave_fluxes - long_name = derived type for special components of surface downward shortwave fluxes - units = W m-2 - dimensions = (horizontal_loop_extent) - type = cmpfsw_type - intent = inout -[fluxswUP_allsky] - standard_name = RRTMGP_sw_flux_profile_upward_allsky - long_name = RRTMGP upward shortwave all-sky flux profile - units = W m-2 - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = inout -[fluxswDOWN_allsky] - standard_name = RRTMGP_sw_flux_profile_downward_allsky - long_name = RRTMGP downward shortwave all-sky flux profile - units = W m-2 - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = inout -[fluxswUP_clrsky] - standard_name = RRTMGP_sw_flux_profile_upward_clrsky - long_name = RRTMGP upward shortwave clr-sky flux profile - units = W m-2 - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = inout -[fluxswDOWN_clrsky] - standard_name = RRTMGP_sw_flux_profile_downward_clrsky - long_name = RRTMGP downward shortwave clr-sky flux profile - units = W m-2 - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = inout -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out From 99e032499991425b5a4af7d538228d3ac5edeecf Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Wed, 24 Aug 2022 22:44:18 +0000 Subject: [PATCH 025/380] Getting really close... --- physics/GFS_rrtmgp_lw_post.F90 | 188 --------- physics/GFS_rrtmgp_lw_post.meta | 253 ----------- physics/GFS_rrtmgp_post.F90 | 394 ++++++++++++++++++ ...tmgp_sw_post.meta => GFS_rrtmgp_post.meta} | 193 +++++++-- physics/GFS_rrtmgp_sw_post.F90 | 286 ------------- physics/rrtmgp_aerosol_optics.F90 | 49 +-- physics/rrtmgp_aerosol_optics.meta | 58 ++- physics/rrtmgp_lw_main.F90 | 15 +- physics/rrtmgp_lw_main.meta | 29 +- physics/rrtmgp_sw_cloud_optics.F90 | 181 -------- physics/rrtmgp_sw_gas_optics.F90 | 109 ----- physics/rrtmgp_sw_main.F90 | 20 +- physics/rrtmgp_sw_main.meta | 29 +- physics/rte-rrtmgp | 2 +- 14 files changed, 685 insertions(+), 1121 deletions(-) delete mode 100644 physics/GFS_rrtmgp_lw_post.F90 delete mode 100644 physics/GFS_rrtmgp_lw_post.meta create mode 100644 physics/GFS_rrtmgp_post.F90 rename physics/{GFS_rrtmgp_sw_post.meta => GFS_rrtmgp_post.meta} (70%) delete mode 100644 physics/GFS_rrtmgp_sw_post.F90 diff --git a/physics/GFS_rrtmgp_lw_post.F90 b/physics/GFS_rrtmgp_lw_post.F90 deleted file mode 100644 index afd56dcf1..000000000 --- a/physics/GFS_rrtmgp_lw_post.F90 +++ /dev/null @@ -1,188 +0,0 @@ -!> \file GFS_rrtmgp_lw_post.F90 -!! -!> \defgroup GFS_rrtmgp_lw_post GFS_rrtmgp_lw_post.F90 -!! -!! \brief RRTMGP Longwave post-processing routine. -!! -module GFS_rrtmgp_lw_post - use machine, only: kind_phys - use module_radlw_parameters, only: topflw_type, sfcflw_type - use mo_heating_rates, only: compute_heating_rate - use radiation_tools, only: check_error_msg - implicit none - - public GFS_rrtmgp_lw_post_run - -contains - -!>\defgroup gfs_rrtmgp_lw_post_mod GFS RRTMGP-LW Post Module -!> \section arg_table_GFS_rrtmgp_lw_post_run -!! \htmlinclude GFS_rrtmgp_lw_post.html -!! -!! \ingroup GFS_rrtmgp_lw_post -!! -!! \brief The all-sky longwave radiation tendency is computed, the clear-sky tendency is computed -!! if requested. -!! -!! RRTMGP surface and TOA fluxes are copied to fields that persist between radiation/physics -!! calls. -!! -!! (optional) Save additional diagnostics. -!! -!! \section GFS_rrtmgp_lw_post_run - ! ######################################################################################## - subroutine GFS_rrtmgp_lw_post_run (nCol, nLev, lslwr, do_lw_clrsky_hr, save_diag, fhlwr, & - p_lev, t_lay, tsfa, fluxlwUP_allsky, fluxlwDOWN_allsky, fluxlwUP_clrsky, iSFC, iTOA,& - fluxlwDOWN_clrsky, raddt, cldsa, mtopa, mbota, cld_frac, cldtaulw, fluxr, sfcdlw, & - sfculw, sfcflw, tsflw, htrlw, htrlwu, topflw, htrlwc, errmsg, errflg) - - ! Inputs - integer, intent(in) :: & - nCol, & ! Horizontal loop extent - nLev, & ! Number of vertical layers - iSFC, & ! Vertical index for surface level - iTOA ! Vertical index for TOA level - logical, intent(in) :: & - lslwr, & ! Logical flags for lw radiation calls - do_lw_clrsky_hr, & ! Output clear-sky SW heating-rate? - save_diag ! Output radiation diagnostics? - real(kind_phys), intent(in) :: & - fhlwr ! Frequency for SW radiation - real(kind_phys), dimension(nCol), intent(in) :: & - tsfa ! Lowest model layer air temperature for radiation (K) - real(kind_phys), dimension(nCol, nLev), intent(in) :: & - t_lay ! Temperature @ model layer centers (K) - real(kind_phys), dimension(nCol, nLev+1), intent(in) :: & - p_lev, & ! Pressure @ model layer-interfaces (Pa) - fluxlwUP_allsky, & ! RRTMGP longwave all-sky flux (W/m2) - fluxlwDOWN_allsky, & ! RRTMGP longwave all-sky flux (W/m2) - fluxlwUP_clrsky, & ! RRTMGP longwave clear-sky flux (W/m2) - fluxlwDOWN_clrsky ! RRTMGP longwave clear-sky flux (W/m2) - real(kind_phys), intent(in) :: & - raddt ! Radiation time step - real(kind_phys), dimension(nCol,5), intent(in) :: & - cldsa ! Fraction of clouds for low, middle, high, total and BL - integer, dimension(nCol,3), intent(in) ::& - mbota, & ! vertical indices for low, middle and high cloud tops - mtopa ! vertical indices for low, middle and high cloud bases - real(kind_phys), dimension(nCol,nLev), intent(in) :: & - cld_frac, & ! Total cloud fraction in each layer - cldtaulw ! approx 10.mu band layer cloud optical depth - - real(kind=kind_phys), dimension(:,:), intent(inout) :: fluxr - - ! Outputs (mandatory) - real(kind_phys), dimension(nCol), intent(inout) :: & - sfcdlw, & ! Total sky sfc downward lw flux (W/m2) - sfculw, & ! Total sky sfc upward lw flux (W/m2) - tsflw ! surface air temp during lw calculation (K) - type(sfcflw_type), dimension(nCol), intent(inout) :: & - sfcflw ! LW radiation fluxes at sfc - real(kind_phys), dimension(nCol,nLev), intent(inout) :: & - htrlw, & ! LW all-sky heating rate - htrlwu ! Heating-rate updated in-between radiation calls. - type(topflw_type), dimension(nCol), intent(out) :: & - topflw ! lw_fluxes_top_atmosphere - character(len=*), intent(out) :: & - errmsg - integer, intent(out) :: & - errflg - - ! Outputs (optional) - real(kind_phys),dimension(nCol, nLev),intent(inout),optional :: & - htrlwc ! Longwave clear-sky heating-rate (K/sec) - - ! Local variables - integer :: i, j, k, itop, ibtc - real(kind_phys) :: tem0d, tem1, tem2 - real(kind_phys),dimension(nCol,nLev) :: hlwc - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (.not. lslwr) return - ! ####################################################################################### - ! Compute LW heating-rates. - ! ####################################################################################### - ! Clear-sky heating-rate (optional) - if (do_lw_clrsky_hr) then - call check_error_msg('GFS_rrtmgp_post',compute_heating_rate( & - fluxlwUP_clrsky, & ! IN - RRTMGP upward longwave clear-sky flux profiles (W/m2) - fluxlwDOWN_clrsky, & ! IN - RRTMGP downward longwave clear-sky flux profiles (W/m2) - p_lev, & ! IN - Pressure @ layer-interfaces (Pa) - htrlwc)) ! OUT - Longwave clear-sky heating rate (K/sec) - endif - - ! All-sky heating-rate (mandatory) - call check_error_msg('GFS_rrtmgp_post',compute_heating_rate( & - fluxlwUP_allsky, & ! IN - RRTMGP upward longwave all-sky flux profiles (W/m2) - fluxlwDOWN_allsky, & ! IN - RRTMGP downward longwave all-sky flux profiles (W/m2) - p_lev, & ! IN - Pressure @ layer-interfaces (Pa) - htrlw)) ! OUT - Longwave all-sky heating rate (K/sec) - - ! ####################################################################################### - ! Save LW outputs. - ! (Copy fluxes from RRTMGP types into model radiation types.) - ! ####################################################################################### - ! TOA fluxes - topflw(:)%upfxc = fluxlwUP_allsky(:,iTOA) - topflw(:)%upfx0 = fluxlwUP_clrsky(:,iTOA) - - ! Surface fluxes - sfcflw(:)%upfxc = fluxlwUP_allsky(:,iSFC) - sfcflw(:)%upfx0 = fluxlwUP_clrsky(:,iSFC) - sfcflw(:)%dnfxc = fluxlwDOWN_allsky(:,iSFC) - sfcflw(:)%dnfx0 = fluxlwDOWN_clrsky(:,iSFC) - - ! Save surface air temp for diurnal adjustment at model t-steps - tsflw (:) = tsfa(:) - - ! Radiation fluxes for other physics processes - sfcdlw(:) = sfcflw(:)%dnfxc - sfculw(:) = sfcflw(:)%upfxc - - ! Heating-rate at radiation timestep, used for adjustment between radiation calls. - htrlwu = htrlw - - ! ####################################################################################### - ! Save LW diagnostics - ! - For time averaged output quantities (including total-sky and clear-sky SW and LW - ! fluxes at TOA and surface; conventional 3-domain cloud amount, cloud top and base - ! pressure, and cloud top temperature; aerosols AOD, etc.), store computed results in - ! corresponding slots of array fluxr with appropriate time weights. - ! - Collect the fluxr data for wrtsfc - ! ####################################################################################### - if (save_diag) then - do i=1,nCol - ! LW all-sky fluxes - fluxr(i,1 ) = fluxr(i,1 ) + fhlwr * fluxlwUP_allsky( i,iTOA) ! total sky top lw up - fluxr(i,19) = fluxr(i,19) + fhlwr * fluxlwDOWN_allsky(i,iSFC) ! total sky sfc lw dn - fluxr(i,20) = fluxr(i,20) + fhlwr * fluxlwUP_allsky( i,iSFC) ! total sky sfc lw up - ! LW clear-sky fluxes - fluxr(i,28) = fluxr(i,28) + fhlwr * fluxlwUP_clrsky( i,iTOA) ! clear sky top lw up - fluxr(i,30) = fluxr(i,30) + fhlwr * fluxlwDOWN_clrsky(i,iSFC) ! clear sky sfc lw dn - fluxr(i,33) = fluxr(i,33) + fhlwr * fluxlwUP_clrsky( i,iSFC) ! clear sky sfc lw up - enddo - - ! Save cld frac,toplyr,botlyr and top temp, note that the order of h,m,l cloud is reversed for - ! the fluxr output. save interface pressure (pa) of top/bot - do j = 1, 3 - do i = 1, nCol - tem0d = raddt * cldsa(i,j) - itop = mtopa(i,j) - ibtc = mbota(i,j) - - ! Add optical depth and emissivity output - tem2 = 0. - do k=ibtc,itop - tem2 = tem2 + cldtaulw(i,k) ! approx 10. mu channel - enddo - fluxr(i,46-j) = fluxr(i,46-j) + tem0d * (1.0-exp(-tem2)) - enddo - enddo - endif - - end subroutine GFS_rrtmgp_lw_post_run - -end module GFS_rrtmgp_lw_post diff --git a/physics/GFS_rrtmgp_lw_post.meta b/physics/GFS_rrtmgp_lw_post.meta deleted file mode 100644 index d458b25f3..000000000 --- a/physics/GFS_rrtmgp_lw_post.meta +++ /dev/null @@ -1,253 +0,0 @@ -[ccpp-table-properties] - name = GFS_rrtmgp_lw_post - type = scheme - dependencies = iounitdef.f,machine.F,radiation_aerosols.f,radlw_param.f,rte-rrtmgp/extensions/mo_fluxes_byband.F90,radiation_tools.F90,rte-rrtmgp/rte/mo_fluxes.F90,rte-rrtmgp/rte/kernels/mo_fluxes_broadband_kernels.F90,rte-rrtmgp/extensions/mo_heating_rates.F90 - -######################################################################## -[ccpp-arg-table] - name = GFS_rrtmgp_lw_post_run - type = scheme -[nCol] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[nLev] - standard_name = vertical_layer_dimension - long_name = number of vertical levels - units = count - dimensions = () - type = integer - intent = in -[iSFC] - standard_name = vertical_index_for_surface_in_RRTMGP - long_name = index for surface layer in RRTMGP - units = flag - dimensions = () - type = integer - intent = in -[iTOA] - standard_name = vertical_index_for_TOA_in_RRTMGP - long_name = index for TOA layer in RRTMGP - units = flag - dimensions = () - type = integer - intent = in -[lslwr] - standard_name = flag_for_calling_longwave_radiation - long_name = logical flags for lw radiation calls - units = flag - dimensions = () - type = logical - intent = in -[do_lw_clrsky_hr] - standard_name = flag_for_output_of_tendency_of_air_temperature_due_to_longwave_heating_on_radiation_timestep_assuming_clear_sky - long_name = flag to output lw heating rate - units = flag - dimensions = () - type = logical - intent = in -[save_diag] - standard_name = flag_for_diagnostics - long_name = logical flag for storing diagnostics - units = flag - dimensions = () - type = logical - intent = in -[fhlwr] - standard_name = period_of_longwave_radiation_calls - long_name = frequency for longwave radiation - units = s - dimensions = () - type = real - kind = kind_phys - intent = in -[tsfa] - standard_name = surface_air_temperature_for_radiation - long_name = lowest model layer air temperature for radiation - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[t_lay] - standard_name = air_temperature_at_layer_for_RRTMGP - long_name = air temperature at vertical layer for radiation calculation - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[p_lev] - standard_name = air_pressure_at_interface_for_RRTMGP - long_name = air pressure level - units = Pa - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = in -[fluxlwUP_allsky] - standard_name = RRTMGP_lw_flux_profile_upward_allsky - long_name = RRTMGP upward longwave all-sky flux profile - units = W m-2 - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = in -[fluxlwDOWN_allsky] - standard_name = RRTMGP_lw_flux_profile_downward_allsky - long_name = RRTMGP downward longwave all-sky flux profile - units = W m-2 - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = in -[fluxlwUP_clrsky] - standard_name = RRTMGP_lw_flux_profile_upward_clrsky - long_name = RRTMGP upward longwave clr-sky flux profile - units = W m-2 - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = in -[fluxlwDOWN_clrsky] - standard_name = RRTMGP_lw_flux_profile_downward_clrsky - long_name = RRTMGP downward longwave clr-sky flux profile - units = W m-2 - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = in -[raddt] - standard_name = time_step_for_radiation - long_name = radiation time step - units = s - dimensions = () - type = real - kind = kind_phys - intent = in -[cldsa] - standard_name = cloud_area_fraction_for_radiation - long_name = fraction of clouds for low, middle, high, total and BL - units = frac - dimensions = (horizontal_loop_extent,5) - type = real - kind = kind_phys - intent = in -[mtopa] - standard_name = model_layer_number_at_cloud_top - long_name = vertical indices for low, middle and high cloud tops - units = index - dimensions = (horizontal_loop_extent,3) - type = integer - intent = in -[mbota] - standard_name = model_layer_number_at_cloud_base - long_name = vertical indices for low, middle and high cloud bases - units = index - dimensions = (horizontal_loop_extent,3) - type = integer - intent = in -[cld_frac] - standard_name = total_cloud_fraction - long_name = layer total cloud fraction - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cldtaulw] - standard_name = cloud_optical_depth_layers_at_10mu_band - long_name = approx 10mu band layer cloud optical depth - units = none - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[fluxr] - standard_name = cumulative_radiation_diagnostic - long_name = time-accumulated 2D radiation-related diagnostic fields - units = mixed - dimensions = (horizontal_loop_extent,number_of_diagnostics_variables_for_radiation) - type = real - kind = kind_phys - intent = inout -[sfcdlw] - standard_name = surface_downwelling_longwave_flux_on_radiation_timestep - long_name = total sky sfc downward lw flux - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[sfculw] - standard_name = surface_upwelling_longwave_flux_on_radiation_timestep - long_name = total sky sfc upward lw flux - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[sfcflw] - standard_name = surface_lw_fluxes_assuming_total_and_clear_sky_on_radiation_timestep - long_name = lw radiation fluxes at sfc - units = W m-2 - dimensions = (horizontal_loop_extent) - type = sfcflw_type - intent = inout -[tsflw] - standard_name = air_temperature_at_surface_adjacent_layer_on_radiation_timestep - long_name = surface air temp during lw calculation - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[htrlw] - standard_name = tendency_of_air_temperature_due_to_longwave_heating_on_radiation_timestep - long_name = total sky lw heating rate - units = K s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[htrlwu] - standard_name = updated_tendency_of_air_temperature_due_to_longwave_heating_on_physics_timestep - long_name = total sky longwave heating rate on physics time step - units = K s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[topflw] - standard_name = lw_fluxes_top_atmosphere - long_name = lw radiation fluxes at top - units = W m-2 - dimensions = (horizontal_loop_extent) - type = topflw_type - intent = out -[htrlwc] - standard_name = tendency_of_air_temperature_due_to_longwave_heating_assuming_clear_sky_on_radiation_timestep - long_name = longwave clear sky heating rate - units = K s-1 - dimensions = (horizontal_loop_extent,adjusted_vertical_layer_dimension_for_radiation) - type = real - kind = kind_phys - intent = inout -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out diff --git a/physics/GFS_rrtmgp_post.F90 b/physics/GFS_rrtmgp_post.F90 new file mode 100644 index 000000000..42161e4d6 --- /dev/null +++ b/physics/GFS_rrtmgp_post.F90 @@ -0,0 +1,394 @@ +!> \file GFS_rrtmgp_post.F90 +!! +!> \defgroup GFS_rrtmgp_post GFS_rrtmgp_post.F90 +!! +!! \brief RRTMGP post-processing routine. +!! +module GFS_rrtmgp_post + use machine, only: kind_phys + use module_radlw_parameters, only: topflw_type, sfcflw_type + use module_radsw_parameters, only: topfsw_type, sfcfsw_type, cmpfsw_type + use mo_heating_rates, only: compute_heating_rate + use radiation_tools, only: check_error_msg + implicit none + + public GFS_rrtmgp_post_run + +contains + ! ######################################################################################## +!>\defgroup gfs_rrtmgp_post_mod GFS RRTMGP Post Module +!> \section arg_table_GFS_rrtmgp_post_run +!! \htmlinclude GFS_rrtmgp_post.html +!! +!! \ingroup GFS_rrtmgp_post +!! +!! \brief The all-sky radiation tendency is computed, the clear-sky tendency is computed +!! if requested. +!! +!! RRTMGP surface and TOA fluxes are copied to fields that persist between radiation/physics +!! calls. +!! +!! (optional) Save additional diagnostics. +!! +!! \section GFS_rrtmgp_post_run + ! ######################################################################################## + subroutine GFS_rrtmgp_post_run (nCol, nLev, nDay, iSFC, iTOA, idxday, doLWrad, doSWrad, & + do_lw_clrsky_hr, do_sw_clrsky_hr, save_diag, fhlwr, fhswr, sfc_alb_nir_dir, & + sfc_alb_nir_dif, sfc_alb_uvvis_dir, sfc_alb_uvvis_dif, p_lev, tsfa, coszen, coszdg, & + fluxlwDOWN_clrsky, fluxlwUP_allsky, fluxlwDOWN_allsky, fluxlwUP_clrsky, & + fluxswDOWN_clrsky, fluxswUP_allsky, fluxswDOWN_allsky, fluxswUP_clrsky, & + raddt, aerodp, cldsa, mtopa, mbota, cld_frac, cldtaulw, cldtausw, scmpsw, fluxr, & + sfcdlw, sfculw, sfcflw, tsflw, htrlw, htrlwu, topflw, nirbmdi, nirdfdi, visbmdi, & + visdfdi, nirbmui, nirdfui, visbmui, visdfui, sfcnsw, sfcdsw, htrsw, sfcfsw, topfsw, & + htrswc, htrlwc, errmsg, errflg) + + ! Inputs + integer, intent(in) :: & + nCol, & ! Horizontal loop extent + nLev, & ! Number of vertical layers + nDay, & ! Number of daylit columns + iSFC, & ! Vertical index for surface level + iTOA ! Vertical index for TOA level + integer, intent(in), dimension(:) :: & + idxday ! Index array for daytime points + integer, intent(in), dimension(:,:) :: & + mbota, & ! Vertical indices for low, middle and high cloud tops + mtopa ! ertical indices for low, middle and high cloud bases + logical, intent(in) :: & + doLWrad, & ! Logical flags for lw radiation calls + doSWrad, & ! Logical flags for sw radiation calls + do_lw_clrsky_hr, & ! Output clear-sky LW heating-rate? + do_sw_clrsky_hr, & ! Output clear-sky SW heating-rate? + save_diag ! Output radiation diagnostics? + real(kind_phys), intent(in) :: & + fhlwr, & ! Frequency for LW radiation calls + fhswr ! Frequency for SW radiation calls + real(kind_phys), dimension(:), intent(in) :: & + tsfa, & ! Lowest model layer air temperature for radiation (K) + coszen, & ! Cosine(SZA) + coszdg, & ! Cosine(SZA), daytime + sfc_alb_nir_dir, & ! Surface albedo (direct) + sfc_alb_nir_dif, & ! Surface albedo (diffuse) + sfc_alb_uvvis_dir, & ! Surface albedo (direct) + sfc_alb_uvvis_dif ! Surface albedo (diffuse) + real(kind_phys), dimension(:,:), intent(in) :: & + p_lev, & ! Pressure @ model layer-interfaces (Pa) + fluxlwUP_allsky, & ! RRTMGP longwave all-sky flux (W/m2) + fluxlwDOWN_allsky, & ! RRTMGP longwave all-sky flux (W/m2) + fluxlwUP_clrsky, & ! RRTMGP longwave clear-sky flux (W/m2) + fluxlwDOWN_clrsky, & ! RRTMGP longwave clear-sky flux (W/m2) + fluxswUP_allsky, & ! RRTMGP shortwave all-sky flux (W/m2) + fluxswDOWN_allsky, & ! RRTMGP shortwave all-sky flux (W/m2) + fluxswUP_clrsky, & ! RRTMGP shortwave clear-sky flux (W/m2) + fluxswDOWN_clrsky ! RRTMGP shortwave clear-sky flux (W/m2) + real(kind_phys), intent(in) :: & + raddt ! Radiation time step + real(kind_phys), dimension(:,:), intent(in) :: & + aerodp, & ! Vertical integrated optical depth for various aerosol species + cldsa, & ! Fraction of clouds for low, middle, high, total and BL + cld_frac, & ! Total cloud fraction in each layer + cldtaulw, & ! approx 10.mu band layer cloud optical depth + cldtausw ! approx .55mu band layer cloud optical depth + type(cmpfsw_type), dimension(:), intent(in) :: & + scmpsw ! 2D surface fluxes, components: + ! uvbfc - total sky downward uv-b flux at (W/m2) + ! uvbf0 - clear sky downward uv-b flux at (W/m2) + ! nirbm - downward nir direct beam flux (W/m2) + ! nirdf - downward nir diffused flux (W/m2) + ! visbm - downward uv+vis direct beam flux (W/m2) + ! visdf - downward uv+vis diffused flux (W/m2) + + + real(kind=kind_phys), dimension(:,:), intent(inout) :: fluxr + + ! Outputs (mandatory) + real(kind_phys), dimension(:), intent(inout) :: & + tsflw, & ! LW sfc air temp during calculation (K) + sfcdlw, & ! LW sfc all-sky downward flux (W/m2) + sfculw, & ! LW sfc all-sky upward flux (W/m2) + nirbmdi, & ! SW sfc nir beam downward flux (W/m2) + nirdfdi, & ! SW sfc nir diff downward flux (W/m2) + visbmdi, & ! SW sfc uv+vis beam downward flux (W/m2) + visdfdi, & ! SW sfc uv+vis diff downward flux (W/m2) + nirbmui, & ! SW sfc nir beam upward flux (W/m2) + nirdfui, & ! SW sfc nir diff upward flux (W/m2) + visbmui, & ! SW sfc uv+vis beam upward flux (W/m2) + visdfui, & ! SW sfc uv+vis diff upward flux (W/m2) + sfcnsw, & ! SW sfc all-sky net flux (W/m2) flux into ground + sfcdsw ! SW sfc all-sky downward flux (W/m2) + real(kind_phys), dimension(:,:), intent(inout) :: & + htrlw, & ! LW all-sky heating rate (K/s) + htrsw, & ! SW all-sky heating rate (K/s) + htrlwu ! LW all-sky heating-rate updated in-between radiation calls. + type(sfcflw_type), dimension(:), intent(inout) :: & + sfcflw ! LW radiation fluxes at sfc + type(sfcfsw_type), dimension(:), intent(inout) :: & + sfcfsw ! SW radiation fluxes at sfc + type(topfsw_type), dimension(:), intent(out) :: & + topfsw ! SW fluxes at top atmosphere + type(topflw_type), dimension(:), intent(out) :: & + topflw ! LW fluxes at top atmosphere + character(len=*), intent(out) :: & + errmsg ! CCPP error message + integer, intent(out) :: & + errflg ! CCPP error code + + ! Outputs (optional) + real(kind_phys),dimension(:,:),intent(inout),optional :: & + htrlwc, & ! LW clear-sky heating-rate (K/s) + htrswc ! SW clear-sky heating rate (K/s) + + ! Local variables + integer :: i, j, k, itop, ibtc + real(kind_phys) :: tem0d, tem1, tem2 + real(kind_phys), dimension(nDay, nLev) :: thetaTendClrSky, thetaTendAllSky + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (.not. (doLWrad .or. doSWrad)) return + + if (doLWRad) then + ! ####################################################################################### + ! Compute LW heating-rates. + ! ####################################################################################### + + ! Clear-sky heating-rate (optional) + if (do_lw_clrsky_hr) then + call check_error_msg('GFS_rrtmgp_post',compute_heating_rate( & + fluxlwUP_clrsky, & ! IN - RRTMGP upward longwave clear-sky flux profiles (W/m2) + fluxlwDOWN_clrsky, & ! IN - RRTMGP downward longwave clear-sky flux profiles (W/m2) + p_lev, & ! IN - Pressure @ layer-interfaces (Pa) + htrlwc)) ! OUT - Longwave clear-sky heating rate (K/sec) + endif + + ! All-sky heating-rate (mandatory) + call check_error_msg('GFS_rrtmgp_post',compute_heating_rate( & + fluxlwUP_allsky, & ! IN - RRTMGP upward longwave all-sky flux profiles (W/m2) + fluxlwDOWN_allsky, & ! IN - RRTMGP downward longwave all-sky flux profiles (W/m2) + p_lev, & ! IN - Pressure @ layer-interfaces (Pa) + htrlw)) ! OUT - Longwave all-sky heating rate (K/sec) + + ! ####################################################################################### + ! Save LW outputs. + ! (Copy fluxes from RRTMGP types into model radiation types.) + ! ####################################################################################### + ! TOA fluxes + + topflw(:)%upfxc = fluxlwUP_allsky(:,iTOA) + topflw(:)%upfx0 = fluxlwUP_clrsky(:,iTOA) + + ! Surface fluxes + sfcflw(:)%upfxc = fluxlwUP_allsky(:,iSFC) + sfcflw(:)%upfx0 = fluxlwUP_clrsky(:,iSFC) + sfcflw(:)%dnfxc = fluxlwDOWN_allsky(:,iSFC) + sfcflw(:)%dnfx0 = fluxlwDOWN_clrsky(:,iSFC) + + ! Save surface air temp for diurnal adjustment at model t-steps + tsflw (:) = tsfa(:) + + ! Radiation fluxes for other physics processes + sfcdlw(:) = sfcflw(:)%dnfxc + sfculw(:) = sfcflw(:)%upfxc + + ! Heating-rate at radiation timestep, used for adjustment between radiation calls. + htrlwu = htrlw + + ! ####################################################################################### + ! Save LW diagnostics + ! - For time averaged output quantities (including total-sky and clear-sky SW and LW + ! fluxes at TOA and surface; conventional 3-domain cloud amount, cloud top and base + ! pressure, and cloud top temperature; aerosols AOD, etc.), store computed results in + ! corresponding slots of array fluxr with appropriate time weights. + ! - Collect the fluxr data for wrtsfc + ! ####################################################################################### + if (save_diag) then + do i=1,nCol + ! LW all-sky fluxes + fluxr(i,1 ) = fluxr(i,1 ) + fhlwr * fluxlwUP_allsky( i,iTOA) ! total sky top lw up + fluxr(i,19) = fluxr(i,19) + fhlwr * fluxlwDOWN_allsky(i,iSFC) ! total sky sfc lw dn + fluxr(i,20) = fluxr(i,20) + fhlwr * fluxlwUP_allsky( i,iSFC) ! total sky sfc lw up + ! LW clear-sky fluxes + fluxr(i,28) = fluxr(i,28) + fhlwr * fluxlwUP_clrsky( i,iTOA) ! clear sky top lw up + fluxr(i,30) = fluxr(i,30) + fhlwr * fluxlwDOWN_clrsky(i,iSFC) ! clear sky sfc lw dn + fluxr(i,33) = fluxr(i,33) + fhlwr * fluxlwUP_clrsky( i,iSFC) ! clear sky sfc lw up + enddo + + ! Save cld frac,toplyr,botlyr and top temp, note that the order of h,m,l cloud is reversed for + ! the fluxr output. save interface pressure (pa) of top/bot + do j = 1, 3 + do i = 1, nCol + tem0d = raddt * cldsa(i,j) + itop = mtopa(i,j) + ibtc = mbota(i,j) + + ! Add optical depth and emissivity output + tem2 = 0. + do k=ibtc,itop + tem2 = tem2 + cldtaulw(i,k) ! approx 10. mu channel + enddo + fluxr(i,46-j) = fluxr(i,46-j) + tem0d * (1.0-exp(-tem2)) + enddo + enddo + endif + endif + ! ####################################################################################### + ! ####################################################################################### + ! ####################################################################################### + ! ####################################################################################### + ! ####################################################################################### + ! ####################################################################################### + if (doSWRad) then + if (nDay .gt. 0) then + ! ################################################################################# + ! Compute SW heating-rates + ! ################################################################################# + + ! Clear-sky heating-rate (optional) + if (do_sw_clrsky_hr) then + htrswc(:,:) = 0._kind_phys + call check_error_msg('GFS_rrtmgp_post',compute_heating_rate( & + fluxswUP_clrsky(idxday(1:nDay),:), & ! IN - Shortwave upward clear-sky flux profiles (W/m2) + fluxswDOWN_clrsky(idxday(1:nDay),:), & ! IN - Shortwave downward clear-sky flux profiles (W/m2) + p_lev(idxday(1:nDay),:), & ! IN - Pressure at model-interface (Pa) + thetaTendClrSky)) ! OUT - Clear-sky heating-rate (K/sec) + htrswc(idxday(1:nDay),:)=thetaTendClrSky !**NOTE** GP doesn't use radiation levels, it uses the model fields. Not sure if this is necessary + endif + + ! All-sky heating-rate (mandatory) + htrsw(:,:) = 0._kind_phys + call check_error_msg('GFS_rrtmgp_post',compute_heating_rate( & + fluxswUP_allsky(idxday(1:nDay),:), & ! IN - Shortwave upward all-sky flux profiles (W/m2) + fluxswDOWN_allsky(idxday(1:nDay),:), & ! IN - Shortwave downward all-sky flux profiles (W/m2) + p_lev(idxday(1:nDay),:), & ! IN - Pressure at model-interface (Pa) + thetaTendAllSky)) ! OUT - All-sky heating-rate (K/sec) + htrsw(idxday(1:nDay),:) = thetaTendAllSky + + ! ################################################################################# + ! Save SW outputs + ! (Copy fluxes from RRTMGP types into model radiation types.) + ! ################################################################################# + + ! TOA fluxes + topfsw(:)%upfxc = fluxswUP_allsky(:,iTOA) + topfsw(:)%upfx0 = fluxswUP_clrsky(:,iTOA) + topfsw(:)%dnfxc = fluxswDOWN_allsky(:,iTOA) + + ! Surface fluxes + sfcfsw(:)%upfxc = fluxswUP_allsky(:,iSFC) + sfcfsw(:)%upfx0 = fluxswUP_clrsky(:,iSFC) + sfcfsw(:)%dnfxc = fluxswDOWN_allsky(:,iSFC) + sfcfsw(:)%dnfx0 = fluxswDOWN_clrsky(:,iSFC) + + ! Surface down and up spectral component fluxes + ! - Save two spectral bands' surface downward and upward fluxes for output. + do i=1,nCol + nirbmdi(i) = scmpsw(i)%nirbm + nirdfdi(i) = scmpsw(i)%nirdf + visbmdi(i) = scmpsw(i)%visbm + visdfdi(i) = scmpsw(i)%visdf + nirbmui(i) = scmpsw(i)%nirbm * sfc_alb_nir_dir(i) + nirdfui(i) = scmpsw(i)%nirdf * sfc_alb_nir_dif(i) + visbmui(i) = scmpsw(i)%visbm * sfc_alb_uvvis_dir(i) + visdfui(i) = scmpsw(i)%visdf * sfc_alb_uvvis_dif(i) + enddo + else ! if_nday_block + ! ################################################################################# + ! Dark everywhere + ! ################################################################################# + htrsw(:,:) = 0.0 + sfcfsw = sfcfsw_type( 0.0, 0.0, 0.0, 0.0 ) + topfsw = topfsw_type( 0.0, 0.0, 0.0 ) + do i=1,nCol + nirbmdi(i) = 0.0 + nirdfdi(i) = 0.0 + visbmdi(i) = 0.0 + visdfdi(i) = 0.0 + nirbmui(i) = 0.0 + nirdfui(i) = 0.0 + visbmui(i) = 0.0 + visdfui(i) = 0.0 + enddo + + if (do_sw_clrsky_hr) then + htrswc(:,:) = 0 + endif + endif ! end_if_nday + + ! Radiation fluxes for other physics processes + do i=1,nCol + sfcnsw(i) = sfcfsw(i)%dnfxc - sfcfsw(i)%upfxc + sfcdsw(i) = sfcfsw(i)%dnfxc + enddo + + ! ################################################################################# + ! Save SW diagnostics + ! - For time averaged output quantities (including total-sky and clear-sky SW and LW + ! fluxes at TOA and surface; conventional 3-domain cloud amount, cloud top and base + ! pressure, and cloud top temperature; aerosols AOD, etc.), store computed results in + ! corresponding slots of array fluxr with appropriate time weights. + ! - Collect the fluxr data for wrtsfc + ! ################################################################################# + if (save_diag) then + do i=1,nCol + fluxr(i,34) = aerodp(i,1) ! total aod at 550nm + fluxr(i,35) = aerodp(i,2) ! DU aod at 550nm + fluxr(i,36) = aerodp(i,3) ! BC aod at 550nm + fluxr(i,37) = aerodp(i,4) ! OC aod at 550nm + fluxr(i,38) = aerodp(i,5) ! SU aod at 550nm + fluxr(i,39) = aerodp(i,6) ! SS aod at 550nm + if (coszen(i) > 0.) then + ! SW all-sky fluxes + tem0d = fhswr * coszdg(i) / coszen(i) + fluxr(i,2 ) = fluxr(i,2) + topfsw(i)%upfxc * tem0d ! total sky top sw up + fluxr(i,3 ) = fluxr(i,3) + sfcfsw(i)%upfxc * tem0d + fluxr(i,4 ) = fluxr(i,4) + sfcfsw(i)%dnfxc * tem0d ! total sky sfc sw dn + ! SW uv-b fluxes + fluxr(i,21) = fluxr(i,21) + scmpsw(i)%uvbfc * tem0d ! total sky uv-b sw dn + fluxr(i,22) = fluxr(i,22) + scmpsw(i)%uvbf0 * tem0d ! clear sky uv-b sw dn + ! SW TOA incoming fluxes + fluxr(i,23) = fluxr(i,23) + topfsw(i)%dnfxc * tem0d ! top sw dn + ! SW SFC flux components + fluxr(i,24) = fluxr(i,24) + visbmdi(i) * tem0d ! uv/vis beam sw dn + fluxr(i,25) = fluxr(i,25) + visdfdi(i) * tem0d ! uv/vis diff sw dn + fluxr(i,26) = fluxr(i,26) + nirbmdi(i) * tem0d ! nir beam sw dn + fluxr(i,27) = fluxr(i,27) + nirdfdi(i) * tem0d ! nir diff sw dn + ! SW clear-sky fluxes + fluxr(i,29) = fluxr(i,29) + topfsw(i)%upfx0 * tem0d + fluxr(i,31) = fluxr(i,31) + sfcfsw(i)%upfx0 * tem0d + fluxr(i,32) = fluxr(i,32) + sfcfsw(i)%dnfx0 * tem0d + endif + enddo + + ! Save total and boundary-layer clouds + do i=1,nCol + fluxr(i,17) = fluxr(i,17) + raddt * cldsa(i,4) + fluxr(i,18) = fluxr(i,18) + raddt * cldsa(i,5) + enddo + + ! Save cld frac,toplyr,botlyr and top temp, note that the order of h,m,l cloud + ! is reversed for the fluxr output. save interface pressure (pa) of top/bot + do j = 1, 3 + do i = 1, nCol + tem0d = raddt * cldsa(i,j) + itop = mtopa(i,j) + ibtc = mbota(i,j) + fluxr(i, 8-j) = fluxr(i, 8-j) + tem0d + fluxr(i,11-j) = fluxr(i,11-j) + tem0d * p_lev(i,itop) + fluxr(i,14-j) = fluxr(i,14-j) + tem0d * p_lev(i,ibtc) + fluxr(i,17-j) = fluxr(i,17-j) + tem0d * p_lev(i,itop) + + ! Add optical depth and emissivity output + tem1 = 0. + do k=ibtc,itop + tem1 = tem1 + cldtausw(i,k) ! approx .55 mu channel + enddo + fluxr(i,43-j) = fluxr(i,43-j) + tem0d * tem1 + enddo + enddo + endif + endif + + end subroutine GFS_rrtmgp_post_run +end module GFS_rrtmgp_post diff --git a/physics/GFS_rrtmgp_sw_post.meta b/physics/GFS_rrtmgp_post.meta similarity index 70% rename from physics/GFS_rrtmgp_sw_post.meta rename to physics/GFS_rrtmgp_post.meta index 7da3b10b0..0d6859f75 100644 --- a/physics/GFS_rrtmgp_sw_post.meta +++ b/physics/GFS_rrtmgp_post.meta @@ -1,14 +1,13 @@ [ccpp-table-properties] - name = GFS_rrtmgp_sw_post + name = GFS_rrtmgp_post type = scheme - dependencies = iounitdef.f,machine.F,radiation_aerosols.f,radsw_param.f,rte-rrtmgp/extensions/mo_fluxes_byband.F90 - dependencies = rte-rrtmgp/rte/mo_fluxes.F90,rte-rrtmgp/rte/kernels/mo_fluxes_broadband_kernels.F90,rte-rrtmgp/extensions/mo_heating_rates.F90,radiation_tools.F90 + dependencies = iounitdef.f,machine.F,radiation_aerosols.f,radlw_param.f,rte-rrtmgp/extensions/mo_fluxes_byband.F90,radiation_tools.F90,rte-rrtmgp/rte/mo_fluxes.F90,rte-rrtmgp/rte/kernels/mo_fluxes_broadband_kernels.F90,rte-rrtmgp/extensions/mo_heating_rates.F90 ######################################################################## [ccpp-arg-table] - name = GFS_rrtmgp_sw_post_run + name = GFS_rrtmgp_post_run type = scheme -[ncol] +[nCol] standard_name = horizontal_loop_extent long_name = horizontal loop extent units = count @@ -50,7 +49,7 @@ dimensions = (horizontal_loop_extent) type = integer intent = in -[lsswr] +[doSWrad] standard_name = flag_for_calling_shortwave_radiation long_name = logical flags for sw radiation calls units = flag @@ -64,6 +63,20 @@ dimensions = () type = logical intent = in +[doLWrad] + standard_name = flag_for_calling_longwave_radiation + long_name = logical flags for lw radiation calls + units = flag + dimensions = () + type = logical + intent = in +[do_lw_clrsky_hr] + standard_name = flag_for_output_of_tendency_of_air_temperature_due_to_longwave_heating_on_radiation_timestep_assuming_clear_sky + long_name = flag to output lw heating rate + units = flag + dimensions = () + type = logical + intent = in [save_diag] standard_name = flag_for_diagnostics long_name = logical flag for storing diagnostics @@ -71,6 +84,14 @@ dimensions = () type = logical intent = in +[fhlwr] + standard_name = period_of_longwave_radiation_calls + long_name = frequency for longwave radiation + units = s + dimensions = () + type = real + kind = kind_phys + intent = in [fhswr] standard_name = period_of_shortwave_radiation_calls long_name = frequency for shortwave radiation @@ -95,22 +116,6 @@ type = real kind = kind_phys intent = in -[t_lay] - standard_name = air_temperature_at_layer_for_RRTMGP - long_name = air temperature at vertical layer for radiation calculation - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[p_lev] - standard_name = air_pressure_at_interface_for_RRTMGP - long_name = air pressure level - units = Pa - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = in [sfc_alb_nir_dir] standard_name = surface_albedo_due_to_near_IR_direct long_name = surface albedo due to near IR direct beam @@ -143,6 +148,54 @@ type = real kind = kind_phys intent = in +[tsfa] + standard_name = surface_air_temperature_for_radiation + long_name = lowest model layer air temperature for radiation + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[p_lev] + standard_name = air_pressure_at_interface_for_RRTMGP + long_name = air pressure level + units = Pa + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in +[fluxlwUP_allsky] + standard_name = RRTMGP_lw_flux_profile_upward_allsky + long_name = RRTMGP upward longwave all-sky flux profile + units = W m-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in +[fluxlwDOWN_allsky] + standard_name = RRTMGP_lw_flux_profile_downward_allsky + long_name = RRTMGP downward longwave all-sky flux profile + units = W m-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in +[fluxlwUP_clrsky] + standard_name = RRTMGP_lw_flux_profile_upward_clrsky + long_name = RRTMGP upward longwave clr-sky flux profile + units = W m-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in +[fluxlwDOWN_clrsky] + standard_name = RRTMGP_lw_flux_profile_downward_clrsky + long_name = RRTMGP downward longwave clr-sky flux profile + units = W m-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in [fluxswUP_allsky] standard_name = RRTMGP_sw_flux_profile_upward_allsky long_name = RRTMGP upward shortwave all-sky flux profile @@ -199,16 +252,16 @@ type = real kind = kind_phys intent = in -[mbota] - standard_name = model_layer_number_at_cloud_base - long_name = vertical indices for low, middle and high cloud bases +[mtopa] + standard_name = model_layer_number_at_cloud_top + long_name = vertical indices for low, middle and high cloud tops units = index dimensions = (horizontal_loop_extent,3) type = integer intent = in -[mtopa] - standard_name = model_layer_number_at_cloud_top - long_name = vertical indices for low, middle and high cloud tops +[mbota] + standard_name = model_layer_number_at_cloud_base + long_name = vertical indices for low, middle and high cloud bases units = index dimensions = (horizontal_loop_extent,3) type = integer @@ -221,6 +274,14 @@ type = real kind = kind_phys intent = in +[cldtaulw] + standard_name = cloud_optical_depth_layers_at_10mu_band + long_name = approx 10mu band layer cloud optical depth + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in [cldtausw] standard_name = cloud_optical_depth_layers_at_0p55mu_band long_name = approx .55mu band layer cloud optical depth @@ -229,6 +290,13 @@ type = real kind = kind_phys intent = in +[scmpsw] + standard_name = components_of_surface_downward_shortwave_fluxes + long_name = derived type for special components of surface downward shortwave fluxes + units = W m-2 + dimensions = (horizontal_loop_extent) + type = cmpfsw_type + intent = in [fluxr] standard_name = cumulative_radiation_diagnostic long_name = time-accumulated 2D radiation-related diagnostic fields @@ -237,6 +305,60 @@ type = real kind = kind_phys intent = inout +[sfcdlw] + standard_name = surface_downwelling_longwave_flux_on_radiation_timestep + long_name = total sky sfc downward lw flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[sfculw] + standard_name = surface_upwelling_longwave_flux_on_radiation_timestep + long_name = total sky sfc upward lw flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[sfcflw] + standard_name = surface_lw_fluxes_assuming_total_and_clear_sky_on_radiation_timestep + long_name = lw radiation fluxes at sfc + units = W m-2 + dimensions = (horizontal_loop_extent) + type = sfcflw_type + intent = inout +[tsflw] + standard_name = air_temperature_at_surface_adjacent_layer_on_radiation_timestep + long_name = surface air temp during lw calculation + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[htrlw] + standard_name = tendency_of_air_temperature_due_to_longwave_heating_on_radiation_timestep + long_name = total sky lw heating rate + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[htrlwu] + standard_name = updated_tendency_of_air_temperature_due_to_longwave_heating_on_physics_timestep + long_name = total sky longwave heating rate on physics time step + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[topflw] + standard_name = lw_fluxes_top_atmosphere + long_name = lw radiation fluxes at top + units = W m-2 + dimensions = (horizontal_loop_extent) + type = topflw_type + intent = out [nirbmdi] standard_name = surface_downwelling_direct_nir_shortwave_flux_on_radiation_timestep long_name = sfc nir beam sw downward flux @@ -338,7 +460,7 @@ units = W m-2 dimensions = (horizontal_loop_extent) type = topfsw_type - intent = inout + intent = out [htrswc] standard_name = tendency_of_air_temperature_due_to_shortwave_heating_assuming_clear_sky_on_radiation_timestep long_name = clear sky sw heating rates @@ -347,12 +469,13 @@ type = real kind = kind_phys intent = inout -[scmpsw] - standard_name = components_of_surface_downward_shortwave_fluxes - long_name = derived type for special components of surface downward shortwave fluxes - units = W m-2 - dimensions = (horizontal_loop_extent) - type = cmpfsw_type +[htrlwc] + standard_name = tendency_of_air_temperature_due_to_longwave_heating_assuming_clear_sky_on_radiation_timestep + long_name = longwave clear sky heating rate + units = K s-1 + dimensions = (horizontal_loop_extent,adjusted_vertical_layer_dimension_for_radiation) + type = real + kind = kind_phys intent = inout [errmsg] standard_name = ccpp_error_message diff --git a/physics/GFS_rrtmgp_sw_post.F90 b/physics/GFS_rrtmgp_sw_post.F90 deleted file mode 100644 index 76e10df93..000000000 --- a/physics/GFS_rrtmgp_sw_post.F90 +++ /dev/null @@ -1,286 +0,0 @@ -!> \file GFS_rrtmgp_sw_post.F90 -!! -!> \defgroup GFS_rrtmgp_sw_post GFS_rrtmgp_sw_post.F90 -!! -!! \brief RRTMGP Shortwave post-processing routine. -!! -module GFS_rrtmgp_sw_post - use machine, only: kind_phys - use module_radiation_aerosols, only: NSPC1 - use module_radsw_parameters, only: topfsw_type, sfcfsw_type, cmpfsw_type - use mo_heating_rates, only: compute_heating_rate - use radiation_tools, only: check_error_msg - use rrtmgp_sw_gas_optics, only: sw_gas_props - implicit none - - public GFS_rrtmgp_sw_post_run - -contains - -!>\defgroup gfs_rrtmgp_sw_post_mod GFS RRTMGP-SW Post Module -!> \section arg_table_GFS_rrtmgp_sw_post_run -!! \htmlinclude GFS_rrtmgp_sw_post_run.html -!! -!> \ingroup GFS_rrtmgp_sw_post -!! RRTMGP Shortwave post-processing routine. -!! -!! \brief The all-sky shortwave radiation tendency is computed, the clear-sky tendency is -!! computed if requested. -!! -!! RRTMGP surface and TOA fluxes are copied to fields that persist between radiation/physics -!! calls. -!! -!! (optional) Save additional diagnostics. -!! -!! \section GFS_rrtmgp_sw_post_run - ! ######################################################################################### - subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky_hr, & - save_diag, fhswr, coszen, coszdg, t_lay, p_lev, sfc_alb_nir_dir, sfc_alb_nir_dif, & - sfc_alb_uvvis_dir, sfc_alb_uvvis_dif, fluxswUP_allsky, & - fluxswDOWN_allsky, fluxswUP_clrsky, fluxswDOWN_clrsky, raddt, aerodp, cldsa, mbota, & - mtopa, cld_frac, cldtausw, fluxr, iSFC, iTOA, & - nirbmdi, nirdfdi, visbmdi, visdfdi, nirbmui, nirdfui, visbmui, visdfui, sfcnsw, & - sfcdsw, htrsw, sfcfsw, topfsw, htrswc, scmpsw, errmsg, errflg) - - ! Inputs - integer, intent(in) :: & - nCol, & ! Horizontal loop extent - nLev, & ! Number of vertical layers - nDay, & ! Number of daylit columns - iSFC, & ! Vertical index for surface level - iTOA ! Vertical index for TOA level - integer, intent(in), dimension(:) :: & - idxday ! Index array for daytime points - logical, intent(in) :: & - lsswr, & ! Call SW radiation? - do_sw_clrsky_hr, & ! Output clear-sky SW heating-rate? - save_diag ! Output radiation diagnostics? - real(kind_phys), intent(in) :: & - fhswr ! Frequency for SW radiation - real(kind_phys), dimension(nCol), intent(in) :: & - t_lay, & ! Temperature at model layer centers (K) - coszen, & ! Cosine(SZA) - coszdg ! Cosine(SZA), daytime - real(kind_phys), dimension(nCol, nLev+1), intent(in) :: & - p_lev ! Pressure @ model layer-interfaces (Pa) - real(kind_phys), dimension(ncol), intent(in) :: & - sfc_alb_nir_dir, & ! Surface albedo (direct) - sfc_alb_nir_dif, & ! Surface albedo (diffuse) - sfc_alb_uvvis_dir, & ! Surface albedo (direct) - sfc_alb_uvvis_dif ! Surface albedo (diffuse) - real(kind_phys), dimension(nCol, nLev+1), intent(in) :: & - fluxswUP_allsky, & ! SW All-sky flux (W/m2) - fluxswDOWN_allsky, & ! SW All-sky flux (W/m2) - fluxswUP_clrsky, & ! SW Clear-sky flux (W/m2) - fluxswDOWN_clrsky ! SW All-sky flux (W/m2) - real(kind_phys), intent(in) :: & - raddt ! Radiation time step - real(kind_phys), dimension(nCol,NSPC1), intent(in) :: & - aerodp ! Vertical integrated optical depth for various aerosol species - real(kind_phys), dimension(nCol,5), intent(in) :: & - cldsa ! Fraction of clouds for low, middle, high, total and BL - integer, dimension(nCol,3), intent(in) ::& - mbota, & ! vertical indices for low, middle and high cloud tops - mtopa ! vertical indices for low, middle and high cloud bases - real(kind_phys), dimension(nCol,nLev), intent(in) :: & - cld_frac, & ! Total cloud fraction in each layer - cldtausw ! approx .55mu band layer cloud optical depth - type(cmpfsw_type), dimension(nCol), intent(in) :: & - scmpsw ! 2D surface fluxes, components: - ! uvbfc - total sky downward uv-b flux at (W/m2) - ! uvbf0 - clear sky downward uv-b flux at (W/m2) - ! nirbm - downward nir direct beam flux (W/m2) - ! nirdf - downward nir diffused flux (W/m2) - ! visbm - downward uv+vis direct beam flux (W/m2) - ! visdf - downward uv+vis diffused flux (W/m2) - - real(kind=kind_phys), dimension(:,:), intent(inout) :: fluxr - - ! Outputs (mandatory) - real(kind_phys), dimension(nCol), intent(inout) :: & - nirbmdi, & ! sfc nir beam sw downward flux (W/m2) - nirdfdi, & ! sfc nir diff sw downward flux (W/m2) - visbmdi, & ! sfc uv+vis beam sw downward flux (W/m2) - visdfdi, & ! sfc uv+vis diff sw downward flux (W/m2) - nirbmui, & ! sfc nir beam sw upward flux (W/m2) - nirdfui, & ! sfc nir diff sw upward flux (W/m2) - visbmui, & ! sfc uv+vis beam sw upward flux (W/m2) - visdfui, & ! sfc uv+vis diff sw upward flux (W/m2) - sfcnsw, & ! total sky sfc netsw flx into ground - sfcdsw ! - real(kind_phys), dimension(nCol,nLev), intent(inout) :: & - htrsw ! SW all-sky heating rate - type(sfcfsw_type), dimension(nCol), intent(inout) :: & - sfcfsw ! sw radiation fluxes at sfc - type(topfsw_type), dimension(nCol), intent(inout) :: & - topfsw ! sw_fluxes_top_atmosphere - character(len=*), intent(out) :: & - errmsg - integer, intent(out) :: & - errflg - - ! Outputs (optional) - real(kind_phys),dimension(nCol, nLev),intent(inout),optional :: & - htrswc ! Clear-sky heating rate (K/s) - - ! Local variables - integer :: i, j, k, itop, ibtc - real(kind_phys) :: tem0d, tem1, tem2 - real(kind_phys), dimension(nDay, nLev) :: thetaTendClrSky, thetaTendAllSky - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (.not. lsswr) return - if (nDay .gt. 0) then - - ! ####################################################################################### - ! Compute SW heating-rates - ! ####################################################################################### - ! Clear-sky heating-rate (optional) - if (do_sw_clrsky_hr) then - htrswc(:,:) = 0._kind_phys - call check_error_msg('GFS_rrtmgp_post',compute_heating_rate( & - fluxswUP_clrsky(idxday(1:nDay),:), & ! IN - Shortwave upward clear-sky flux profiles (W/m2) - fluxswDOWN_clrsky(idxday(1:nDay),:), & ! IN - Shortwave downward clear-sky flux profiles (W/m2) - p_lev(idxday(1:nDay),:), & ! IN - Pressure at model-interface (Pa) - thetaTendClrSky)) ! OUT - Clear-sky heating-rate (K/sec) - htrswc(idxday(1:nDay),:)=thetaTendClrSky !**NOTE** GP doesn't use radiation levels, it uses the model fields. Not sure if this is necessary - endif - - ! All-sky heating-rate (mandatory) - htrsw(:,:) = 0._kind_phys - call check_error_msg('GFS_rrtmgp_post',compute_heating_rate( & - fluxswUP_allsky(idxday(1:nDay),:), & ! IN - Shortwave upward all-sky flux profiles (W/m2) - fluxswDOWN_allsky(idxday(1:nDay),:), & ! IN - Shortwave downward all-sky flux profiles (W/m2) - p_lev(idxday(1:nDay),:), & ! IN - Pressure at model-interface (Pa) - thetaTendAllSky)) ! OUT - All-sky heating-rate (K/sec) - htrsw(idxday(1:nDay),:) = thetaTendAllSky - - ! ####################################################################################### - ! Save SW outputs - ! (Copy fluxes from RRTMGP types into model radiation types.) - ! ####################################################################################### - - ! TOA fluxes - topfsw(:)%upfxc = fluxswUP_allsky(:,iTOA) - topfsw(:)%upfx0 = fluxswUP_clrsky(:,iTOA) - topfsw(:)%dnfxc = fluxswDOWN_allsky(:,iTOA) - - ! Surface fluxes - sfcfsw(:)%upfxc = fluxswUP_allsky(:,iSFC) - sfcfsw(:)%upfx0 = fluxswUP_clrsky(:,iSFC) - sfcfsw(:)%dnfxc = fluxswDOWN_allsky(:,iSFC) - sfcfsw(:)%dnfx0 = fluxswDOWN_clrsky(:,iSFC) - - ! Surface down and up spectral component fluxes - ! - Save two spectral bands' surface downward and upward fluxes for output. - do i=1,nCol - nirbmdi(i) = scmpsw(i)%nirbm - nirdfdi(i) = scmpsw(i)%nirdf - visbmdi(i) = scmpsw(i)%visbm - visdfdi(i) = scmpsw(i)%visdf - nirbmui(i) = scmpsw(i)%nirbm * sfc_alb_nir_dir(i) - nirdfui(i) = scmpsw(i)%nirdf * sfc_alb_nir_dif(i) - visbmui(i) = scmpsw(i)%visbm * sfc_alb_uvvis_dir(i) - visdfui(i) = scmpsw(i)%visdf * sfc_alb_uvvis_dif(i) - enddo - else ! if_nday_block - ! ####################################################################################### - ! Dark everywhere - ! ####################################################################################### - htrsw(:,:) = 0.0 - sfcfsw = sfcfsw_type( 0.0, 0.0, 0.0, 0.0 ) - topfsw = topfsw_type( 0.0, 0.0, 0.0 ) - do i=1,nCol - nirbmdi(i) = 0.0 - nirdfdi(i) = 0.0 - visbmdi(i) = 0.0 - visdfdi(i) = 0.0 - nirbmui(i) = 0.0 - nirdfui(i) = 0.0 - visbmui(i) = 0.0 - visdfui(i) = 0.0 - enddo - - if (do_sw_clrsky_hr) then - htrswc(:,:) = 0 - endif - endif ! end_if_nday - - ! Radiation fluxes for other physics processes - do i=1,nCol - sfcnsw(i) = sfcfsw(i)%dnfxc - sfcfsw(i)%upfxc - sfcdsw(i) = sfcfsw(i)%dnfxc - enddo - - ! ####################################################################################### - ! Save SW diagnostics - ! - For time averaged output quantities (including total-sky and clear-sky SW and LW - ! fluxes at TOA and surface; conventional 3-domain cloud amount, cloud top and base - ! pressure, and cloud top temperature; aerosols AOD, etc.), store computed results in - ! corresponding slots of array fluxr with appropriate time weights. - ! - Collect the fluxr data for wrtsfc - ! ####################################################################################### - if (save_diag) then - do i=1,nCol - fluxr(i,34) = aerodp(i,1) ! total aod at 550nm - fluxr(i,35) = aerodp(i,2) ! DU aod at 550nm - fluxr(i,36) = aerodp(i,3) ! BC aod at 550nm - fluxr(i,37) = aerodp(i,4) ! OC aod at 550nm - fluxr(i,38) = aerodp(i,5) ! SU aod at 550nm - fluxr(i,39) = aerodp(i,6) ! SS aod at 550nm - if (coszen(i) > 0.) then - ! SW all-sky fluxes - tem0d = fhswr * coszdg(i) / coszen(i) - fluxr(i,2 ) = fluxr(i,2) + topfsw(i)%upfxc * tem0d ! total sky top sw up - fluxr(i,3 ) = fluxr(i,3) + sfcfsw(i)%upfxc * tem0d - fluxr(i,4 ) = fluxr(i,4) + sfcfsw(i)%dnfxc * tem0d ! total sky sfc sw dn - ! SW uv-b fluxes - fluxr(i,21) = fluxr(i,21) + scmpsw(i)%uvbfc * tem0d ! total sky uv-b sw dn - fluxr(i,22) = fluxr(i,22) + scmpsw(i)%uvbf0 * tem0d ! clear sky uv-b sw dn - ! SW TOA incoming fluxes - fluxr(i,23) = fluxr(i,23) + topfsw(i)%dnfxc * tem0d ! top sw dn - ! SW SFC flux components - fluxr(i,24) = fluxr(i,24) + visbmdi(i) * tem0d ! uv/vis beam sw dn - fluxr(i,25) = fluxr(i,25) + visdfdi(i) * tem0d ! uv/vis diff sw dn - fluxr(i,26) = fluxr(i,26) + nirbmdi(i) * tem0d ! nir beam sw dn - fluxr(i,27) = fluxr(i,27) + nirdfdi(i) * tem0d ! nir diff sw dn - ! SW clear-sky fluxes - fluxr(i,29) = fluxr(i,29) + topfsw(i)%upfx0 * tem0d - fluxr(i,31) = fluxr(i,31) + sfcfsw(i)%upfx0 * tem0d - fluxr(i,32) = fluxr(i,32) + sfcfsw(i)%dnfx0 * tem0d - endif - enddo - - ! Save total and boundary-layer clouds - do i=1,nCol - fluxr(i,17) = fluxr(i,17) + raddt * cldsa(i,4) - fluxr(i,18) = fluxr(i,18) + raddt * cldsa(i,5) - enddo - - ! Save cld frac,toplyr,botlyr and top temp, note that the order of h,m,l cloud - ! is reversed for the fluxr output. save interface pressure (pa) of top/bot - do j = 1, 3 - do i = 1, nCol - tem0d = raddt * cldsa(i,j) - itop = mtopa(i,j) - ibtc = mbota(i,j) - fluxr(i, 8-j) = fluxr(i, 8-j) + tem0d - fluxr(i,11-j) = fluxr(i,11-j) + tem0d * p_lev(i,itop) - fluxr(i,14-j) = fluxr(i,14-j) + tem0d * p_lev(i,ibtc) - fluxr(i,17-j) = fluxr(i,17-j) + tem0d * p_lev(i,itop) - - ! Add optical depth and emissivity output - tem1 = 0. - do k=ibtc,itop - tem1 = tem1 + cldtausw(i,k) ! approx .55 mu channel - enddo - fluxr(i,43-j) = fluxr(i,43-j) + tem0d * tem1 - enddo - enddo - endif - end subroutine GFS_rrtmgp_sw_post_run - -end module GFS_rrtmgp_sw_post diff --git a/physics/rrtmgp_aerosol_optics.F90 b/physics/rrtmgp_aerosol_optics.F90 index c8c4991fe..cf3f7deea 100644 --- a/physics/rrtmgp_aerosol_optics.F90 +++ b/physics/rrtmgp_aerosol_optics.F90 @@ -3,16 +3,10 @@ module rrtmgp_aerosol_optics use machine, only: kind_phys - use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp - use mo_optical_props, only: ty_optical_props_2str, ty_optical_props_1scl use radiation_tools, only: check_error_msg use rrtmgp_sw_gas_optics, only: sw_gas_props use rrtmgp_lw_gas_optics, only: lw_gas_props - use module_radiation_aerosols, only: & - NF_AESW, & ! Number of optical-fields in SW output (3=tau+g+omega) - NF_AELW, & ! Number of optical-fields in LW output (3=tau+g+omega) - setaer, & ! Routine to compute aerosol radiative properties (tau,g,omega) - NSPC1 ! Number of species for vertically integrated aerosol optical-depth + use module_radiation_aerosols, only: setaer use netcdf implicit none @@ -30,9 +24,9 @@ module rrtmgp_aerosol_optics !! \section arg_table_rrtmgp_aerosol_optics_run !! \htmlinclude rrtmgp_aerosol_optics_run.html !! - subroutine rrtmgp_aerosol_optics_run(doSWrad, doLWrad, nCol, nLev, & - nDay, idxday, p_lev, p_lay, p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, & - aerodp, sw_optical_props_aerosol, lw_optical_props_aerosol, errmsg, errflg ) + subroutine rrtmgp_aerosol_optics_run(doSWrad, doLWrad, nCol, nLev, nDay, idxday, p_lev, & + p_lay, p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, & + aerodp, aerlw_tau, aerlw_ssa, aerlw_g, aersw_tau, aersw_ssa, aersw_g, errmsg, errflg ) ! Inputs logical, intent(in) :: & @@ -63,19 +57,22 @@ subroutine rrtmgp_aerosol_optics_run(doSWrad, doLWrad, nCol, nLev, & ! Outputs real(kind_phys), dimension(:,:), intent(out) :: & aerodp ! Vertical integrated optical depth for various aerosol species - type(ty_optical_props_2str),intent(out) :: & - sw_optical_props_aerosol ! RRTMGP DDT: Longwave aerosol optical properties (tau) - type(ty_optical_props_1scl),intent(out) :: & - lw_optical_props_aerosol ! RRTMGP DDT: Longwave aerosol optical properties (tau) + real(kind_phys), dimension(:,:,:), intent(out) :: & + aerlw_tau, & ! Longwave aerosol optical depth + aerlw_ssa, & ! Longwave aerosol single scattering albedo + aerlw_g, & ! Longwave aerosol asymmetry parameter + aersw_tau, & ! Shortwave aerosol optical depth + aersw_ssa, & ! Shortwave aerosol single scattering albedo + aersw_g ! Shortwave aerosol asymmetry parameter integer, intent(out) :: & errflg ! CCPP error flag character(len=*), intent(out) :: & errmsg ! CCPP error message ! Local variables - real(kind_phys), dimension(nCol, nLev, lw_gas_props%get_nband(), NF_AELW) :: & + real(kind_phys), dimension(nCol, nLev, lw_gas_props%get_nband(), 3) :: & aerosolslw ! - real(kind_phys), dimension(nCol, nLev, sw_gas_props%get_nband(), NF_AESW) :: & + real(kind_phys), dimension(nCol, nLev, sw_gas_props%get_nband(), 3) :: & aerosolssw, aerosolssw2 integer :: iBand @@ -101,22 +98,18 @@ subroutine rrtmgp_aerosol_optics_run(doSWrad, doLWrad, nCol, nLev, & aerosolssw(1:nCol,:,2:sw_gas_props%get_nband(),1) = aerosolssw2(1:nCol,:,1:sw_gas_props%get_nband()-1,1) aerosolssw(1:nCol,:,2:sw_gas_props%get_nband(),2) = aerosolssw2(1:nCol,:,1:sw_gas_props%get_nband()-1,2) aerosolssw(1:nCol,:,2:sw_gas_props%get_nband(),3) = aerosolssw2(1:nCol,:,1:sw_gas_props%get_nband()-1,3) - - ! Allocate RRTMGP DDT: Aerosol optics [nCol,nlev,nBands] - call check_error_msg('rrtmgp_aerosol_optics_run',sw_optical_props_aerosol%alloc_2str( & - nDay, nlev, sw_gas_props%get_band_lims_wavenumber())) - - ! Copy aerosol optical information to RRTMGP DDT - sw_optical_props_aerosol%tau = aerosolssw(idxday(1:nday),:,:,1) - sw_optical_props_aerosol%ssa = aerosolssw(idxday(1:nday),:,:,2) - sw_optical_props_aerosol%g = aerosolssw(idxday(1:nday),:,:,3) + + ! Copy aerosol optical information/ + aersw_tau = aerosolssw(:,:,:,1) + aersw_ssa = aerosolssw(:,:,:,2) + aersw_g = aerosolssw(:,:,:,3) endif ! Longwave if (doLWrad) then - call check_error_msg('rrtmgp_aerosol_optics_run',lw_optical_props_aerosol%alloc_1scl( & - nCol, nlev, lw_gas_props%get_band_lims_wavenumber())) - lw_optical_props_aerosol%tau = aerosolslw(:,:,:,1) * (1. - aerosolslw(:,:,:,2)) + aerlw_tau = aerosolslw(:,:,:,1) + aerlw_ssa = aerosolslw(:,:,:,2) + aerlw_g = aerosolslw(:,:,:,3) endif end subroutine rrtmgp_aerosol_optics_run diff --git a/physics/rrtmgp_aerosol_optics.meta b/physics/rrtmgp_aerosol_optics.meta index dee342fb5..6dbf9c73c 100644 --- a/physics/rrtmgp_aerosol_optics.meta +++ b/physics/rrtmgp_aerosol_optics.meta @@ -137,19 +137,53 @@ type = real kind = kind_phys intent = out -[sw_optical_props_aerosol] - standard_name = shortwave_optical_properties_for_aerosols - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str +[aersw_tau] + standard_name = aerosol_optical_depth_for_shortwave_bands_01_16 + long_name = aerosol optical depth for shortwave bands 01-16 + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_aerosol_bands_for_shortwave_radiation) + type = real + kind = kind_phys intent = out -[lw_optical_props_aerosol] - standard_name = longwave_optical_properties_for_aerosols - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_1scl +[aersw_ssa] + standard_name = aerosol_single_scattering_albedo_for_shortwave_bands_01_16 + long_name = aerosol single scattering albedo for shortwave bands 01-16 + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_aerosol_bands_for_shortwave_radiation) + type = real + kind = kind_phys + intent = out +[aersw_g] + standard_name = aerosol_asymmetry_parameter_for_shortwave_bands_01_16 + long_name = aerosol asymmetry parameter for shortwave bands 01-16 + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_aerosol_bands_for_shortwave_radiation) + type = real + kind = kind_phys + intent = out +[aerlw_tau] + standard_name = aerosol_optical_depth_for_longwave_bands_01_16 + long_name = aerosol optical depth for longwave bands 01-16 + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_aerosol_bands_for_longwave_radiation) + type = real + kind = kind_phys + intent = out +[aerlw_ssa] + standard_name = aerosol_single_scattering_albedo_for_longwave_bands_01_16 + long_name = aerosol single scattering albedo for longwave bands 01-16 + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_aerosol_bands_for_longwave_radiation) + type = real + kind = kind_phys + intent = out +[aerlw_g] + standard_name = aerosol_asymmetry_parameter_for_longwave_bands_01_16 + long_name = aerosol asymmetry parameter for longwave bands 01-16 + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_aerosol_bands_for_longwave_radiation) + type = real + kind = kind_phys intent = out [errmsg] standard_name = ccpp_error_message diff --git a/physics/rrtmgp_lw_main.F90 b/physics/rrtmgp_lw_main.F90 index 0277b276a..df46e8eda 100644 --- a/physics/rrtmgp_lw_main.F90 +++ b/physics/rrtmgp_lw_main.F90 @@ -109,10 +109,9 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, & cld_rwp, cld_rerain, precip_frac, cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, & cld_cnv_reice, cld_pbl_lwp, cld_pbl_reliq, cld_pbl_iwp, cld_pbl_reice, & - cloud_overlap_param, active_gases_array, & - lw_optical_props_aerosol, fluxlwUP_allsky, fluxlwDOWN_allsky, & - fluxlwUP_clrsky, fluxlwDOWN_clrsky, fluxlwUP_jac, fluxlwUP_radtime, & - fluxlwDOWN_radtime, errmsg, errflg) + cloud_overlap_param, active_gases_array, aerlw_tau, aerlw_ssa, aerlw_g, & + fluxlwUP_allsky, fluxlwDOWN_allsky, fluxlwUP_clrsky, fluxlwDOWN_clrsky, & + fluxlwUP_jac, fluxlwUP_radtime, fluxlwDOWN_radtime, errmsg, errflg) ! Inputs logical, intent(in) :: & @@ -173,10 +172,12 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, cld_pbl_iwp, & ! Water path for PBL ice cloud-particles cld_pbl_reice, & ! Effective radius for PBL ice cloud-particles cloud_overlap_param ! Cloud overlap parameter + real(kind_phys), dimension(:,:,:), intent(in) :: & + aerlw_tau, & ! Aerosol optical depth + aerlw_ssa, & ! Aerosol single scattering albedo + aerlw_g ! Aerosol asymmetry paramter character(len=*), dimension(:), intent(in) :: & active_gases_array ! List of active gases from namelist as array - type(ty_optical_props_1scl),intent(inout) :: & - lw_optical_props_aerosol ! RRTMGP DDT: Longwave aerosol optical properties (tau) ! Outputs real(kind_phys), dimension(:,:), intent(inout) :: & @@ -482,7 +483,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, ! ! ################################################################################### ! Add aerosol optics to gas optics - lw_optical_props_aerosol_local%tau = lw_optical_props_aerosol%tau(iCol:iCol2,:,:) + lw_optical_props_aerosol_local%tau = aerlw_tau(iCol:iCol2,:,:) call check_error_msg('rrtmgp_lw_main_increment_aerosol_to_clrsky',& lw_optical_props_aerosol_local%increment(lw_optical_props_clrsky)) diff --git a/physics/rrtmgp_lw_main.meta b/physics/rrtmgp_lw_main.meta index 334a75607..c4a0ec9ee 100644 --- a/physics/rrtmgp_lw_main.meta +++ b/physics/rrtmgp_lw_main.meta @@ -555,12 +555,29 @@ type = character kind = len=* intent = in -[lw_optical_props_aerosol] - standard_name = longwave_optical_properties_for_aerosols - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_1scl +[aerlw_tau] + standard_name = aerosol_optical_depth_for_longwave_bands_01_16 + long_name = aerosol optical depth for longwave bands 01-16 + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_aerosol_bands_for_longwave_radiation) + type = real + kind = kind_phys + intent = in +[aerlw_ssa] + standard_name = aerosol_single_scattering_albedo_for_longwave_bands_01_16 + long_name = aerosol single scattering albedo for longwave bands 01-16 + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_aerosol_bands_for_longwave_radiation) + type = real + kind = kind_phys + intent = in +[aerlw_g] + standard_name = aerosol_asymmetry_parameter_for_longwave_bands_01_16 + long_name = aerosol asymmetry parameter for longwave bands 01-16 + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_aerosol_bands_for_longwave_radiation) + type = real + kind = kind_phys intent = in [fluxlwUP_radtime] standard_name = RRTMGP_lw_flux_profile_upward_allsky_on_radiation_timestep diff --git a/physics/rrtmgp_sw_cloud_optics.F90 b/physics/rrtmgp_sw_cloud_optics.F90 index a750a549b..287fab719 100644 --- a/physics/rrtmgp_sw_cloud_optics.F90 +++ b/physics/rrtmgp_sw_cloud_optics.F90 @@ -2,7 +2,6 @@ module rrtmgp_sw_cloud_optics use machine, only: kind_phys use mo_rte_kind, only: wl use mo_cloud_optics, only: ty_cloud_optics - use mo_optical_props, only: ty_optical_props_2str use rrtmgp_sw_gas_optics, only: sw_gas_props use radiation_tools, only: check_error_msg use netcdf @@ -386,184 +385,4 @@ subroutine rrtmgp_sw_cloud_optics_init(doG_cldoptics, doGP_cldoptics_PADE, 0.970, 0.970, 0.970, 0.700, 0.700, 0.700, 0.700/) end subroutine rrtmgp_sw_cloud_optics_init - - ! ######################################################################################### - ! SUBROTUINE rrtmgp_sw_cloud_optics_run() - ! ######################################################################################### -!! \section arg_table_rrtmgp_sw_cloud_optics_run -!! \htmlinclude rrtmgp_sw_cloud_optics.html -!! - subroutine rrtmgp_sw_cloud_optics_run(doSWrad, doG_cldoptics, icliq_sw, icice_sw, & - doGP_cldoptics_PADE, doGP_cldoptics_LUT, do_mynnedmf, imfdeepcnv, imfdeepcnv_gf, & - imfdeepcnv_samf, nCol, nLev, nDay, nbndsGPsw, idxday, cld_frac, cld_lwp, cld_reliq, & - cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, cld_rerain, precip_frac, & - cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, cld_cnv_reice, cld_pbl_lwp, cld_pbl_reliq, & - cld_pbl_iwp, cld_pbl_reice, sw_optical_props_cloudsByBand, & - sw_optical_props_cnvcloudsByBand, sw_optical_props_precipByBand, & - sw_optical_props_MYNNcloudsByBand, cldtausw, errmsg, errflg) - - ! Inputs - logical, intent(in) :: & - doSWrad, & ! Logical flag for shortwave radiation call - doG_cldoptics, & ! Use legacy RRTMG cloud-optics? - doGP_cldoptics_PADE, & ! Use RRTMGP cloud-optics: PADE approximation? - doGP_cldoptics_LUT, & ! Use RRTMGP cloud-optics: LUTs? - do_mynnedmf ! - integer, intent(in) :: & - nbndsGPsw, & ! Number of shortwave bands - nCol, & ! Number of horizontal gridpoints - nLev, & ! Number of vertical levels - nday, & ! Number of daylit points. - icliq_sw, & ! Choice of treatment of liquid cloud optical properties (RRTMG legacy) - icice_sw, & ! Choice of treatment of ice cloud optical properties (RRTMG legacy) - imfdeepcnv, & ! - imfdeepcnv_gf, & ! - imfdeepcnv_samf ! - integer,intent(in),dimension(:) :: & - idxday ! Indices for daylit points. - real(kind_phys), dimension(:,:),intent(in) :: & - cld_frac, & ! Total cloud fraction by layer - cld_lwp, & ! Cloud liquid water path - cld_reliq, & ! Cloud liquid effective radius - cld_iwp, & ! Cloud ice water path - cld_reice, & ! Cloud ice effective radius - cld_swp, & ! Cloud snow water path - cld_resnow, & ! Cloud snow effective radius - cld_rwp, & ! Cloud rain water path - cld_rerain, & ! Cloud rain effective radius - precip_frac, & ! Precipitation fraction by layer - cld_cnv_lwp, & ! Water path for convective liquid cloud-particles (microns) - cld_cnv_reliq, & ! Effective radius for convective liquid cloud-particles (microns) - cld_cnv_iwp, & ! Water path for convective ice cloud-particles (microns) - cld_cnv_reice, & ! Effective radius for convective ice cloud-particles (microns) - cld_pbl_lwp, & ! Water path for SGS PBL liquid cloud-particles - cld_pbl_reliq, & ! Effective radius for SGS PBL liquid cloud-particles - cld_pbl_iwp, & ! Water path for SGS PBL ice cloud-particles - cld_pbl_reice ! Effective radius for SGS PBL ice cloud-particles - ! Outputs - character(len=*), intent(out) :: & - errmsg ! CCPP error message - integer, intent(out) :: & - errflg ! CCPP error flag - type(ty_optical_props_2str),intent(out) :: & - sw_optical_props_cloudsByBand, & ! RRTMGP DDT: Shortwave optical properties in each band (clouds) - sw_optical_props_cnvcloudsByBand, & ! RRTMGP DDT: Shortwave optical properties in each band (convective cloud) - sw_optical_props_MYNNcloudsByBand,& ! RRTMGP DDT: Shortwave optical properties in each band (MYNN PBL cloud) - sw_optical_props_precipByBand ! RRTMGP DDT: Shortwave optical properties in each band (cloud precipitation) - real(kind_phys), dimension(:,:), intent(out) :: & - cldtausw ! Approx 10.mu band layer cloud optical depth - - ! Local variables - integer :: iDay, iLay, iBand - real(kind_phys) :: tau_rain, tau_snow, ssa_rain, ssa_snow, asy_rain, asy_snow, & - tau_prec, asy_prec, ssa_prec, asyw, ssaw, za1, za2 - real(kind_phys), dimension(nday,nLev,nbndsGPsw) :: & - tau_cld, ssa_cld, asy_cld, tau_precip, ssa_precip, asy_precip - type(ty_optical_props_2str) :: sw_optical_props_cloudsByBand_daylit - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (.not. doSWrad) return - - ! Only process sunlit points... - if (nDay .gt. 0) then - - ! Compute cloud/precipitation optics. - if (doGP_cldoptics_PADE .or. doGP_cldoptics_LUT) then - ! i) Cloud-optics. - call check_error_msg('rrtmgp_sw_cloud_optics_run - sw_optical_props_cloudsByBand',& - sw_optical_props_cloudsByBand%alloc_2str(nday, nLev, sw_cloud_props%get_band_lims_wavenumber())) - - call check_error_msg('rrtmgp_sw_cloud_optics_run - clouds',sw_cloud_props%cloud_optics(& - cld_lwp(idxday(1:nday),:), & ! IN - Cloud liquid water path - cld_iwp(idxday(1:nday),:), & ! IN - Cloud ice water path - cld_reliq(idxday(1:nday),:), & ! IN - Cloud liquid effective radius - cld_reice(idxday(1:nday),:), & ! IN - Cloud ice effective radius - sw_optical_props_cloudsByBand)) ! OUT - RRTMGP DDT: Shortwave optical properties, - ! in each band (tau,ssa,g) - - ! ii) Convective cloud-optics - if (imfdeepcnv == imfdeepcnv_samf .or. imfdeepcnv == imfdeepcnv_gf) then - call check_error_msg('rrtmgp_sw_cloud_optics_run - sw_optical_props_cnvcloudsByBand',& - sw_optical_props_cnvcloudsByBand%alloc_2str(nday, nLev, sw_cloud_props%get_band_lims_wavenumber())) - - call check_error_msg('rrtmgp_sw_cloud_optics_run - convective clouds',sw_cloud_props%cloud_optics(& - cld_cnv_lwp(idxday(1:nday),:), & ! IN - Convective cloud liquid water path - cld_cnv_iwp(idxday(1:nday),:), & ! IN - Convective cloud ice water path - cld_cnv_reliq(idxday(1:nday),:), & ! IN - Convective cloud liquid effective radius - cld_cnv_reice(idxday(1:nday),:), & ! IN - Convective cloud ice effective radius - sw_optical_props_cnvcloudsByBand)) ! OUT - RRTMGP DDT: Shortwave optical properties, - ! in each band (tau,ssa,g) - endif - - ! iii) MYNN cloud-optics - if (do_mynnedmf) then - call check_error_msg('rrtmgp_sw_cloud_optics_run - sw_optical_props_MYNNcloudsByBand',& - sw_optical_props_MYNNcloudsByBand%alloc_2str(nday, nLev, sw_cloud_props%get_band_lims_wavenumber())) - - call check_error_msg('rrtmgp_sw_MYNNcloud_optics_run - MYNN-EDMF cloud',sw_cloud_props%cloud_optics(& - cld_pbl_lwp(idxday(1:nday),:), & ! IN - MYNN-EDMF PBL cloud liquid water path (g/m2) - cld_pbl_iwp(idxday(1:nday),:), & ! IN - MYNN-EDMF PBL cloud ice water path (g/m2) - cld_pbl_reliq(idxday(1:nday),:), & ! IN - MYNN-EDMF PBL cloud liquid effective radius (microns) - cld_pbl_reice(idxday(1:nday),:), & ! IN - MYNN-EDMF PBL cloud ice effective radius (microns) - sw_optical_props_MYNNcloudsByBand)) ! OUT - RRTMGP DDT containing MYNN-EDMF PBL cloud radiative properties - ! in each band - endif - - ! iv) Cloud precipitation optics: rain and snow(+groupel) - call check_error_msg('rrtmgp_sw_cloud_optics_run - sw_optical_props_precipByBand',& - sw_optical_props_precipByBand%alloc_2str(nday, nLev, sw_cloud_props%get_band_lims_wavenumber())) - sw_optical_props_precipByBand%tau(:,:,:) = 0._kind_phys - sw_optical_props_precipByBand%ssa(:,:,:) = 1._kind_phys - sw_optical_props_precipByBand%g(:,:,:) = 0._kind_phys - - do iDay=1,nDay - do iLay=1,nLev - if (cld_frac(idxday(iDay),iLay) .gt. 1.e-12_kind_phys) then - ! Rain/Snow optical depth (No band dependence) - tau_rain = cld_rwp(idxday(iDay),iLay)*a0r - if (cld_swp(idxday(iDay),iLay) .gt. 0. .and. cld_resnow(idxday(iDay),iLay) .gt. 10._kind_phys) then - tau_snow = cld_swp(idxday(iDay),iLay)*1.09087*(a0s + a1s/(1.0315*cld_resnow(idxday(iDay),iLay))) ! fu's formula - else - tau_snow = 0._kind_phys - endif - - ! Rain/Snow single-scattering albedo and asymmetry (Band dependent) - do iBand=1,nbndsGPsw - ! By species - ssa_rain = tau_rain*(1.-b0r(iBand)) - asy_rain = ssa_rain*c0r(iBand) - ssa_snow = tau_snow*(1.-(b0s(iBand)+b1s(iBand)*1.0315*cld_resnow(idxday(iDay),iLay))) - asy_snow = ssa_snow*c0s(iBand) - ! Combine - tau_prec = max(1.e-12_kind_phys, tau_rain + tau_snow) - ssa_prec = max(1.e-12_kind_phys, ssa_rain + ssa_snow) - asy_prec = max(1.e-12_kind_phys, asy_rain + asy_snow) - asyw = asy_prec/max(1.e-12_kind_phys, ssa_prec) - ssaw = min(1._kind_phys-0.000001, ssa_prec/tau_prec) - za1 = asyw * asyw - za2 = ssaw * za1 - sw_optical_props_precipByBand%tau(iDay,iLay,iBand) = (1._kind_phys - za2) * tau_prec - sw_optical_props_precipByBand%ssa(iDay,iLay,iBand) = (ssaw - za2) / (1._kind_phys - za2) - sw_optical_props_precipByBand%g(iDay,iLay,iBand) = asyw/(1+asyw) - enddo - endif - enddo - enddo - endif - - ! All-sky SW optical depth ~0.55microns (DJS asks: Move to cloud diagnostics?) - cldtausw(idxday(1:nDay),:) = sw_optical_props_cloudsByBand%tau(:,:,11) - endif - - end subroutine rrtmgp_sw_cloud_optics_run - - ! ######################################################################################### - ! SUBROTUINE rrtmgp_sw_cloud_optics_finalize() - ! ######################################################################################### - subroutine rrtmgp_sw_cloud_optics_finalize() - end subroutine rrtmgp_sw_cloud_optics_finalize - end module rrtmgp_sw_cloud_optics diff --git a/physics/rrtmgp_sw_gas_optics.F90 b/physics/rrtmgp_sw_gas_optics.F90 index 4bafa56a4..823cdc1ca 100644 --- a/physics/rrtmgp_sw_gas_optics.F90 +++ b/physics/rrtmgp_sw_gas_optics.F90 @@ -14,7 +14,6 @@ module rrtmgp_sw_gas_optics use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp use mo_gas_concentrations, only: ty_gas_concs use radiation_tools, only: check_error_msg - use mo_optical_props, only: ty_optical_props_2str use netcdf #ifdef MPI use mpi @@ -126,7 +125,6 @@ subroutine rrtmgp_sw_gas_optics_init(rrtmgp_root_dir, rrtmgp_sw_file_gas, character(len=264) :: sw_gas_props_file type(ty_gas_concs) :: gas_concentrations ! RRTMGP DDT containing active trace gases - ! Initialize errmsg = '' errflg = 0 @@ -504,113 +502,6 @@ subroutine rrtmgp_sw_gas_optics_init(rrtmgp_root_dir, rrtmgp_sw_file_gas, sb_defaultSW, rayl_lowerSW, rayl_upperSW)) end subroutine rrtmgp_sw_gas_optics_init - -!> @} - ! ###################################################################################### -!> \section arg_table_rrtmgp_sw_gas_optics_run -!! \htmlinclude rrtmgp_sw_gas_optics.html -!! -!> \ingroup rrtmgp_sw_gas_optics -!! -!! Compute shortwave optical prperties (optical-depth, single-scattering albedo, -!! asymmetry parameter) for clear-sky conditions. -!! -!! \section rrtmgp_sw_gas_optics_run -!> @{ - ! ###################################################################################### - subroutine rrtmgp_sw_gas_optics_run(doSWrad, nCol, nLev, ngptsGPsw, nday, idxday, p_lay, & - p_lev, toa_src_sw, t_lay, t_lev, active_gases_array, gas_concentrations, solcon, & - sw_optical_props_clrsky, errmsg, errflg) - - ! Inputs - logical, intent(in) :: & - doSWrad ! Flag to calculate SW irradiances - integer,intent(in) :: & - ngptsGPsw, & ! Number of spectral (g) points. - nDay, & ! Number of daylit points. - nCol, & ! Number of horizontal points - nLev ! Number of vertical levels - integer,intent(in),dimension(ncol) :: & - idxday ! Indices for daylit points. - real(kind_phys), dimension(ncol,nLev), intent(in) :: & - p_lay, & ! Pressure @ model layer-centers (Pa) - t_lay ! Temperature (K) - real(kind_phys), dimension(ncol,nLev+1), intent(in) :: & - p_lev, & ! Pressure @ model layer-interfaces (Pa) - t_lev ! Temperature @ model levels - type(ty_gas_concs),intent(inout) :: & - gas_concentrations ! RRTMGP DDT: trace gas concentrations (vmr) - real(kind_phys), intent(in) :: & - solcon ! Solar constant - - ! Output - character(len=*), intent(out) :: & - errmsg ! CCPP error message - integer, intent(out) :: & - errflg ! CCPP error code - type(ty_optical_props_2str),intent(out) :: & - sw_optical_props_clrsky ! RRTMGP DDT: clear-sky shortwave optical properties, spectral (tau,ssa,g) - real(kind_phys), dimension(nCol,ngptsGPsw), intent(out) :: & - toa_src_sw ! TOA incident spectral flux (W/m2) - character(len=*), dimension(:), intent(in) :: & - active_gases_array ! List of active gases from namelist as array - - ! Local variables - integer :: ij,iGas - real(kind_phys), dimension(ncol,nLev) :: vmrTemp - real(kind_phys), dimension(nday,ngptsGPsw) :: toa_src_sw_temp - type(ty_gas_concs) :: gas_concentrations_daylit - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (.not. doSWrad) return - - gas_concentrations%gas_name(:) = active_gases_array(:) - - toa_src_sw(:,:) = 0._kind_phys - if (nDay .gt. 0) then - ! Allocate space - call check_error_msg('rrtmgp_sw_gas_optics_run_alloc_2str',& - sw_optical_props_clrsky%alloc_2str(nday, nLev, sw_gas_props)) - - gas_concentrations_daylit%ncol = nDay - gas_concentrations_daylit%nlay = nLev - allocate(gas_concentrations_daylit%gas_name(gas_concentrations%get_num_gases())) - allocate(gas_concentrations_daylit%concs(gas_concentrations%get_num_gases())) - do iGas=1,gas_concentrations%get_num_gases() - allocate(gas_concentrations_daylit%concs(iGas)%conc(nDay, nLev)) - enddo - gas_concentrations_daylit%gas_name(:) = active_gases_array(:) - - ! Subset the gas concentrations. - do iGas=1,gas_concentrations%get_num_gases() - call check_error_msg('rrtmgp_sw_gas_optics_run_get_vmr',& - gas_concentrations%get_vmr(trim(gas_concentrations_daylit%gas_name(iGas)),vmrTemp)) - call check_error_msg('rrtmgp_sw_gas_optics_run_set_vmr',& - gas_concentrations_daylit%set_vmr(trim(gas_concentrations_daylit%gas_name(iGas)),vmrTemp(idxday(1:nday),:))) - enddo - - ! Call SW gas-optics - call check_error_msg('rrtmgp_sw_gas_optics_run',sw_gas_props%gas_optics(& - p_lay(idxday(1:nday),:), & ! IN - Pressure @ layer-centers (Pa) - p_lev(idxday(1:nday),:), & ! IN - Pressure @ layer-interfaces (Pa) - t_lay(idxday(1:nday),:), & ! IN - Temperature @ layer-centers (K) - gas_concentrations_daylit, & ! IN - RRTMGP DDT: trace gas volumne mixing-ratios - sw_optical_props_clrsky, & ! OUT - RRTMGP DDT: Shortwave optical properties, by - ! spectral point (tau,ssa,g) - toa_src_sw_temp)) ! OUT - TOA incident shortwave radiation (spectral) - toa_src_sw(idxday(1:nday),:) = toa_src_sw_temp - - ! Scale incident flux - do ij=1,nday - toa_src_sw(idxday(ij),:) = toa_src_sw(idxday(ij),:)*solcon/ & - sum(toa_src_sw(idxday(ij),:)) - enddo - endif - - end subroutine rrtmgp_sw_gas_optics_run !> @} end module rrtmgp_sw_gas_optics diff --git a/physics/rrtmgp_sw_main.F90 b/physics/rrtmgp_sw_main.F90 index a10f899e0..232bb5847 100644 --- a/physics/rrtmgp_sw_main.F90 +++ b/physics/rrtmgp_sw_main.F90 @@ -82,7 +82,7 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, & cld_rerain, precip_frac, cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, cld_cnv_reice, & cld_pbl_lwp, cld_pbl_reliq, cld_pbl_iwp, cld_pbl_reice, cloud_overlap_param, & - active_gases_array, sw_optical_props_aerosol, solcon, scmpsw, & + active_gases_array, aersw_tau, aersw_ssa, aersw_g, solcon, scmpsw, & fluxswUP_allsky, fluxswDOWN_allsky, fluxswUP_clrsky, fluxswDOWN_clrsky, cldtausw, & errmsg, errflg) @@ -148,10 +148,12 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ cld_pbl_iwp, & ! Water path for PBL ice cloud-particles cld_pbl_reice, & ! Effective radius for PBL ice cloud-particles cloud_overlap_param ! + real(kind_phys), dimension(:,:,:), intent(in) :: & + aersw_tau, & ! Aerosol optical depth + aersw_ssa, & ! Aerosol single scattering albedo + aersw_g ! Aerosol asymmetry paramter character(len=*), dimension(:), intent(in) :: & active_gases_array ! List of active gases from namelist as array - type(ty_optical_props_2str),intent(in) :: & - sw_optical_props_aerosol ! RRTMGP DDT: Shortwave aerosol optical properties (tau,ssa,g) real(kind_phys), intent(in) :: & solcon ! Solar constant @@ -279,9 +281,9 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ sw_optical_props_precipByBand%tau = 0._kind_phys sw_optical_props_precipByBand%ssa = 0._kind_phys sw_optical_props_precipByBand%g = 0._kind_phys - sw_optical_props_aerosol_local%tau = 0._kind_phys - sw_optical_props_aerosol_local%ssa = 0._kind_phys - sw_optical_props_aerosol_local%g = 0._kind_phys + !sw_optical_props_aerosol_local%tau = 0._kind_phys + !sw_optical_props_aerosol_local%ssa = 0._kind_phys + !sw_optical_props_aerosol_local%g = 0._kind_phys if (doGP_sgs_cnv) then sw_optical_props_cnvcloudsByBand%tau = 0._kind_phys sw_optical_props_cnvcloudsByBand%ssa = 0._kind_phys @@ -502,9 +504,9 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ ! ! ################################################################################### ! Add aerosol optics to gaseous (clear-sky) optical properties - sw_optical_props_aerosol_local%tau = sw_optical_props_aerosol%tau(ix:ix2,:,:) - sw_optical_props_aerosol_local%ssa = sw_optical_props_aerosol%ssa(ix:ix2,:,:) - sw_optical_props_aerosol_local%g = sw_optical_props_aerosol%g(ix:ix2,:,:) + sw_optical_props_aerosol_local%tau = aersw_tau(iCol:iCol+rrtmgp_phys_blksz-1,:,:) + sw_optical_props_aerosol_local%ssa = aersw_ssa(iCol:iCol+rrtmgp_phys_blksz-1,:,:) + sw_optical_props_aerosol_local%g = aersw_g(iCol:iCol+rrtmgp_phys_blksz-1,:,:) call check_error_msg('rrtmgp_sw_main_increment_aerosol_to_clrsky', & sw_optical_props_aerosol_local%increment(sw_optical_props_accum)) diff --git a/physics/rrtmgp_sw_main.meta b/physics/rrtmgp_sw_main.meta index 956716c80..1d50a780e 100644 --- a/physics/rrtmgp_sw_main.meta +++ b/physics/rrtmgp_sw_main.meta @@ -547,12 +547,29 @@ type = character kind = len=* intent = in -[sw_optical_props_aerosol] - standard_name = shortwave_optical_properties_for_aerosols - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str +[aersw_tau] + standard_name = aerosol_optical_depth_for_shortwave_bands_01_16 + long_name = aerosol optical depth for shortwave bands 01-16 + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_aerosol_bands_for_shortwave_radiation) + type = real + kind = kind_phys + intent = in +[aersw_ssa] + standard_name = aerosol_single_scattering_albedo_for_shortwave_bands_01_16 + long_name = aerosol single scattering albedo for shortwave bands 01-16 + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_aerosol_bands_for_shortwave_radiation) + type = real + kind = kind_phys + intent = in +[aersw_g] + standard_name = aerosol_asymmetry_parameter_for_shortwave_bands_01_16 + long_name = aerosol asymmetry parameter for shortwave bands 01-16 + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_aerosol_bands_for_shortwave_radiation) + type = real + kind = kind_phys intent = in [solcon] standard_name = solar_constant diff --git a/physics/rte-rrtmgp b/physics/rte-rrtmgp index 7f01618c9..0dc54f5ec 160000 --- a/physics/rte-rrtmgp +++ b/physics/rte-rrtmgp @@ -1 +1 @@ -Subproject commit 7f01618c92409658bddd3afa9acb004c608f6a0d +Subproject commit 0dc54f5ecaeb1e1e342efd1e02d0bcd41737bde2 From e1a452fba890f63d09fdd54b69946b3564fcaeac Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Wed, 24 Aug 2022 22:45:34 +0000 Subject: [PATCH 026/380] Updated submodule pointer --- .gitmodules | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitmodules b/.gitmodules index 75e5ea836..8758980ec 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,4 +1,4 @@ [submodule "physics/rte-rrtmgp"] path = physics/rte-rrtmgp url = https://github.com/earth-system-radiation/rte-rrtmgp - branch = dtc/ccpp + branch = main From be305d579b35c779d096df969906a2c22bbf23b4 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 25 Aug 2022 18:31:36 +0000 Subject: [PATCH 027/380] various snow bug fixes --- physics/clm_lake.f90 | 74 ++++++++++++++++++++++++------------------- physics/clm_lake.meta | 50 +++++++++++++++++++++-------- physics/sfc_diag.f | 22 ++++++++++--- physics/sfc_diag.meta | 16 +++++++++- 4 files changed, 110 insertions(+), 52 deletions(-) diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90 index a07f48d40..2efce1431 100644 --- a/physics/clm_lake.f90 +++ b/physics/clm_lake.f90 @@ -131,7 +131,7 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& xlat_d ,z_lake3d ,dz_lake3d ,lakedepth2d ,& watsat3d ,csol3d ,tkmg3d ,tkdry3d ,& tksatu3d ,phii ,& - xice, xice_threshold ,im,km ,& + fice ,min_lakeice ,im,km ,& h2osno2d ,snowdp2d ,snl2d ,z3d ,& !h dz3d ,zi3d ,h2osoi_vol3d ,h2osoi_liq3d ,& h2osoi_ice3d ,t_grnd2d ,t_soisno3d ,t_lake3d ,& @@ -140,11 +140,11 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& con_cp ,icy ,& hflx ,evap ,grdflx ,tsfc ,& !o lake_t2m ,lake_q2m ,clm_lake_initialized ,& - isltyp ,snow ,use_lakedepth ,& + weasd ,isltyp ,snowd ,use_lakedepth ,& restart ,lakedepth_default ,& - sand3d ,clay3d ,& + rainnc ,rainc ,sand3d ,clay3d ,& ! Flake output variables - weasd ,snwdph ,hice ,tsurf ,& + weasdi ,snodi ,hice ,tsurf ,& t_sfc ,lflx ,ustar ,qsfc ,& ch ,cm ,chh ,cmm ,& lake_t_snow ,tisfc ,tsurf_ice ,wind ,& @@ -168,17 +168,18 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& INTEGER , INTENT (IN) :: im,km,me,master LOGICAL, INTENT(IN) :: restart,use_lakedepth,first_time_step REAL(KIND_PHYS), INTENT(INOUT) :: clm_lake_initialized(:) - REAL(KIND_PHYS), INTENT(IN) :: xice_threshold, con_rd,con_g,con_cp,lakedepth_default + REAL(KIND_PHYS), INTENT(IN) :: min_lakeice, con_rd,con_g,con_cp,lakedepth_default logical, intent(inout) :: icy(:) - REAL(KIND_PHYS), DIMENSION( : ), INTENT(INOUT):: XICE + REAL(KIND_PHYS), DIMENSION( : ), INTENT(INOUT):: fice + REAL(KIND_PHYS), DIMENSION( : ), INTENT(IN) :: weasd, snowd REAL(KIND_PHYS), DIMENSION( : ), INTENT(IN):: tg3 - REAL(KIND_PHYS), DIMENSION( : ), INTENT(IN) :: SNOW, ZLVL + REAL(KIND_PHYS), DIMENSION( : ), INTENT(IN) :: ZLVL, RAINC, RAINNC INTEGER, DIMENSION(:), INTENT(IN) :: use_lake_model real(kind_phys), dimension(:), intent(in) :: rho0 ! air density at surface REAL(KIND_PHYS), DIMENSION( : ), INTENT(INOUT) :: & - weasd ,snwdph ,hice ,tsurf ,& + weasdi ,snodi ,hice ,tsurf ,& t_sfc ,lflx ,ustar ,qsfc ,& chh ,cmm ,lake_t_snow ,tisfc ,& tsurf_ice ,wind @@ -304,7 +305,7 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& real(kind_phys) :: tkdry(1,nlevsoil) ! thermal conductivity, dry soil (W/m/Kelvin) real(kind_phys) :: csol(1,nlevsoil) ! heat capacity, soil solids (J/m**3/Kelvin) - integer :: lake_points + integer :: lake_points, snow_points, ice_points character*255 :: message logical, parameter :: feedback_to_atmosphere = .true. ! FIXME: REMOVE @@ -361,18 +362,18 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& endif ! Still have some points to initialize - call lakeini(kdt, ISLTYP, gt0, SNOW, & !i - restart, lakedepth_default, & + call lakeini(kdt, ISLTYP, gt0, snowd, & !i + weasd, restart, lakedepth_default, & lakedepth2d, savedtke12d, snowdp2d, h2osno2d, & !o snl2d, t_grnd2d, t_lake3d, lake_icefrac3d, & z_lake3d, dz_lake3d, t_soisno3d, h2osoi_ice3d, & h2osoi_liq3d, h2osoi_vol3d, z3d, dz3d, & zi3d, watsat3d, csol3d, tkmg3d, & - xice, xice_threshold, tsfc, & + fice, min_lakeice, tsfc, & use_lake_model, use_lakedepth, con_g, con_rd, & tkdry3d, tksatu3d, im, prsi, & clm_lake_initialized, & - sand3d, clay3d, tg3, & + sand3d, clay3d, tg3, & km, me, master, errmsg, errflg) if(errflg/=0) then return @@ -391,6 +392,8 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& endif lake_points=0 + snow_points=0 + ice_points=0 lake_top_loop: DO I = 1,im @@ -401,6 +404,7 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& PSFC = prsi(i,1) Q2K = qvcurr(i) LWDN = DLWSFCI(I)*EMISS(I) + PRCP = denh2o * (rainc(i)+rainnc(i))*1000.0_kind_phys/dtime PRCP = RAIN(i)*1000.0_kind_phys/dtime ! use physics timestep since PRCP comes from non-surface schemes SOLDN = DSWSFCI(I) ! SOLDN is total incoming solar SOLNET = SOLDN*(1.-ALBEDO(I)) ! use mid-day albedo to determine net downward solar @@ -543,14 +547,15 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& !TH2(I) = T2(I)*(1.E5/PSFC)**RCP ! potential temperature (CCPP doesn't want this) lake_q2m(I) = q_ref2m(c) ! [frac] specific humidity albedo(i) = ( 0.6 * lake_icefrac3d(i,1) ) + ( (1.0-lake_icefrac3d(i,1)) * 0.08) - xice(i) = lake_icefrac3d(i,1) + fice(i) = lake_icefrac3d(i,1) - if(xice(i)>xice_threshold) then - weasd(i) = h2osno(c) ! water_equivalent_accumulated_snow_depth_over_ice - snwdph(i) = h2osno(c)/snow_bd*1000 ! surface_snow_thickness_water_equivalent_over_ice + if(fice(i)>=min_lakeice) then + weasdi(i) = h2osno(c) ! water_equivalent_accumulated_snow_depth_over_ice + snodi(i) = snowdp(c) ! surface_snow_thickness_water_equivalent_over_ice tisfc(i) = t_grnd(c) ! surface_skin_temperature_over_ice tsurf_ice(i) = t_grnd(c) ! surface_skin_temperature_after_iteration_over_ice icy(i)=.true. + ice_points = ice_points+1 ! Assume that, if a layer has ice, the entire layer thickness is ice. hice(I) = 0 @@ -560,16 +565,19 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& endif end do else - weasd(i) = 0 - snwdph(i) = 0 + weasdi(i) = 0 + snodi(i) = 0 tisfc(i) = tsurf(i) tsurf_ice(i) = tisfc(i) hice(i) = 0 endif - if(snl2d(i)>0) then + if(snl2d(i)<0) then lake_t_snow(i) = t_grnd(c) tisfc(i) = lake_t_snow(i) + snow_points = snow_points+1 + else + lake_t_snow(i) = -9999 endif ustar = ustar_out(1) ! surface_friction_velocity_over_water @@ -586,9 +594,9 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& endif if_lake_is_here ENDDO lake_top_loop - if(LAKEDEBUG .and. lake_points>0) then -3082 format('lake points processed in timestep ',I0,' by rank ',I0,' = ',I0) - print 3082,kdt,me,lake_points + if(LAKEDEBUG .and. lake_points>0 .and. (kdt<3 .or. mod(kdt,30)==3)) then +3082 format('lake points processed in timestep ',I0,' by rank ',I0,' = ',I0,' snow=',I0,' ice=',I0) + print 3082,kdt,me,lake_points,snow_points,ice_points endif CONTAINS @@ -5115,14 +5123,14 @@ subroutine clm_lake_init(con_pi,karman,con_g,con_sbc,con_t0c,rhowater,con_csol,c end subroutine clm_lake_init ! Some fields in lakeini are not available until runtime, so this cannot be in a CCPP init routine. - SUBROUTINE lakeini(kdt, ISLTYP, gt0, SNOW, & !i - restart, lakedepth_default, & + SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, & !i + weasd, restart, lakedepth_default, & lakedepth2d, savedtke12d, snowdp2d, h2osno2d, & !o snl2d, t_grnd2d, t_lake3d, lake_icefrac3d, & z_lake3d, dz_lake3d, t_soisno3d, h2osoi_ice3d, & h2osoi_liq3d, h2osoi_vol3d, z3d, dz3d, & zi3d, watsat3d, csol3d, tkmg3d, & - xice, xice_threshold, tsfc, & + fice, min_lakeice, tsfc, & use_lake_model, use_lakedepth, con_g, con_rd, & tkdry3d, tksatu3d, im, prsi, & clm_lake_initialized, & @@ -5141,8 +5149,8 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, SNOW, CHARACTER(*), INTENT(OUT) :: errmsg INTEGER , INTENT (IN) :: im, me, master, km, kdt - REAL(KIND_PHYS), INTENT(IN) :: xice_threshold, con_g, con_rd - REAL(KIND_PHYS), DIMENSION(IM), INTENT(IN):: XICE,TG3 + REAL(KIND_PHYS), INTENT(IN) :: min_lakeice, con_g, con_rd + REAL(KIND_PHYS), DIMENSION(IM), INTENT(IN):: FICE,TG3 REAL(KIND_PHYS), DIMENSION(IM), INTENT(IN):: tsfc REAL(KIND_PHYS), DIMENSION(IM) ,INTENT(INOUT) :: clm_lake_initialized @@ -5153,7 +5161,7 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, SNOW, LOGICAL , INTENT(IN) :: restart INTEGER, DIMENSION(IM), INTENT(IN) :: ISLTYP - REAL(KIND_PHYS), DIMENSION(IM), INTENT(IN) :: SNOW + REAL(KIND_PHYS), DIMENSION(IM), INTENT(IN) :: snowd,weasd REAL(kind_phys), DIMENSION(IM,KM), INTENT(IN) :: gt0, prsi real(kind_phys), intent(in) :: lakedepth_default @@ -5244,8 +5252,8 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, SNOW, cycle endif - snowdp2d(i) = snow(i)*0.005 ! SNOW in kg/m^2 and snowdp in m - h2osno2d(i) = snow(i) ! mm + snowdp2d(i) = snowd(i) ! SNOW in kg/m^2 and snowdp in m + h2osno2d(i) = weasd(i) ! mm snl2d(i) = defval do k = -nlevsnow+1,nlevsoil @@ -5262,8 +5270,8 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, SNOW, dz_lake3d(i,k) = defval enddo - if(xice(i).gt.xice_threshold) then - lake_icefrac3d(i,1) = xice(i) + if(fice(i)>min_lakeice) then + lake_icefrac3d(i,1) = fice(i) endif z3d(i,:) = 0.0 diff --git a/physics/clm_lake.meta b/physics/clm_lake.meta index 9fd286afd..0fd782856 100644 --- a/physics/clm_lake.meta +++ b/physics/clm_lake.meta @@ -7,6 +7,22 @@ [ccpp-arg-table] name = clm_lake_run type = scheme +[rainnc] + standard_name = lwe_thickness_of_explicit_precipitation_amount_on_previous_timestep + long_name = explicit rainfall from previous timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[rainc] + standard_name = lwe_thickness_of_convective_precipitation_amount_on_previous_timestep + long_name = convective_precipitation_amount from previous timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [tg3] standard_name = deep_soil_temperature long_name = deep soil temperature @@ -236,7 +252,7 @@ type = real kind = kind_phys intent = in -[xice] +[fice] standard_name = sea_ice_area_fraction_of_sea_area_fraction long_name = ice fraction over open water units = frac @@ -244,7 +260,7 @@ type = real kind = kind_phys intent = inout -[xice_threshold] +[min_lakeice] standard_name = min_lake_ice_area_fraction long_name = minimum lake ice value units = frac @@ -421,7 +437,7 @@ [lake_t2m] standard_name = temperature_at_2m_from_clm_lake long_name = temperature at 2m from clm lake - units = frac + units = K dimensions = (horizontal_loop_extent) type = real kind = kind_phys @@ -449,14 +465,6 @@ dimensions = (horizontal_loop_extent) type = integer intent = inout -[snow] - standard_name = surface_snow_thickness_water_equivalent_over_land - long_name = water equivalent snow depth over land - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in [use_lakedepth] standard_name = flag_for_initializing_clm_lake_depth_from_lake_depth long_name = flag for initializing clm lake depth from lake depth @@ -515,14 +523,30 @@ type = integer intent = inout [weasd] + standard_name = lwe_thickness_of_surface_snow_amount + long_name = water equiv of acc snow depth over land and sea ice + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[snowd] + standard_name = lwe_surface_snow + long_name = water equivalent snow depth + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[weasdi] standard_name = water_equivalent_accumulated_snow_depth_over_ice - long_name = water equiv of acc snow depth over ice + long_name = water equiv of acc snow depth over land units = mm dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout -[snwdph] +[snodi] standard_name = surface_snow_thickness_water_equivalent_over_ice long_name = water equivalent snow depth over ice units = mm diff --git a/physics/sfc_diag.f b/physics/sfc_diag.f index 31bd4aaf2..1312395e2 100644 --- a/physics/sfc_diag.f +++ b/physics/sfc_diag.f @@ -5,8 +5,11 @@ !! @{ module sfc_diag - contains + + logical, parameter :: LAKEDEBUG = .true. + contains + subroutine sfc_diag_init end subroutine sfc_diag_init @@ -25,7 +28,7 @@ subroutine sfc_diag_run & & (im,grav,cp,eps,epsm1,ps,u1,v1,t1,q1,prslki, & & evap,fm,fh,fm10,fh2,tskin,qsurf,thsfc_loc, & & use_lake_model,iopt_lake,iopt_lake_clm, & - & lake_t2m,lake_q2m, & + & lake_t2m,lake_q2m,kdt,me, & & f10m,u10m,v10m,t2m,q2m,errmsg,errflg & & ) ! @@ -33,14 +36,15 @@ subroutine sfc_diag_run & use funcphys, only : fpvs implicit none ! - integer, intent(in) :: im, iopt_lake, iopt_lake_clm + integer, intent(in) :: im, iopt_lake, iopt_lake_clm, kdt, me logical, intent(in) :: thsfc_loc ! Flag for reference pot. temp. real(kind=kind_phys), intent(in) :: grav,cp,eps,epsm1 real(kind=kind_phys), dimension(:), intent(in) :: & & ps, u1, v1, t1, q1, tskin, & & qsurf, prslki, evap, fm, fh, fm10, fh2 real(kind=kind_phys), dimension(:), intent(out) :: & - & f10m, u10m, v10m, t2m, q2m, lake_t2m, & + & f10m, u10m, v10m, t2m, q2m + real(kind=kind_phys), dimension(:), intent(in) :: lake_t2m, & & lake_q2m integer, dimension(:), intent(in) :: use_lake_model character(len=*), intent(out) :: errmsg @@ -49,7 +53,7 @@ subroutine sfc_diag_run & ! locals ! real(kind=kind_phys), parameter :: qmin=1.0e-8 - integer :: k,i + integer :: k,i, clm_t2m_count ! real(kind=kind_phys) :: fhi, qss, wrk @@ -69,6 +73,7 @@ subroutine sfc_diag_run & ! ps is in pascals ! !! + clm_t2m_count=0 do i = 1, im f10m(i) = fm10(i) / fm(i) ! f10m(i) = min(f10m(i),1.) @@ -77,6 +82,7 @@ subroutine sfc_diag_run & if(use_lake_model(i)>0 .and. iopt_lake==iopt_lake_clm) then t2m(i) = lake_t2m(i) q2m(i) = lake_q2m(i) + clm_t2m_count=clm_t2m_count+1 else fhi = fh2(i) / fh(i) ! t2m(i) = tskin(i)*(1. - fhi) + t1(i) * prslki(i) * fhi @@ -102,6 +108,12 @@ subroutine sfc_diag_run & endif enddo + if(LAKEDEBUG .and. clm_t2m_count>0 .and. kdt<5) then +3082 format('lake 2m points processed in timestep ',I0, & + & ' by rank ',I0,' = ',I0) + print 3082,kdt,me,clm_t2m_count + endif + return end subroutine sfc_diag_run !> @} diff --git a/physics/sfc_diag.meta b/physics/sfc_diag.meta index 3bbb5de03..00f725cb8 100644 --- a/physics/sfc_diag.meta +++ b/physics/sfc_diag.meta @@ -181,7 +181,7 @@ [lake_t2m] standard_name = temperature_at_2m_from_clm_lake long_name = temperature at 2m from clm lake - units = frac + units = K dimensions = (horizontal_loop_extent) type = real kind = kind_phys @@ -194,6 +194,20 @@ type = real kind = kind_phys intent = in +[kdt] + standard_name = index_of_timestep + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = in +[me] + standard_name = mpi_rank + long_name = current MPI-rank + units = index + dimensions = () + type = integer + intent = in [f10m] standard_name = ratio_of_wind_at_surface_adjacent_layer_to_wind_at_10m long_name = ratio of fm10 and fm From 0c1f94999109915823e9b1824dfa889ce1791ff7 Mon Sep 17 00:00:00 2001 From: Samuel Trahan Date: Thu, 25 Aug 2022 19:11:16 +0000 Subject: [PATCH 028/380] rainnc and rainc do not exist --- physics/clm_lake.f90 | 5 ++--- physics/clm_lake.meta | 16 ---------------- 2 files changed, 2 insertions(+), 19 deletions(-) diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90 index 2efce1431..43c6711be 100644 --- a/physics/clm_lake.f90 +++ b/physics/clm_lake.f90 @@ -142,7 +142,7 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& lake_t2m ,lake_q2m ,clm_lake_initialized ,& weasd ,isltyp ,snowd ,use_lakedepth ,& restart ,lakedepth_default ,& - rainnc ,rainc ,sand3d ,clay3d ,& + sand3d ,clay3d ,& ! Flake output variables weasdi ,snodi ,hice ,tsurf ,& t_sfc ,lflx ,ustar ,qsfc ,& @@ -173,7 +173,7 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& REAL(KIND_PHYS), DIMENSION( : ), INTENT(INOUT):: fice REAL(KIND_PHYS), DIMENSION( : ), INTENT(IN) :: weasd, snowd REAL(KIND_PHYS), DIMENSION( : ), INTENT(IN):: tg3 - REAL(KIND_PHYS), DIMENSION( : ), INTENT(IN) :: ZLVL, RAINC, RAINNC + REAL(KIND_PHYS), DIMENSION( : ), INTENT(IN) :: ZLVL INTEGER, DIMENSION(:), INTENT(IN) :: use_lake_model real(kind_phys), dimension(:), intent(in) :: rho0 ! air density at surface @@ -404,7 +404,6 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& PSFC = prsi(i,1) Q2K = qvcurr(i) LWDN = DLWSFCI(I)*EMISS(I) - PRCP = denh2o * (rainc(i)+rainnc(i))*1000.0_kind_phys/dtime PRCP = RAIN(i)*1000.0_kind_phys/dtime ! use physics timestep since PRCP comes from non-surface schemes SOLDN = DSWSFCI(I) ! SOLDN is total incoming solar SOLNET = SOLDN*(1.-ALBEDO(I)) ! use mid-day albedo to determine net downward solar diff --git a/physics/clm_lake.meta b/physics/clm_lake.meta index 0fd782856..8e213f06c 100644 --- a/physics/clm_lake.meta +++ b/physics/clm_lake.meta @@ -7,22 +7,6 @@ [ccpp-arg-table] name = clm_lake_run type = scheme -[rainnc] - standard_name = lwe_thickness_of_explicit_precipitation_amount_on_previous_timestep - long_name = explicit rainfall from previous timestep - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[rainc] - standard_name = lwe_thickness_of_convective_precipitation_amount_on_previous_timestep - long_name = convective_precipitation_amount from previous timestep - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in [tg3] standard_name = deep_soil_temperature long_name = deep soil temperature From 0ecd6207a41f3e806fc6fa062247e96743f6fbf5 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 25 Aug 2022 19:33:40 +0000 Subject: [PATCH 029/380] remove bad unit conversion --- physics/clm_lake.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90 index 43c6711be..4002f941d 100644 --- a/physics/clm_lake.f90 +++ b/physics/clm_lake.f90 @@ -404,7 +404,7 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& PSFC = prsi(i,1) Q2K = qvcurr(i) LWDN = DLWSFCI(I)*EMISS(I) - PRCP = RAIN(i)*1000.0_kind_phys/dtime ! use physics timestep since PRCP comes from non-surface schemes + PRCP = RAIN(i)/dtime ! [mm/s] use physics timestep since PRCP comes from non-surface schemes SOLDN = DSWSFCI(I) ! SOLDN is total incoming solar SOLNET = SOLDN*(1.-ALBEDO(I)) ! use mid-day albedo to determine net downward solar ! (no solar zenith angle correction) From bbe1a16d30037b33849e1ebed64cb888da383a20 Mon Sep 17 00:00:00 2001 From: Samuel Trahan Date: Thu, 25 Aug 2022 20:23:52 +0000 Subject: [PATCH 030/380] unit conversion issue --- physics/clm_lake.f90 | 2 +- physics/clm_lake.meta | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90 index 4002f941d..cfaea7cfc 100644 --- a/physics/clm_lake.f90 +++ b/physics/clm_lake.f90 @@ -5251,7 +5251,7 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, cycle endif - snowdp2d(i) = snowd(i) ! SNOW in kg/m^2 and snowdp in m + snowdp2d(i) = snowd(i)*1e-3 ! SNOW in kg/m^2 and snowdp in m h2osno2d(i) = weasd(i) ! mm snl2d(i) = defval diff --git a/physics/clm_lake.meta b/physics/clm_lake.meta index 8e213f06c..8cc2accb4 100644 --- a/physics/clm_lake.meta +++ b/physics/clm_lake.meta @@ -277,7 +277,7 @@ [snowdp2d] standard_name = actual_snow_depth_in_clm_lake_model long_name = actual acc snow depth over lake in clm lake model - units = mm + units = m dimensions = (horizontal_loop_extent) type = real kind = kind_phys From 9a07ae9abbe47516b5415997712a0f887a8aa57f Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 25 Aug 2022 21:19:57 +0000 Subject: [PATCH 031/380] LAKEDEBUG is now clm_lake_debug namelist parameter --- physics/clm_lake.f90 | 8 +++++--- physics/clm_lake.meta | 8 ++++++++ physics/sfc_diag.f | 8 -------- 3 files changed, 13 insertions(+), 11 deletions(-) diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90 index cfaea7cfc..9b8db78b8 100644 --- a/physics/clm_lake.f90 +++ b/physics/clm_lake.f90 @@ -31,7 +31,7 @@ MODULE clm_lake implicit none - logical, parameter :: LAKEDEBUG = .true. ! Enable lots of checks and debug prints and errors + logical :: LAKEDEBUG = .false. ! Enable lots of checks and debug prints and errors logical, parameter :: PERGRO = .false. @@ -357,7 +357,7 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& endif ! At this point, at least one thread should have read in the unhappy points. if(unhappy_count==FAILED_TO_READ_UNHAPPY_POINTS .and. kdt<2) then - write(0,'(A)') "ERROR: Could not read unhappy points" + write(0,'(A)') "Could not read unhappy points. Will not print unhappy point data." endif endif @@ -5028,14 +5028,16 @@ end subroutine MoninObukIni !! \htmlinclude clm_lake_init.html !! subroutine clm_lake_init(con_pi,karman,con_g,con_sbc,con_t0c,rhowater,con_csol,con_cliq, & - con_hfus,con_hvap,con_rd,con_cp,rhoice,errmsg,errflg) + con_hfus,con_hvap,con_rd,con_cp,rhoice,clm_lake_debug,errmsg,errflg) implicit none real(kind_phys), intent(in) :: con_pi,karman,con_g,con_sbc,con_t0c, & rhowater,con_csol,con_cliq, con_hfus,con_hvap,con_rd,con_cp,rhoice INTEGER, INTENT(OUT) :: errflg CHARACTER(*), INTENT(OUT) :: errmsg + logical, intent(in) :: clm_lake_debug integer :: i, j + LAKEDEBUG = clm_lake_debug if(LAKEDEBUG) then write(0,*) 'clm_lake_init' endif diff --git a/physics/clm_lake.meta b/physics/clm_lake.meta index 8cc2accb4..1fd67984c 100644 --- a/physics/clm_lake.meta +++ b/physics/clm_lake.meta @@ -803,6 +803,14 @@ type = real kind = kind_phys intent = in +[clm_lake_debug] + standard_name = flag_for_verbose_debugging_in_clm_lake_model + long_name = flag for verbose debugging in clm lake model + units = flag + dimensions = () + type = logical + active = (control_for_lake_model_selection == 3) + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/sfc_diag.f b/physics/sfc_diag.f index 1312395e2..a8e87b9ac 100644 --- a/physics/sfc_diag.f +++ b/physics/sfc_diag.f @@ -6,8 +6,6 @@ module sfc_diag - logical, parameter :: LAKEDEBUG = .true. - contains subroutine sfc_diag_init @@ -108,12 +106,6 @@ subroutine sfc_diag_run & endif enddo - if(LAKEDEBUG .and. clm_t2m_count>0 .and. kdt<5) then -3082 format('lake 2m points processed in timestep ',I0, & - & ' by rank ',I0,' = ',I0) - print 3082,kdt,me,clm_t2m_count - endif - return end subroutine sfc_diag_run !> @} From eeac3d6e1ea2525fbc96dcff831d6cada6a64f42 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Fri, 26 Aug 2022 15:16:08 +0000 Subject: [PATCH 032/380] Some housekeeping. Working in UFS. --- CMakeLists.txt | 12 ----- physics/GFS_rrtmgp_post.meta | 2 +- physics/GFS_rrtmgp_pre.F90 | 32 ++++++------ physics/GFS_rrtmgp_pre.meta | 32 ------------ physics/rrtmgp_lw_cloud_optics.F90 | 34 ++++++------- physics/rrtmgp_lw_gas_optics.F90 | 35 ++++--------- physics/rrtmgp_lw_main.F90 | 81 ++++++++++++++---------------- physics/rrtmgp_lw_main.meta | 39 -------------- physics/rrtmgp_sw_cloud_optics.F90 | 43 +++++++--------- physics/rrtmgp_sw_gas_optics.F90 | 28 ++++------- physics/rrtmgp_sw_main.F90 | 73 +++++++++++++-------------- physics/rrtmgp_sw_main.meta | 7 --- 12 files changed, 144 insertions(+), 274 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index d14778b06..482081614 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -81,14 +81,10 @@ get_filename_component(LOCAL_CURRENT_SOURCE_DIR ${FULL_PATH_TO_CMAKELISTS} DIREC # List of files that need to be compiled without OpenMP set(SCHEMES_OPENMP_OFF ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/mo_gas_optics.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/mo_rrtmgp_constants.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/mo_rrtmgp_util_reorder.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/mo_gas_concentrations.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/mo_rrtmgp_util_string.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/kernels/mo_gas_optics_kernels.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/kernels/mo_rrtmgp_util_reorder_kernels.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/mo_gas_optics_rrtmgp.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/tests/mo_testing_io.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/tests/clear_sky_regression.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/extensions/mo_rrtmgp_clr_all_sky.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/extensions/mo_fluxes_byband.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/extensions/solar_variability/mo_solar_variability.F90 @@ -97,14 +93,6 @@ set(SCHEMES_OPENMP_OFF ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/mo_ ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/extensions/mo_compute_bc.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/extensions/cloud_optics/mo_cloud_sampling.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/extensions/cloud_optics/mo_cloud_optics.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/examples/mo_load_coefficients.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/examples/rfmip-clear-sky/rrtmgp_rfmip_sw.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/examples/rfmip-clear-sky/mo_rfmip_io.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/examples/rfmip-clear-sky/rrtmgp_rfmip_lw.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/examples/mo_simple_netcdf.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/examples/all-sky/rrtmgp_allsky.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/examples/all-sky/mo_load_cloud_coefficients.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/examples/all-sky/mo_garand_atmos_io.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/mo_rte_config.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/mo_source_functions.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/mo_rte_sw.F90 diff --git a/physics/GFS_rrtmgp_post.meta b/physics/GFS_rrtmgp_post.meta index 0d6859f75..0caa1c387 100644 --- a/physics/GFS_rrtmgp_post.meta +++ b/physics/GFS_rrtmgp_post.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_rrtmgp_post type = scheme - dependencies = iounitdef.f,machine.F,radiation_aerosols.f,radlw_param.f,rte-rrtmgp/extensions/mo_fluxes_byband.F90,radiation_tools.F90,rte-rrtmgp/rte/mo_fluxes.F90,rte-rrtmgp/rte/kernels/mo_fluxes_broadband_kernels.F90,rte-rrtmgp/extensions/mo_heating_rates.F90 + dependencies = iounitdef.f,machine.F,radiation_aerosols.f,radlw_param.f,radiation_tools.F90,rte-rrtmgp/extensions/mo_heating_rates.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/GFS_rrtmgp_pre.F90 b/physics/GFS_rrtmgp_pre.F90 index 5b4bb025e..45b40b938 100644 --- a/physics/GFS_rrtmgp_pre.F90 +++ b/physics/GFS_rrtmgp_pre.F90 @@ -113,8 +113,8 @@ end subroutine GFS_rrtmgp_pre_init ! ######################################################################################### subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, doSWrad, doLWrad, fhswr, fhlwr, & xlat, xlon, prsl, tgrs, prslk, prsi, qgrs, tsfc, coslat, sinlat, con_g, con_rd, & - con_eps, con_epsm1, con_fvirt, con_epsqs, solhr, minGPpres, maxGPpres, minGPtemp, & - maxGPtemp, raddt, p_lay, t_lay, p_lev, t_lev, vmr_o2, vmr_h2o, vmr_o3, vmr_ch4, & + con_eps, con_epsm1, con_fvirt, con_epsqs, solhr, raddt, p_lay, t_lay, p_lev, t_lev, & + vmr_o2, vmr_h2o, vmr_o3, vmr_ch4, & vmr_n2o, vmr_co2, tsfg, tsfa, qs_lay, q_lay, tv_lay, & relhum, deltaZ, deltaZc, deltaP, active_gases_array, & tsfc_radtime, coszen, coszdg, top_at_1, iSFC, iTOA, nDay, idxday, semis, & @@ -130,10 +130,6 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, doSWrad, doLWrad, fhswr, fhl doSWrad, & ! Call SW radiation? doLWrad ! Call LW radiation real(kind_phys), intent(in) :: & - minGPtemp, & ! Minimum temperature allowed in RRTMGP. - maxGPtemp, & ! Maximum ... - minGPpres, & ! Minimum pressure allowed in RRTMGP. - maxGPpres, & ! Maximum pressure allowed in RRTMGP. fhswr, & ! Frequency of SW radiation call. fhlwr ! Frequency of LW radiation call. real(kind_phys), intent(in) :: & @@ -245,27 +241,29 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, doSWrad, doLWrad, fhswr, fhl ! Bound temperature/pressure at layer centers. do iLay=1,nLev do iCol=1,NCOL - if (t_lay(iCol,iLay) .le. minGPtemp) then - t_lay(iCol,iLay) = minGPtemp + epsilon(minGPtemp) + if (t_lay(iCol,iLay) .le. lw_gas_props%get_temp_min()) then + t_lay(iCol,iLay) = lw_gas_props%get_temp_min() + epsilon(lw_gas_props%get_temp_min()) endif - if (p_lay(iCol,iLay) .le. minGPpres) then - p_lay(iCol,iLay) = minGPpres + epsilon(minGPpres) + if (p_lay(iCol,iLay) .le. lw_gas_props%get_press_min()) then + p_lay(iCol,iLay) = lw_gas_props%get_press_min() + epsilon(lw_gas_props%get_press_min()) endif - if (t_lay(iCol,iLay) .ge. maxGPtemp) then - t_lay(iCol,iLay) = maxGPtemp - epsilon(maxGPtemp) + if (t_lay(iCol,iLay) .ge. lw_gas_props%get_temp_max()) then + t_lay(iCol,iLay) = lw_gas_props%get_temp_max() - epsilon(lw_gas_props%get_temp_max()) endif - if (p_lay(iCol,iLay) .ge. maxGPpres) then - p_lay(iCol,iLay) = maxGPpres - epsilon(maxGPpres) + if (p_lay(iCol,iLay) .ge. lw_gas_props%get_press_max()) then + p_lay(iCol,iLay) = lw_gas_props%get_press_max() - epsilon(lw_gas_props%get_press_max()) endif enddo enddo ! Temperature at layer-interfaces - call cmp_tlev(nCol,nLev,minGPpres,p_lay,t_lay,p_lev,tsfc,t_lev) + call cmp_tlev(nCol,nLev,lw_gas_props%get_press_min(),p_lay,t_lay,p_lev,tsfc,t_lev) do iLev=1,nLev+1 do iCol=1,nCol - if (t_lev(iCol,iLev) .le. minGPtemp) t_lev(iCol,iLev) = minGPtemp + epsilon(minGPtemp) - if (t_lev(iCol,iLev) .ge. maxGPtemp) t_lev(iCol,iLev) = maxGPtemp - epsilon(maxGPtemp) + if (t_lev(iCol,iLev) .le. lw_gas_props%get_temp_min()) t_lev(iCol,iLev) = & + lw_gas_props%get_temp_min() + epsilon(lw_gas_props%get_temp_min()) + if (t_lev(iCol,iLev) .ge. lw_gas_props%get_temp_max()) t_lev(iCol,iLev) = & + lw_gas_props%get_temp_max() - epsilon(lw_gas_props%get_temp_max()) enddo enddo diff --git a/physics/GFS_rrtmgp_pre.meta b/physics/GFS_rrtmgp_pre.meta index 2eb9a92b4..f77ac89db 100644 --- a/physics/GFS_rrtmgp_pre.meta +++ b/physics/GFS_rrtmgp_pre.meta @@ -245,38 +245,6 @@ type = real kind = kind_phys intent = in -[minGPpres] - standard_name = minimum_pressure_in_RRTMGP - long_name = minimum pressure allowed in RRTMGP - units = Pa - dimensions = () - type = real - kind = kind_phys - intent = in -[maxGPpres] - standard_name = maximum_pressure_in_RRTMGP - long_name = maximum pressure allowed in RRTMGP - units = Pa - dimensions = () - type = real - kind = kind_phys - intent = in -[minGPtemp] - standard_name = minimum_temperature_in_RRTMGP - long_name = minimum temperature allowed in RRTMGP - units = K - dimensions = () - type = real - kind = kind_phys - intent = in -[maxGPtemp] - standard_name = maximum_temperature_in_RRTMGP - long_name = maximum temperature allowed in RRTMGP - units = K - dimensions = () - type = real - kind = kind_phys - intent = in [raddt] standard_name = time_step_for_radiation long_name = radiation time step diff --git a/physics/rrtmgp_lw_cloud_optics.F90 b/physics/rrtmgp_lw_cloud_optics.F90 index 58823a197..9915c0040 100644 --- a/physics/rrtmgp_lw_cloud_optics.F90 +++ b/physics/rrtmgp_lw_cloud_optics.F90 @@ -75,43 +75,39 @@ module rrtmgp_lw_cloud_optics ! ###################################################################################### ! SUBROUTINE rrtmgp_lw_cloud_optics_init() ! ###################################################################################### - subroutine rrtmgp_lw_cloud_optics_init(nrghice, mpicomm, mpirank, mpiroot, & - doG_cldoptics, doGP_cldoptics_PADE, doGP_cldoptics_LUT, rrtmgp_root_dir, & - rrtmgp_lw_file_clouds, errmsg, errflg) + subroutine rrtmgp_lw_cloud_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_clouds, & + doGP_cldoptics_PADE, doGP_cldoptics_LUT, nrghice, mpicomm, mpirank, mpiroot, & + errmsg, errflg) ! Inputs + character(len=128),intent(in) :: & + rrtmgp_root_dir, & ! RTE-RRTMGP root directory + rrtmgp_lw_file_clouds ! RRTMGP file containing clouds optics data + logical, intent(in) :: & - doG_cldoptics, & ! Use legacy RRTMG cloud-optics? - doGP_cldoptics_PADE, & ! Use RRTMGP cloud-optics: PADE approximation? - doGP_cldoptics_LUT ! Use RRTMGP cloud-optics: LUTs? + doGP_cldoptics_PADE,& ! Use RRTMGP cloud-optics: PADE approximation? + doGP_cldoptics_LUT ! Use RRTMGP cloud-optics: LUTs? integer, intent(inout) :: & - nrghice ! Number of ice-roughness categories + nrghice ! Number of ice-roughness categories integer, intent(in) :: & - mpicomm, & ! MPI communicator - mpirank, & ! Current MPI rank - mpiroot ! Master MPI rank - character(len=128),intent(in) :: & - rrtmgp_root_dir, & ! RTE-RRTMGP root directory - rrtmgp_lw_file_clouds ! RRTMGP file containing coefficients used to compute clouds optical properties + mpicomm, & ! MPI communicator + mpirank, & ! Current MPI rank + mpiroot ! Master MPI rank ! Outputs character(len=*), intent(out) :: & - errmsg ! Error message + errmsg ! Error message integer, intent(out) :: & - errflg ! Error code + errflg ! Error code ! Local variables integer :: dimID,varID,status,ncid,mpierr character(len=264) :: lw_cloud_props_file - integer,parameter :: max_strlen=256, nrghice_default=2 ! Initialize errmsg = '' errflg = 0 - ! If not using RRTMGP cloud optics, return. - if (doG_cldoptics) return - ! Filenames are set in the physics_nml lw_cloud_props_file = trim(rrtmgp_root_dir)//trim(rrtmgp_lw_file_clouds) diff --git a/physics/rrtmgp_lw_gas_optics.F90 b/physics/rrtmgp_lw_gas_optics.F90 index a50c8b7e0..8cd38f210 100644 --- a/physics/rrtmgp_lw_gas_optics.F90 +++ b/physics/rrtmgp_lw_gas_optics.F90 @@ -78,14 +78,15 @@ module rrtmgp_lw_gas_optics ! ######################################################################################### ! SUBROUTINE rrtmgp_lw_gas_optics_init ! ######################################################################################### - subroutine rrtmgp_lw_gas_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, mpicomm, & - mpirank, mpiroot, minGPpres, maxGPpres, minGPtemp, maxGPtemp, active_gases_array, & - errmsg, errflg) + subroutine rrtmgp_lw_gas_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, & + active_gases_array, mpicomm, mpirank, mpiroot, errmsg, errflg) ! Inputs character(len=128),intent(in) :: & rrtmgp_root_dir, & ! RTE-RRTMGP root directory - rrtmgp_lw_file_gas ! RRTMGP file containing coefficients used to compute gaseous optical properties + rrtmgp_lw_file_gas ! RRTMGP file containing K-distribution data + character(len=*), dimension(:), intent(in) :: & + active_gases_array ! List of active gases from namelist as array integer,intent(in) :: & mpicomm, & ! MPI communicator mpirank, & ! Current MPI rank @@ -96,20 +97,12 @@ subroutine rrtmgp_lw_gas_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, mpicom errmsg ! CCPP error message integer, intent(out) :: & errflg ! CCPP error code - real(kind_phys), intent(out) :: & - minGPtemp, & ! Minimum temperature allowed by RRTMGP. - maxGPtemp, & ! Maximum ... - minGPpres, & ! Minimum pressure allowed by RRTMGP. - maxGPpres ! Maximum pressure allowed by RRTMGP. - character(len=*), dimension(:), intent(in) :: & - active_gases_array ! List of active gases from namelist as array ! Local variables - integer :: ncid, dimID, varID, status, iGas, ierr, ii, mpierr, iChar - integer,dimension(:),allocatable :: temp1, temp2, temp3, temp4, & - temp_log_array1, temp_log_array2, temp_log_array3, temp_log_array4 + integer :: ncid, dimID, varID, status, ii, mpierr, iChar + integer,dimension(:),allocatable :: temp1, temp2, temp3, temp4 character(len=264) :: lw_gas_props_file - type(ty_gas_concs) :: gas_concentrations ! RRTMGP DDT: trace gas concentrations (vmr) + type(ty_gas_concs) :: gas_concs ! RRTMGP DDT: trace gas concentrations (vmr) ! Initialize errmsg = '' @@ -442,9 +435,8 @@ subroutine rrtmgp_lw_gas_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, mpicom ! Initialize RRTMGP DDT's... ! ! ####################################################################################### - allocate(gas_concentrations%gas_name(1:size(active_gases_array))) - gas_concentrations%gas_name(:) = active_gases_array(:) - call check_error_msg('rrtmgp_lw_gas_optics_init',lw_gas_props%load(gas_concentrations, & + call check_error_msg('rrtmgp_lw_gas_optics_init_gas_concs',gas_concs%init(active_gases_array)) + call check_error_msg('rrtmgp_lw_gas_optics_init_load',lw_gas_props%load(gas_concs, & gas_namesLW, key_speciesLW, band2gptLW, band_limsLW, press_refLW, press_ref_tropLW,& temp_refLW, temp_ref_pLW, temp_ref_tLW, vmr_refLW, kmajorLW, kminor_lowerLW, & kminor_upperLW, gas_minorLW, identifier_minorLW, minor_gases_lowerLW, & @@ -454,13 +446,6 @@ subroutine rrtmgp_lw_gas_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, mpicom scale_by_complement_upperLW, kminor_start_lowerLW, kminor_start_upperLW, totplnkLW,& planck_fracLW, rayl_lowerLW, rayl_upperLW, optimal_angle_fitLW)) - ! The minimum pressure allowed in GP RTE calculations. Used to bound uppermost layer - ! temperature (GFS_rrtmgp_pre.F90) - minGPpres = lw_gas_props%get_press_min() - maxGPpres = lw_gas_props%get_press_max() - minGPtemp = lw_gas_props%get_temp_min() - maxGPtemp = lw_gas_props%get_temp_max() - end subroutine rrtmgp_lw_gas_optics_init end module rrtmgp_lw_gas_optics diff --git a/physics/rrtmgp_lw_main.F90 b/physics/rrtmgp_lw_main.F90 index df46e8eda..4a0b47ba1 100644 --- a/physics/rrtmgp_lw_main.F90 +++ b/physics/rrtmgp_lw_main.F90 @@ -39,53 +39,46 @@ module rrtmgp_lw_main !! \section rrtmgp_lw_main_init !> @{ ! ###################################################################################### - subroutine rrtmgp_lw_main_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, mpicomm, mpirank, & - mpiroot, minGPpres, maxGPpres, minGPtemp, maxGPtemp, active_gases_array, nrghice, & - doG_cldoptics, doGP_cldoptics_PADE, doGP_cldoptics_LUT, rrtmgp_lw_file_clouds, & - errmsg, errflg) + subroutine rrtmgp_lw_main_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, & + rrtmgp_lw_file_clouds, active_gases_array, doGP_cldoptics_PADE, & + doGP_cldoptics_LUT, nrghice, mpicomm, mpirank, mpiroot, nrghice, errmsg, errflg) ! Inputs + character(len=128),intent(in) :: & + rrtmgp_root_dir, & ! RTE-RRTMGP root directory + rrtmgp_lw_file_clouds, & ! RRTMGP file containing coefficients used to compute + ! clouds optical properties + rrtmgp_lw_file_gas ! RRTMGP file containing coefficients used to compute + ! gaseous optical properties + character(len=*), dimension(:), intent(in) :: & + active_gases_array ! List of active gases from namelist as array) logical, intent(in) :: & - doG_cldoptics, & ! Use legacy RRTMG cloud-optics? doGP_cldoptics_PADE, & ! Use RRTMGP cloud-optics: PADE approximation? doGP_cldoptics_LUT ! Use RRTMGP cloud-optics: LUTs? integer, intent(inout) :: & nrghice ! Number of ice-roughness categories - character(len=128),intent(in) :: & - rrtmgp_root_dir, & ! RTE-RRTMGP root directory - rrtmgp_lw_file_clouds, & ! RRTMGP file containing coefficients used to compute - ! clouds optical properties - rrtmgp_lw_file_gas ! RRTMGP file containing coefficients used to compute - ! gaseous optical properties integer,intent(in) :: & mpicomm, & ! MPI communicator mpirank, & ! Current MPI rank mpiroot ! Master MPI rank - character(len=*), dimension(:), intent(in) :: & - active_gases_array ! List of active gases from namelist as array) + ! Outputs character(len=*), intent(out) :: & errmsg ! CCPP error message integer, intent(out) :: & errflg ! CCPP error code - real(kind_phys), intent(out) :: & - minGPtemp, & ! Minimum temperature allowed by RRTMGP. - maxGPtemp, & ! Maximum ... - minGPpres, & ! Minimum pressure allowed by RRTMGP. - maxGPpres ! Maximum pressure allowed by RRTMGP. ! Initialize CCPP error handling variables errmsg = '' errflg = 0 ! RRTMGP longwave gas-optics (k-distribution) initialization - call rrtmgp_lw_gas_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, mpicomm, mpirank,& - mpiroot, minGPpres, maxGPpres, minGPtemp, maxGPtemp, active_gases_array, errmsg,& - errflg) + call rrtmgp_lw_gas_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, & + active_gases_array, mpicomm, mpirank, mpiroot, errmsg, errflg) ! RRTMGP longwave cloud-optics initialization - call rrtmgp_lw_cloud_optics_init(nrghice, mpicomm, mpirank, mpiroot, doG_cldoptics, & - doGP_cldoptics_PADE, doGP_cldoptics_LUT, rrtmgp_root_dir, rrtmgp_lw_file_clouds,& + call rrtmgp_lw_cloud_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_clouds, & + doGP_cldoptics_PADE, doGP_cldoptics_LUT, nrghice, mpicomm, mpirank, mpiroot, & errmsg, errflg) end subroutine rrtmgp_lw_main_init @@ -226,14 +219,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, ! ###################################################################################### ! ty_gas_concs - gas_concs%ncol = rrtmgp_phys_blksz - gas_concs%nlay = nLay - allocate(gas_concs%gas_name(nGases)) - allocate(gas_concs%concs(nGases)) - do iGas=1,ngases - allocate(gas_concs%concs(iGas)%conc(rrtmgp_phys_blksz, nLay)) - enddo - gas_concs%gas_name(:) = active_gases_array(:) + call check_error_msg('rrtmgp_lw_main_gas_concs_init',gas_concs%init(active_gases_array)) ! ty_optical_props call check_error_msg('rrtmgp_lw_main_gas_optics_init',& @@ -270,10 +256,6 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, ! Initialize/reset ! ! ################################################################################### - ! ty_gas_concs - do iGas=1,nGases - gas_concs%concs(iGas)%conc(:,:) = 0._kind_phys - end do ! ty_optical_props lw_optical_props_clrsky%tau = 0._kind_phys lw_optical_props_precipByBand%tau = 0._kind_phys @@ -307,12 +289,18 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, ! Set gas-concentrations ! ! ################################################################################### - gas_concs%concs(istr_o2)%conc(:,:) = vmr_o2(iCol:iCol2,:) - gas_concs%concs(istr_co2)%conc(:,:) = vmr_co2(iCol:iCol2,:) - gas_concs%concs(istr_ch4)%conc(:,:) = vmr_ch4(iCol:iCol2,:) - gas_concs%concs(istr_n2o)%conc(:,:) = vmr_n2o(iCol:iCol2,:) - gas_concs%concs(istr_h2o)%conc(:,:) = vmr_h2o(iCol:iCol2,:) - gas_concs%concs(istr_o3)%conc(:,:) = vmr_o3(iCol:iCol2,:) + call check_error_msg('rrtmgp_lw_main_set_vmr_o2', & + gas_concs%set_vmr(trim(active_gases_array(istr_o2)), vmr_o2(iCol:iCol2,:))) + call check_error_msg('rrtmgp_lw_main_set_vmr_co2', & + gas_concs%set_vmr(trim(active_gases_array(istr_co2)),vmr_co2(iCol:iCol2,:))) + call check_error_msg('rrtmgp_lw_main_set_vmr_ch4', & + gas_concs%set_vmr(trim(active_gases_array(istr_ch4)),vmr_ch4(iCol:iCol2,:))) + call check_error_msg('rrtmgp_lw_main_set_vmr_n2o', & + gas_concs%set_vmr(trim(active_gases_array(istr_n2o)),vmr_n2o(iCol:iCol2,:))) + call check_error_msg('rrtmgp_lw_main_set_vmr_h2o', & + gas_concs%set_vmr(trim(active_gases_array(istr_h2o)),vmr_h2o(iCol:iCol2,:))) + call check_error_msg('rrtmgp_lw_main_set_vmr_o3', & + gas_concs%set_vmr(trim(active_gases_array(istr_o3)), vmr_o3(iCol:iCol2,:))) ! ################################################################################### ! @@ -361,6 +349,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, ! in each band ! Include convective (subgrid scale) clouds? if (doGP_sgs_cnv) then + ! Compute call check_error_msg('rrtmgp_lw_main_cnv_cloud_optics',lw_cloud_props%cloud_optics(& cld_cnv_lwp(iCol:iCol2,:), & ! IN - Convective cloud liquid water path (g/m2) cld_cnv_iwp(iCol:iCol2,:), & ! IN - Convective cloud ice water path (g/m2) @@ -368,12 +357,14 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, cld_cnv_reice(iCol:iCol2,:), & ! IN - Convective cloud ice effective radius (microns) lw_optical_props_cnvcloudsByBand)) ! OUT - RRTMGP DDT containing convective cloud radiative properties ! in each band + ! Increment call check_error_msg('rrtmgp_lw_main_increment_cnvclouds_to_clouds',& lw_optical_props_cnvcloudsByBand%increment(lw_optical_props_cloudsByBand)) endif ! Include PBL (subgrid scale) clouds? if (doGP_sgs_pbl) then + ! Compute call check_error_msg('rrtmgp_lw_main_pbl_cloud_optics',lw_cloud_props%cloud_optics(& cld_pbl_lwp(iCol:iCol2,:), & ! IN - PBL cloud liquid water path (g/m2) cld_pbl_iwp(iCol:iCol2,:), & ! IN - PBL cloud ice water path (g/m2) @@ -381,6 +372,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, cld_pbl_reice(iCol:iCol2,:), & ! IN - PBL cloud ice effective radius (microns) lw_optical_props_pblcloudsByBand)) ! OUT - RRTMGP DDT containing PBL cloud radiative properties ! in each band + ! Increment call check_error_msg('rrtmgp_lw_main_increment_pblclouds_to_clouds',& lw_optical_props_pblcloudsByBand%increment(lw_optical_props_cloudsByBand)) endif @@ -411,6 +403,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, endif enddo enddo + ! Increment call check_error_msg('rrtmgp_lw_main_increment_precip_to_clouds',& lw_optical_props_precipByBand%increment(lw_optical_props_cloudsByBand)) @@ -482,7 +475,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, ! Compute clear-sky fluxes (gaseous+aerosol) (optional) ! ! ################################################################################### - ! Add aerosol optics to gas optics + ! Increment lw_optical_props_aerosol_local%tau = aerlw_tau(iCol:iCol2,:,:) call check_error_msg('rrtmgp_lw_main_increment_aerosol_to_clrsky',& lw_optical_props_aerosol_local%increment(lw_optical_props_clrsky)) @@ -534,7 +527,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, ! Include LW cloud-scattering? if (doGP_lwscat) then - ! Add clear-sky optics to cloud-optics (2-stream) + ! Increment call check_error_msg('rrtmgp_lw_main_increment_clrsky_to_clouds',& lw_optical_props_clrsky%increment(lw_optical_props_clouds)) @@ -559,7 +552,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, end if ! No scattering in LW clouds. else - ! Add cloud optics to clear-sky optics (scalar) + ! Increment call check_error_msg('rrtmgp_lw_main_increment_clouds_to_clrsky', & lw_optical_props_clouds%increment(lw_optical_props_clrsky)) diff --git a/physics/rrtmgp_lw_main.meta b/physics/rrtmgp_lw_main.meta index c4a0ec9ee..89e4bed2e 100644 --- a/physics/rrtmgp_lw_main.meta +++ b/physics/rrtmgp_lw_main.meta @@ -36,13 +36,6 @@ type = character intent = in kind = len=128 -[doG_cldoptics] - standard_name = flag_to_calc_lw_cld_optics_using_RRTMG - long_name = logical flag to control cloud optics scheme. - units = flag - dimensions = () - type = logical - intent = in [doGP_cldoptics_PADE] standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_PADE long_name = logical flag to control cloud optics scheme. @@ -85,38 +78,6 @@ dimensions = () type = integer intent = in -[minGPpres] - standard_name = minimum_pressure_in_RRTMGP - long_name = minimum pressure allowed in RRTMGP - units = Pa - dimensions = () - type = real - kind = kind_phys - intent = out -[maxGPpres] - standard_name = maximum_pressure_in_RRTMGP - long_name = maximum pressure allowed in RRTMGP - units = Pa - dimensions = () - type = real - kind = kind_phys - intent = out -[minGPtemp] - standard_name = minimum_temperature_in_RRTMGP - long_name = minimum temperature allowed in RRTMGP - units = K - dimensions = () - type = real - kind = kind_phys - intent = out -[maxGPtemp] - standard_name = maximum_temperature_in_RRTMGP - long_name = maximum temperature allowed in RRTMGP - units = K - dimensions = () - type = real - kind = kind_phys - intent = out [active_gases_array] standard_name = list_of_active_gases_used_by_RRTMGP long_name = list of active gases used by RRTMGP diff --git a/physics/rrtmgp_sw_cloud_optics.F90 b/physics/rrtmgp_sw_cloud_optics.F90 index 287fab719..4293a7be6 100644 --- a/physics/rrtmgp_sw_cloud_optics.F90 +++ b/physics/rrtmgp_sw_cloud_optics.F90 @@ -48,44 +48,41 @@ module rrtmgp_sw_cloud_optics pade_exticeSW, & ! PADE coefficients for shortwave ice extinction pade_ssaiceSW, & ! PADE coefficients for shortwave ice single scattering albedo pade_asyiceSW ! PADE coefficients for shortwave ice asymmetry parameter + real(kind_phys) :: & + radliq_lwrSW, & ! Liquid particle size lower bound for LUT interpolation + radliq_uprSW, & ! Liquid particle size upper bound for LUT interpolation + radice_lwrSW, & ! Ice particle size upper bound for LUT interpolation + radice_uprSW ! Ice particle size lower bound for LUT interpolation - ! Parameters used for rain and snow(+groupel) RRTMGP cloud-optics + ! Parameters used for rain and snow(+groupel) RRTMGP cloud-optics. *NOTE* Same as in RRTMG + ! Need to document these magic numbers below. real(kind_phys),parameter :: & - a0r = 3.07e-3, & ! - a0s = 0.0, & ! - a1s = 1.5 ! + a0r = 3.07e-3, & ! + a0s = 0.0, & ! + a1s = 1.5 ! real(kind_phys),dimension(:),allocatable :: b0r,b0s,b1s,c0r,c0s - real(kind_phys) :: & - radliq_lwrSW, & ! Liquid particle size lower bound for LUT interpolation - radliq_uprSW, & ! Liquid particle size upper bound for LUT interpolation - radice_lwrSW, & ! Ice particle size upper bound for LUT interpolation - radice_uprSW ! Ice particle size lower bound for LUT interpolation contains ! ###################################################################################### ! SUBROUTINE sw_cloud_optics_init ! ###################################################################################### -!! \section arg_table_rrtmgp_sw_cloud_optics_init -!! \htmlinclude rrtmgp_lw_cloud_optics.html -!! - subroutine rrtmgp_sw_cloud_optics_init(doG_cldoptics, doGP_cldoptics_PADE, & - doGP_cldoptics_LUT, nrghice, rrtmgp_root_dir, rrtmgp_sw_file_clouds, mpicomm, & - mpirank, mpiroot, errmsg, errflg) + subroutine rrtmgp_sw_cloud_optics_init( rrtmgp_root_dir, rrtmgp_sw_file_clouds, & + doGP_cldoptics_PADE, doGP_cldoptics_LUT, nrghice, mpicomm, mpirank, mpiroot, & + errmsg, errflg) ! Inputs + character(len=128),intent(in) :: & + rrtmgp_root_dir, & ! RTE-RRTMGP root directory + rrtmgp_sw_file_clouds ! RRTMGP file containing cloud-optic data logical, intent(in) :: & - doG_cldoptics, & ! Use legacy RRTMG cloud-optics? - doGP_cldoptics_PADE, & ! Use RRTMGP cloud-optics: PADE approximation? - doGP_cldoptics_LUT ! Use RRTMGP cloud-optics: LUTs? + doGP_cldoptics_PADE,& ! Use RRTMGP cloud-optics: PADE approximation? + doGP_cldoptics_LUT ! Use RRTMGP cloud-optics: LUTs? integer, intent(inout) :: & nrghice ! Number of ice-roughness categories integer, intent(in) :: & mpicomm, & ! MPI communicator mpirank, & ! Current MPI rank mpiroot ! Master MPI rank - character(len=128),intent(in) :: & - rrtmgp_root_dir, & ! RTE-RRTMGP root directory - rrtmgp_sw_file_clouds ! RRTMGP file containing coefficients used to compute clouds optical properties ! Outputs character(len=*), intent(out) :: & @@ -101,8 +98,6 @@ subroutine rrtmgp_sw_cloud_optics_init(doG_cldoptics, doGP_cldoptics_PADE, errmsg = '' errflg = 0 - if (doG_cldoptics) return - ! Filenames are set in the physics_nml sw_cloud_props_file = trim(rrtmgp_root_dir)//trim(rrtmgp_sw_file_clouds) @@ -161,7 +156,7 @@ subroutine rrtmgp_sw_cloud_optics_init(doG_cldoptics, doGP_cldoptics_PADE, call mpi_bcast(nPairsSW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) #endif - ! Has the number of ice-roughnesses provided from the namelist? + ! Has the number of ice-roughnes categories been provided from the namelist? ! If so, override nrghice from cloud-optics file if (nrghice .ne. 0) nrghice_fromfileSW = nrghice #ifdef MPI diff --git a/physics/rrtmgp_sw_gas_optics.F90 b/physics/rrtmgp_sw_gas_optics.F90 index 823cdc1ca..f62a75e4b 100644 --- a/physics/rrtmgp_sw_gas_optics.F90 +++ b/physics/rrtmgp_sw_gas_optics.F90 @@ -2,11 +2,8 @@ !! !> \defgroup rrtmgp_sw_gas_optics rrtmgp_sw_gas_optics.F90 !! -!! \brief This module contains two routines: One to initialize the k-distribution data -!! and functions needed to compute the shortwave gaseous optical properties in RRTMGP. -!! The second routine is a ccpp scheme within the "radiation loop", where the shortwave -!! optical prperties (optical-depth, single-scattering albedo, asymmetry parameter) are -!! computed for clear-sky conditions (no aerosols) +!! \brief This module contains a routine to initialize the k-distribution data used +!! by the RRTMGP shortwave radiation scheme. !! module rrtmgp_sw_gas_optics use machine, only: kind_phys @@ -82,7 +79,7 @@ module rrtmgp_sw_gas_optics scale_by_complement_upperSW ! Absorption is scaled by concentration of scaling_gas (F) or its complement (T) contains - + ! ###################################################################################### !>\defgroup rrtmgp_sw_gas_optics_mod GFS RRTMGP-SW Gas Optics Module !> @{ !! \section arg_table_rrtmgp_sw_gas_optics_init @@ -99,19 +96,19 @@ module rrtmgp_sw_gas_optics !! \section rrtmgp_sw_gas_optics_init !> @{ ! ###################################################################################### - subroutine rrtmgp_sw_gas_optics_init(rrtmgp_root_dir, rrtmgp_sw_file_gas, & + subroutine rrtmgp_sw_gas_optics_init(rrtmgp_root_dir, rrtmgp_sw_file_gas, & active_gases_array, mpicomm, mpirank, mpiroot, errmsg, errflg) ! Inputs character(len=128),intent(in) :: & rrtmgp_root_dir, & ! RTE-RRTMGP root directory - rrtmgp_sw_file_gas ! RRTMGP file containing coefficients used to compute gaseous optical properties + rrtmgp_sw_file_gas ! RRTMGP file containing K-distribution data + character(len=*), dimension(:), intent(in) :: & + active_gases_array ! List of active gases from namelist as array integer,intent(in) :: & mpicomm, & ! MPI communicator mpirank, & ! Current MPI rank mpiroot ! Master MPI rank - character(len=*), dimension(:), intent(in) :: & - active_gases_array ! List of active gases from namelist as array ! Outputs character(len=*), intent(out) :: & @@ -120,10 +117,10 @@ subroutine rrtmgp_sw_gas_optics_init(rrtmgp_root_dir, rrtmgp_sw_file_gas, errflg ! CCPP error code ! Local variables - integer :: status, ncid, dimid, varID, iGas, mpierr, iChar + integer :: status, ncid, dimid, varID, mpierr, iChar integer,dimension(:),allocatable :: temp1, temp2, temp3, temp4 character(len=264) :: sw_gas_props_file - type(ty_gas_concs) :: gas_concentrations ! RRTMGP DDT containing active trace gases + type(ty_gas_concs) :: gas_concs ! RRTMGP DDT containing active trace gases ! Initialize errmsg = '' @@ -486,17 +483,14 @@ subroutine rrtmgp_sw_gas_optics_init(rrtmgp_root_dir, rrtmgp_sw_file_gas, ! Initialize RRTMGP DDT's... ! ! ####################################################################################### - allocate(gas_concentrations%gas_name(1:size(active_gases_array))) - gas_concentrations%gas_name(:) = active_gases_array(:) - call check_error_msg('sw_gas_optics_init',sw_gas_props%load(gas_concentrations, & + call check_error_msg('rrtmgp_sw_gas_optics_init_gas_concs',gas_concs%init(active_gases_array)) + call check_error_msg('rrtmgp_sw_gas_optics_init_load',sw_gas_props%load(gas_concs, & gas_namesSW, key_speciesSW, band2gptSW, band_limsSW, press_refSW, press_ref_tropSW,& temp_refSW, temp_ref_pSW, temp_ref_tSW, vmr_refSW, kmajorSW, kminor_lowerSW, & kminor_upperSW, gas_minorSW, identifier_minorSW, minor_gases_lowerSW, & minor_gases_upperSW, minor_limits_gpt_lowerSW, minor_limits_gpt_upperSW, & minor_scales_with_density_lowerSW, minor_scales_with_density_upperSW, & scaling_gas_lowerSW, scaling_gas_upperSW, scale_by_complement_lowerSW, & - - scale_by_complement_upperSW, kminor_start_lowerSW, kminor_start_upperSW, & solar_quietSW, solar_facularSW, solar_sunspotSW, tsi_defaultSW, mg_defaultSW, & sb_defaultSW, rayl_lowerSW, rayl_upperSW)) diff --git a/physics/rrtmgp_sw_main.F90 b/physics/rrtmgp_sw_main.F90 index 232bb5847..1c47f1cd0 100644 --- a/physics/rrtmgp_sw_main.F90 +++ b/physics/rrtmgp_sw_main.F90 @@ -28,26 +28,26 @@ module rrtmgp_sw_main !! \section arg_table_rrtmgp_sw_main_init !! \htmlinclude rrtmgp_sw_main_init.html !! - subroutine rrtmgp_sw_main_init(rrtmgp_root_dir, rrtmgp_sw_file_gas, mpicomm, mpirank, & - mpiroot, active_gases_array, nrghice, doG_cldoptics, doGP_cldoptics_PADE, & - doGP_cldoptics_LUT,rrtmgp_sw_file_clouds, errmsg, errflg) + subroutine rrtmgp_sw_main_init(rrtmgp_root_dir, rrtmgp_sw_file_gas, rrtmgp_sw_file_clouds,& + active_gases_array, doGP_cldoptics_PADE, doGP_cldoptics_LUT, nrghice, mpicomm, & + mpirank, mpiroot, errmsg, errflg) + ! Inputs + character(len=128),intent(in) :: & + rrtmgp_root_dir, & ! RTE-RRTMGP root directory + rrtmgp_sw_file_clouds, & ! RRTMGP file containing K-distribution data + rrtmgp_sw_file_gas ! RRTMGP file containing cloud-optics data + character(len=*), dimension(:), intent(in) :: & + active_gases_array ! List of active gases from namelist as array) logical, intent(in) :: & - doG_cldoptics, & ! Use legacy RRTMG cloud-optics? doGP_cldoptics_PADE, & ! Use RRTMGP cloud-optics: PADE approximation? doGP_cldoptics_LUT ! Use RRTMGP cloud-optics: LUTs? integer, intent(inout) :: & nrghice ! Number of ice-roughness categories - character(len=128),intent(in) :: & - rrtmgp_root_dir, & ! RTE-RRTMGP root directory - rrtmgp_sw_file_clouds, & ! RRTMGP file containing coefficients used to compute clouds optical properties - rrtmgp_sw_file_gas ! RRTMGP file containing coefficients used to compute gaseous optical properties integer,intent(in) :: & mpicomm, & ! MPI communicator mpirank, & ! Current MPI rank mpiroot ! Master MPI rank - character(len=*), dimension(:), intent(in) :: & - active_gases_array ! List of active gases from namelist as array) ! Outputs character(len=*), intent(out) :: & errmsg ! CCPP error message @@ -59,13 +59,14 @@ subroutine rrtmgp_sw_main_init(rrtmgp_root_dir, rrtmgp_sw_file_gas, mpicomm, mpi errflg = 0 ! RRTMGP shortwave gas-optics (k-distribution) initialization - call rrtmgp_sw_gas_optics_init(rrtmgp_root_dir, rrtmgp_sw_file_gas, active_gases_array, & + call rrtmgp_sw_gas_optics_init(rrtmgp_root_dir, rrtmgp_sw_file_gas, active_gases_array,& mpicomm, mpirank, mpiroot, errmsg, errflg) ! RRTMGP shortwave cloud-optics initialization - call rrtmgp_sw_cloud_optics_init(doG_cldoptics, doGP_cldoptics_PADE, doGP_cldoptics_LUT,& - nrghice, rrtmgp_root_dir, rrtmgp_sw_file_clouds, mpicomm, mpirank, mpiroot, errmsg,& - errflg) + call rrtmgp_sw_cloud_optics_init(rrtmgp_root_dir, rrtmgp_sw_file_clouds, & + doGP_cldoptics_PADE, doGP_cldoptics_LUT, nrghice, mpicomm, mpirank, mpiroot, & + errmsg, errflg) + end subroutine rrtmgp_sw_main_init ! ######################################################################################### @@ -222,14 +223,7 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ ! ###################################################################################### ! ty_gas_concs - gas_concs%ncol = rrtmgp_phys_blksz - gas_concs%nlay = nLay - allocate(gas_concs%gas_name(nGases)) - allocate(gas_concs%concs(nGases)) - do iGas=1,nGases - allocate(gas_concs%concs(iGas)%conc(rrtmgp_phys_blksz, nLay)) - enddo - gas_concs%gas_name(:) = active_gases_array(:) + call check_error_msg('rrtmgp_sw_main_gas_concs_init',gas_concs%init(active_gases_array)) ! ty_optical_props call check_error_msg('rrtmgp_sw_main_accumulated_optics_init',& @@ -281,9 +275,6 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ sw_optical_props_precipByBand%tau = 0._kind_phys sw_optical_props_precipByBand%ssa = 0._kind_phys sw_optical_props_precipByBand%g = 0._kind_phys - !sw_optical_props_aerosol_local%tau = 0._kind_phys - !sw_optical_props_aerosol_local%ssa = 0._kind_phys - !sw_optical_props_aerosol_local%g = 0._kind_phys if (doGP_sgs_cnv) then sw_optical_props_cnvcloudsByBand%tau = 0._kind_phys sw_optical_props_cnvcloudsByBand%ssa = 0._kind_phys @@ -302,13 +293,19 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ ! Set gas-concentrations ! ! ################################################################################### - gas_concs%concs(istr_o2)%conc(:,:) = vmr_o2(ix:ix2,:) - gas_concs%concs(istr_co2)%conc(:,:) = vmr_co2(ix:ix2,:) - gas_concs%concs(istr_ch4)%conc(:,:) = vmr_ch4(ix:ix2,:) - gas_concs%concs(istr_n2o)%conc(:,:) = vmr_n2o(ix:ix2,:) - gas_concs%concs(istr_h2o)%conc(:,:) = vmr_h2o(ix:ix2,:) - gas_concs%concs(istr_o3)%conc(:,:) = vmr_o3(ix:ix2,:) - + call check_error_msg('rrtmgp_sw_main_set_vmr_o2', & + gas_concs%set_vmr(trim(active_gases_array(istr_o2)), vmr_o2(ix:ix2,:))) + call check_error_msg('rrtmgp_sw_main_set_vmr_co2', & + gas_concs%set_vmr(trim(active_gases_array(istr_co2)),vmr_co2(ix:ix2,:))) + call check_error_msg('rrtmgp_sw_main_set_vmr_ch4', & + gas_concs%set_vmr(trim(active_gases_array(istr_ch4)),vmr_ch4(ix:ix2,:))) + call check_error_msg('rrtmgp_sw_main_set_vmr_n2o', & + gas_concs%set_vmr(trim(active_gases_array(istr_n2o)),vmr_n2o(ix:ix2,:))) + call check_error_msg('rrtmgp_sw_main_set_vmr_h2o', & + gas_concs%set_vmr(trim(active_gases_array(istr_h2o)),vmr_h2o(ix:ix2,:))) + call check_error_msg('rrtmgp_sw_main_set_vmr_o3', & + gas_concs%set_vmr(trim(active_gases_array(istr_o3)), vmr_o3(ix:ix2,:))) + ! ################################################################################### ! ! Set surface albedo @@ -373,6 +370,7 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ ! Include convective clouds? if (doGP_sgs_cnv) then + ! Compute call check_error_msg('rrtmgp_sw_main_cnv_cloud_optics',sw_cloud_props%cloud_optics(& cld_cnv_lwp(ix:ix2,:), & ! IN - Convective cloud liquid water path (g/m2) cld_cnv_iwp(ix:ix2,:), & ! IN - Convective cloud ice water path (g/m2) @@ -380,13 +378,14 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ cld_cnv_reice(ix:ix2,:), & ! IN - Convective cloud ice effective radius (microns) sw_optical_props_cnvcloudsByBand)) ! OUT - RRTMGP DDT containing convective cloud radiative properties ! in each band - ! + ! Increment call check_error_msg('rrtmgp_sw_main_increment_cnvclouds_to_clouds',& sw_optical_props_cnvcloudsByBand%increment(sw_optical_props_cloudsByBand)) endif ! Include PBL clouds? if (doGP_sgs_pbl) then + ! Compute call check_error_msg('rrtmgp_sw_main_pbl_cloud_optics',sw_cloud_props%cloud_optics(& cld_pbl_lwp(ix:ix2,:), & ! IN - PBL cloud liquid water path (g/m2) cld_pbl_iwp(ix:ix2,:), & ! IN - PBL cloud ice water path (g/m2) @@ -394,7 +393,7 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ cld_pbl_reice(ix:ix2,:), & ! IN - PBL cloud ice effective radius (microns) sw_optical_props_pblcloudsByBand)) ! OUT - RRTMGP DDT containing PBL cloud radiative properties ! in each band - ! + ! Increment call check_error_msg('rrtmgp_sw_main_increment_pblclouds_to_clouds',& sw_optical_props_pblcloudsByBand%increment(sw_optical_props_cloudsByBand)) endif @@ -433,7 +432,7 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ endif enddo enddo - ! + ! Increment call check_error_msg('rrtmgp_sw_main_increment_precip_to_clouds',& sw_optical_props_precipByBand%increment(sw_optical_props_cloudsByBand)) @@ -503,7 +502,7 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ ! Compute clear-sky fluxes (gaseous+aerosol) (optional) ! ! ################################################################################### - ! Add aerosol optics to gaseous (clear-sky) optical properties + ! Increment sw_optical_props_aerosol_local%tau = aersw_tau(iCol:iCol+rrtmgp_phys_blksz-1,:,:) sw_optical_props_aerosol_local%ssa = aersw_ssa(iCol:iCol+rrtmgp_phys_blksz-1,:,:) sw_optical_props_aerosol_local%g = aersw_g(iCol:iCol+rrtmgp_phys_blksz-1,:,:) @@ -563,7 +562,7 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ ! Delta scale !call check_error_msg('rrtmgp_sw_main_delta_scale',sw_optical_props_clouds%delta_scale()) - ! Add clear-sky to cloud-sky + ! Increment call check_error_msg('rrtmgp_sw_main_increment_clouds_to_clrsky', & sw_optical_props_clouds%increment(sw_optical_props_accum)) diff --git a/physics/rrtmgp_sw_main.meta b/physics/rrtmgp_sw_main.meta index 1d50a780e..78e435c96 100644 --- a/physics/rrtmgp_sw_main.meta +++ b/physics/rrtmgp_sw_main.meta @@ -36,13 +36,6 @@ type = character intent = in kind = len=128 -[doG_cldoptics] - standard_name = flag_to_calc_lw_cld_optics_using_RRTMG - long_name = logical flag to control cloud optics scheme. - units = flag - dimensions = () - type = logical - intent = in [doGP_cldoptics_PADE] standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_PADE long_name = logical flag to control cloud optics scheme. From 757a4eb2a18d62fcad2df6112b9865b915b12b7a Mon Sep 17 00:00:00 2001 From: Samuel Trahan Date: Fri, 26 Aug 2022 19:30:17 +0000 Subject: [PATCH 033/380] tweaks for salty lakes --- physics/clm_lake.f90 | 213 ++++++++++++++++++++++++++++++++++++++---- physics/clm_lake.meta | 22 +++++ 2 files changed, 216 insertions(+), 19 deletions(-) diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90 index 9b8db78b8..1a2f88d80 100644 --- a/physics/clm_lake.f90 +++ b/physics/clm_lake.f90 @@ -31,6 +31,10 @@ MODULE clm_lake implicit none + private + + public :: clm_lake_run, clm_lake_init, LAKEDEBUG + logical :: LAKEDEBUG = .false. ! Enable lots of checks and debug prints and errors logical, parameter :: PERGRO = .false. @@ -119,8 +123,122 @@ MODULE clm_lake real(kind_phys) :: dzsoi(1:nlevsoil) !soil dz (thickness) real(kind_phys) :: zisoi(0:nlevsoil) !soil zi (interfaces) + real, parameter :: SaltLk_T(1:25) = (/0.5, 0.,-0.5, 3., 4., 7., 8., 12., 13., 16., 19., 21., & + 23.5, 25.,26.,24.,23.,20.5,18.,15., 11.5, 8., 4., 1., 0.5/) + real, parameter :: julm(1:13) = (/0,31,59,90,120,151,181,212,243,273,304,334,365/) + CONTAINS + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine get_month_and_day(IDATE,month,day_of_month,day_of_year,fhour) + implicit none + integer, intent(in) :: IDATE(4) + integer, intent(out) :: month,day_of_month,day_of_year + real(kind_phys), intent(in) :: fhour + + integer :: idat(8),jdat(8), w3kindreal, w3kindint, jdow, jdoy, jday + real(8) :: rinc(5) + real(4) :: rinc4(5) + + idat = 0 + idat(1) = idate(4) + idat(2) = idate(2) + idat(3) = idate(3) + idat(5) = idate(1) + rinc = 0. + rinc(2) = fhour + call w3kind(w3kindreal,w3kindint) + if(w3kindreal==4) then + rinc4 = rinc + CALL W3MOVDAT(RINC4,IDAT,JDAT) + else + CALL W3MOVDAT(RINC,IDAT,JDAT) + endif +! + jdow = 0 + jdoy = 0 + jday = 0 + call w3doxdat(jdat,jdow,jdoy,jday) + + day_of_year = jday + day_of_month = IDATE(3) + month = IDATE(2) + end subroutine get_month_and_day + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + logical function limit_temperature_by_climatology(xlat_d,xlon_positive) + implicit none + real(kind_phys), intent(in) :: xlat_d, xlon_positive + real(kind_phys) :: xlon_d + + xlon_d = xlon_positive + if(xlon_d>180) xlon_d = xlon_d - 360 + + limit_temperature_by_climatology=.false. + + !tgs - 7nov19 - salinity effect on freezing point (Tanya, Stan, Trevor). + ! --- The Great Salt Lake (GSL), Utah lat/long (39.5-42.0,-111.5- -117.7). + ! --- THe GSL's salinity is 270 ppt above ~41.22 N with freezing point of -24 C, + ! --- and 150 ppt south of ~41.22 N with freezing point -10 C (info from Trevor Alcott). + ! --- The fresh-water Willard Bay should be excluded from the box around the Great Salt + ! --- Lake: lat/long 41.3539, -112.102, HRRR i,j = 494,667 (info from Stan and Trevor). + ! --- + ! --- 1jun2020: reset the GSL freezing point to be -5 C, + ! --- and add a check (after call to LakeMain) to keep the lake ice free for the whole year. + if ((xlon_d.gt.-117.7 .and. xlon_d.lt.-111.5) .and. & + ! excludes Willard Bay + .not. (xlon_d.gt.-112.104 .and. xlon_d.lt.-112.100))then + + if(xlat_d.gt.39.5 .and. xlat_d.lt.41.22) then + if(lakedebug) then + print *,'The Great Salt Lake south of 41.22 N, lat,lon',xlat_d,xlon_d + endif + limit_temperature_by_climatology = .true. + + elseif(( xlat_d.ge.41.22 .and. xlat_d.lt.42.) .and. .not. & + ! excludes Willard Bay + (xlat_d.gt.41.352 .and. xlat_d.lt.41.354)) then + if(lakedebug) then + print *,'The Great Salt Lake north of 41.22 N xlat_d,xlon_d ',xlat_d,xlon_d + endif + !print *,'Ice fraction on the GSL ', i,j,lake_icefrac3d(i,:,j) + limit_temperature_by_climatology = .true. + + endif ! xlat_d + + endif ! xlon_d + + !if(i==495.and.j==668) print *,'Willard Bay salty=',i,j,limit_temperature_by_climatology,xlat_d,xlon_d + + end function limit_temperature_by_climatology + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + logical function is_salty(xlat_d,xlon_positive) + implicit none + real(kind_phys), intent(in) :: xlat_d, xlon_positive + real(kind_phys) :: xlon_d + + xlon_d = xlon_positive + if(xlon_d>180) xlon_d = xlon_d - 360 + + is_salty=limit_temperature_by_climatology(xlat_d,xlon_d) + + ! --- The Mono Lake in California, salinity is 75 ppt with freezing point at + ! --- -4.2 C (Stan). The Mono Lake lat/long (37.9-38.2, -119.3 - 118.8) + if (xlon_d.gt.-119.3.and. xlon_d.lt.-118.8) then + if(xlat_d.gt.37.9 .and. xlat_d.lt.38.2) then + is_salty = .true. + print *,'Mono Lake, i,j',xlat_d,xlon_d + endif ! xlat_d + endif ! xlon_d + !tgs --- end of special treatment for salty lakes + end function is_salty + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !> \section arg_table_clm_lake_run Argument Table !! \htmlinclude clm_lake_run.html !! @@ -136,8 +254,8 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& dz3d ,zi3d ,h2osoi_vol3d ,h2osoi_liq3d ,& h2osoi_ice3d ,t_grnd2d ,t_soisno3d ,t_lake3d ,& savedtke12d ,lake_icefrac3d ,use_lake_model ,& - iopt_lake ,iopt_lake_clm ,& - con_cp ,icy ,& + iopt_lake ,iopt_lake_clm ,fhour ,& + con_cp ,icy ,IDATE ,& hflx ,evap ,grdflx ,tsfc ,& !o lake_t2m ,lake_q2m ,clm_lake_initialized ,& weasd ,isltyp ,snowd ,use_lakedepth ,& @@ -149,7 +267,7 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& ch ,cm ,chh ,cmm ,& lake_t_snow ,tisfc ,tsurf_ice ,wind ,& ! - xlon_d ,kdt ,tg3 ,& + xlon_d ,kdt ,tg3 ,salty ,& me ,master ,errmsg ,errflg ) !============================================================================== @@ -162,13 +280,13 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& !in: - INTEGER, INTENT(IN) :: iopt_lake, iopt_lake_clm, kdt + INTEGER, INTENT(IN) :: iopt_lake, iopt_lake_clm, kdt, IDATE(4) INTEGER, INTENT(OUT) :: errflg CHARACTER(*), INTENT(OUT) :: errmsg INTEGER , INTENT (IN) :: im,km,me,master LOGICAL, INTENT(IN) :: restart,use_lakedepth,first_time_step REAL(KIND_PHYS), INTENT(INOUT) :: clm_lake_initialized(:) - REAL(KIND_PHYS), INTENT(IN) :: min_lakeice, con_rd,con_g,con_cp,lakedepth_default + REAL(KIND_PHYS), INTENT(IN) :: min_lakeice, con_rd,con_g,con_cp,lakedepth_default, fhour logical, intent(inout) :: icy(:) REAL(KIND_PHYS), DIMENSION( : ), INTENT(INOUT):: fice REAL(KIND_PHYS), DIMENSION( : ), INTENT(IN) :: weasd, snowd @@ -199,6 +317,7 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(IN) :: rain REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(INOUT) :: albedo INTEGER, DIMENSION( : ), INTENT(IN) :: ISLTYP + INTEGER, DIMENSION( : ), INTENT(INOUT) :: salty REAL(KIND_PHYS), INTENT(IN) :: dtp REAL(KIND_PHYS), DIMENSION( :,: ),INTENT(INOUT) :: z_lake3d REAL(KIND_PHYS), DIMENSION( :,: ),INTENT(INOUT) :: dz_lake3d @@ -363,17 +482,17 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& ! Still have some points to initialize call lakeini(kdt, ISLTYP, gt0, snowd, & !i - weasd, restart, lakedepth_default, & + weasd, restart, lakedepth_default, fhour, & lakedepth2d, savedtke12d, snowdp2d, h2osno2d, & !o snl2d, t_grnd2d, t_lake3d, lake_icefrac3d, & z_lake3d, dz_lake3d, t_soisno3d, h2osoi_ice3d, & h2osoi_liq3d, h2osoi_vol3d, z3d, dz3d, & zi3d, watsat3d, csol3d, tkmg3d, & - fice, min_lakeice, tsfc, & + IDATE, fice, min_lakeice, tsfc, & use_lake_model, use_lakedepth, con_g, con_rd, & tkdry3d, tksatu3d, im, prsi, & - clm_lake_initialized, & - sand3d, clay3d, tg3, & + xlat_d, xlon_d, clm_lake_initialized, & + sand3d, clay3d, tg3, salty, & km, me, master, errmsg, errflg) if(errflg/=0) then return @@ -399,6 +518,9 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& if_lake_is_here: if (flag_iter(i) .and. use_lake_model(i)/=0) THEN + + + SFCTMP = gt0(i,1) PBOT = prsi(i,2) PSFC = prsi(i,1) @@ -437,7 +559,13 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& t_grnd(c) = t_grnd2d(i) do k = 1,nlevlake t_lake(c,k) = t_lake3d(i,k) - lake_icefrac(c,k) = lake_icefrac3d(i,k) + !-- If T of salty lakes is above the freezing point, keep them ice free + if(salty(i)==1 .and. t_lake(c,k) > tfrz .and. lake_icefrac3d(i,k) > 0.) then + lake_icefrac(c,k) = 0. + else + lake_icefrac(c,k) = lake_icefrac3d(i,k) + endif + !lake_icefrac(c,k) = lake_icefrac3d(i,k) z_lake(c,k) = z_lake3d(i,k) dz_lake(c,k) = dz_lake3d(i,k) enddo @@ -5125,17 +5253,17 @@ end subroutine clm_lake_init ! Some fields in lakeini are not available until runtime, so this cannot be in a CCPP init routine. SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, & !i - weasd, restart, lakedepth_default, & + weasd, restart, lakedepth_default, fhour, & lakedepth2d, savedtke12d, snowdp2d, h2osno2d, & !o snl2d, t_grnd2d, t_lake3d, lake_icefrac3d, & z_lake3d, dz_lake3d, t_soisno3d, h2osoi_ice3d, & h2osoi_liq3d, h2osoi_vol3d, z3d, dz3d, & zi3d, watsat3d, csol3d, tkmg3d, & - fice, min_lakeice, tsfc, & + IDATE, fice, min_lakeice, tsfc, & use_lake_model, use_lakedepth, con_g, con_rd, & tkdry3d, tksatu3d, im, prsi, & - clm_lake_initialized, & - sand3d, clay3d, tg3, & + xlat_d, xlon_d, clm_lake_initialized, & + sand3d, clay3d, tg3, salty, & km, me, master, errmsg, errflg) !============================================================================== @@ -5149,12 +5277,12 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, INTEGER, INTENT(OUT) :: errflg CHARACTER(*), INTENT(OUT) :: errmsg - INTEGER , INTENT (IN) :: im, me, master, km, kdt - REAL(KIND_PHYS), INTENT(IN) :: min_lakeice, con_g, con_rd - REAL(KIND_PHYS), DIMENSION(IM), INTENT(IN):: FICE,TG3 + INTEGER , INTENT (IN) :: im, me, master, km, kdt, IDATE(4) + REAL(KIND_PHYS), INTENT(IN) :: min_lakeice, con_g, con_rd, fhour + REAL(KIND_PHYS), DIMENSION(IM), INTENT(IN):: FICE,TG3, xlat_d, xlon_d REAL(KIND_PHYS), DIMENSION(IM), INTENT(IN):: tsfc REAL(KIND_PHYS), DIMENSION(IM) ,INTENT(INOUT) :: clm_lake_initialized - + INTEGER, DIMENSION(IM) ,INTENT(INOUT) :: salty integer, dimension(IM), intent(in) :: use_lake_model !INTEGER , INTENT (IN) :: lakeflag !INTEGER , INTENT (INOUT) :: lake_depth_flag @@ -5219,16 +5347,43 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, character*256 :: message real(kind_phys) :: ht + logical :: climatology_limits + integer, parameter :: xcheck=38 integer, parameter :: ycheck=92 - integer :: used_lakedepth_default, init_points + integer :: used_lakedepth_default, init_points, month, julday + integer :: mon, iday, num2, num1, juld, day2, day1, wght1, wght2 + real(kind_phys) :: Tclim used_lakedepth_default=0 errmsg = '' errflg = 0 + call get_month_and_day(IDATE,month,iday,julday,fhour) + + !-- Compute weight for the current day + mon = month + if(iday > 15) mon=mon+1 + if(mon == 1) mon=13 + + num2 = month * 2 + if(iday > 15) num2=num2+1 + if(num2 == 1) num2=25 + num1 = num2 - 1 + + juld = julday + if (juld < 7) juld = juld + 365 + day2 = julm(mon)+15 + day1 = julm(mon) + wght1=(day2-julday)/float(day2-day1) + wght2=(julday-day1)/float(day2-day1) + + if(LAKEDEBUG .and. me==0) then + print *,'month,num1,num2,day1,day2,wght1,wght2',month,num1,num2,day1,day2,wght1,wght2 + endif + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DO i=1,im @@ -5253,6 +5408,12 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, cycle endif + if(is_salty(xlat_d(i),xlon_d(i))) then + salty(i) = 1 + else + salty(i) = 0 + endif + snowdp2d(i) = snowd(i)*1e-3 ! SNOW in kg/m^2 and snowdp in m h2osno2d(i) = weasd(i) ! mm @@ -5274,6 +5435,20 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, if(fice(i)>min_lakeice) then lake_icefrac3d(i,1) = fice(i) endif + + !-- Check on the Great Salt Lake (GSL) when the model is cycled + !-- Bound the GSL temperature with +/- 3 C from climatology + if(limit_temperature_by_climatology(xlat_d(i),xlon_d(i))) then + Tclim = tfrz + wght1*saltlk_t(num1) & + + wght2*saltlk_t(num2) + if(lakedebug) print *,'Tclim,tsfc,t_lake3d',i,Tclim,tsfc(i),t_lake3d(i,:),t_soisno3d(i,:) + t_grnd2d(i) = min(Tclim+3.0_kind_phys,(max(tsfc(i),Tclim-3.0_kind_phys))) + do k = 1,nlevlake + t_lake3d(i,k) = min(Tclim+3.0_kind_phys,(max(t_lake3d(i,k),Tclim-3.0_kind_phys))) + enddo + t_soisno3d(i,1) = min(Tclim+3.0_kind_phys,(max(t_soisno3d(i,1),Tclim-3.0_kind_phys))) + if(lakedebug) print *,'After Tclim,tsfc,t_lake3d',i,Tclim,tsfc(i),t_lake3d(i,:),t_soisno3d(i,:) + endif z3d(i,:) = 0.0 dz3d(i,:) = 0.0 diff --git a/physics/clm_lake.meta b/physics/clm_lake.meta index 1fd67984c..d2fc08d81 100644 --- a/physics/clm_lake.meta +++ b/physics/clm_lake.meta @@ -7,6 +7,28 @@ [ccpp-arg-table] name = clm_lake_run type = scheme +[fhour] + standard_name = forecast_time + long_name = current forecast time + units = h + dimensions = () + type = real + kind = kind_phys + intent = in +[idate] + standard_name = date_and_time_at_model_initialization_in_united_states_order + long_name = initial date with different size and ordering + units = none + dimensions = (4) + type = integer + intent = in +[salty] + standard_name = clm_lake_is_salty + long_name = lake at this point is salty (1) or not (0) + units = 1 + dimensions = (horizontal_loop_extent) + type = integer + intent = inout [tg3] standard_name = deep_soil_temperature long_name = deep soil temperature From 9470375468f8495c38474dcd96be1d29ed67878a Mon Sep 17 00:00:00 2001 From: Samuel Trahan Date: Fri, 26 Aug 2022 20:37:11 +0000 Subject: [PATCH 034/380] fix bugs in salty code and add Caspian & Dead seas --- physics/clm_lake.f90 | 41 +++++++++++++++++++++++++++-------------- 1 file changed, 27 insertions(+), 14 deletions(-) diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90 index 1a2f88d80..a472e47bd 100644 --- a/physics/clm_lake.f90 +++ b/physics/clm_lake.f90 @@ -231,10 +231,27 @@ logical function is_salty(xlat_d,xlon_positive) if (xlon_d.gt.-119.3.and. xlon_d.lt.-118.8) then if(xlat_d.gt.37.9 .and. xlat_d.lt.38.2) then is_salty = .true. - print *,'Mono Lake, i,j',xlat_d,xlon_d + if(lakedebug) then + print *,'Salty Mono Lake, i,j',xlat_d,xlon_d + endif endif ! xlat_d endif ! xlon_d - !tgs --- end of special treatment for salty lakes + + ! --- Caspian Sea and Dead Sea are salty too (Sam, Tanya) + if ( xlat_d>36.5_kind_phys .and. xlat_d<47.1_kind_phys .and. xlon_d>46.8_kind_phys .and. xlon_d<55.0_kind_phys ) then + if(lakedebug) then + print *,'Salty Caspian Sea ',xlat_d,xlon_d + endif + is_salty = .true. + end if + if ( xlon_d>35.3 .and. xlon_d<35.6 .and. xlat_d>31.3 .and. xlat_d<31.8) then + if(lakedebug) then + print *,'Salty Dead Sea ',xlat_d,xlon_d + endif + is_salty = .true. + endif + + !tgs --- end of special treatment for salty lakes end function is_salty !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -317,7 +334,7 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(IN) :: rain REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(INOUT) :: albedo INTEGER, DIMENSION( : ), INTENT(IN) :: ISLTYP - INTEGER, DIMENSION( : ), INTENT(INOUT) :: salty + INTEGER, DIMENSION( : ), INTENT(INOUT) :: salty REAL(KIND_PHYS), INTENT(IN) :: dtp REAL(KIND_PHYS), DIMENSION( :,: ),INTENT(INOUT) :: z_lake3d REAL(KIND_PHYS), DIMENSION( :,: ),INTENT(INOUT) :: dz_lake3d @@ -492,7 +509,7 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& use_lake_model, use_lakedepth, con_g, con_rd, & tkdry3d, tksatu3d, im, prsi, & xlat_d, xlon_d, clm_lake_initialized, & - sand3d, clay3d, tg3, salty, & + sand3d, clay3d, tg3, & km, me, master, errmsg, errflg) if(errflg/=0) then return @@ -518,8 +535,11 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& if_lake_is_here: if (flag_iter(i) .and. use_lake_model(i)/=0) THEN - - + if(is_salty(xlat_d(i),xlon_d(i))) then + salty(i) = 1 + else + salty(i) = 0 + endif SFCTMP = gt0(i,1) PBOT = prsi(i,2) @@ -5263,7 +5283,7 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, use_lake_model, use_lakedepth, con_g, con_rd, & tkdry3d, tksatu3d, im, prsi, & xlat_d, xlon_d, clm_lake_initialized, & - sand3d, clay3d, tg3, salty, & + sand3d, clay3d, tg3, & km, me, master, errmsg, errflg) !============================================================================== @@ -5282,7 +5302,6 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, REAL(KIND_PHYS), DIMENSION(IM), INTENT(IN):: FICE,TG3, xlat_d, xlon_d REAL(KIND_PHYS), DIMENSION(IM), INTENT(IN):: tsfc REAL(KIND_PHYS), DIMENSION(IM) ,INTENT(INOUT) :: clm_lake_initialized - INTEGER, DIMENSION(IM) ,INTENT(INOUT) :: salty integer, dimension(IM), intent(in) :: use_lake_model !INTEGER , INTENT (IN) :: lakeflag !INTEGER , INTENT (INOUT) :: lake_depth_flag @@ -5408,12 +5427,6 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, cycle endif - if(is_salty(xlat_d(i),xlon_d(i))) then - salty(i) = 1 - else - salty(i) = 0 - endif - snowdp2d(i) = snowd(i)*1e-3 ! SNOW in kg/m^2 and snowdp in m h2osno2d(i) = weasd(i) ! mm From 1d8998d80035d36e3250810c546e6a01fb696939 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Wed, 31 Aug 2022 16:19:42 +0000 Subject: [PATCH 035/380] Revert change to CMakeLists.txt --- CMakeLists.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 242275411..d14778b06 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -195,7 +195,7 @@ set_target_properties(ccpp_physics PROPERTIES VERSION ${PROJECT_VERSION} target_include_directories(ccpp_physics PUBLIC $) -target_link_libraries(ccpp_physics PUBLIC w3nco::w3nco_d NetCDF::NetCDF_Fortran) +target_link_libraries(ccpp_physics PUBLIC w3emc::w3emc_d NetCDF::NetCDF_Fortran) # Define where to install the library install(TARGETS ccpp_physics From 82bcd677c7c54efab29bbbb32099519ee687a6b3 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Tue, 6 Sep 2022 20:25:14 +0000 Subject: [PATCH 036/380] Omission from previous commit --- physics/physcons.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/physcons.F90 b/physics/physcons.F90 index 41d37491a..7b7a71c98 100644 --- a/physics/physcons.F90 +++ b/physics/physcons.F90 @@ -53,8 +53,8 @@ module physcons real(kind=kind_phys),parameter:: con_omega =7.2921e-5_kind_phys !< ang vel of earth (\f$s^{-1}\f$) real(kind=kind_phys),parameter:: con_p0 =1.01325e5_kind_phys !< standard atmospheric pressure (\f$Pa\f$) ! real(kind=kind_phys),parameter:: con_solr =1.36822e+3_kind_phys ! solar constant (W/m2)-aer(2001) - real(kind=kind_phys),parameter:: con_solr_old =1.3660e+3_kind_phys !< solar constant (\f$W/m^{2}\f$)-Liu(2002) - real(kind=kind_phys),parameter:: con_solr =1.3608e+3_kind_phys !< solar constant (\f$W/m^{2}\f$)-nasa-sorce Tim(2008) + real(kind=kind_phys),parameter:: con_solr_2002 =1.3660e+3_kind_phys !< solar constant (\f$W/m^{2}\f$)-Liu(2002) + real(kind=kind_phys),parameter:: con_solr_2008 =1.3608e+3_kind_phys !< solar constant (\f$W/m^{2}\f$)-nasa-sorce Tim(2008) ! real(kind=kind_phys),parameter:: con_solr =1.36742732e+3_kind_phys ! solar constant (W/m2)-gfdl(1989) - OPR as of Jan 2006 ! Selected geophysics/astronomy constants with kind=kind_dyn real(kind=kind_dyn), parameter:: con_g_dyn =9.80665e+0_kind_dyn !< gravity (\f$m/s^{2}\f$) From ad28dcac1e28fd53dc46e6436ae7f1a213da8739 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Wed, 7 Sep 2022 05:47:33 +0000 Subject: [PATCH 037/380] Reorganize logic in solver loop --- physics/GFS_rrtmgp_pre.F90 | 3 ++ physics/rrtmgp_lw_main.F90 | 49 +++++++++++++++--------- physics/rrtmgp_sw_main.F90 | 78 +++++++++++++++++++++++++------------- 3 files changed, 87 insertions(+), 43 deletions(-) diff --git a/physics/GFS_rrtmgp_pre.F90 b/physics/GFS_rrtmgp_pre.F90 index 45b40b938..7de803015 100644 --- a/physics/GFS_rrtmgp_pre.F90 +++ b/physics/GFS_rrtmgp_pre.F90 @@ -25,6 +25,9 @@ module GFS_rrtmgp_pre amo3 = 47.9982_kind_phys, & !< Modelular weight of ozone (g/mol) amdw = amd/amw, & !< Molecular weight of dry air / water vapor amdo3 = amd/amo3 !< Molecular weight of dry air / ozone + real(kind_phys), parameter :: eps = 1.0e-6_kind_phys + real(kind_phys), parameter :: oneminus = 1.0_kind_phys - eps + real(kind_phys), parameter :: ftiny = 1.0e-12_kind_phys ! Save trace gas indices. integer :: iStr_h2o, iStr_co2, iStr_o3, iStr_n2o, iStr_ch4, iStr_o2, iStr_ccl4, & diff --git a/physics/rrtmgp_lw_main.F90 b/physics/rrtmgp_lw_main.F90 index 4a0b47ba1..ab82dc56a 100644 --- a/physics/rrtmgp_lw_main.F90 +++ b/physics/rrtmgp_lw_main.F90 @@ -1,11 +1,11 @@ -! ###################################################################################### +! ########################################################################################### !> \file rrtmgp_lw_main.F90 !! !> \defgroup rrtmgp_lw_main rrtmgp_lw_main.F90 !! !! \brief This module contains the longwave RRTMGP radiation scheme. !! -! ###################################################################################### +! ########################################################################################### module rrtmgp_lw_main use machine, only: kind_phys use mo_optical_props, only: ty_optical_props_1scl, ty_optical_props_2str @@ -17,18 +17,19 @@ module rrtmgp_lw_main use mo_source_functions, only: ty_source_func_lw use radiation_tools, only: check_error_msg use rrtmgp_lw_gas_optics, only: lw_gas_props,rrtmgp_lw_gas_optics_init - use rrtmgp_lw_cloud_optics, only: lw_cloud_props, rrtmgp_lw_cloud_optics_init, & - abssnow0, abssnow1, absrain + use rrtmgp_lw_cloud_optics, only: lw_cloud_props, rrtmgp_lw_cloud_optics_init, abssnow0, & + abssnow1, absrain use module_radiation_gases, only: NF_VGAS, getgases, getozn - use GFS_rrtmgp_pre, only: iStr_h2o, iStr_co2, iStr_o3, iStr_n2o, iStr_ch4, & - iStr_o2, iStr_ccl4, iStr_cfc11, iStr_cfc12, iStr_cfc22 + use GFS_rrtmgp_pre, only: iStr_h2o, iStr_co2, iStr_o3, iStr_n2o, iStr_ch4, & + iStr_o2, iStr_ccl4, iStr_cfc11, iStr_cfc12, iStr_cfc22, & + eps, oneminus, ftiny use mersenne_twister, only: random_setseed, random_number, random_stat use rrtmgp_sampling, only: sampled_mask, draw_samples implicit none public rrtmgp_lw_main_init, rrtmgp_lw_main_run contains - ! ###################################################################################### + ! ######################################################################################### !! \section arg_table_rrtmgp_lw_main_init !! \htmlinclude rrtmgp_lw_main_int.html !! @@ -38,10 +39,10 @@ module rrtmgp_lw_main !! !! \section rrtmgp_lw_main_init !> @{ - ! ###################################################################################### - subroutine rrtmgp_lw_main_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, & - rrtmgp_lw_file_clouds, active_gases_array, doGP_cldoptics_PADE, & - doGP_cldoptics_LUT, nrghice, mpicomm, mpirank, mpiroot, nrghice, errmsg, errflg) + ! ######################################################################################### + subroutine rrtmgp_lw_main_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, rrtmgp_lw_file_clouds,& + active_gases_array, doGP_cldoptics_PADE, doGP_cldoptics_LUT, nrghice, mpicomm, & + mpirank, mpiroot, errmsg, errflg) ! Inputs character(len=128),intent(in) :: & @@ -189,14 +190,15 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, ! Local variables type(ty_gas_concs) :: gas_concs type(ty_optical_props_1scl) :: lw_optical_props_clrsky, lw_optical_props_aerosol_local - type(ty_optical_props_2str) :: lw_optical_props_clouds, lw_optical_props_cloudsByBand, & - lw_optical_props_cnvcloudsByBand, lw_optical_props_pblcloudsByBand, & + type(ty_optical_props_2str) :: lw_optical_props_clouds, lw_optical_props_cloudsByBand,& + lw_optical_props_cnvcloudsByBand, lw_optical_props_pblcloudsByBand, & lw_optical_props_precipByBand type(ty_source_func_lw) :: sources type(ty_fluxes_byband) :: flux_allsky, flux_clrsky integer :: iCol, iLay, iGas, iBand, iCol2, ix, iblck integer, dimension(rrtmgp_phys_blksz) :: ipseed_lw type(random_stat) :: rng_stat + real(kind_phys), dimension(rrtmgp_phys_blksz) :: zcf0, zcf1 logical, dimension(rrtmgp_phys_blksz,nLay,lw_gas_props%get_ngpt()) :: maskMCICA real(kind_phys), dimension(rrtmgp_phys_blksz) :: tau_rain, tau_snow real(kind_phys), dimension(lw_gas_props%get_ngpt()) :: rng1D @@ -206,6 +208,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, fluxLW_up_allsky, fluxLW_up_clrsky, fluxLW_dn_allsky, fluxLW_dn_clrsky real(kind_phys), dimension(rrtmgp_phys_blksz,lw_gas_props%get_ngpt()) :: lw_Ds real(kind_phys), dimension(lw_gas_props%get_nband(),rrtmgp_phys_blksz) :: sfc_emiss_byband + ! Initialize CCPP error handling variables errmsg = '' errflg = 0 @@ -251,6 +254,18 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, do iCol=1,nCol,rrtmgp_phys_blksz iCol2 = iCol + rrtmgp_phys_blksz - 1 + ! Create clear/cloudy indicator + zcf0(:) = 1._kind_phys + zcf1(:) = 1._kind_phys + do iblck = 1, rrtmgp_phys_blksz + do iLay=1,nLay + zcf0(iblck) = min(zcf0(iblck), 1._kind_phys - cld_frac(iCol+iblck-1,iLay)) + enddo + if (zcf0(iblck) <= ftiny) zcf0(iblck) = 0._kind_phys + if (zcf0(iblck) > oneminus) zcf0(iblck) = 1._kind_phys + zcf1(iblck) = 1._kind_phys - zcf0(iblck) + enddo + ! ################################################################################### ! ! Initialize/reset @@ -309,7 +324,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, ! ################################################################################### ! Assign same emissivity to all band do iblck=1,rrtmgp_phys_blksz - if (semis(iCol+iblck-1) > 1e-6 .and. semis(iCol+iblck-1) <= 1.0) then + if (semis(iCol+iblck-1) > eps .and. semis(iCol+iblck-1) <= 1._kind_phys) then do iBand=1,lw_gas_props%get_nband() sfc_emiss_byband(iBand,iblck) = semis(iCol+iblck-1) enddo @@ -338,7 +353,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, ! Compute cloud-optics... ! ! ################################################################################### - if (any(cld_frac(iCol:iCol2,:) .gt. 0.)) then + if (any(zcf1 .gt. eps)) then ! Microphysical (gridmean) cloud optics call check_error_msg('rrtmgp_lw_main_cloud_optics',lw_cloud_props%cloud_optics(& cld_lwp(iCol:iCol2,:), & ! IN - Cloud liquid water path (g/m2) @@ -387,7 +402,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, tau_snow(:) = 0._kind_phys do ix=1,rrtmgp_phys_blksz do iLay=1,nLay - if (cld_frac(iCol+ix-1,iLay) .gt. 0.) then + if (cld_frac(iCol+ix-1,iLay) .gt. eps) then ! Rain optical-depth (No band dependence) tau_rain(ix) = absrain*cld_rwp(iCol+ix-1,iLay) @@ -413,7 +428,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, ! *Note* All of the included cloud-types are sampled together, not independently. ! ! ################################################################################### - if (any(cld_frac(iCol:iCol2,:) .gt. 0.)) then + if (any(zcf1 .gt. eps)) then ! Change random number seed value for each radiation invocation (isubc_lw =1 or 2). if(isubc_lw == 1) then ! advance prescribed permutation seed do ix=1,rrtmgp_phys_blksz diff --git a/physics/rrtmgp_sw_main.F90 b/physics/rrtmgp_sw_main.F90 index 1c47f1cd0..325607daa 100644 --- a/physics/rrtmgp_sw_main.F90 +++ b/physics/rrtmgp_sw_main.F90 @@ -14,12 +14,14 @@ module rrtmgp_sw_main use rrtmgp_sw_cloud_optics, only: sw_cloud_props, rrtmgp_sw_cloud_optics_init, a0r, a0s, & a1s, b0r, b0s, b1s, c0r, c0s use GFS_rrtmgp_pre, only: iStr_h2o, iStr_co2, iStr_o3, iStr_n2o, iStr_ch4, & - iStr_o2, iStr_ccl4, iStr_cfc11, iStr_cfc12, iStr_cfc22 + iStr_o2, iStr_ccl4, iStr_cfc11, iStr_cfc12, iStr_cfc22, & + eps, oneminus, ftiny use mersenne_twister, only: random_setseed, random_number, random_stat use rrtmgp_sampling, only: sampled_mask, draw_samples implicit none public rrtmgp_sw_main_init, rrtmgp_sw_main_run + contains ! ######################################################################################### @@ -189,6 +191,7 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ type(ty_fluxes_byband) :: flux_allsky, flux_clrsky real(kind_phys) :: tau_rain, tau_snow, ssa_rain, ssa_snow, asy_rain, asy_snow, & tau_prec, asy_prec, ssa_prec, asyw, ssaw, za1, za2, flux_dir, flux_dif + real(kind_phys), dimension(rrtmgp_phys_blksz) :: zcf0, zcf1 real(kind_phys), dimension(sw_gas_props%get_ngpt()) :: rng1D real(kind_phys), dimension(sw_gas_props%get_ngpt(),nLay,rrtmgp_phys_blksz) :: rng3D,rng3D2 real(kind_phys), dimension(sw_gas_props%get_ngpt()*nLay) :: rng2D @@ -252,12 +255,32 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ flux_clrsky%bnd_flux_up => fluxSW_up_clrsky flux_clrsky%bnd_flux_dn => fluxSW_dn_clrsky + ! ###################################################################################### + ! ! Loop over all (daylit) columns... + ! + ! ###################################################################################### do iCol=1,nDay,rrtmgp_phys_blksz ix = idx(iCol) ix2 = idx(iCol + rrtmgp_phys_blksz - 1) + ! Create clear/cloudy indicator + zcf0(:) = 1._kind_phys + zcf1(:) = 1._kind_phys + do iblck = 1, rrtmgp_phys_blksz + do iLay=1,nLay + zcf0(iblck) = min(zcf0(iblck), 1._kind_phys - cld_frac(ix+iblck-1,iLay)) + enddo + if (zcf0(iblck) <= ftiny) zcf0(iblck) = 0._kind_phys + if (zcf0(iblck) > oneminus) zcf0(iblck) = 1._kind_phys + zcf1(iblck) = 1._kind_phys - zcf0(iblck) + enddo + + ! ################################################################################### + ! ! Initialize/reset + ! + ! ################################################################################### fluxSW_up_allsky = 0._kind_phys fluxSW_dn_allsky = 0._kind_phys fluxSW_dn_dir_allsky = 0._kind_phys @@ -306,6 +329,25 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ call check_error_msg('rrtmgp_sw_main_set_vmr_o3', & gas_concs%set_vmr(trim(active_gases_array(istr_o3)), vmr_o3(ix:ix2,:))) + ! ################################################################################### + ! + ! Compute gas-optics + ! + ! ################################################################################### + + call check_error_msg('rrtmgp_sw_main_gas_optics',sw_gas_props%gas_optics(& + p_lay(ix:ix2,:), & ! IN - Pressure @ layer-centers (Pa) + p_lev(ix:ix2,:), & ! IN - Pressure @ layer-interfaces (Pa) + t_lay(ix:ix2,:), & ! IN - Temperature @ layer-centers (K) + gas_concs, & ! IN - RRTMGP DDT: trace gas volumne mixing-ratios + sw_optical_props_accum, & ! OUT - RRTMGP DDT: Shortwave optical properties, by + ! spectral point (tau,ssa,g) + toa_src_sw)) ! OUT - TOA incident shortwave radiation (spectral) + ! Scale incident flux + do iblck = 1, rrtmgp_phys_blksz + toa_src_sw(iblck,:) = toa_src_sw(iblck,:)*solcon / sum(toa_src_sw(iblck,:)) + enddo + ! ################################################################################### ! ! Set surface albedo @@ -322,8 +364,10 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ sfc_alb_dif(iBand,iblck) = sfc_alb_nir_dif(ix+iblck-1) endif if (bandlimits(1,iBand) .eq. nIR_uvvis_bnd(1)) then - sfc_alb_dir(iBand,iblck) = 0.5_kind_phys*(sfc_alb_nir_dir(ix+iblck-1) + sfc_alb_uvvis_dir(ix+iblck-1)) - sfc_alb_dif(iBand,iblck) = 0.5_kind_phys*(sfc_alb_nir_dif(ix+iblck-1) + sfc_alb_uvvis_dif(ix+iblck-1)) + sfc_alb_dir(iBand,iblck) = 0.5_kind_phys*(sfc_alb_nir_dir(ix+iblck-1) + & + sfc_alb_uvvis_dir(ix+iblck-1)) + sfc_alb_dif(iBand,iblck) = 0.5_kind_phys*(sfc_alb_nir_dif(ix+iblck-1) + & + sfc_alb_uvvis_dif(ix+iblck-1)) ibd = iBand endif if (bandlimits(1,iBand) .ge. nIR_uvvis_bnd(2)) then @@ -333,31 +377,13 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ if (bandlimits(1,iBand) .eq. uvb_bnd(1)) ibd_uv = iBand enddo enddo - - ! ################################################################################### - ! - ! Compute gas-optics... - ! - ! ################################################################################### - call check_error_msg('rrtmgp_sw_main_gas_optics',sw_gas_props%gas_optics(& - p_lay(ix:ix2,:), & ! IN - Pressure @ layer-centers (Pa) - p_lev(ix:ix2,:), & ! IN - Pressure @ layer-interfaces (Pa) - t_lay(ix:ix2,:), & ! IN - Temperature @ layer-centers (K) - gas_concs, & ! IN - RRTMGP DDT: trace gas volumne mixing-ratios - sw_optical_props_accum, & ! OUT - RRTMGP DDT: Shortwave optical properties, by - ! spectral point (tau,ssa,g) - toa_src_sw)) ! OUT - TOA incident shortwave radiation (spectral) - ! Scale incident flux - do iblck = 1, rrtmgp_phys_blksz - toa_src_sw(iblck,:) = toa_src_sw(iblck,:)*solcon / sum(toa_src_sw(iblck,:)) - enddo ! ################################################################################### ! ! Compute optics for cloud(s) and precipitation, sample clouds... ! ! ################################################################################### - if (any(cld_frac(ix:ix2,:) .gt. 1.e-6_kind_phys)) then + if (any(zcf1 .gt. eps)) then ! Gridmean/mp-clouds call check_error_msg('rrtmgp_sw_main_cloud_optics',sw_cloud_props%cloud_optics(& cld_lwp(ix:ix2,:), & ! IN - Cloud liquid water path @@ -401,7 +427,7 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ ! Cloud precipitation optics: rain and snow(+groupel) do iblck = 1, rrtmgp_phys_blksz do iLay=1,nLay - if (cld_frac(ix+iblck-1,iLay) .gt. 1.e-12_kind_phys) then + if (cld_frac(ix+iblck-1,iLay) .gt. ftiny) then ! Rain/Snow optical depth (No band dependence) tau_rain = cld_rwp(ix+iblck-1,iLay)*a0r if (cld_swp(ix+iblck-1,iLay) .gt. 0. .and. cld_resnow(ix+iblck-1,iLay) .gt. 10._kind_phys) then @@ -499,7 +525,7 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ ! ################################################################################### ! - ! Compute clear-sky fluxes (gaseous+aerosol) (optional) + ! Compute clear-sky fluxes (gaseous+aerosol) ! ! ################################################################################### ! Increment @@ -558,7 +584,7 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ ! All-sky fluxes (clear-sky + clouds + precipitation) ! ! ################################################################################### - if (any(cld_frac(ix:ix2,:) .gt. 1.e-6_kind_phys)) then + if (any(zcf1 .gt. eps)) then ! Delta scale !call check_error_msg('rrtmgp_sw_main_delta_scale',sw_optical_props_clouds%delta_scale()) @@ -607,7 +633,7 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ scmpsw_allsky(iblck)%uvbfc = flux_allsky%bnd_flux_dn(iblck,iSFC,ibd_uv) enddo ! Store surface downward beam/diffused flux components - if (cld_frac(ix+iblck-1,iSFC) .gt. 1.e-6_kind_phys) then + if (zcf1(iblck) .gt. eps) then scmpsw(ix+iblck-1)%nirbm = scmpsw_allsky(iblck)%nirbm scmpsw(ix+iblck-1)%nirdf = scmpsw_allsky(iblck)%nirdf scmpsw(ix+iblck-1)%visbm = scmpsw_allsky(iblck)%visbm From 2f9e6041743ae32e8a3c446c1dfd5a5b6cc76d50 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Wed, 7 Sep 2022 14:15:50 -0600 Subject: [PATCH 038/380] Adress reviewers comments --- physics/GFS_cloud_diagnostics.F90 | 68 +++++------ physics/GFS_cloud_diagnostics.meta | 6 +- physics/GFS_rrtmg_pre.meta | 4 +- physics/GFS_rrtmg_setup.F90 | 65 +++++----- physics/GFS_rrtmg_setup.meta | 42 +++++++ physics/GFS_rrtmgp_cloud_overlap.meta | 4 +- physics/GFS_rrtmgp_pre.meta | 4 +- physics/radiation_gases.f | 165 +++++++++++++++++++++++--- physics/radlw_main.F90 | 63 +++++++--- physics/radlw_main.meta | 46 ++++++- physics/radsw_main.F90 | 70 +++++++---- physics/radsw_main.meta | 46 ++++++- physics/rrtmgp_aerosol_optics.meta | 4 +- physics/rrtmgp_lw_rte.meta | 4 +- physics/rrtmgp_sw_rte.meta | 4 +- 15 files changed, 457 insertions(+), 138 deletions(-) diff --git a/physics/GFS_cloud_diagnostics.F90 b/physics/GFS_cloud_diagnostics.F90 index 49cb992de..86dc2b518 100644 --- a/physics/GFS_cloud_diagnostics.F90 +++ b/physics/GFS_cloud_diagnostics.F90 @@ -38,47 +38,47 @@ subroutine GFS_cloud_diagnostics_run(nCol, nLev, iovr, iovr_rand, iovr_maxrand, implicit none ! Inputs - integer, intent(in) :: & - nCol, & ! Number of horizontal grid-points - nLev ! Number of vertical-layers - integer, intent(in) :: & - iovr, & ! - iovr_rand, & ! Flag for random cloud overlap method - iovr_maxrand, & ! Flag for maximum-random cloud overlap method - iovr_max, & ! Flag for maximum cloud overlap method - iovr_dcorr, & ! Flag for decorrelation-length cloud overlap method - iovr_exp, & ! Flag for exponential cloud overlap method - iovr_exprand ! Flag for exponential-random cloud overlap method - logical, intent(in) :: & - lsswr, & ! Call SW radiation? - lslwr, & ! Call LW radiation - top_at_1 - real(kind_phys), intent(in) :: & - con_pi ! Physical constant: pi + integer, intent(in) :: & + nCol, & ! Number of horizontal grid-points + nLev ! Number of vertical-layers + integer, intent(in) :: & + iovr, & ! Choice of cloud-overlap method + iovr_rand, & ! Flag for random cloud overlap method + iovr_maxrand, & ! Flag for maximum-random cloud overlap method + iovr_max, & ! Flag for maximum cloud overlap method + iovr_dcorr, & ! Flag for decorrelation-length cloud overlap method + iovr_exp, & ! Flag for exponential cloud overlap method + iovr_exprand ! Flag for exponential-random cloud overlap method + logical, intent(in) :: & + lsswr, & ! Call SW radiation? + lslwr, & ! Call LW radiation? + top_at_1 ! Vertical ordering flag + real(kind_phys), intent(in) :: & + con_pi ! Physical constant: pi real(kind_phys), dimension(:), intent(in) :: & - lat, & ! Latitude - de_lgth, & ! Decorrelation length - si + lat, & ! Latitude + de_lgth, & ! Decorrelation length + si ! Vertical sigma coordinate real(kind_phys), dimension(:,:), intent(in) :: & - p_lay, & ! Pressure at model-layer - cld_frac ! Total cloud fraction + p_lay, & ! Pressure at model-layer + cld_frac ! Total cloud fraction real(kind_phys), dimension(:,:), intent(in) :: & - p_lev ! Pressure at model interfaces + p_lev ! Pressure at model interfaces real(kind_phys), dimension(:,:), intent(in) :: & - deltaZ, & ! Layer thickness (m) - cloud_overlap_param, & ! Cloud-overlap parameter - precip_overlap_param ! Precipitation overlap parameter + deltaZ, & ! Layer thickness (m) + cloud_overlap_param, & ! Cloud-overlap parameter + precip_overlap_param ! Precipitation overlap parameter ! Outputs - character(len=*), intent(out) :: & - errmsg ! Error message - integer, intent(out) :: & - errflg ! Error flag - integer,dimension(:,:),intent(out) :: & - mbota, & ! Vertical indices for cloud tops - mtopa ! Vertical indices for cloud bases + character(len=*), intent(out) :: & + errmsg ! Error message + integer, intent(out) :: & + errflg ! Error flag + integer,dimension(:,:),intent(out) :: & + mbota, & ! Vertical indices for cloud tops + mtopa ! Vertical indices for cloud bases real(kind_phys),dimension(:,:), intent(out) :: & - cldsa ! Fraction of clouds for low, middle, high, total and BL + cldsa ! Fraction of clouds for low, middle, high, total and BL ! Local variables integer i,id,iCol,iLay,icld diff --git a/physics/GFS_cloud_diagnostics.meta b/physics/GFS_cloud_diagnostics.meta index 2408397d6..53d1552e6 100644 --- a/physics/GFS_cloud_diagnostics.meta +++ b/physics/GFS_cloud_diagnostics.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_cloud_diagnostics type = scheme - dependencies = machine.F + dependencies = machine.F,radiation_clouds.f ######################################################################## [ccpp-arg-table] @@ -157,8 +157,8 @@ kind = kind_phys intent = in [top_at_1] - standard_name = flag_for_vertical_ordering_in_RRTMGP - long_name = flag for vertical ordering in RRTMGP + standard_name = flag_for_vertical_ordering_in_radiation + long_name = flag for vertical ordering in radiation units = flag dimensions = () type = logical diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index cb158346a..228b73f20 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -1388,8 +1388,8 @@ kind = kind_phys intent = out [top_at_1] - standard_name = flag_for_vertical_ordering_in_RRTMGP - long_name = flag for vertical ordering in RRTMGP + standard_name = flag_for_vertical_ordering_in_radiation + long_name = flag for vertical ordering in radiation units = flag dimensions = () type = logical diff --git a/physics/GFS_rrtmg_setup.F90 b/physics/GFS_rrtmg_setup.F90 index 543776e80..5ad446985 100644 --- a/physics/GFS_rrtmg_setup.F90 +++ b/physics/GFS_rrtmg_setup.F90 @@ -39,12 +39,14 @@ module GFS_rrtmg_setup !! \htmlinclude GFS_rrtmg_setup_init.html !! subroutine GFS_rrtmg_setup_init ( si, levr, ictm, isol, solar_file, ico2, & - iaer, ntcw, num_p3d, npdf3d, ntoz, iovr, icliq_sw, lcrick, lcnorm, & - imp_physics, lnoprec, idate, iflip, do_RRTMGP, me, lalw1bd, iaermdl, & - iaerflg, aeros_file, con_pi, con_t0c, con_c, con_boltz, con_plnk, & - con_solr_2008, con_solr_2002, co2usr_file, co2cyc_file, rad_hr_units,& - inc_minor_gas, ilwcliq, iswcliq, isubcsw, isubclw, iswmode, ipsd0, & - errmsg, errflg) + iaer, ntcw, num_p3d, npdf3d, ntoz, iovr, iovr_rand, iovr_maxrand, & + iovr_max, iovr_dcorr, iovr_exp, iovr_exprand, icliq_sw, lcrick, & + lcnorm, imp_physics, lnoprec, idate, iflip, do_RRTMGP, me, lalw1bd, & + iaermdl, iaerflg, aeros_file, con_pi, con_t0c, con_c, con_boltz, & + con_plnk, con_solr_2008, con_solr_2002, co2usr_file, co2cyc_file, & + rad_hr_units, inc_minor_gas, ilwcliq, iswcliq, isubcsw, isubclw, & + iswmode, ipsd0, errmsg, errflg) + ! ================= subprogram documentation block ================ ! ! ! ! subprogram: GFS_rrtmg_setup_init - a subprogram to initialize radiation ! @@ -151,8 +153,10 @@ subroutine GFS_rrtmg_setup_init ( si, levr, ictm, isol, solar_file, ico2, & ! interface variables real (kind=kind_phys), intent(in) :: si(:) integer, intent(in) :: levr, ictm, isol, ico2, iaer, ntcw, num_p3d, & - npdf3d, ntoz, iovr, icliq_sw, imp_physics, iflip, me, & - rad_hr_units, ilwcliq, iswcliq, isubcsw, isubclw, iswmode + npdf3d, ntoz, iovr, iovr_rand, iovr_maxrand, iovr_max, & + iovr_dcorr, iovr_exp, iovr_exprand, icliq_sw, imp_physics, & + iflip, me, rad_hr_units, ilwcliq, iswcliq, isubcsw, isubclw, & + iswmode integer, intent(in) :: idate(:) logical, intent(in) :: lcrick, lcnorm, lnoprec, do_RRTMGP, lalw1bd, & inc_minor_gas @@ -197,32 +201,37 @@ subroutine GFS_rrtmg_setup_init ( si, levr, ictm, isol, solar_file, ico2, & endif if ( me == 0 ) then - print *,' In rad_initialize (GFS_rrtmg_setup_init), before calling radinit' - print *,' si =',si - print *,' levr=',levr,' ictm=',ictm,' isol=',isol,' ico2=',ico2,& - & ' iaermdl=',iaermdl,' iaerflg=',iaerflg - print *,' np3d=',num_p3d,' ntoz=',ntoz, & - & ' iovr=',iovr,' isubcsw=',isubcsw, & - & ' isubclw=',isubclw,' icliq_sw=',icliq_sw, & - & ' iflip=',iflip,' me=',me - print *,' lcrick=',lcrick, & - & ' lcnorm=',lcnorm,' lnoprec=',lnoprec + print *,' In rad_initialize (GFS_rrtmg_setup_init), before calling RRTMG initialization' + print *,' si =',si + print *,' levr=',levr,' ictm=',ictm,' isol=',isol,' ico2=',ico2,& + ' iaermdl=',iaermdl,' iaerflg=',iaerflg + print *,' np3d=',num_p3d,' ntoz=',ntoz, & + ' iovr=',iovr,' isubcsw=',isubcsw, & + ' isubclw=',isubclw,' icliq_sw=',icliq_sw, & + ' iflip=',iflip,' me=',me + print *,' lcrick=',lcrick, & + ' lcnorm=',lcnorm,' lnoprec=',lnoprec endif - call sol_init ( me, isol, solar_file, con_solr_2008, con_solr_2002,& - con_pi ) ! astronomy initialization routine - call aer_init ( levr, me, iaermdl, iaerflg, lalw1bd, aeros_file, con_pi, & - con_t0c, con_c, con_boltz, con_plnk, errflg, errmsg) ! aerosols initialization routine - call gas_init ( me, co2usr_file, co2cyc_file, ico2, ictm, ntoz, con_pi, & - errflg, errmsg) ! co2 and other gases initialization routine - call cld_init ( si, levr, imp_physics, me, errflg, errmsg) ! cloud initialization routine - call rlwinit ( me, rad_hr_units, inc_minor_gas, ilwcliq, isubcsw, iovr, errflg, errmsg ) ! lw RRTMG initialization routine - call rswinit ( me, rad_hr_units, inc_minor_gas, iswcliq, isubclw, iovr, iswmode, errflg, errmsg ) ! sw RRTMG initialization routine + ! Call initialization routines + call sol_init ( me, isol, solar_file, con_solr_2008,con_solr_2002,& + con_pi ) + call aer_init ( levr, me, iaermdl, iaerflg, lalw1bd, aeros_file, & + con_pi, con_t0c, con_c, con_boltz, con_plnk, errflg, errmsg) + call gas_init ( me, co2usr_file, co2cyc_file, ico2, ictm, ntoz, & + con_pi, errflg, errmsg) + call cld_init ( si, levr, imp_physics, me, errflg, errmsg) + call rlwinit ( me, rad_hr_units, inc_minor_gas, ilwcliq, isubcsw, & + iovr, iovr_rand, iovr_maxrand, iovr_max, iovr_dcorr, & + iovr_exp, iovr_exprand, errflg, errmsg ) + call rswinit ( me, rad_hr_units, inc_minor_gas, iswcliq, isubclw, & + iovr, iovr_rand, iovr_maxrand, iovr_max, iovr_dcorr, & + iovr_exp, iovr_exprand,iswmode, errflg, errmsg ) if ( me == 0 ) then print *,' Radiation sub-cloud initial seed =',ipsd0, & & ' IC-idate =',idate - print *,' return from rad_initialize (GFS_rrtmg_setup_init) - after calling radinit' + print *,' return from rad_initialize (GFS_rrtmg_setup_init) - after calling RRTMG initialization' endif ! is_initialized = .true. diff --git a/physics/GFS_rrtmg_setup.meta b/physics/GFS_rrtmg_setup.meta index b6d3520bf..40da39a1c 100644 --- a/physics/GFS_rrtmg_setup.meta +++ b/physics/GFS_rrtmg_setup.meta @@ -110,6 +110,48 @@ dimensions = () type = integer intent = in +[iovr_exp] + standard_name = flag_for_exponential_cloud_overlap_method + long_name = choice of exponential cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_exprand] + standard_name = flag_for_exponential_random_cloud_overlap_method + long_name = choice of exponential-random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_max] + standard_name = flag_for_maximum_cloud_overlap_method + long_name = choice of maximum cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_rand] + standard_name = flag_for_random_cloud_overlap_method + long_name = choice of random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_maxrand] + standard_name = flag_for_maximum_random_cloud_overlap_method + long_name = choice of maximum-random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_dcorr] + standard_name = flag_for_decorrelation_length_cloud_overlap_method + long_name = choice of decorrelation-length cloud overlap method + units = flag + dimensions = () + type = integer + intent = in [isubcsw] standard_name = flag_for_sw_clouds_grid_approximation long_name = flag for sw clouds sub-grid approximation diff --git a/physics/GFS_rrtmgp_cloud_overlap.meta b/physics/GFS_rrtmgp_cloud_overlap.meta index f7d12bed5..cf6a05217 100644 --- a/physics/GFS_rrtmgp_cloud_overlap.meta +++ b/physics/GFS_rrtmgp_cloud_overlap.meta @@ -210,8 +210,8 @@ kind = kind_phys intent = in [top_at_1] - standard_name = flag_for_vertical_ordering_in_RRTMGP - long_name = flag for vertical ordering in RRTMGP + standard_name = flag_for_vertical_ordering_in_radiation + long_name = flag for vertical ordering in radiation units = flag dimensions = () type = logical diff --git a/physics/GFS_rrtmgp_pre.meta b/physics/GFS_rrtmgp_pre.meta index 86645cb1a..ff6e262cc 100644 --- a/physics/GFS_rrtmgp_pre.meta +++ b/physics/GFS_rrtmgp_pre.meta @@ -364,8 +364,8 @@ kind = kind_phys intent = inout [top_at_1] - standard_name = flag_for_vertical_ordering_in_RRTMGP - long_name = flag for vertical ordering in RRTMGP + standard_name = flag_for_vertical_ordering_in_radiation + long_name = flag for vertical ordering in radiation units = flag dimensions = () type = logical diff --git a/physics/radiation_gases.f b/physics/radiation_gases.f index 85204e5ab..797028d97 100644 --- a/physics/radiation_gases.f +++ b/physics/radiation_gases.f @@ -221,7 +221,15 @@ module module_radiation_gases !> This subroutine sets up ozone, co2, etc. parameters. If climatology !! ozone then read in monthly ozone data. -!!\param me print message control flag +!!\param me print message control flag +!!\param co2usr_file co2 user defined data table +!!\param co2cyc_file co2 climotology monthly cycle data table +!!\param ictmflg data ic time/date control flag +!!\param ico2flg co2 data source control flag +!!\param ioznflg ozone data control flag +!!\param con_pi physical constant Pi +!!\param errflg error flag +!!\param errmsg error message !>\section gas_init_gen gas_init General Algorithm !----------------------------------- subroutine gas_init( me, co2usr_file, co2cyc_file, ico2flg, & @@ -233,12 +241,34 @@ subroutine gas_init( me, co2usr_file, co2cyc_file, ico2flg, & ! then read in monthly ozone data. ! ! ! ! inputs: ! -! me - print message control flag ! -! co2usr_file - external co2 user defined data table ! -! co2cyc_file - external co2 climotology monthly cycle data table ! +! me - print message control flag ! +! ico2flg - co2 data source control flag ! +! =0: use prescribed co2 global mean value ! +! =1: use input global mean co2 value (co2_glb) ! +! =2: use input 2-d monthly co2 value (co2vmr_sav) ! +! ictmflg - =yyyy#, data ic time/date control flag ! +! =-2: same as 0, but superimpose seasonal cycle ! +! from climatology data set. ! +! =-1: use user provided external data for the fcst ! +! time, no extrapolation. ! +! =0: use data at initial cond time, if not existed ! +! then use latest, without extrapolation. ! +! =1: use data at the forecast time, if not existed ! +! then use latest and extrapolate to fcst time. ! +! =yyyy0: use yyyy data for the forecast time, no ! +! further data extrapolation. ! +! =yyyy1: use yyyy data for the fcst. if needed, do ! +! extrapolation to match the fcst time. ! +! ioznflg - ozone data control flag ! +! =0: use climatological ozone profile ! +! >0: use interactive ozone profile ! +! co2usr_file - external co2 user defined data table ! +! co2cyc_file - external co2 climotology monthly cycle data table ! +! con_pi - physical constant Pi ! ! ! ! outputs: (CCPP error handling) ! -! (errflg, errmsg) ! +! errflg - error flag ! +! errmsg - error message ! ! ! ! internal module variables: ! ! pkstr, o3r - arrays for climatology ozone data ! @@ -508,13 +538,20 @@ end subroutine gas_init !> This subroutine reads in 2-d monthly co2 data set for a specified !! year. Data are in a 15 degree lat/lon horizontal resolution. -!!\param iyear year of the requested data for fcst -!!\param imon month of the year -!!\param iday day of the month -!!\param ihour hour of the day -!!\param loz1st clim ozone 1st time update control flag -!!\param ldoco2 co2 update control flag -!!\param me print message control flag +!!\param iyear year of the requested data for fcst +!!\param imon month of the year +!!\param iday day of the month +!!\param ihour hour of the day +!!\param loz1st clim ozone 1st time update control flag +!!\param ldoco2 co2 update control flag +!!\param me print message control flag +!!\param co2dat_file co2 2d monthly obsv data table +!!\param co2gbl_file co2 global annual mean data table +!!\param ictmflg data ic time/date control flag +!!\param ico2flg co2 data source control flag +!!\param ioznflg ozone data control flag +!!\param errflg error flag +!!\param errmsg error message !>\section gen_gas_update gas_update General Algorithm !----------------------------------- subroutine gas_update(iyear, imon, iday, ihour, loz1st, ldoco2, & @@ -526,6 +563,50 @@ subroutine gas_update(iyear, imon, iday, ihour, loz1st, ldoco2, & ! gas_update reads in 2-d monthly co2 data set for a specified year. ! ! data are in a 15 degree lat/lon horizontal resolution. ! ! ! +! inputs: dimemsion ! +! iyear - year of the requested data for fcst 1 ! +! imon - month of the year 1 ! +! iday - day of the month 1 ! +! ihour - hour of the day 1 ! +! loz1st - clim ozone 1st time update control flag 1 ! +! ldoco2 - co2 update control flag 1 ! +! me - print message control flag 1 ! +! ico2flg - co2 data source control flag ! +! =0: use prescribed co2 global mean value ! +! =1: use input global mean co2 value (co2_glb) ! +! =2: use input 2-d monthly co2 value (co2vmr_sav) ! +! ictmflg - =yyyy#, data ic time/date control flag ! +! =-2: same as 0, but superimpose seasonal cycle ! +! from climatology data set. ! +! =-1: use user provided external data for the fcst ! +! time, no extrapolation. ! +! =0: use data at initial cond time, if not existed ! +! then use latest, without extrapolation. ! +! =1: use data at the forecast time, if not existed ! +! then use latest and extrapolate to fcst time. ! +! =yyyy0: use yyyy data for the forecast time, no ! +! further data extrapolation. ! +! =yyyy1: use yyyy data for the fcst. if needed, do ! +! extrapolation to match the fcst time. ! +! ioznflg - ozone data control flag ! +! =0: use climatological ozone profile ! +! >0: use interactive ozone profile ! +! ivflip - vertical profile indexing flag ! +! co2dat_file - external co2 2d monthly obsv data table ! +! co2gbl_file - external co2 global annual mean data table ! +! ! +! outputs: (CCPP error handling) ! +! errflg - error flag ! +! errmsg - error message ! +! ! +! internal module variables: ! +! co2vmr_sav - monthly co2 volume mixing ratio IMXCO2*JMXCO2*12 ! +! co2cyc_sav - monthly cycle co2 vol mixing ratio IMXCO2*JMXCO2*12 ! +! co2_glb - global annual mean co2 mixing ratio ! +! gco2cyc - global monthly mean co2 variation 12 ! +! k1oz,k2oz,facoz ! +! - climatology ozone parameters 1 ! +! ! ! usage: call gas_update ! ! ! ! subprograms called: none ! @@ -691,7 +772,6 @@ subroutine gas_update(iyear, imon, iday, ihour, loz1st, ldoco2, & ! --- ... set up input data file name - print*,"co2dat_file: ",co2dat_file cfile1 = co2dat_file write(cfile1(19:22),34) idyr 34 format(i4.4) @@ -867,6 +947,9 @@ end subroutine gas_update !!\param xlat (IMAX), grid latitude in radians, default range to !! pi/2 -> -pi/2, otherwise see in-line comment !!\param IMAX, LMAX horizontal/vertical dimensions for output data +!!\param ico2flg (1), co2 data source control flag +!!\param top_at_1 (1), vertical ordering flag +!!\param con_pi (1), physical constant Pi !!\param gasdat (IMAX,LMAX,NF_VGAS) - gases volume mixing ratioes !!\n (:,:,1) - co2 !!\n (:,:,2) - n2o @@ -878,6 +961,12 @@ end subroutine gas_update !!\n (:,:,8) - cfc22 !!\n (:,:,9) - ccl4 !!\n (:,:,10) - cfc113 +!!\n +!> - Internal module variables : +!!\n co2vmr_sav - saved monthly co2 concentration from sub gas_update +!!\n co2_glb - saved global annual mean co2 value from gas_update +!!\n gco2cyc - saved global seasonal variation of co2 climatology +!! in 12-month form !>\section gen_getgases getgases General Algorithm !----------------------------------- subroutine getgases( plvl, xlon, xlat, IMAX, LMAX, ico2flg, & @@ -889,6 +978,39 @@ subroutine getgases( plvl, xlon, xlat, IMAX, LMAX, ico2flg, & ! observed values, all other gases are asigned to the climatological ! ! values. ! ! ! +! inputs: ! +! plvl(IMAX,LMAX+1)- pressure at model layer interfaces (mb) ! +! xlon(IMAX) - grid longitude in radians, ok both 0->2pi or ! +! -pi -> +pi arrangements ! +! xlat(IMAX) - grid latitude in radians, default range to ! +! pi/2 -> -pi/2, otherwise see in-line comment ! +! IMAX, LMAX - horiz, vert dimensions for output data ! +! ico2flg - co2 data source control flag ! +! =0: use prescribed co2 global mean value ! +! =1: use input global mean co2 value (co2_glb) ! +! =2: use input 2-d monthly co2 value (co2vmr_sav)! +! top_at_1 - vertical profile indexing flag ! +! con_pi - physical constant Pi ! +! ! +! outputs: ! +! gasdat(IMAX,LMAX,NF_VGAS) - gases volume mixing ratioes ! +! (:,:,1) - co2 ! +! (:,:,2) - n2o ! +! (:,:,3) - ch4 ! +! (:,:,4) - o2 ! +! (:,:,5) - co ! +! (:,:,6) - cfc11 ! +! (:,:,7) - cfc12 ! +! (:,:,8) - cfc22 ! +! (:,:,9) - ccl4 ! +! (:,:,10) - cfc113 ! +! ! +! note: for lower atmos co2vmr_sav may have clim monthly deviations ! +! superimposed on init-cond co2 value, while co2_glb only ! +! contains the global mean value, thus needs to add the ! +! monthly dglobal mean deviation gco2cyc at upper atmos. for ! +! ictmflg/=-2, this value will be zero. ! +! ! ! usage: call getgases ! ! ! ! subprograms called: none ! @@ -986,7 +1108,8 @@ end subroutine getgases !!\param prslk (IMAX,LM), exner function = \f$(p/p0)^{rocp}\f$ !!\param xlat (IMAX), latitude in radians, default to pi/2 -> !! -pi/2 range, otherwise see in-line comment -!!\param IMAX, LM horizontal and vertical dimensions +!!\param IMAX, LM (1), horizontal and vertical dimensions +!!\param top_at_1 (1), vertical profile indexing flag !!\param o3mmr (IMAX,LM), output ozone profile in mass mixing !! ratio (g/g) !>\section getozn_gen getozn General Algorithm @@ -999,6 +1122,20 @@ subroutine getozn( prslk,xlat, IMAX, LM, top_at_1, o3mmr) ! ! ! this code is originally written By Shrinivas Moorthi ! ! ! +! inputs: ! +! prslk (IMAX,LM) - exner function = (p/p0)**rocp ! +! xlat (IMAX) - latitude in radians, default to pi/2 -> -pi/2 ! +! range, otherwise see in-line comment ! +! IMAX, LM - horizontal and vertical dimensions ! +! top_at_1 - vertical profile indexing flag ! +! ! +! outputs: ! +! o3mmr (IMAX,LM) - output ozone profile in mass mixing ratio (g/g)! +! ! +! module variables: ! +! k1oz, k2oz - ozone data interpolation indices ! +! facoz - ozone data interpolation factor ! +! ! ! usage: call getozn ! ! ! ! =================================================================== ! diff --git a/physics/radlw_main.F90 b/physics/radlw_main.F90 index 341ca47ed..34db600e5 100644 --- a/physics/radlw_main.F90 +++ b/physics/radlw_main.F90 @@ -423,6 +423,8 @@ subroutine rrtmg_lw_run & & icseed,aeraod,aerssa,sfemis,sfgtmp, & & dzlyr,delpin,de_lgth,alpha, & & npts, nlay, nlp1, lprnt, cld_cf, lslwr, top_at_1, iovr, & + & iovr_rand, iovr_maxrand, iovr_max, iovr_dcorr, iovr_exp, & + & iovr_exprand, & & inc_minor_gas, ilwcliq, ilwcice, isubclw, & & hlwc,topflx,sfcflx,cldtau, & ! --- outputs & HLW0,HLWB,FLXPRF, & ! --- optional @@ -495,13 +497,19 @@ subroutine rrtmg_lw_run & ! =0: no sub-col cld treatment, use grid-mean cld quantities ! ! =1: mcica sub-col, prescribed seeds to get random numbers ! ! =2: mcica sub-col, providing array icseed for random numbers! -! iovr - cloud overlapping control flag ! -! =0: random overlapping clouds ! -! =1: maximum/random overlapping clouds ! -! =2: maximum overlap cloud (used for isubclw>0 only) ! -! =3: decorrelation-length overlap (for isubclw>0 only) ! -! =4: exponential cloud overlap (AER) ! -! =5: exponential-random cloud overlap (AER) ! +! iovr - clouds vertical overlapping control flag ! +! =iovr_rand ! +! =iovr_maxrand ! +! =iovr_max ! +! =iovr_dcorr ! +! =iovr_exp ! +! =iovr_exprand ! +! iovr_rand - choice of cloud-overlap: random ! +! iovr_maxrand - choice of cloud-overlap: maximum random ! +! iovr_max - choice of cloud-overlap: maximum ! +! iovr_dcorr - choice of cloud-overlap: decorrelation length ! +! iovr_exp - choice of cloud-overlap: exponential ! +! iovr_exprand - choice of cloud-overlap: exponential random ! ! ! ! output variables: ! ! hlwc (npts,nlay): total sky heating rate (k/day or k/sec) ! @@ -599,7 +607,8 @@ subroutine rrtmg_lw_run & ! --- inputs: integer, intent(in) :: npts, nlay, nlp1, ilwcliq, ilwcice, & - isubclw, iovr + isubclw, iovr, iovr_dcorr, iovr_exp, iovr_exprand, iovr_rand,& + iovr_maxrand, iovr_max integer, intent(in) :: icseed(npts) logical, intent(in) :: lprnt, inc_minor_gas @@ -784,7 +793,7 @@ subroutine rrtmg_lw_run & endif stemp = sfgtmp(iplon) ! surface ground temp - if (iovr == 3) delgth= de_lgth(iplon) ! clouds decorr-length + if (iovr == iovr_dcorr) delgth= de_lgth(iplon) ! clouds decorr-length !> -# Prepare atmospheric profile for use in rrtm. ! the vertical index of internal array is from surface to top @@ -808,7 +817,7 @@ subroutine rrtmg_lw_run & tavel(k)= tlyr(iplon,k1) tz(k) = tlvl(iplon,k1) dz(k) = dzlyr(iplon,k1) - if (iovr == 4 .or. iovr == 5) alph(k) = alpha(iplon,k) ! alpha decorrelation + if (iovr == iovr_exp .or. iovr == iovr_exprand) alph(k) = alpha(iplon,k) ! alpha decorrelation !> -# Set absorber amount for h2o, co2, and o3. @@ -921,7 +930,7 @@ subroutine rrtmg_lw_run & tavel(k)= tlyr(iplon,k) tz(k) = tlvl(iplon,k+1) dz(k) = dzlyr(iplon,k) - if (iovr == 4 .or. iovr == 5) alph(k) = alpha(iplon,k) ! alpha decorrelation + if (iovr == iovr_exp .or. iovr == iovr_exprand) alph(k) = alpha(iplon,k) ! alpha decorrelation ! --- ... set absorber amount !test use @@ -1311,7 +1320,8 @@ end subroutine rrtmg_lw_run !!\param me print control for parallel process !!\section rlwinit_gen rlwinit General Algorithm subroutine rlwinit( me, rad_hr_units, inc_minor_gas, ilwcliq, & - isubclw, iovr, errflg, errmsg ) + isubclw, iovr, iovr_rand, iovr_maxrand, iovr_max, iovr_dcorr,& + iovr_exp, iovr_exprand, errflg, errmsg ) ! =================== program usage description =================== ! ! ! @@ -1334,12 +1344,18 @@ subroutine rlwinit( me, rad_hr_units, inc_minor_gas, ilwcliq, & ! =1: mcica sub-col, prescribed seeds to get random numbers ! ! =2: mcica sub-col, providing array icseed for random numbers! ! iovr - clouds vertical overlapping control flag ! -! =0: random overlapping clouds ! -! =1: maximum/random overlapping clouds ! -! =2: maximum overlap cloud (isubcol>0 only) ! -! =3: decorrelation-length overlap (for isubclw>0 only) ! -! =4: exponential cloud overlap (AER) ! -! =5: exponential-random cloud overlap (AER) ! +! =iovr_rand ! +! =iovr_maxrand ! +! =iovr_max ! +! =iovr_dcorr ! +! =iovr_exp ! +! =iovr_exprand ! +! iovr_rand - choice of cloud-overlap: random ! +! iovr_maxrand - choice of cloud-overlap: maximum random ! +! iovr_max - choice of cloud-overlap: maximum ! +! iovr_dcorr - choice of cloud-overlap: decorrelation length ! +! iovr_exp - choice of cloud-overlap: exponential ! +! iovr_exprand - choice of cloud-overlap: exponential random ! ! ! ! outputs: ! ! errflg - error flag ! @@ -1373,7 +1389,9 @@ subroutine rlwinit( me, rad_hr_units, inc_minor_gas, ilwcliq, & ! ====================== end of description block ================= ! ! --- inputs: - integer, intent(in) :: me, rad_hr_units, ilwcliq, isubclw, iovr + integer, intent(in) :: me, rad_hr_units, ilwcliq, isubclw, iovr, & + iovr_rand, iovr_maxrand, iovr_max, iovr_dcorr, iovr_exp, & + iovr_exprand logical, intent(in) :: inc_minor_gas ! --- outputs: @@ -1394,6 +1412,13 @@ subroutine rlwinit( me, rad_hr_units, inc_minor_gas, ilwcliq, & errflg = 0 errmsg = '' + if ((iovr .ne. iovr_rand) .and. (iovr .ne. iovr_maxrand) .and. & + (iovr .ne. iovr_max) .and. (iovr .ne. iovr_dcorr) .and. & + (iovr .ne. iovr_exp) .and. (iovr .ne. iovr_exprand)) then + errflg = 1 + errmsg = 'ERROR(rlwinit): Error in specification of cloud overlap flag' + endif + if (me == 0) then print *,' - Using AER Longwave Radiation, Version: ', VTAGLW diff --git a/physics/radlw_main.meta b/physics/radlw_main.meta index e336e6011..406f773e3 100644 --- a/physics/radlw_main.meta +++ b/physics/radlw_main.meta @@ -242,8 +242,8 @@ type = logical intent = in [top_at_1] - standard_name = flag_for_vertical_ordering_in_RRTMGP - long_name = flag for vertical ordering in RRTMGP + standard_name = flag_for_vertical_ordering_in_radiation + long_name = flag for vertical ordering in radiation units = flag dimensions = () type = logical @@ -255,6 +255,48 @@ dimensions = () type = integer intent = in +[iovr_exp] + standard_name = flag_for_exponential_cloud_overlap_method + long_name = choice of exponential cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_exprand] + standard_name = flag_for_exponential_random_cloud_overlap_method + long_name = choice of exponential-random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_max] + standard_name = flag_for_maximum_cloud_overlap_method + long_name = choice of maximum cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_rand] + standard_name = flag_for_random_cloud_overlap_method + long_name = choice of random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_maxrand] + standard_name = flag_for_maximum_random_cloud_overlap_method + long_name = choice of maximum-random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_dcorr] + standard_name = flag_for_decorrelation_length_cloud_overlap_method + long_name = choice of decorrelation-length cloud overlap method + units = flag + dimensions = () + type = integer + intent = in [inc_minor_gas] standard_name = flag_to_include_minor_gases_in_rrtmg long_name = flag to include minor trace gases in rrtmg diff --git a/physics/radsw_main.F90 b/physics/radsw_main.F90 index cf6c37346..602fa3ae3 100644 --- a/physics/radsw_main.F90 +++ b/physics/radsw_main.F90 @@ -500,8 +500,8 @@ subroutine rrtmg_sw_run & & dzlyr,delpin,de_lgth,alpha, & & cosz,solcon,NDAY,idxday, & & npts, nlay, nlp1, lprnt, inc_minor_gas, iswcliq, iswcice, & - & isubcsw, iovr, top_at_1, iswmode, & - & cld_cf, lsswr, & + & isubcsw, iovr, top_at_1, iswmode, cld_cf, lsswr, iovr_rand,& + & iovr_maxrand, iovr_max, iovr_dcorr, iovr_exp, iovr_exprand,& & hswc,topflx,sfcflx,cldtau, & ! --- outputs & HSW0,HSWB,FLXPRF,FDNCMP, & ! --- optional & cld_lwp, cld_ref_liq, cld_iwp, cld_ref_ice, & @@ -584,13 +584,19 @@ subroutine rrtmg_sw_run & ! =0: no sub-col cld treatment, use grid-mean cld quantities ! ! =1: mcica sub-col, prescribed seeds to get random numbers ! ! =2: mcica sub-col, providing array icseed for random numbers! -! iovr - cloud overlapping control flag ! -! =0: random overlapping clouds ! -! =1: maximum/random overlapping clouds ! -! =2: maximum overlap cloud ! -! =3: decorrelation-length overlap clouds ! -! =4: exponential cloud overlap (AER) ! -! =5: exponential-random cloud overlap (AER) ! +! iovr - clouds vertical overlapping control flag ! +! =iovr_rand ! +! =iovr_maxrand ! +! =iovr_max ! +! =iovr_dcorr ! +! =iovr_exp ! +! =iovr_exprand ! +! iovr_rand - choice of cloud-overlap: random ! +! iovr_maxrand - choice of cloud-overlap: maximum random ! +! iovr_max - choice of cloud-overlap: maximum ! +! iovr_dcorr - choice of cloud-overlap: decorrelation length ! +! iovr_exp - choice of cloud-overlap: exponential ! +! iovr_exprand - choice of cloud-overlap: exponential random ! ! ! ! output variables: ! ! hswc (npts,nlay): total sky heating rates (k/sec or k/day) ! @@ -680,7 +686,8 @@ subroutine rrtmg_sw_run & ! --- inputs: integer, intent(in) :: npts, nlay, nlp1, NDAY, iswcliq, iswcice, & - isubcsw, iovr, iswmode + isubcsw, iovr, iswmode, iovr_dcorr, iovr_exp, iovr_exprand, & + iovr_rand, iovr_maxrand, iovr_max integer, dimension(:), intent(in) :: idxday, icseed @@ -889,7 +896,7 @@ subroutine rrtmg_sw_run & cosz1 = cosz(j1) sntz1 = f_one / cosz(j1) ssolar = s0fac * cosz(j1) - if (iovr == 3) delgth = de_lgth(j1) ! clouds decorr-length + if (iovr == iovr_dcorr) delgth = de_lgth(j1) ! clouds decorr-length !> - Prepare surface albedo: bm,df - dir,dif; 1,2 - nir,uvv. albbm(1) = sfcalb_nir_dir(j1) @@ -911,7 +918,7 @@ subroutine rrtmg_sw_run & tavel(k) = tlyr(j1,kk) delp (k) = delpin(j1,kk) dz (k) = dzlyr (j1,kk) - if (iovr == 4 .or. iovr == 5) alph(k) = alpha(j1,k) ! alpha decorrelation + if (iovr == iovr_exp .or. iovr == iovr_exprand) alph(k) = alpha(j1,k) ! alpha decorrelation !> - Set absorber and gas column amount, convert from volume mixing !! ratio to molec/cm2 based on coldry (scaled to 1.0e-20) @@ -1002,7 +1009,7 @@ subroutine rrtmg_sw_run & tavel(k) = tlyr(j1,k) delp (k) = delpin(j1,k) dz (k) = dzlyr (j1,k) - if (iovr == 4 .or. iovr == 5) alph(k) = alpha(j1,k) ! alpha decorrelation + if (iovr == iovr_exp .or. iovr == iovr_exprand) alph(k) = alpha(j1,k) ! alpha decorrelation ! --- ... set absorber amount !test use @@ -1093,11 +1100,11 @@ subroutine rrtmg_sw_run & zcf0 = f_one zcf1 = f_one - if (iovr == 0) then ! random overlapping + if (iovr == iovr_rand) then ! random overlapping do k = 1, nlay zcf0 = zcf0 * (f_one - cfrac(k)) enddo - else if (iovr == 1) then ! max/ran/exp overlapping + else if (iovr == iovr_maxrand) then ! max/ran/exp overlapping do k = 1, nlay if (cfrac(k) > ftiny) then ! cloudy layer zcf1 = min ( zcf1, f_one-cfrac(k) ) @@ -1379,7 +1386,8 @@ end subroutine rrtmg_sw_run !>\section rswinit_gen rswinit General Algorithm !----------------------------------- subroutine rswinit( me, rad_hr_units, inc_minor_gas, iswcliq, & - isubcsw, iovr, iswmode, errflg, errmsg ) + isubcsw, iovr, iovr_rand, iovr_maxrand, iovr_max, iovr_dcorr,& + iovr_exp, iovr_exprand, iswmode, errflg, errmsg ) ! =================== program usage description =================== ! ! ! @@ -1400,13 +1408,19 @@ subroutine rswinit( me, rad_hr_units, inc_minor_gas, iswcliq, & ! =0: no sub-col cld treatment, use grid-mean cld quantities ! ! =1: mcica sub-col, prescribed seeds to get random numbers ! ! =2: mcica sub-col, providing array icseed for random numbers! -! iovr - clouds vertical overlapping control flag ! -! =0: random overlapping clouds ! -! =1: maximum/random overlapping clouds ! -! =2: maximum overlap cloud ! -! =3: decorrelation-length overlap clouds ! -! =4: exponential cloud overlap (AER) ! -! =5: exponential-random cloud overlap (AER) ! +! iovr - clouds vertical overlapping control flag ! +! =iovr_rand ! +! =iovr_maxrand ! +! =iovr_max ! +! =iovr_dcorr ! +! =iovr_exp ! +! =iovr_exprand ! +! iovr_rand - choice of cloud-overlap: random ! +! iovr_maxrand - choice of cloud-overlap: maximum random ! +! iovr_max - choice of cloud-overlap: maximum ! +! iovr_dcorr - choice of cloud-overlap: decorrelation length ! +! iovr_exp - choice of cloud-overlap: exponential ! +! iovr_exprand - choice of cloud-overlap: exponential random ! ! iswmode - control flag for 2-stream transfer scheme ! ! =1; delta-eddington (joseph et al., 1976) ! ! =2: pifm (zdunkowski et al., 1980) ! @@ -1428,7 +1442,8 @@ subroutine rswinit( me, rad_hr_units, inc_minor_gas, iswcliq, & ! --- inputs: integer, intent(in) :: me, rad_hr_units, iswcliq, isubcsw, iovr, & - iswmode + iswmode, iovr_rand, iovr_maxrand, iovr_max, iovr_dcorr, & + iovr_exp, iovr_exprand logical, intent(in) :: inc_minor_gas ! --- outputs: character(len=*), intent(out) :: errmsg @@ -1448,6 +1463,13 @@ subroutine rswinit( me, rad_hr_units, inc_minor_gas, iswcliq, & errflg = 0 errmsg = '' + if ((iovr .ne. iovr_rand) .and. (iovr .ne. iovr_maxrand) .and. & + (iovr .ne. iovr_max) .and. (iovr .ne. iovr_dcorr) .and. & + (iovr .ne. iovr_exp) .and. (iovr .ne. iovr_exprand)) then + errflg = 1 + errmsg = 'ERROR(rswinit): Error in specification of cloud overlap flag' + endif + if (me == 0) then print *,' - Using AER Shortwave Radiation, Version: ',VTAGSW diff --git a/physics/radsw_main.meta b/physics/radsw_main.meta index 222f3ce9e..85e446498 100644 --- a/physics/radsw_main.meta +++ b/physics/radsw_main.meta @@ -288,8 +288,8 @@ type = logical intent = in [top_at_1] - standard_name = flag_for_vertical_ordering_in_RRTMGP - long_name = flag for vertical ordering in RRTMGP + standard_name = flag_for_vertical_ordering_in_radiation + long_name = flag for vertical ordering in radiation units = flag dimensions = () type = logical @@ -322,6 +322,48 @@ dimensions = () type = integer intent = in +[iovr_exp] + standard_name = flag_for_exponential_cloud_overlap_method + long_name = choice of exponential cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_exprand] + standard_name = flag_for_exponential_random_cloud_overlap_method + long_name = choice of exponential-random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_max] + standard_name = flag_for_maximum_cloud_overlap_method + long_name = choice of maximum cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_rand] + standard_name = flag_for_random_cloud_overlap_method + long_name = choice of random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_maxrand] + standard_name = flag_for_maximum_random_cloud_overlap_method + long_name = choice of maximum-random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_dcorr] + standard_name = flag_for_decorrelation_length_cloud_overlap_method + long_name = choice of decorrelation-length cloud overlap method + units = flag + dimensions = () + type = integer + intent = in [iswmode] standard_name = flag_for_sw_scattering_choice long_name = flag for rrtmg shortwave scattering choice diff --git a/physics/rrtmgp_aerosol_optics.meta b/physics/rrtmgp_aerosol_optics.meta index f2fc09be6..5f5946afa 100644 --- a/physics/rrtmgp_aerosol_optics.meta +++ b/physics/rrtmgp_aerosol_optics.meta @@ -22,8 +22,8 @@ type = logical intent = in [top_at_1] - standard_name = flag_for_vertical_ordering_in_RRTMGP - long_name = flag for vertical ordering in RRTMGP + standard_name = flag_for_vertical_ordering_in_radiation + long_name = flag for vertical ordering in radiation units = flag dimensions = () type = logical diff --git a/physics/rrtmgp_lw_rte.meta b/physics/rrtmgp_lw_rte.meta index 0ad0754b5..15dbc1062 100644 --- a/physics/rrtmgp_lw_rte.meta +++ b/physics/rrtmgp_lw_rte.meta @@ -72,8 +72,8 @@ type = integer intent = in [top_at_1] - standard_name = flag_for_vertical_ordering_in_RRTMGP - long_name = flag for vertical ordering in RRTMGP + standard_name = flag_for_vertical_ordering_in_radiation + long_name = flag for vertical ordering in radiation units = flag dimensions = () type = logical diff --git a/physics/rrtmgp_sw_rte.meta b/physics/rrtmgp_sw_rte.meta index 9ab24c8b3..3f5bf2b3c 100644 --- a/physics/rrtmgp_sw_rte.meta +++ b/physics/rrtmgp_sw_rte.meta @@ -67,8 +67,8 @@ kind = kind_phys intent = in [top_at_1] - standard_name = flag_for_vertical_ordering_in_RRTMGP - long_name = flag for vertical ordering in RRTMGP + standard_name = flag_for_vertical_ordering_in_radiation + long_name = flag for vertical ordering in radiation units = flag dimensions = () type = logical From dab7efdc064cc7f1ad36e1144ef3fa473cb2d520 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Wed, 7 Sep 2022 15:18:11 -0600 Subject: [PATCH 039/380] Address issue 957 --- physics/GFS_rrtmgp_cloud_mp.F90 | 35 ++++++++++++++++++++------------ physics/GFS_rrtmgp_cloud_mp.meta | 8 ++++++++ 2 files changed, 30 insertions(+), 13 deletions(-) diff --git a/physics/GFS_rrtmgp_cloud_mp.F90 b/physics/GFS_rrtmgp_cloud_mp.F90 index 966c9f2e9..7b6f60554 100644 --- a/physics/GFS_rrtmgp_cloud_mp.F90 +++ b/physics/GFS_rrtmgp_cloud_mp.F90 @@ -43,7 +43,7 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, cld_rerain, precip_frac, & cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, cld_cnv_reice, cld_pbl_lwp, & cld_pbl_reliq, cld_pbl_iwp, cld_pbl_reice, lwp_ex, iwp_ex, lwp_fc, iwp_fc, & - errmsg, errflg) + cldfra2d, errmsg, errflg) implicit none ! Inputs @@ -123,6 +123,8 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic iwp_ex, & ! Total ice water path from explicit microphysics lwp_fc, & ! Total liquid water path from cloud fraction scheme iwp_fc ! Total ice water path from cloud fraction scheme + real(kind_phys), dimension(:), intent(out) :: & + cldfra2d ! Instantaneous 2D (max-in-column) cloud fraction real(kind_phys), dimension(:,:),intent(inout) :: & cld_frac, & ! Cloud-fraction for stratiform clouds cld_lwp, & ! Water path for stratiform liquid cloud-particles @@ -281,6 +283,13 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic endif endif + do iCol = 1, nCol + cldfra2d(iCol) = 0._kind_phys + do iLay = 1, nLev-1 + cldfra2d(iCol) = max(cldfra2d(iCol), cld_frac(iCol,iLay)) + enddo + enddo + precip_frac(1:nCol,1:nLev) = cld_frac(1:nCol,1:nLev) end subroutine GFS_rrtmgp_cloud_mp_run @@ -459,23 +468,23 @@ subroutine cloud_mp_SAMF(nCol, nLev, t_lay, p_lev, p_lay, qs_lay, relhum, nCol, & ! Number of horizontal grid points nLev ! Number of vertical layers real(kind_phys), intent(in) :: & - con_g, & ! Physical constant: gravitational constant - con_ttp, & ! Triple point temperature of water (K) + con_g, & ! Physical constant: gravity (m s-2) + con_ttp, & ! Triple point temperature of water (K) alpha0 ! real(kind_phys), dimension(:,:),intent(in) :: & - t_lay, & ! Temperature at layer centers (K) - p_lev, & ! Pressure at layer interfaces (Pa) - p_lay, & ! - qs_lay, & ! - relhum, & ! - cnv_mixratio ! Convective cloud mixing-ratio (kg/kg) + t_lay, & ! Temperature at layer-centers (K) + p_lev, & ! Pressure at layer-interfaces (Pa) + p_lay, & ! Presure at layer-centers (Pa) + qs_lay, & ! Specific-humidity at layer-centers (kg/kg) + relhum, & ! Relative-humidity (1) + cnv_mixratio ! Convective cloud mixing-ratio (kg/kg) ! Outputs real(kind_phys), dimension(:,:),intent(inout) :: & cld_cnv_lwp, & ! Convective cloud liquid water path cld_cnv_reliq, & ! Convective cloud liquid effective radius cld_cnv_iwp, & ! Convective cloud ice water path cld_cnv_reice, & ! Convective cloud ice effecive radius - cld_cnv_frac ! Convective cloud-fraction (1) + cld_cnv_frac ! Convective cloud-fraction ! Local integer :: iCol, iLay real(kind_phys) :: tem0, tem1, deltaP, clwc @@ -487,13 +496,13 @@ subroutine cloud_mp_SAMF(nCol, nLev, t_lay, p_lev, p_lay, qs_lay, relhum, tem1 = min(1.0, max(0.0, (con_ttp-t_lay(iCol,iLay))*0.05)) deltaP = abs(p_lev(iCol,iLay+1)-p_lev(iCol,iLay))*0.01 clwc = max(0.0, cnv_mixratio(iCol,iLay)) * tem0 * deltaP - cld_cnv_iwp(iCol,iLay) = clwc * tem1 - cld_cnv_lwp(iCol,iLay) = clwc - cld_cnv_iwp(iCol,iLay) + cld_cnv_iwp(iCol,iLay) = clwc * tem1 + cld_cnv_lwp(iCol,iLay) = clwc - cld_cnv_iwp(iCol,iLay) cld_cnv_reliq(iCol,iLay) = reliq_def cld_cnv_reice(iCol,iLay) = reice_def ! Xu-Randall (1996) cloud-fraction. - cld_cnv_frac(iCol,iLay) = cld_frac_XuRandall(p_lay(iCol,iLay), & + cld_cnv_frac(iCol,iLay) = cld_frac_XuRandall(p_lay(iCol,iLay), & qs_lay(iCol,iLay), relhum(iCol,iLay), cnv_mixratio(iCol,iLay), alpha0) endif enddo diff --git a/physics/GFS_rrtmgp_cloud_mp.meta b/physics/GFS_rrtmgp_cloud_mp.meta index 88a050abb..a5a986b8a 100644 --- a/physics/GFS_rrtmgp_cloud_mp.meta +++ b/physics/GFS_rrtmgp_cloud_mp.meta @@ -639,6 +639,14 @@ type = real kind = kind_phys intent = inout +[cldfra2d] + standard_name = max_in_column_cloud_fraction + long_name = instantaneous 2D (max-in-column) cloud fraction + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 0650bae3ed02503c904a0e94d05b98c21eb3d725 Mon Sep 17 00:00:00 2001 From: dustinswales Date: Mon, 12 Sep 2022 15:45:26 -0600 Subject: [PATCH 040/380] Fix bug in metadata. --- physics/GFS_rrtmg_setup.F90 | 11 +++++------ physics/GFS_rrtmg_setup.meta | 15 ++++----------- physics/radlw_main.meta | 12 ++++++------ physics/radsw_main.meta | 12 ++++++------ 4 files changed, 21 insertions(+), 29 deletions(-) diff --git a/physics/GFS_rrtmg_setup.F90 b/physics/GFS_rrtmg_setup.F90 index 5ad446985..c61ce358e 100644 --- a/physics/GFS_rrtmg_setup.F90 +++ b/physics/GFS_rrtmg_setup.F90 @@ -44,8 +44,8 @@ subroutine GFS_rrtmg_setup_init ( si, levr, ictm, isol, solar_file, ico2, & lcnorm, imp_physics, lnoprec, idate, iflip, do_RRTMGP, me, lalw1bd, & iaermdl, iaerflg, aeros_file, con_pi, con_t0c, con_c, con_boltz, & con_plnk, con_solr_2008, con_solr_2002, co2usr_file, co2cyc_file, & - rad_hr_units, inc_minor_gas, ilwcliq, iswcliq, isubcsw, isubclw, & - iswmode, ipsd0, errmsg, errflg) + rad_hr_units, inc_minor_gas, icliq_lw, isubcsw, isubclw, iswmode, & + ipsd0, errmsg, errflg) ! ================= subprogram documentation block ================ ! ! ! @@ -155,8 +155,7 @@ subroutine GFS_rrtmg_setup_init ( si, levr, ictm, isol, solar_file, ico2, & integer, intent(in) :: levr, ictm, isol, ico2, iaer, ntcw, num_p3d, & npdf3d, ntoz, iovr, iovr_rand, iovr_maxrand, iovr_max, & iovr_dcorr, iovr_exp, iovr_exprand, icliq_sw, imp_physics, & - iflip, me, rad_hr_units, ilwcliq, iswcliq, isubcsw, isubclw, & - iswmode + iflip, me, rad_hr_units, icliq_lw, isubcsw, isubclw, iswmode integer, intent(in) :: idate(:) logical, intent(in) :: lcrick, lcnorm, lnoprec, do_RRTMGP, lalw1bd, & inc_minor_gas @@ -221,10 +220,10 @@ subroutine GFS_rrtmg_setup_init ( si, levr, ictm, isol, solar_file, ico2, & call gas_init ( me, co2usr_file, co2cyc_file, ico2, ictm, ntoz, & con_pi, errflg, errmsg) call cld_init ( si, levr, imp_physics, me, errflg, errmsg) - call rlwinit ( me, rad_hr_units, inc_minor_gas, ilwcliq, isubcsw, & + call rlwinit ( me, rad_hr_units, inc_minor_gas, icliq_lw, isubcsw, & iovr, iovr_rand, iovr_maxrand, iovr_max, iovr_dcorr, & iovr_exp, iovr_exprand, errflg, errmsg ) - call rswinit ( me, rad_hr_units, inc_minor_gas, iswcliq, isubclw, & + call rswinit ( me, rad_hr_units, inc_minor_gas, icliq_sw, isubclw, & iovr, iovr_rand, iovr_maxrand, iovr_max, iovr_dcorr, & iovr_exp, iovr_exprand,iswmode, errflg, errmsg ) diff --git a/physics/GFS_rrtmg_setup.meta b/physics/GFS_rrtmg_setup.meta index 40da39a1c..bf323676d 100644 --- a/physics/GFS_rrtmg_setup.meta +++ b/physics/GFS_rrtmg_setup.meta @@ -274,18 +274,11 @@ dimensions = () type = logical intent = in -[ilwcliq] - standard_name = flag_for_rrtmg_lw_cloud_optics - long_name = flag for rrtmg longwave cloud optics +[icliq_lw] + standard_name = flag_for_optical_property_for_liquid_clouds_for_longwave_radiation + long_name = lw optical property for liquid clouds units = flag - dimensions = () - type = integer - intent = in -[iswcliq] - standard_name = flag_for_rrtmg_sw_cloud_optics - long_name = flag for rrtmg shortwave cloud optics - units = flag - dimensions = () + dimensions = () type = integer intent = in [con_pi] diff --git a/physics/radlw_main.meta b/physics/radlw_main.meta index 406f773e3..3dccc97b3 100644 --- a/physics/radlw_main.meta +++ b/physics/radlw_main.meta @@ -305,17 +305,17 @@ type = logical intent = in [ilwcliq] - standard_name = flag_for_rrtmg_lw_cloud_optics - long_name = flag for rrtmg longwave cloud optics + standard_name = flag_for_optical_property_for_liquid_clouds_for_longwave_radiation + long_name = lw optical property for liquid clouds units = flag - dimensions = () + dimensions = () type = integer intent = in [ilwcice] - standard_name = flag_for_rrtmg_lw_ice_cloud_optics - long_name = flag for rrtmg longwave ice cloud optics + standard_name = flag_for_optical_property_for_ice_clouds_for_longwave_radiation + long_name = lw optical property for ice clouds units = flag - dimensions = () + dimensions = () type = integer intent = in [isubclw] diff --git a/physics/radsw_main.meta b/physics/radsw_main.meta index 85e446498..eff5cdca3 100644 --- a/physics/radsw_main.meta +++ b/physics/radsw_main.meta @@ -295,17 +295,17 @@ type = logical intent = in [iswcice] - standard_name = flag_for_rrtmg_sw_ice_cloud_optics - long_name = flag for rrtmg shortwave ice cloud optics + standard_name = flag_for_optical_property_for_ice_clouds_for_shortwave_radiation + long_name = sw optical property for ice clouds units = flag - dimensions = () + dimensions = () type = integer intent = in [iswcliq] - standard_name = flag_for_rrtmg_sw_cloud_optics - long_name = flag for rrtmg shortwave cloud optics + standard_name = control_for_shortwave_radiation_liquid_clouds + long_name = sw optical property for liquid clouds units = flag - dimensions = () + dimensions = () type = integer intent = in [isubcsw] From 405621763e00169e7edd7253491b5ea21aea9f29 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Fri, 16 Sep 2022 00:52:37 +0000 Subject: [PATCH 041/380] fix some bugs and make some more --- physics/clm_lake.f90 | 88 +++++++++++++++++++++++-------------- physics/flake_driver.F90 | 6 +-- physics/flake_driver.meta | 8 ---- physics/myjsfc_wrapper.F90 | 4 +- physics/myjsfc_wrapper.meta | 8 ---- physics/sfc_diag.f | 12 ++--- 6 files changed, 67 insertions(+), 59 deletions(-) diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90 index a472e47bd..dcb97de44 100644 --- a/physics/clm_lake.f90 +++ b/physics/clm_lake.f90 @@ -616,6 +616,19 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& print *,'Unhappy point before LakeMain t_soilsno = ',t_soisno(1,:) endif endif + + eflx_lwrad_net = -9999 + eflx_gnet = -9999 + eflx_sh_tot = -9999 + eflx_lh_tot = -9999 + t_ref2m = -9999 + q_ref2m = -9999 + taux = -9999 + tauy = -9999 + ram1 = -9999 + z0mg = -9999 + ustar_out = -9999 + is_unhappy=.false. CALL LakeMain(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, & !I forc_hgt_t,forc_hgt_u,forc_q, forc_u, & @@ -730,6 +743,10 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& ustar = ustar_out(1) ! surface_friction_velocity_over_water ! Calculate qsfc from t_grnd: (surface_specific_humidity_over_water) + PSFC = prsi(i,1) + discard1 = -9999 + discard2 = -9999 + discard3 = -9999 call QSat(t_grnd(c),psfc,discard1,discard2,qsfc(i),discard3) ! From flake driver: @@ -1191,7 +1208,6 @@ SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, ! real(kind_phys) :: z0mg(lbp:ubp) ! roughness length over ground, momentum [m] real(kind_phys) :: z0hg(lbp:ubp) ! roughness length over ground, sensible heat [m] real(kind_phys) :: z0qg(lbp:ubp) ! roughness length over ground, latent heat [m] - real(kind_phys) :: beta(2) ! fraction solar rad absorbed at surface: depends on lake type real(kind_phys) :: u2m ! 2 m wind speed (m/s) real(kind_phys) :: u10(1) ! 10-m wind (m/s) (for dust model) real(kind_phys) :: fv(1) ! friction velocity (m/s) (for dust model) @@ -1206,7 +1222,8 @@ SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, ! ! Constants for lake temperature model ! - data beta/0.4_kind_phys, 0.4_kind_phys/ ! (deep lake, shallow lake) + real(kind_phys), parameter :: beta(2) = & ! fraction solar rad absorbed at surface: depends on lake type + (/0.4_kind_phys, 0.4_kind_phys/) ! (deep lake, shallow lake) ! This is the energy absorbed at the lake surface if no snow. ! data za /0.6_kind_phys, 0.5_kind_phys/ ! data eta /0.1_kind_phys, 0.5_kind_phys/ @@ -1741,8 +1758,6 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! integer , parameter :: islak = 2 ! index of lake, 1 = deep lake, 2 = shallow lake real(kind_phys), parameter :: p0 = 1._kind_phys ! neutral value of turbulent prandtl number integer :: i,j,fc,fp,g,c,p ! do loop or array index - real(kind_phys) :: beta(2) ! fraction solar rad absorbed at surface: depends on lake type - real(kind_phys) :: za(2) ! base of surface absorption layer (m): depends on lake type real(kind_phys) :: eta(2) ! light extinction coefficient (/m): depends on lake type real(kind_phys) :: cwat ! specific heat capacity of water (j/m**3/kelvin) real(kind_phys) :: cice_eff ! effective heat capacity of ice (using density of @@ -1810,8 +1825,10 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! ! ! Constants for lake temperature model ! - data beta/0.4_kind_phys, 0.4_kind_phys/ ! (deep lake, shallow lake) - data za /0.6_kind_phys, 0.6_kind_phys/ + real(kind_phys), parameter :: beta(2) = & ! fraction solar rad absorbed at surface: depends on lake type + (/0.4_kind_phys, 0.4_kind_phys/) ! (deep lake, shallow lake) + real(kind_phys), parameter :: za(2) = & ! base of surface absorption layer (m): depends on lake type + (/0.6_kind_phys, 0.6_kind_phys/) ! For now, keep beta and za for shallow lake the same as deep lake, until better data is found. ! It looks like eta is key and that larger values give better results for shallow lakes. Use ! empirical expression from Hakanson (below). This is still a very unconstrained parameter @@ -4229,9 +4246,8 @@ subroutine CombineSnowLayers(lbc, ubc, & !i integer :: neibor ! adjacent node selected for combination real(kind_phys):: zwice(lbc:ubc) ! total ice mass in snow real(kind_phys):: zwliq (lbc:ubc) ! total liquid water in snow - real(kind_phys):: dzmin(5) ! minimum of top snow layer - - data dzmin /0.010, 0.015, 0.025, 0.055, 0.115/ + real(kind_phys), parameter :: dzmin(5) = & ! minimum of top snow layer + (/0.010, 0.015, 0.025, 0.055, 0.115/) !----------------------------------------------------------------------- ! Check the mass of ice lens of snow, when the total is less than a small value, @@ -5374,38 +5390,21 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, integer :: used_lakedepth_default, init_points, month, julday integer :: mon, iday, num2, num1, juld, day2, day1, wght1, wght2 real(kind_phys) :: Tclim + logical :: have_date used_lakedepth_default=0 + have_date=.false. errmsg = '' errflg = 0 - call get_month_and_day(IDATE,month,iday,julday,fhour) - - !-- Compute weight for the current day - mon = month - if(iday > 15) mon=mon+1 - if(mon == 1) mon=13 - - num2 = month * 2 - if(iday > 15) num2=num2+1 - if(num2 == 1) num2=25 - num1 = num2 - 1 - - juld = julday - if (juld < 7) juld = juld + 365 - day2 = julm(mon)+15 - day1 = julm(mon) - wght1=(day2-julday)/float(day2-day1) - wght2=(julday-day1)/float(day2-day1) - if(LAKEDEBUG .and. me==0) then print *,'month,num1,num2,day1,day2,wght1,wght2',month,num1,num2,day1,day2,wght1,wght2 endif !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - DO i=1,im + do_init_part1: DO i=1,im if(use_lake_model(i)==0) then cycle endif @@ -5427,6 +5426,31 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, cycle endif + if(.not.have_date) then + !$OMP CRITICAL + call get_month_and_day(IDATE,month,iday,julday,fhour) + !$OMP END CRITICAL + + have_date = .true. + + !-- Compute weight for the current day + mon = month + if(iday > 15) mon=mon+1 + if(mon == 1) mon=13 + + num2 = month * 2 + if(iday > 15) num2=num2+1 + if(num2 == 1) num2=25 + num1 = num2 - 1 + + juld = julday + if (juld < 7) juld = juld + 365 + day2 = julm(mon)+15 + day1 = julm(mon) + wght1=(day2-julday)/float(day2-day1) + wght2=(julday-day1)/float(day2-day1) + endif + snowdp2d(i) = snowd(i)*1e-3 ! SNOW in kg/m^2 and snowdp in m h2osno2d(i) = weasd(i) ! mm @@ -5472,7 +5496,7 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, h2osoi_vol3d(i,:) = 0.0 snl2d(i) = 0.0 - ENDDO + ENDDO do_init_part1 if(used_lakedepth_default>0) then print *,'used lakedepth_default: ',used_lakedepth_default @@ -5481,7 +5505,7 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, !!!!!!!!!!!!!!!!!!begin to initialize lake variables!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! init_points=0 - DO i = 1,im + do_init_part2: DO i = 1,im if(use_lake_model(i)==0 .or. clm_lake_initialized(i)>0) then cycle @@ -5684,7 +5708,7 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, end do clm_lake_initialized(i) = 1 - ENDDO + ENDDO do_init_part2 if(LAKEDEBUG .and. init_points>0) then diff --git a/physics/flake_driver.F90 b/physics/flake_driver.F90 index e27d32ff3..a277783fb 100644 --- a/physics/flake_driver.F90 +++ b/physics/flake_driver.F90 @@ -50,7 +50,7 @@ end subroutine flake_driver_finalize SUBROUTINE flake_driver_run ( & ! ---- Inputs im, ps, t1, q1, wind, min_lakeice, & - dlwflx, dswsfc, lakedepth, lakefrac, & + dlwflx, dswsfc, lakedepth, & use_lake_model, snow, xlat, delt, zlvl, elev, & wet, yearlen, julian, imon, & flag_iter, first_time_step, flag_restart, & @@ -91,7 +91,7 @@ SUBROUTINE flake_driver_run ( & real (kind=kind_phys), intent(in) :: delt, min_lakeice real (kind=kind_phys), dimension(:), intent(in) :: & - & xlat, lakedepth, lakefrac, snow + & xlat, lakedepth, snow real (kind=kind_phys), dimension(:), intent(in) :: weasd @@ -308,7 +308,7 @@ SUBROUTINE flake_driver_run ( & ! w_extinc(i) = 3.0 ! write(0,1002) julian,xlat(i),w_albedo(I),w_extinc(i),elev(i),tsurf(i),T_sfc(i),t_bot1(i) -! write(0,1003) use_lake_model(i),i,lakefrac(i),lakedepth(i), snwdph(i), hice(i), fice(i) +! write(0,1003) use_lake_model(i),i,lakedepth(i), snwdph(i), hice(i), fice(i) ! write(0,1004) ps(i), wind(i), t1(i), q1(i), dlwflx(i), dswsfc(i), zlvl(i) endif !flag diff --git a/physics/flake_driver.meta b/physics/flake_driver.meta index 834bfd0a4..94335a62d 100644 --- a/physics/flake_driver.meta +++ b/physics/flake_driver.meta @@ -118,14 +118,6 @@ type = real kind = kind_phys intent = in -[lakefrac] - standard_name = lake_area_fraction - long_name = fraction of horizontal grid area occupied by lake - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in [use_lake_model] standard_name = flag_for_using_lake_model long_name = flag indicating lake points using a lake model diff --git a/physics/myjsfc_wrapper.F90 b/physics/myjsfc_wrapper.F90 index d7737e911..fa729d088 100644 --- a/physics/myjsfc_wrapper.F90 +++ b/physics/myjsfc_wrapper.F90 @@ -52,7 +52,7 @@ SUBROUTINE myjsfc_wrapper_run( & & phy_myj_a1u, phy_myj_a1t, phy_myj_a1q, & & pblh, slmsk, zorl, ustar, rib, & & cm,ch,stress,ffm,ffh,fm10,fh2, & - & landfrac,lakefrac,oceanfrac,fice, & + & landfrac, oceanfrac,fice, & & z0rl_wat, z0rl_lnd, z0rl_ice, & ! intent(inout) & ustar_wat, ustar_lnd, ustar_ice, & ! intent(inout) & cm_wat, cm_lnd, cm_ice, & ! intent(inout) @@ -121,7 +121,7 @@ SUBROUTINE myjsfc_wrapper_run( & real(kind=kind_phys),dimension(:),intent(inout) :: & & cm, ch, stress, ffm, ffh, fm10, fh2 real(kind=kind_phys), dimension(:), intent(inout) :: & - & landfrac, lakefrac, oceanfrac, fice + & landfrac, oceanfrac, fice real(kind=kind_phys), dimension(:), intent(inout) :: & & z0rl_wat, z0rl_lnd, z0rl_ice, & & ustar_wat, ustar_lnd, ustar_ice, & diff --git a/physics/myjsfc_wrapper.meta b/physics/myjsfc_wrapper.meta index 65ccc7dd9..40b6b78f3 100644 --- a/physics/myjsfc_wrapper.meta +++ b/physics/myjsfc_wrapper.meta @@ -421,14 +421,6 @@ type = real kind = kind_phys intent = inout -[lakefrac] - standard_name = lake_area_fraction - long_name = fraction of horizontal grid area occupied by lake - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout [oceanfrac] standard_name = sea_area_fraction long_name = fraction of horizontal grid area occupied by ocean diff --git a/physics/sfc_diag.f b/physics/sfc_diag.f index a8e87b9ac..7018d395c 100644 --- a/physics/sfc_diag.f +++ b/physics/sfc_diag.f @@ -77,11 +77,11 @@ subroutine sfc_diag_run & ! f10m(i) = min(f10m(i),1.) u10m(i) = f10m(i) * u1(i) v10m(i) = f10m(i) * v1(i) - if(use_lake_model(i)>0 .and. iopt_lake==iopt_lake_clm) then - t2m(i) = lake_t2m(i) - q2m(i) = lake_q2m(i) - clm_t2m_count=clm_t2m_count+1 - else + ! use_clm_2m: if(use_lake_model(i)>0 .and. iopt_lake==iopt_lake_clm) then + ! t2m(i) = lake_t2m(i) + ! q2m(i) = lake_q2m(i) + ! clm_t2m_count=clm_t2m_count+1 + ! else fhi = fh2(i) / fh(i) ! t2m(i) = tskin(i)*(1. - fhi) + t1(i) * prslki(i) * fhi ! sig2k = 1. - (grav+grav) / (cp * t2m(i)) @@ -103,7 +103,7 @@ subroutine sfc_diag_run & qss = fpvs(t2m(i)) qss = eps * qss / (ps(i) + epsm1 * qss) q2m(i) = min(q2m(i),qss) - endif + ! endif use_clm_2m enddo return From 2014d7b54491a965d462ab83f047fd9847c1f1d6 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Mon, 19 Sep 2022 22:04:54 +0000 Subject: [PATCH 042/380] set roughness length over ice & water in clm lake model --- physics/clm_lake.f90 | 7 +++++-- physics/clm_lake.meta | 16 ++++++++++++++++ 2 files changed, 21 insertions(+), 2 deletions(-) diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90 index dcb97de44..c46642b1d 100644 --- a/physics/clm_lake.f90 +++ b/physics/clm_lake.f90 @@ -277,7 +277,7 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& lake_t2m ,lake_q2m ,clm_lake_initialized ,& weasd ,isltyp ,snowd ,use_lakedepth ,& restart ,lakedepth_default ,& - sand3d ,clay3d ,& + zorlw ,zorli ,sand3d ,clay3d ,& ! Flake output variables weasdi ,snodi ,hice ,tsurf ,& t_sfc ,lflx ,ustar ,qsfc ,& @@ -332,7 +332,7 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(IN) :: dswsfci REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(IN) :: emiss REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(IN) :: rain - REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(INOUT) :: albedo + REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(INOUT) :: albedo, zorlw, zorli INTEGER, DIMENSION( : ), INTENT(IN) :: ISLTYP INTEGER, DIMENSION( : ), INTENT(INOUT) :: salty REAL(KIND_PHYS), INTENT(IN) :: dtp @@ -717,6 +717,8 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& icy(i)=.true. ice_points = ice_points+1 + zorli(i) = z0mg(c) + ! Assume that, if a layer has ice, the entire layer thickness is ice. hice(I) = 0 do k=1,nlevlake @@ -725,6 +727,7 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& endif end do else + zorlw(i) = z0mg(c) weasdi(i) = 0 snodi(i) = 0 tisfc(i) = tsurf(i) diff --git a/physics/clm_lake.meta b/physics/clm_lake.meta index d2fc08d81..5953677e5 100644 --- a/physics/clm_lake.meta +++ b/physics/clm_lake.meta @@ -7,6 +7,22 @@ [ccpp-arg-table] name = clm_lake_run type = scheme +[zorlw] + standard_name = surface_roughness_length_over_water + long_name = surface roughness length over water + units = cm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[zorli] + standard_name = surface_roughness_length_over_ice + long_name = surface roughness length over ice + units = cm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout [fhour] standard_name = forecast_time long_name = current forecast time From 2fe654eddc9e559b91c555f14b1645385cb9128d Mon Sep 17 00:00:00 2001 From: dustinswales Date: Wed, 21 Sep 2022 11:08:26 -0600 Subject: [PATCH 043/380] Address reviewers comments. Bug found in seeding for cloud-sampling in RRTMGP. --- physics/GFS_rrtmg_pre.F90 | 10 ++---- physics/GFS_rrtmg_pre.meta | 2 +- physics/GFS_rrtmgp_cloud_overlap.F90 | 2 +- physics/GFS_rrtmgp_pre.F90 | 50 ++++++++++----------------- physics/GFS_rrtmgp_pre.meta | 8 ++--- physics/GFS_rrtmgp_setup.F90 | 42 +++++++++++++---------- physics/GFS_rrtmgp_setup.meta | 51 +++++----------------------- physics/myjsfc_wrapper.F90 | 2 +- 8 files changed, 59 insertions(+), 108 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 9de3cb16c..d5540a043 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -19,7 +19,7 @@ module GFS_rrtmg_pre !>\section rrtmg_pre_gen General Algorithm subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & imfdeepcnv, imfdeepcnv_gf, me, ncnd, ntrac, num_p3d, npdf3d, ncnvcld3d,& - ntqv, ntcw,ntiw, ntlnc, ntinc, ntrnc, ntsnc, ntccn, & + ntqv, ntcw,ntiw, ntlnc, ntinc, ntrnc, ntsnc, ntccn, top_at_1, & ntrw, ntsw, ntgl, nthl, ntwa, ntoz, & ntclamt, nleffr, nieffr, nseffr, lndp_type, kdt, & ntdu1, ntdu2, ntdu3, ntdu4, ntdu5, ntss1, ntss2, & @@ -45,7 +45,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & clouds9, cldsa, cldfra, cldfra2d, lwp_ex,iwp_ex, lwp_fc,iwp_fc, & faersw1, faersw2, faersw3, faerlw1, faerlw2, faerlw3, alpha, & aero_dir_fdb, smoke_ext, dust_ext, & - spp_wts_rad, spp_rad, rrfs_smoke_band, top_at_1, ico2, errmsg, errflg) + spp_wts_rad, spp_rad, rrfs_smoke_band, ico2, errmsg, errflg) use machine, only: kind_phys @@ -124,7 +124,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & logical, intent(in) :: lsswr, lslwr, ltaerosol, lgfdlmprad, & uni_cld, effr_in, do_mynnedmf, & lmfshal, lmfdeep2, pert_clds, lcrick,& - lcnorm + lcnorm, top_at_1 logical, intent(in) :: aero_dir_fdb real(kind=kind_phys), dimension(:,:), intent(in) :: smoke_ext, dust_ext @@ -203,7 +203,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & faerlw2,& faerlw3 real(kind=kind_phys), dimension(:,:), intent(out) :: alpha - logical, intent(out) :: top_at_1 character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -260,9 +259,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & errmsg = '' errflg = 0 - ! Vertical ordering - top_at_1 = (prsi(1,1) .lt. prsi(1, LMP)) - if (.not. (lsswr .or. lslwr)) return !--- set commonly used integers diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 228b73f20..752a6e1ed 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -1393,7 +1393,7 @@ units = flag dimensions = () type = logical - intent = out + intent = in [si] standard_name = sigma_pressure_hybrid_vertical_coordinate long_name = vertical sigma coordinate for radiation initialization diff --git a/physics/GFS_rrtmgp_cloud_overlap.F90 b/physics/GFS_rrtmgp_cloud_overlap.F90 index 28c925600..0094f8165 100644 --- a/physics/GFS_rrtmgp_cloud_overlap.F90 +++ b/physics/GFS_rrtmgp_cloud_overlap.F90 @@ -100,6 +100,7 @@ subroutine GFS_rrtmgp_cloud_overlap_run(nCol, nLev, yearlen, doSWrad, doLWrad, ! ! Cloud decorrelation length ! + de_lgth(:) = 0. if (idcor == idcor_hogan) then call cmp_dcorr_lgth(nCol, lat, con_pi, de_lgth) endif @@ -116,7 +117,6 @@ subroutine GFS_rrtmgp_cloud_overlap_run(nCol, nLev, yearlen, doSWrad, doLWrad, if (iovr == iovr_dcorr .or. iovr == iovr_exp .or. iovr == iovr_exprand) then call get_alpha_exper(nCol, nLev, iovr, iovr_exprand, deltaZc*0.001, de_lgth, cld_frac, cloud_overlap_param) else - de_lgth(:) = 0. cloud_overlap_param(:,:) = 0. endif diff --git a/physics/GFS_rrtmgp_pre.F90 b/physics/GFS_rrtmgp_pre.F90 index 9822aaf74..f68cdf000 100644 --- a/physics/GFS_rrtmgp_pre.F90 +++ b/physics/GFS_rrtmgp_pre.F90 @@ -5,19 +5,14 @@ !! \brief This module contains code to prepare model fields for use by the RRTMGP !! radiation scheme. module GFS_rrtmgp_pre - use machine, only: & - kind_phys !< Working type - use funcphys, only: & - fpvs !< Function ot compute sat. vapor pressure over liq. - use module_radiation_astronomy, only: & - coszmn - use module_radiation_gases, only: & - NF_VGAS, & !< Number of active gas species - getgases, & !< Routine to setup trace gases - getozn !< Routine to setup ozone - ! RRTMGP types - use mo_gas_concentrations, only: ty_gas_concs - use radiation_tools, only: check_error_msg,cmp_tlev + use machine, only: kind_phys + use funcphys, only: fpvs + use module_radiation_astronomy, only: coszmn + use module_radiation_gases, only: NF_VGAS, getgases, getozn + use mo_gas_concentrations, only: ty_gas_concs + use radiation_tools, only: check_error_msg,cmp_tlev + + implicit none real(kind_phys), parameter :: & amd = 28.9644_kind_phys, & !< Molecular weight of dry-air (g/mol) @@ -120,12 +115,16 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw ! Inputs integer, intent(in) :: & + me, & ! Current MPI rank nCol, & ! Number of horizontal grid points nLev, & ! Number of vertical layers nTracers, & ! Number of tracers from model. i_o3, & ! Index into tracer array for ozone - ico2 ! Flag for co2 radiation scheme + ico2, & ! Flag for co2 radiation scheme + iSFC, & ! Vertical index for surface + iTOA ! Vertical index for TOA logical, intent(in) :: & + top_at_1, & ! Vertical ordering flag lsswr, & ! Call SW radiation? lslwr ! Call LW radiation real(kind_phys), intent(in) :: & @@ -164,11 +163,7 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw character(len=*), intent(out) :: & errmsg ! Error message integer, intent(out) :: & - errflg, & ! Error flag - iSFC, & ! Vertical index for surface - iTOA ! Vertical index for TOA - logical, intent(out) :: & - top_at_1 ! Vertical ordering flag + errflg ! Error flag real(kind_phys), intent(inout) :: & raddt ! Radiation time-step real(kind_phys), dimension(:), intent(inout) :: & @@ -209,20 +204,6 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw errflg = 0 if (.not. (lsswr .or. lslwr)) return - - ! ####################################################################################### - ! What is vertical ordering? - ! ####################################################################################### - top_at_1 = (prsi(1,1) .lt. prsi(1, nLev)) - if (top_at_1) then - iSFC = nLev - iTOA = 1 - iSFC_ilev = iSFC + 1 - else - iSFC = 1 - iTOA = nLev - iSFC_ilev = 1 - endif ! ####################################################################################### ! Compute some fields needed by RRTMGP @@ -384,6 +365,9 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw ! ####################################################################################### ! Setup surface ground temperature and ground/air skin temperature if required. ! ####################################################################################### + iSFC_ilev = 1 + if (top_at_1) iSFC_ilev = iSFC + 1 + tsfg(1:NCOL) = t_lev(1:NCOL,iSFC_ilev) tsfa(1:NCOL) = t_lay(1:NCOL,iSFC) diff --git a/physics/GFS_rrtmgp_pre.meta b/physics/GFS_rrtmgp_pre.meta index ff6e262cc..1c269af0f 100644 --- a/physics/GFS_rrtmgp_pre.meta +++ b/physics/GFS_rrtmgp_pre.meta @@ -2,7 +2,7 @@ name = GFS_rrtmgp_pre type = scheme dependencies = funcphys.f90,iounitdef.f,machine.F,module_bfmicrophysics.f,physcons.F90,radcons.f90,radiation_aerosols.f - dependencies = radiation_astronomy.f,radiation_clouds.f,radiation_gases.f,radiation_tools.F90,rrtmg_lw_cloud_optics.F90 + dependencies = radiation_astronomy.f,radiation_gases.f,radiation_tools.F90,rrtmg_lw_cloud_optics.F90 ######################################################################## [ccpp-arg-table] @@ -369,21 +369,21 @@ units = flag dimensions = () type = logical - intent = out + intent = in [iSFC] standard_name = vertical_index_for_surface_in_RRTMGP long_name = index for surface layer in RRTMGP units = flag dimensions = () type = integer - intent = out + intent = in [iTOA] standard_name = vertical_index_for_TOA_in_RRTMGP long_name = index for TOA layer in RRTMGP units = flag dimensions = () type = integer - intent = out + intent = in [tsfc_radtime] standard_name = surface_skin_temperature_on_radiation_timestep long_name = surface skin temperature on radiation timestep diff --git a/physics/GFS_rrtmgp_setup.F90 b/physics/GFS_rrtmgp_setup.F90 index 842d8e983..ad1d05cf8 100644 --- a/physics/GFS_rrtmgp_setup.F90 +++ b/physics/GFS_rrtmgp_setup.F90 @@ -9,7 +9,9 @@ module GFS_rrtmgp_setup implicit none public GFS_rrtmgp_setup_init, GFS_rrtmgp_setup_timestep_init, GFS_rrtmgp_setup_finalize - + + private + ! Version tag and last revision date character(40), parameter :: & VTAGRAD='NCEP-RRTMGP_driver v1.0 Sep 2019 ' @@ -35,10 +37,9 @@ module GFS_rrtmgp_setup subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires, & imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, imp_physics_zhao_carr, & imp_physics_zhao_carr_pdf, imp_physics_mg, si, levr, ictm, isol, ico2, iaer, & - ntcw, num_p3d, ntoz, iovr, isubc_sw, isubc_lw, icliq_sw, crick_proof, ccnorm, & - norad_precip, lalw1bd, idate, iflip, me, aeros_file, iaermdl, iaerflg, con_pi, & - con_t0c, con_c, con_boltz, con_plnk, solar_file, con_solr_2008, con_solr_2002, & - co2usr_file, co2cyc_file, errmsg, errflg) + ntcw, ntoz, iovr, isubc_sw, isubc_lw, lalw1bd, idate, me, aeros_file, & + iaermdl, iaerflg, con_pi, con_t0c, con_c, con_boltz, con_plnk, solar_file, & + con_solr_2008, con_solr_2002, co2usr_file, co2cyc_file, ipsd0, errmsg, errflg) ! Inputs logical, intent(in) :: do_RRTMGP @@ -56,18 +57,19 @@ subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires, real(kind_phys), dimension(:), intent(in) :: & si integer, intent(in) :: levr, ictm, isol, ico2, iaer, & - ntcw, num_p3d, ntoz, iovr, isubc_sw, isubc_lw, & - icliq_sw, iflip, me + ntcw, ntoz, iovr, isubc_sw, isubc_lw, & + me logical, intent(in) :: & - crick_proof, ccnorm, norad_precip, lalw1bd + lalw1bd integer, intent(in), dimension(:) :: & idate character(len=26),intent(in) :: aeros_file, solar_file, co2usr_file, co2cyc_file ! Outputs - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(out) :: iaermdl, iaerflg + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(inout) :: ipsd0 + integer, intent(out) :: iaermdl, iaerflg ! Initialize the CCPP error handling variables errmsg = '' @@ -94,6 +96,11 @@ subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires, errflg = 1 return endif + + ! Assign initial permutation seed for mcica cloud-radiation + if ( isubc_sw>0 .or. isubc_lw>0 ) then + ipsd0 = 17*idate(1)+43*idate(2)+37*idate(3)+23*idate(4) + endif if ( me == 0 ) then print *,' In rad_initialize (GFS_rrtmgp_setup_init), before calling radinit' @@ -102,18 +109,17 @@ subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires, ' ictm = ',ictm, & ' isol = ',isol, & ' ico2 = ',ico2, & - ' iaer = ',iaer, & - ' ntcw = ',ntcw - print *,' np3d = ',num_p3d, & + ' iaermdl = ',iaermdl, & + ' iaerflg = ',iaerflg, & + ' ntcw = ',ntcw, & ' ntoz = ',ntoz, & ' iovr = ',iovr, & ' isubc_sw = ',isubc_sw, & ' isubc_lw = ',isubc_lw, & - ' icliq_sw = ',icliq_sw, & - ' iflip = ',iflip, & + ' ipsd0 = ',ipsd0, & ' me = ',me endif - + loz1st = (ntoz == 0) ! first-time clim ozone data read flag month0 = 0 iyear0 = 0 @@ -123,7 +129,7 @@ subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires, call sol_init ( me, isol, solar_file, con_solr_2008, con_solr_2002, con_pi ) call aer_init ( levr, me, iaermdl, iaerflg, lalw1bd, aeros_file, con_pi, con_t0c, & con_c, con_boltz, con_plnk, errflg, errmsg) - call gas_init ( me, co2usr_file, co2cyc_file, ico2, ntoz, ictm, con_pi, errflg, errmsg ) + call gas_init ( me, co2usr_file, co2cyc_file, ico2, ictm, ntoz, con_pi, errflg, errmsg ) if ( me == 0 ) then print *,' return from rad_initialize (GFS_rrtmgp_setup_init) - after calling radinit' diff --git a/physics/GFS_rrtmgp_setup.meta b/physics/GFS_rrtmgp_setup.meta index 8a9fd4ef6..d47aadb93 100644 --- a/physics/GFS_rrtmgp_setup.meta +++ b/physics/GFS_rrtmgp_setup.meta @@ -2,7 +2,7 @@ name = GFS_rrtmgp_setup type = scheme dependencies = iounitdef.f,machine.F,module_bfmicrophysics.f,radiation_aerosols.f,radiation_astronomy.f - dependencies = module_mp_thompson.F90,radiation_clouds.f,radiation_gases.f + dependencies = module_mp_thompson.F90,radiation_gases.f ######################################################################## [ccpp-arg-table] @@ -146,13 +146,6 @@ dimensions = () type = integer intent = in -[num_p3d] - standard_name = number_of_microphysics_variables_in_xyz_dimensioned_restart_array - long_name = number of 3D arrays needed for microphysics - units = count - dimensions = () - type = integer - intent = in [ntoz] standard_name = index_of_ozone_mixing_ratio_in_tracer_concentration_array long_name = tracer index for ozone mixing ratio @@ -181,34 +174,6 @@ dimensions = () type = integer intent = in -[icliq_sw] - standard_name = control_for_shortwave_radiation_liquid_clouds - long_name = sw optical property for liquid clouds - units = flag - dimensions = () - type = integer - intent = in -[crick_proof] - standard_name = flag_for_CRICK_proof_cloud_water - long_name = flag for CRICK-Proof cloud water - units = flag - dimensions = () - type = logical - intent = in -[ccnorm] - standard_name = flag_for_in_cloud_condensate - long_name = flag for cloud condensate normalized by cloud cover - units = flag - dimensions = () - type = logical - intent = in -[norad_precip] - standard_name = flag_for_turning_off_precipitation_radiative_effect - long_name = radiation precip flag for Ferrier/Moorthi - units = flag - dimensions = () - type = logical - intent = in [lalw1bd] standard_name = flag_for_longwave_aerosol_band_properties long_name = flag for band or multiband longwave aerosol properties @@ -223,13 +188,6 @@ dimensions = (4) type = integer intent = in -[iflip] - standard_name = control_for_vertical_index_direction - long_name = flag for vertical index direction control - units = flag - dimensions = () - type = integer - intent = in [me] standard_name = mpi_rank long_name = current MPI-rank @@ -301,6 +259,13 @@ type = character kind = len=26 intent = in +[ipsd0] + standard_name = initial_seed_for_mcica + long_name = initial permutaion seed for mcica radiation + units = none + dimensions = () + type = integer + intent = inout [iaermdl] standard_name = flag_for_aerosol_radiation_scheme long_name = flag for aerosol scheme to use in radiation diff --git a/physics/myjsfc_wrapper.F90 b/physics/myjsfc_wrapper.F90 index 81cb36765..cebd2a9f1 100644 --- a/physics/myjsfc_wrapper.F90 +++ b/physics/myjsfc_wrapper.F90 @@ -334,7 +334,7 @@ SUBROUTINE myjsfc_wrapper_run( & & ,phy_f2d_myj(1:im,13) & & ,1,im,1,1,1,levs & & ,1,im,1,1,1,levs & - & ,1,im,1,1,1,levs) + & ,1,im,1,1,1,levs, errmsg, errflg) do i = 1, im if(flag_iter(i))then From 51b9243107a4c886e35b270768cd501f602d4534 Mon Sep 17 00:00:00 2001 From: dustinswales Date: Thu, 22 Sep 2022 10:52:18 -0600 Subject: [PATCH 044/380] Update CODEOWNERS file --- CODEOWNERS | 170 ++++++++++++++++++++++++++--------------------------- 1 file changed, 85 insertions(+), 85 deletions(-) diff --git a/CODEOWNERS b/CODEOWNERS index cf7a886aa..a8cbf59ca 100644 --- a/CODEOWNERS +++ b/CODEOWNERS @@ -4,127 +4,127 @@ # Default codeowners for files that don't have specific owners: -* @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +* @grantfirl @ChunxiZhang-NOAA @dustinswales @mzhangw # The following lines are from the CCPP Primary Schemes Points of Contact # https://docs.google.com/spreadsheets/d/14y0Th_sSpCqlssEMNfSZ_Ni9wrpPqfpPY0kRG7jCZB8/edit#gid=0 # (Internal NOAA document.) -smoke/* @haiqinli @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +smoke/* @haiqinli @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/cs_conv_aw_adj.* @AnningCheng-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/cs_conv.* @AnningCheng-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/cu_gf* @hannahcbarnes @haiqinli @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/sascnvn.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/cu_ntiedtke* @ChunxiZhang-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/rascnv.* @SMoorthi-emc @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/cs_conv_aw_adj.* @AnningCheng-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/cs_conv.* @AnningCheng-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/cu_gf* @hannahcbarnes @haiqinli @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/sascnvn.* @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/cu_ntiedtke* @ChunxiZhang-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/rascnv.* @SMoorthi-emc @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/samfdeepcnv.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/samfshalcnv.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/samfaerosols.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/samfdeepcnv.* @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/samfshalcnv.* @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/samfaerosols.* @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/shalcnv.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/unified_ugwp* @mdtoyNOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/ugwp_driver_v0.F @mdtoyNOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/cires_ugwp* @mdtoyNOAA @ValeryYudin-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/drag_suite.* @mdtoyNOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/shalcnv.* @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/unified_ugwp* @mdtoyNOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/ugwp_driver_v0.F @mdtoyNOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/cires_ugwp* @mdtoyNOAA @ValeryYudin-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/drag_suite.* @mdtoyNOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/gwdc.* @Songyou184 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/gwdps.* @Songyou184 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/gwdc.* @Songyou184 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/gwdps.* @Songyou184 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/gfdl_fv_sat_adj.* @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/gfdl_cloud_microphys.* @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/gfdl_fv_sat_adj.* @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/gfdl_cloud_microphys.* @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/module_gfdl_cloud_microphys.* @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/multi_gases.F90 @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/module_gfdl_cloud_microphys.* @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/multi_gases.F90 @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/mp_fer_hires.* @ericaligo-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/module_MP_FER_HIRES.* @ericaligo-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/mp_fer_hires.* @ericaligo-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/module_MP_FER_HIRES.* @ericaligo-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/module_mp_thompson* @gthompsnWRF @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/module_mp_radar.* @gthompsnWRF @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/mp_thompson* @gthompsnWRF @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/module_mp_thompson* @gthompsnWRF @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/module_mp_radar.* @gthompsnWRF @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/mp_thompson* @gthompsnWRF @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/precpd.* @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/gscond.* @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/precpd.* @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/gscond.* @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/m_micro* @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/aer_cloud.F @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/aerclm_def.F @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/cldmacro.F @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/cldwat2m_micro.F @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/wv_saturation.F @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/micro_mg* @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/m_micro* @AnningCheng-NOAA @andrewgettelman @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/aer_cloud.F @AnningCheng-NOAA @andrewgettelman @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/aerclm_def.F @AnningCheng-NOAA @andrewgettelman @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/cldmacro.F @AnningCheng-NOAA @andrewgettelman @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/cldwat2m_micro.F @AnningCheng-NOAA @andrewgettelman @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/wv_saturation.F @AnningCheng-NOAA @andrewgettelman @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/micro_mg* @AnningCheng-NOAA @andrewgettelman @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/ozphys* @AlexBelochitski-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/ozphys* @AlexBelochitski-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/satmedmfvdif.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/satmedmfvdifq.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/mfpbl.f @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/mfscu.f @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/mfpbltq.f @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/mfscuq.f @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/satmedmfvdif.* @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/satmedmfvdifq.* @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/mfpbl.f @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/mfscu.f @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/mfpbltq.f @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/mfscuq.f @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/shinhongvdif.* @ChunxiZhang-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/ysuvdif.* @ChunxiZhang-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich +physics/shinhongvdif.* @ChunxiZhang-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/ysuvdif.* @ChunxiZhang-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/tridi.f @JongilHan66 @ChunxiZhang-NOAA @JongilHan66 @WeiguoWang-NOAA @AlexBelochitski-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich +physics/tridi.f @JongilHan66 @ChunxiZhang-NOAA @JongilHan66 @WeiguoWang-NOAA @AlexBelochitski-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/moninedmf.* @JongilHan66 @WeiguoWang-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/moninedmf.* @JongilHan66 @WeiguoWang-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/module_BL_MYJPBL.* @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/module_MYJPBL_wrapper.* @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/module_BL_MYJPBL.* @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/module_MYJPBL_wrapper.* @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/module_bl_mynn.* @joeolson42 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/module_MYNNPBL_wrapper.* @joeolson42 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/module_bl_mynn.* @joeolson42 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/module_MYNNPBL_wrapper.* @joeolson42 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/gcm_shoc.* @AlexBelochitski-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/moninshoc.* @AlexBelochitski-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/gcm_shoc.* @AlexBelochitski-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/moninshoc.* @AlexBelochitski-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/rte-rrtmgp @dustinswales @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/radiation_tools.* @dustinswales @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/rrtmgp_lw_rte.met* @dustinswales @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/rrtmgp_sw_rte.met* @dustinswales @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/rte-rrtmgp @dustinswales @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/radiation_tools.* @dustinswales @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/rrtmgp_lw_rte.* @dustinswales @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/rrtmgp_sw_rte.* @dustinswales @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/radlw_main.* @mjiacono @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/HWRF_mcica_random_numbers.F90 @mjiacono @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/HWRF_mersenne_twister.F90 @mjiacono @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/radlw_datatb.f @mjiacono @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/radsw_datatb.* @mjiacono @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/radsw_main.* @mjiacono @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/radlw_main.* @mjiacono @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/HWRF_mcica_random_numbers.F90 @mjiacono @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/HWRF_mersenne_twister.F90 @mjiacono @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/radlw_datatb.f @mjiacono @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/radsw_datatb.* @mjiacono @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/radsw_main.* @mjiacono @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/radsw_param.f @dustinswales @Qingfu-Liu @mjiacono @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/radsw_param.f @dustinswales @Qingfu-Liu @mjiacono @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/rayleigh_damp.* @yangfanglin @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/GFS_stochastics.* @pjpegion @lisa-bengtsson @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/flake* @YihuaWu-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/rayleigh_damp.* @yangfanglin @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_stochastics.* @pjpegion @lisa-bengtsson @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/flake* @YihuaWu-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/sfc_drv.* @HelinWei-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/sflx.f @HelinWei-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/surface_perturbation.* @HelinWei-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/sfc_drv.* @HelinWei-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/sflx.f @HelinWei-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/surface_perturbation.* @HelinWei-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/*noahmp* @barlage @cenlinhe @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/*noahmp* @barlage @cenlinhe @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/set_soilveg.* @HelinWei-NOAA @barlage @cenlinhe @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/namelist_soilveg.* @HelinWei-NOAA @barlage @cenlinhe @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/set_soilveg.* @HelinWei-NOAA @barlage @cenlinhe @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/namelist_soilveg.* @HelinWei-NOAA @barlage @cenlinhe @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/namelist_soilveg_ruc.* @tanyasmirnova @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/set_soilveg_ruc.* @tanyasmirnova @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/module_sf_ruclsm.* @tanyasmirnova @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/module_soil_pre.* @tanyasmirnova @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/sfc_drv_ruc.* @tanyasmirnova @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/namelist_soilveg_ruc.* @tanyasmirnova @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/set_soilveg_ruc.* @tanyasmirnova @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/module_sf_ruclsm.* @tanyasmirnova @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/module_soil_pre.* @tanyasmirnova @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/sfc_drv_ruc.* @tanyasmirnova @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/date_def.f @XuLi-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/*nst* @XuLi-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/date_def.f @XuLi-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/*nst* @XuLi-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/sfc_ocean.* @HelinWei-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/sfc_diff.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/sfc_ocean.* @HelinWei-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/sfc_diff.* @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/h2ophys.* @AlexBelochitski-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/h2ophys.* @AlexBelochitski-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/sfc_sice.* @wd20xw @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/sfc_cice.* @wd20xw @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/sfc_sice.* @wd20xw @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/sfc_cice.* @wd20xw @grantfirl @ChunxiZhang-NOAA @dustinswales ######################################################################## From f5ca603e55d705b0fdcddfafb096da0d643f8a44 Mon Sep 17 00:00:00 2001 From: dustinswales Date: Thu, 22 Sep 2022 14:34:52 -0600 Subject: [PATCH 045/380] Update CODEOWNERS --- CODEOWNERS | 262 ++++++++++++++++++++++++++++++++++------------------- 1 file changed, 167 insertions(+), 95 deletions(-) diff --git a/CODEOWNERS b/CODEOWNERS index a8cbf59ca..55373ae36 100644 --- a/CODEOWNERS +++ b/CODEOWNERS @@ -12,119 +12,191 @@ # (Internal NOAA document.) smoke/* @haiqinli @grantfirl @ChunxiZhang-NOAA @dustinswales - +physics/aerclm_def.F @AnningCheng-NOAA @andrewgettelman @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/aer_cloud.F @AnningCheng-NOAA @andrewgettelman @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/aerinterp.F90 @AnningCheng-NOAA @andrewgettelman @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/bl_mynn_common.f90 @joeolson42 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/calpreciptype.f90 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/cires_orowam2017.f @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/cires_tauamf_data.F90 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/cires_ugwp* @mdtoyNOAA @ValeryYudin-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/cldmacro.F @AnningCheng-NOAA @andrewgettelman @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/cldwat2m_micro.F @AnningCheng-NOAA @andrewgettelman @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/cnvc90.* @grantfirl @ChunxiZhang-NOAA @dustinswales physics/cs_conv_aw_adj.* @AnningCheng-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales physics/cs_conv.* @AnningCheng-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales physics/cu_gf* @hannahcbarnes @haiqinli @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/sascnvn.* @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales physics/cu_ntiedtke* @ChunxiZhang-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/rascnv.* @SMoorthi-emc @grantfirl @ChunxiZhang-NOAA @dustinswales - -physics/samfdeepcnv.* @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/samfshalcnv.* @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/samfaerosols.* @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales - -physics/shalcnv.* @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/unified_ugwp* @mdtoyNOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/ugwp_driver_v0.F @mdtoyNOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/cires_ugwp* @mdtoyNOAA @ValeryYudin-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/date_def.f @XuLi-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/dcyc2t3.* @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales physics/drag_suite.* @mdtoyNOAA @grantfirl @ChunxiZhang-NOAA @dustinswales - +physics/flake* @YihuaWu-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/funcphys.f90 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/fv_sat_adj.* @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/gcycle.F90 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/get_phi_fv3.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/get_prs_fv3.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/gfdl_cloud_microphys.* @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFDL_parse_tracers.F90 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/gfdl_sfc_layer.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_cloud_diagnostics.* @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_DCNV_generic_post.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_DCNV_generic_pre.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_debug.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_GWD_generic_post.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_GWD_generic_pre.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_MP_generic_post.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_MP_generic_pre.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_PBL_generic_common.F90 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_PBL_generic_post.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_PBL_generic_pre.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_phys_time_vary.fv3.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_phys_time_vary.scm.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/gfs_phy_tracer_config.F @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_radiation_surface.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_rad_time_vary.fv3.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_rad_time_vary.scm.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_rrtmgp_cloud_mp.* @dustinswales @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_rrtmgp_cloud_overlap.* @dustinswales @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_rrtmgp_lw_post.* @dustinswales @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_rrtmg_post.* @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_rrtmgp_pre.* @dustinswales @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_rrtmg_pre.* @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_rrtmgp_setup.* @dustinswales @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_rrtmgp_sw_post.* @dustinswales @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_rrtmgp_sw_pre.* @dustinswales @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_rrtmg_setup.* @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_SCNV_generic_post.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_SCNV_generic_pre.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_stochastics.* @pjpegion @lisa-bengtsson @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_suite_interstitial_1.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_suite_interstitial_2.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_suite_interstitial_3.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_suite_interstitial_4.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_suite_interstitial_5.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_suite_interstitial_phys_reset.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_suite_interstitial_rad_reset.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_suite_stateout_reset.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_suite_stateout_update.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_surface_composites_inter.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_surface_composites_post.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_surface_composites_pre.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_surface_generic_post.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_surface_generic_pre.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_surface_loop_control_part1.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_surface_loop_control_part2.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_time_vary_pre.fv3.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_time_vary_pre.scm.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/gocart_tracer_config_stub.f @grantfirl @ChunxiZhang-NOAA @dustinswales physics/gwdc.* @Songyou184 @grantfirl @ChunxiZhang-NOAA @dustinswales physics/gwdps.* @Songyou184 @grantfirl @ChunxiZhang-NOAA @dustinswales - -physics/gfdl_fv_sat_adj.* @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/gfdl_cloud_microphys.* @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales - -physics/module_gfdl_cloud_microphys.* @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/multi_gases.F90 @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales - -physics/mp_fer_hires.* @ericaligo-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/module_MP_FER_HIRES.* @ericaligo-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales - -physics/module_mp_thompson* @gthompsnWRF @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/module_mp_radar.* @gthompsnWRF @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/mp_thompson* @gthompsnWRF @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales - -physics/precpd.* @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/gscond.* @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales - -physics/m_micro* @AnningCheng-NOAA @andrewgettelman @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/aer_cloud.F @AnningCheng-NOAA @andrewgettelman @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/aerclm_def.F @AnningCheng-NOAA @andrewgettelman @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/cldmacro.F @AnningCheng-NOAA @andrewgettelman @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/cldwat2m_micro.F @AnningCheng-NOAA @andrewgettelman @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/wv_saturation.F @AnningCheng-NOAA @andrewgettelman @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/micro_mg* @AnningCheng-NOAA @andrewgettelman @grantfirl @ChunxiZhang-NOAA @dustinswales - -physics/ozphys* @AlexBelochitski-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales - -physics/satmedmfvdif.* @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/satmedmfvdifq.* @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/h2o_def.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/h2ointerp.f90 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/h2ophys.* @AlexBelochitski-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/hedmf.* @JongilHan66 @WeiguoWang-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/iccn_def.F @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/iccninterp.F90 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/iounitdef.f @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/lsm_noah.* @HelinWei-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/lsm_ruc.* @tanyasmirnova @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/machine.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/maximum_hourly_diagnostics.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/mersenne_twister.f @grantfirl @ChunxiZhang-NOAA @dustinswales physics/mfpbl.f @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/mfscu.f @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/mfpblt.f @grantfirl @ChunxiZhang-NOAA @dustinswales physics/mfpbltq.f @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/mfscu.f @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales physics/mfscuq.f @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales - -physics/shinhongvdif.* @ChunxiZhang-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/ysuvdif.* @ChunxiZhang-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales - -physics/tridi.f @JongilHan66 @ChunxiZhang-NOAA @JongilHan66 @WeiguoWang-NOAA @AlexBelochitski-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales - -physics/moninedmf.* @JongilHan66 @WeiguoWang-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales - +physics/micro_mg* @AnningCheng-NOAA @andrewgettelman @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/m_micro* @AnningCheng-NOAA @andrewgettelman @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/module_bfmicrophysics.f @grantfirl @ChunxiZhang-NOAA @dustinswales physics/module_BL_MYJPBL.* @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/module_MYJPBL_wrapper.* @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales - physics/module_bl_mynn.* @joeolson42 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/module_MYNNPBL_wrapper.* @joeolson42 @grantfirl @ChunxiZhang-NOAA @dustinswales - -physics/gcm_shoc.* @AlexBelochitski-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/module_gfdl_cloud_microphys.* @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/module_MP_FER_HIRES.* @ericaligo-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/module_mp_nssl_2mom.F90 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/module_mp_radar.* @gthompsnWRF @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/module_mp_thompson* @gthompsnWRF @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/module_nst* @XuLi-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/module_sf_exchcoef.f90 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/module_SF_JSFC.F90 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/module_sf_mynn.F90 @joeolson42 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/module_sf_ruclsm.* @tanyasmirnova @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/module_soil_pre.* @tanyasmirnova @grantfirl @ChunxiZhang-NOAA @dustinswales physics/moninshoc.* @AlexBelochitski-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales - -physics/rte-rrtmgp @dustinswales @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/radiation_tools.* @dustinswales @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/rrtmgp_lw_rte.* @dustinswales @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/rrtmgp_sw_rte.* @dustinswales @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales - -physics/radlw_main.* @mjiacono @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/HWRF_mcica_random_numbers.F90 @mjiacono @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/HWRF_mersenne_twister.F90 @mjiacono @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/radlw_datatb.f @mjiacono @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/radsw_datatb.* @mjiacono @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/radsw_main.* @mjiacono @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales - -physics/radsw_param.f @dustinswales @Qingfu-Liu @mjiacono @grantfirl @ChunxiZhang-NOAA @dustinswales - -physics/rayleigh_damp.* @yangfanglin @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_stochastics.* @pjpegion @lisa-bengtsson @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/flake* @YihuaWu-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales - -physics/sfc_drv.* @HelinWei-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/sflx.f @HelinWei-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/surface_perturbation.* @HelinWei-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales - -physics/*noahmp* @barlage @cenlinhe @grantfirl @ChunxiZhang-NOAA @dustinswales - -physics/set_soilveg.* @HelinWei-NOAA @barlage @cenlinhe @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/mp_fer_hires.* @ericaligo-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/mp_nssl.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/mp_thompson* @gthompsnWRF @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/multi_gases.F90 @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/myjpbl_wrapper.* @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/myjsfc_wrapper.* @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/mynnedmf_wrapper.* @joeolson42 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/mynnsfc_wrapper.* @joeolson42 @grantfirl @ChunxiZhang-NOAA @dustinswales physics/namelist_soilveg.* @HelinWei-NOAA @barlage @cenlinhe @grantfirl @ChunxiZhang-NOAA @dustinswales - physics/namelist_soilveg_ruc.* @tanyasmirnova @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/*noahmp* @barlage @cenlinhe @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/ozinterp.f90 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/ozne_def.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/ozphys* @AlexBelochitski-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/physcons.F90 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/physparam.f @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/phys_tend.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/progsigma_calc.f90 @lisa-bengtsson @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/radcons.f90 @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/radiation_aerosols.f @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/radiation_astronomy.f @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/radiation_cloud_overlap.F90 @dustinswales @mjiacono @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/radiation_clouds.f @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/radiation_gases.f @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/radiation_surface.* @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/radiation_tools.F90 @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/radlw_* @mjiacono @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/radsw_* @mjiacono @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/rad_sw_pre.* @dustinswales @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/rascnv.* @SMoorthi-emc @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/rayleigh_damp.* @yangfanglin @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/rrtmg_lw_cloud_optics.F90 @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/rrtmg_lw_post.* @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/rrtmg_lw_pre.* @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/rrtmgp_aerosol_optics.* @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/rrtmgp_lw_* @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/rrtmgp_sw_* @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/rrtmg_sw_cloud_optics.F90 @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/rrtmg_sw_post.* @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/rte-rrtmgp @RobertPincus @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/samfdeepcnv.* @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/samfshalcnv.* @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/samfaerosols.* @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/sascnvn.* @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/satmedmfvdif.* @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/satmedmfvdifq.* @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/scm_sfc_flux_spec.* @grantfirl @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/set_soilveg.* @HelinWei-NOAA @barlage @cenlinhe @grantfirl @ChunxiZhang-NOAA @dustinswales physics/set_soilveg_ruc.* @tanyasmirnova @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/module_sf_ruclsm.* @tanyasmirnova @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/module_soil_pre.* @tanyasmirnova @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/sfc_drv_ruc.* @tanyasmirnova @grantfirl @ChunxiZhang-NOAA @dustinswales - -physics/date_def.f @XuLi-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/*nst* @XuLi-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales - -physics/sfc_ocean.* @HelinWei-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/sfc_cice.* @wd20xw @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/sfc_diag.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/sfc_diag_post.* @grantfirl @ChunxiZhang-NOAA @dustinswales physics/sfc_diff.* @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales - -physics/h2ophys.* @AlexBelochitski-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales - +physics/sfc_nst* @XuLi-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/sfc_ocean.* @HelinWei-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales physics/sfc_sice.* @wd20xw @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/sfc_cice.* @wd20xw @grantfirl @ChunxiZhang-NOAA @dustinswales +#physics/sfcsub.F @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/sflx.f @HelinWei-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/sgscloud_radpost.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/sgscloud_radpre.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/shalcnv.* @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/shinhongvdif.* @ChunxiZhang-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/shoc.* @AlexBelochitski-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/surface_perturbation.* @HelinWei-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/tridi.f @JongilHan66 @ChunxiZhang-NOAA @WeiguoWang-NOAA @AlexBelochitski-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/ugwp_driver_v0.F @mdtoyNOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/ugwpv1_gsldrag.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/ugwpv1_gsldrag_post.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/unified_ugwp* @mdtoyNOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/wv_saturation.F @AnningCheng-NOAA @andrewgettelman @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/ysuvdif.* @ChunxiZhang-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/zhaocarr_gscond.* @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/zhaocarr_precpd.* @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales ######################################################################## From d35be37ed9441d449efeb3dae2c536ceb1cb4cf9 Mon Sep 17 00:00:00 2001 From: dustinswales Date: Fri, 23 Sep 2022 08:49:05 -0600 Subject: [PATCH 046/380] Some modifications for rrtmgp physics blocking to work. --- physics/rrtmgp_lw_main.F90 | 77 ++++++++++++++++-------------- physics/rrtmgp_sw_main.F90 | 96 +++++++++++++++++++++++--------------- 2 files changed, 101 insertions(+), 72 deletions(-) diff --git a/physics/rrtmgp_lw_main.F90 b/physics/rrtmgp_lw_main.F90 index ab82dc56a..0ea0c3f7c 100644 --- a/physics/rrtmgp_lw_main.F90 +++ b/physics/rrtmgp_lw_main.F90 @@ -195,19 +195,17 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, lw_optical_props_precipByBand type(ty_source_func_lw) :: sources type(ty_fluxes_byband) :: flux_allsky, flux_clrsky - integer :: iCol, iLay, iGas, iBand, iCol2, ix, iblck - integer, dimension(rrtmgp_phys_blksz) :: ipseed_lw + integer :: iCol, iLay, iGas, iBand, iCol2, ix, iblck, blksz + type(random_stat) :: rng_stat - real(kind_phys), dimension(rrtmgp_phys_blksz) :: zcf0, zcf1 - logical, dimension(rrtmgp_phys_blksz,nLay,lw_gas_props%get_ngpt()) :: maskMCICA - real(kind_phys), dimension(rrtmgp_phys_blksz) :: tau_rain, tau_snow real(kind_phys), dimension(lw_gas_props%get_ngpt()) :: rng1D - real(kind_phys), dimension(lw_gas_props%get_ngpt(),nLay,rrtmgp_phys_blksz) :: rng3D,rng3D2 - real(kind_phys), dimension(lw_gas_props%get_ngpt()*nLay) :: rng2D - real(kind_phys), dimension(rrtmgp_phys_blksz,nLay+1,lw_gas_props%get_nband()),target :: & - fluxLW_up_allsky, fluxLW_up_clrsky, fluxLW_dn_allsky, fluxLW_dn_clrsky - real(kind_phys), dimension(rrtmgp_phys_blksz,lw_gas_props%get_ngpt()) :: lw_Ds - real(kind_phys), dimension(lw_gas_props%get_nband(),rrtmgp_phys_blksz) :: sfc_emiss_byband + real(kind_phys) :: tau_rain, tau_snow + integer, dimension(:), allocatable :: ipseed_lw + real(kind_phys), dimension(:), allocatable :: zcf0, zcf1, rng2D + real(kind_phys), dimension(:,:), allocatable :: lw_Ds, sfc_emiss_byband + real(kind_phys), dimension(:,:,:), allocatable :: rng3D,rng3D2 + logical, dimension(:,:,:), allocatable :: maskMCICA + real(kind_phys), dimension(:,:,:), allocatable, target :: fluxLW_up_allsky, fluxLW_up_clrsky, fluxLW_dn_allsky, fluxLW_dn_clrsky ! Initialize CCPP error handling variables errmsg = '' @@ -220,30 +218,43 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, ! Allocate/initialize RRTMGP DDT's ! ! ###################################################################################### + blksz = minval((/nCol,rrtmgp_phys_blksz/)) + + allocate(ipseed_lw(blksz), zcf0(blksz), zcf1(blksz), & + maskMCICA(blksz,nLay,lw_gas_props%get_ngpt()), & + rng3D(lw_gas_props%get_ngpt(),nLay,blksz), & + rng3D2(lw_gas_props%get_ngpt(),nLay,blksz), & + rng2D(lw_gas_props%get_ngpt()*nLay), & + fluxLW_up_allsky(blksz,nLay+1,lw_gas_props%get_nband()), & + fluxLW_up_clrsky(blksz,nLay+1,lw_gas_props%get_nband()), & + fluxLW_dn_allsky(blksz,nLay+1,lw_gas_props%get_nband()), & + fluxLW_dn_clrsky(blksz,nLay+1,lw_gas_props%get_nband()), & + lw_Ds(blksz,lw_gas_props%get_ngpt()), & + sfc_emiss_byband(lw_gas_props%get_nband(),blksz)) ! ty_gas_concs call check_error_msg('rrtmgp_lw_main_gas_concs_init',gas_concs%init(active_gases_array)) ! ty_optical_props call check_error_msg('rrtmgp_lw_main_gas_optics_init',& - lw_optical_props_clrsky%alloc_1scl(rrtmgp_phys_blksz, nLay, lw_gas_props)) + lw_optical_props_clrsky%alloc_1scl(blksz, nLay, lw_gas_props)) call check_error_msg('rrtmgp_lw_main_sources_init',& - sources%alloc(rrtmgp_phys_blksz, nLay, lw_gas_props)) + sources%alloc(blksz, nLay, lw_gas_props)) call check_error_msg('rrtmgp_lw_main_cloud_optics_init',& - lw_optical_props_cloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) + lw_optical_props_cloudsByBand%alloc_2str(blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) call check_error_msg('rrtmgp_lw_main_precip_optics_init',& - lw_optical_props_precipByBand%alloc_2str(rrtmgp_phys_blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) + lw_optical_props_precipByBand%alloc_2str(blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) call check_error_msg('rrtmgp_lw_mian_cloud_sampling_init', & - lw_optical_props_clouds%alloc_2str(rrtmgp_phys_blksz, nLay, lw_gas_props)) + lw_optical_props_clouds%alloc_2str(blksz, nLay, lw_gas_props)) call check_error_msg('rrtmgp_lw_main_aerosol_optics_init',& - lw_optical_props_aerosol_local%alloc_1scl(rrtmgp_phys_blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) + lw_optical_props_aerosol_local%alloc_1scl(blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) if (doGP_sgs_cnv) then call check_error_msg('rrtmgp_lw_main_cnv_cloud_optics_init',& - lw_optical_props_cnvcloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) + lw_optical_props_cnvcloudsByBand%alloc_2str(blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) endif if (doGP_sgs_pbl) then call check_error_msg('rrtmgp_lw_main_pbl_cloud_optics_init',& - lw_optical_props_pblcloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) + lw_optical_props_pblcloudsByBand%alloc_2str(blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) endif ! ###################################################################################### @@ -251,13 +262,13 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, ! Loop over all columns... ! ! ###################################################################################### - do iCol=1,nCol,rrtmgp_phys_blksz - iCol2 = iCol + rrtmgp_phys_blksz - 1 + do iCol=1,nCol,blksz + iCol2 = iCol + blksz - 1 ! Create clear/cloudy indicator zcf0(:) = 1._kind_phys zcf1(:) = 1._kind_phys - do iblck = 1, rrtmgp_phys_blksz + do iblck = 1, blksz do iLay=1,nLay zcf0(iblck) = min(zcf0(iblck), 1._kind_phys - cld_frac(iCol+iblck-1,iLay)) enddo @@ -323,7 +334,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, ! ! ################################################################################### ! Assign same emissivity to all band - do iblck=1,rrtmgp_phys_blksz + do iblck=1,blksz if (semis(iCol+iblck-1) > eps .and. semis(iCol+iblck-1) <= 1._kind_phys) then do iBand=1,lw_gas_props%get_nband() sfc_emiss_byband(iBand,iblck) = semis(iCol+iblck-1) @@ -398,22 +409,20 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, ! Cloud precipitation optics: rain and snow(+groupel) ! ! ################################################################################### - tau_rain(:) = 0._kind_phys - tau_snow(:) = 0._kind_phys - do ix=1,rrtmgp_phys_blksz + do ix=1,blksz do iLay=1,nLay if (cld_frac(iCol+ix-1,iLay) .gt. eps) then ! Rain optical-depth (No band dependence) - tau_rain(ix) = absrain*cld_rwp(iCol+ix-1,iLay) + tau_rain = absrain*cld_rwp(iCol+ix-1,iLay) ! Snow (+groupel) optical-depth (No band dependence) if (cld_swp(iCol+ix-1,iLay) .gt. 0. .and. cld_resnow(iCol+ix-1,iLay) .gt. 10._kind_phys) then - tau_snow(ix) = abssnow0*1.05756*cld_swp(iCol+ix-1,iLay)/cld_resnow(iCol+ix-1,iLay) + tau_snow = abssnow0*1.05756*cld_swp(iCol+ix-1,iLay)/cld_resnow(iCol+ix-1,iLay) else - tau_snow(ix) = 0.0 + tau_snow = 0.0 endif do iBand=1,lw_gas_props%get_nband() - lw_optical_props_precipByBand%tau(ix,iLay,iBand) = tau_rain(ix) + tau_snow(ix) + lw_optical_props_precipByBand%tau(ix,iLay,iBand) = tau_rain + tau_snow enddo endif enddo @@ -431,17 +440,17 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, if (any(zcf1 .gt. eps)) then ! Change random number seed value for each radiation invocation (isubc_lw =1 or 2). if(isubc_lw == 1) then ! advance prescribed permutation seed - do ix=1,rrtmgp_phys_blksz + do ix=1,blksz ipseed_lw(ix) = lw_gas_props%get_ngpt() + iCol + ix - 1 enddo elseif (isubc_lw == 2) then ! use input array of permutaion seeds - do ix=1,rrtmgp_phys_blksz + do ix=1,blksz ipseed_lw(ix) = icseed_lw(iCol+ix-1) enddo endif ! Call RNG - do ix=1,rrtmgp_phys_blksz + do ix=1,blksz call random_setseed(ipseed_lw(ix),rng_stat) ! Use same rng for each layer if (iovr == iovr_max) then @@ -464,7 +473,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, endif ! Exponential decorrelation length overlap if (iovr == iovr_dcorr) then - do ix=1,rrtmgp_phys_blksz + do ix=1,blksz ! Generate second RNG call random_setseed(ipseed_lw(ix),rng_stat) call random_number(rng2D,rng_stat) diff --git a/physics/rrtmgp_sw_main.F90 b/physics/rrtmgp_sw_main.F90 index 325607daa..ea2f36273 100644 --- a/physics/rrtmgp_sw_main.F90 +++ b/physics/rrtmgp_sw_main.F90 @@ -110,8 +110,8 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ iovr_dcorr, & ! Flag for decorrelation-length cloud overlap method iovr_exp, & ! Flag for exponential cloud overlap method iovr_exprand, & ! Flag for exponential-random cloud overlap method - isubc_sw, & ! - iSFC + isubc_sw, & ! Flag for sw clouds sub-grid approximation + iSFC ! Surface layer index integer,intent(in),dimension(:) :: & idx, & ! Index array for daytime points icseed_sw ! Seed for random number generation for shortwave radiation @@ -150,7 +150,7 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ cld_pbl_reliq, & ! Effective radius for PBL liquid cloud-particles cld_pbl_iwp, & ! Water path for PBL ice cloud-particles cld_pbl_reice, & ! Effective radius for PBL ice cloud-particles - cloud_overlap_param ! + cloud_overlap_param ! Cloud overlap parameter real(kind_phys), dimension(:,:,:), intent(in) :: & aersw_tau, & ! Aerosol optical depth aersw_ssa, & ! Aerosol single scattering albedo @@ -182,7 +182,6 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ ! visdf - downward uv+vis diffused flux (W/m2) ! Local variables - type(cmpfsw_type), dimension(rrtmgp_phys_blksz) :: scmpsw_clrsky, scmpsw_allsky type(ty_gas_concs) :: gas_concs type(ty_optical_props_2str) :: sw_optical_props_accum, sw_optical_props_aerosol_local, & sw_optical_props_cloudsByBand, sw_optical_props_cnvcloudsByBand, & @@ -191,24 +190,24 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ type(ty_fluxes_byband) :: flux_allsky, flux_clrsky real(kind_phys) :: tau_rain, tau_snow, ssa_rain, ssa_snow, asy_rain, asy_snow, & tau_prec, asy_prec, ssa_prec, asyw, ssaw, za1, za2, flux_dir, flux_dif - real(kind_phys), dimension(rrtmgp_phys_blksz) :: zcf0, zcf1 real(kind_phys), dimension(sw_gas_props%get_ngpt()) :: rng1D - real(kind_phys), dimension(sw_gas_props%get_ngpt(),nLay,rrtmgp_phys_blksz) :: rng3D,rng3D2 real(kind_phys), dimension(sw_gas_props%get_ngpt()*nLay) :: rng2D - logical, dimension(rrtmgp_phys_blksz,nLay,sw_gas_props%get_ngpt()) :: maskMCICA - real(kind_phys), dimension(sw_gas_props%get_nband(),rrtmgp_phys_blksz) :: & - sfc_alb_dir, sfc_alb_dif - real(kind_phys), dimension(rrtmgp_phys_blksz,nLay+1,sw_gas_props%get_nband()),target :: & - fluxSW_up_allsky, fluxSW_up_clrsky, fluxSW_dn_dir_clrsky, fluxSW_dn_allsky, & - fluxSW_dn_clrsky, fluxSW_dn_dir_allsky - integer :: iBand, ibd, ibd_uv, iCol, iGas, iLay, ix, ix2, iblck - integer, dimension(rrtmgp_phys_blksz) :: ipseed_sw + integer :: iBand, ibd, ibd_uv, iCol, iGas, iLay, ix, ix2, iblck, blksz type(random_stat) :: rng_stat real(kind_phys), dimension(2,sw_gas_props%get_nband()) :: bandlimits real(kind_phys), dimension(2), parameter :: & nIR_uvvis_bnd = (/12850,16000/), & uvb_bnd = (/29000,38000/) - real(kind_phys), dimension(rrtmgp_phys_blksz,sw_gas_props%get_ngpt()) :: toa_src_sw + + type(cmpfsw_type), dimension(:), allocatable :: scmpsw_clrsky, scmpsw_allsky + integer, dimension(:), allocatable :: ipseed_sw + real(kind_phys), dimension(:), allocatable :: zcf0, zcf1 + real(kind_phys), dimension(:,:), allocatable :: toa_src_sw, sfc_alb_dir, sfc_alb_dif + real(kind_phys), dimension(:,:,:), allocatable :: rng3D,rng3D2 + logical, dimension(:,:,:), allocatable :: maskMCICA + real(kind_phys), dimension(:,:,:), allocatable, target :: & + fluxSW_up_allsky, fluxSW_up_clrsky, fluxSW_dn_dir_clrsky, fluxSW_dn_allsky, & + fluxSW_dn_clrsky, fluxSW_dn_dir_allsky ! Initialize CCPP error handling variables errmsg = '' @@ -218,34 +217,51 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ if (nDay .gt. 0) then + ! bandlimits = sw_gas_props%get_band_lims_wavenumber() + ! ###################################################################################### ! ! Allocate/initialize RRTMGP DDT's ! ! ###################################################################################### + blksz = minval((/nDay,rrtmgp_phys_blksz/)) + + allocate(scmpsw_clrsky(blksz), scmpsw_allsky(blksz), zcf0(blksz), zcf1(blksz), & + rng3D(sw_gas_props%get_ngpt(),nLay,blksz), & + rng3D2(sw_gas_props%get_ngpt(),nLay,blksz), & + maskMCICA(blksz,nLay,sw_gas_props%get_ngpt()), & + sfc_alb_dir(sw_gas_props%get_nband(),blksz), & + sfc_alb_dif(sw_gas_props%get_nband(),blksz), & + fluxSW_up_allsky(blksz,nLay+1,sw_gas_props%get_nband()), & + fluxSW_up_clrsky(blksz,nLay+1,sw_gas_props%get_nband()), & + fluxSW_dn_dir_clrsky(blksz,nLay+1,sw_gas_props%get_nband()), & + fluxSW_dn_allsky(blksz,nLay+1,sw_gas_props%get_nband()), & + fluxSW_dn_clrsky(blksz,nLay+1,sw_gas_props%get_nband()), & + fluxSW_dn_dir_allsky(blksz,nLay+1,sw_gas_props%get_nband()), & + ipseed_sw(blksz), toa_src_sw(blksz,sw_gas_props%get_ngpt())) ! ty_gas_concs call check_error_msg('rrtmgp_sw_main_gas_concs_init',gas_concs%init(active_gases_array)) ! ty_optical_props call check_error_msg('rrtmgp_sw_main_accumulated_optics_init',& - sw_optical_props_accum%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props)) + sw_optical_props_accum%alloc_2str(blksz, nLay, sw_gas_props)) call check_error_msg('rrtmgp_sw_main_cloud_optics_init',& - sw_optical_props_cloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) + sw_optical_props_cloudsByBand%alloc_2str(blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) call check_error_msg('rrtmgp_sw_main_precip_optics_init',& - sw_optical_props_precipByBand%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) + sw_optical_props_precipByBand%alloc_2str(blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) call check_error_msg('rrtmgp_sw_mian_cloud_sampling_init', & - sw_optical_props_clouds%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props)) + sw_optical_props_clouds%alloc_2str(blksz, nLay, sw_gas_props)) call check_error_msg('rrtmgp_sw_main_aerosol_optics_init',& - sw_optical_props_aerosol_local%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) + sw_optical_props_aerosol_local%alloc_2str(blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) if (doGP_sgs_cnv) then call check_error_msg('rrtmgp_sw_main_cnv_cloud_optics_init',& - sw_optical_props_cnvcloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) + sw_optical_props_cnvcloudsByBand%alloc_2str(blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) endif if (doGP_sgs_pbl) then call check_error_msg('rrtmgp_sw_main_pbl_cloud_optics_init',& - sw_optical_props_pblcloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) + sw_optical_props_pblcloudsByBand%alloc_2str(blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) endif ! ty_fluxes_byband @@ -260,14 +276,18 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ ! Loop over all (daylit) columns... ! ! ###################################################################################### - do iCol=1,nDay,rrtmgp_phys_blksz + do iCol=1,nDay,blksz ix = idx(iCol) - ix2 = idx(iCol + rrtmgp_phys_blksz - 1) + ix2 = idx(iCol) + blksz - 1 + if (ix2 > nDay) then + ix = nDay - blksz + 1 + ix2 = nDay + endif ! Create clear/cloudy indicator zcf0(:) = 1._kind_phys zcf1(:) = 1._kind_phys - do iblck = 1, rrtmgp_phys_blksz + do iblck = 1, blksz do iLay=1,nLay zcf0(iblck) = min(zcf0(iblck), 1._kind_phys - cld_frac(ix+iblck-1,iLay)) enddo @@ -344,7 +364,7 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ ! spectral point (tau,ssa,g) toa_src_sw)) ! OUT - TOA incident shortwave radiation (spectral) ! Scale incident flux - do iblck = 1, rrtmgp_phys_blksz + do iblck = 1, blksz toa_src_sw(iblck,:) = toa_src_sw(iblck,:)*solcon / sum(toa_src_sw(iblck,:)) enddo @@ -357,7 +377,7 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ ! For overlapping band, average near-IR and us-vis albedos. ! ! ################################################################################### - do iblck = 1, rrtmgp_phys_blksz + do iblck = 1, blksz do iBand=1,sw_gas_props%get_nband() if (bandlimits(1,iBand) .lt. nIR_uvvis_bnd(1)) then sfc_alb_dir(iBand,iblck) = sfc_alb_nir_dir(ix+iblck-1) @@ -425,7 +445,7 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ endif ! Cloud precipitation optics: rain and snow(+groupel) - do iblck = 1, rrtmgp_phys_blksz + do iblck = 1, blksz do iLay=1,nLay if (cld_frac(ix+iblck-1,iLay) .gt. ftiny) then ! Rain/Snow optical depth (No band dependence) @@ -469,17 +489,17 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ ! ################################################################################### ! Change random number seed value for each radiation invocation (isubc_sw =1 or 2). if(isubc_sw == 1) then ! advance prescribed permutation seed - do iblck = 1, rrtmgp_phys_blksz + do iblck = 1, blksz ipseed_sw(iblck) = sw_gas_props%get_ngpt() + iCol + iblck - 1 enddo elseif (isubc_sw == 2) then ! use input array of permutaion seeds - do iblck = 1, rrtmgp_phys_blksz + do iblck = 1, blksz ipseed_sw(iblck) = icseed_sw(ix+iblck-1) enddo endif ! Call RNG - do iblck = 1, rrtmgp_phys_blksz + do iblck = 1, blksz call random_setseed(ipseed_sw(iblck),rng_stat) ! Use same rng for each layer if (iovr == iovr_max) then @@ -502,7 +522,7 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ endif ! Exponential decorrelation length overlap if (iovr == iovr_dcorr) then - do iblck = 1, rrtmgp_phys_blksz + do iblck = 1, blksz ! Generate second RNG call random_setseed(ipseed_sw(iblck),rng_stat) call random_number(rng2D,rng_stat) @@ -529,9 +549,9 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ ! ! ################################################################################### ! Increment - sw_optical_props_aerosol_local%tau = aersw_tau(iCol:iCol+rrtmgp_phys_blksz-1,:,:) - sw_optical_props_aerosol_local%ssa = aersw_ssa(iCol:iCol+rrtmgp_phys_blksz-1,:,:) - sw_optical_props_aerosol_local%g = aersw_g(iCol:iCol+rrtmgp_phys_blksz-1,:,:) + sw_optical_props_aerosol_local%tau = aersw_tau(iCol:iCol+blksz-1,:,:) + sw_optical_props_aerosol_local%ssa = aersw_ssa(iCol:iCol+blksz-1,:,:) + sw_optical_props_aerosol_local%g = aersw_g(iCol:iCol+blksz-1,:,:) call check_error_msg('rrtmgp_sw_main_increment_aerosol_to_clrsky', & sw_optical_props_aerosol_local%increment(sw_optical_props_accum)) @@ -553,7 +573,7 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ fluxswDOWN_clrsky(ix:ix2,:) = sum(flux_clrsky%bnd_flux_dn, dim=3) ! Compute surface downward beam/diffused flux components - do iblck = 1, rrtmgp_phys_blksz + do iblck = 1, blksz do iBand=1,sw_gas_props%get_nband() flux_dir = flux_clrsky%bnd_flux_dn(iblck,iSFC,iBand) flux_dif = 0._kind_phys @@ -607,7 +627,7 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ fluxswDOWN_allsky(ix:ix2,:) = sum(flux_allsky%bnd_flux_dn, dim=3) ! Compute and store downward beam/diffused flux components - do iblck = 1, rrtmgp_phys_blksz + do iblck = 1, blksz ! Loop over bands, sum fluxes... do iBand=1,sw_gas_props%get_nband() flux_dir = flux_allsky%bnd_flux_dn_dir(iblck,iSFC,iBand) @@ -651,7 +671,7 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ else ! No clouds fluxswUP_allsky(ix:ix2,:) = sum(flux_clrsky%bnd_flux_up, dim=3) fluxswDOWN_allsky(ix:ix2,:) = sum(flux_clrsky%bnd_flux_dn, dim=3) - do iblck = 1, rrtmgp_phys_blksz + do iblck = 1, blksz scmpsw(ix+iblck-1)%nirbm = scmpsw_clrsky(iblck)%nirbm scmpsw(ix+iblck-1)%nirdf = scmpsw_clrsky(iblck)%nirdf scmpsw(ix+iblck-1)%visbm = scmpsw_clrsky(iblck)%visbm From 67b693e31bcd4dc43c2e3874eca3cfd42c5cfa1a Mon Sep 17 00:00:00 2001 From: drnimbusrain Date: Wed, 28 Sep 2022 14:20:33 +0000 Subject: [PATCH 047/380] Testing hedmf change. --- physics/hedmf.f | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/physics/hedmf.f b/physics/hedmf.f index 4b010a121..0059d2bce 100644 --- a/physics/hedmf.f +++ b/physics/hedmf.f @@ -837,7 +837,11 @@ subroutine hedmf_run (im,km,ntrac,ntcw,dv,du,tau,rtg, & dku(i,k) = max(dku(i,k),xkzmo(i,k)) dkt(i,k) = min(dkt(i,k),dkmax) dkt(i,k) = max(dkt(i,k),xkzo(i,k)) + if(k .eq. 1) then + dktx(i,k)= dkt(i,k)*0.5 + else dktx(i,k)= dkt(i,k) + endif endif enddo !i enddo !k From e2c7f47b46f5cf09bcf4c36ae2a9725a6291efb9 Mon Sep 17 00:00:00 2001 From: drnimbusrain Date: Thu, 29 Sep 2022 14:43:53 +0000 Subject: [PATCH 048/380] Rolled back hedmf test change. --- physics/hedmf.f | 4 ---- 1 file changed, 4 deletions(-) diff --git a/physics/hedmf.f b/physics/hedmf.f index 0059d2bce..4b010a121 100644 --- a/physics/hedmf.f +++ b/physics/hedmf.f @@ -837,11 +837,7 @@ subroutine hedmf_run (im,km,ntrac,ntcw,dv,du,tau,rtg, & dku(i,k) = max(dku(i,k),xkzmo(i,k)) dkt(i,k) = min(dkt(i,k),dkmax) dkt(i,k) = max(dkt(i,k),xkzo(i,k)) - if(k .eq. 1) then - dktx(i,k)= dkt(i,k)*0.5 - else dktx(i,k)= dkt(i,k) - endif endif enddo !i enddo !k From b65af77c56476d6c7e34735fe60daa667fa84989 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Mon, 3 Oct 2022 19:47:05 +0000 Subject: [PATCH 049/380] Revert "Some modifications for rrtmgp physics blocking to work." This reverts commit d35be37ed9441d449efeb3dae2c536ceb1cb4cf9. --- physics/rrtmgp_lw_main.F90 | 77 ++++++++++++++---------------- physics/rrtmgp_sw_main.F90 | 96 +++++++++++++++----------------------- 2 files changed, 72 insertions(+), 101 deletions(-) diff --git a/physics/rrtmgp_lw_main.F90 b/physics/rrtmgp_lw_main.F90 index 0ea0c3f7c..ab82dc56a 100644 --- a/physics/rrtmgp_lw_main.F90 +++ b/physics/rrtmgp_lw_main.F90 @@ -195,17 +195,19 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, lw_optical_props_precipByBand type(ty_source_func_lw) :: sources type(ty_fluxes_byband) :: flux_allsky, flux_clrsky - integer :: iCol, iLay, iGas, iBand, iCol2, ix, iblck, blksz - + integer :: iCol, iLay, iGas, iBand, iCol2, ix, iblck + integer, dimension(rrtmgp_phys_blksz) :: ipseed_lw type(random_stat) :: rng_stat + real(kind_phys), dimension(rrtmgp_phys_blksz) :: zcf0, zcf1 + logical, dimension(rrtmgp_phys_blksz,nLay,lw_gas_props%get_ngpt()) :: maskMCICA + real(kind_phys), dimension(rrtmgp_phys_blksz) :: tau_rain, tau_snow real(kind_phys), dimension(lw_gas_props%get_ngpt()) :: rng1D - real(kind_phys) :: tau_rain, tau_snow - integer, dimension(:), allocatable :: ipseed_lw - real(kind_phys), dimension(:), allocatable :: zcf0, zcf1, rng2D - real(kind_phys), dimension(:,:), allocatable :: lw_Ds, sfc_emiss_byband - real(kind_phys), dimension(:,:,:), allocatable :: rng3D,rng3D2 - logical, dimension(:,:,:), allocatable :: maskMCICA - real(kind_phys), dimension(:,:,:), allocatable, target :: fluxLW_up_allsky, fluxLW_up_clrsky, fluxLW_dn_allsky, fluxLW_dn_clrsky + real(kind_phys), dimension(lw_gas_props%get_ngpt(),nLay,rrtmgp_phys_blksz) :: rng3D,rng3D2 + real(kind_phys), dimension(lw_gas_props%get_ngpt()*nLay) :: rng2D + real(kind_phys), dimension(rrtmgp_phys_blksz,nLay+1,lw_gas_props%get_nband()),target :: & + fluxLW_up_allsky, fluxLW_up_clrsky, fluxLW_dn_allsky, fluxLW_dn_clrsky + real(kind_phys), dimension(rrtmgp_phys_blksz,lw_gas_props%get_ngpt()) :: lw_Ds + real(kind_phys), dimension(lw_gas_props%get_nband(),rrtmgp_phys_blksz) :: sfc_emiss_byband ! Initialize CCPP error handling variables errmsg = '' @@ -218,43 +220,30 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, ! Allocate/initialize RRTMGP DDT's ! ! ###################################################################################### - blksz = minval((/nCol,rrtmgp_phys_blksz/)) - - allocate(ipseed_lw(blksz), zcf0(blksz), zcf1(blksz), & - maskMCICA(blksz,nLay,lw_gas_props%get_ngpt()), & - rng3D(lw_gas_props%get_ngpt(),nLay,blksz), & - rng3D2(lw_gas_props%get_ngpt(),nLay,blksz), & - rng2D(lw_gas_props%get_ngpt()*nLay), & - fluxLW_up_allsky(blksz,nLay+1,lw_gas_props%get_nband()), & - fluxLW_up_clrsky(blksz,nLay+1,lw_gas_props%get_nband()), & - fluxLW_dn_allsky(blksz,nLay+1,lw_gas_props%get_nband()), & - fluxLW_dn_clrsky(blksz,nLay+1,lw_gas_props%get_nband()), & - lw_Ds(blksz,lw_gas_props%get_ngpt()), & - sfc_emiss_byband(lw_gas_props%get_nband(),blksz)) ! ty_gas_concs call check_error_msg('rrtmgp_lw_main_gas_concs_init',gas_concs%init(active_gases_array)) ! ty_optical_props call check_error_msg('rrtmgp_lw_main_gas_optics_init',& - lw_optical_props_clrsky%alloc_1scl(blksz, nLay, lw_gas_props)) + lw_optical_props_clrsky%alloc_1scl(rrtmgp_phys_blksz, nLay, lw_gas_props)) call check_error_msg('rrtmgp_lw_main_sources_init',& - sources%alloc(blksz, nLay, lw_gas_props)) + sources%alloc(rrtmgp_phys_blksz, nLay, lw_gas_props)) call check_error_msg('rrtmgp_lw_main_cloud_optics_init',& - lw_optical_props_cloudsByBand%alloc_2str(blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) + lw_optical_props_cloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) call check_error_msg('rrtmgp_lw_main_precip_optics_init',& - lw_optical_props_precipByBand%alloc_2str(blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) + lw_optical_props_precipByBand%alloc_2str(rrtmgp_phys_blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) call check_error_msg('rrtmgp_lw_mian_cloud_sampling_init', & - lw_optical_props_clouds%alloc_2str(blksz, nLay, lw_gas_props)) + lw_optical_props_clouds%alloc_2str(rrtmgp_phys_blksz, nLay, lw_gas_props)) call check_error_msg('rrtmgp_lw_main_aerosol_optics_init',& - lw_optical_props_aerosol_local%alloc_1scl(blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) + lw_optical_props_aerosol_local%alloc_1scl(rrtmgp_phys_blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) if (doGP_sgs_cnv) then call check_error_msg('rrtmgp_lw_main_cnv_cloud_optics_init',& - lw_optical_props_cnvcloudsByBand%alloc_2str(blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) + lw_optical_props_cnvcloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) endif if (doGP_sgs_pbl) then call check_error_msg('rrtmgp_lw_main_pbl_cloud_optics_init',& - lw_optical_props_pblcloudsByBand%alloc_2str(blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) + lw_optical_props_pblcloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) endif ! ###################################################################################### @@ -262,13 +251,13 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, ! Loop over all columns... ! ! ###################################################################################### - do iCol=1,nCol,blksz - iCol2 = iCol + blksz - 1 + do iCol=1,nCol,rrtmgp_phys_blksz + iCol2 = iCol + rrtmgp_phys_blksz - 1 ! Create clear/cloudy indicator zcf0(:) = 1._kind_phys zcf1(:) = 1._kind_phys - do iblck = 1, blksz + do iblck = 1, rrtmgp_phys_blksz do iLay=1,nLay zcf0(iblck) = min(zcf0(iblck), 1._kind_phys - cld_frac(iCol+iblck-1,iLay)) enddo @@ -334,7 +323,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, ! ! ################################################################################### ! Assign same emissivity to all band - do iblck=1,blksz + do iblck=1,rrtmgp_phys_blksz if (semis(iCol+iblck-1) > eps .and. semis(iCol+iblck-1) <= 1._kind_phys) then do iBand=1,lw_gas_props%get_nband() sfc_emiss_byband(iBand,iblck) = semis(iCol+iblck-1) @@ -409,20 +398,22 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, ! Cloud precipitation optics: rain and snow(+groupel) ! ! ################################################################################### - do ix=1,blksz + tau_rain(:) = 0._kind_phys + tau_snow(:) = 0._kind_phys + do ix=1,rrtmgp_phys_blksz do iLay=1,nLay if (cld_frac(iCol+ix-1,iLay) .gt. eps) then ! Rain optical-depth (No band dependence) - tau_rain = absrain*cld_rwp(iCol+ix-1,iLay) + tau_rain(ix) = absrain*cld_rwp(iCol+ix-1,iLay) ! Snow (+groupel) optical-depth (No band dependence) if (cld_swp(iCol+ix-1,iLay) .gt. 0. .and. cld_resnow(iCol+ix-1,iLay) .gt. 10._kind_phys) then - tau_snow = abssnow0*1.05756*cld_swp(iCol+ix-1,iLay)/cld_resnow(iCol+ix-1,iLay) + tau_snow(ix) = abssnow0*1.05756*cld_swp(iCol+ix-1,iLay)/cld_resnow(iCol+ix-1,iLay) else - tau_snow = 0.0 + tau_snow(ix) = 0.0 endif do iBand=1,lw_gas_props%get_nband() - lw_optical_props_precipByBand%tau(ix,iLay,iBand) = tau_rain + tau_snow + lw_optical_props_precipByBand%tau(ix,iLay,iBand) = tau_rain(ix) + tau_snow(ix) enddo endif enddo @@ -440,17 +431,17 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, if (any(zcf1 .gt. eps)) then ! Change random number seed value for each radiation invocation (isubc_lw =1 or 2). if(isubc_lw == 1) then ! advance prescribed permutation seed - do ix=1,blksz + do ix=1,rrtmgp_phys_blksz ipseed_lw(ix) = lw_gas_props%get_ngpt() + iCol + ix - 1 enddo elseif (isubc_lw == 2) then ! use input array of permutaion seeds - do ix=1,blksz + do ix=1,rrtmgp_phys_blksz ipseed_lw(ix) = icseed_lw(iCol+ix-1) enddo endif ! Call RNG - do ix=1,blksz + do ix=1,rrtmgp_phys_blksz call random_setseed(ipseed_lw(ix),rng_stat) ! Use same rng for each layer if (iovr == iovr_max) then @@ -473,7 +464,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, endif ! Exponential decorrelation length overlap if (iovr == iovr_dcorr) then - do ix=1,blksz + do ix=1,rrtmgp_phys_blksz ! Generate second RNG call random_setseed(ipseed_lw(ix),rng_stat) call random_number(rng2D,rng_stat) diff --git a/physics/rrtmgp_sw_main.F90 b/physics/rrtmgp_sw_main.F90 index ea2f36273..325607daa 100644 --- a/physics/rrtmgp_sw_main.F90 +++ b/physics/rrtmgp_sw_main.F90 @@ -110,8 +110,8 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ iovr_dcorr, & ! Flag for decorrelation-length cloud overlap method iovr_exp, & ! Flag for exponential cloud overlap method iovr_exprand, & ! Flag for exponential-random cloud overlap method - isubc_sw, & ! Flag for sw clouds sub-grid approximation - iSFC ! Surface layer index + isubc_sw, & ! + iSFC integer,intent(in),dimension(:) :: & idx, & ! Index array for daytime points icseed_sw ! Seed for random number generation for shortwave radiation @@ -150,7 +150,7 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ cld_pbl_reliq, & ! Effective radius for PBL liquid cloud-particles cld_pbl_iwp, & ! Water path for PBL ice cloud-particles cld_pbl_reice, & ! Effective radius for PBL ice cloud-particles - cloud_overlap_param ! Cloud overlap parameter + cloud_overlap_param ! real(kind_phys), dimension(:,:,:), intent(in) :: & aersw_tau, & ! Aerosol optical depth aersw_ssa, & ! Aerosol single scattering albedo @@ -182,6 +182,7 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ ! visdf - downward uv+vis diffused flux (W/m2) ! Local variables + type(cmpfsw_type), dimension(rrtmgp_phys_blksz) :: scmpsw_clrsky, scmpsw_allsky type(ty_gas_concs) :: gas_concs type(ty_optical_props_2str) :: sw_optical_props_accum, sw_optical_props_aerosol_local, & sw_optical_props_cloudsByBand, sw_optical_props_cnvcloudsByBand, & @@ -190,24 +191,24 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ type(ty_fluxes_byband) :: flux_allsky, flux_clrsky real(kind_phys) :: tau_rain, tau_snow, ssa_rain, ssa_snow, asy_rain, asy_snow, & tau_prec, asy_prec, ssa_prec, asyw, ssaw, za1, za2, flux_dir, flux_dif + real(kind_phys), dimension(rrtmgp_phys_blksz) :: zcf0, zcf1 real(kind_phys), dimension(sw_gas_props%get_ngpt()) :: rng1D + real(kind_phys), dimension(sw_gas_props%get_ngpt(),nLay,rrtmgp_phys_blksz) :: rng3D,rng3D2 real(kind_phys), dimension(sw_gas_props%get_ngpt()*nLay) :: rng2D - integer :: iBand, ibd, ibd_uv, iCol, iGas, iLay, ix, ix2, iblck, blksz + logical, dimension(rrtmgp_phys_blksz,nLay,sw_gas_props%get_ngpt()) :: maskMCICA + real(kind_phys), dimension(sw_gas_props%get_nband(),rrtmgp_phys_blksz) :: & + sfc_alb_dir, sfc_alb_dif + real(kind_phys), dimension(rrtmgp_phys_blksz,nLay+1,sw_gas_props%get_nband()),target :: & + fluxSW_up_allsky, fluxSW_up_clrsky, fluxSW_dn_dir_clrsky, fluxSW_dn_allsky, & + fluxSW_dn_clrsky, fluxSW_dn_dir_allsky + integer :: iBand, ibd, ibd_uv, iCol, iGas, iLay, ix, ix2, iblck + integer, dimension(rrtmgp_phys_blksz) :: ipseed_sw type(random_stat) :: rng_stat real(kind_phys), dimension(2,sw_gas_props%get_nband()) :: bandlimits real(kind_phys), dimension(2), parameter :: & nIR_uvvis_bnd = (/12850,16000/), & uvb_bnd = (/29000,38000/) - - type(cmpfsw_type), dimension(:), allocatable :: scmpsw_clrsky, scmpsw_allsky - integer, dimension(:), allocatable :: ipseed_sw - real(kind_phys), dimension(:), allocatable :: zcf0, zcf1 - real(kind_phys), dimension(:,:), allocatable :: toa_src_sw, sfc_alb_dir, sfc_alb_dif - real(kind_phys), dimension(:,:,:), allocatable :: rng3D,rng3D2 - logical, dimension(:,:,:), allocatable :: maskMCICA - real(kind_phys), dimension(:,:,:), allocatable, target :: & - fluxSW_up_allsky, fluxSW_up_clrsky, fluxSW_dn_dir_clrsky, fluxSW_dn_allsky, & - fluxSW_dn_clrsky, fluxSW_dn_dir_allsky + real(kind_phys), dimension(rrtmgp_phys_blksz,sw_gas_props%get_ngpt()) :: toa_src_sw ! Initialize CCPP error handling variables errmsg = '' @@ -217,51 +218,34 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ if (nDay .gt. 0) then - ! bandlimits = sw_gas_props%get_band_lims_wavenumber() - ! ###################################################################################### ! ! Allocate/initialize RRTMGP DDT's ! ! ###################################################################################### - blksz = minval((/nDay,rrtmgp_phys_blksz/)) - - allocate(scmpsw_clrsky(blksz), scmpsw_allsky(blksz), zcf0(blksz), zcf1(blksz), & - rng3D(sw_gas_props%get_ngpt(),nLay,blksz), & - rng3D2(sw_gas_props%get_ngpt(),nLay,blksz), & - maskMCICA(blksz,nLay,sw_gas_props%get_ngpt()), & - sfc_alb_dir(sw_gas_props%get_nband(),blksz), & - sfc_alb_dif(sw_gas_props%get_nband(),blksz), & - fluxSW_up_allsky(blksz,nLay+1,sw_gas_props%get_nband()), & - fluxSW_up_clrsky(blksz,nLay+1,sw_gas_props%get_nband()), & - fluxSW_dn_dir_clrsky(blksz,nLay+1,sw_gas_props%get_nband()), & - fluxSW_dn_allsky(blksz,nLay+1,sw_gas_props%get_nband()), & - fluxSW_dn_clrsky(blksz,nLay+1,sw_gas_props%get_nband()), & - fluxSW_dn_dir_allsky(blksz,nLay+1,sw_gas_props%get_nband()), & - ipseed_sw(blksz), toa_src_sw(blksz,sw_gas_props%get_ngpt())) ! ty_gas_concs call check_error_msg('rrtmgp_sw_main_gas_concs_init',gas_concs%init(active_gases_array)) ! ty_optical_props call check_error_msg('rrtmgp_sw_main_accumulated_optics_init',& - sw_optical_props_accum%alloc_2str(blksz, nLay, sw_gas_props)) + sw_optical_props_accum%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props)) call check_error_msg('rrtmgp_sw_main_cloud_optics_init',& - sw_optical_props_cloudsByBand%alloc_2str(blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) + sw_optical_props_cloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) call check_error_msg('rrtmgp_sw_main_precip_optics_init',& - sw_optical_props_precipByBand%alloc_2str(blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) + sw_optical_props_precipByBand%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) call check_error_msg('rrtmgp_sw_mian_cloud_sampling_init', & - sw_optical_props_clouds%alloc_2str(blksz, nLay, sw_gas_props)) + sw_optical_props_clouds%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props)) call check_error_msg('rrtmgp_sw_main_aerosol_optics_init',& - sw_optical_props_aerosol_local%alloc_2str(blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) + sw_optical_props_aerosol_local%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) if (doGP_sgs_cnv) then call check_error_msg('rrtmgp_sw_main_cnv_cloud_optics_init',& - sw_optical_props_cnvcloudsByBand%alloc_2str(blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) + sw_optical_props_cnvcloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) endif if (doGP_sgs_pbl) then call check_error_msg('rrtmgp_sw_main_pbl_cloud_optics_init',& - sw_optical_props_pblcloudsByBand%alloc_2str(blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) + sw_optical_props_pblcloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) endif ! ty_fluxes_byband @@ -276,18 +260,14 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ ! Loop over all (daylit) columns... ! ! ###################################################################################### - do iCol=1,nDay,blksz + do iCol=1,nDay,rrtmgp_phys_blksz ix = idx(iCol) - ix2 = idx(iCol) + blksz - 1 - if (ix2 > nDay) then - ix = nDay - blksz + 1 - ix2 = nDay - endif + ix2 = idx(iCol + rrtmgp_phys_blksz - 1) ! Create clear/cloudy indicator zcf0(:) = 1._kind_phys zcf1(:) = 1._kind_phys - do iblck = 1, blksz + do iblck = 1, rrtmgp_phys_blksz do iLay=1,nLay zcf0(iblck) = min(zcf0(iblck), 1._kind_phys - cld_frac(ix+iblck-1,iLay)) enddo @@ -364,7 +344,7 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ ! spectral point (tau,ssa,g) toa_src_sw)) ! OUT - TOA incident shortwave radiation (spectral) ! Scale incident flux - do iblck = 1, blksz + do iblck = 1, rrtmgp_phys_blksz toa_src_sw(iblck,:) = toa_src_sw(iblck,:)*solcon / sum(toa_src_sw(iblck,:)) enddo @@ -377,7 +357,7 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ ! For overlapping band, average near-IR and us-vis albedos. ! ! ################################################################################### - do iblck = 1, blksz + do iblck = 1, rrtmgp_phys_blksz do iBand=1,sw_gas_props%get_nband() if (bandlimits(1,iBand) .lt. nIR_uvvis_bnd(1)) then sfc_alb_dir(iBand,iblck) = sfc_alb_nir_dir(ix+iblck-1) @@ -445,7 +425,7 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ endif ! Cloud precipitation optics: rain and snow(+groupel) - do iblck = 1, blksz + do iblck = 1, rrtmgp_phys_blksz do iLay=1,nLay if (cld_frac(ix+iblck-1,iLay) .gt. ftiny) then ! Rain/Snow optical depth (No band dependence) @@ -489,17 +469,17 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ ! ################################################################################### ! Change random number seed value for each radiation invocation (isubc_sw =1 or 2). if(isubc_sw == 1) then ! advance prescribed permutation seed - do iblck = 1, blksz + do iblck = 1, rrtmgp_phys_blksz ipseed_sw(iblck) = sw_gas_props%get_ngpt() + iCol + iblck - 1 enddo elseif (isubc_sw == 2) then ! use input array of permutaion seeds - do iblck = 1, blksz + do iblck = 1, rrtmgp_phys_blksz ipseed_sw(iblck) = icseed_sw(ix+iblck-1) enddo endif ! Call RNG - do iblck = 1, blksz + do iblck = 1, rrtmgp_phys_blksz call random_setseed(ipseed_sw(iblck),rng_stat) ! Use same rng for each layer if (iovr == iovr_max) then @@ -522,7 +502,7 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ endif ! Exponential decorrelation length overlap if (iovr == iovr_dcorr) then - do iblck = 1, blksz + do iblck = 1, rrtmgp_phys_blksz ! Generate second RNG call random_setseed(ipseed_sw(iblck),rng_stat) call random_number(rng2D,rng_stat) @@ -549,9 +529,9 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ ! ! ################################################################################### ! Increment - sw_optical_props_aerosol_local%tau = aersw_tau(iCol:iCol+blksz-1,:,:) - sw_optical_props_aerosol_local%ssa = aersw_ssa(iCol:iCol+blksz-1,:,:) - sw_optical_props_aerosol_local%g = aersw_g(iCol:iCol+blksz-1,:,:) + sw_optical_props_aerosol_local%tau = aersw_tau(iCol:iCol+rrtmgp_phys_blksz-1,:,:) + sw_optical_props_aerosol_local%ssa = aersw_ssa(iCol:iCol+rrtmgp_phys_blksz-1,:,:) + sw_optical_props_aerosol_local%g = aersw_g(iCol:iCol+rrtmgp_phys_blksz-1,:,:) call check_error_msg('rrtmgp_sw_main_increment_aerosol_to_clrsky', & sw_optical_props_aerosol_local%increment(sw_optical_props_accum)) @@ -573,7 +553,7 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ fluxswDOWN_clrsky(ix:ix2,:) = sum(flux_clrsky%bnd_flux_dn, dim=3) ! Compute surface downward beam/diffused flux components - do iblck = 1, blksz + do iblck = 1, rrtmgp_phys_blksz do iBand=1,sw_gas_props%get_nband() flux_dir = flux_clrsky%bnd_flux_dn(iblck,iSFC,iBand) flux_dif = 0._kind_phys @@ -627,7 +607,7 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ fluxswDOWN_allsky(ix:ix2,:) = sum(flux_allsky%bnd_flux_dn, dim=3) ! Compute and store downward beam/diffused flux components - do iblck = 1, blksz + do iblck = 1, rrtmgp_phys_blksz ! Loop over bands, sum fluxes... do iBand=1,sw_gas_props%get_nband() flux_dir = flux_allsky%bnd_flux_dn_dir(iblck,iSFC,iBand) @@ -671,7 +651,7 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ else ! No clouds fluxswUP_allsky(ix:ix2,:) = sum(flux_clrsky%bnd_flux_up, dim=3) fluxswDOWN_allsky(ix:ix2,:) = sum(flux_clrsky%bnd_flux_dn, dim=3) - do iblck = 1, blksz + do iblck = 1, rrtmgp_phys_blksz scmpsw(ix+iblck-1)%nirbm = scmpsw_clrsky(iblck)%nirbm scmpsw(ix+iblck-1)%nirdf = scmpsw_clrsky(iblck)%nirdf scmpsw(ix+iblck-1)%visbm = scmpsw_clrsky(iblck)%visbm From 1b34a74129f055fd822e6731680d3bcef0f0f0b1 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Mon, 3 Oct 2022 20:53:54 +0000 Subject: [PATCH 050/380] Move allocation of RRTMGP DDTs to init --- physics/rrtmgp_lw_main.F90 | 120 ++++++++--------- physics/rrtmgp_lw_main.meta | 32 ++++- physics/rrtmgp_sw_main.F90 | 252 ++++++++++++++++++------------------ physics/rrtmgp_sw_main.meta | 32 ++++- 4 files changed, 249 insertions(+), 187 deletions(-) diff --git a/physics/rrtmgp_lw_main.F90 b/physics/rrtmgp_lw_main.F90 index ab82dc56a..d6b0ab630 100644 --- a/physics/rrtmgp_lw_main.F90 +++ b/physics/rrtmgp_lw_main.F90 @@ -27,6 +27,13 @@ module rrtmgp_lw_main use rrtmgp_sampling, only: sampled_mask, draw_samples implicit none + type(ty_gas_concs) :: gas_concs + type(ty_optical_props_1scl) :: lw_optical_props_clrsky, lw_optical_props_aerosol_local + type(ty_optical_props_2str) :: lw_optical_props_clouds, lw_optical_props_cloudsByBand, & + lw_optical_props_cnvcloudsByBand, lw_optical_props_pblcloudsByBand, & + lw_optical_props_precipByBand + type(ty_source_func_lw) :: sources + public rrtmgp_lw_main_init, rrtmgp_lw_main_run contains ! ######################################################################################### @@ -41,8 +48,9 @@ module rrtmgp_lw_main !> @{ ! ######################################################################################### subroutine rrtmgp_lw_main_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, rrtmgp_lw_file_clouds,& - active_gases_array, doGP_cldoptics_PADE, doGP_cldoptics_LUT, nrghice, mpicomm, & - mpirank, mpiroot, errmsg, errflg) + active_gases_array, doGP_cldoptics_PADE, doGP_cldoptics_LUT, doGP_sgs_pbl, & + doGP_sgs_cnv, nrghice, mpicomm, mpirank, mpiroot, nLay, rrtmgp_phys_blksz, & + errmsg, errflg) ! Inputs character(len=128),intent(in) :: & @@ -55,13 +63,17 @@ subroutine rrtmgp_lw_main_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, rrtmgp_lw_fi active_gases_array ! List of active gases from namelist as array) logical, intent(in) :: & doGP_cldoptics_PADE, & ! Use RRTMGP cloud-optics: PADE approximation? - doGP_cldoptics_LUT ! Use RRTMGP cloud-optics: LUTs? + doGP_cldoptics_LUT, & ! Use RRTMGP cloud-optics: LUTs? + doGP_sgs_pbl, & ! Flag to include sgs PBL clouds + doGP_sgs_cnv ! Flag to include sgs convective clouds integer, intent(inout) :: & nrghice ! Number of ice-roughness categories integer,intent(in) :: & mpicomm, & ! MPI communicator mpirank, & ! Current MPI rank - mpiroot ! Master MPI rank + mpiroot, & ! Master MPI rank + rrtmgp_phys_blksz, & ! Number of horizontal points to process at once. + nLay ! Outputs character(len=*), intent(out) :: & @@ -82,6 +94,33 @@ subroutine rrtmgp_lw_main_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, rrtmgp_lw_fi doGP_cldoptics_PADE, doGP_cldoptics_LUT, nrghice, mpicomm, mpirank, mpiroot, & errmsg, errflg) + ! DDTs + + ! ty_gas_concs + call check_error_msg('rrtmgp_lw_main_gas_concs_init',gas_concs%init(active_gases_array)) + + ! ty_optical_props + call check_error_msg('rrtmgp_lw_main_gas_optics_init',& + lw_optical_props_clrsky%alloc_1scl(rrtmgp_phys_blksz, nLay, lw_gas_props)) + call check_error_msg('rrtmgp_lw_main_sources_init',& + sources%alloc(rrtmgp_phys_blksz, nLay, lw_gas_props)) + call check_error_msg('rrtmgp_lw_main_cloud_optics_init',& + lw_optical_props_cloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) + call check_error_msg('rrtmgp_lw_main_precip_optics_init',& + lw_optical_props_precipByBand%alloc_2str(rrtmgp_phys_blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) + call check_error_msg('rrtmgp_lw_mian_cloud_sampling_init', & + lw_optical_props_clouds%alloc_2str(rrtmgp_phys_blksz, nLay, lw_gas_props)) + call check_error_msg('rrtmgp_lw_main_aerosol_optics_init',& + lw_optical_props_aerosol_local%alloc_1scl(rrtmgp_phys_blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) + if (doGP_sgs_cnv) then + call check_error_msg('rrtmgp_lw_main_cnv_cloud_optics_init',& + lw_optical_props_cnvcloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) + endif + if (doGP_sgs_pbl) then + call check_error_msg('rrtmgp_lw_main_pbl_cloud_optics_init',& + lw_optical_props_pblcloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) + endif + end subroutine rrtmgp_lw_main_init !> @} ! ###################################################################################### @@ -188,13 +227,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, errflg ! CCPP error flag ! Local variables - type(ty_gas_concs) :: gas_concs - type(ty_optical_props_1scl) :: lw_optical_props_clrsky, lw_optical_props_aerosol_local - type(ty_optical_props_2str) :: lw_optical_props_clouds, lw_optical_props_cloudsByBand,& - lw_optical_props_cnvcloudsByBand, lw_optical_props_pblcloudsByBand, & - lw_optical_props_precipByBand - type(ty_source_func_lw) :: sources - type(ty_fluxes_byband) :: flux_allsky, flux_clrsky + type(ty_fluxes_byband) :: flux_allsky, flux_clrsky integer :: iCol, iLay, iGas, iBand, iCol2, ix, iblck integer, dimension(rrtmgp_phys_blksz) :: ipseed_lw type(random_stat) :: rng_stat @@ -215,37 +248,6 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, if (.not. doLWrad) return - ! ###################################################################################### - ! - ! Allocate/initialize RRTMGP DDT's - ! - ! ###################################################################################### - - ! ty_gas_concs - call check_error_msg('rrtmgp_lw_main_gas_concs_init',gas_concs%init(active_gases_array)) - - ! ty_optical_props - call check_error_msg('rrtmgp_lw_main_gas_optics_init',& - lw_optical_props_clrsky%alloc_1scl(rrtmgp_phys_blksz, nLay, lw_gas_props)) - call check_error_msg('rrtmgp_lw_main_sources_init',& - sources%alloc(rrtmgp_phys_blksz, nLay, lw_gas_props)) - call check_error_msg('rrtmgp_lw_main_cloud_optics_init',& - lw_optical_props_cloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) - call check_error_msg('rrtmgp_lw_main_precip_optics_init',& - lw_optical_props_precipByBand%alloc_2str(rrtmgp_phys_blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) - call check_error_msg('rrtmgp_lw_mian_cloud_sampling_init', & - lw_optical_props_clouds%alloc_2str(rrtmgp_phys_blksz, nLay, lw_gas_props)) - call check_error_msg('rrtmgp_lw_main_aerosol_optics_init',& - lw_optical_props_aerosol_local%alloc_1scl(rrtmgp_phys_blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) - if (doGP_sgs_cnv) then - call check_error_msg('rrtmgp_lw_main_cnv_cloud_optics_init',& - lw_optical_props_cnvcloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) - endif - if (doGP_sgs_pbl) then - call check_error_msg('rrtmgp_lw_main_pbl_cloud_optics_init',& - lw_optical_props_pblcloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) - endif - ! ###################################################################################### ! ! Loop over all columns... @@ -254,23 +256,8 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, do iCol=1,nCol,rrtmgp_phys_blksz iCol2 = iCol + rrtmgp_phys_blksz - 1 - ! Create clear/cloudy indicator - zcf0(:) = 1._kind_phys - zcf1(:) = 1._kind_phys - do iblck = 1, rrtmgp_phys_blksz - do iLay=1,nLay - zcf0(iblck) = min(zcf0(iblck), 1._kind_phys - cld_frac(iCol+iblck-1,iLay)) - enddo - if (zcf0(iblck) <= ftiny) zcf0(iblck) = 0._kind_phys - if (zcf0(iblck) > oneminus) zcf0(iblck) = 1._kind_phys - zcf1(iblck) = 1._kind_phys - zcf0(iblck) - enddo - - ! ################################################################################### - ! ! Initialize/reset - ! - ! ################################################################################### + ! ty_optical_props lw_optical_props_clrsky%tau = 0._kind_phys lw_optical_props_precipByBand%tau = 0._kind_phys @@ -293,7 +280,12 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, fluxLW_dn_clrsky = 0._kind_phys if (doGP_sgs_cnv) lw_optical_props_cnvcloudsByBand%tau = 0._kind_phys if (doGP_sgs_pbl) lw_optical_props_pblcloudsByBand%tau = 0._kind_phys + ! ty_fluxes_byband + fluxLW_up_allsky = 0._kind_phys + fluxLW_dn_allsky = 0._kind_phys + fluxLW_up_clrsky = 0._kind_phys + fluxLW_dn_clrsky = 0._kind_phys flux_allsky%bnd_flux_up => fluxLW_up_allsky flux_allsky%bnd_flux_dn => fluxLW_dn_allsky flux_clrsky%bnd_flux_up => fluxLW_up_clrsky @@ -353,6 +345,18 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, ! Compute cloud-optics... ! ! ################################################################################### + ! Create clear/cloudy indicator + zcf0(:) = 1._kind_phys + zcf1(:) = 1._kind_phys + do iblck = 1, rrtmgp_phys_blksz + do iLay=1,nLay + zcf0(iblck) = min(zcf0(iblck), 1._kind_phys - cld_frac(iCol+iblck-1,iLay)) + enddo + if (zcf0(iblck) <= ftiny) zcf0(iblck) = 0._kind_phys + if (zcf0(iblck) > oneminus) zcf0(iblck) = 1._kind_phys + zcf1(iblck) = 1._kind_phys - zcf0(iblck) + enddo + if (any(zcf1 .gt. eps)) then ! Microphysical (gridmean) cloud optics call check_error_msg('rrtmgp_lw_main_cloud_optics',lw_cloud_props%cloud_optics(& diff --git a/physics/rrtmgp_lw_main.meta b/physics/rrtmgp_lw_main.meta index 89e4bed2e..a1a384b25 100644 --- a/physics/rrtmgp_lw_main.meta +++ b/physics/rrtmgp_lw_main.meta @@ -50,6 +50,20 @@ dimensions = () type = logical intent = in +[doGP_sgs_cnv] + standard_name = flag_to_include_sgs_convective_cloud_in_RRTMGP + long_name = logical flag to control sgs convective cloud in RRTMGP + units = flag + dimensions = () + type = logical + intent = in +[doGP_sgs_pbl] + standard_name = flag_to_include_sgs_MYNN_EDMF_cloud_in_RRTMGP + long_name = logical flag to control MYNN-EDMF PBL cloud in RRTMGP + units = flag + dimensions = () + type = logical + intent = in [nrghice] standard_name = number_of_ice_roughness_categories long_name = number of ice-roughness categories in RRTMGP calculation @@ -78,6 +92,20 @@ dimensions = () type = integer intent = in +[rrtmgp_phys_blksz] + standard_name = number_of_columns_per_RRTMGP_LW_block + long_name = number of columns to process at a time by RRTMGP LW scheme + units = count + dimensions = () + type = integer + intent = in +[nLay] + standard_name = vertical_layer_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in [active_gases_array] standard_name = list_of_active_gases_used_by_RRTMGP long_name = list of active gases used by RRTMGP @@ -163,8 +191,8 @@ type = integer intent = in [rrtmgp_phys_blksz] - standard_name = number_of_columns_per_RRTMGP_block - long_name = number of columns to process ata time by RRTMGP + standard_name = number_of_columns_per_RRTMGP_LW_block + long_name = number of columns to process at a time by RRTMGP LW scheme units = count dimensions = () type = integer diff --git a/physics/rrtmgp_sw_main.F90 b/physics/rrtmgp_sw_main.F90 index 325607daa..114a3001a 100644 --- a/physics/rrtmgp_sw_main.F90 +++ b/physics/rrtmgp_sw_main.F90 @@ -20,6 +20,12 @@ module rrtmgp_sw_main use rrtmgp_sampling, only: sampled_mask, draw_samples implicit none + type(ty_gas_concs) :: gas_concs + type(ty_optical_props_2str) :: sw_optical_props_accum, sw_optical_props_aerosol_local, & + sw_optical_props_cloudsByBand, sw_optical_props_cnvcloudsByBand, & + sw_optical_props_pblcloudsByBand, sw_optical_props_precipByBand, & + sw_optical_props_clouds + public rrtmgp_sw_main_init, rrtmgp_sw_main_run contains @@ -31,8 +37,9 @@ module rrtmgp_sw_main !! \htmlinclude rrtmgp_sw_main_init.html !! subroutine rrtmgp_sw_main_init(rrtmgp_root_dir, rrtmgp_sw_file_gas, rrtmgp_sw_file_clouds,& - active_gases_array, doGP_cldoptics_PADE, doGP_cldoptics_LUT, nrghice, mpicomm, & - mpirank, mpiroot, errmsg, errflg) + active_gases_array, doGP_cldoptics_PADE, doGP_cldoptics_LUT, doGP_sgs_pbl, & + doGP_sgs_cnv, nrghice, mpicomm, mpirank, mpiroot, nLay, rrtmgp_phys_blksz, & + errmsg, errflg) ! Inputs character(len=128),intent(in) :: & @@ -40,16 +47,20 @@ subroutine rrtmgp_sw_main_init(rrtmgp_root_dir, rrtmgp_sw_file_gas, rrtmgp_sw_fi rrtmgp_sw_file_clouds, & ! RRTMGP file containing K-distribution data rrtmgp_sw_file_gas ! RRTMGP file containing cloud-optics data character(len=*), dimension(:), intent(in) :: & - active_gases_array ! List of active gases from namelist as array) + active_gases_array ! List of active gases from namelist as array) logical, intent(in) :: & doGP_cldoptics_PADE, & ! Use RRTMGP cloud-optics: PADE approximation? - doGP_cldoptics_LUT ! Use RRTMGP cloud-optics: LUTs? + doGP_cldoptics_LUT, & ! Use RRTMGP cloud-optics: LUTs? + doGP_sgs_pbl, & ! Flag to include sgs PBL clouds + doGP_sgs_cnv ! Flag to include sgs convective clouds integer, intent(inout) :: & nrghice ! Number of ice-roughness categories integer,intent(in) :: & mpicomm, & ! MPI communicator mpirank, & ! Current MPI rank - mpiroot ! Master MPI rank + mpiroot, & ! Master MPI rank + rrtmgp_phys_blksz, & ! Number of horizontal points to process at once. + nLay ! Outputs character(len=*), intent(out) :: & errmsg ! CCPP error message @@ -69,6 +80,30 @@ subroutine rrtmgp_sw_main_init(rrtmgp_root_dir, rrtmgp_sw_file_gas, rrtmgp_sw_fi doGP_cldoptics_PADE, doGP_cldoptics_LUT, nrghice, mpicomm, mpirank, mpiroot, & errmsg, errflg) + ! DDTs + + ! ty_gas_concs + call check_error_msg('rrtmgp_sw_main_gas_concs_init',gas_concs%init(active_gases_array)) + + ! ty_optical_props + call check_error_msg('rrtmgp_sw_main_accumulated_optics_init',& + sw_optical_props_accum%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props)) + call check_error_msg('rrtmgp_sw_main_cloud_optics_init',& + sw_optical_props_cloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) + call check_error_msg('rrtmgp_sw_main_precip_optics_init',& + sw_optical_props_precipByBand%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) + call check_error_msg('rrtmgp_sw_mian_cloud_sampling_init', & + sw_optical_props_clouds%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props)) + call check_error_msg('rrtmgp_sw_main_aerosol_optics_init',& + sw_optical_props_aerosol_local%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) + if (doGP_sgs_cnv) then + call check_error_msg('rrtmgp_sw_main_cnv_cloud_optics_init',& + sw_optical_props_cnvcloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) + endif + if (doGP_sgs_pbl) then + call check_error_msg('rrtmgp_sw_main_pbl_cloud_optics_init',& + sw_optical_props_pblcloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) + endif end subroutine rrtmgp_sw_main_init ! ######################################################################################### @@ -183,11 +218,6 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ ! Local variables type(cmpfsw_type), dimension(rrtmgp_phys_blksz) :: scmpsw_clrsky, scmpsw_allsky - type(ty_gas_concs) :: gas_concs - type(ty_optical_props_2str) :: sw_optical_props_accum, sw_optical_props_aerosol_local, & - sw_optical_props_cloudsByBand, sw_optical_props_cnvcloudsByBand, & - sw_optical_props_pblcloudsByBand, sw_optical_props_precipByBand, & - sw_optical_props_clouds type(ty_fluxes_byband) :: flux_allsky, flux_clrsky real(kind_phys) :: tau_rain, tau_snow, ssa_rain, ssa_snow, asy_rain, asy_snow, & tau_prec, asy_prec, ssa_prec, asyw, ssaw, za1, za2, flux_dir, flux_dif @@ -202,7 +232,7 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ fluxSW_up_allsky, fluxSW_up_clrsky, fluxSW_dn_dir_clrsky, fluxSW_dn_allsky, & fluxSW_dn_clrsky, fluxSW_dn_dir_allsky integer :: iBand, ibd, ibd_uv, iCol, iGas, iLay, ix, ix2, iblck - integer, dimension(rrtmgp_phys_blksz) :: ipseed_sw + integer, dimension(rrtmgp_phys_blksz) :: ipseed_sw, iCols type(random_stat) :: rng_stat real(kind_phys), dimension(2,sw_gas_props%get_nband()) :: bandlimits real(kind_phys), dimension(2), parameter :: & @@ -219,57 +249,22 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ if (nDay .gt. 0) then bandlimits = sw_gas_props%get_band_lims_wavenumber() - ! ###################################################################################### - ! - ! Allocate/initialize RRTMGP DDT's - ! - ! ###################################################################################### - - ! ty_gas_concs - call check_error_msg('rrtmgp_sw_main_gas_concs_init',gas_concs%init(active_gases_array)) - - ! ty_optical_props - call check_error_msg('rrtmgp_sw_main_accumulated_optics_init',& - sw_optical_props_accum%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props)) - call check_error_msg('rrtmgp_sw_main_cloud_optics_init',& - sw_optical_props_cloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) - call check_error_msg('rrtmgp_sw_main_precip_optics_init',& - sw_optical_props_precipByBand%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) - call check_error_msg('rrtmgp_sw_mian_cloud_sampling_init', & - sw_optical_props_clouds%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props)) - call check_error_msg('rrtmgp_sw_main_aerosol_optics_init',& - sw_optical_props_aerosol_local%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) - if (doGP_sgs_cnv) then - call check_error_msg('rrtmgp_sw_main_cnv_cloud_optics_init',& - sw_optical_props_cnvcloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) - endif - if (doGP_sgs_pbl) then - call check_error_msg('rrtmgp_sw_main_pbl_cloud_optics_init',& - sw_optical_props_pblcloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) - endif - - ! ty_fluxes_byband - flux_allsky%bnd_flux_up => fluxSW_up_allsky - flux_allsky%bnd_flux_dn => fluxSW_dn_allsky - flux_allsky%bnd_flux_dn_dir => fluxSW_dn_dir_allsky - flux_clrsky%bnd_flux_up => fluxSW_up_clrsky - flux_clrsky%bnd_flux_dn => fluxSW_dn_clrsky - ! ###################################################################################### ! ! Loop over all (daylit) columns... ! ! ###################################################################################### do iCol=1,nDay,rrtmgp_phys_blksz - ix = idx(iCol) - ix2 = idx(iCol + rrtmgp_phys_blksz - 1) + !ix = idx(iCol) + !ix2 = idx(iCol + rrtmgp_phys_blksz - 1) + iCols = idx(iCol:iCol + rrtmgp_phys_blksz - 1) ! Create clear/cloudy indicator zcf0(:) = 1._kind_phys zcf1(:) = 1._kind_phys do iblck = 1, rrtmgp_phys_blksz do iLay=1,nLay - zcf0(iblck) = min(zcf0(iblck), 1._kind_phys - cld_frac(ix+iblck-1,iLay)) + zcf0(iblck) = min(zcf0(iblck), 1._kind_phys - cld_frac(iCols(iblck),iLay)) enddo if (zcf0(iblck) <= ftiny) zcf0(iblck) = 0._kind_phys if (zcf0(iblck) > oneminus) zcf0(iblck) = 1._kind_phys @@ -281,11 +276,6 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ ! Initialize/reset ! ! ################################################################################### - fluxSW_up_allsky = 0._kind_phys - fluxSW_dn_allsky = 0._kind_phys - fluxSW_dn_dir_allsky = 0._kind_phys - fluxSW_up_clrsky = 0._kind_phys - fluxSW_dn_clrsky = 0._kind_phys sw_optical_props_clouds%tau = 0._kind_phys sw_optical_props_clouds%ssa = 0._kind_phys sw_optical_props_clouds%g = 0._kind_phys @@ -311,23 +301,35 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ scmpsw_clrsky= cmpfsw_type( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 ) scmpsw_allsky= cmpfsw_type( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 ) + ! ty_fluxes_byband + fluxSW_up_allsky = 0._kind_phys + fluxSW_dn_allsky = 0._kind_phys + fluxSW_dn_dir_allsky = 0._kind_phys + fluxSW_up_clrsky = 0._kind_phys + fluxSW_dn_clrsky = 0._kind_phys + flux_allsky%bnd_flux_up => fluxSW_up_allsky + flux_allsky%bnd_flux_dn => fluxSW_dn_allsky + flux_allsky%bnd_flux_dn_dir => fluxSW_dn_dir_allsky + flux_clrsky%bnd_flux_up => fluxSW_up_clrsky + flux_clrsky%bnd_flux_dn => fluxSW_dn_clrsky + ! ################################################################################### ! ! Set gas-concentrations ! ! ################################################################################### call check_error_msg('rrtmgp_sw_main_set_vmr_o2', & - gas_concs%set_vmr(trim(active_gases_array(istr_o2)), vmr_o2(ix:ix2,:))) + gas_concs%set_vmr(trim(active_gases_array(istr_o2)), vmr_o2(iCols,:))) call check_error_msg('rrtmgp_sw_main_set_vmr_co2', & - gas_concs%set_vmr(trim(active_gases_array(istr_co2)),vmr_co2(ix:ix2,:))) + gas_concs%set_vmr(trim(active_gases_array(istr_co2)),vmr_co2(iCols,:))) call check_error_msg('rrtmgp_sw_main_set_vmr_ch4', & - gas_concs%set_vmr(trim(active_gases_array(istr_ch4)),vmr_ch4(ix:ix2,:))) + gas_concs%set_vmr(trim(active_gases_array(istr_ch4)),vmr_ch4(iCols,:))) call check_error_msg('rrtmgp_sw_main_set_vmr_n2o', & - gas_concs%set_vmr(trim(active_gases_array(istr_n2o)),vmr_n2o(ix:ix2,:))) + gas_concs%set_vmr(trim(active_gases_array(istr_n2o)),vmr_n2o(iCols,:))) call check_error_msg('rrtmgp_sw_main_set_vmr_h2o', & - gas_concs%set_vmr(trim(active_gases_array(istr_h2o)),vmr_h2o(ix:ix2,:))) + gas_concs%set_vmr(trim(active_gases_array(istr_h2o)),vmr_h2o(iCols,:))) call check_error_msg('rrtmgp_sw_main_set_vmr_o3', & - gas_concs%set_vmr(trim(active_gases_array(istr_o3)), vmr_o3(ix:ix2,:))) + gas_concs%set_vmr(trim(active_gases_array(istr_o3)), vmr_o3(iCols,:))) ! ################################################################################### ! @@ -336,9 +338,9 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ ! ################################################################################### call check_error_msg('rrtmgp_sw_main_gas_optics',sw_gas_props%gas_optics(& - p_lay(ix:ix2,:), & ! IN - Pressure @ layer-centers (Pa) - p_lev(ix:ix2,:), & ! IN - Pressure @ layer-interfaces (Pa) - t_lay(ix:ix2,:), & ! IN - Temperature @ layer-centers (K) + p_lay(iCols,:), & ! IN - Pressure @ layer-centers (Pa) + p_lev(iCols,:), & ! IN - Pressure @ layer-interfaces (Pa) + t_lay(iCols,:), & ! IN - Temperature @ layer-centers (K) gas_concs, & ! IN - RRTMGP DDT: trace gas volumne mixing-ratios sw_optical_props_accum, & ! OUT - RRTMGP DDT: Shortwave optical properties, by ! spectral point (tau,ssa,g) @@ -360,19 +362,19 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ do iblck = 1, rrtmgp_phys_blksz do iBand=1,sw_gas_props%get_nband() if (bandlimits(1,iBand) .lt. nIR_uvvis_bnd(1)) then - sfc_alb_dir(iBand,iblck) = sfc_alb_nir_dir(ix+iblck-1) - sfc_alb_dif(iBand,iblck) = sfc_alb_nir_dif(ix+iblck-1) + sfc_alb_dir(iBand,iblck) = sfc_alb_nir_dir(iCols(iblck)) + sfc_alb_dif(iBand,iblck) = sfc_alb_nir_dif(iCols(iblck)) endif if (bandlimits(1,iBand) .eq. nIR_uvvis_bnd(1)) then - sfc_alb_dir(iBand,iblck) = 0.5_kind_phys*(sfc_alb_nir_dir(ix+iblck-1) + & - sfc_alb_uvvis_dir(ix+iblck-1)) - sfc_alb_dif(iBand,iblck) = 0.5_kind_phys*(sfc_alb_nir_dif(ix+iblck-1) + & - sfc_alb_uvvis_dif(ix+iblck-1)) + sfc_alb_dir(iBand,iblck) = 0.5_kind_phys*(sfc_alb_nir_dir(iCols(iblck)) + & + sfc_alb_uvvis_dir(iCols(iblck))) + sfc_alb_dif(iBand,iblck) = 0.5_kind_phys*(sfc_alb_nir_dif(iCols(iblck)) + & + sfc_alb_uvvis_dif(iCols(iblck))) ibd = iBand endif if (bandlimits(1,iBand) .ge. nIR_uvvis_bnd(2)) then - sfc_alb_dir(iBand,iblck) = sfc_alb_uvvis_dir(ix+iblck-1) - sfc_alb_dif(iBand,iblck) = sfc_alb_uvvis_dif(ix+iblck-1) + sfc_alb_dir(iBand,iblck) = sfc_alb_uvvis_dir(iCols(iblck)) + sfc_alb_dif(iBand,iblck) = sfc_alb_uvvis_dif(iCols(iblck)) endif if (bandlimits(1,iBand) .eq. uvb_bnd(1)) ibd_uv = iBand enddo @@ -386,22 +388,22 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ if (any(zcf1 .gt. eps)) then ! Gridmean/mp-clouds call check_error_msg('rrtmgp_sw_main_cloud_optics',sw_cloud_props%cloud_optics(& - cld_lwp(ix:ix2,:), & ! IN - Cloud liquid water path - cld_iwp(ix:ix2,:), & ! IN - Cloud ice water path - cld_reliq(ix:ix2,:), & ! IN - Cloud liquid effective radius - cld_reice(ix:ix2,:), & ! IN - Cloud ice effective radius + cld_lwp(iCols,:), & ! IN - Cloud liquid water path + cld_iwp(iCols,:), & ! IN - Cloud ice water path + cld_reliq(iCols,:), & ! IN - Cloud liquid effective radius + cld_reice(iCols,:), & ! IN - Cloud ice effective radius sw_optical_props_cloudsByBand)) ! OUT - RRTMGP DDT: Shortwave optical properties, ! in each band (tau,ssa,g) - cldtausw(ix:ix2,:) = sw_optical_props_cloudsByBand%tau(:,:,11) + cldtausw(iCols,:) = sw_optical_props_cloudsByBand%tau(:,:,11) ! Include convective clouds? if (doGP_sgs_cnv) then ! Compute call check_error_msg('rrtmgp_sw_main_cnv_cloud_optics',sw_cloud_props%cloud_optics(& - cld_cnv_lwp(ix:ix2,:), & ! IN - Convective cloud liquid water path (g/m2) - cld_cnv_iwp(ix:ix2,:), & ! IN - Convective cloud ice water path (g/m2) - cld_cnv_reliq(ix:ix2,:), & ! IN - Convective cloud liquid effective radius (microns) - cld_cnv_reice(ix:ix2,:), & ! IN - Convective cloud ice effective radius (microns) + cld_cnv_lwp(iCols,:), & ! IN - Convective cloud liquid water path (g/m2) + cld_cnv_iwp(iCols,:), & ! IN - Convective cloud ice water path (g/m2) + cld_cnv_reliq(iCols,:), & ! IN - Convective cloud liquid effective radius (microns) + cld_cnv_reice(iCols,:), & ! IN - Convective cloud ice effective radius (microns) sw_optical_props_cnvcloudsByBand)) ! OUT - RRTMGP DDT containing convective cloud radiative properties ! in each band ! Increment @@ -413,10 +415,10 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ if (doGP_sgs_pbl) then ! Compute call check_error_msg('rrtmgp_sw_main_pbl_cloud_optics',sw_cloud_props%cloud_optics(& - cld_pbl_lwp(ix:ix2,:), & ! IN - PBL cloud liquid water path (g/m2) - cld_pbl_iwp(ix:ix2,:), & ! IN - PBL cloud ice water path (g/m2) - cld_pbl_reliq(ix:ix2,:), & ! IN - PBL cloud liquid effective radius (microns) - cld_pbl_reice(ix:ix2,:), & ! IN - PBL cloud ice effective radius (microns) + cld_pbl_lwp(iCols,:), & ! IN - PBL cloud liquid water path (g/m2) + cld_pbl_iwp(iCols,:), & ! IN - PBL cloud ice water path (g/m2) + cld_pbl_reliq(iCols,:), & ! IN - PBL cloud liquid effective radius (microns) + cld_pbl_reice(iCols,:), & ! IN - PBL cloud ice effective radius (microns) sw_optical_props_pblcloudsByBand)) ! OUT - RRTMGP DDT containing PBL cloud radiative properties ! in each band ! Increment @@ -427,11 +429,11 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ ! Cloud precipitation optics: rain and snow(+groupel) do iblck = 1, rrtmgp_phys_blksz do iLay=1,nLay - if (cld_frac(ix+iblck-1,iLay) .gt. ftiny) then + if (cld_frac(iCols(iblck),iLay) .gt. ftiny) then ! Rain/Snow optical depth (No band dependence) - tau_rain = cld_rwp(ix+iblck-1,iLay)*a0r - if (cld_swp(ix+iblck-1,iLay) .gt. 0. .and. cld_resnow(ix+iblck-1,iLay) .gt. 10._kind_phys) then - tau_snow = cld_swp(ix+iblck-1,iLay)*1.09087*(a0s + a1s/(1.0315*cld_resnow(ix+iblck-1,iLay))) ! fu's formula + tau_rain = cld_rwp(iCols(iblck),iLay)*a0r + if (cld_swp(iCols(iblck),iLay) .gt. 0. .and. cld_resnow(iCols(iblck),iLay) .gt. 10._kind_phys) then + tau_snow = cld_swp(iCols(iblck),iLay)*1.09087*(a0s + a1s/(1.0315*cld_resnow(iCols(iblck),iLay))) ! fu's formula else tau_snow = 0._kind_phys endif @@ -441,7 +443,7 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ ! By species ssa_rain = tau_rain*(1.-b0r(iBand)) asy_rain = ssa_rain*c0r(iBand) - ssa_snow = tau_snow*(1.-(b0s(iBand)+b1s(iBand)*1.0315*cld_resnow(ix+iblck-1,iLay))) + ssa_snow = tau_snow*(1.-(b0s(iBand)+b1s(iBand)*1.0315*cld_resnow(iCols(iblck),iLay))) asy_snow = ssa_snow*c0s(iBand) ! Combine tau_prec = max(1.e-12_kind_phys, tau_rain + tau_snow) @@ -470,11 +472,11 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ ! Change random number seed value for each radiation invocation (isubc_sw =1 or 2). if(isubc_sw == 1) then ! advance prescribed permutation seed do iblck = 1, rrtmgp_phys_blksz - ipseed_sw(iblck) = sw_gas_props%get_ngpt() + iCol + iblck - 1 + ipseed_sw(iblck) = sw_gas_props%get_ngpt() + iCols(iblck) enddo elseif (isubc_sw == 2) then ! use input array of permutaion seeds do iblck = 1, rrtmgp_phys_blksz - ipseed_sw(iblck) = icseed_sw(ix+iblck-1) + ipseed_sw(iblck) = icseed_sw(iCols(iblck)) enddo endif @@ -498,7 +500,7 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ ! Cloud-overlap. ! Maximum-random, random or maximum. if (iovr == iovr_maxrand .or. iovr == iovr_rand .or. iovr == iovr_max) then - call sampled_mask(rng3D, cld_frac(ix:ix2,:), maskMCICA) + call sampled_mask(rng3D, cld_frac(iCols,:), maskMCICA) endif ! Exponential decorrelation length overlap if (iovr == iovr_dcorr) then @@ -509,13 +511,13 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ rng3D2(:,:,iblck) = reshape(source = rng2D,shape=[sw_gas_props%get_ngpt(),nLay]) enddo ! - call sampled_mask(rng3D, cld_frac(ix:ix2,:), maskMCICA, & - overlap_param = cloud_overlap_param(ix:ix2,1:nLay-1), randoms2 = rng3D2) + call sampled_mask(rng3D, cld_frac(iCols,:), maskMCICA, & + overlap_param = cloud_overlap_param(iCols,1:nLay-1), randoms2 = rng3D2) endif ! Exponential or Exponential-random if (iovr == iovr_exp .or. iovr == iovr_exprand) then - call sampled_mask(rng3D, cld_frac(ix:ix2,:), maskMCICA, & - overlap_param = cloud_overlap_param(ix:ix2,1:nLay-1)) + call sampled_mask(rng3D, cld_frac(iCols,:), maskMCICA, & + overlap_param = cloud_overlap_param(iCols,1:nLay-1)) endif ! Sampling. Map band optical depth to each g-point using McICA call check_error_msg('rrtmgp_sw_main_cloud_sampling',& @@ -529,9 +531,9 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ ! ! ################################################################################### ! Increment - sw_optical_props_aerosol_local%tau = aersw_tau(iCol:iCol+rrtmgp_phys_blksz-1,:,:) - sw_optical_props_aerosol_local%ssa = aersw_ssa(iCol:iCol+rrtmgp_phys_blksz-1,:,:) - sw_optical_props_aerosol_local%g = aersw_g(iCol:iCol+rrtmgp_phys_blksz-1,:,:) + sw_optical_props_aerosol_local%tau = aersw_tau(iCols,:,:) + sw_optical_props_aerosol_local%ssa = aersw_ssa(iCols,:,:) + sw_optical_props_aerosol_local%g = aersw_g(iCols,:,:) call check_error_msg('rrtmgp_sw_main_increment_aerosol_to_clrsky', & sw_optical_props_aerosol_local%increment(sw_optical_props_accum)) @@ -542,15 +544,15 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ call check_error_msg('rrtmgp_sw_main_rte_sw_clrsky',rte_sw( & sw_optical_props_accum, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag - coszen(ix:ix2), & ! IN - Cosine of solar zenith angle + coszen(iCols), & ! IN - Cosine of solar zenith angle toa_src_sw, & ! IN - incident solar flux at TOA sfc_alb_dir, & ! IN - Shortwave surface albedo (direct) sfc_alb_dif, & ! IN - Shortwave surface albedo (diffuse) flux_clrsky)) ! OUT - Fluxes, clear-sky, 3D (1,nLay,nBand) ! Store fluxes - fluxswUP_clrsky(ix:ix2,:) = sum(flux_clrsky%bnd_flux_up, dim=3) - fluxswDOWN_clrsky(ix:ix2,:) = sum(flux_clrsky%bnd_flux_dn, dim=3) + fluxswUP_clrsky(iCols,:) = sum(flux_clrsky%bnd_flux_up, dim=3) + fluxswDOWN_clrsky(iCols,:) = sum(flux_clrsky%bnd_flux_dn, dim=3) ! Compute surface downward beam/diffused flux components do iblck = 1, rrtmgp_phys_blksz @@ -596,15 +598,15 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ call check_error_msg('rrtmgp_sw_main_rte_sw_allsky',rte_sw( & sw_optical_props_accum, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag - coszen(ix:ix2), & ! IN - Cosine of solar zenith angle + coszen(iCols), & ! IN - Cosine of solar zenith angle toa_src_sw, & ! IN - incident solar flux at TOA sfc_alb_dir, & ! IN - Shortwave surface albedo (direct) sfc_alb_dif, & ! IN - Shortwave surface albedo (diffuse) flux_allsky)) ! OUT - Fluxes, clear-sky, 3D (1,nLay,nBand) ! Store fluxes - fluxswUP_allsky(ix:ix2,:) = sum(flux_allsky%bnd_flux_up, dim=3) - fluxswDOWN_allsky(ix:ix2,:) = sum(flux_allsky%bnd_flux_dn, dim=3) + fluxswUP_allsky(iCols,:) = sum(flux_allsky%bnd_flux_up, dim=3) + fluxswDOWN_allsky(iCols,:) = sum(flux_allsky%bnd_flux_dn, dim=3) ! Compute and store downward beam/diffused flux components do iblck = 1, rrtmgp_phys_blksz @@ -634,30 +636,30 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ enddo ! Store surface downward beam/diffused flux components if (zcf1(iblck) .gt. eps) then - scmpsw(ix+iblck-1)%nirbm = scmpsw_allsky(iblck)%nirbm - scmpsw(ix+iblck-1)%nirdf = scmpsw_allsky(iblck)%nirdf - scmpsw(ix+iblck-1)%visbm = scmpsw_allsky(iblck)%visbm - scmpsw(ix+iblck-1)%visdf = scmpsw_allsky(iblck)%visdf - scmpsw(ix+iblck-1)%uvbfc = flux_allsky%bnd_flux_dn(iblck,iSFC,ibd_uv) + scmpsw(iCols(iblck))%nirbm = scmpsw_allsky(iblck)%nirbm + scmpsw(iCols(iblck))%nirdf = scmpsw_allsky(iblck)%nirdf + scmpsw(iCols(iblck))%visbm = scmpsw_allsky(iblck)%visbm + scmpsw(iCols(iblck))%visdf = scmpsw_allsky(iblck)%visdf + scmpsw(iCols(iblck))%uvbfc = flux_allsky%bnd_flux_dn(iblck,iSFC,ibd_uv) else - scmpsw(ix+iblck-1)%nirbm = scmpsw_clrsky(iblck)%nirbm - scmpsw(ix+iblck-1)%nirdf = scmpsw_clrsky(iblck)%nirdf - scmpsw(ix+iblck-1)%visbm = scmpsw_clrsky(iblck)%visbm - scmpsw(ix+iblck-1)%visdf = scmpsw_clrsky(iblck)%visdf - scmpsw(ix+iblck-1)%uvbfc = flux_clrsky%bnd_flux_dn(iblck,iSFC,ibd_uv) + scmpsw(iCols(iblck))%nirbm = scmpsw_clrsky(iblck)%nirbm + scmpsw(iCols(iblck))%nirdf = scmpsw_clrsky(iblck)%nirdf + scmpsw(iCols(iblck))%visbm = scmpsw_clrsky(iblck)%visbm + scmpsw(iCols(iblck))%visdf = scmpsw_clrsky(iblck)%visdf + scmpsw(iCols(iblck))%uvbfc = flux_clrsky%bnd_flux_dn(iblck,iSFC,ibd_uv) endif - scmpsw(ix+iblck-1)%uvbf0 = flux_clrsky%bnd_flux_dn(iblck,iSFC,ibd_uv) + scmpsw(iCols(iblck))%uvbf0 = flux_clrsky%bnd_flux_dn(iblck,iSFC,ibd_uv) enddo else ! No clouds - fluxswUP_allsky(ix:ix2,:) = sum(flux_clrsky%bnd_flux_up, dim=3) - fluxswDOWN_allsky(ix:ix2,:) = sum(flux_clrsky%bnd_flux_dn, dim=3) + fluxswUP_allsky(iCols,:) = sum(flux_clrsky%bnd_flux_up, dim=3) + fluxswDOWN_allsky(iCols,:) = sum(flux_clrsky%bnd_flux_dn, dim=3) do iblck = 1, rrtmgp_phys_blksz - scmpsw(ix+iblck-1)%nirbm = scmpsw_clrsky(iblck)%nirbm - scmpsw(ix+iblck-1)%nirdf = scmpsw_clrsky(iblck)%nirdf - scmpsw(ix+iblck-1)%visbm = scmpsw_clrsky(iblck)%visbm - scmpsw(ix+iblck-1)%visdf = scmpsw_clrsky(iblck)%visdf - scmpsw(ix+iblck-1)%uvbfc = flux_clrsky%bnd_flux_dn(iblck,iSFC,ibd_uv) - scmpsw(ix+iblck-1)%uvbf0 = flux_clrsky%bnd_flux_dn(iblck,iSFC,ibd_uv) + scmpsw(iCols(iblck))%nirbm = scmpsw_clrsky(iblck)%nirbm + scmpsw(iCols(iblck))%nirdf = scmpsw_clrsky(iblck)%nirdf + scmpsw(iCols(iblck))%visbm = scmpsw_clrsky(iblck)%visbm + scmpsw(iCols(iblck))%visdf = scmpsw_clrsky(iblck)%visdf + scmpsw(iCols(iblck))%uvbfc = flux_clrsky%bnd_flux_dn(iblck,iSFC,ibd_uv) + scmpsw(iCols(iblck))%uvbf0 = flux_clrsky%bnd_flux_dn(iblck,iSFC,ibd_uv) enddo endif ! diff --git a/physics/rrtmgp_sw_main.meta b/physics/rrtmgp_sw_main.meta index 78e435c96..c0be1658f 100644 --- a/physics/rrtmgp_sw_main.meta +++ b/physics/rrtmgp_sw_main.meta @@ -57,6 +57,34 @@ dimensions = () type = integer intent = inout +[doGP_sgs_cnv] + standard_name = flag_to_include_sgs_convective_cloud_in_RRTMGP + long_name = logical flag to control sgs convective cloud in RRTMGP + units = flag + dimensions = () + type = logical + intent = in +[doGP_sgs_pbl] + standard_name = flag_to_include_sgs_MYNN_EDMF_cloud_in_RRTMGP + long_name = logical flag to control MYNN-EDMF PBL cloud in RRTMGP + units = flag + dimensions = () + type = logical + intent = in +[rrtmgp_phys_blksz] + standard_name = number_of_columns_per_RRTMGP_SW_block + long_name = number of columns to process at a time by RRTMGP SW scheme + units = count + dimensions = () + type = integer + intent = in +[nLay] + standard_name = vertical_layer_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in [mpirank] standard_name = mpi_rank long_name = current MPI rank @@ -163,8 +191,8 @@ type = integer intent = in [rrtmgp_phys_blksz] - standard_name = number_of_columns_per_RRTMGP_block - long_name = number of columns to process ata time by RRTMGP + standard_name = number_of_columns_per_RRTMGP_SW_block + long_name = number of columns to process at a time by RRTMGP SW scheme units = count dimensions = () type = integer From 789ddb933c1e4ca238a31cabd8a26901230e972a Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Tue, 11 Oct 2022 18:48:53 +0000 Subject: [PATCH 051/380] several fixes to initialization --- physics/clm_lake.f90 | 247 ++++++++++++++++++++---------------------- physics/clm_lake.meta | 29 ++++- physics/sfc_diag.f | 4 +- 3 files changed, 146 insertions(+), 134 deletions(-) diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90 index c46642b1d..97cbe025f 100644 --- a/physics/clm_lake.f90 +++ b/physics/clm_lake.f90 @@ -123,9 +123,11 @@ MODULE clm_lake real(kind_phys) :: dzsoi(1:nlevsoil) !soil dz (thickness) real(kind_phys) :: zisoi(0:nlevsoil) !soil zi (interfaces) - real, parameter :: SaltLk_T(1:25) = (/0.5, 0.,-0.5, 3., 4., 7., 8., 12., 13., 16., 19., 21., & - 23.5, 25.,26.,24.,23.,20.5,18.,15., 11.5, 8., 4., 1., 0.5/) + real, parameter :: SaltLk_T(1:25) = (/ 0.5, 0.,-0.5, 3., 4., 7., 8., 12., 13., 16., 19., 21., & + 23.5, 25., 26.,24.,23.,20.5,18., 15., 11.5, 8., 4., 1., 0.5/) + real, parameter :: month_length(12) = (/ 31, 29, 31, 30, 31, 30, 31, 30, 30, 31, 30, 31 /) real, parameter :: julm(1:13) = (/0,31,59,90,120,151,181,212,243,273,304,334,365/) + logical, parameter :: include_all_salty_locations = .false. CONTAINS @@ -226,6 +228,7 @@ logical function is_salty(xlat_d,xlon_positive) is_salty=limit_temperature_by_climatology(xlat_d,xlon_d) + if(include_all_salty_locations) then ! --- The Mono Lake in California, salinity is 75 ppt with freezing point at ! --- -4.2 C (Stan). The Mono Lake lat/long (37.9-38.2, -119.3 - 118.8) if (xlon_d.gt.-119.3.and. xlon_d.lt.-118.8) then @@ -250,7 +253,7 @@ logical function is_salty(xlat_d,xlon_positive) endif is_salty = .true. endif - + endif !tgs --- end of special treatment for salty lakes end function is_salty @@ -263,9 +266,9 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& gt0 ,prsi ,con_rd,con_g ,qvcurr ,& !i gu0 ,gv0 ,dlwsfci ,emiss ,& rain ,dtp ,dswsfci ,albedo ,& - xlat_d ,z_lake3d ,dz_lake3d ,lakedepth2d ,& + xlat_d ,z_lake3d ,dz_lake3d ,oro_lakedepth ,& watsat3d ,csol3d ,tkmg3d ,tkdry3d ,& - tksatu3d ,phii ,& + tksatu3d ,wet ,phii ,clm_lakedepth ,& fice ,min_lakeice ,im,km ,& h2osno2d ,snowdp2d ,snl2d ,z3d ,& !h dz3d ,zi3d ,h2osoi_vol3d ,h2osoi_liq3d ,& @@ -276,7 +279,7 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& hflx ,evap ,grdflx ,tsfc ,& !o lake_t2m ,lake_q2m ,clm_lake_initialized ,& weasd ,isltyp ,snowd ,use_lakedepth ,& - restart ,lakedepth_default ,& + restart ,lakedepth_default ,pgr ,& zorlw ,zorli ,sand3d ,clay3d ,& ! Flake output variables weasdi ,snodi ,hice ,tsurf ,& @@ -304,10 +307,10 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& LOGICAL, INTENT(IN) :: restart,use_lakedepth,first_time_step REAL(KIND_PHYS), INTENT(INOUT) :: clm_lake_initialized(:) REAL(KIND_PHYS), INTENT(IN) :: min_lakeice, con_rd,con_g,con_cp,lakedepth_default, fhour - logical, intent(inout) :: icy(:) + logical, intent(inout) :: icy(:), wet(:) REAL(KIND_PHYS), DIMENSION( : ), INTENT(INOUT):: fice - REAL(KIND_PHYS), DIMENSION( : ), INTENT(IN) :: weasd, snowd - REAL(KIND_PHYS), DIMENSION( : ), INTENT(IN):: tg3 + REAL(KIND_PHYS), DIMENSION( : ), INTENT(INOUT) :: weasd, snowd + REAL(KIND_PHYS), DIMENSION( : ), INTENT(IN):: tg3, pgr REAL(KIND_PHYS), DIMENSION( : ), INTENT(IN) :: ZLVL INTEGER, DIMENSION(:), INTENT(IN) :: use_lake_model @@ -343,7 +346,8 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& REAL(KIND_PHYS), DIMENSION( :,: ),INTENT(INOUT) :: tkmg3d REAL(KIND_PHYS), DIMENSION( :,: ),INTENT(INOUT) :: tkdry3d REAL(KIND_PHYS), DIMENSION( :,: ),INTENT(INOUT) :: tksatu3d - REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(INOUT) :: lakedepth2d + REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(INOUT) :: clm_lakedepth + REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(IN ) :: oro_lakedepth !feedback to atmosphere: REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(OUT) :: hflx @@ -464,6 +468,9 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& ! The latitude and longitude of unhappy points. real(kind_phys), allocatable, save :: unhappy_lat(:),unhappy_lon(:) + integer :: month,num1,num2,day_of_month + real(kind_phys) :: wght1,wght2,Tclim + errmsg = ' ' errflg = 0 @@ -498,18 +505,18 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& endif ! Still have some points to initialize - call lakeini(kdt, ISLTYP, gt0, snowd, & !i + call lakeini(kdt, ISLTYP, gt0, snowd, & weasd, restart, lakedepth_default, fhour, & - lakedepth2d, savedtke12d, snowdp2d, h2osno2d, & !o + oro_lakedepth, savedtke12d, snowdp2d, h2osno2d, & snl2d, t_grnd2d, t_lake3d, lake_icefrac3d, & z_lake3d, dz_lake3d, t_soisno3d, h2osoi_ice3d, & h2osoi_liq3d, h2osoi_vol3d, z3d, dz3d, & zi3d, watsat3d, csol3d, tkmg3d, & - IDATE, fice, min_lakeice, tsfc, & + fice, min_lakeice, tsfc, & use_lake_model, use_lakedepth, con_g, con_rd, & tkdry3d, tksatu3d, im, prsi, & xlat_d, xlon_d, clm_lake_initialized, & - sand3d, clay3d, tg3, & + sand3d, clay3d, tg3, clm_lakedepth, & km, me, master, errmsg, errflg) if(errflg/=0) then return @@ -531,6 +538,28 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& snow_points=0 ice_points=0 + month = IDATE(2) + day_of_month = IDATE(3) + + num1 = month*2-1 + if(day_of_month>15) then + num1 = num1 + 1 + endif + num2 = num1+1 + + wght2 = day_of_month/month_length(month) + if(wght2<0 .or. wght2>1) then + if(lakedebug) then + write(0,*) 'Warning: wght2 is not 0..1: ',wght2 + endif + wght2 = max(0.0_kind_phys,min(1.0_kind_phys,wght2)) + endif + wght1 = 1.0_kind_phys - wght2 + + if(LAKEDEBUG .and. me==0) then + print *,'month,num1,num2,wght1,wght2',month,num1,num2,wght1,wght2 + endif + lake_top_loop: DO I = 1,im if_lake_is_here: if (flag_iter(i) .and. use_lake_model(i)/=0) THEN @@ -541,9 +570,21 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& salty(i) = 0 endif + if(salty(i)/=0) then + Tclim = tfrz + wght1*saltlk_T(num1) & + + wght2*saltlk_T(num2) + if(lakedebug) print *,'Tclim,tsfc,t_lake3d',i,Tclim,tsfc(i),t_lake3d(i,:),t_soisno3d(i,:) + t_grnd2d(i) = min(Tclim+3.0_kind_phys,(max(tsfc(i),Tclim-3.0_kind_phys))) + do k = 1,nlevlake + t_lake3d(i,k) = min(Tclim+3.0_kind_phys,(max(t_lake3d(i,k),Tclim-3.0_kind_phys))) + enddo + t_soisno3d(i,1) = min(Tclim+3.0_kind_phys,(max(t_soisno3d(i,1),Tclim-3.0_kind_phys))) + if(lakedebug) print *,'After Tclim,tsfc,t_lake3d',i,Tclim,tsfc(i),t_lake3d(i,:),t_soisno3d(i,:) + endif + SFCTMP = gt0(i,1) - PBOT = prsi(i,2) - PSFC = prsi(i,1) + PBOT = prsi(i,1) + PSFC = pgr(i) Q2K = qvcurr(i) LWDN = DLWSFCI(I)*EMISS(I) PRCP = RAIN(i)/dtime ! [mm/s] use physics timestep since PRCP comes from non-surface schemes @@ -571,7 +612,7 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& lat(c) = XLAT_D(I)*pi/180 ! [radian] do_capsnow(c) = .false. - lakedepth(c) = lakedepth2d(i) + lakedepth(c) = clm_lakedepth(i) savedtke1(c) = savedtke12d(i) snowdp(c) = snowdp2d(i) h2osno(c) = h2osno2d(i) @@ -691,7 +732,7 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& ! No equivalent in CCPP: ! LH(I) = eflx_lh_tot(c)/rho1(i) ![kg*m/(kg*s)] - + !-- The CLM output is combined for fractional ice and water if( t_grnd(c) >= tfrz ) then qfx = eflx_lh_tot(c)/hvap else @@ -709,12 +750,19 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& albedo(i) = ( 0.6 * lake_icefrac3d(i,1) ) + ( (1.0-lake_icefrac3d(i,1)) * 0.08) fice(i) = lake_icefrac3d(i,1) + zorlw(i) = z0mg(c) + if(fice(i)>=min_lakeice) then weasdi(i) = h2osno(c) ! water_equivalent_accumulated_snow_depth_over_ice snodi(i) = snowdp(c) ! surface_snow_thickness_water_equivalent_over_ice tisfc(i) = t_grnd(c) ! surface_skin_temperature_over_ice tsurf_ice(i) = t_grnd(c) ! surface_skin_temperature_after_iteration_over_ice icy(i)=.true. + if(fice(i)==1.) then + wet(i) = .false. + else + wet(i) = .true. + endif ice_points = ice_points+1 zorli(i) = z0mg(c) @@ -727,12 +775,14 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& endif end do else - zorlw(i) = z0mg(c) + icy(i)=.false. + wet(i)=.true. weasdi(i) = 0 snodi(i) = 0 tisfc(i) = tsurf(i) tsurf_ice(i) = tisfc(i) hice(i) = 0 + fice(i) = 0 endif if(snl2d(i)<0) then @@ -752,7 +802,7 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& discard3 = -9999 call QSat(t_grnd(c),psfc,discard1,discard2,qsfc(i),discard3) - ! From flake driver: + ! From flake driver - combined ice/water: chh(i)=ch(i)*wind(i)*1.225 ! surface_drag_mass_flux_for_heat_and_moisture_in_air_over_water cmm(i)=cm(i)*wind(i) ! surface_drag_wind_speed_for_momentum_in_air_over_water @@ -5293,16 +5343,16 @@ end subroutine clm_lake_init ! Some fields in lakeini are not available until runtime, so this cannot be in a CCPP init routine. SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, & !i weasd, restart, lakedepth_default, fhour, & - lakedepth2d, savedtke12d, snowdp2d, h2osno2d, & !o + oro_lakedepth, savedtke12d, snowdp2d, h2osno2d, & !o snl2d, t_grnd2d, t_lake3d, lake_icefrac3d, & z_lake3d, dz_lake3d, t_soisno3d, h2osoi_ice3d, & h2osoi_liq3d, h2osoi_vol3d, z3d, dz3d, & zi3d, watsat3d, csol3d, tkmg3d, & - IDATE, fice, min_lakeice, tsfc, & + fice, min_lakeice, tsfc, & use_lake_model, use_lakedepth, con_g, con_rd, & tkdry3d, tksatu3d, im, prsi, & xlat_d, xlon_d, clm_lake_initialized, & - sand3d, clay3d, tg3, & + sand3d, clay3d, tg3, clm_lakedepth, & km, me, master, errmsg, errflg) !============================================================================== @@ -5316,9 +5366,10 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, INTEGER, INTENT(OUT) :: errflg CHARACTER(*), INTENT(OUT) :: errmsg - INTEGER , INTENT (IN) :: im, me, master, km, kdt, IDATE(4) + INTEGER , INTENT (IN) :: im, me, master, km, kdt REAL(KIND_PHYS), INTENT(IN) :: min_lakeice, con_g, con_rd, fhour - REAL(KIND_PHYS), DIMENSION(IM), INTENT(IN):: FICE,TG3, xlat_d, xlon_d + REAL(KIND_PHYS), DIMENSION(IM), INTENT(INOUT):: FICE + REAL(KIND_PHYS), DIMENSION(IM), INTENT(IN):: TG3, xlat_d, xlon_d REAL(KIND_PHYS), DIMENSION(IM), INTENT(IN):: tsfc REAL(KIND_PHYS), DIMENSION(IM) ,INTENT(INOUT) :: clm_lake_initialized integer, dimension(IM), intent(in) :: use_lake_model @@ -5328,11 +5379,12 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, LOGICAL , INTENT(IN) :: restart INTEGER, DIMENSION(IM), INTENT(IN) :: ISLTYP - REAL(KIND_PHYS), DIMENSION(IM), INTENT(IN) :: snowd,weasd + REAL(KIND_PHYS), DIMENSION(IM), INTENT(INOUT) :: snowd,weasd REAL(kind_phys), DIMENSION(IM,KM), INTENT(IN) :: gt0, prsi real(kind_phys), intent(in) :: lakedepth_default - real(kind_phys), dimension(IM),intent(inout) :: lakedepth2d + real(kind_phys), dimension(IM),intent(inout) :: clm_lakedepth + real(kind_phys), dimension(IM),intent(in) :: oro_lakedepth real(kind_phys), dimension(IM),intent(out) :: savedtke12d real(kind_phys), dimension(IM),intent(out) :: snowdp2d, & h2osno2d, & @@ -5393,67 +5445,39 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, integer :: used_lakedepth_default, init_points, month, julday integer :: mon, iday, num2, num1, juld, day2, day1, wght1, wght2 real(kind_phys) :: Tclim - logical :: have_date used_lakedepth_default=0 - have_date=.false. errmsg = '' errflg = 0 - if(LAKEDEBUG .and. me==0) then - print *,'month,num1,num2,day1,day2,wght1,wght2',month,num1,num2,day1,day2,wght1,wght2 - endif - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!!!!begin to initialize lake variables!!!!!!!!!!!!!!!!!! - do_init_part1: DO i=1,im - if(use_lake_model(i)==0) then + init_points=0 + do_init: DO i=1,im + if(use_lake_model(i)==0 .or. clm_lake_initialized(i)>0) then cycle endif - if(kdt<2) then ! To handle restarts with bad lakedepth2d if ( use_lakedepth ) then - if (lakedepth2d(i) <= 0.0) then - lakedepth2d(i) = lakedepth_default + if (oro_lakedepth(i) == 10.0 .or. oro_lakedepth(i) <= 0.) then + !- 10.0 is the fill value for lake depth, in this case set to default value + clm_lakedepth(i) = lakedepth_default used_lakedepth_default = used_lakedepth_default+1 + else + clm_lakedepth(i) = oro_lakedepth(i) endif else - lakedepth2d(i) = lakedepth_default + !- all lakes are initialized with the default lake depth + clm_lakedepth(i) = lakedepth_default used_lakedepth_default = used_lakedepth_default+1 endif - endif if(clm_lake_initialized(i)>0) then cycle endif - if(.not.have_date) then - !$OMP CRITICAL - call get_month_and_day(IDATE,month,iday,julday,fhour) - !$OMP END CRITICAL - - have_date = .true. - - !-- Compute weight for the current day - mon = month - if(iday > 15) mon=mon+1 - if(mon == 1) mon=13 - - num2 = month * 2 - if(iday > 15) num2=num2+1 - if(num2 == 1) num2=25 - num1 = num2 - 1 - - juld = julday - if (juld < 7) juld = juld + 365 - day2 = julm(mon)+15 - day1 = julm(mon) - wght1=(day2-julday)/float(day2-day1) - wght2=(julday-day1)/float(day2-day1) - endif - snowdp2d(i) = snowd(i)*1e-3 ! SNOW in kg/m^2 and snowdp in m h2osno2d(i) = weasd(i) ! mm @@ -5474,20 +5498,14 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, if(fice(i)>min_lakeice) then lake_icefrac3d(i,1) = fice(i) - endif - - !-- Check on the Great Salt Lake (GSL) when the model is cycled - !-- Bound the GSL temperature with +/- 3 C from climatology - if(limit_temperature_by_climatology(xlat_d(i),xlon_d(i))) then - Tclim = tfrz + wght1*saltlk_t(num1) & - + wght2*saltlk_t(num2) - if(lakedebug) print *,'Tclim,tsfc,t_lake3d',i,Tclim,tsfc(i),t_lake3d(i,:),t_soisno3d(i,:) - t_grnd2d(i) = min(Tclim+3.0_kind_phys,(max(tsfc(i),Tclim-3.0_kind_phys))) - do k = 1,nlevlake - t_lake3d(i,k) = min(Tclim+3.0_kind_phys,(max(t_lake3d(i,k),Tclim-3.0_kind_phys))) - enddo - t_soisno3d(i,1) = min(Tclim+3.0_kind_phys,(max(t_soisno3d(i,1),Tclim-3.0_kind_phys))) - if(lakedebug) print *,'After Tclim,tsfc,t_lake3d',i,Tclim,tsfc(i),t_lake3d(i,:),t_soisno3d(i,:) + snowdp2d(i) = snowd(i)*1e-3 ! SNOW in kg/m^2 and snowdp in m + h2osno2d(i) = weasd(i) ! mm + else + fice(i) = 0. + snowd(i) = 0. + weasd(i) = 0. + snowdp2d(i) = 0. + h2osno2d(i) = 0. endif z3d(i,:) = 0.0 @@ -5499,23 +5517,6 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, h2osoi_vol3d(i,:) = 0.0 snl2d(i) = 0.0 - ENDDO do_init_part1 - - if(used_lakedepth_default>0) then - print *,'used lakedepth_default: ',used_lakedepth_default - endif - - !!!!!!!!!!!!!!!!!!begin to initialize lake variables!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - init_points=0 - do_init_part2: DO i = 1,im - - if(use_lake_model(i)==0 .or. clm_lake_initialized(i)>0) then - cycle - endif - - init_points = init_points+1 - ! Soil hydraulic and thermal properties isl = ISLTYP(i) if (isl == 0 ) isl = 14 @@ -5563,37 +5564,17 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, watdry3d(i,k) = watsat3d(i,k) * (316230._kind_phys/sucsat3d(i,k)) ** (-1._kind_phys/bsw3d(i,k)) watopt3d(i,k) = watsat3d(i,k) * (158490._kind_phys/sucsat3d(i,k)) ** (-1._kind_phys/bsw3d(i,k)) end do - if (lakedepth2d(i) == spval) then - lakedepth2d(i) = zlak(nlevlake) + 0.5_kind_phys*dzlak(nlevlake) + if (clm_lakedepth(i) == spval) then + clm_lakedepth(i) = zlak(nlevlake) + 0.5_kind_phys*dzlak(nlevlake) z_lake3d(i,1:nlevlake) = zlak(1:nlevlake) dz_lake3d(i,1:nlevlake) = dzlak(1:nlevlake) else - depthratio2d(i) = lakedepth2d(i) / (zlak(nlevlake) + 0.5_kind_phys*dzlak(nlevlake)) + depthratio2d(i) = clm_lakedepth(i) / (zlak(nlevlake) + 0.5_kind_phys*dzlak(nlevlake)) z_lake3d(i,1) = zlak(1) dz_lake3d(i,1) = dzlak(1) dz_lake3d(i,2:nlevlake) = dzlak(2:nlevlake)*depthratio2d(i) z_lake3d(i,2:nlevlake) = zlak(2:nlevlake)*depthratio2d(i) + dz_lake3d(i,1)*(1._kind_phys - depthratio2d(i)) end if - ! initial t_lake3d here - if(tsfc(i)<160) then - write(errmsg,'(A,F20.12,A)') 'Invalid tsfc value ',tsfc(i),' found. Was tsfc not initialized?' - write(0,'(A)') trim(errmsg) - errflg=1 - return - endif - t_soisno3d(i,1) = tsfc(i) - t_lake3d(i,1) = tsfc(i) - t_grnd2d(i) = tsfc(i) - do k = 2, nlevlake - if(z_lake3d(i,k).le.depth_c) then - t_soisno3d(i,k)=tsfc(i)+(277.0-tsfc(i))/depth_c*z_lake3d(i,k) - t_lake3d(i,k)=tsfc(i)+(277.0-tsfc(i))/depth_c*z_lake3d(i,k) - else - t_soisno3d(i,k) = tsfc(i) - t_lake3d(i,k) = tsfc(i) - end if - enddo - !end initial t_lake3d here z3d(i,1:nlevsoil) = zsoi(1:nlevsoil) zi3d(i,0:nlevsoil) = zisoi(0:nlevsoil) dz3d(i,1:nlevsoil) = dzsoi(1:nlevsoil) @@ -5663,15 +5644,15 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, ! 3:subroutine makearbinit - if (snl2d(i) < 0) then - do k = snl2d(i)+1, 0 - ! Be careful because there may be new snow layers with bad temperatures like 0 even if - ! coming from init. con. file. - if(t_soisno3d(i,k) > 300 .or. t_soisno3d(i,k) < 200) t_soisno3d(i,k) = tsfc(i) - enddo - end if - ! initial t_lake3d here + if(tsfc(i)<160) then + write(errmsg,'(A,F20.12,A)') 'Invalid tsfc value ',tsfc(i),' found. Was tsfc not initialized?' + write(0,'(A)') trim(errmsg) + errflg=1 + return + endif + + t_lake3d(i,1) = tsfc(i) t_grnd2d(i) = tsfc(i) do k = 2, nlevlake @@ -5689,6 +5670,14 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, t_soisno3d(i,k)=t_soisno3d(i,1)+(t_soisno3d(i,nlevsoil)-t_soisno3d(i,1))*dzsoi(k) enddo + if (snl2d(i) < 0) then + do k = snl2d(i)+1, 0 + ! Be careful because there may be new snow layers with bad temperatures like 0 even if + ! coming from init. con. file. + if(t_soisno3d(i,k) > 300 .or. t_soisno3d(i,k) < 200) t_soisno3d(i,k) = min(tfrz,tsfc(i)) + enddo + end if + do k = 1,nlevsoil h2osoi_vol3d(i,k) = 1.0_kind_phys h2osoi_vol3d(i,k) = min(h2osoi_vol3d(i,k),watsat3d(i,k)) @@ -5711,7 +5700,7 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, end do clm_lake_initialized(i) = 1 - ENDDO do_init_part2 + ENDDO do_init if(LAKEDEBUG .and. init_points>0) then diff --git a/physics/clm_lake.meta b/physics/clm_lake.meta index 5953677e5..5a2cd9565 100644 --- a/physics/clm_lake.meta +++ b/physics/clm_lake.meta @@ -7,6 +7,14 @@ [ccpp-arg-table] name = clm_lake_run type = scheme +[pgr] + standard_name = surface_air_pressure + long_name = surface pressure + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [zorlw] standard_name = surface_roughness_length_over_water long_name = surface roughness length over water @@ -218,7 +226,15 @@ type = real kind = kind_phys intent = inout -[lakedepth2d] +[clm_lakedepth] + standard_name = clm_lake_depth + long_name = clm internal copy of lake depth with 10.0 replaced by default lake depth + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[oro_lakedepth] standard_name = lake_depth long_name = lake depth units = m @@ -551,7 +567,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = in + intent = inout [snowd] standard_name = lwe_surface_snow long_name = water equivalent snow depth @@ -559,7 +575,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = in + intent = inout [weasdi] standard_name = water_equivalent_accumulated_snow_depth_over_ice long_name = water equiv of acc snow depth over land @@ -710,6 +726,13 @@ dimensions = () type = integer intent = in +[wet] + standard_name = flag_nonzero_wet_surface_fraction + long_name = flag indicating presence of some ocean or lake surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = inout [icy] standard_name = flag_nonzero_sea_ice_surface_fraction long_name = flag indicating presence of some sea ice surface area fraction diff --git a/physics/sfc_diag.f b/physics/sfc_diag.f index 7018d395c..9b78cad88 100644 --- a/physics/sfc_diag.f +++ b/physics/sfc_diag.f @@ -88,9 +88,9 @@ subroutine sfc_diag_run & ! t2m(i) = t2m(i) * sig2k wrk = 1.0 - fhi if(thsfc_loc) then ! Use local potential temperature - t2m(i) = tskin(i)*wrk + t1(i)*prslki(i)*fhi - (grav+grav)/cp + t2m(i)= tskin(i)*wrk + t1(i)*prslki(i)*fhi - (grav+grav)/cp else ! Use potential temperature referenced to 1000 hPa - t2m(i) = tskin(i)*wrk + t1(i)*fhi - (grav+grav)/cp + t2m(i)= tskin(i)*wrk + t1(i)*fhi - (grav+grav)/cp endif if(evap(i) >= 0.) then ! for evaporation>0, use inferred qsurf to deduce q2m From d0d7d509c5e1c013093f09b2c44b05ab5eb9488b Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Mon, 17 Oct 2022 21:47:45 +0000 Subject: [PATCH 052/380] Update CODEOWNERS --- CODEOWNERS | 23 +++++++++++------------ 1 file changed, 11 insertions(+), 12 deletions(-) diff --git a/CODEOWNERS b/CODEOWNERS index 55373ae36..3cf17b8bb 100644 --- a/CODEOWNERS +++ b/CODEOWNERS @@ -19,7 +19,7 @@ physics/bl_mynn_common.f90 @joeolson42 physics/calpreciptype.f90 @grantfirl @ChunxiZhang-NOAA @dustinswales physics/cires_orowam2017.f @grantfirl @ChunxiZhang-NOAA @dustinswales physics/cires_tauamf_data.F90 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/cires_ugwp* @mdtoyNOAA @ValeryYudin-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/cires_ugwp* @ValeryYudin-NOAA @mdtoyNOAA @grantfirl @ChunxiZhang-NOAA @dustinswales physics/cldmacro.F @AnningCheng-NOAA @andrewgettelman @grantfirl @ChunxiZhang-NOAA @dustinswales physics/cldwat2m_micro.F @AnningCheng-NOAA @andrewgettelman @grantfirl @ChunxiZhang-NOAA @dustinswales physics/cnvc90.* @grantfirl @ChunxiZhang-NOAA @dustinswales @@ -38,7 +38,7 @@ physics/get_phi_fv3.* physics/get_prs_fv3.* @grantfirl @ChunxiZhang-NOAA @dustinswales physics/gfdl_cloud_microphys.* @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales physics/GFDL_parse_tracers.F90 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/gfdl_sfc_layer.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/gfdl_sfc_layer.* @ZhanZhang-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales physics/GFS_cloud_diagnostics.* @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales physics/GFS_DCNV_generic_post.* @grantfirl @ChunxiZhang-NOAA @dustinswales physics/GFS_DCNV_generic_pre.* @grantfirl @ChunxiZhang-NOAA @dustinswales @@ -92,7 +92,7 @@ physics/gwdc.* @Songyou184 physics/gwdps.* @Songyou184 @grantfirl @ChunxiZhang-NOAA @dustinswales physics/h2o_def.* @grantfirl @ChunxiZhang-NOAA @dustinswales physics/h2ointerp.f90 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/h2ophys.* @AlexBelochitski-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/h2ophys.* @SMoorthi-emc @grantfirl @ChunxiZhang-NOAA @dustinswales physics/hedmf.* @JongilHan66 @WeiguoWang-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales physics/iccn_def.F @grantfirl @ChunxiZhang-NOAA @dustinswales physics/iccninterp.F90 @grantfirl @ChunxiZhang-NOAA @dustinswales @@ -103,7 +103,7 @@ physics/machine.* physics/maximum_hourly_diagnostics.* @grantfirl @ChunxiZhang-NOAA @dustinswales physics/mersenne_twister.f @grantfirl @ChunxiZhang-NOAA @dustinswales physics/mfpbl.f @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/mfpblt.f @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/mfpblt.f @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales physics/mfpbltq.f @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales physics/mfscu.f @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales physics/mfscuq.f @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales @@ -119,11 +119,11 @@ physics/module_mp_radar.* @gthompsnWRF @RuiyuSun physics/module_mp_thompson* @gthompsnWRF @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales physics/module_nst* @XuLi-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales physics/module_sf_exchcoef.f90 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/module_SF_JSFC.F90 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/module_SF_JSFC.F90 @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales physics/module_sf_mynn.F90 @joeolson42 @grantfirl @ChunxiZhang-NOAA @dustinswales physics/module_sf_ruclsm.* @tanyasmirnova @grantfirl @ChunxiZhang-NOAA @dustinswales physics/module_soil_pre.* @tanyasmirnova @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/moninshoc.* @AlexBelochitski-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/moninshoc.* @SMoorthi-emc @grantfirl @ChunxiZhang-NOAA @dustinswales physics/mp_fer_hires.* @ericaligo-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales physics/mp_nssl.* @grantfirl @ChunxiZhang-NOAA @dustinswales physics/mp_thompson* @gthompsnWRF @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales @@ -137,13 +137,12 @@ physics/namelist_soilveg_ruc.* @tanyasmirnova physics/*noahmp* @barlage @cenlinhe @grantfirl @ChunxiZhang-NOAA @dustinswales physics/ozinterp.f90 @grantfirl @ChunxiZhang-NOAA @dustinswales physics/ozne_def.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/ozphys* @AlexBelochitski-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/ozphys* @SMoorthi-emc @grantfirl @ChunxiZhang-NOAA @dustinswales physics/physcons.F90 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/physparam.f @grantfirl @ChunxiZhang-NOAA @dustinswales physics/phys_tend.* @grantfirl @ChunxiZhang-NOAA @dustinswales physics/progsigma_calc.f90 @lisa-bengtsson @grantfirl @ChunxiZhang-NOAA @dustinswales physics/radcons.f90 @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/radiation_aerosols.f @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/radiation_aerosols.f @Qingfu-Liu @dustinswales @AnningCheng-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales physics/radiation_astronomy.f @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales physics/radiation_cloud_overlap.F90 @dustinswales @mjiacono @grantfirl @ChunxiZhang-NOAA @dustinswales physics/radiation_clouds.f @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales @@ -186,11 +185,11 @@ physics/sgscloud_radpost.* physics/sgscloud_radpre.* @grantfirl @ChunxiZhang-NOAA @dustinswales physics/shalcnv.* @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales physics/shinhongvdif.* @ChunxiZhang-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/shoc.* @AlexBelochitski-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/shoc.* @SMoorthi-emc @grantfirl @ChunxiZhang-NOAA @dustinswales physics/surface_perturbation.* @HelinWei-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/tridi.f @JongilHan66 @ChunxiZhang-NOAA @WeiguoWang-NOAA @AlexBelochitski-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/tridi.f @JongilHan66 @ChunxiZhang-NOAA @WeiguoWang-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales physics/ugwp_driver_v0.F @mdtoyNOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/ugwpv1_gsldrag.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/ugwpv1_gsldrag.* @mdtoyNOAA @grantfirl @ChunxiZhang-NOAA @dustinswales physics/ugwpv1_gsldrag_post.* @grantfirl @ChunxiZhang-NOAA @dustinswales physics/unified_ugwp* @mdtoyNOAA @grantfirl @ChunxiZhang-NOAA @dustinswales physics/wv_saturation.F @AnningCheng-NOAA @andrewgettelman @grantfirl @ChunxiZhang-NOAA @dustinswales From 3acd145d13e076e0dc5a55ace0975fc6070818d8 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Mon, 17 Oct 2022 22:27:04 +0000 Subject: [PATCH 053/380] more updates from tanya --- physics/GFS_surface_composites_post.F90 | 191 +++++++++++++---------- physics/GFS_surface_composites_post.meta | 35 +++++ physics/GFS_surface_composites_pre.F90 | 27 ++-- physics/GFS_surface_composites_pre.meta | 16 +- physics/clm_lake.f90 | 54 +------ physics/clm_lake.meta | 7 - 6 files changed, 179 insertions(+), 151 deletions(-) diff --git a/physics/GFS_surface_composites_post.F90 b/physics/GFS_surface_composites_post.F90 index 62c014417..c05113f7f 100644 --- a/physics/GFS_surface_composites_post.F90 +++ b/physics/GFS_surface_composites_post.F90 @@ -24,7 +24,7 @@ module GFS_surface_composites_post !! subroutine GFS_surface_composites_post_run ( & im, kice, km, rd, rvrdm1, cplflx, cplwav2atm, frac_grid, flag_cice, thsfc_loc, islmsk, dry, wet, icy, wind, t1, q1, prsl1, & - landfrac, lakefrac, oceanfrac, zorl, zorlo, zorll, zorli, garea, & + landfrac, lakefrac, oceanfrac, zorl, zorlo, zorll, zorli, garea, frac_ice, & cd, cd_wat, cd_lnd, cd_ice, cdq, cdq_wat, cdq_lnd, cdq_ice, rb, rb_wat, rb_lnd, rb_ice, stress, stress_wat, stress_lnd, & stress_ice, ffmm, ffmm_wat, ffmm_lnd, ffmm_ice, ffhh, ffhh_wat, ffhh_lnd, ffhh_ice, uustar, uustar_wat, uustar_lnd, & uustar_ice, fm10, fm10_wat, fm10_lnd, fm10_ice, fh2, fh2_wat, fh2_lnd, fh2_ice, tsurf_wat, tsurf_lnd, tsurf_ice, & @@ -32,17 +32,17 @@ subroutine GFS_surface_composites_post_run ( ep1d_lnd, ep1d_ice, weasd, weasd_lnd, weasd_ice, snowd, snowd_lnd, snowd_ice, tprcp, tprcp_wat, & tprcp_lnd, tprcp_ice, evap, evap_wat, evap_lnd, evap_ice, hflx, hflx_wat, hflx_lnd, hflx_ice, qss, qss_wat, qss_lnd, & qss_ice, tsfc, tsfco, tsfcl, tsfc_wat, tisfc, hice, cice, tiice, & - sigmaf, zvfun, lheatstrg, h0facu, h0facs, hflxq, hffac, stc, & + sigmaf, zvfun, lheatstrg, h0facu, h0facs, hflxq, hffac, stc, lkm, iopt_lake, iopt_lake_clm, use_lake_model, & grav, prsik1, prslk1, prslki, z1, ztmax_wat, ztmax_lnd, ztmax_ice, huge, errmsg, errflg) implicit none - integer, intent(in) :: im, kice, km - logical, intent(in) :: cplflx, frac_grid, cplwav2atm + integer, intent(in) :: im, kice, km, lkm, iopt_lake, iopt_lake_clm + logical, intent(in) :: cplflx, frac_grid, cplwav2atm, frac_ice logical, intent(in) :: lheatstrg logical, dimension(:), intent(in) :: flag_cice, dry, icy logical, dimension(:), intent(inout) :: wet - integer, dimension(:), intent(in) :: islmsk + integer, dimension(:), intent(in) :: islmsk, use_lake_model real(kind=kind_phys), dimension(:), intent(in) :: wind, t1, q1, prsl1, landfrac, lakefrac, oceanfrac, & cd_wat, cd_lnd, cd_ice, cdq_wat, cdq_lnd, cdq_ice, rb_wat, rb_lnd, rb_ice, stress_wat, & stress_lnd, stress_ice, ffmm_wat, ffmm_lnd, ffmm_ice, ffhh_wat, ffhh_lnd, ffhh_ice, uustar_wat, uustar_lnd, uustar_ice, & @@ -88,13 +88,13 @@ subroutine GFS_surface_composites_post_run ( errflg = 0 ! --- generate ocean/land/ice composites - do i=1, im - if(lakefrac(i)>0.0) then + do i=1, im + if(use_lake_model(i) > 0.0) then wet(i) = .true. endif - enddo + enddo - if (frac_grid) then + if_frac_grid: if (frac_grid) then do i=1, im @@ -266,7 +266,7 @@ subroutine GFS_surface_composites_post_run ( endif enddo - else + else ! not fractional grid do i=1,im ! if (islmsk(i) == 1) then @@ -299,89 +299,110 @@ subroutine GFS_surface_composites_post_run ( ! elseif (islmsk(i) == 0) then elseif (wet(i)) then !-- water - zorl(i) = zorlo(i) - cd(i) = cd_wat(i) - cdq(i) = cdq_wat(i) - rb(i) = rb_wat(i) - stress(i) = stress_wat(i) - ffmm(i) = ffmm_wat(i) - ffhh(i) = ffhh_wat(i) - uustar(i) = uustar_wat(i) - fm10(i) = fm10_wat(i) - fh2(i) = fh2_wat(i) - tsfco(i) = tsfc_wat(i) ! over lake (and ocean when uncoupled) - tsfc(i) = tsfco(i) - tsfcl(i) = tsfc(i) - tisfc(i) = tsfc(i) - cmm(i) = cmm_wat(i) - chh(i) = chh_wat(i) - gflx(i) = gflx_wat(i) - ep1d(i) = ep1d_wat(i) - weasd(i) = zero - snowd(i) = zero - evap(i) = evap_wat(i) - hflx(i) = hflx_wat(i) - qss(i) = qss_wat(i) - hice(i) = zero - cice(i) = zero + call composite_wet else ! islmsk(i) == 2 !-- ice - zorl(i) = zorli(i) - cd(i) = cd_ice(i) - cdq(i) = cdq_ice(i) - rb(i) = rb_ice(i) - ffmm(i) = ffmm_ice(i) - ffhh(i) = ffhh_ice(i) - uustar(i) = uustar_ice(i) - fm10(i) = fm10_ice(i) - fh2(i) = fh2_ice(i) - stress(i) = stress_ice(i) - cmm(i) = cmm_ice(i) - chh(i) = chh_ice(i) - gflx(i) = gflx_ice(i) - ep1d(i) = ep1d_ice(i) - weasd(i) = weasd_ice(i) * cice(i) - snowd(i) = snowd_ice(i) * cice(i) - qss(i) = qss_ice(i) - evap(i) = evap_ice(i) - hflx(i) = hflx_ice(i) -! - txi = cice(i) - txo = one - txi - evap(i) = txi * evap_ice(i) + txo * evap_wat(i) - hflx(i) = txi * hflx_ice(i) + txo * hflx_wat(i) - tsfc(i) = txi * tisfc(i) + txo * tsfc_wat(i) - stress(i) = txi * stress_ice(i) + txo * stress_wat(i) - qss(i) = txi * qss_ice(i) + txo * qss_wat(i) - ep1d(i) = txi * ep1d_ice(i) + txo * ep1d_wat(i) - - lnzorli = zero ; lnzorlo = zero - if (zorli(i) /= huge) then - lnzorli = log(zorli(i)) - endif - if (zorlo(i) /= huge) then - lnzorlo = log(zorlo(i)) - endif - zorl(i) = exp(txi*lnzorli + txo*lnzorlo) -! zorl(i) = exp(txi*log(zorli(i)) + txo*log(zorlo(i))) -! - if (wet(i)) then - tsfco(i) = tsfc_wat(i) - else - tsfco(i) = tsfc(i) - endif - tsfcl(i) = tsfc(i) - do k=1,min(kice,km) ! store tiice in stc to reduce output in the nonfrac grid case - stc(i,k) = tiice(i,k) - enddo + call composite_icy(.true.) + call composite_combine_wet_icy endif - enddo - endif ! if (frac_grid) + endif if_frac_grid ! --- compositing done + contains + + subroutine composite_wet + implicit none + zorl(i) = zorlo(i) + cd(i) = cd_wat(i) + cdq(i) = cdq_wat(i) + rb(i) = rb_wat(i) + stress(i) = stress_wat(i) + ffmm(i) = ffmm_wat(i) + ffhh(i) = ffhh_wat(i) + uustar(i) = uustar_wat(i) + fm10(i) = fm10_wat(i) + fh2(i) = fh2_wat(i) + tsfco(i) = tsfc_wat(i) ! over lake (and ocean when uncoupled) + tsfc(i) = tsfco(i) + tsfcl(i) = tsfc(i) + tisfc(i) = tsfc(i) + cmm(i) = cmm_wat(i) + chh(i) = chh_wat(i) + gflx(i) = gflx_wat(i) + ep1d(i) = ep1d_wat(i) + weasd(i) = zero + snowd(i) = zero + evap(i) = evap_wat(i) + hflx(i) = hflx_wat(i) + qss(i) = qss_wat(i) + hice(i) = zero + cice(i) = zero + end subroutine composite_wet + + subroutine composite_icy(cice_weighting) + implicit none + logical, intent(in) :: cice_weighting + zorl(i) = zorli(i) + cd(i) = cd_ice(i) + cdq(i) = cdq_ice(i) + rb(i) = rb_ice(i) + ffmm(i) = ffmm_ice(i) + ffhh(i) = ffhh_ice(i) + uustar(i) = uustar_ice(i) + fm10(i) = fm10_ice(i) + fh2(i) = fh2_ice(i) + stress(i) = stress_ice(i) + cmm(i) = cmm_ice(i) + chh(i) = chh_ice(i) + gflx(i) = gflx_ice(i) + ep1d(i) = ep1d_ice(i) + if(cice_weighting) then + weasd(i) = weasd_ice(i) * cice(i) + snowd(i) = snowd_ice(i) * cice(i) + else + weasd(i) = weasd_ice(i) + snowd(i) = snowd_ice(i) + endif + qss(i) = qss_ice(i) + evap(i) = evap_ice(i) + hflx(i) = hflx_ice(i) + end subroutine composite_icy + + subroutine composite_combine_wet_icy + implicit none + txi = cice(i) + txo = one - txi + evap(i) = txi * evap_ice(i) + txo * evap_wat(i) + hflx(i) = txi * hflx_ice(i) + txo * hflx_wat(i) + tsfc(i) = txi * tisfc(i) + txo * tsfc_wat(i) + stress(i) = txi * stress_ice(i) + txo * stress_wat(i) + qss(i) = txi * qss_ice(i) + txo * qss_wat(i) + ep1d(i) = txi * ep1d_ice(i) + txo * ep1d_wat(i) + + lnzorli = zero ; lnzorlo = zero + if (zorli(i) /= huge) then + lnzorli = log(zorli(i)) + endif + if (zorlo(i) /= huge) then + lnzorlo = log(zorlo(i)) + endif + zorl(i) = exp(txi*lnzorli + txo*lnzorlo) + ! zorl(i) = exp(txi*log(zorli(i)) + txo*log(zorlo(i))) + ! + if (wet(i)) then + tsfco(i) = tsfc_wat(i) + else + tsfco(i) = tsfc(i) + endif + tsfcl(i) = tsfc(i) + do k=1,min(kice,km) ! store tiice in stc to reduce output in the nonfrac grid case + stc(i,k) = tiice(i,k) + enddo + end subroutine composite_combine_wet_icy + end subroutine GFS_surface_composites_post_run end module GFS_surface_composites_post diff --git a/physics/GFS_surface_composites_post.meta b/physics/GFS_surface_composites_post.meta index c7e8c6476..a78610cc7 100644 --- a/physics/GFS_surface_composites_post.meta +++ b/physics/GFS_surface_composites_post.meta @@ -29,6 +29,34 @@ dimensions = () type = integer intent = in +[lkm] + standard_name = control_for_lake_model_execution_method + long_name = control for lake model execution: 0=no lake, 1=lake, 2=lake+nsst + units = flag + dimensions = () + type = integer + intent = in +[iopt_lake] + standard_name = control_for_lake_model_selection + long_name = control for lake model selection + units = 1 + dimensions = () + type = integer + intent = in +[iopt_lake_clm] + standard_name = clm_lake_model_control_selection_value + long_name = value that indicates clm lake model in the control for lake model selection + units = 1 + dimensions = () + type = integer + intent = in +[use_lake_model] + standard_name = flag_for_using_lake_model + long_name = flag indicating lake points using a lake model + units = flag + dimensions = (horizontal_loop_extent) + type = integer + intent = in [rd] standard_name = gas_constant_of_dry_air long_name = ideal gas constant for dry air @@ -66,6 +94,13 @@ dimensions = () type = logical intent = in +[frac_ice] + standard_name = flag_for_fractional_ice_when_fractional_landmask_is_disabled + long_name = flag for fractional ice when fractional landmask is disabled + units = flag + dimensions = () + type = logical + intent = in [flag_cice] standard_name = flag_for_cice long_name = flag for cice diff --git a/physics/GFS_surface_composites_pre.F90 b/physics/GFS_surface_composites_pre.F90 index 862ba2b6c..9a34fddf7 100644 --- a/physics/GFS_surface_composites_pre.F90 +++ b/physics/GFS_surface_composites_pre.F90 @@ -21,7 +21,7 @@ module GFS_surface_composites_pre !> \section arg_table_GFS_surface_composites_pre_run Argument Table !! \htmlinclude GFS_surface_composites_pre_run.html !! - subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, & + subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, iopt_lake, iopt_lake_clm, & flag_cice, cplflx, cplice, cplwav2atm, lsm, lsm_ruc, & landfrac, lakefrac, lakedepth, oceanfrac, frland, & dry, icy, lake, use_lake_model, wet, hice, cice, zorlo, zorll, zorli, & @@ -35,11 +35,11 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, implicit none ! Interface variables - integer, intent(in ) :: im, lkm, kdt, lsm, lsm_ruc + integer, intent(in ) :: im, lkm, kdt, lsm, lsm_ruc, iopt_lake, iopt_lake_clm logical, intent(in ) :: cplflx, cplice, cplwav2atm, frac_grid logical, dimension(:), intent(inout) :: flag_cice logical, dimension(:), intent(inout) :: dry, icy, lake, wet - integer, dimension(:), intent(inout) :: use_lake_model + integer, dimension(:), intent(in ) :: use_lake_model real(kind=kind_phys), dimension(:), intent(in ) :: landfrac, lakefrac, lakedepth, oceanfrac real(kind=kind_phys), dimension(:), intent(inout) :: cice, hice real(kind=kind_phys), dimension(:), intent( out) :: frland @@ -67,16 +67,17 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, ! Local variables integer :: i + logical :: is_clm ! Initialize CCPP error handling variables errmsg = '' errflg = 0 - do i=1,im + do i=1,im if(use_lake_model(i) > 0.0) then wet(i) = .true. endif - enddo + enddo if (frac_grid) then ! cice is ice fraction wrt water area do i=1,im @@ -183,10 +184,13 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, if (icy(i)) tsfco(i) = max(tisfc(i), tgice) endif endif - else + else ! Not ocean and not land + is_clm = lkm>0 .and. iopt_lake==iopt_lake_clm .and. use_lake_model(i)>0 if (cice(i) >= min_lakeice) then icy(i) = .true. - tisfc(i) = max(timin, min(tisfc(i), tgice)) + if(.not.is_clm) then + tisfc(i) = max(timin, min(tisfc(i), tgice)) + endif islmsk(i) = 2 else cice(i) = zero @@ -198,7 +202,9 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice(i) = .false. if (cice(i) < one) then wet(i) = .true. ! some open lake - if (icy(i)) tsfco(i) = max(tisfc(i), tgice) + if (icy(i) .and. .not.is_clm) then + tsfco(i) = max(tisfc(i), tgice) + endif endif endif endif @@ -233,7 +239,10 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, endif if (icy(i)) then ! Ice uustar_ice(i) = uustar(i) - if(lsm /= lsm_ruc) weasd_ice(i) = weasd(i) + is_clm = lkm>0 .and. iopt_lake==iopt_lake_clm .and. use_lake_model(i)>0 + if(lsm /= lsm_ruc .and. .not.is_clm) then + weasd_ice(i) = weasd(i) + endif tsurf_ice(i) = tisfc(i) ep1d_ice(i) = zero gflx_ice(i) = zero diff --git a/physics/GFS_surface_composites_pre.meta b/physics/GFS_surface_composites_pre.meta index 6a56b35b8..d62076e4b 100644 --- a/physics/GFS_surface_composites_pre.meta +++ b/physics/GFS_surface_composites_pre.meta @@ -137,7 +137,21 @@ units = flag dimensions = (horizontal_loop_extent) type = integer - intent = inout + intent = in +[iopt_lake] + standard_name = control_for_lake_model_selection + long_name = control for lake model selection + units = 1 + dimensions = () + type = integer + intent = in +[iopt_lake_clm] + standard_name = clm_lake_model_control_selection_value + long_name = value that indicates clm lake model in the control for lake model selection + units = 1 + dimensions = () + type = integer + intent = in [wet] standard_name = flag_nonzero_wet_surface_fraction long_name = flag indicating presence of some ocean or lake surface area fraction diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90 index 97cbe025f..e444b9453 100644 --- a/physics/clm_lake.f90 +++ b/physics/clm_lake.f90 @@ -42,7 +42,7 @@ MODULE clm_lake logical, parameter :: USE_ETALAKE = .false. real, parameter :: ETALAKE = 1.1925*50**(-0.424) ! Set this to your desired value if USE_ETALAKE=.true. - ! Level counts must be consistent with model (GFS_Typedefs.F90) + ! Level counts must be consistent with model (GFS_typedefs.F90) integer, parameter :: nlevsoil = 10 ! number of soil layers integer, parameter :: nlevlake = 10 ! number of lake layers integer, parameter :: nlevsnow = 5 ! maximum number of snow layers @@ -126,50 +126,12 @@ MODULE clm_lake real, parameter :: SaltLk_T(1:25) = (/ 0.5, 0.,-0.5, 3., 4., 7., 8., 12., 13., 16., 19., 21., & 23.5, 25., 26.,24.,23.,20.5,18., 15., 11.5, 8., 4., 1., 0.5/) real, parameter :: month_length(12) = (/ 31, 29, 31, 30, 31, 30, 31, 30, 30, 31, 30, 31 /) - real, parameter :: julm(1:13) = (/0,31,59,90,120,151,181,212,243,273,304,334,365/) logical, parameter :: include_all_salty_locations = .false. CONTAINS !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine get_month_and_day(IDATE,month,day_of_month,day_of_year,fhour) - implicit none - integer, intent(in) :: IDATE(4) - integer, intent(out) :: month,day_of_month,day_of_year - real(kind_phys), intent(in) :: fhour - - integer :: idat(8),jdat(8), w3kindreal, w3kindint, jdow, jdoy, jday - real(8) :: rinc(5) - real(4) :: rinc4(5) - - idat = 0 - idat(1) = idate(4) - idat(2) = idate(2) - idat(3) = idate(3) - idat(5) = idate(1) - rinc = 0. - rinc(2) = fhour - call w3kind(w3kindreal,w3kindint) - if(w3kindreal==4) then - rinc4 = rinc - CALL W3MOVDAT(RINC4,IDAT,JDAT) - else - CALL W3MOVDAT(RINC,IDAT,JDAT) - endif -! - jdow = 0 - jdoy = 0 - jday = 0 - call w3doxdat(jdat,jdow,jdoy,jday) - - day_of_year = jday - day_of_month = IDATE(3) - month = IDATE(2) - end subroutine get_month_and_day - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - logical function limit_temperature_by_climatology(xlat_d,xlon_positive) implicit none real(kind_phys), intent(in) :: xlat_d, xlon_positive @@ -228,7 +190,7 @@ logical function is_salty(xlat_d,xlon_positive) is_salty=limit_temperature_by_climatology(xlat_d,xlon_d) - if(include_all_salty_locations) then + other_locations: if(include_all_salty_locations) then ! --- The Mono Lake in California, salinity is 75 ppt with freezing point at ! --- -4.2 C (Stan). The Mono Lake lat/long (37.9-38.2, -119.3 - 118.8) if (xlon_d.gt.-119.3.and. xlon_d.lt.-118.8) then @@ -253,7 +215,7 @@ logical function is_salty(xlat_d,xlon_positive) endif is_salty = .true. endif - endif + endif other_locations !tgs --- end of special treatment for salty lakes end function is_salty @@ -268,7 +230,7 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& rain ,dtp ,dswsfci ,albedo ,& xlat_d ,z_lake3d ,dz_lake3d ,oro_lakedepth ,& watsat3d ,csol3d ,tkmg3d ,tkdry3d ,& - tksatu3d ,wet ,phii ,clm_lakedepth ,& + tksatu3d , phii ,clm_lakedepth ,& fice ,min_lakeice ,im,km ,& h2osno2d ,snowdp2d ,snl2d ,z3d ,& !h dz3d ,zi3d ,h2osoi_vol3d ,h2osoi_liq3d ,& @@ -307,7 +269,7 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& LOGICAL, INTENT(IN) :: restart,use_lakedepth,first_time_step REAL(KIND_PHYS), INTENT(INOUT) :: clm_lake_initialized(:) REAL(KIND_PHYS), INTENT(IN) :: min_lakeice, con_rd,con_g,con_cp,lakedepth_default, fhour - logical, intent(inout) :: icy(:), wet(:) + logical, intent(inout) :: icy(:) REAL(KIND_PHYS), DIMENSION( : ), INTENT(INOUT):: fice REAL(KIND_PHYS), DIMENSION( : ), INTENT(INOUT) :: weasd, snowd REAL(KIND_PHYS), DIMENSION( : ), INTENT(IN):: tg3, pgr @@ -758,11 +720,6 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& tisfc(i) = t_grnd(c) ! surface_skin_temperature_over_ice tsurf_ice(i) = t_grnd(c) ! surface_skin_temperature_after_iteration_over_ice icy(i)=.true. - if(fice(i)==1.) then - wet(i) = .false. - else - wet(i) = .true. - endif ice_points = ice_points+1 zorli(i) = z0mg(c) @@ -776,7 +733,6 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& end do else icy(i)=.false. - wet(i)=.true. weasdi(i) = 0 snodi(i) = 0 tisfc(i) = tsurf(i) diff --git a/physics/clm_lake.meta b/physics/clm_lake.meta index 5a2cd9565..5224b3616 100644 --- a/physics/clm_lake.meta +++ b/physics/clm_lake.meta @@ -726,13 +726,6 @@ dimensions = () type = integer intent = in -[wet] - standard_name = flag_nonzero_wet_surface_fraction - long_name = flag indicating presence of some ocean or lake surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = inout [icy] standard_name = flag_nonzero_sea_ice_surface_fraction long_name = flag indicating presence of some sea ice surface area fraction From 833905039101dc13ccf6a46ec94b47470f4b5a78 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 20 Oct 2022 16:52:38 +0000 Subject: [PATCH 054/380] rework variables and add fractional ice --- physics/GFS_surface_composites_post.F90 | 105 +-- physics/clm_lake.f90 | 407 ++++++----- physics/clm_lake.meta | 904 +++++++++++++----------- 3 files changed, 780 insertions(+), 636 deletions(-) diff --git a/physics/GFS_surface_composites_post.F90 b/physics/GFS_surface_composites_post.F90 index c05113f7f..eb6b2e32e 100644 --- a/physics/GFS_surface_composites_post.F90 +++ b/physics/GFS_surface_composites_post.F90 @@ -94,7 +94,7 @@ subroutine GFS_surface_composites_post_run ( endif enddo - if_frac_grid: if (frac_grid) then + fractional_grid: if (frac_grid) then do i=1, im @@ -269,49 +269,70 @@ subroutine GFS_surface_composites_post_run ( else ! not fractional grid do i=1,im -! if (islmsk(i) == 1) then + + ! This code assumes points are always 100% lake or 0% lake, + ! and lake points must have wet(i)=true, even if they have + ! 100% ice cover. The only fractional coverage allowed is + ! fractional ice on lake points that ran the CLM Lake + ! Model (frac_ice). For more general fractional grid support, use + ! frac_grid. + if (dry(i)) then - !-- land - zorl(i) = zorll(i) - cd(i) = cd_lnd(i) - cdq(i) = cdq_lnd(i) - rb(i) = rb_lnd(i) - stress(i) = stress_lnd(i) - ffmm(i) = ffmm_lnd(i) - ffhh(i) = ffhh_lnd(i) - uustar(i) = uustar_lnd(i) - fm10(i) = fm10_lnd(i) - fh2(i) = fh2_lnd(i) - tsfc(i) = tsfcl(i) - tsfco(i) = tsfc(i) - tisfc(i) = tsfc(i) - cmm(i) = cmm_lnd(i) - chh(i) = chh_lnd(i) - gflx(i) = gflx_lnd(i) - ep1d(i) = ep1d_lnd(i) - weasd(i) = weasd_lnd(i) - snowd(i) = snowd_lnd(i) - evap(i) = evap_lnd(i) - hflx(i) = hflx_lnd(i) - qss(i) = qss_lnd(i) - hice(i) = zero - cice(i) = zero -! elseif (islmsk(i) == 0) then - elseif (wet(i)) then - !-- water + ! This is a land point. + call composite_land + elseif(frac_ice .and. use_lake_model(i)>0 .and. iopt_lake==iopt_lake_clm) then + ! This is a lake point where the CLM Lake Model was run with frac_ice. + if(icy(i)) then + ! Lake point has more than min_lakeice ice. + call composite_icy(.true.) + call composite_wet_and_icy + else + ! Lake point has less than min_lakeice ice. + call composite_wet + endif + else if (wet(i)) then + ! Wet point that is not a lake, or lake point with frac_ice disabled. call composite_wet else ! islmsk(i) == 2 - !-- ice - call composite_icy(.true.) - call composite_combine_wet_icy + ! This is not a lake point, and it is icy. + call composite_icy(.false.) + call composite_wet_and_icy endif enddo - endif if_frac_grid + endif fractional_grid ! --- compositing done contains + + subroutine composite_land + implicit none + zorl(i) = zorll(i) + cd(i) = cd_lnd(i) + cdq(i) = cdq_lnd(i) + rb(i) = rb_lnd(i) + stress(i) = stress_lnd(i) + ffmm(i) = ffmm_lnd(i) + ffhh(i) = ffhh_lnd(i) + uustar(i) = uustar_lnd(i) + fm10(i) = fm10_lnd(i) + fh2(i) = fh2_lnd(i) + tsfc(i) = tsfcl(i) + tsfco(i) = tsfc(i) + tisfc(i) = tsfc(i) + cmm(i) = cmm_lnd(i) + chh(i) = chh_lnd(i) + gflx(i) = gflx_lnd(i) + ep1d(i) = ep1d_lnd(i) + weasd(i) = weasd_lnd(i) + snowd(i) = snowd_lnd(i) + evap(i) = evap_lnd(i) + hflx(i) = hflx_lnd(i) + qss(i) = qss_lnd(i) + hice(i) = zero + cice(i) = zero + end subroutine composite_land subroutine composite_wet implicit none @@ -342,9 +363,9 @@ subroutine composite_wet cice(i) = zero end subroutine composite_wet - subroutine composite_icy(cice_weighting) + subroutine composite_icy(is_clm) implicit none - logical, intent(in) :: cice_weighting + logical, intent(in) :: is_clm zorl(i) = zorli(i) cd(i) = cd_ice(i) cdq(i) = cdq_ice(i) @@ -359,19 +380,19 @@ subroutine composite_icy(cice_weighting) chh(i) = chh_ice(i) gflx(i) = gflx_ice(i) ep1d(i) = ep1d_ice(i) - if(cice_weighting) then - weasd(i) = weasd_ice(i) * cice(i) - snowd(i) = snowd_ice(i) * cice(i) - else + if(is_clm) then weasd(i) = weasd_ice(i) snowd(i) = snowd_ice(i) + else + weasd(i) = weasd_ice(i) * cice(i) + snowd(i) = snowd_ice(i) * cice(i) endif qss(i) = qss_ice(i) evap(i) = evap_ice(i) hflx(i) = hflx_ice(i) end subroutine composite_icy - subroutine composite_combine_wet_icy + subroutine composite_wet_and_icy implicit none txi = cice(i) txo = one - txi @@ -401,7 +422,7 @@ subroutine composite_combine_wet_icy do k=1,min(kice,km) ! store tiice in stc to reduce output in the nonfrac grid case stc(i,k) = tiice(i,k) enddo - end subroutine composite_combine_wet_icy + end subroutine composite_wet_and_icy end subroutine GFS_surface_composites_post_run diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90 index e444b9453..3d4cb6d9a 100644 --- a/physics/clm_lake.f90 +++ b/physics/clm_lake.f90 @@ -224,33 +224,37 @@ end function is_salty !> \section arg_table_clm_lake_run Argument Table !! \htmlinclude clm_lake_run.html !! - SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& - gt0 ,prsi ,con_rd,con_g ,qvcurr ,& !i - gu0 ,gv0 ,dlwsfci ,emiss ,& - rain ,dtp ,dswsfci ,albedo ,& - xlat_d ,z_lake3d ,dz_lake3d ,oro_lakedepth ,& - watsat3d ,csol3d ,tkmg3d ,tkdry3d ,& - tksatu3d , phii ,clm_lakedepth ,& - fice ,min_lakeice ,im,km ,& - h2osno2d ,snowdp2d ,snl2d ,z3d ,& !h - dz3d ,zi3d ,h2osoi_vol3d ,h2osoi_liq3d ,& - h2osoi_ice3d ,t_grnd2d ,t_soisno3d ,t_lake3d ,& - savedtke12d ,lake_icefrac3d ,use_lake_model ,& - iopt_lake ,iopt_lake_clm ,fhour ,& - con_cp ,icy ,IDATE ,& - hflx ,evap ,grdflx ,tsfc ,& !o - lake_t2m ,lake_q2m ,clm_lake_initialized ,& - weasd ,isltyp ,snowd ,use_lakedepth ,& - restart ,lakedepth_default ,pgr ,& - zorlw ,zorli ,sand3d ,clay3d ,& -! Flake output variables - weasdi ,snodi ,hice ,tsurf ,& - t_sfc ,lflx ,ustar ,qsfc ,& - ch ,cm ,chh ,cmm ,& - lake_t_snow ,tisfc ,tsurf_ice ,wind ,& -! - xlon_d ,kdt ,tg3 ,salty ,& - me ,master ,errmsg ,errflg ) + SUBROUTINE clm_lake_run( & + ! Model time and metadata: + im, km, me, master, restart, first_time_step, fhour, IDATE, kdt, & + + ! Configuration and initialization: + iopt_lake, iopt_lake_clm, min_lakeice, lakedepth_default, use_lakedepth, & + dtp, use_lake_model, clm_lake_initialized, frac_grid, frac_ice, & + + ! Atmospheric model state inputs: + tg3, pgr, zlvl, gt0, prsi, phii, qvcurr, gu0, gv0, xlat_d, xlon_d, & + ch, cm, dlwsfci, dswsfci, emiss, rain, oro_lakedepth, wind, rho0, tsfc, & + flag_iter, ISLTYP, & + + ! Feedback to atmosphere: + evap_wat, evap_ice, hflx_wat, hflx_ice, gflx_wat, gflx_ice, & + ep1d_water, ep1d_ice, tsurf_water, tsurf_ice, tsfc_wat, tisfc, & + weasdi, snodi, hice, qss_water, qss_ice, & + cmm_water, cmm_ice, chh_water, chh_ice, & + uustar_water, uustar_ice, lake_t_snow, albedo, zorlw, & + zorli, lake_t2m, lake_q2m, weasd, snowd, fice, & + icy, & + + ! Lake model internal state stored by caller: + + salty, savedtke12d, snowdp2d, h2osno2d, snl2d, t_grnd2d, t_lake3d, & + lake_icefrac3d, t_soisno3d, h2osoi_ice3d, h2osoi_liq3d, h2osoi_vol3d, & + z3d, dz3d, zi3d, z_lake3d, dz_lake3d, watsat3d, csol3d, sand3d, clay3d, & + tkmg3d, tkdry3d, tksatu3d, clm_lakedepth, & + + ! Error reporting: + errflg, errmsg) !============================================================================== ! This subroutine was first edited by Hongping Gu and Jiming Jin for coupling @@ -260,72 +264,56 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& IMPLICIT NONE - !in: - - INTEGER, INTENT(IN) :: iopt_lake, iopt_lake_clm, kdt, IDATE(4) - INTEGER, INTENT(OUT) :: errflg - CHARACTER(*), INTENT(OUT) :: errmsg + ! + ! Model time and metadata: + ! INTEGER , INTENT (IN) :: im,km,me,master - LOGICAL, INTENT(IN) :: restart,use_lakedepth,first_time_step - REAL(KIND_PHYS), INTENT(INOUT) :: clm_lake_initialized(:) - REAL(KIND_PHYS), INTENT(IN) :: min_lakeice, con_rd,con_g,con_cp,lakedepth_default, fhour - logical, intent(inout) :: icy(:) - REAL(KIND_PHYS), DIMENSION( : ), INTENT(INOUT):: fice - REAL(KIND_PHYS), DIMENSION( : ), INTENT(INOUT) :: weasd, snowd - REAL(KIND_PHYS), DIMENSION( : ), INTENT(IN):: tg3, pgr - REAL(KIND_PHYS), DIMENSION( : ), INTENT(IN) :: ZLVL + LOGICAL, INTENT(IN) :: restart,first_time_step + INTEGER, INTENT(IN) :: IDATE(4), kdt + REAL, INTENT(IN) :: fhour + ! + ! Configuration and initialization: + ! + INTEGER, INTENT(IN) :: iopt_lake, iopt_lake_clm + REAL(KIND_PHYS), INTENT(IN) :: min_lakeice, lakedepth_default, dtp + LOGICAL, INTENT(IN) :: use_lakedepth INTEGER, DIMENSION(:), INTENT(IN) :: use_lake_model - real(kind_phys), dimension(:), intent(in) :: rho0 ! air density at surface - - REAL(KIND_PHYS), DIMENSION( : ), INTENT(INOUT) :: & - weasdi ,snodi ,hice ,tsurf ,& - t_sfc ,lflx ,ustar ,qsfc ,& - chh ,cmm ,lake_t_snow ,tisfc ,& - tsurf_ice ,wind - LOGICAL, DIMENSION(:), INTENT(IN) :: flag_iter - REAL(KIND_PHYS), DIMENSION( :, : ),INTENT(IN) :: gt0 - REAL(KIND_PHYS), DIMENSION( :, : ),INTENT(IN) :: prsi - REAL(KIND_PHYS), DIMENSION( :, : ),INTENT(IN) :: phii - REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(IN) :: qvcurr - REAL(KIND_PHYS), DIMENSION( :, : ),INTENT(IN) :: gu0 - REAL(KIND_PHYS), DIMENSION( :, : ),INTENT(IN) :: gv0 - REAL(KIND_PHYS), DIMENSION( : ), INTENT(IN) :: xlat_d, xlon_d - REAL(KIND_PHYS), DIMENSION( : ), INTENT(IN) :: ch - REAL(KIND_PHYS), DIMENSION( : ), INTENT(IN) :: cm - REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(IN) :: dlwsfci - REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(IN) :: dswsfci - REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(IN) :: emiss - REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(IN) :: rain - REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(INOUT) :: albedo, zorlw, zorli - INTEGER, DIMENSION( : ), INTENT(IN) :: ISLTYP + REAL(KIND_PHYS), INTENT(INOUT) :: clm_lake_initialized(:) + LOGICAL, INTENT(IN) :: frac_grid, frac_ice + + ! + ! Atmospheric model state inputs: + ! + REAL(KIND_PHYS), DIMENSION(:), INTENT(IN):: & + tg3, pgr, zlvl, qvcurr, xlat_d, xlon_d, ch, cm, & + dlwsfci, dswsfci, emiss, rain, oro_lakedepth, wind, rho0, tsfc + REAL(KIND_PHYS), DIMENSION(:,:), INTENT(in) :: gu0, gv0, prsi, gt0, phii + LOGICAL, DIMENSION(:), INTENT(IN) :: flag_iter + INTEGER, DIMENSION(:), INTENT(IN) :: ISLTYP + + ! + ! Feedback to atmosphere: + ! + REAL(KIND_PHYS), DIMENSION(:), INTENT(INOUT) :: & + evap_wat, evap_ice, hflx_wat, hflx_ice, gflx_wat, gflx_ice, & + ep1d_water, ep1d_ice, tsurf_water, tsurf_ice, tsfc_wat, tisfc, & + weasdi, snodi, hice, qss_water, qss_ice, & + cmm_water, cmm_ice, chh_water, chh_ice, & + uustar_water, uustar_ice, lake_t_snow, albedo, zorlw, & + zorli, lake_t2m, lake_q2m, weasd, snowd, fice + LOGICAL, INTENT(INOUT) :: icy(:) + + ! + ! Lake model internal state stored by caller: + ! INTEGER, DIMENSION( : ), INTENT(INOUT) :: salty - REAL(KIND_PHYS), INTENT(IN) :: dtp - REAL(KIND_PHYS), DIMENSION( :,: ),INTENT(INOUT) :: z_lake3d - REAL(KIND_PHYS), DIMENSION( :,: ),INTENT(INOUT) :: dz_lake3d - REAL(KIND_PHYS), DIMENSION( :,: ),INTENT(INOUT) :: watsat3d - REAL(KIND_PHYS), DIMENSION( :,: ),INTENT(INOUT) :: csol3d, sand3d, clay3d - REAL(KIND_PHYS), DIMENSION( :,: ),INTENT(INOUT) :: tkmg3d - REAL(KIND_PHYS), DIMENSION( :,: ),INTENT(INOUT) :: tkdry3d - REAL(KIND_PHYS), DIMENSION( :,: ),INTENT(INOUT) :: tksatu3d - REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(INOUT) :: clm_lakedepth - REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(IN ) :: oro_lakedepth - - !feedback to atmosphere: - REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(OUT) :: hflx - REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(OUT) :: evap - REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(OUT) :: GRDFLX - REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(IN ) :: tsfc - REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(OUT) :: lake_t2m - REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(OUT) :: lake_q2m - - !in&out: - - real(kind_phys), dimension(: ) ,intent(inout) :: savedtke12d - real(kind_phys), dimension(: ) ,intent(inout) :: snowdp2d, & - h2osno2d, & - snl2d, & - t_grnd2d + + real(kind_phys), dimension(: ) ,intent(inout) :: savedtke12d, & + snowdp2d, & + h2osno2d, & + snl2d, & + t_grnd2d real(kind_phys), dimension( :,: ) ,INTENT(inout) :: t_lake3d, & lake_icefrac3d @@ -336,15 +324,33 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& z3d, & dz3d real(kind_phys), dimension( :,-nlevsnow+0: ) ,INTENT(inout) :: zi3d + + REAL(KIND_PHYS), DIMENSION( :,: ),INTENT(INOUT) :: z_lake3d + REAL(KIND_PHYS), DIMENSION( :,: ),INTENT(INOUT) :: dz_lake3d + REAL(KIND_PHYS), DIMENSION( :,: ),INTENT(INOUT) :: watsat3d + REAL(KIND_PHYS), DIMENSION( :,: ),INTENT(INOUT) :: csol3d, sand3d, clay3d + REAL(KIND_PHYS), DIMENSION( :,: ),INTENT(INOUT) :: tkmg3d + REAL(KIND_PHYS), DIMENSION( :,: ),INTENT(INOUT) :: tkdry3d + REAL(KIND_PHYS), DIMENSION( :,: ),INTENT(INOUT) :: tksatu3d + REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(INOUT) :: clm_lakedepth + + ! + ! Error reporting: + ! + INTEGER, INTENT(OUT) :: errflg + CHARACTER(*), INTENT(OUT) :: errmsg + - !local variable: + ! + !local variables: + ! REAL(kind_phys) :: SFCTMP,PBOT,PSFC,Q2K,LWDN,PRCP,SOLDN,SOLNET,dtime INTEGER :: C,i,j,k - !tempory varibles in: + !temporary varibles in: real(kind_phys) :: forc_t(1) ! atmospheric temperature (Kelvin) real(kind_phys) :: forc_pbot(1) ! atm bottom level pressure (Pa) real(kind_phys) :: forc_psrf(1) ! atmospheric surface pressure (Pa) @@ -466,20 +472,21 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& endif endif - ! Still have some points to initialize - call lakeini(kdt, ISLTYP, gt0, snowd, & - weasd, restart, lakedepth_default, fhour, & - oro_lakedepth, savedtke12d, snowdp2d, h2osno2d, & - snl2d, t_grnd2d, t_lake3d, lake_icefrac3d, & - z_lake3d, dz_lake3d, t_soisno3d, h2osoi_ice3d, & - h2osoi_liq3d, h2osoi_vol3d, z3d, dz3d, & - zi3d, watsat3d, csol3d, tkmg3d, & - fice, min_lakeice, tsfc, & - use_lake_model, use_lakedepth, con_g, con_rd, & - tkdry3d, tksatu3d, im, prsi, & - xlat_d, xlon_d, clm_lake_initialized, & - sand3d, clay3d, tg3, clm_lakedepth, & - km, me, master, errmsg, errflg) + ! Initialize any uninitialized lake points. + call lakeini(kdt=kdt, ISLTYP=ISLTYP, gt0=gt0, snowd=snowd, weasd=weasd, & + restart=restart, lakedepth_default=lakedepth_default, fhour=fhour, & + oro_lakedepth=oro_lakedepth, savedtke12d=savedtke12d, snowdp2d=snowdp2d, & + h2osno2d=h2osno2d, snl2d=snl2d, t_grnd2d=t_grnd2d, t_lake3d=t_lake3d, & + lake_icefrac3d=lake_icefrac3d, z_lake3d=z_lake3d, dz_lake3d=dz_lake3d, & + t_soisno3d=t_soisno3d, h2osoi_ice3d=h2osoi_ice3d, h2osoi_liq3d=h2osoi_liq3d, & + h2osoi_vol3d=h2osoi_vol3d, z3d=z3d, dz3d=dz3d, zi3d=zi3d, watsat3d=watsat3d, & + csol3d=csol3d, tkmg3d=tkmg3d, fice=fice, min_lakeice=min_lakeice, & + tsfc=tsfc, & + use_lake_model=use_lake_model, use_lakedepth=use_lakedepth, tkdry3d=tkdry3d, & + tksatu3d=tksatu3d, im=im, prsi=prsi, xlat_d=xlat_d, xlon_d=xlon_d, & + clm_lake_initialized=clm_lake_initialized, sand3d=sand3d, clay3d=clay3d, & + tg3=tg3, clm_lakedepth=clm_lakedepth, km=km, me=me, master=master, & + errmsg=errmsg, errflg=errflg) if(errflg/=0) then return endif @@ -535,13 +542,13 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& if(salty(i)/=0) then Tclim = tfrz + wght1*saltlk_T(num1) & + wght2*saltlk_T(num2) - if(lakedebug) print *,'Tclim,tsfc,t_lake3d',i,Tclim,tsfc(i),t_lake3d(i,:),t_soisno3d(i,:) - t_grnd2d(i) = min(Tclim+3.0_kind_phys,(max(tsfc(i),Tclim-3.0_kind_phys))) + if(lakedebug) print *,'Tclim,tsfc,t_lake3d',i,Tclim,tsfc_wat(i),t_lake3d(i,:),t_soisno3d(i,:) + t_grnd2d(i) = min(Tclim+3.0_kind_phys,(max(tsfc_wat(i),Tclim-3.0_kind_phys))) do k = 1,nlevlake t_lake3d(i,k) = min(Tclim+3.0_kind_phys,(max(t_lake3d(i,k),Tclim-3.0_kind_phys))) enddo t_soisno3d(i,1) = min(Tclim+3.0_kind_phys,(max(t_soisno3d(i,1),Tclim-3.0_kind_phys))) - if(lakedebug) print *,'After Tclim,tsfc,t_lake3d',i,Tclim,tsfc(i),t_lake3d(i,:),t_soisno3d(i,:) + if(lakedebug) print *,'After Tclim,tsfc,t_lake3d',i,Tclim,tsfc_wat(i),t_lake3d(i,:),t_soisno3d(i,:) endif SFCTMP = gt0(i,1) @@ -688,81 +695,99 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& enddo - if(feedback_to_atmosphere) then + feedback: if(feedback_to_atmosphere) then c = 1 - ! No equivalent in CCPP: - ! LH(I) = eflx_lh_tot(c)/rho1(i) ![kg*m/(kg*s)] - !-- The CLM output is combined for fractional ice and water if( t_grnd(c) >= tfrz ) then qfx = eflx_lh_tot(c)/hvap else - qfx = eflx_lh_tot(c)/hsub ! heat flux (W/m^2)=>mass flux(kg/(sm^2)) + qfx = eflx_lh_tot(c)/hsub ! heat flux (W/m^2)=>mass flux(kg/(sm^2)) endif - evap(i) = qfx/rho0(i) ! kinematic_surface_upward_latent_heat_flux_over_water - HFLX(i)=eflx_sh_tot(c)/(rho0(i)*con_cp) ! kinematic_surface_upward_sensible_heat_flux_over_water - GRDFLX(I) = eflx_gnet(c) ![W/m/m] upward_heat_flux_in_soil_over_water - lflx(i) = eflx_lh_tot(c) ![W/m/m] surface_upward_potential_latent_heat_flux_over_water - tsurf(I) = t_grnd(c) ![K] surface skin temperature after iteration over water - t_sfc(I) = t_grnd(c) ![K] surface skin temperature over water - lake_t2m(I) = t_ref2m(c) - !TH2(I) = T2(I)*(1.E5/PSFC)**RCP ! potential temperature (CCPP doesn't want this) - lake_q2m(I) = q_ref2m(c) ! [frac] specific humidity - albedo(i) = ( 0.6 * lake_icefrac3d(i,1) ) + ( (1.0-lake_icefrac3d(i,1)) * 0.08) - fice(i) = lake_icefrac3d(i,1) - - zorlw(i) = z0mg(c) - - if(fice(i)>=min_lakeice) then - weasdi(i) = h2osno(c) ! water_equivalent_accumulated_snow_depth_over_ice - snodi(i) = snowdp(c) ! surface_snow_thickness_water_equivalent_over_ice - tisfc(i) = t_grnd(c) ! surface_skin_temperature_over_ice - tsurf_ice(i) = t_grnd(c) ! surface_skin_temperature_after_iteration_over_ice - icy(i)=.true. + evap_wat(i) = qfx/rho0(i) ! kinematic_surface_upward_latent_heat_flux_over_water + hflx_wat(i)=eflx_sh_tot(c)/(rho0(i)*cpair) ! kinematic_surface_upward_sensible_heat_flux_over_water + gflx_wat(I) = eflx_gnet(c) ![W/m/m] upward_heat_flux_in_soil_over_water + ep1d_water(i) = eflx_lh_tot(c) ![W/m/m] surface_upward_potential_latent_heat_flux_over_water + tsurf_water(I) = t_grnd(c) ![K] surface skin temperature after iteration over water + tsfc_wat(i) = t_grnd(c) ![K] surface skin temperature over water + lake_t2m(I) = t_ref2m(c) ![K] temperature_at_2m_from_clm_lake + lake_q2m(I) = q_ref2m(c) ! [frac] specific_humidity_at_2m_from_clm_lake + albedo(i) = ( 0.6 * lake_icefrac3d(i,1) ) + & ! mid_day_surface_albedo_over_lake + ( (1.0-lake_icefrac3d(i,1)) * 0.08) + fice(i) = lake_icefrac3d(i,1) ! sea_ice_area_fraction_of_sea_area_fraction + uustar_water(i) = ustar_out(c) ! surface_friction_velocity_over_water + zorlw(i) = z0mg(c) ! surface_roughness_length_over_water + + ! WRF variables with no equivalent in CCPP: + ! LH(I) = eflx_lh_tot(c)/rho1(i) ![kg*m/(kg*s)] + !TH2(I) = T2(I)*(1.E5/PSFC)**RCP ! potential temperature + + ! Calculate qsfc from t_grnd: ! surface_specific_humidity_over_water + PSFC = prsi(i,1) + discard1 = -9999 + discard2 = -9999 + discard3 = -9999 + call QSat(t_grnd(c),psfc,discard1,discard2,qss_water(i),discard3) + + ! Combined water-ice chh and cmm calculations come from Flake model: + chh_water(i) = ch(i)*wind(i)*1.225 ! surface_drag_mass_flux_for_heat_and_moisture_in_air_over_water + cmm_water(i) = cm(i)*wind(i) ! surface_drag_wind_speed_for_momentum_in_air_over_water + + ice_point: if(fice(i)>=min_lakeice) then + ! Most ice variables are identical to water variables. + if(frac_ice .or. frac_grid) then + evap_ice(i) = evap_wat(i) ! kinematic_surface_upward_latent_heat_flux_over_ice + hflx_ice(i) = hflx_wat(i) ! kinematic_surface_upward_sensible_heat_flux_over_ice + gflx_ice(i) = gflx_wat(i) ! upward_heat_flux_in_soil_over_ice + ep1d_ice(i) = ep1d_water(i) ! surface_upward_potential_latent_heat_flux_over_ice + chh_ice(i) = chh_water(i) ! surface_drag_mass_flux_for_heat_and_moisture_in_air_over_ice + cmm_ice(i) = cmm_water(i) ! surface_drag_wind_speed_for_momentum_in_air_over_ice + qss_ice(i) = qss_water(i) ! surface_specific_humidity_over_ice + uustar_ice(i) = uustar_water(c) ! surface_friction_velocity_over_ice + endif + + tsurf_ice(i) = tsurf_water(i) ! surface_skin_temperature_after_iteration_over_ice + tisfc(i) = t_grnd(c) ! surface_skin_temperature_over_ice + weasdi(i) = h2osno(c) ! water_equivalent_accumulated_snow_depth_over_ice + snodi(i) = snowdp(c) ! surface_snow_thickness_water_equivalent_over_ice + tsurf_ice(i) = t_grnd(c) ! surface_skin_temperature_after_iteration_over_ice + + ! Ice points are icy: + icy(i)=.true. ! flag_nonzero_sea_ice_surface_fraction ice_points = ice_points+1 - zorli(i) = z0mg(c) + zorli(i) = z0mg(c) ! surface_roughness_length_over_ice ! Assume that, if a layer has ice, the entire layer thickness is ice. - hice(I) = 0 + hice(I) = 0 ! sea_ice_thickness do k=1,nlevlake if(lake_icefrac3d(i,k)>0) then hice(i) = hice(i) + dz_lake3d(i,k) endif end do - else + else ! Not an ice point + ! On non-icy lake points, set variables relevant to + ! lake ice to reasonable defaults. Let LSM fill in + ! other variables. icy(i)=.false. weasdi(i) = 0 snodi(i) = 0 - tisfc(i) = tsurf(i) + tisfc(i) = t_grnd(c) tsurf_ice(i) = tisfc(i) hice(i) = 0 fice(i) = 0 - endif + endif ice_point if(snl2d(i)<0) then - lake_t_snow(i) = t_grnd(c) - tisfc(i) = lake_t_snow(i) + ! If there is snow, ice surface temperature should be snow temperature. + lake_t_snow(i) = t_grnd(c) ! surface_skin_temperature_over_ice + tisfc(i) = lake_t_snow(i) ! temperature_of_snow_on_lake snow_points = snow_points+1 else lake_t_snow(i) = -9999 endif - ustar = ustar_out(1) ! surface_friction_velocity_over_water - - ! Calculate qsfc from t_grnd: (surface_specific_humidity_over_water) - PSFC = prsi(i,1) - discard1 = -9999 - discard2 = -9999 - discard3 = -9999 - call QSat(t_grnd(c),psfc,discard1,discard2,qsfc(i),discard3) - - ! From flake driver - combined ice/water: - chh(i)=ch(i)*wind(i)*1.225 ! surface_drag_mass_flux_for_heat_and_moisture_in_air_over_water - cmm(i)=cm(i)*wind(i) ! surface_drag_wind_speed_for_momentum_in_air_over_water - - endif + endif feedback endif if_lake_is_here ENDDO lake_top_loop @@ -775,28 +800,62 @@ SUBROUTINE clm_lake_run( flag_iter ,zlvl ,rho0 ,first_time_step ,& CONTAINS logical function point_is_unhappy(xlat_d,xlon_d) + ! Is this point near one of the points read in from the unhappy_txt file? + ! If lakedebug is false, then it will return false immediately. implicit none integer :: j real, intent(in) :: xlat_d,xlon_d - do j=1,unhappy_count - if(abs(xlat_d-unhappy_lat(j))<.015 .and. abs(xlon_d-unhappy_lon(j))<.015) then - point_is_unhappy=.true. -1444 format('Now processing unhappy point ',I0,' location xlat_d=',F20.12,' xlon_d=',F20.12,' close to xlat_d=',F20.12,' xlon_d=',F20.12) - print 1444,j,xlat_d,xlon_d,unhappy_lat(j),unhappy_lon(j) - return - endif - enddo + if(lakedebug) then + do j=1,unhappy_count + if(abs(xlat_d-unhappy_lat(j))<.015 .and. abs(xlon_d-unhappy_lon(j))<.015) then + point_is_unhappy=.true. +1444 format('Now processing unhappy point ',I0,' location xlat_d=',F20.12,' xlon_d=',F20.12,' close to xlat_d=',F20.12,' xlon_d=',F20.12) + print 1444,j,xlat_d,xlon_d,unhappy_lat(j),unhappy_lon(j) + return + endif + enddo + endif - ! No points matched + ! No points matched or lakedebug is disabled. point_is_unhappy=.false. end function point_is_unhappy subroutine read_unhappy_points + ! Reads points from unhappy_txt file into unhappy_lat and unhappy lon. + ! Sets unhappy_count to the number of points read in. + ! On error, sets unhappy_count to FAILED_TO_READ_UNHAPPY_POINTS + ! + ! Also allocates unhappy_lat and unhappy_lon. Their size may + ! be larger than the number of unhappy points if the header + ! line with the point count has a higher count than the + ! number of data lines. + ! + ! File format is: + ! ------------------------------------------ + ! |5 | number of points to read in. + ! |12.34567890000000000 12.34567890000000000| Lat and lon, exactly 20 characters each, with one space between + ! | 18.70411 134.4567890000000000| Lat and lon, exactly 20 characters each, with one space between + ! |-19.8567890000000000 -134.05| Lat and lon, exactly 20 characters each, with one space between + ! |36.34567890000000000 28.34567890000000000| Lat and lon, exactly 20 characters each, with one space between + ! |-85.4567890000000000 -41.4567890000000000| Lat and lon, exactly 20 characters each, with one space between + ! ------------------------------------------- + ! + ! Longitudes must be between -180 and +180 degrees. + ! + ! If the lat and lon fields are not exactly 20 characters, + ! with one space between them, the code will not work. You + ! can space-pad them before the number or put lots of zeros + ! after the decimal point. use ISO_FORTRAN_ENV, only: iostat_end, iostat_eor implicit none integer :: i,unhappy_iostat,unhappy_unit,expect_count,actual_count + ! This uses GOTOs to mimics a try-catch construct. Do not + ! remove the GOTOs. They are the cleanest and most + ! maintainable way to implement error handlers in Fortran + ! when a long cleanup block is required in multiple places. + ! Number of points actually read in is 0 since we haven't read yet. actual_count=0 @@ -844,13 +903,17 @@ subroutine read_unhappy_points return ! Success! + ! Error handlers. + + ! Theses do not set errmsg or error flag because this is + ! just an error in setting up a diagnostic, not in the model + ! itself. + 1000 continue ! Error handler, after file is opened close(unhappy_iostat) 1001 continue ! Error handler, whether file was opened or not write(0,'(A)') message - ! errmsg=message - ! errflg=1 if(allocated(unhappy_lat)) deallocate(unhappy_lat) if(allocated(unhappy_lon)) deallocate(unhappy_lon) unhappy_count=FAILED_TO_READ_UNHAPPY_POINTS @@ -5296,7 +5359,6 @@ subroutine clm_lake_init(con_pi,karman,con_g,con_sbc,con_t0c,rhowater,con_csol,c end subroutine clm_lake_init -! Some fields in lakeini are not available until runtime, so this cannot be in a CCPP init routine. SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, & !i weasd, restart, lakedepth_default, fhour, & oro_lakedepth, savedtke12d, snowdp2d, h2osno2d, & !o @@ -5304,13 +5366,20 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, z_lake3d, dz_lake3d, t_soisno3d, h2osoi_ice3d, & h2osoi_liq3d, h2osoi_vol3d, z3d, dz3d, & zi3d, watsat3d, csol3d, tkmg3d, & - fice, min_lakeice, tsfc, & - use_lake_model, use_lakedepth, con_g, con_rd, & + fice, min_lakeice, tsfc, & + use_lake_model, use_lakedepth, & tkdry3d, tksatu3d, im, prsi, & xlat_d, xlon_d, clm_lake_initialized, & sand3d, clay3d, tg3, clm_lakedepth, & km, me, master, errmsg, errflg) + ! Some fields in lakeini are not available during initialization, + ! so clm_lake_init cannot complete the initialization. What is not + ! in clm_lake_init, is initialized in lakeini on points where + ! use_lake_model(i)>0. The clm_lake_initialized(i) guards against + ! initializing a point twice. For that to work, + ! clm_lake_initialized must be a restart variable. + !============================================================================== ! This subroutine was first edited by Hongping Gu for coupling ! 07/20/2010 @@ -5323,7 +5392,7 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, CHARACTER(*), INTENT(OUT) :: errmsg INTEGER , INTENT (IN) :: im, me, master, km, kdt - REAL(KIND_PHYS), INTENT(IN) :: min_lakeice, con_g, con_rd, fhour + REAL(KIND_PHYS), INTENT(IN) :: min_lakeice, fhour REAL(KIND_PHYS), DIMENSION(IM), INTENT(INOUT):: FICE REAL(KIND_PHYS), DIMENSION(IM), INTENT(IN):: TG3, xlat_d, xlon_d REAL(KIND_PHYS), DIMENSION(IM), INTENT(IN):: tsfc diff --git a/physics/clm_lake.meta b/physics/clm_lake.meta index 5224b3616..e7e3f8ba3 100644 --- a/physics/clm_lake.meta +++ b/physics/clm_lake.meta @@ -7,30 +7,48 @@ [ccpp-arg-table] name = clm_lake_run type = scheme -[pgr] - standard_name = surface_air_pressure - long_name = surface pressure - units = Pa - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[km] + standard_name = vertical_layer_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in +[me] + standard_name = mpi_rank + long_name = current MPI-rank + units = index + dimensions = () + type = integer + intent = in +[master] + standard_name = mpi_root + long_name = master MPI-rank + units = index + dimensions = () + type = integer + intent = in +[restart] + standard_name = flag_for_restart + long_name = flag for restart (warmstart) or coldstart + units = flag + dimensions = () + type = logical + intent = in +[first_time_step] + standard_name = flag_for_first_timestep + long_name = flag for first time step for time integration loop (cold/warmstart) + units = flag + dimensions = () + type = logical intent = in -[zorlw] - standard_name = surface_roughness_length_over_water - long_name = surface roughness length over water - units = cm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[zorli] - standard_name = surface_roughness_length_over_ice - long_name = surface roughness length over ice - units = cm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout [fhour] standard_name = forecast_time long_name = current forecast time @@ -46,21 +64,6 @@ dimensions = (4) type = integer intent = in -[salty] - standard_name = clm_lake_is_salty - long_name = lake at this point is salty (1) or not (0) - units = 1 - dimensions = (horizontal_loop_extent) - type = integer - intent = inout -[tg3] - standard_name = deep_soil_temperature - long_name = deep soil temperature - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in [kdt] standard_name = index_of_timestep long_name = current forecast iteration @@ -68,20 +71,96 @@ dimensions = () type = integer intent = in -[first_time_step] - standard_name = flag_for_first_timestep - long_name = flag for first time step for time integration loop (cold/warmstart) +[iopt_lake] + standard_name = control_for_lake_model_selection + long_name = control for lake model selection + units = 1 + dimensions = () + type = integer + intent = in +[iopt_lake_clm] + standard_name = clm_lake_model_control_selection_value + long_name = value that indicates clm lake model in the control for lake model selection + units = 1 + dimensions = () + type = integer + intent = in +[min_lakeice] + standard_name = min_lake_ice_area_fraction + long_name = minimum lake ice value + units = frac + dimensions = () + type = real + kind = kind_phys + intent = in +[lakedepth_default] + standard_name = default_lake_depth_in_clm_lake_model + long_name = default lake depth in clm lake model + units = m + dimensions = () + type = real + kind = kind_phys + intent = in +[use_lakedepth] + standard_name = flag_for_initializing_clm_lake_depth_from_lake_depth + long_name = flag for initializing clm lake depth from lake depth units = flag dimensions = () type = logical intent = in -[flag_iter] - standard_name = flag_for_iteration - long_name = flag for iteration +[dtp] + standard_name = timestep_for_physics + long_name = physics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[use_lake_model] + standard_name = flag_for_using_lake_model + long_name = flag indicating lake points using a lake model + units = flag + dimensions = (horizontal_loop_extent) + type = integer + intent = inout +[clm_lake_initialized] + standard_name = flag_for_clm_lake_initialization + long_name = set to true in clm_lake_run after likeini is called, as a workaround for ccpp limitation units = flag dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[frac_grid] + standard_name = flag_for_fractional_landmask + long_name = flag for fractional grid + units = flag + dimensions = () + type = logical + intent = in +[frac_ice] + standard_name = flag_for_fractional_ice_when_fractional_landmask_is_disabled + long_name = flag for fractional ice when fractional landmask is disabled + units = flag + dimensions = () type = logical intent = in +[tg3] + standard_name = deep_soil_temperature + long_name = deep soil temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[pgr] + standard_name = surface_air_pressure + long_name = surface pressure + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [zlvl] standard_name = height_above_ground_at_lowest_model_layer long_name = layer 1 height above ground (not MSL) @@ -106,19 +185,11 @@ type = real kind = kind_phys intent = in -[con_rd] - standard_name = gas_constant_of_dry_air - long_name = ideal gas constant for dry air - units = J kg-1 K-1 - dimensions = () - type = real - kind = kind_phys - intent = in -[con_g] - standard_name = gravitational_acceleration - long_name = gravitational acceleration - units = m s-2 - dimensions = () +[phii] + standard_name = geopotential_at_interface + long_name = geopotential at model layer interfaces + units = m2 s-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) type = real kind = kind_phys intent = in @@ -130,14 +201,6 @@ type = real kind = kind_phys intent = in -[rho0] - standard_name = air_pressure_at_surface_adjacent_layer - long_name = mean pressure at lowest model layer - units = Pa - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in [gu0] standard_name = x_wind_of_new_state long_name = zonal wind updated by physics @@ -154,6 +217,38 @@ type = real kind = kind_phys intent = in +[xlat_d] + standard_name = latitude_in_degree + long_name = latitude in degree north + units = degree_north + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[xlon_d] + standard_name = longitude_in_degree + long_name = longitude in degree east + units = degree_east + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[ch] + standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air_over_water + long_name = surface exchange coeff heat surface exchange coeff heat & moisture over ocean moisture over water + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[cm] + standard_name = surface_drag_coefficient_for_momentum_in_air_over_water + long_name = surface exchange coeff for momentum over water + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [dlwsfci] standard_name = surface_downwelling_longwave_flux long_name = surface downwelling longwave flux at current time @@ -162,6 +257,14 @@ type = real kind = kind_phys intent = in +[dswsfci] + standard_name = surface_downwelling_shortwave_flux + long_name = surface downwelling shortwave flux at current time + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [emiss] standard_name = surface_longwave_emissivity long_name = surface lw emissivity in fraction @@ -178,297 +281,265 @@ type = real kind = kind_phys intent = in -[dtp] - standard_name = timestep_for_physics - long_name = physics timestep - units = s - dimensions = () +[oro_lakedepth] + standard_name = lake_depth + long_name = lake depth + units = m + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in -[dswsfci] - standard_name = surface_downwelling_shortwave_flux - long_name = surface downwelling shortwave flux at current time - units = W m-2 +[wind] + standard_name = wind_speed_at_lowest_model_layer + long_name = wind speed at lowest model level + units = m s-1 dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in -[albedo] - standard_name = mid_day_surface_albedo_over_lake - long_name = mid day surface albedo over lake - units = fraction +[rho0] + standard_name = air_pressure_at_surface_adjacent_layer + long_name = mean pressure at lowest model layer + units = Pa dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = inout -[xlat_d] - standard_name = latitude_in_degree - long_name = latitude in degree north - units = degree_north + intent = in +[tsfc] + standard_name = surface_skin_temperature + long_name = surface skin temperature + units = K dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in -[z_lake3d] - standard_name = depth_of_lake_interface_layers - long_name = depth of lake interface layers - units = fraction - dimensions = (horizontal_loop_extent, lake_vertical_dimension_for_clm_lake_model) +[flag_iter] + standard_name = flag_for_iteration + long_name = flag for iteration + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in +[isltyp] + standard_name = soil_type_classification + long_name = soil type at each grid cell + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[evap_wat] + standard_name = kinematic_surface_upward_latent_heat_flux_over_water + long_name = kinematic surface upward latent heat flux over water + units = kg kg-1 m s-1 + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout -[dz_lake3d] - standard_name = thickness_of_lake_layers - long_name = thickness of lake layers - units = fraction - dimensions = (horizontal_loop_extent, lake_vertical_dimension_for_clm_lake_model) +[evap_ice] + standard_name = kinematic_surface_upward_latent_heat_flux_over_ice + long_name = kinematic surface upward latent heat flux over ice + units = kg kg-1 m s-1 + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout -[clm_lakedepth] - standard_name = clm_lake_depth - long_name = clm internal copy of lake depth with 10.0 replaced by default lake depth - units = m +[hflx_wat] + standard_name = kinematic_surface_upward_sensible_heat_flux_over_water + long_name = kinematic surface upward sensible heat flux over water + units = K m s-1 dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = in -[oro_lakedepth] - standard_name = lake_depth - long_name = lake depth - units = m + intent = inout +[hflx_ice] + standard_name = kinematic_surface_upward_sensible_heat_flux_over_ice + long_name = kinematic surface upward sensible heat flux over ice + units = K m s-1 dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout -[watsat3d] - standard_name = saturated_volumetric_soil_water_in_lake_model - long_name = saturated volumetric soil water in lake model - units = m - dimensions = (horizontal_loop_extent, lake_vertical_dimension_for_clm_lake_model) +[gflx_wat] + standard_name = upward_heat_flux_in_soil_over_water + long_name = soil heat flux over water + units = W m-2 + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout -[csol3d] - standard_name = soil_heat_capacity_in_lake_model - long_name = soil heat capacity in lake model - units = m - dimensions = (horizontal_loop_extent, lake_vertical_dimension_for_clm_lake_model) +[gflx_ice] + standard_name = upward_heat_flux_in_soil_over_ice + long_name = soil heat flux over ice + units = W m-2 + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout -[tkmg3d] - standard_name = soil_mineral_thermal_conductivity_in_lake_model - long_name = soil mineral thermal conductivity in lake model - units = m - dimensions = (horizontal_loop_extent, lake_vertical_dimension_for_clm_lake_model) +[ep1d_water] + standard_name = surface_upward_potential_latent_heat_flux_over_water + long_name = surface upward potential latent heat flux over water + units = W m-2 + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout -[tkdry3d] - standard_name = dry_soil_thermal_conductivity_in_lake_model - long_name = dry soil thermal conductivity in lake model - units = m - dimensions = (horizontal_loop_extent, lake_vertical_dimension_for_clm_lake_model) +[ep1d_ice] + standard_name = surface_upward_potential_latent_heat_flux_over_ice + long_name = surface upward potential latent heat flux over ice + units = W m-2 + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout -[tksatu3d] - standard_name = saturated_soil_thermal_conductivity_in_lake_model - long_name = saturated soil thermal conductivity in lake model - units = m - dimensions = (horizontal_loop_extent, lake_vertical_dimension_for_clm_lake_model) +[tsurf_water] + standard_name = surface_skin_temperature_after_iteration_over_water + long_name = surface skin temperature after iteration over water + units = K + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout -[phii] - standard_name = geopotential_at_interface - long_name = geopotential at model layer interfaces - units = m2 s-2 - dimensions = (horizontal_loop_extent,vertical_interface_dimension) +[tsurf_ice] + standard_name = surface_skin_temperature_after_iteration_over_ice + long_name = surface skin temperature after iteration over ice + units = K + dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = in -[fice] - standard_name = sea_ice_area_fraction_of_sea_area_fraction - long_name = ice fraction over open water - units = frac + intent = inout +[tsfc_wat] + standard_name = surface_skin_temperature_over_water + long_name = surface skin temperature over water + units = K dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout -[min_lakeice] - standard_name = min_lake_ice_area_fraction - long_name = minimum lake ice value - units = frac - dimensions = () +[tisfc] + standard_name = surface_skin_temperature_over_ice + long_name = surface skin temperature over ice + units = K + dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = in -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[km] - standard_name = vertical_layer_dimension - long_name = number of vertical levels - units = count - dimensions = () - type = integer - intent = in -[h2osno2d] - standard_name = water_equivalent_accumulated_snow_depth_in_clm_lake_model - long_name = water equiv of acc snow depth over lake in clm lake model + intent = inout +[weasdi] + standard_name = water_equivalent_accumulated_snow_depth_over_ice + long_name = water equiv of acc snow depth over land units = mm dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout -[snowdp2d] - standard_name = actual_snow_depth_in_clm_lake_model - long_name = actual acc snow depth over lake in clm lake model +[snodi] + standard_name = surface_snow_thickness_water_equivalent_over_ice + long_name = water equivalent snow depth over ice + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[hice] + standard_name = sea_ice_thickness + long_name = sea ice thickness units = m dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout -[snl2d] - standard_name = snow_layers_in_clm_lake_model - long_name = snow layers in clm lake model (treated as integer) - units = count +[qss_water] + standard_name = surface_specific_humidity_over_water + long_name = surface air saturation specific humidity over water + units = kg kg-1 dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout -[z3d] - standard_name = snow_level_depth_in_clm_lake_model - long_name = snow level depth in clm lake model - units = m - dimensions = (horizontal_loop_extent,snow_plus_soil_minus_one_vertical_dimension_for_clm_lake_model) +[qss_ice] + standard_name = surface_specific_humidity_over_ice + long_name = surface air saturation specific humidity over ice + units = kg kg-1 + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout -[dz3d] - standard_name = snow_level_thickness_in_clm_lake_model - long_name = snow level thickness in clm lake model - units = m - dimensions = (horizontal_loop_extent,snow_plus_soil_minus_one_vertical_dimension_for_clm_lake_model) +[cmm_water] + standard_name = surface_drag_wind_speed_for_momentum_in_air_over_water + long_name = momentum exchange coefficient over water + units = m s-1 + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout -[zi3d] - standard_name = snow_interface_depth_in_clm_lake_model - long_name = snow interface_depth in clm lake model - units = m - dimensions = (horizontal_loop_extent,snow_plus_soil_vertical_dimension_for_clm_lake_model) +[cmm_ice] + standard_name = surface_drag_wind_speed_for_momentum_in_air_over_ice + long_name = momentum exchange coefficient over ice + units = m s-1 + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout -[h2osoi_vol3d] - standard_name = volumetric_soil_water_in_clm_lake_model - long_name = volumetric soil water in clm lake model - units = m3 m-3 - dimensions = (horizontal_loop_extent,snow_plus_soil_minus_one_vertical_dimension_for_clm_lake_model) +[chh_water] + standard_name = surface_drag_mass_flux_for_heat_and_moisture_in_air_over_water + long_name = thermal exchange coefficient over water + units = kg m-2 s-1 + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout -[h2osoi_liq3d] - standard_name = soil_liquid_water_content_in_clm_lake_model - long_name = soil liquid water content in clm lake model - units = kg m-3 - dimensions = (horizontal_loop_extent,snow_plus_soil_minus_one_vertical_dimension_for_clm_lake_model) +[chh_ice] + standard_name = surface_drag_mass_flux_for_heat_and_moisture_in_air_over_ice + long_name = thermal exchange coefficient over ice + units = kg m-2 s-1 + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout -[h2osoi_ice3d] - standard_name = soil_ice_water_content_in_clm_lake_model - long_name = soil ice water content in clm lake model - units = kg m-3 - dimensions = (horizontal_loop_extent,snow_plus_soil_minus_one_vertical_dimension_for_clm_lake_model) +[uustar_water] + standard_name = surface_friction_velocity_over_water + long_name = surface friction velocity over water + units = m s-1 + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout -[t_grnd2d] - standard_name = skin_temperature_from_clm_lake_model - long_name = skin_temperature_from_clm_lake_model - units = K +[uustar_ice] + standard_name = surface_friction_velocity_over_ice + long_name = surface friction velocity over ice + units = m s-1 dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout -[t_soisno3d] - standard_name = soil_or_snow_layer_temperature_from_clm_lake_model - long_name = soil or snow layer temperature from clm lake model +[lake_t_snow] + standard_name = temperature_of_snow_on_lake + long_name = the temperature of snow on a lake units = K - dimensions = (horizontal_loop_extent,snow_plus_soil_minus_one_vertical_dimension_for_clm_lake_model) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout -[t_lake3d] - standard_name = lake_layer_temperature_from_clm_lake_model - long_name = lake layer temperature from clm lake model - units = K - dimensions = (horizontal_loop_extent,lake_vertical_dimension_for_clm_lake_model) +[albedo] + standard_name = mid_day_surface_albedo_over_lake + long_name = mid day surface albedo over lake + units = fraction + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout -[savedtke12d] - standard_name = top_level_eddy_conductivity_from_previous_timestep_in_clm_lake_model - long_name = top level eddy conductivity from previous timestep in clm lake model - units = kg m-3 +[zorlw] + standard_name = surface_roughness_length_over_water + long_name = surface roughness length over water + units = cm dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout -[lake_icefrac3d] - standard_name = lake_fractional_ice_cover_on_clm_lake_levels - long_name = lake fractional ice cover on clm lake levels - units = kg m-3 - dimensions = (horizontal_loop_extent,lake_vertical_dimension_for_clm_lake_model) - type = real - kind = kind_phys - intent = inout -[con_cp] - standard_name = specific_heat_of_dry_air_at_constant_pressure - long_name = specific heat of dry air at constant pressure - units = J kg-1 K-1 - dimensions = () - type = real - kind = kind_phys - intent = in -[hflx] - standard_name = kinematic_surface_upward_sensible_heat_flux_over_water - long_name = kinematic surface upward sensible heat flux over water - units = K m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[evap] - standard_name = kinematic_surface_upward_latent_heat_flux_over_water - long_name = kinematic surface upward latent heat flux over water - units = kg kg-1 m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[grdflx] - standard_name = upward_heat_flux_in_soil_over_water - long_name = soil heat flux over water - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[tsfc] - standard_name = surface_skin_temperature - long_name = surface skin temperature - units = K - dimensions = (horizontal_loop_extent) +[zorli] + standard_name = surface_roughness_length_over_ice + long_name = surface roughness length over ice + units = cm + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout @@ -488,251 +559,234 @@ type = real kind = kind_phys intent = out -[clm_lake_initialized] - standard_name = flag_for_clm_lake_initialization - long_name = set to true in clm_lake_run after likeini is called, as a workaround for ccpp limitation - units = flag +[weasd] + standard_name = lwe_thickness_of_surface_snow_amount + long_name = water equiv of acc snow depth over land and sea ice + units = mm dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout -[isltyp] - standard_name = soil_type_classification - long_name = soil type at each grid cell - units = index +[snowd] + standard_name = lwe_surface_snow + long_name = water equivalent snow depth + units = mm dimensions = (horizontal_loop_extent) - type = integer + type = real + kind = kind_phys intent = inout -[use_lakedepth] - standard_name = flag_for_initializing_clm_lake_depth_from_lake_depth - long_name = flag for initializing clm lake depth from lake depth - units = flag - dimensions = () - type = logical - intent = in -[restart] - standard_name = flag_for_restart - long_name = flag for restart (warmstart) or coldstart - units = flag - dimensions = () - type = logical - intent = in -[lakedepth_default] - standard_name = default_lake_depth_in_clm_lake_model - long_name = default lake depth in clm lake model - units = m - dimensions = () +[fice] + standard_name = sea_ice_area_fraction_of_sea_area_fraction + long_name = ice fraction over open water + units = frac + dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = in -[use_lake_model] - standard_name = flag_for_using_lake_model - long_name = flag indicating lake points using a lake model + intent = inout +[icy] + standard_name = flag_nonzero_sea_ice_surface_fraction + long_name = flag indicating presence of some sea ice surface area fraction units = flag dimensions = (horizontal_loop_extent) - type = integer + type = logical intent = inout -[iopt_lake] - standard_name = control_for_lake_model_selection - long_name = control for lake model selection - units = 1 - dimensions = () - type = integer - intent = in -[iopt_lake_clm] - standard_name = clm_lake_model_control_selection_value - long_name = value that indicates clm lake model in the control for lake model selection +[salty] + standard_name = clm_lake_is_salty + long_name = lake at this point is salty (1) or not (0) units = 1 - dimensions = () - type = integer - intent = in -[clay3d] - standard_name = clm_lake_percent_clay - long_name = percent clay in clm lake model - units = percent - dimensions = (horizontal_loop_extent,soil_vertical_dimension_for_clm_lake_model) - type = integer - intent = inout -[sand3d] - standard_name = clm_lake_percent_sand - long_name = percent sand in clm lake model - units = percent - dimensions = (horizontal_loop_extent,soil_vertical_dimension_for_clm_lake_model) + dimensions = (horizontal_loop_extent) type = integer intent = inout -[weasd] - standard_name = lwe_thickness_of_surface_snow_amount - long_name = water equiv of acc snow depth over land and sea ice - units = mm +[savedtke12d] + standard_name = top_level_eddy_conductivity_from_previous_timestep_in_clm_lake_model + long_name = top level eddy conductivity from previous timestep in clm lake model + units = kg m-3 dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout -[snowd] - standard_name = lwe_surface_snow - long_name = water equivalent snow depth - units = mm +[snowdp2d] + standard_name = actual_snow_depth_in_clm_lake_model + long_name = actual acc snow depth over lake in clm lake model + units = m dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout -[weasdi] - standard_name = water_equivalent_accumulated_snow_depth_over_ice - long_name = water equiv of acc snow depth over land +[h2osno2d] + standard_name = water_equivalent_accumulated_snow_depth_in_clm_lake_model + long_name = water equiv of acc snow depth over lake in clm lake model units = mm dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout -[snodi] - standard_name = surface_snow_thickness_water_equivalent_over_ice - long_name = water equivalent snow depth over ice - units = mm +[snl2d] + standard_name = snow_layers_in_clm_lake_model + long_name = snow layers in clm lake model (treated as integer) + units = count dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout -[hice] - standard_name = sea_ice_thickness - long_name = sea ice thickness - units = m +[t_grnd2d] + standard_name = skin_temperature_from_clm_lake_model + long_name = skin_temperature_from_clm_lake_model + units = K dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout -[tsurf] - standard_name = surface_skin_temperature_after_iteration_over_water - long_name = surface skin temperature after iteration over water +[t_lake3d] + standard_name = lake_layer_temperature_from_clm_lake_model + long_name = lake layer temperature from clm lake model units = K - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_loop_extent,lake_vertical_dimension_for_clm_lake_model) type = real kind = kind_phys intent = inout -[t_sfc] - standard_name = surface_skin_temperature_over_water - long_name = surface skin temperature over water +[lake_icefrac3d] + standard_name = lake_fractional_ice_cover_on_clm_lake_levels + long_name = lake fractional ice cover on clm lake levels + units = kg m-3 + dimensions = (horizontal_loop_extent,lake_vertical_dimension_for_clm_lake_model) + type = real + kind = kind_phys + intent = inout +[t_soisno3d] + standard_name = soil_or_snow_layer_temperature_from_clm_lake_model + long_name = soil or snow layer temperature from clm lake model units = K - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_loop_extent,snow_plus_soil_minus_one_vertical_dimension_for_clm_lake_model) type = real kind = kind_phys intent = inout -[lflx] - standard_name = surface_upward_potential_latent_heat_flux_over_water - long_name = surface upward potential latent heat flux over water - units = W m-2 - dimensions = (horizontal_loop_extent) +[h2osoi_ice3d] + standard_name = soil_ice_water_content_in_clm_lake_model + long_name = soil ice water content in clm lake model + units = kg m-3 + dimensions = (horizontal_loop_extent,snow_plus_soil_minus_one_vertical_dimension_for_clm_lake_model) type = real kind = kind_phys intent = inout -[ustar] - standard_name = surface_friction_velocity_over_water - long_name = surface friction velocity over water - units = m s-1 - dimensions = (horizontal_loop_extent) +[h2osoi_liq3d] + standard_name = soil_liquid_water_content_in_clm_lake_model + long_name = soil liquid water content in clm lake model + units = kg m-3 + dimensions = (horizontal_loop_extent,snow_plus_soil_minus_one_vertical_dimension_for_clm_lake_model) type = real kind = kind_phys intent = inout -[qsfc] - standard_name = surface_specific_humidity_over_water - long_name = surface air saturation specific humidity over water - units = kg kg-1 - dimensions = (horizontal_loop_extent) +[h2osoi_vol3d] + standard_name = volumetric_soil_water_in_clm_lake_model + long_name = volumetric soil water in clm lake model + units = m3 m-3 + dimensions = (horizontal_loop_extent,snow_plus_soil_minus_one_vertical_dimension_for_clm_lake_model) type = real kind = kind_phys intent = inout -[ch] - standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air_over_water - long_name = surface exchange coeff heat surface exchange coeff heat & moisture over ocean moisture over water - units = none - dimensions = (horizontal_loop_extent) +[z3d] + standard_name = snow_level_depth_in_clm_lake_model + long_name = snow level depth in clm lake model + units = m + dimensions = (horizontal_loop_extent,snow_plus_soil_minus_one_vertical_dimension_for_clm_lake_model) type = real kind = kind_phys intent = inout -[cm] - standard_name = surface_drag_coefficient_for_momentum_in_air_over_water - long_name = surface exchange coeff for momentum over water - units = none - dimensions = (horizontal_loop_extent) +[dz3d] + standard_name = snow_level_thickness_in_clm_lake_model + long_name = snow level thickness in clm lake model + units = m + dimensions = (horizontal_loop_extent,snow_plus_soil_minus_one_vertical_dimension_for_clm_lake_model) type = real kind = kind_phys intent = inout -[chh] - standard_name = surface_drag_mass_flux_for_heat_and_moisture_in_air_over_water - long_name = thermal exchange coefficient over water - units = kg m-2 s-1 - dimensions = (horizontal_loop_extent) +[zi3d] + standard_name = snow_interface_depth_in_clm_lake_model + long_name = snow interface_depth in clm lake model + units = m + dimensions = (horizontal_loop_extent,snow_plus_soil_vertical_dimension_for_clm_lake_model) type = real kind = kind_phys intent = inout -[cmm] - standard_name = surface_drag_wind_speed_for_momentum_in_air_over_water - long_name = momentum exchange coefficient over water - units = m s-1 - dimensions = (horizontal_loop_extent) +[z_lake3d] + standard_name = depth_of_lake_interface_layers + long_name = depth of lake interface layers + units = fraction + dimensions = (horizontal_loop_extent, lake_vertical_dimension_for_clm_lake_model) type = real kind = kind_phys intent = inout -[lake_t_snow] - standard_name = temperature_of_snow_on_lake - long_name = the temperature of snow on a lake - units = K - dimensions = (horizontal_loop_extent) +[dz_lake3d] + standard_name = thickness_of_lake_layers + long_name = thickness of lake layers + units = fraction + dimensions = (horizontal_loop_extent, lake_vertical_dimension_for_clm_lake_model) type = real kind = kind_phys intent = inout -[tisfc] - standard_name = surface_skin_temperature_over_ice - long_name = surface skin temperature over ice - units = K - dimensions = (horizontal_loop_extent) +[watsat3d] + standard_name = saturated_volumetric_soil_water_in_lake_model + long_name = saturated volumetric soil water in lake model + units = m + dimensions = (horizontal_loop_extent, lake_vertical_dimension_for_clm_lake_model) type = real kind = kind_phys intent = inout -[tsurf_ice] - standard_name = surface_skin_temperature_after_iteration_over_ice - long_name = surface skin temperature after iteration over ice - units = K - dimensions = (horizontal_loop_extent) +[csol3d] + standard_name = soil_heat_capacity_in_lake_model + long_name = soil heat capacity in lake model + units = m + dimensions = (horizontal_loop_extent, lake_vertical_dimension_for_clm_lake_model) type = real kind = kind_phys intent = inout -[wind] - standard_name = wind_speed_at_lowest_model_layer - long_name = wind speed at lowest model level - units = m s-1 - dimensions = (horizontal_loop_extent) +[sand3d] + standard_name = clm_lake_percent_sand + long_name = percent sand in clm lake model + units = percent + dimensions = (horizontal_loop_extent,soil_vertical_dimension_for_clm_lake_model) + type = integer + intent = inout +[clay3d] + standard_name = clm_lake_percent_clay + long_name = percent clay in clm lake model + units = percent + dimensions = (horizontal_loop_extent,soil_vertical_dimension_for_clm_lake_model) + type = integer + intent = inout +[tkmg3d] + standard_name = soil_mineral_thermal_conductivity_in_lake_model + long_name = soil mineral thermal conductivity in lake model + units = m + dimensions = (horizontal_loop_extent, lake_vertical_dimension_for_clm_lake_model) type = real kind = kind_phys - intent = in -[xlon_d] - standard_name = longitude_in_degree - long_name = longitude in degree east - units = degree_east + intent = inout +[tkdry3d] + standard_name = dry_soil_thermal_conductivity_in_lake_model + long_name = dry soil thermal conductivity in lake model + units = m + dimensions = (horizontal_loop_extent, lake_vertical_dimension_for_clm_lake_model) + type = real + kind = kind_phys + intent = inout +[tksatu3d] + standard_name = saturated_soil_thermal_conductivity_in_lake_model + long_name = saturated soil thermal conductivity in lake model + units = m + dimensions = (horizontal_loop_extent, lake_vertical_dimension_for_clm_lake_model) + type = real + kind = kind_phys + intent = inout +[clm_lakedepth] + standard_name = clm_lake_depth + long_name = clm internal copy of lake depth with 10.0 replaced by default lake depth + units = m dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in -[me] - standard_name = mpi_rank - long_name = current MPI-rank - units = index - dimensions = () - type = integer - intent = in -[master] - standard_name = mpi_root - long_name = master MPI-rank - units = index - dimensions = () - type = integer - intent = in -[icy] - standard_name = flag_nonzero_sea_ice_surface_fraction - long_name = flag indicating presence of some sea ice surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = inout [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 217a8bf497c484842a0d26c3fa3425160d3f2e7e Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 20 Oct 2022 19:52:49 +0000 Subject: [PATCH 055/380] bug fixes to get fractional ice working --- physics/GFS_surface_composites_pre.F90 | 9 +++++++-- physics/clm_lake.f90 | 4 ++-- 2 files changed, 9 insertions(+), 4 deletions(-) diff --git a/physics/GFS_surface_composites_pre.F90 b/physics/GFS_surface_composites_pre.F90 index 9a34fddf7..fa0398d94 100644 --- a/physics/GFS_surface_composites_pre.F90 +++ b/physics/GFS_surface_composites_pre.F90 @@ -200,9 +200,14 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, iopt_lake, iopt_l endif islmsk_cice(i) = islmsk(i) flag_cice(i) = .false. - if (cice(i) < one) then + if(is_clm) then + wet(i) = .true. + if (icy(i)) then + tsfco(i) = max(tisfc(i), tgice) + endif + else if(cice(i) < one) then wet(i) = .true. ! some open lake - if (icy(i) .and. .not.is_clm) then + if (icy(i)) then tsfco(i) = max(tisfc(i), tgice) endif endif diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90 index 3d4cb6d9a..fee6d9cc8 100644 --- a/physics/clm_lake.f90 +++ b/physics/clm_lake.f90 @@ -715,7 +715,7 @@ SUBROUTINE clm_lake_run( & albedo(i) = ( 0.6 * lake_icefrac3d(i,1) ) + & ! mid_day_surface_albedo_over_lake ( (1.0-lake_icefrac3d(i,1)) * 0.08) fice(i) = lake_icefrac3d(i,1) ! sea_ice_area_fraction_of_sea_area_fraction - uustar_water(i) = ustar_out(c) ! surface_friction_velocity_over_water + !uustar_water(i) = ustar_out(c) ! surface_friction_velocity_over_water zorlw(i) = z0mg(c) ! surface_roughness_length_over_water ! WRF variables with no equivalent in CCPP: @@ -743,7 +743,7 @@ SUBROUTINE clm_lake_run( & chh_ice(i) = chh_water(i) ! surface_drag_mass_flux_for_heat_and_moisture_in_air_over_ice cmm_ice(i) = cmm_water(i) ! surface_drag_wind_speed_for_momentum_in_air_over_ice qss_ice(i) = qss_water(i) ! surface_specific_humidity_over_ice - uustar_ice(i) = uustar_water(c) ! surface_friction_velocity_over_ice +! uustar_ice(i) = uustar_water(i) ! surface_friction_velocity_over_ice endif tsurf_ice(i) = tsurf_water(i) ! surface_skin_temperature_after_iteration_over_ice From c34a3d381b5930d1a3f8eb83e9e5c163f4e24b31 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Mon, 24 Oct 2022 19:30:22 +0000 Subject: [PATCH 056/380] bug fixes for restart (not enough though) --- physics/GFS_MP_generic_post.F90 | 12 +++++++----- physics/GFS_MP_generic_post.meta | 21 +++++++++++++++++++++ physics/clm_lake.f90 | 20 ++++++++++---------- physics/clm_lake.meta | 28 +++++++++++----------------- 4 files changed, 49 insertions(+), 32 deletions(-) diff --git a/physics/GFS_MP_generic_post.F90 b/physics/GFS_MP_generic_post.F90 index 0940ab7b6..b0178b5ef 100644 --- a/physics/GFS_MP_generic_post.F90 +++ b/physics/GFS_MP_generic_post.F90 @@ -28,7 +28,7 @@ subroutine GFS_MP_generic_post_run( graupelprv, draincprv, drainncprv, diceprv, dsnowprv, dgraupelprv, dtp, dfi_radar_max_intervals, & dtend, dtidx, index_of_temperature, index_of_process_mp,ldiag3d, qdiag3d,dqdt_qmicro, lssav, num_dfi_radar, & fh_dfi_radar,index_of_process_dfi_radar, ix_dfi_radar, dfi_radar_tten, radar_tten_limits, fhour, prevsq, & - errmsg, errflg) + iopt_lake, iopt_lake_clm, lkm, errmsg, errflg) ! use machine, only: kind_phys use calpreciptype_mod, only: calpreciptype @@ -36,7 +36,7 @@ subroutine GFS_MP_generic_post_run( integer, intent(in) :: im, levs, kdt, nrcm, nncl, ntcw, ntrac, num_dfi_radar, index_of_process_dfi_radar integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_mg, imp_physics_fer_hires - integer, intent(in) :: imp_physics_nssl + integer, intent(in) :: imp_physics_nssl, iopt_lake_clm, iopt_lake, lkm logical, intent(in) :: cal_pre, lssav, ldiag3d, qdiag3d, cplflx, cplchm, progsigma integer, intent(in) :: index_of_temperature,index_of_process_mp @@ -138,9 +138,10 @@ subroutine GFS_MP_generic_post_run( ice = frain*rain1*sr ! time-step ice end if - if (lsm==lsm_ruc .or. lsm==lsm_noahmp) then - raincprv(:) = rainc(:) - rainncprv(:) = frain * rain1(:) + if (lsm==lsm_ruc .or. lsm==lsm_noahmp .or. (lkm>0 .and. iopt_lake==iopt_lake_clm)) then + raincprv(:) = rainc(:) + rainncprv(:) = frain * rain1(:) + if(lsm==lsm_ruc .or. lsm==lsm_noahmp) then iceprv(:) = ice(:) snowprv(:) = snow(:) graupelprv(:) = graupel(:) @@ -155,6 +156,7 @@ subroutine GFS_MP_generic_post_run( dgraupelprv(:) = tem * graupelprv(:) diceprv(:) = tem * iceprv(:) end if + end if end if if (cal_pre) then ! hchuang: add dominant precipitation type algorithm diff --git a/physics/GFS_MP_generic_post.meta b/physics/GFS_MP_generic_post.meta index 7ba09363a..b52e1dcd8 100644 --- a/physics/GFS_MP_generic_post.meta +++ b/physics/GFS_MP_generic_post.meta @@ -754,6 +754,27 @@ dimensions = () type = logical intent = in +[lkm] + standard_name = control_for_lake_model_execution_method + long_name = control for lake model execution: 0=no lake, 1=lake, 2=lake+nsst + units = flag + dimensions = () + type = integer + intent = in +[iopt_lake] + standard_name = control_for_lake_model_selection + long_name = control for lake model selection + units = 1 + dimensions = () + type = integer + intent = in +[iopt_lake_clm] + standard_name = clm_lake_model_control_selection_value + long_name = value that indicates clm lake model in the control for lake model selection + units = 1 + dimensions = () + type = integer + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90 index fee6d9cc8..0b1498395 100644 --- a/physics/clm_lake.f90 +++ b/physics/clm_lake.f90 @@ -226,7 +226,7 @@ end function is_salty !! SUBROUTINE clm_lake_run( & ! Model time and metadata: - im, km, me, master, restart, first_time_step, fhour, IDATE, kdt, & + im, km, me, master, fhour, IDATE, kdt, & ! Configuration and initialization: iopt_lake, iopt_lake_clm, min_lakeice, lakedepth_default, use_lakedepth, & @@ -234,8 +234,8 @@ SUBROUTINE clm_lake_run( & ! Atmospheric model state inputs: tg3, pgr, zlvl, gt0, prsi, phii, qvcurr, gu0, gv0, xlat_d, xlon_d, & - ch, cm, dlwsfci, dswsfci, emiss, rain, oro_lakedepth, wind, rho0, tsfc, & - flag_iter, ISLTYP, & + ch, cm, dlwsfci, dswsfci, emiss, oro_lakedepth, wind, rho0, tsfc, & + flag_iter, ISLTYP, rainncprv, raincprv, & ! Feedback to atmosphere: evap_wat, evap_ice, hflx_wat, hflx_ice, gflx_wat, gflx_ice, & @@ -268,7 +268,6 @@ SUBROUTINE clm_lake_run( & ! Model time and metadata: ! INTEGER , INTENT (IN) :: im,km,me,master - LOGICAL, INTENT(IN) :: restart,first_time_step INTEGER, INTENT(IN) :: IDATE(4), kdt REAL, INTENT(IN) :: fhour @@ -287,7 +286,8 @@ SUBROUTINE clm_lake_run( & ! REAL(KIND_PHYS), DIMENSION(:), INTENT(IN):: & tg3, pgr, zlvl, qvcurr, xlat_d, xlon_d, ch, cm, & - dlwsfci, dswsfci, emiss, rain, oro_lakedepth, wind, rho0, tsfc + dlwsfci, dswsfci, emiss, oro_lakedepth, wind, rho0, tsfc, & + rainncprv, raincprv REAL(KIND_PHYS), DIMENSION(:,:), INTENT(in) :: gu0, gv0, prsi, gt0, phii LOGICAL, DIMENSION(:), INTENT(IN) :: flag_iter INTEGER, DIMENSION(:), INTENT(IN) :: ISLTYP @@ -362,7 +362,7 @@ SUBROUTINE clm_lake_run( & real(kind_phys) :: forc_u(1) ! atmospheric wind speed in east direction (m/s) real(kind_phys) :: forc_v(1) ! atmospheric wind speed in north direction (m/s) real(kind_phys) :: forc_lwrad(1) ! downward infrared (longwave) radiation (W/m**2) - real(kind_phys) :: prec(1) ! snow or rain rate [mm/s] + real(kind_phys) :: prec(1) ! snow or rain rate [mm/s] real(kind_phys) :: sabg(1) ! solar radiation absorbed by ground (W/m**2) real(kind_phys) :: lat(1) ! latitude (radians) real(kind_phys) :: z_lake(1,nlevlake) ! layer depth for lake (m) @@ -474,7 +474,7 @@ SUBROUTINE clm_lake_run( & ! Initialize any uninitialized lake points. call lakeini(kdt=kdt, ISLTYP=ISLTYP, gt0=gt0, snowd=snowd, weasd=weasd, & - restart=restart, lakedepth_default=lakedepth_default, fhour=fhour, & + lakedepth_default=lakedepth_default, fhour=fhour, & oro_lakedepth=oro_lakedepth, savedtke12d=savedtke12d, snowdp2d=snowdp2d, & h2osno2d=h2osno2d, snl2d=snl2d, t_grnd2d=t_grnd2d, t_lake3d=t_lake3d, & lake_icefrac3d=lake_icefrac3d, z_lake3d=z_lake3d, dz_lake3d=dz_lake3d, & @@ -556,7 +556,8 @@ SUBROUTINE clm_lake_run( & PSFC = pgr(i) Q2K = qvcurr(i) LWDN = DLWSFCI(I)*EMISS(I) - PRCP = RAIN(i)/dtime ! [mm/s] use physics timestep since PRCP comes from non-surface schemes + ! FIXME: Should multiply PRCP by 1000 + PRCP = (raincprv(i)+rainncprv(i))/dtime ! [mm/s] use physics timestep since PRCP comes from non-surface schemes SOLDN = DSWSFCI(I) ! SOLDN is total incoming solar SOLNET = SOLDN*(1.-ALBEDO(I)) ! use mid-day albedo to determine net downward solar ! (no solar zenith angle correction) @@ -5360,7 +5361,7 @@ subroutine clm_lake_init(con_pi,karman,con_g,con_sbc,con_t0c,rhowater,con_csol,c end subroutine clm_lake_init SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, & !i - weasd, restart, lakedepth_default, fhour, & + weasd, lakedepth_default, fhour, & oro_lakedepth, savedtke12d, snowdp2d, h2osno2d, & !o snl2d, t_grnd2d, t_lake3d, lake_icefrac3d, & z_lake3d, dz_lake3d, t_soisno3d, h2osoi_ice3d, & @@ -5402,7 +5403,6 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, !INTEGER , INTENT (INOUT) :: lake_depth_flag LOGICAL, INTENT (IN) :: use_lakedepth - LOGICAL , INTENT(IN) :: restart INTEGER, DIMENSION(IM), INTENT(IN) :: ISLTYP REAL(KIND_PHYS), DIMENSION(IM), INTENT(INOUT) :: snowd,weasd REAL(kind_phys), DIMENSION(IM,KM), INTENT(IN) :: gt0, prsi diff --git a/physics/clm_lake.meta b/physics/clm_lake.meta index e7e3f8ba3..d2d477490 100644 --- a/physics/clm_lake.meta +++ b/physics/clm_lake.meta @@ -35,20 +35,6 @@ dimensions = () type = integer intent = in -[restart] - standard_name = flag_for_restart - long_name = flag for restart (warmstart) or coldstart - units = flag - dimensions = () - type = logical - intent = in -[first_time_step] - standard_name = flag_for_first_timestep - long_name = flag for first time step for time integration loop (cold/warmstart) - units = flag - dimensions = () - type = logical - intent = in [fhour] standard_name = forecast_time long_name = current forecast time @@ -273,9 +259,17 @@ type = real kind = kind_phys intent = in -[rain] - standard_name = lwe_thickness_of_precipitation_amount_on_dynamics_timestep - long_name = total rain at this time step +[raincprv] + standard_name = lwe_thickness_of_convective_precipitation_amount_on_previous_timestep + long_name = convective_precipitation_amount from previous timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[rainncprv] + standard_name = lwe_thickness_of_explicit_precipitation_amount_on_previous_timestep + long_name = explicit rainfall from previous timestep units = m dimensions = (horizontal_loop_extent) type = real From 469ef08b05e7dd74fd4d1adc557d9d18241a63ad Mon Sep 17 00:00:00 2001 From: dustinswales Date: Thu, 27 Oct 2022 13:10:24 -0600 Subject: [PATCH 057/380] Update CODEOWNERS --- CODEOWNERS | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/CODEOWNERS b/CODEOWNERS index 3cf17b8bb..15821a791 100644 --- a/CODEOWNERS +++ b/CODEOWNERS @@ -163,8 +163,8 @@ physics/rrtmgp_sw_* @dustinswales physics/rrtmg_sw_cloud_optics.F90 @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales physics/rrtmg_sw_post.* @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales physics/rte-rrtmgp @RobertPincus @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/samfdeepcnv.* @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/samfshalcnv.* @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/samfdeepcnv.* @JongilHan66 @lisa-bengtsson @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/samfshalcnv.* @JongilHan66 @lisa-bengtsson @grantfirl @ChunxiZhang-NOAA @dustinswales physics/samfaerosols.* @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales physics/sascnvn.* @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales physics/satmedmfvdif.* @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales From 6d74eafffee0b1a5e3763a1dd1fb01b17d896078 Mon Sep 17 00:00:00 2001 From: dustinswales Date: Thu, 27 Oct 2022 14:36:24 -0600 Subject: [PATCH 058/380] Changes to metadata to accommodate standard_name rules. --- physics/GFS_phys_time_vary.fv3.meta | 6 ++--- physics/GFS_rad_time_vary.fv3.meta | 4 +-- physics/GFS_rad_time_vary.scm.meta | 4 +-- physics/GFS_rrtmg_pre.meta | 12 ++++----- physics/GFS_rrtmg_setup.meta | 38 ++++++++++++++--------------- physics/GFS_rrtmgp_setup.meta | 24 +++++++++--------- physics/radsw_main.meta | 6 ++--- 7 files changed, 47 insertions(+), 47 deletions(-) diff --git a/physics/GFS_phys_time_vary.fv3.meta b/physics/GFS_phys_time_vary.fv3.meta index 36ac38ab9..ce8c6c54b 100644 --- a/physics/GFS_phys_time_vary.fv3.meta +++ b/physics/GFS_phys_time_vary.fv3.meta @@ -45,9 +45,9 @@ type = logical intent = in [iaermdl] - standard_name = flag_for_aerosol_radiation_scheme - long_name = flag for aerosol scheme to use in radiation - units = flag + standard_name = control_for_aerosol_radiation_scheme + long_name = control of aerosol scheme in radiation + units = 1 dimensions = () type = integer intent = in diff --git a/physics/GFS_rad_time_vary.fv3.meta b/physics/GFS_rad_time_vary.fv3.meta index 387625796..19eb41dc2 100644 --- a/physics/GFS_rad_time_vary.fv3.meta +++ b/physics/GFS_rad_time_vary.fv3.meta @@ -137,14 +137,14 @@ [ipsd0] standard_name = initial_seed_for_mcica long_name = initial permutaion seed for mcica radiation - units = none + units = 1 dimensions = () type = integer intent = in [ipsdlim] standard_name = limit_for_initial_seed_for_mcica long_name = limit for initial permutaion seed for mcica radiation - units = none + units = 1 dimensions = () type = integer intent = in diff --git a/physics/GFS_rad_time_vary.scm.meta b/physics/GFS_rad_time_vary.scm.meta index 387625796..19eb41dc2 100644 --- a/physics/GFS_rad_time_vary.scm.meta +++ b/physics/GFS_rad_time_vary.scm.meta @@ -137,14 +137,14 @@ [ipsd0] standard_name = initial_seed_for_mcica long_name = initial permutaion seed for mcica radiation - units = none + units = 1 dimensions = () type = integer intent = in [ipsdlim] standard_name = limit_for_initial_seed_for_mcica long_name = limit for initial permutaion seed for mcica radiation - units = none + units = 1 dimensions = () type = integer intent = in diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 34aade056..53f05225b 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -220,16 +220,16 @@ type = integer intent = in [iaermdl] - standard_name = flag_for_aerosol_radiation_scheme - long_name = flag for aerosol scheme to use in radiation - units = flag + standard_name = control_for_aerosol_radiation_scheme + long_name = control of aerosol scheme in radiation + units = 1 dimensions = () type = integer intent = in [iaerflg] - standard_name = flag_for_aerosol_effects_in_radiation - long_name = flag for aerosol effects to include in radiation - units = flag + standard_name = control_for_aerosol_effects_in_radiation + long_name = control of aerosol effects in radiation + units = 1 dimensions = () type = integer intent = in diff --git a/physics/GFS_rrtmg_setup.meta b/physics/GFS_rrtmg_setup.meta index d6f0b0e7a..5821de33f 100644 --- a/physics/GFS_rrtmg_setup.meta +++ b/physics/GFS_rrtmg_setup.meta @@ -167,9 +167,9 @@ type = integer intent = in [iswmode] - standard_name = flag_for_sw_scattering_choice - long_name = flag for rrtmg shortwave scattering choice - units = flag + standard_name = control_for_sw_scattering_choice + long_name = control of rrtmg shortwave scattering choice + units = 1 dimensions = () type = integer intent = in @@ -261,9 +261,9 @@ kind = len=26 intent = in [rad_hr_units] - standard_name = flag_for_radiation_heating_rate_units - long_name = flag to control heating rate units - units = count + standard_name = control_for_radiation_heating_rate_units + long_name = control of heating rate units + units = 1 dimensions = () type = integer intent = in @@ -322,9 +322,9 @@ kind = kind_phys intent = in [lalw1bd] - standard_name = flag_for_longwave_aerosol_band_properties - long_name = flag for band or multiband longwave aerosol properties - units = flag + standard_name = do_longwave_aerosol_band_properties + long_name = control of band or multiband longwave aerosol properties + units = 1 dimensions = () type = logical intent = in @@ -345,21 +345,21 @@ [ipsd0] standard_name = initial_seed_for_mcica long_name = initial permutaion seed for mcica radiation - units = none + units = 1 dimensions = () type = integer intent = inout [iaermdl] - standard_name = flag_for_aerosol_radiation_scheme - long_name = flag for aerosol scheme to use in radiation - units = flag + standard_name = control_for_aerosol_radiation_scheme + long_name = control of aerosol scheme in radiation + units = 1 dimensions = () type = integer intent = out [iaerflg] - standard_name = flag_for_aerosol_effects_in_radiation - long_name = flag for aerosol effects to include in radiation - units = flag + standard_name = control_for_aerosol_effects_in_radiation + long_name = control of aerosol effects in radiation + units = 1 dimensions = () type = integer intent = out @@ -428,9 +428,9 @@ type = integer intent = in [iaermdl] - standard_name = flag_for_aerosol_radiation_scheme - long_name = flag for aerosol scheme to use in radiation - units = flag + standard_name = control_for_aerosol_radiation_scheme + long_name = control of aerosol scheme in radiation + units = 1 dimensions = () type = integer intent = in diff --git a/physics/GFS_rrtmgp_setup.meta b/physics/GFS_rrtmgp_setup.meta index d47aadb93..ad4a8a765 100644 --- a/physics/GFS_rrtmgp_setup.meta +++ b/physics/GFS_rrtmgp_setup.meta @@ -175,9 +175,9 @@ type = integer intent = in [lalw1bd] - standard_name = flag_for_longwave_aerosol_band_properties - long_name = flag for band or multiband longwave aerosol properties - units = flag + standard_name = do_longwave_aerosol_band_properties + long_name = control of band or multiband longwave aerosol properties + units = 1 dimensions = () type = logical intent = in @@ -267,16 +267,16 @@ type = integer intent = inout [iaermdl] - standard_name = flag_for_aerosol_radiation_scheme - long_name = flag for aerosol scheme to use in radiation - units = flag + standard_name = control_for_aerosol_radiation_scheme + long_name = control of aerosol scheme in radiation + units = 1 dimensions = () type = integer intent = out [iaerflg] - standard_name = flag_for_aerosol_effects_in_radiation - long_name = flag for aerosol effects to include in radiation - units = flag + standard_name = control_for_aerosol_effects_in_radiation + long_name = control of aerosol effects in radiation + units = 1 dimensions = () type = integer intent = out @@ -390,9 +390,9 @@ type = integer intent = in [iaermdl] - standard_name = flag_for_aerosol_radiation_scheme - long_name = flag for aerosol scheme to use in radiation - units = flag + standard_name = control_for_aerosol_radiation_scheme + long_name = control of aerosol scheme in radiation + units = 1 dimensions = () type = integer intent = in diff --git a/physics/radsw_main.meta b/physics/radsw_main.meta index eff5cdca3..1edb6fcac 100644 --- a/physics/radsw_main.meta +++ b/physics/radsw_main.meta @@ -365,9 +365,9 @@ type = integer intent = in [iswmode] - standard_name = flag_for_sw_scattering_choice - long_name = flag for rrtmg shortwave scattering choice - units = flag + standard_name = control_for_sw_scattering_choice + long_name = control of rrtmg shortwave scattering choice + units = 1 dimensions = () type = integer intent = in From 751d5c738df6aad2540fae3e83f45b97faf56a64 Mon Sep 17 00:00:00 2001 From: dustinswales Date: Tue, 1 Nov 2022 17:42:04 -0600 Subject: [PATCH 059/380] Set fv3atm fork used in CI to NCAR, from NOAA-EMC --- .github/workflows/ci_fv3_ccpp_prebuild.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci_fv3_ccpp_prebuild.yml b/.github/workflows/ci_fv3_ccpp_prebuild.yml index a32b66b7b..1d41a2891 100644 --- a/.github/workflows/ci_fv3_ccpp_prebuild.yml +++ b/.github/workflows/ci_fv3_ccpp_prebuild.yml @@ -26,7 +26,7 @@ jobs: run: echo "GIT_REMOTE_HASH=`git rev-parse HEAD`" >> $GITHUB_ENV - name: Checkout latest fv3atm - run: git clone https://github.com/NOAA-EMC/fv3atm.git + run: git clone https://github.com/NCAR/fv3atm.git - name: Initialize submodules run: | From 4900b309c9a15c9544c64ae42b343458f203031e Mon Sep 17 00:00:00 2001 From: dustinswales Date: Wed, 2 Nov 2022 10:02:34 -0600 Subject: [PATCH 060/380] Omission from previous commit. --- physics/GFS_rrtmg_setup.meta | 6 +++--- physics/rrtmgp_aerosol_optics.meta | 12 ++++++------ 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/physics/GFS_rrtmg_setup.meta b/physics/GFS_rrtmg_setup.meta index 5821de33f..93319fe75 100644 --- a/physics/GFS_rrtmg_setup.meta +++ b/physics/GFS_rrtmg_setup.meta @@ -435,9 +435,9 @@ type = integer intent = in [iaerflg] - standard_name = flag_for_aerosol_effects_in_radiation - long_name = flag for aerosol effects to include in radiation - units = flag + standard_name = control_for_aerosol_effects_in_radiation + long_name = control of aerosol effects in radiation + units = 1 dimensions = () type = integer intent = in diff --git a/physics/rrtmgp_aerosol_optics.meta b/physics/rrtmgp_aerosol_optics.meta index 5f5946afa..74c0f4f70 100644 --- a/physics/rrtmgp_aerosol_optics.meta +++ b/physics/rrtmgp_aerosol_optics.meta @@ -175,16 +175,16 @@ kind = kind_phys intent = in [iaermdl] - standard_name = flag_for_aerosol_radiation_scheme - long_name = flag for aerosol scheme to use in radiation - units = flag + standard_name = control_for_aerosol_radiation_scheme + long_name = control of aerosol scheme in radiation + units = 1 dimensions = () type = integer intent = in [iaerflg] - standard_name = flag_for_aerosol_effects_in_radiation - long_name = flag for aerosol effects to include in radiation - units = flag + standard_name = control_for_aerosol_effects_in_radiation + long_name = control of aerosol effects in radiation + units = 1 dimensions = () type = integer intent = in From a4aac0362433d0912ad497bf2e5375b150e5fd49 Mon Sep 17 00:00:00 2001 From: Helin Wei Date: Thu, 10 Nov 2022 19:24:07 -0500 Subject: [PATCH 061/380] adding soil color data --- physics/GFS_debug.F90 | 10 +- physics/GFS_debug.meta | 7 + physics/GFS_phys_time_vary.fv3.F90 | 12 +- physics/GFS_phys_time_vary.fv3.meta | 7 + physics/GFS_surface_generic_post.F90 | 14 +- physics/GFS_surface_generic_post.meta | 28 +++ physics/GFS_surface_generic_pre.F90 | 31 ++- physics/GFS_surface_generic_pre.meta | 30 ++- physics/gcycle.F90 | 8 +- physics/noahmp_tables.f90 | 23 +- physics/noahmpdrv.F90 | 6 +- physics/noahmpdrv.meta | 7 + physics/sfcsub.F | 328 ++++++++++++++++++++------ 13 files changed, 401 insertions(+), 110 deletions(-) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 5e6419256..279b6df22 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -488,6 +488,10 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%vtype_save', Sfcprop%vtype_save) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%stype' , Sfcprop%stype) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%stype_save', Sfcprop%stype_save) + + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%scolor' , Sfcprop%scolor) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%scolore_save', Sfcprop%scolor_save) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%uustar' , Sfcprop%uustar) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%oro' , Sfcprop%oro) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%oro_uf' , Sfcprop%oro_uf) @@ -1524,7 +1528,7 @@ module GFS_checkland !! \htmlinclude GFS_checkland_run.html !! subroutine GFS_checkland_run (me, master, blkno, im, kdt, iter, flag_iter, flag_guess, & - flag_init, flag_restart, frac_grid, isot, ivegsrc, stype, vtype, slope, & + flag_init, flag_restart, frac_grid, isot, ivegsrc, stype,scolor, vtype, slope, & dry, icy, wet, lake, ocean, oceanfrac, landfrac, lakefrac, slmsk, islmsk, & zorl, zorlw, zorll, zorli, fice, errmsg, errflg ) @@ -1547,6 +1551,8 @@ subroutine GFS_checkland_run (me, master, blkno, im, kdt, iter, flag_iter, flag_ integer, intent(in ) :: isot integer, intent(in ) :: ivegsrc integer, intent(in ) :: stype(:) + integer, intent(in ) :: scolor(:) + integer, intent(in ) :: vtype(:) integer, intent(in ) :: slope(:) logical, intent(in ) :: dry(:) @@ -1591,6 +1597,8 @@ subroutine GFS_checkland_run (me, master, blkno, im, kdt, iter, flag_iter, flag_ write(0,'(a,2i5,1x,1x,l)') 'YYY: i, blk, flag_iter(i) :', i, blkno, flag_iter(i) write(0,'(a,2i5,1x,1x,l)') 'YYY: i, blk, flag_guess(i) :', i, blkno, flag_guess(i) write(0,'(a,2i5,1x,e16.7)')'YYY: i, blk, stype(i) :', i, blkno, stype(i) + + write(0,'(a,2i5,1x,e16.7)')'YYY: i, blk, scolor(i) :', i, blkno, scolor(i) write(0,'(a,2i5,1x,e16.7)')'YYY: i, blk, vtype(i) :', i, blkno, vtype(i) write(0,'(a,2i5,1x,e16.7)')'YYY: i, blk, slope(i) :', i, blkno, slope(i) write(0,'(a,2i5,1x,1x,l)') 'YYY: i, blk, dry(i) :', i, blkno, dry(i) diff --git a/physics/GFS_debug.meta b/physics/GFS_debug.meta index 23175ce0f..1ad24e1d6 100644 --- a/physics/GFS_debug.meta +++ b/physics/GFS_debug.meta @@ -543,6 +543,13 @@ dimensions = (horizontal_loop_extent) type = integer intent = in +[scolor] + standard_name = soil_color_classification + long_name = soil color for lsm + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in [vtype] standard_name = vegetation_type_classification long_name = vegetation type for lsm diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index 796856ad3..1e40df0ca 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -160,6 +160,7 @@ subroutine GFS_phys_time_vary_init ( real(kind_phys), intent(inout) :: tsnoxy (:,lsnow_lsm_lbound:) real(kind_phys), intent(inout) :: smoiseq(:,:) real(kind_phys), intent(inout) :: zsnsoxy(:,lsnow_lsm_lbound:) + real(kind_phys), intent(inout) :: slc(:,:) real(kind_phys), intent(inout) :: smc(:,:) real(kind_phys), intent(inout) :: stc(:,:) @@ -168,6 +169,7 @@ subroutine GFS_phys_time_vary_init ( real(kind_phys), intent(in) :: canopy(:) real(kind_phys), intent(in) :: tg3(:) integer, intent(in) :: stype(:) + real(kind_phys), intent(in) :: con_t0c integer, intent(in) :: nthrds @@ -465,8 +467,8 @@ subroutine GFS_phys_time_vary_init ( !$OMP shared(isbarren_table,isice_table,isurban_table) & !$omp shared(iswater_table,laim_table,sla_table,bexp_table) & !$omp shared(stc,smc,slc,tg3,snowxy,tsnoxy,snicexy,snliqxy) & -!$omp shared(zsnsoxy,STYPE,SMCMAX_TABLE,SMCWLT_TABLE,zs,dzs) & -!$omp shared(DWSAT_TABLE,DKSAT_TABLE,PSISAT_TABLE,smoiseq) & +!$omp shared(zsnsoxy,stype,smcmax_table,smcwlt_table,zs,dzs) & +!$omp shared(dwsat_table,dksat_table,psisat_table,smoiseq) & !$OMP shared(smcwtdxy,deeprechxy,rechxy,errmsg,errflg) & !$OMP private(vegtyp,masslai,masssai,snd,dzsno,dzsnso,isnow) & !$OMP private(soiltyp,bexp,smcmax,smcwlt,dwsat,dksat,psisat,ddz) @@ -717,7 +719,7 @@ subroutine GFS_phys_time_vary_timestep_init ( kice, ialb, isot, ivegsrc, input_nml_file, use_ufo, nst_anl, frac_grid, fhcyc, phour, & lakefrac, min_seaice, min_lakeice, smc, slc, stc, smois, sh2o, tslb, tiice, tg3, tref, & tsfc, tsfco, tisfc, hice, fice, facsf, facwf, alvsf, alvwf, alnsf, alnwf, zorli, zorll, & - zorlo, weasd, slope, snoalb, canopy, vfrac, vtype, stype, shdmin, shdmax, snowd, & + zorlo, weasd, slope, snoalb, canopy, vfrac, vtype, stype,scolor, shdmin, shdmax, snowd, & !soil color cv, cvb, cvt, oro, oro_uf, xlat_d, xlon_d, slmsk, landfrac, & do_ugwp_v1, jindx1_tau, jindx2_tau, ddy_j1tau, ddy_j2tau, tau_amf, errmsg, errflg) @@ -763,7 +765,7 @@ subroutine GFS_phys_time_vary_timestep_init ( zorli(:), zorll(:), zorlo(:), weasd(:), snoalb(:), & canopy(:), vfrac(:), shdmin(:), shdmax(:), & snowd(:), cv(:), cvb(:), cvt(:), oro(:), oro_uf(:), slmsk(:) - integer, intent(inout) :: vtype(:), stype(:), slope(:) + integer, intent(inout) :: vtype(:), stype(:),scolor(:), slope(:) !soil color character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -899,7 +901,7 @@ subroutine GFS_phys_time_vary_timestep_init ( frac_grid, smc, slc, stc, smois, sh2o, tslb, tiice, tg3, tref, tsfc, & tsfco, tisfc, hice, fice, facsf, facwf, alvsf, alvwf, alnsf, alnwf, & zorli, zorll, zorlo, weasd, slope, snoalb, canopy, vfrac, vtype, & - stype, shdmin, shdmax, snowd, cv, cvb, cvt, oro, oro_uf, & + stype,scolor, shdmin, shdmax, snowd, cv, cvb, cvt, oro, oro_uf, & !soil color xlat_d, xlon_d, slmsk, imap, jmap) endif endif diff --git a/physics/GFS_phys_time_vary.fv3.meta b/physics/GFS_phys_time_vary.fv3.meta index f37235975..202ef9853 100644 --- a/physics/GFS_phys_time_vary.fv3.meta +++ b/physics/GFS_phys_time_vary.fv3.meta @@ -1712,6 +1712,13 @@ dimensions = (horizontal_dimension) type = integer intent = inout +[scolor] + standard_name = soil_color_classification + long_name = soil color for lsm + units = index + dimensions = (horizontal_dimension) + type = integer + intent = in [shdmin] standard_name = min_vegetation_area_fraction long_name = min fractional coverage of green vegetation diff --git a/physics/GFS_surface_generic_post.F90 b/physics/GFS_surface_generic_post.F90 index 76d3f570c..9faebc8cf 100644 --- a/physics/GFS_surface_generic_post.F90 +++ b/physics/GFS_surface_generic_post.F90 @@ -21,10 +21,10 @@ module GFS_surface_generic_post !> \section arg_table_GFS_surface_generic_post_init Argument Table !! \htmlinclude GFS_surface_generic_post_init.html !! - subroutine GFS_surface_generic_post_init (vtype, stype, slope, vtype_save, stype_save, slope_save, errmsg, errflg) + subroutine GFS_surface_generic_post_init (vtype, stype,scolor, slope, vtype_save, stype_save,scolor_save, slope_save, errmsg, errflg) - integer, dimension(:), intent(in) :: vtype_save, stype_save, slope_save - integer, dimension(:), intent(out) :: vtype, stype, slope + integer, dimension(:), intent(in) :: vtype_save, stype_save,scolor_save, slope_save + integer, dimension(:), intent(out) :: vtype, stype, scolor,slope ! CCPP error handling character(len=*), intent(out) :: errmsg @@ -37,6 +37,7 @@ subroutine GFS_surface_generic_post_init (vtype, stype, slope, vtype_save, stype ! Restore vegetation, soil and slope type vtype(:) = vtype_save(:) stype(:) = stype_save(:) + scolor(:) = scolor_save(:) slope(:) = slope_save(:) end subroutine GFS_surface_generic_post_init @@ -53,7 +54,7 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplaqm, cplchm, cplwav, cpl v10mi_cpl, tsfci_cpl, psurfi_cpl, nnirbmi_cpl, nnirdfi_cpl, nvisbmi_cpl, nvisdfi_cpl, nswsfci_cpl, nswsfc_cpl, nnirbm_cpl, & nnirdf_cpl, nvisbm_cpl, nvisdf_cpl, gflux, evbsa, evcwa, transa, sbsnoa, snowca, snohfa, paha, ep, ecan, etran, edir, waxy, & runoff, srunoff, runof, drain, tecan, tetran, tedir, twa, lheatstrg, h0facu, h0facs, zvfun, hflx, evap, hflxq, hffac, & - isot, ivegsrc, islmsk, vtype, stype, slope, vtype_save, stype_save, slope_save, errmsg, errflg) + isot, ivegsrc, islmsk, vtype, stype,scolor, slope, vtype_save, stype_save,scolor_save, slope_save, errmsg, errflg) implicit none @@ -85,8 +86,8 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplaqm, cplchm, cplwav, cpl real(kind=kind_phys), dimension(:), intent(out) :: hflxq real(kind=kind_phys), dimension(:), intent(out) :: hffac - integer, intent(in) :: isot, ivegsrc, islmsk(:), vtype_save(:), stype_save(:), slope_save(:) - integer, intent(out) :: vtype(:), stype(:), slope(:) + integer, intent(in) :: isot, ivegsrc, islmsk(:), vtype_save(:), stype_save(:),scolor_save(:), slope_save(:) + integer, intent(out) :: vtype(:), stype(:),scolor(:), slope(:) ! CCPP error handling variables character(len=*), intent(out) :: errmsg @@ -274,6 +275,7 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplaqm, cplchm, cplwav, cpl ! Restore vegetation, soil and slope type vtype(:) = vtype_save(:) stype(:) = stype_save(:) + scolor(:) = scolor_save(:) slope(:) = slope_save(:) end subroutine GFS_surface_generic_post_run diff --git a/physics/GFS_surface_generic_post.meta b/physics/GFS_surface_generic_post.meta index aeb5c9754..9658be7d8 100644 --- a/physics/GFS_surface_generic_post.meta +++ b/physics/GFS_surface_generic_post.meta @@ -22,6 +22,13 @@ dimensions = (horizontal_dimension) type = integer intent = out +[scolor] + standard_name = soil_color_classification + long_name = soil color for lsm + units = index + dimensions = (horizontal_dimension) + type = integer + intent = out [slope] standard_name = surface_slope_classification long_name = sfc slope type for lsm @@ -43,6 +50,13 @@ dimensions = (horizontal_dimension) type = integer intent = in +[scolor_save] + standard_name = soil_color_classification_save + long_name = soil color for lsm save + units = index + dimensions = (horizontal_dimension) + type = integer + intent = in [slope_save] standard_name = surface_slope_classification_save long_name = sfc slope type for lsm save @@ -988,6 +1002,13 @@ dimensions = (horizontal_loop_extent) type = integer intent = out +[scolor] + standard_name = soil_color_classification + long_name = soil color for lsm + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = out [slope] standard_name = surface_slope_classification long_name = sfc slope type for lsm @@ -1009,6 +1030,13 @@ dimensions = (horizontal_loop_extent) type = integer intent = in +[scolor_save] + standard_name = soil_color_classification_save + long_name = soil color for lsm save + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in [slope_save] standard_name = surface_slope_classification_save long_name = sfc slope type for lsm save diff --git a/physics/GFS_surface_generic_pre.F90 b/physics/GFS_surface_generic_pre.F90 index 6ecb2f713..5d321814c 100644 --- a/physics/GFS_surface_generic_pre.F90 +++ b/physics/GFS_surface_generic_pre.F90 @@ -21,16 +21,16 @@ module GFS_surface_generic_pre !> \section arg_table_GFS_surface_generic_pre_init Argument Table !! \htmlinclude GFS_surface_generic_pre_init.html !! - subroutine GFS_surface_generic_pre_init (nthreads, im, slmsk, isot, ivegsrc, stype, vtype, slope, & - vtype_save, stype_save, slope_save, errmsg, errflg) + subroutine GFS_surface_generic_pre_init (nthreads, im, slmsk, isot, ivegsrc, stype,scolor, vtype, slope, & + vtype_save, stype_save,scolor_save, slope_save, errmsg, errflg) implicit none ! Interface variables integer, intent(in) :: nthreads, im, isot, ivegsrc real(kind_phys), dimension(:), intent(in) :: slmsk - integer, dimension(:), intent(inout) :: vtype, stype, slope - integer, dimension(:), intent(out) :: vtype_save, stype_save, slope_save + integer, dimension(:), intent(inout) :: vtype, stype, scolor,slope + integer, dimension(:), intent(out) :: vtype_save, stype_save,scolor_save, slope_save ! CCPP error handling character(len=*), intent(out) :: errmsg @@ -49,22 +49,23 @@ subroutine GFS_surface_generic_pre_init (nthreads, im, slmsk, isot, ivegsrc, sty ! Save current values of vegetation, soil and slope type vtype_save(:) = vtype(:) stype_save(:) = stype(:) + scolor_save(:) = scolor(:) slope_save(:) = slope(:) - call update_vegetation_soil_slope_type(nthreads, im, isot, ivegsrc, islmsk, vtype, stype, slope) + call update_vegetation_soil_slope_type(nthreads, im, isot, ivegsrc, islmsk, vtype, stype,scolor, slope) end subroutine GFS_surface_generic_pre_init !> \section arg_table_GFS_surface_generic_pre_run Argument Table !! \htmlinclude GFS_surface_generic_pre_run.html !! - subroutine GFS_surface_generic_pre_run (nthreads, im, levs, vfrac, islmsk, isot, ivegsrc, stype, vtype, slope, & + subroutine GFS_surface_generic_pre_run (nthreads, im, levs, vfrac, islmsk, isot, ivegsrc, stype, scolor,vtype, slope, & prsik_1, prslk_1, tsfc, phil, con_g, sigmaf, work3, zlvl, & drain_cpl, dsnow_cpl, rain_cpl, snow_cpl, lndp_type, n_var_lndp, sfc_wts, & lndp_var_list, lndp_prt_list, & z01d, zt1d, bexp1d, xlai1d, vegf1d, lndp_vgf, & cplflx, flag_cice, islmsk_cice, slimskin_cpl, & - wind, u1, v1, cnvwind, smcwlt2, smcref2, vtype_save, stype_save, slope_save, & + wind, u1, v1, cnvwind, smcwlt2, smcref2, vtype_save, stype_save,scolor_save, slope_save, & errmsg, errflg) use surface_perturbation, only: cdfnor @@ -77,8 +78,8 @@ subroutine GFS_surface_generic_pre_run (nthreads, im, levs, vfrac, islmsk, isot, real(kind=kind_phys), intent(in) :: con_g real(kind=kind_phys), dimension(:), intent(in) :: vfrac, prsik_1, prslk_1 - integer, dimension(:), intent(inout) :: vtype, stype, slope - integer, dimension(:), intent(out) :: vtype_save(:), stype_save(:), slope_save(:) + integer, dimension(:), intent(inout) :: vtype, stype,scolor, slope + integer, dimension(:), intent(out) :: vtype_save(:), stype_save(:),scolor_save(:), slope_save(:) real(kind=kind_phys), dimension(:), intent(inout) :: tsfc real(kind=kind_phys), dimension(:,:), intent(in) :: phil @@ -159,9 +160,10 @@ subroutine GFS_surface_generic_pre_run (nthreads, im, levs, vfrac, islmsk, isot, ! Save current values of vegetation, soil and slope type vtype_save(:) = vtype(:) stype_save(:) = stype(:) + scolor_save(:) = scolor(:) slope_save(:) = slope(:) - call update_vegetation_soil_slope_type(nthreads, im, isot, ivegsrc, islmsk, vtype, stype, slope) + call update_vegetation_soil_slope_type(nthreads, im, isot, ivegsrc, islmsk, vtype, stype,scolor, slope) do i=1,im sigmaf(i) = max(vfrac(i), 0.01_kind_phys) @@ -191,16 +193,19 @@ subroutine GFS_surface_generic_pre_run (nthreads, im, levs, vfrac, islmsk, isot, end subroutine GFS_surface_generic_pre_run - subroutine update_vegetation_soil_slope_type(nthreads, im, isot, ivegsrc, islmsk, vtype, stype, slope) + subroutine update_vegetation_soil_slope_type(nthreads, im, isot, ivegsrc, islmsk, vtype, stype,scolor, slope) implicit none integer, intent(in) :: nthreads, im, isot, ivegsrc, islmsk(:) - integer, intent(inout) :: vtype(:), stype(:), slope(:) + integer, intent(inout) :: vtype(:), stype(:),scolor(:), slope(:) integer :: i !$OMP parallel do num_threads(nthreads) default(none) private(i) & -!$OMP shared(im, isot, ivegsrc, islmsk, vtype, stype, slope) +!$OMP shared(im, isot, ivegsrc, islmsk, vtype, stype,scolor, slope) + +! scolor is a place holder now, how to update soil color based on the mask/veg/sot src + do i=1,im if (islmsk(i) == 2) then if (isot == 1) then diff --git a/physics/GFS_surface_generic_pre.meta b/physics/GFS_surface_generic_pre.meta index f5b7f7f27..d78988787 100644 --- a/physics/GFS_surface_generic_pre.meta +++ b/physics/GFS_surface_generic_pre.meta @@ -50,6 +50,13 @@ dimensions = (horizontal_dimension) type = integer intent = inout +[scolor] + standard_name = soil_color_classification + long_name = soil color for lsm + units = index + dimensions = (horizontal_dimension) + type = integer + intent = inout [vtype] standard_name = vegetation_type_classification long_name = vegetation type for lsm @@ -71,6 +78,13 @@ dimensions = (horizontal_dimension) type = integer intent = out +[scolor_save] + standard_name = soil_color_classification_save + long_name = soil color for lsm save + units = index + dimensions = (horizontal_dimension) + type = integer + intent = out [vtype_save] standard_name = vegetation_type_classification_save long_name = vegetation type for lsm save @@ -162,6 +176,13 @@ dimensions = (horizontal_loop_extent) type = integer intent = inout +[scolor] + standard_name = soil_color_classification + long_name = soil color for lsm + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = inout [vtype] standard_name = vegetation_type_classification long_name = vegetation type for lsm @@ -190,6 +211,13 @@ dimensions = (horizontal_loop_extent) type = integer intent = out +[scolor_save] + standard_name = soil_color_classification_save + long_name = soil color for lsm save + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = out [slope_save] standard_name = surface_slope_classification_save long_name = sfc slope type for lsm save @@ -470,4 +498,4 @@ units = 1 dimensions = () type = integer - intent = out \ No newline at end of file + intent = out diff --git a/physics/gcycle.F90 b/physics/gcycle.F90 index 5f4f959c6..aea978a41 100644 --- a/physics/gcycle.F90 +++ b/physics/gcycle.F90 @@ -21,7 +21,7 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, frac_grid, smc, slc, stc, smois, sh2o, tslb, tiice, tg3, tref, tsfc, & tsfco, tisfc, hice, fice, facsf, facwf, alvsf, alvwf, alnsf, alnwf, & zorli, zorll, zorlo, weasd, slope, snoalb, canopy, vfrac, vtype, & - stype, shdmin, shdmax, snowd, cv, cvb, cvt, oro, oro_uf, & + stype,scolor, shdmin, shdmax, snowd, cv, cvb, cvt, oro, oro_uf, & !scolor: soil color xlat_d, xlon_d, slmsk, imap, jmap) ! ! @@ -74,6 +74,7 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, slmsk(:) integer, intent(inout) :: vtype(:), & stype(:), & + scolor(:), & !soil color slope(:) integer, intent(in) :: imap(:), jmap(:) @@ -87,6 +88,7 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, slpfcs (nx*ny), & vegfcs (nx*ny), & sltfcs (nx*ny), & + slcfcs (nx*ny), & !soil color TSFFCS (nx*ny), & ZORFCS (nx*ny), & AISFCS (nx*ny), & @@ -128,6 +130,7 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, slpfcs = real(slope) vegfcs = real(vtype) sltfcs = real(stype) + slcfcs = real(scolor) !soil color ! if (frac_grid) then do ix=1,npts @@ -227,7 +230,7 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, shdmin, shdmax, slpfcs, snoalb, tsffcs, & weasd, zorfcs, albfc1, tg3, canopy, & smcfc1, stcfc1, slmsk, aisfcs, & - vfrac, vegfcs, sltfcs, alffc1, cv, & + vfrac, vegfcs, sltfcs, slcfcs,alffc1, cv, & !slcfcs: soil color cvb, cvt, me, nthrds, & nlunit, size(input_nml_file), input_nml_file, & min_ice, ialb, isot, ivegsrc, & @@ -247,6 +250,7 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, slope = int(slpfcs) vtype = int(vegfcs) stype = int(sltfcs) + scolor = int(slcfcs) !soil color ! do ix=1,npts zorll(ix) = ZORFCS(ix) diff --git a/physics/noahmp_tables.f90 b/physics/noahmp_tables.f90 index 2e3e2920e..0e9f64af1 100644 --- a/physics/noahmp_tables.f90 +++ b/physics/noahmp_tables.f90 @@ -13,7 +13,8 @@ module noahmp_tables integer, private, parameter :: mvt = 30 ! use 30 instead of 27 integer, private, parameter :: mband = 2 - integer, private, parameter :: msc = 8 +! integer, private, parameter :: msc = 8 + integer, private, parameter :: msc = 20 integer, private, parameter :: max_soiltyp = 30 integer, private, parameter :: ncrop = 5 integer, private, parameter :: nstage = 8 @@ -741,12 +742,24 @@ module noahmp_tables ! &_______________________________________________________________________& real :: albsat_table(msc,mband) !< saturated soil albedos: 1=vis, 2=nir - data(albsat_table(i,1),i=1,8)/0.15,0.11,0.10,0.09,0.08,0.07,0.06,0.05/ - data(albsat_table(i,2),i=1,8)/0.30,0.22,0.20,0.18,0.16,0.14,0.12,0.10/ +! data(albsat_table(i,1),i=1,8)/0.15,0.11,0.10,0.09,0.08,0.07,0.06,0.05/ +! data(albsat_table(i,2),i=1,8)/0.30,0.22,0.20,0.18,0.16,0.14,0.12,0.10/ + + data(albsat_table(i,1),i=1,20) /0.25,0.23,0.21,0.20,0.19,0.18,0.17,0.16,& + & 0.15,0.14,0.13,0.12,0.11,0.10,0.09,0.08,0.07,0.06,0.05,0.04 / + + data(albsat_table(i,2),i=1,20) /0.50,0.46,0.42,0.40,0.38,0.36,0.34,0.32,& + & 0.30,0.28,0.26,0.24,0.22,0.20,0.18,0.16,0.14,0.12,0.10,0.08 / real :: albdry_table(msc,mband) !< dry soil albedos: 1=vis, 2=nir - data(albdry_table(i,1),i=1,8)/0.27,0.22,0.20,0.18,0.16,0.14,0.12,0.10/ - data(albdry_table(i,2),i=1,8)/0.54,0.44,0.40,0.36,0.32,0.28,0.24,0.20/ +! data(albdry_table(i,1),i=1,8)/0.27,0.22,0.20,0.18,0.16,0.14,0.12,0.10/ +! data(albdry_table(i,2),i=1,8)/0.54,0.44,0.40,0.36,0.32,0.28,0.24,0.20/ + + data(albdry_table(i,1),i=1,20) /0.36,0.34,0.32,0.31,0.30,0.29,0.28,0.27,& + & 0.26,0.25,0.24,0.23,0.22,0.20,0.18,0.16,0.14,0.12,0.10,0.08/ + + data(albdry_table(i,2),i=1,20) /0.61,0.57,0.53,0.51,0.49,0.48,0.45,0.43,& + & 0.41,0.39,0.37,0.35,0.33,0.31,0.29,0.27,0.25,0.23,0.21,0.16/ real :: albice_table(mband) !< albedo land ice: 1=vis, 2=nir data (albice_table(i),i=1,mband) /0.80, 0.55/ diff --git a/physics/noahmpdrv.F90 b/physics/noahmpdrv.F90 index fed823ead..dfdbd1bc6 100644 --- a/physics/noahmpdrv.F90 +++ b/physics/noahmpdrv.F90 @@ -131,7 +131,7 @@ end subroutine noahmpdrv_init subroutine noahmpdrv_run & !................................... ! --- inputs: - ( im, km, lsnowl, itime, ps, u1, v1, t1, q1, soiltyp, & + ( im, km, lsnowl, itime, ps, u1, v1, t1, q1, soiltyp,soilcol,& vegtype, sigmaf, dlwflx, dswsfc, snet, delt, tg3, cm, ch, & prsl1, prslk1, prslki, prsik1, zf,pblh, dry, wind, slopetyp, & shdmin, shdmax, snoalb, sfalb, flag_iter,con_g, & @@ -206,6 +206,7 @@ subroutine noahmpdrv_run & real(kind=kind_phys), dimension(:) , intent(in) :: t1 ! layer 1 temperature [K] real(kind=kind_phys), dimension(:) , intent(in) :: q1 ! layer 1 specific humidity [kg/kg] integer , dimension(:) , intent(in) :: soiltyp ! soil type (integer index) + integer , dimension(:) , intent(in) :: soilcol ! soil color (integer index) integer , dimension(:) , intent(in) :: vegtype ! vegetation type (integer index) real(kind=kind_phys), dimension(:) , intent(in) :: sigmaf ! areal fractional cover of green vegetation real(kind=kind_phys), dimension(:) , intent(in) :: dlwflx ! downward longwave radiation [W/m2] @@ -753,7 +754,8 @@ subroutine noahmpdrv_run & soil_category = soiltyp(i) slope_category = slopetyp(i) - soil_color_category = 4 + soil_color_category = soilcol(i) +! soil_color_category = 4 call transfer_mp_parameters(vegetation_category, soil_category, & slope_category, soil_color_category, crop_type,parameters) diff --git a/physics/noahmpdrv.meta b/physics/noahmpdrv.meta index 3235b7c90..208788889 100644 --- a/physics/noahmpdrv.meta +++ b/physics/noahmpdrv.meta @@ -174,6 +174,13 @@ dimensions = (horizontal_loop_extent) type = integer intent= in +[soilcol] + standard_name = soil_color_classification + long_name = soil color at each grid cell + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent= in [vegtype] standard_name = vegetation_type_classification long_name = vegetation type at each grid cell diff --git a/physics/sfcsub.F b/physics/sfcsub.F index dae710760..4a247a1a7 100644 --- a/physics/sfcsub.F +++ b/physics/sfcsub.F @@ -16,8 +16,8 @@ module sfccyc_module ! integer kpdtsf,kpdwet,kpdsno,kpdzor,kpdais,kpdtg3,kpdplr,kpdgla, & kpdmxi,kpdscv,kpdsmc,kpdoro,kpdmsk,kpdstc,kpdacn,kpdveg, - & kpdvet,kpdsot - &, kpdvmn,kpdvmx,kpdslp,kpdabs + & kpdvet,kpdsot,kpdsoc, + & kpdvmn,kpdvmx,kpdslp,kpdabs &, kpdsnd, kpdabs_0, kpdabs_1, kpdalb(4) parameter(kpdtsf=11, kpdwet=86, kpdsno=65, kpdzor=83, ! & kpdalb=84, kpdais=91, kpdtg3=11, kpdplr=224, @@ -26,7 +26,7 @@ module sfccyc_module & kpdoro=8, kpdmsk=81, kpdstc=11, kpdacn=91, kpdveg=87, !cbosu max snow albedo uses a grib id number of 159, not 255. & kpdvmn=255, kpdvmx=255,kpdslp=236, kpdabs_0=255, - & kpdvet=225, kpdsot=224,kpdabs_1=159, + & kpdvet=225, kpdsot=224,kpdsoc=255,kpdabs_1=159, & kpdsnd=66 ) ! integer, parameter :: kpdalb_0(4)=(/212,215,213,216/) @@ -37,6 +37,7 @@ module sfccyc_module integer, parameter :: xdata=7200, ydata=3600, mdata=xdata*ydata integer :: veg_type_landice integer :: soil_type_landice + integer :: soil_color_landice integer :: num_threads ! ! @@ -81,7 +82,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & &, vmnfcs,vmxfcs,slpfcs,absfcs & &, tsffcs,snofcs,zorfcs,albfcs,tg3fcs & &, cnpfcs,smcfcs,stcfcs,slifcs,aisfcs & - &, vegfcs,vetfcs,sotfcs,alffcs & + &, vegfcs,vetfcs,sotfcs,socfcs,alffcs & &, cvfcs,cvbfcs,cvtfcs,me,nthrds,nlunit & &, sz_nml,input_nml_file & &, min_ice & @@ -125,15 +126,17 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & vetsmn,vetimx,vetimn,vetjmx,vetjmn, & & sotlmx,sotlmn,sotomx,sotomn,sotsmx, & & sotsmn,sotimx,sotimn,sotjmx,sotjmn, & + & soclmx,soclmn,socomx,socomn,socsmx, & + & socsmn,socimx,socimn,socjmx,socjmn, & & alslmx,alslmn,alsomx,alsomn,alssmx, & & alssmn,alsimx,alsimn,alsjmx,alsjmn, & & epstsf,epsalb,epssno,epswet,epszor, & & epsplr,epsoro,epssmc,epsscv,eptsfc, & & epstg3,epsais,epsacn,epsveg,epsvet, & - & epssot,epsalf,qctsfs,qcsnos,qctsfi, & + & epssot,epssoc,epsalf,qctsfs,qcsnos,qctsfi, & & aislim,snwmin,snwmax,cplrl,cplrs, & & cvegl,czors,csnol,csnos,czorl,csots, & - & csotl,cvwgs,cvetl,cvets,calfs, & + & csotl,csocs,csocl,cvwgs,cvetl,cvets,calfs, & & fcalfl,fcalfs,ccvt,ccnp,ccv,ccvb, & & calbl,calfl,calbs,ctsfs,grboro, & & grbmsk,ctsfl,deltf,caisl,caiss, & @@ -142,6 +145,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & faiss,fsnol,bltmsk,falbs,cvegs,percrit, & & deltsfc,critp2,critp3,blnmsk,critp1, & & fcplrl,fcplrs,fczors,fvets,fsotl,fsots, & + & fsocl,fsocs, & & fvetl,fplrs,fvegl,fvegs,fcsnol,fcsnos, & & fczorl,fcalbs,fctsfl,fctsfs,fcalbl, & & falfs,falfl,fh,crit,zsca,ztsfc,tem1,tem2 & @@ -167,7 +171,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & &, sihnew integer imsk,jmsk,ifp,irtscv,irtacn,irtais,irtsno,irtzor, & - & irtalb,irtsot,irtalf,j,irtvet,irtsmc,irtstc,irtveg, & + & irtalb,irtsot,irtsoc,irtalf,j,irtvet,irtsmc,irtstc,irtveg,& & irtwet,k,iprnt,kk,irttsf,iret,i,igrdbg,iy,im,id, & & icalbl,icalbs,icalfl,ictsfs,lugb,len,lsoil,ih, & & ictsfl,iczors,icplrl,icplrs,iczorl,icalfs,icsnol, & @@ -238,6 +242,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! sli .. land/sea/sea-ice mask. (1/0/2 respectively) ! veg .. vegetation cover ! sot .. soil type +! soc .. soil color !cwu [+2l] add sih & sic ! sih .. sea ice thickness ! sic .. sea ice concentration @@ -364,6 +369,10 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & parameter(sotlmx=16.,sotlmn=1.0,sotomx=0.0,sotomn=0.0, & sotsmx=16.,sotsmn=1.0,sotimx=0.,sotimn=0., & sotjmx=0.,sotjmn=0.) +! soil color + parameter(soclmx=20.,soclmn=1.0,socomx=0.0,socomn=0.0, + & socsmx=20.,socsmn=1.0,socimx=0.,socimn=0., + & socjmx=0.,socjmn=0.) ! fraction of vegetation for strongly and weakly zeneith angle dependent ! albedo parameter(alslmx=1.0,alslmn=0.0,alsomx=0.0,alsomn=0.0, @@ -378,7 +387,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & epsais=0.,epsacn=0.01,epsveg=0.01, & epssih=0.001,epssic=0.001, & epsvmn=0.01,epsvmx=0.01,epsabs=0.001,epsslp=0.01, - & epsvet=.01,epssot=.01,epsalf=.001) + & epsvet=.01,epssot=.01,epssoc=0.01,epsalf=.001) ! ! quality control of analysis snow and sea ice ! @@ -427,6 +436,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! vegetation cover analysis analysis ! vegetation type analysis analysis ! soil type analysis analysis +! soil color analysis analysis ! sea-ice thickness forecast forecast ! sea-ice concentration analysis analysis ! vegetation cover min analysis analysis @@ -467,14 +477,14 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! character*500 fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc & &, fnplrc,fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc & - &, fnvegc,fnvetc,fnsotc & + &, fnvegc,fnvetc,fnsotc,fnsocc & &, fnvmnc,fnvmxc,fnslpc,fnabsc, fnalbc2 real (kind=kind_io8) tsfclm(len), wetclm(len), snoclm(len) & &, zorclm(len), albclm(len,4), aisclm(len) & &, tg3clm(len), acnclm(len), cnpclm(len) & &, cvclm (len), cvbclm(len), cvtclm(len) & &, scvclm(len), tsfcl2(len), vegclm(len) & - &, vetclm(len), sotclm(len), alfclm(len,2), sliclm(len) & + &, vetclm(len), sotclm(len), socclm(len),alfclm(len,2), sliclm(len)& &, smcclm(len,lsoil), stcclm(len,lsoil) & &, sihclm(len), sicclm(len) & &, vmnclm(len), vmxclm(len), slpclm(len), absclm(len) @@ -483,7 +493,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! character*500 fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa & &, fnplra,fntg3a,fnscva,fnsmca,fnstca,fnacna & - &, fnvega,fnveta,fnsota & + &, fnvega,fnveta,fnsota,fnsoca & &, fnvmna,fnvmxa,fnslpa,fnabsa ! real (kind=kind_io8) tsfanl(len), wetanl(len), snoanl(len) & @@ -491,7 +501,8 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & &, tg3anl(len), acnanl(len), cnpanl(len) & &, cvanl (len), cvbanl(len), cvtanl(len) & &, scvanl(len), tsfan2(len), veganl(len) & - &, vetanl(len), sotanl(len), alfanl(len,2), slianl(len) & + &, vetanl(len), sotanl(len), socanl(len) & + &, alfanl(len,2), slianl(len) & &, smcanl(len,lsoil), stcanl(len,lsoil) & &, sihanl(len), sicanl(len) & &, vmnanl(len), vmxanl(len), slpanl(len), absanl(len) @@ -505,7 +516,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & &, tg3fcs(len), acnfcs(len), cnpfcs(len) & &, cvfcs (len), cvbfcs(len), cvtfcs(len) & &, slifcs(len), vegfcs(len) & - &, vetfcs(len), sotfcs(len), alffcs(len,2) & + &, vetfcs(len), sotfcs(len), socfcs(len), alffcs(len,2) & &, smcfcs(len,lsoil), stcfcs(len,lsoil) & &, sihfcs(len), sicfcs(len), sitfcs(len) & &, vmnfcs(len), vmxfcs(len), slpfcs(len), absfcs(len) & @@ -536,7 +547,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! real (kind=kind_io8), allocatable, dimension(:) :: & & tsffcsd, snofcsd, tg3fcsd, zorfcsd, slifcsd, aisfcsd, & - & cnpfcsd, vegfcsd, vetfcsd, sotfcsd, sihfcsd, sicfcsd, & + & cnpfcsd, vegfcsd, vetfcsd, sotfcsd, socfcsd, sihfcsd, sicfcsd, & & vmnfcsd, vmxfcsd, slpfcsd, absfcsd real (kind=kind_io8), allocatable, dimension(:,:) :: & & smcfcsd, stcfcsd, albfcsd @@ -574,6 +585,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! rec. 16 canopy water content (cnpanl) -----> f10m ! rec. 17 vegetation type ! rec. 18 soil type +! rec. 18 soil color ? add later? ! rec. 19 zeneith angle dependent vegetation fraction (two types) ! rec. 20 uustar ! rec. 21 ffmm @@ -609,11 +621,11 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & namelist/namsfc/fnglac,fnmxic, & fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, & fnplrc,fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc, - & fnvegc,fnvetc,fnsotc,fnalbc2, + & fnvegc,fnvetc,fnsotc,fnsocc,fnalbc2, & fnvmnc,fnvmxc,fnslpc,fnabsc, & fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, & fnplra,fntg3a,fnscva,fnsmca,fnstca,fnacna, - & fnvega,fnveta,fnsota, + & fnvega,fnveta,fnsota,fnsoca, & fnvmna,fnvmxa,fnslpa,fnabsa, & fnmskh, & ldebug,lgchek,lqcbgs,critp1,critp2,critp3, @@ -622,6 +634,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & ftsfl,ftsfs,falbl,falbs,faisl,faiss,fsnol,fsnos, & fzorl,fzors,fplrl,fplrs,fsmcl,fsmcs, & fstcl,fstcs,fvegl,fvegs,fvetl,fvets,fsotl,fsots, + & fsocl,fsocs, & fctsfl,fctsfs,fcalbl,fcalbs,fcsnol,fcsnos, & fczorl,fczors,fcplrl,fcplrs,fcsmcl,fcsmcs, & fcstcl,fcstcs,fsalfl,fsalfs,fcalfl,flalfs, @@ -647,6 +660,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & data fnalbc2/'global_albedo4.1x1.grb'/ data fntsfc/'global_sstclim.2x2.grb'/ data fnsotc/'global_soiltype.1x1.grb'/ + data fnsocc/'C96.soil_color.tileX.nc'/ data fnvegc/'global_vegfrac.1x1.grb'/ data fnvetc/'global_vegtype.1x1.grb'/ data fnglac/'global_glacier.2x2.grb'/ @@ -683,6 +697,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & data fnvega/' '/ data fnveta/' '/ data fnsota/' '/ + data fnsoca/' '/ !clu [+4l] add fn()a for vmn, vmx, abs, slp data fnvmna/' '/ data fnvmxa/' '/ @@ -704,6 +719,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & data fplrl/0.0/, fplrs/0.0/ data fvetl/0.0/, fvets/99999.0/ data fsotl/0.0/, fsots/99999.0/ + data fsocl/0.0/, fsocs/99999.0/ data fvegl/0.0/, fvegs/99999.0/ !cwu [+4l] add f()l and f()s for sih, sic and aislim, sihlim data fsihl/99999.0/, fsihs/99999.0/ @@ -744,6 +760,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & fnplra,fntg3a,fnscva,fnsmca,fnstca,fnacna,fnvega, & fnvetc,fnveta, & fnsotc,fnsota, + & fnsocc,fnsoca, !clu [+2l] add fn()c and fn()a for vmn, vmx, slp, abs & fnvmnc,fnvmxc,fnabsc,fnslpc, & fnvmna,fnvmxa,fnabsa,fnslpa, @@ -753,6 +770,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & ftsfl,ftsfs,falbl,falbs,faisl,faiss,fsnol,fsnos, & fzorl,fzors,fplrl,fplrs,fsmcl,fsmcs,falfl,falfs, & fstcl,fstcs,fvegl,fvegs,fvetl,fvets,fsotl,fsots, + & fsocl,fsocs, & fctsfl,fctsfs,fcalbl,fcalbs,fcsnol,fcsnos, & fczorl,fczors,fcplrl,fcplrs,fcsmcl,fcsmcs, & fcstcl,fcstcs,fcalfl,fcalfs, @@ -771,6 +789,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & ctsfl, ctsfs, calbl, calfl, calbs, calfs, csmcs, & csnol, csnos, czorl, czors, cplrl, cplrs, cstcl, & cstcs, cvegl, cvwgs, cvetl, cvets, csotl, csots, + & csocl, csocs, & csmcl !cwu [+1l] add c()l and c()s for sih, sic &, csihl, csihs, csicl, csics @@ -860,6 +879,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & print *,' fstcs=',fstcs(1:lsoil) print *,' aislim=',aislim,' sihnew=',sihnew print *,' isot=', isot,' ivegsrc=',ivegsrc + print *,' fnsotc =', fnsotc endif if (ivegsrc == 2) then ! sib @@ -872,6 +892,8 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & else soil_type_landice = 16 endif + + soil_color_landice = 10 !does not matter, only one source ! deltf = deltsfc / 24.0 ! @@ -981,6 +1003,15 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & csots = 0. !... soil type over sea if (fsots >= 99999.) csots = 1. if (fsots > 0. .and. fsots < 99999) csots = exp(-deltf/fsots) +! + csocl = 0. !... soil color over land + if (fsocl >= 99999.) csocl = 1. + if (fsocl > 0. .and. fsocl < 99999) csocl = exp(-deltf/fsocl) +! + csocs = 0. !... soil color over sea + if (fsocs >= 99999.) csots = 1. + if (fsocs > 0. .and. fsocs < 99999) csocs = exp(-deltf/fsocs) + !cwu [+16l]--------------------------------------------------------------- ! @@ -1109,16 +1140,16 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & call clima(lugb,iy,im,id,ih,fh,len,lsoil,slmskl,slmskw, & fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, & fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc, - & fnvetc,fnsotc, + & fnvetc,fnsotc,fnsocc, & fnvmnc,fnvmxc,fnslpc,fnabsc, & tsfclm,tsfcl2,wetclm,snoclm,zorclm,albclm,aisclm, & tg3clm,cvclm ,cvbclm,cvtclm, & cnpclm,smcclm,stcclm,sliclm,scvclm,acnclm,vegclm, - & vetclm,sotclm,alfclm, + & vetclm,sotclm,socclm,alfclm, & vmnclm,vmxclm,slpclm,absclm, & kpdtsf,kpdwet,kpdsno,kpdzor,kpdalb,kpdais, & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, - & kpdvet,kpdsot,kpdalf,tsfcl0, + & kpdvet,kpdsot,kpdsoc,kpdalf,tsfcl0, & kpdvmn,kpdvmx,kpdslp,kpdabs, & deltsfc, lanom &, imsk, jmsk, slmskh, rla, rlo, gausm, blnmsk, bltmsk,me @@ -1128,6 +1159,10 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! scale surface roughness and albedo to model required units ! +! do i=1,len +! print *, 'BEFORE QC socclm (i) is ',socclm (i) +! enddo + zsca=100. call scale(zorclm,len,zsca) zsca=0.01 @@ -1150,7 +1185,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! make sure vegetation type and soil type are non zero over land ! - call landtyp(vetclm,sotclm,slpclm,slmskl,len) + call landtyp(vetclm,sotclm,socclm,slpclm,slmskl,len) ! !cwu [-1l/+1l] !* ice concentration or ice mask (only ice mask used in the model now) @@ -1317,6 +1352,20 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & sotlmx,sotlmn,sotomx,sotomn,sotimx,sotimn, & sotjmx,sotjmn,sotsmx,sotsmn,epssot, & rla,rlo,len,kqcm,percrit,lgchek,me) +! soil color + call qcmxmn('socc ',socclm,slmskl,snoclm,icefl1, + & soclmx,soclmn,socomx,socomn,socimx,socimn, + & socjmx,socjmn,socsmx,socsmn,epssoc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + +! do i=1,len +! print *, 'AFTER QC socclm (i) is ',socclm (i) +! enddo + +! write(6,*) 'socclm after QC ' +! znnt=1. +! call nntprt(socclm,len,znnt) + !cwu [+8l] --------------------------------------------------------------- call qcmxmn('sihc ',sihclm,sliclm,snoclm,icefl1, & sihlmx,sihlmn,sihomx,sihomn,sihimx,sihimn, @@ -1382,6 +1431,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & call monitr('vegclm',vegclm,sliclm,snoclm,len) call monitr('vetclm',vetclm,sliclm,snoclm,len) call monitr('sotclm',sotclm,sliclm,snoclm,len) + call monitr('socclm',socclm,sliclm,snoclm,len) !cwu [+2l] add sih, sic call monitr('sihclm',sihclm,sliclm,snoclm,len) call monitr('sicclm',sicclm,sliclm,snoclm,len) @@ -1405,16 +1455,20 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & call filanl(tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl,aisanl, & tg3anl,cvanl ,cvbanl,cvtanl, & cnpanl,smcanl,stcanl,slianl,scvanl,veganl, - & vetanl,sotanl,alfanl, + & vetanl,sotanl,socanl,alfanl, & sihanl,sicanl, & vmnanl,vmxanl,slpanl,absanl, & tsfclm,tsfcl2,wetclm,snoclm,zorclm,albclm,aisclm, & tg3clm,cvclm ,cvbclm,cvtclm, & cnpclm,smcclm,stcclm,sliclm,scvclm,vegclm, - & vetclm,sotclm,alfclm, + & vetclm,sotclm,socclm,alfclm, & sihclm,sicclm, & vmnclm,vmxclm,slpclm,absclm, & len,lsoil) + +! do i=1,len +! print *, 'AFTER FILANL (i) is ',socanl (i) +! enddo ! ! reverse scaling to match with grib analysis input ! @@ -1440,24 +1494,28 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & call analy(lugb,iy,im,id,ih,fh,len,lsoil,slmskl,slmskw, & fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, & fntg3a,fnscva,fnsmca,fnstca,fnacna,fnvega, - & fnveta,fnsota, + & fnveta,fnsota,fnsoca, & fnvmna,fnvmxa,fnslpa,fnabsa, & tsfanl,wetanl,snoanl,zoranl,albanl,aisanl, & tg3anl,cvanl ,cvbanl,cvtanl, & smcanl,stcanl,slianl,scvanl,acnanl,veganl, - & vetanl,sotanl,alfanl,tsfan0, + & vetanl,sotanl,socanl,alfanl,tsfan0, & vmnanl,vmxanl,slpanl,absanl, & kpdtsf,kpdwet,kpdsno,kpdsnd,kpdzor,kpdalb,kpdais, & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, - & kpdvet,kpdsot,kpdalf, + & kpdvet,kpdsot,kpdsoc,kpdalf, & kpdvmn,kpdvmx,kpdslp,kpdabs, & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, - & irtvet,irtsot,irtalf + & irtvet,irtsot,irtsoc,irtalf &, irtvmn,irtvmx,irtslp,irtabs, & imsk, jmsk, slmskh, rla, rlo, gausm, blnmsk, bltmsk &, me, lanom) +! do i=1,len +! print *, 'AFTER ANALY (i) is ',socanl (i) +! enddo + ! if(lprnt) print *,' tsfanl=',tsfanl(iprnt) ! ! scale zor and alb to match forecast model units @@ -1705,6 +1763,15 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & sotlmx,sotlmn,sotomx,sotomn,sotimx,sotimn, & sotjmx,sotjmn,sotsmx,sotsmn,epssot, & rla,rlo,len,kqcm,percrit,lgchek,me) +! soil color + call qcmxmn('soca ',socanl,slmskl,snoanl,icefl1, + & soclmx,soclmn,socomx,socomn,socimx,socimn, + & socjmx,socjmn,socsmx,socsmn,epssoc, + & rla,rlo,len,kqcm,percrit,lgchek,me) +! do i=1,len +! print *, 'AFTER QC (i) is ',socanl (i) +! enddo + !clu [+16l]---------------------------------------------------------------------- ! call qcmxmn('vmna ',vmnanl,slianl,snoanl,icefl1, call qcmxmn('vmna ',vmnanl,slmskl,snoanl,icefl1, @@ -1758,6 +1825,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & call monitr('veganl',veganl,slianl,snoanl,len) call monitr('vetanl',vetanl,slianl,snoanl,len) call monitr('sotanl',sotanl,slianl,snoanl,len) + call monitr('socanl',socanl,slianl,snoanl,len) !cwu [+2l] add sih, sic call monitr('sihanl',sihanl,slianl,snoanl,len) call monitr('sicanl',sicanl,slianl,snoanl,len) @@ -1789,7 +1857,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & call filfcs(tsffcs,wetfcs,snofcs,zorfcs,albfcs, & tg3fcs,cvfcs ,cvbfcs,cvtfcs, & cnpfcs,smcfcs,stcfcs,slifcs,aisfcs, - & vegfcs,vetfcs,sotfcs,alffcs, + & vegfcs,vetfcs,sotfcs,socfcs,alffcs, !cwu [+1l] add ()fcs for sih, sic & sihfcs,sicfcs, !clu [+1l] add ()fcs for vmn, vmx, slp, abs @@ -1797,12 +1865,17 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & tsfanl,wetanl,snoanl,zoranl,albanl, & tg3anl,cvanl ,cvbanl,cvtanl, & cnpanl,smcanl,stcanl,slianl,aisanl, - & veganl,vetanl,sotanl,alfanl, + & veganl,vetanl,sotanl,socanl,alfanl, !cwu [+1l] add ()anl for sih, sic & sihanl,sicanl, !clu [+1l] add ()anl for vmn, vmx, slp, abs & vmnanl,vmxanl,slpanl,absanl, & len,lsoil) + + do i=1,len + print *, 'AFTER FILFCS (i) is ',socfcs (i) + enddo + if (sig1t(1) /= 0.) then call usesgt(sig1t,slianl,tg3anl,len,lsoil,tsffcs,stcfcs, & tsfimx) @@ -1949,6 +2022,15 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & sotlmx,sotlmn,sotomx,sotomn,sotimx,sotimn, & sotjmx,sotjmn,sotsmx,sotsmn,epssot, & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('socf ',socfcs,slmskl,snofcs,icefl1, + & soclmx,soclmn,socomx,socomn,socimx,socimn, + & socjmx,socjmn,socsmx,socsmn,epssoc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + +! do i=1,len +! print *, 'AFTER QC SOCFCS(i) is ',socfcs (i) +! enddo + !clu [+16l] --------------------------------------------------------------- ! call qcmxmn('vmnf ',vmnfcs,slifcs,snofcs,icefl1, @@ -2002,6 +2084,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & call monitr('vegfcs',vegfcs,slifcs,snofcs,len) call monitr('vetfcs',vetfcs,slifcs,snofcs,len) call monitr('sotfcs',sotfcs,slifcs,snofcs,len) + call monitr('socfcs',socfcs,slifcs,snofcs,len) !cwu [+2l] add sih, sic call monitr('sihfcs',sihfcs,slifcs,snofcs,len) call monitr('sicfcs',sicfcs,slifcs,snofcs,len) @@ -2066,23 +2149,23 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & tsffcs,wetfcs,snofcs,zorfcs,albfcs,aisfcs, & cvfcs ,cvbfcs,cvtfcs, & cnpfcs,smcfcs,stcfcs,slifcs,vegfcs, - & vetfcs,sotfcs,alffcs, + & vetfcs,sotfcs,socfcs,alffcs, & sihanl,sicanl, & vmnanl,vmxanl,slpanl,absanl, & tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl,aisanl, & cvanl ,cvbanl,cvtanl, & cnpanl,smcanl,stcanl,slianl,veganl, - & vetanl,sotanl,alfanl, + & vetanl,sotanl,socanl,alfanl, & ctsfl,calbl,caisl,csnol,csmcl,czorl,cstcl,cvegl, & ctsfs,calbs,caiss,csnos,csmcs,czors,cstcs,cvegs, - & ccv,ccvb,ccvt,ccnp,cvetl,cvets,csotl,csots, + & ccv,ccvb,ccvt,ccnp,cvetl,cvets,csotl,csots,csocl,csocs, & calfl,calfs, & csihl,csihs,csicl,csics, & cvmnl,cvmns,cvmxl,cvmxs,cslpl,cslps,cabsl,cabss, & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, & irtvmn,irtvmx,irtslp,irtabs, - & irtvet,irtsot,irtalf,landice,me) + & irtvet,irtsot,irtsoc,irtalf,landice,me) call setzro(snoanl,epssno,len) @@ -2177,6 +2260,17 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & sotlmx,sotlmn,sotomx,sotomn,sotimx,sotimn, & sotjmx,sotjmn,sotsmx,sotsmn,epssot, & rla,rlo,len,kqcm,percrit,lgchek,me) +! do i=1,len +! print *, 'BEFORE FINAL QC SOCANL(i) is ',socanl (i) +! enddo + + call qcmxmn('socm ',socanl,slmskl,snoanl,icefl1, + & soclmx,soclmn,socomx,socomn,socimx,socimn, + & socjmx,socjmn,socsmx,socsmn,epssoc, + & rla,rlo,len,kqcm,percrit,lgchek,me) +! do i=1,len +! print *, 'AFTER FINAL QC SOCANL(i) is ',socanl (i) +! enddo !cwu [+8l] add sih, sic, call qcmxmn('sihm ',sihanl,slianl,snoanl,icefl1, & sihlmx,sihlmn,sihomx,sihomn,sihimx,sihimn, @@ -2269,6 +2363,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & call monitr('veganl',veganl,slianl,snoanl,len) call monitr('vetanl',vetanl,slianl,snoanl,len) call monitr('sotanl',sotanl,slianl,snoanl,len) + call monitr('socanl',socanl,slianl,snoanl,len) !cwu [+2l] add sih, sic, call monitr('sihanl',sihanl,slianl,snoanl,len) call monitr('sicanl',sicanl,slianl,snoanl,len) @@ -2284,7 +2379,8 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & allocate (tsffcsd(len), snofcsd(len), tg3fcsd(len), & & zorfcsd(len), slifcsd(len), aisfcsd(len), & & cnpfcsd(len), vegfcsd(len), vetfcsd(len), & - & sotfcsd(len), sihfcsd(len), sicfcsd(len), & + & sotfcsd(len), socfcsd(len),sihfcsd(len), & + & sicfcsd(len), & & vmnfcsd(len), vmxfcsd(len), slpfcsd(len), & & absfcsd(len)) allocate (smcfcsd(len,lsoil), stcfcsd(len,lsoil), & @@ -2302,6 +2398,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & vegfcsd(i) = veganl(i) - vegfcs(i) vetfcsd(i) = vetanl(i) - vetfcs(i) sotfcsd(i) = sotanl(i) - sotfcs(i) + socfcsd(i) = socanl(i) - socfcs(i) !clu [+2l] add sih, sic sihfcsd(i) = sihanl(i) - sihfcs(i) sicfcsd(i) = sicanl(i) - sicfcs(i) @@ -2355,6 +2452,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & call monitr('vegdif',vegfcsd,slianl,snoanl,len) call monitr('vetdif',vetfcsd,slianl,snoanl,len) call monitr('sotdif',sotfcsd,slianl,snoanl,len) + call monitr('socdif',socfcsd,slianl,snoanl,len) !cwu [+2l] add sih, sic call monitr('sihdif',sihfcsd,slianl,snoanl,len) call monitr('sicdif',sicfcsd,slianl,snoanl,len) @@ -2365,7 +2463,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & call monitr('absdif',absfcsd,slianl,snoanl,len) endif deallocate (tsffcsd, snofcsd, tg3fcsd, zorfcsd, slifcsd, & - & aisfcsd, cnpfcsd, vegfcsd, vetfcsd, sotfcsd, & + & aisfcsd, cnpfcsd, vegfcsd, vetfcsd, sotfcsd,socfcsd, & & sihfcsd, sicfcsd, vmnfcsd, vmxfcsd, slpfcsd, & & absfcsd) deallocate (smcfcsd, stcfcsd, albfcsd) @@ -2388,6 +2486,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & vegfcs(i) = veganl(i) vetfcs(i) = vetanl(i) sotfcs(i) = sotanl(i) + socfcs(i) = socanl(i) !clu [+4l] add vmn, vmx, slp, abs vmnfcs(i) = vmnanl(i) vmxfcs(i) = vmxanl(i) @@ -3645,14 +3744,14 @@ subroutine filanl(tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl, & & aisanl, & & tg3anl,cvanl ,cvbanl,cvtanl, & & cnpanl,smcanl,stcanl,slianl,scvanl,veganl, & - & vetanl,sotanl,alfanl, & + & vetanl,sotanl,socanl,alfanl, & !socanl: soil color & sihanl,sicanl, & !cwu [+1l] add ()anl for sih, sic & vmnanl,vmxanl,slpanl,absanl, & !clu [+1l] add ()anl for vmn, vmx, slp, abs & tsfclm,tsfcl2,wetclm,snoclm,zorclm,albclm, & & aisclm, & & tg3clm,cvclm ,cvbclm,cvtclm, & & cnpclm,smcclm,stcclm,sliclm,scvclm,vegclm, & - & vetclm,sotclm,alfclm, & + & vetclm,sotclm,socclm,alfclm, & !socclm: soil color & sihclm,sicclm, & !cwu [+1l] add ()clm for sih, sic & vmnclm,vmxclm,slpclm,absclm, & !clu [+1l] add ()clm for vmn, vmx, slp, abs & len,lsoil) @@ -3668,7 +3767,7 @@ subroutine filanl(tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl, & & cnpanl(len), & & smcanl(len,lsoil),stcanl(len,lsoil), & & slianl(len),scvanl(len),veganl(len), & - & vetanl(len),sotanl(len),alfanl(len,2) & + & vetanl(len),sotanl(len),socanl(len),alfanl(len,2) & !socanl:soil color &, sihanl(len),sicanl(len) & &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) real (kind=kind_io8) tsfclm(len),tsfcl2(len),wetclm(len), & @@ -3679,7 +3778,7 @@ subroutine filanl(tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl, & & cnpclm(len), & & smcclm(len,lsoil),stcclm(len,lsoil), & & sliclm(len),scvclm(len),vegclm(len), & - & vetclm(len),sotclm(len),alfclm(len,2) & + & vetclm(len),sotclm(len),socclm(len),alfclm(len,2) & !socclm:soil color &, sihclm(len),sicclm(len) & &, vmnclm(len),vmxclm(len),slpclm(len),absclm(len) ! @@ -3698,6 +3797,7 @@ subroutine filanl(tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl, & veganl(i) = vegclm(i) ! vegetation cover vetanl(i) = vetclm(i) ! vegetation type sotanl(i) = sotclm(i) ! soil type + socanl(i) = socclm(i) ! soil color cvanl(i) = cvclm(i) ! cv cvbanl(i) = cvbclm(i) ! cvb cvtanl(i) = cvtclm(i) ! cvt @@ -3735,20 +3835,20 @@ subroutine filanl(tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl, & subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil,slmskl,slmskw, & & fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, & & fntg3a,fnscva,fnsmca,fnstca,fnacna,fnvega, & - & fnveta,fnsota, & + & fnveta,fnsota,fnsoca, & !fnsoca: soil color & fnvmna,fnvmxa,fnslpa,fnabsa, & !clu [+1l] add fn()a for vmn, vmx, slp, abs & tsfanl,wetanl,snoanl,zoranl,albanl,aisanl, & & tg3anl,cvanl ,cvbanl,cvtanl, & & smcanl,stcanl,slianl,scvanl,acnanl,veganl, & - & vetanl,sotanl,alfanl,tsfan0, & + & vetanl,sotanl,socanl,alfanl,tsfan0, & !soil color & vmnanl,vmxanl,slpanl,absanl, & !clu [+1l] add ()anl for vmn, vmx, slp, abs & kpdtsf,kpdwet,kpdsno,kpdsnd,kpdzor,kpdalb,kpdais,& & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, & - & kprvet,kpdsot,kpdalf, & + & kprvet,kpdsot,kpdsoc,kpdalf, & !kpdsoc: soil color & kpdvmn,kpdvmx,kpdslp,kpdabs, & !clu [+1l] add kpd() for vmn, vmx, slp, abs & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, & !cggg snow mods & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, & - & irtvet,irtsot,irtalf & + & irtvet,irtsot,irtsoc,irtalf & !irtsoc: soil color &, irtvmn,irtvmx,irtslp,irtabs & !clu [+1l] add irt() for vmn, vmx, slp, abs &, imsk, jmsk, slmskh, outlat, outlon & &, gaus, blno, blto, me, lanom) @@ -3756,9 +3856,9 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil,slmskl,slmskw, & implicit none logical lanom integer irtsmc,irtacn,irtstc,irtvet,irtveg,irtscv,irtzor,irtsno, & - & irtalb,irttg3,irtais,iret,me,kk,kpdvet,i,irtalf,irtsot, & + & irtalb,irttg3,irtais,iret,me,kk,kpdvet,i,irtalf,irtsot,irtsoc, & !irtsoc:soil color & imsk,jmsk,irtwet,lsoil,len,kpdtsf,kpdsno,kpdsnd,kpdwet,iy,& - & lugb,im,ih,id,kpdveg,kpdstc,kprvet,irttsf,kpdsot,kpdsmc, & + & lugb,im,ih,id,kpdveg,kpdstc,kprvet,irttsf,kpdsot,kpdsoc,kpdsmc,& !kpdsoc: soil color & kpdais,kpdzor,kpdtg3,kpdacn,kpdscv,j & &, kpdvmn,kpdvmx,kpdslp,kpdabs,irtvmn,irtvmx,irtslp,irtabs real (kind=kind_io8) blto,blno,fh @@ -3774,15 +3874,15 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil,slmskl,slmskw, & ! character*500 fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, & & fntg3a,fnscva,fnsmca,fnstca,fnacna,fnvega, & - & fnveta,fnsota - &, fnvmna,fnvmxa,fnslpa,fnabsa + & fnveta,fnsota,fnsoca, & !fnsoca: soil color + & fnvmna,fnvmxa,fnslpa,fnabsa real (kind=kind_io8) tsfanl(len), wetanl(len), snoanl(len), & & zoranl(len), albanl(len,4), aisanl(len), & & tg3anl(len), acnanl(len), & & cvanl (len), cvbanl(len), cvtanl(len), & & slianl(len), scvanl(len), veganl(len), & - & vetanl(len), sotanl(len), alfanl(len,2), & + & vetanl(len), sotanl(len), socanl(len),alfanl(len,2), & !socanl: soil color & smcanl(len,lsoil), stcanl(len,lsoil), & & tsfan0(len) & &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) @@ -4267,6 +4367,36 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil,slmskl,slmskw, & endif endif +! +! soil color +! + irtsoc=0 + if(fnsoca(1:8).ne.' ') then + call fixrda(lugb,fnsoca,kpdsoc,slmskl, + & iy,im,id,ih,fh,socanl,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + irtsoc=iret + if(iret.eq.1) then + write(6,*) 'FATAL ERROR: soil color analysis read error.' + call abort + elseif(iret.eq.-1) then + if (me .eq. 0) then + print *,'old soil color analysis provided', + & ' indicating proper file name is given.' + print *,' no error suspected.' + write(6,*) 'forecast guess will be used' + endif + else + if (me .eq. 0) print *,'soil color analysis provided.' + endif + else + if (me .eq. 0) then +! print *,'************************************************' + print *,'no soil color anly available. climatology used' + endif + endif + !clu [+120l]-------------------------------------------------------------- ! ! min vegetation cover @@ -4397,13 +4527,13 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil,slmskl,slmskw, & subroutine filfcs(tsffcs,wetfcs,snofcs,zorfcs,albfcs, & & tg3fcs,cvfcs ,cvbfcs,cvtfcs, & & cnpfcs,smcfcs,stcfcs,slifcs,aisfcs, & - & vegfcs, vetfcs, sotfcs, alffcs, & + & vegfcs, vetfcs, sotfcs,socfcs, alffcs, & !socfcs: soil color & sihfcs,sicfcs, & !cwu [+1l] add ()fcs for sih, sic & vmnfcs,vmxfcs,slpfcs,absfcs, & !clu [+1l] add ()fcs for vmn, vmx, slp, abs & tsfanl,wetanl,snoanl,zoranl,albanl, & & tg3anl,cvanl ,cvbanl,cvtanl, & & cnpanl,smcanl,stcanl,slianl,aisanl, & - & veganl, vetanl, sotanl, alfanl, & + & veganl, vetanl, sotanl,socanl, alfanl, & !soil color & sihanl,sicanl, & !cwu [+1l] add ()anl for sih, sic & vmnanl,vmxanl,slpanl,absanl, & !clu [+1l] add ()anl for vmn, vmx, slp, abs & len,lsoil) @@ -4418,7 +4548,7 @@ subroutine filfcs(tsffcs,wetfcs,snofcs,zorfcs,albfcs, & & cnpfcs(len), & & smcfcs(len,lsoil),stcfcs(len,lsoil), & & slifcs(len),vegfcs(len), & - & vetfcs(len),sotfcs(len),alffcs(len,2) & + & vetfcs(len),sotfcs(len),socfcs(len),alffcs(len,2) & !socfcs: soil color &, sihfcs(len),sicfcs(len) & &, vmnfcs(len),vmxfcs(len),slpfcs(len),absfcs(len) real (kind=kind_io8) tsfanl(len),wetanl(len),snoanl(len), & @@ -4428,7 +4558,7 @@ subroutine filfcs(tsffcs,wetfcs,snofcs,zorfcs,albfcs, & & cnpanl(len), & & smcanl(len,lsoil),stcanl(len,lsoil), & & slianl(len),veganl(len), & - & vetanl(len),sotanl(len),alfanl(len,2) & + & vetanl(len),sotanl(len),socanl(len),alfanl(len,2) & !socanl:soil color &, sihanl(len),sicanl(len) & &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) ! @@ -4457,6 +4587,7 @@ subroutine filfcs(tsffcs,wetfcs,snofcs,zorfcs,albfcs, & vegfcs(i) = veganl(i) ! vegetation cover vetfcs(i) = vetanl(i) ! vegetation type sotfcs(i) = sotanl(i) ! soil type + socfcs(i) = socanl(i) ! soil color alffcs(i,1) = alfanl(i,1) ! vegetation fraction for albedo alffcs(i,2) = alfanl(i,2) ! vegetation fraction for albedo !cwu [+2l] add sih, sic @@ -4688,41 +4819,43 @@ subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & & tsffcs,wetfcs,snofcs,zorfcs,albfcs,aisfcs, & & cvfcs ,cvbfcs,cvtfcs, & & cnpfcs,smcfcs,stcfcs,slifcs,vegfcs, & - & vetfcs,sotfcs,alffcs, & + & vetfcs,sotfcs,socfcs,alffcs, & !socfcs:soil color & sihanl,sicanl, & & vmnanl,vmxanl,slpanl,absanl, & & tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl,aisanl,& & cvanl ,cvbanl,cvtanl, & & cnpanl,smcanl,stcanl,slianl,veganl, & - & vetanl,sotanl,alfanl, & + & vetanl,sotanl,socanl,alfanl, & !socanl:soil color & ctsfl,calbl,caisl,csnol,csmcl,czorl,cstcl,cvegl, & & ctsfs,calbs,caiss,csnos,csmcs,czors,cstcs,cvegs, & & ccv,ccvb,ccvt,ccnp,cvetl,cvets,csotl,csots, & + & csocl,csocs, & !csocl,csocs:soil color & calfl,calfs, & & csihl,csihs,csicl,csics, & & cvmnl,cvmns,cvmxl,cvmxs,cslpl,cslps,cabsl,cabss, & & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, & & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, & & irtvmn,irtvmx,irtslp,irtabs, & - & irtvet,irtsot,irtalf, landice, me) + & irtvet,irtsot,irtsoc,irtalf, landice, me) use machine , only : kind_io8,kind_io4 use sfccyc_module, only : veg_type_landice, soil_type_landice, & - & num_threads, zero, one + & num_threads, zero, one,soil_color_landice implicit none integer k,i,im,id,iy,len,lsoil,ih,irtacn,irtsmc,irtscv,irtais, & - & irttg3,irtstc,irtalf,me,irtsot,irtveg,irtvet, irtzor, & + & irttg3,irtstc,irtalf,me,irtsot,irtsoc,irtveg,irtvet, irtzor, & !irtsoc:soil color & irtalb,irtsno,irttsf,irtwet,j & &, irtvmn,irtvmx,irtslp,irtabs logical, intent(in) :: landice - real (kind=kind_io8) rvegs,rvets,rzors,raiss,rsnos,rsots,rcnp, & - & rcvt,rcv,rcvb,rsnol,rzorl,raisl,ralbl, & - & ralfl,rvegl,ralbs,ralfs,rtsfs,rvetl,rsotl, & + real (kind=kind_io8) rvegs,rvets,rzors,raiss,rsnos,rsots,rsocs, & !rsocs:soil color + & rcnp,rcvt,rcv,rcvb,rsnol,rzorl,raisl,ralbl, & + & ralfl,rvegl,ralbs,ralfs,rtsfs,rvetl,rsotl,rsocl, & & qzors,qvegs,qsnos,qalfs,qaiss,qvets,qcvt, & - & qcnp,qcvb,qsots,qcv,qaisl,qsnol,qalfl, & - & qtsfl,qalbl,qzorl,qtsfs,qalbs,qsotl,qvegl, & + & qcnp,qcvb,qsots,qsocs,qcv,qaisl,qsnol,qalfl, & + & qtsfl,qalbl,qzorl,qtsfs,qalbs,qsotl,qsocl,qvegl, & & qvetl,rtsfl,calbs,caiss,ctsfs,czorl,cvegl, & & csnos,ccvb,ccvt,ccv,czors,cvegs,caisl,csnol, & & calbl,fh,ctsfl,ccnp,csots,calfl,csotl,cvetl, & + & csocl,csocs, & !csocl,csocs:soil color & cvets,calfs,deltsfc, & & csihl,csihs,csicl,csics, & & rsihl,rsihs,rsicl,rsics, & @@ -4739,7 +4872,7 @@ subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & & cnpfcs(len), & & smcfcs(len,lsoil),stcfcs(len,lsoil), & & slifcs(len), vegfcs(len), & - & vetfcs(len), sotfcs(len), alffcs(len,2) & + & vetfcs(len), sotfcs(len),socfcs(len), alffcs(len,2) & !socfcs:soil color &, sihfcs(len), sicfcs(len) & &, vmnfcs(len),vmxfcs(len),slpfcs(len),absfcs(len) real (kind=kind_io8) tsfanl(len),tsfan2(len), & @@ -4749,7 +4882,7 @@ subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & & cnpanl(len), & & smcanl(len,lsoil),stcanl(len,lsoil), & & slianl(len), veganl(len), & - & vetanl(len), sotanl(len), alfanl(len,2) & + & vetanl(len), sotanl(len),socanl(len), alfanl(len,2) & !socanl:soil color &, sihanl(len),sicanl(len) & &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) ! @@ -4787,6 +4920,7 @@ subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & rvegl = cvegl rvetl = cvetl rsotl = csotl + rsocl = csocl !soil color rsihl = csihl rsicl = csicl rvmnl = cvmnl @@ -4804,6 +4938,7 @@ subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & rvegs = cvegs rvets = cvets rsots = csots + rsocs = csocs !soil color rsihs = csihs rsics = csics rvmns = cvmns @@ -4885,6 +5020,11 @@ subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & rsots = 1. endif + if(irtsoc == -1) then !soil color + rsocl = 1. + rsocs = 1. + endif + if(irtacn == -1) then rsicl = 1. rsics = 1. @@ -4921,6 +5061,10 @@ subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & 101 format('rtsfs,ralbs,raiss,rsnos,rsmcs,rzors,rvegs,rsics=',11f7.3) ! print *,' ralfl=',ralfl,' ralfs=',ralfs,' rsotl=',rsotl ! *,' rsots=',rsots,' rvetl=',rvetl,' rvets=',rvets + + write(6,102) rsocl,rsocs + 102 format('rsoc1, rsocs =',10f7.3) + endif ! qtsfl = 1. - rtsfl @@ -4933,6 +5077,8 @@ subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & qvegl = 1. - rvegl qvetl = 1. - rvetl qsotl = 1. - rsotl + qsocl = 1. - rsocl !soil color + qsihl = 1. - rsihl qsicl = 1. - rsicl qvmnl = 1. - rvmnl @@ -4950,6 +5096,8 @@ subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & qvegs = 1. - rvegs qvets = 1. - rvets qsots = 1. - rsots + qsocs = 1. - rsocs + qsihs = 1. - rsihs qsics = 1. - rsics qvmns = 1. - rvmns @@ -4999,9 +5147,11 @@ subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & if(slianl(i) == zero) then vetanl(i) = vetfcs(i)*rvets + vetanl(i)*qvets sotanl(i) = sotfcs(i)*rsots + sotanl(i)*qsots + socanl(i) = socfcs(i)*rsocs + socanl(i)*qsocs else vetanl(i) = vetfcs(i)*rvetl + vetanl(i)*qvetl sotanl(i) = sotfcs(i)*rsotl + sotanl(i)*qsotl + socanl(i) = socfcs(i)*rsocl + socanl(i)*qsocl endif enddo enddo @@ -5066,7 +5216,7 @@ subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & ! enddo -! at landice points, set the soil type, slope type and +! at landice points, set the soil type, color,slope type and ! greenness fields to flag values. if (landice) then @@ -5074,6 +5224,7 @@ subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & if (nint(slianl(i)) == 1) then if (nint(vetanl(i)) == veg_type_landice) then sotanl(i) = soil_type_landice + socanl(i) = soil_color_landice veganl(i) = 0.0 slpanl(i) = 9.0 vmnanl(i) = 0.0 @@ -6895,12 +7046,12 @@ subroutine ga2la(gauin,imxin,jmxin,regout,imxout,jmxout, & end !>\ingroup mod_sfcsub - subroutine landtyp(vegtype,soiltype,slptype,slmask,len) + subroutine landtyp(vegtype,soiltype,colortype,slptype,slmask,len) use machine , only : kind_io8,kind_io4 implicit none integer i,len real (kind=kind_io8) vegtype(len),soiltype(len),slmask(len) & - &, slptype(len) + &, slptype(len),colortype(len) ! ! make sure that the soil type and veg type are non-zero over land ! @@ -6908,6 +7059,7 @@ subroutine landtyp(vegtype,soiltype,slptype,slmask,len) if (slmask(i) .eq. 1) then if (vegtype(i) .eq. 0.) vegtype(i) = 7 if (soiltype(i) .eq. 0.) soiltype(i) = 2 + if (colortype(i) .eq. 0.) colortype(i)= 4 if (slptype(i) .eq. 0.) slptype(i) = 1 endif enddo @@ -6966,16 +7118,16 @@ subroutine anomint(tsfan0,tsfclm,tsfcl0,tsfanl,len) subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil,slmskl,slmskw, & & fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, & & fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc, & - & fnvetc,fnsotc, & + & fnvetc,fnsotc,fnsocc, & & fnvmnc,fnvmxc,fnslpc,fnabsc, & & tsfclm,tsfcl2,wetclm,snoclm,zorclm,albclm,aisclm,& & tg3clm,cvclm ,cvbclm,cvtclm, & & cnpclm,smcclm,stcclm,sliclm,scvclm,acnclm,vegclm,& - & vetclm,sotclm,alfclm, & + & vetclm,sotclm,socclm,alfclm, & & vmnclm,vmxclm,slpclm,absclm, & & kpdtsf,kpdwet,kpdsno,kpdzor,kpdalb,kpdais, & & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, & - & kpdvet,kpdsot,kpdalf,tsfcl0, & + & kpdvet,kpdsot,kpdsoc,kpdalf,tsfcl0, & & kpdvmn,kpdvmx,kpdslp,kpdabs, & & deltsfc, lanom & &, imsk, jmsk, slmskh, outlat, outlon & @@ -6993,13 +7145,13 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil,slmskl,slmskw, & & jy,mon1,is2,isx,kpd9,is1,l,nn,mon2,mon,is,kpdsno, & & kpdzor,kpdtsf,kpdwet,kpdscv,kpdacn,kpdais,kpdtg3,im,id, & & lugb,iy,len,lsoil,ih,kpdsmc,iprnt,me,m1,m2,k1,k2, & - & kpdvet,kpdsot,kpdstc,kpdveg,jmsk,imsk,j,ialb & + & kpdvet,kpdsot,kpdsoc,kpdstc,kpdveg,jmsk,imsk,j,ialb & &, kpdvmn,kpdvmx,kpdslp,kpdabs,landice_cat integer kpdalb(4), kpdalf(2) ! character*500 fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, & & fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc, & - & fnvetc,fnsotc,fnalbc2 & + & fnvetc,fnsotc,fnsocc,fnalbc2 & &, fnvmnc,fnvmxc,fnslpc,fnabsc real (kind=kind_io8) tsfclm(len),tsfcl2(len), & & wetclm(len),snoclm(len), & @@ -7009,7 +7161,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil,slmskl,slmskw, & & cnpclm(len), & & smcclm(len,lsoil),stcclm(len,lsoil), & & sliclm(len),scvclm(len),vegclm(len), & - & vetclm(len),sotclm(len),alfclm(len,2) & + & vetclm(len),sotclm(len),socclm(len),alfclm(len,2) & &, vmnclm(len),vmxclm(len),slpclm(len),absclm(len) real (kind=kind_io8) slmskh(imsk,jmsk) real (kind=kind_io8) outlat(len), outlon(len) @@ -7051,7 +7203,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil,slmskl,slmskw, & & zor(:,:),wet(:,:), & ais(:,:), acn(:,:), scv(:,:), smc(:,:,:), & tg3(:), alb(:,:,:), alf(:,:), - & vet(:), sot(:), tsf2(:), + & vet(:), sot(:), soc(:), tsf2(:), & veg(:,:), stc(:,:,:) &, vmn(:), vmx(:), slp(:), absm(:) ! @@ -7060,7 +7212,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil,slmskl,slmskw, & data mon1s/0/, mon2s/0/, sea1s/0/, sea2s/0/ ! save first, tsf, sno, zor, wet, ais, acn, scv, smc, tg3, - & alb, alf, vet, sot, tsf2, veg, stc, + & alb, alf, vet, sot, soc,tsf2, veg, stc, & vmn, vmx, slp, absm, & mon1s, mon2s, sea1s, sea2s, dayhf, k1, k2, m1, m2, & landice_cat @@ -7115,7 +7267,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil,slmskl,slmskw, & & wet(len,2), ais(len,2), acn(len,2), & scv(len,2), smc(len,lsoil,2), & tg3(len), alb(len,4,2), alf(len,2), - & vet(len), sot(len), tsf2(len), + & vet(len), sot(len), soc(len),tsf2(len), !clu [+1l] add vmn, vmx, slp, abs & vmn(len), vmx(len), slp(len), absm(len), & veg(len,2), stc(len,lsoil,2)) @@ -7394,6 +7546,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil,slmskl,slmskw, & endif ! ! soil type + print *,'in FIXREAD fnsotc =',fnsotc ! if(fnsotc(1:8).ne.' ') then if ( index(fnsotc, "tileX.nc") == 0) then ! grib file @@ -7409,6 +7562,24 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil,slmskl,slmskw, & if (me .eq. 0) write(6,*) 'climatological soil type read in.' endif +! +! soil color +! + If(fnsocc(1:8).ne.' ') then + if ( index(fnsocc, "tileX.nc") == 0) then ! grib file + kpd7=-1 + call fixrdc(lugb,fnsocc,kpdsoc,kpd7,kpd9,slmskl, + & soc,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + else + call fixrdc_tile(fnsocc, tile_num_ch, i_index, j_index, + & 255, soc, 1, len, me) + if (me .eq. 0) write(6,*) 'Soil color data name is',fnsocc + endif + if (me .eq. 0) write(6,*) 'climatological soil color read in.' + endif + ! ! min vegetation cover ! @@ -8088,6 +8259,11 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil,slmskl,slmskw, & enddo endif + if(fnsocc(1:8).ne.' ') then + do i=1,len + socclm(i) = soc(i) + enddo + endif !clu ---------------------------------------------------------------------- ! @@ -8217,6 +8393,8 @@ subroutine fixrdc_tile(filename_raw, tile_num_ch, & error=nf90_inq_varid(ncid, 'vegetation_type', id_var) case(236) error=nf90_inq_varid(ncid, 'slope_type', id_var) + case(255) + ERROR=NF90_INQ_VARID(NCID, 'soil_color', id_var) case(256:257) error=nf90_inq_varid(ncid, 'vegetation_greenness', id_var) case default From 786cd2083f7e77fa3c5597ad1fabd63cd833ba56 Mon Sep 17 00:00:00 2001 From: dustinswales Date: Tue, 22 Nov 2022 11:11:09 -0700 Subject: [PATCH 062/380] Omission from previous commit --- physics/GFS_rrtmgp_setup.meta | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/GFS_rrtmgp_setup.meta b/physics/GFS_rrtmgp_setup.meta index ad4a8a765..2bba14506 100644 --- a/physics/GFS_rrtmgp_setup.meta +++ b/physics/GFS_rrtmgp_setup.meta @@ -262,7 +262,7 @@ [ipsd0] standard_name = initial_seed_for_mcica long_name = initial permutaion seed for mcica radiation - units = none + units = 1 dimensions = () type = integer intent = inout From fb6fdb9914cb3e9c2cbed4b91c32d7de3e868ba8 Mon Sep 17 00:00:00 2001 From: dustinswales Date: Tue, 22 Nov 2022 15:43:49 -0700 Subject: [PATCH 063/380] Move declaration to init. --- physics/GFS_rrtmg_setup.F90 | 10 +++++----- physics/GFS_rrtmg_setup.meta | 16 ++++++++++++++++ physics/radiation_clouds.f | 12 ++++++------ 3 files changed, 27 insertions(+), 11 deletions(-) diff --git a/physics/GFS_rrtmg_setup.F90 b/physics/GFS_rrtmg_setup.F90 index addd847a2..384d5252d 100644 --- a/physics/GFS_rrtmg_setup.F90 +++ b/physics/GFS_rrtmg_setup.F90 @@ -42,9 +42,9 @@ subroutine GFS_rrtmg_setup_init ( si, levr, ictm, isol, solar_file, ico2, & iovr_max, iovr_dcorr, iovr_exp, iovr_exprand, icliq_sw, lcrick, & lcnorm, imp_physics, lnoprec, idate, iflip, do_RRTMGP, me, lalw1bd, & iaermdl, iaerflg, aeros_file, con_pi, con_t0c, con_c, con_boltz, & - con_plnk, con_solr_2008, con_solr_2002, co2usr_file, co2cyc_file, & - rad_hr_units, inc_minor_gas, icliq_lw, isubcsw, isubclw, iswmode, & - ipsd0, ltp, lextop, errmsg, errflg) + con_plnk, con_solr_2008, con_solr_2002, con_g, con_rd, co2usr_file, & + co2cyc_file, rad_hr_units, inc_minor_gas, icliq_lw, isubcsw, isubclw,& + iswmode, ipsd0, ltp, lextop, errmsg, errflg) ! ================= subprogram documentation block ================ ! ! ! ! subprogram: GFS_rrtmg_setup_init - a subprogram to initialize radiation ! @@ -162,7 +162,7 @@ subroutine GFS_rrtmg_setup_init ( si, levr, ictm, isol, solar_file, ico2, & character(len=26),intent(in) :: aeros_file, solar_file, co2usr_file,& co2cyc_file real(kind_phys), intent(in) :: con_pi, con_t0c, con_c, con_boltz, & - con_plnk, con_solr_2008, con_solr_2002 + con_plnk, con_solr_2008, con_solr_2002, con_g, con_rd integer, intent(inout) :: ipsd0 character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -220,7 +220,7 @@ subroutine GFS_rrtmg_setup_init ( si, levr, ictm, isol, solar_file, ico2, & con_pi, con_t0c, con_c, con_boltz, con_plnk, errflg, errmsg) call gas_init ( me, co2usr_file, co2cyc_file, ico2, ictm, ntoz, & con_pi, errflg, errmsg) - call cld_init ( si, levr, imp_physics, me, errflg, errmsg) + call cld_init ( si, levr, imp_physics, me, con_g, con_rd, errflg, errmsg) call rlwinit ( me, rad_hr_units, inc_minor_gas, icliq_lw, isubcsw, & iovr, iovr_rand, iovr_maxrand, iovr_max, iovr_dcorr, & iovr_exp, iovr_exprand, errflg, errmsg ) diff --git a/physics/GFS_rrtmg_setup.meta b/physics/GFS_rrtmg_setup.meta index 93319fe75..adf6d8750 100644 --- a/physics/GFS_rrtmg_setup.meta +++ b/physics/GFS_rrtmg_setup.meta @@ -321,6 +321,22 @@ type = real kind = kind_phys intent = in +[con_rd] + standard_name = gas_constant_of_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in [lalw1bd] standard_name = do_longwave_aerosol_band_properties long_name = control of band or multiband longwave aerosol properties diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index 0b7fba648..bb851c607 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -252,7 +252,7 @@ module module_radiation_clouds !!\param me print control flag !>\section cld_init General Algorithm subroutine cld_init & - & ( si, NLAY, imp_physics, me, errflg, errmsg ) + & ( si, NLAY, imp_physics, me, con_g, con_rd, errflg, errmsg ) ! =================================================================== ! ! ! ! abstract: cld_init is an initialization program for cloud-radiation ! @@ -281,7 +281,7 @@ subroutine cld_init & ! --- inputs: integer, intent(in) :: NLAY, me, imp_physics - real (kind=kind_phys), intent(in) :: si(:) + real (kind=kind_phys), intent(in) :: si(:), con_g, con_rd ! --- outputs: integer, intent(out) :: errflg @@ -294,6 +294,10 @@ subroutine cld_init & errmsg = '' errflg = 0 + ! Initialze module parameters + gfac = 1.0e5/con_g + gord = con_g/con_rd + if (me == 0) then print *, VTAGCLD !print out version tag print *,' - Using Prognostic Cloud Method' @@ -588,10 +592,6 @@ subroutine radiation_clouds_prop & print*, 'in radiation_clouds_prop=', imp_physics, uni_cld, & & ncndl, lgfdlmprad, do_mynnedmf, imfdeepcnv, kdt end if - - ! - gfac = 1.0e5/con_g - gord = con_g/con_rd do k = 1, NLAY do i = 1, IX From e079dc7abc2964b6e232cf4dcee779e1a5581636 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Mon, 28 Nov 2022 17:19:09 +0000 Subject: [PATCH 064/380] revert some changes --- physics/GFS_MP_generic_post.F90 | 19 +- physics/GFS_MP_generic_post.meta | 7 + physics/GFS_surface_composites_post.F90 | 247 ++++++++++-------------- physics/clm_lake.f90 | 6 +- physics/clm_lake.meta | 2 +- physics/physcons.F90 | 2 +- physics/sfc_diag.f | 60 +++--- physics/sfc_diag.meta | 51 ----- 8 files changed, 149 insertions(+), 245 deletions(-) diff --git a/physics/GFS_MP_generic_post.F90 b/physics/GFS_MP_generic_post.F90 index a1df2a880..65ec9f67e 100644 --- a/physics/GFS_MP_generic_post.F90 +++ b/physics/GFS_MP_generic_post.F90 @@ -28,7 +28,7 @@ subroutine GFS_MP_generic_post_run( graupelprv, draincprv, drainncprv, diceprv, dsnowprv, dgraupelprv, dtp, dfi_radar_max_intervals, & dtend, dtidx, index_of_temperature, index_of_process_mp,ldiag3d, qdiag3d,dqdt_qmicro, lssav, num_dfi_radar, & fh_dfi_radar,index_of_process_dfi_radar, ix_dfi_radar, dfi_radar_tten, radar_tten_limits, fhour, prevsq, & - iopt_lake, iopt_lake_clm, lkm, errmsg, errflg) + iopt_lake, iopt_lake_clm, lkm, use_lake_model, errmsg, errflg) ! use machine, only: kind_phys use calpreciptype_mod, only: calpreciptype @@ -38,7 +38,7 @@ subroutine GFS_MP_generic_post_run( integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_mg, imp_physics_fer_hires integer, intent(in) :: imp_physics_nssl, iopt_lake_clm, iopt_lake, lkm logical, intent(in) :: cal_pre, lssav, ldiag3d, qdiag3d, cplflx, cplchm, cpllnd, progsigma - integer, intent(in) :: index_of_temperature,index_of_process_mp + integer, intent(in) :: index_of_temperature,index_of_process_mp,use_lake_model(:) integer :: dfi_radar_max_intervals real(kind=kind_phys), intent(in) :: fh_dfi_radar(:), fhour @@ -138,10 +138,9 @@ subroutine GFS_MP_generic_post_run( ice = frain*rain1*sr ! time-step ice end if - if (lsm==lsm_ruc .or. lsm==lsm_noahmp .or. (lkm>0 .and. iopt_lake==iopt_lake_clm)) then - raincprv(:) = rainc(:) - rainncprv(:) = frain * rain1(:) - if(lsm==lsm_ruc .or. lsm==lsm_noahmp) then + if (lsm==lsm_ruc .or. lsm==lsm_noahmp) then + raincprv(:) = rainc(:) + rainncprv(:) = frain * rain1(:) iceprv(:) = ice(:) snowprv(:) = snow(:) graupelprv(:) = graupel(:) @@ -156,7 +155,13 @@ subroutine GFS_MP_generic_post_run( dgraupelprv(:) = tem * graupelprv(:) diceprv(:) = tem * iceprv(:) end if - end if + else if(lkm>0 .and. iopt_lake==iopt_lake_clm) then + do i=1,im + if(use_lake_model(i)>0) then + raincprv(i) = rainc(i) + rainncprv(i) = frain * rain1(i) + end if + end do end if if (cal_pre) then ! hchuang: add dominant precipitation type algorithm diff --git a/physics/GFS_MP_generic_post.meta b/physics/GFS_MP_generic_post.meta index 4cc0579be..1287dd68a 100644 --- a/physics/GFS_MP_generic_post.meta +++ b/physics/GFS_MP_generic_post.meta @@ -782,6 +782,13 @@ dimensions = () type = integer intent = in +[use_lake_model] + standard_name = flag_for_using_lake_model + long_name = flag indicating lake points using a lake model + units = flag + dimensions = (horizontal_loop_extent) + type = integer + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/GFS_surface_composites_post.F90 b/physics/GFS_surface_composites_post.F90 index eb6b2e32e..868db390f 100644 --- a/physics/GFS_surface_composites_post.F90 +++ b/physics/GFS_surface_composites_post.F90 @@ -269,34 +269,109 @@ subroutine GFS_surface_composites_post_run ( else ! not fractional grid do i=1,im - - ! This code assumes points are always 100% lake or 0% lake, - ! and lake points must have wet(i)=true, even if they have - ! 100% ice cover. The only fractional coverage allowed is - ! fractional ice on lake points that ran the CLM Lake - ! Model (frac_ice). For more general fractional grid support, use - ! frac_grid. - - if (dry(i)) then - ! This is a land point. - call composite_land - elseif(frac_ice .and. use_lake_model(i)>0 .and. iopt_lake==iopt_lake_clm) then - ! This is a lake point where the CLM Lake Model was run with frac_ice. - if(icy(i)) then - ! Lake point has more than min_lakeice ice. - call composite_icy(.true.) - call composite_wet_and_icy + if (islmsk(i) == 1) then + !-- land + zorl(i) = zorll(i) + cd(i) = cd_lnd(i) + cdq(i) = cdq_lnd(i) + rb(i) = rb_lnd(i) + stress(i) = stress_lnd(i) + ffmm(i) = ffmm_lnd(i) + ffhh(i) = ffhh_lnd(i) + uustar(i) = uustar_lnd(i) + fm10(i) = fm10_lnd(i) + fh2(i) = fh2_lnd(i) + tsfc(i) = tsfcl(i) + tsfco(i) = tsfc(i) + tisfc(i) = tsfc(i) + cmm(i) = cmm_lnd(i) + chh(i) = chh_lnd(i) + gflx(i) = gflx_lnd(i) + ep1d(i) = ep1d_lnd(i) + weasd(i) = weasd_lnd(i) + snowd(i) = snowd_lnd(i) + evap(i) = evap_lnd(i) + hflx(i) = hflx_lnd(i) + qss(i) = qss_lnd(i) + hice(i) = zero + cice(i) = zero + elseif (islmsk(i) == 0) then + !-- water + zorl(i) = zorlo(i) + cd(i) = cd_wat(i) + cdq(i) = cdq_wat(i) + rb(i) = rb_wat(i) + stress(i) = stress_wat(i) + ffmm(i) = ffmm_wat(i) + ffhh(i) = ffhh_wat(i) + uustar(i) = uustar_wat(i) + fm10(i) = fm10_wat(i) + fh2(i) = fh2_wat(i) + tsfco(i) = tsfc_wat(i) ! over lake (and ocean when uncoupled) + tsfc(i) = tsfco(i) + tsfcl(i) = tsfc(i) + tisfc(i) = tsfc(i) + cmm(i) = cmm_wat(i) + chh(i) = chh_wat(i) + gflx(i) = gflx_wat(i) + ep1d(i) = ep1d_wat(i) + weasd(i) = zero + snowd(i) = zero + evap(i) = evap_wat(i) + hflx(i) = hflx_wat(i) + qss(i) = qss_wat(i) + hice(i) = zero + cice(i) = zero + else ! islmsk(i) == 2 + !-- ice + zorl(i) = zorli(i) + cd(i) = cd_ice(i) + cdq(i) = cdq_ice(i) + rb(i) = rb_ice(i) + ffmm(i) = ffmm_ice(i) + ffhh(i) = ffhh_ice(i) + uustar(i) = uustar_ice(i) + fm10(i) = fm10_ice(i) + fh2(i) = fh2_ice(i) + stress(i) = stress_ice(i) + cmm(i) = cmm_ice(i) + chh(i) = chh_ice(i) + gflx(i) = gflx_ice(i) + ep1d(i) = ep1d_ice(i) + weasd(i) = weasd_ice(i) * cice(i) + snowd(i) = snowd_ice(i) * cice(i) + qss(i) = qss_ice(i) + evap(i) = evap_ice(i) + hflx(i) = hflx_ice(i) +! + txi = cice(i) + txo = one - txi + evap(i) = txi * evap_ice(i) + txo * evap_wat(i) + hflx(i) = txi * hflx_ice(i) + txo * hflx_wat(i) + tsfc(i) = txi * tisfc(i) + txo * tsfc_wat(i) + stress(i) = txi * stress_ice(i) + txo * stress_wat(i) + qss(i) = txi * qss_ice(i) + txo * qss_wat(i) + ep1d(i) = txi * ep1d_ice(i) + txo * ep1d_wat(i) + + lnzorli = zero ; lnzorlo = zero + if (zorli(i) /= huge) then + lnzorli = log(zorli(i)) + endif + if (zorlo(i) /= huge) then + lnzorlo = log(zorlo(i)) + endif + zorl(i) = exp(txi*lnzorli + txo*lnzorlo) +! zorl(i) = exp(txi*log(zorli(i)) + txo*log(zorlo(i))) +! + if (wet(i)) then + tsfco(i) = tsfc_wat(i) else - ! Lake point has less than min_lakeice ice. - call composite_wet + tsfco(i) = tsfc(i) endif - else if (wet(i)) then - ! Wet point that is not a lake, or lake point with frac_ice disabled. - call composite_wet - else ! islmsk(i) == 2 - ! This is not a lake point, and it is icy. - call composite_icy(.false.) - call composite_wet_and_icy + tsfcl(i) = tsfc(i) + do k=1,min(kice,km) ! store tiice in stc to reduce output in the nonfrac grid case + stc(i,k) = tiice(i,k) + enddo endif enddo @@ -304,126 +379,6 @@ subroutine GFS_surface_composites_post_run ( ! --- compositing done - contains - - subroutine composite_land - implicit none - zorl(i) = zorll(i) - cd(i) = cd_lnd(i) - cdq(i) = cdq_lnd(i) - rb(i) = rb_lnd(i) - stress(i) = stress_lnd(i) - ffmm(i) = ffmm_lnd(i) - ffhh(i) = ffhh_lnd(i) - uustar(i) = uustar_lnd(i) - fm10(i) = fm10_lnd(i) - fh2(i) = fh2_lnd(i) - tsfc(i) = tsfcl(i) - tsfco(i) = tsfc(i) - tisfc(i) = tsfc(i) - cmm(i) = cmm_lnd(i) - chh(i) = chh_lnd(i) - gflx(i) = gflx_lnd(i) - ep1d(i) = ep1d_lnd(i) - weasd(i) = weasd_lnd(i) - snowd(i) = snowd_lnd(i) - evap(i) = evap_lnd(i) - hflx(i) = hflx_lnd(i) - qss(i) = qss_lnd(i) - hice(i) = zero - cice(i) = zero - end subroutine composite_land - - subroutine composite_wet - implicit none - zorl(i) = zorlo(i) - cd(i) = cd_wat(i) - cdq(i) = cdq_wat(i) - rb(i) = rb_wat(i) - stress(i) = stress_wat(i) - ffmm(i) = ffmm_wat(i) - ffhh(i) = ffhh_wat(i) - uustar(i) = uustar_wat(i) - fm10(i) = fm10_wat(i) - fh2(i) = fh2_wat(i) - tsfco(i) = tsfc_wat(i) ! over lake (and ocean when uncoupled) - tsfc(i) = tsfco(i) - tsfcl(i) = tsfc(i) - tisfc(i) = tsfc(i) - cmm(i) = cmm_wat(i) - chh(i) = chh_wat(i) - gflx(i) = gflx_wat(i) - ep1d(i) = ep1d_wat(i) - weasd(i) = zero - snowd(i) = zero - evap(i) = evap_wat(i) - hflx(i) = hflx_wat(i) - qss(i) = qss_wat(i) - hice(i) = zero - cice(i) = zero - end subroutine composite_wet - - subroutine composite_icy(is_clm) - implicit none - logical, intent(in) :: is_clm - zorl(i) = zorli(i) - cd(i) = cd_ice(i) - cdq(i) = cdq_ice(i) - rb(i) = rb_ice(i) - ffmm(i) = ffmm_ice(i) - ffhh(i) = ffhh_ice(i) - uustar(i) = uustar_ice(i) - fm10(i) = fm10_ice(i) - fh2(i) = fh2_ice(i) - stress(i) = stress_ice(i) - cmm(i) = cmm_ice(i) - chh(i) = chh_ice(i) - gflx(i) = gflx_ice(i) - ep1d(i) = ep1d_ice(i) - if(is_clm) then - weasd(i) = weasd_ice(i) - snowd(i) = snowd_ice(i) - else - weasd(i) = weasd_ice(i) * cice(i) - snowd(i) = snowd_ice(i) * cice(i) - endif - qss(i) = qss_ice(i) - evap(i) = evap_ice(i) - hflx(i) = hflx_ice(i) - end subroutine composite_icy - - subroutine composite_wet_and_icy - implicit none - txi = cice(i) - txo = one - txi - evap(i) = txi * evap_ice(i) + txo * evap_wat(i) - hflx(i) = txi * hflx_ice(i) + txo * hflx_wat(i) - tsfc(i) = txi * tisfc(i) + txo * tsfc_wat(i) - stress(i) = txi * stress_ice(i) + txo * stress_wat(i) - qss(i) = txi * qss_ice(i) + txo * qss_wat(i) - ep1d(i) = txi * ep1d_ice(i) + txo * ep1d_wat(i) - - lnzorli = zero ; lnzorlo = zero - if (zorli(i) /= huge) then - lnzorli = log(zorli(i)) - endif - if (zorlo(i) /= huge) then - lnzorlo = log(zorlo(i)) - endif - zorl(i) = exp(txi*lnzorli + txo*lnzorlo) - ! zorl(i) = exp(txi*log(zorli(i)) + txo*log(zorlo(i))) - ! - if (wet(i)) then - tsfco(i) = tsfc_wat(i) - else - tsfco(i) = tsfc(i) - endif - tsfcl(i) = tsfc(i) - do k=1,min(kice,km) ! store tiice in stc to reduce output in the nonfrac grid case - stc(i,k) = tiice(i,k) - enddo - end subroutine composite_wet_and_icy - end subroutine GFS_surface_composites_post_run end module GFS_surface_composites_post diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90 index 0b1498395..3128519bb 100644 --- a/physics/clm_lake.f90 +++ b/physics/clm_lake.f90 @@ -5265,10 +5265,10 @@ end subroutine MoninObukIni !! \htmlinclude clm_lake_init.html !! subroutine clm_lake_init(con_pi,karman,con_g,con_sbc,con_t0c,rhowater,con_csol,con_cliq, & - con_hfus,con_hvap,con_rd,con_cp,rhoice,clm_lake_debug,errmsg,errflg) + con_hfus,con_hvap,con_rd,con_cp,rholakeice,clm_lake_debug,errmsg,errflg) implicit none real(kind_phys), intent(in) :: con_pi,karman,con_g,con_sbc,con_t0c, & - rhowater,con_csol,con_cliq, con_hfus,con_hvap,con_rd,con_cp,rhoice + rhowater,con_csol,con_cliq, con_hfus,con_hvap,con_rd,con_cp,rholakeice INTEGER, INTENT(OUT) :: errflg CHARACTER(*), INTENT(OUT) :: errmsg logical, intent(in) :: clm_lake_debug @@ -5288,7 +5288,7 @@ subroutine clm_lake_init(con_pi,karman,con_g,con_sbc,con_t0c,rhowater,con_csol,c sb = con_sbc tfrz = con_t0c denh2o = rhowater - denice = rhoice + denice = rholakeice cpice = con_csol cpliq = con_cliq hfus = con_hfus diff --git a/physics/clm_lake.meta b/physics/clm_lake.meta index d2d477490..0c8a3af33 100644 --- a/physics/clm_lake.meta +++ b/physics/clm_lake.meta @@ -897,7 +897,7 @@ type = real kind = kind_phys intent = in -[rhoice] +[rholakeice] standard_name = density_of_ice_on_lake long_name = density of ice on a lake units = kg m-3 diff --git a/physics/physcons.F90 b/physics/physcons.F90 index a8792eed3..9051af1a6 100644 --- a/physics/physcons.F90 +++ b/physics/physcons.F90 @@ -139,7 +139,7 @@ module physcons real(kind=kind_phys),parameter:: rhowater = 1000._kind_phys !< density of water (kg/m^3) real(kind=kind_phys),parameter:: rhosnow = 100._kind_phys !< density of snow (kg/m^3) real(kind=kind_phys),parameter:: rhoair = 1.28_kind_phys !< density of air near surface (kg/m^3) - real(kind=kind_phys),parameter:: rhoice = 0.917e3_kind_phys !< density of ice on lake (kg/m^3) + real(kind=kind_phys),parameter:: rholakeice = 0.917e3_kind_phys !< density of ice on lake (kg/m^3) ! Decorrelation length constant (km) for iovr = 4 or 5 and idcor = 0 real(kind=kind_phys),parameter:: decorr_con = 2.50_kind_phys diff --git a/physics/sfc_diag.f b/physics/sfc_diag.f index 2d69a7ecb..045ad75b0 100644 --- a/physics/sfc_diag.f +++ b/physics/sfc_diag.f @@ -2,7 +2,6 @@ !! This file contains the land surface diagnose calculation scheme. module sfc_diag - contains !> \defgroup sfc_diag_mod GFS sfc_diag module @@ -14,8 +13,6 @@ module sfc_diag subroutine sfc_diag_run & & (im,grav,cp,eps,epsm1,ps,u1,v1,t1,q1,prslki, & & evap,fm,fh,fm10,fh2,tskin,qsurf,thsfc_loc, & - & use_lake_model,iopt_lake,iopt_lake_clm, & - & lake_t2m,lake_q2m,kdt,me, & & f10m,u10m,v10m,t2m,q2m,errmsg,errflg & & ) ! @@ -23,7 +20,7 @@ subroutine sfc_diag_run & use funcphys, only : fpvs implicit none ! - integer, intent(in) :: im, iopt_lake, iopt_lake_clm, kdt, me + integer, intent(in) :: im logical, intent(in) :: thsfc_loc ! Flag for reference pot. temp. real(kind=kind_phys), intent(in) :: grav,cp,eps,epsm1 real(kind=kind_phys), dimension(:), intent(in) :: & @@ -31,19 +28,15 @@ subroutine sfc_diag_run & & qsurf, prslki, evap, fm, fh, fm10, fh2 real(kind=kind_phys), dimension(:), intent(out) :: & & f10m, u10m, v10m, t2m, q2m - real(kind=kind_phys), dimension(:), intent(in) :: lake_t2m, & - & lake_q2m - integer, dimension(:), intent(in) :: use_lake_model character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg ! ! locals ! real(kind=kind_phys), parameter :: qmin=1.0e-8 - integer :: k,i, clm_t2m_count + integer :: k,i ! real(kind=kind_phys) :: fhi, qss, wrk - ! real(kind=kind_phys) sig2k, fhi, qss ! ! real, parameter :: g=grav @@ -60,39 +53,34 @@ subroutine sfc_diag_run & ! ps is in pascals ! !! - clm_t2m_count=0 do i = 1, im f10m(i) = fm10(i) / fm(i) ! f10m(i) = min(f10m(i),1.) u10m(i) = f10m(i) * u1(i) v10m(i) = f10m(i) * v1(i) - ! use_clm_2m: if(use_lake_model(i)>0 .and. iopt_lake==iopt_lake_clm) then - ! t2m(i) = lake_t2m(i) - ! q2m(i) = lake_q2m(i) - ! clm_t2m_count=clm_t2m_count+1 - ! else - fhi = fh2(i) / fh(i) -! t2m(i) = tskin(i)*(1. - fhi) + t1(i) * prslki(i) * fhi -! sig2k = 1. - (grav+grav) / (cp * t2m(i)) -! t2m(i) = t2m(i) * sig2k - wrk = 1.0 - fhi - if(thsfc_loc) then ! Use local potential temperature - t2m(i)= tskin(i)*wrk + t1(i)*prslki(i)*fhi - (grav+grav)/cp - else ! Use potential temperature referenced to 1000 hPa - t2m(i)= tskin(i)*wrk + t1(i)*fhi - (grav+grav)/cp - endif + fhi = fh2(i) / fh(i) +! t2m(i) = tskin(i)*(1. - fhi) + t1(i) * prslki(i) * fhi +! sig2k = 1. - (grav+grav) / (cp * t2m(i)) +! t2m(i) = t2m(i) * sig2k + wrk = 1.0 - fhi + + + if(thsfc_loc) then ! Use local potential temperature + t2m(i) = tskin(i)*wrk + t1(i)*prslki(i)*fhi - (grav+grav)/cp + else ! Use potential temperature referenced to 1000 hPa + t2m(i) = tskin(i)*wrk + t1(i)*fhi - (grav+grav)/cp + endif - if(evap(i) >= 0.) then ! for evaporation>0, use inferred qsurf to deduce q2m - q2m(i) = qsurf(i)*wrk + max(qmin,q1(i))*fhi - else ! for dew formation, use saturated q at tskin - qss = fpvs(tskin(i)) - qss = eps * qss / (ps(i) + epsm1 * qss) - q2m(i) = qss*wrk + max(qmin,q1(i))*fhi - endif - qss = fpvs(t2m(i)) - qss = eps * qss / (ps(i) + epsm1 * qss) - q2m(i) = min(q2m(i),qss) - ! endif use_clm_2m + if(evap(i) >= 0.) then ! for evaporation>0, use inferred qsurf to deduce q2m + q2m(i) = qsurf(i)*wrk + max(qmin,q1(i))*fhi + else ! for dew formation, use saturated q at tskin + qss = fpvs(tskin(i)) + qss = eps * qss / (ps(i) + epsm1 * qss) + q2m(i) = qss*wrk + max(qmin,q1(i))*fhi + endif + qss = fpvs(t2m(i)) + qss = eps * qss / (ps(i) + epsm1 * qss) + q2m(i) = min(q2m(i),qss) enddo return diff --git a/physics/sfc_diag.meta b/physics/sfc_diag.meta index 00f725cb8..dd3bf79b8 100644 --- a/physics/sfc_diag.meta +++ b/physics/sfc_diag.meta @@ -157,57 +157,6 @@ dimensions = () type = logical intent = in -[use_lake_model] - standard_name = flag_for_using_lake_model - long_name = flag indicating lake points using a lake model - units = flag - dimensions = (horizontal_loop_extent) - type = integer - intent = in -[iopt_lake] - standard_name = control_for_lake_model_selection - long_name = control for lake model selection - units = 1 - dimensions = () - type = integer - intent = in -[iopt_lake_clm] - standard_name = clm_lake_model_control_selection_value - long_name = value that indicates clm lake model in the control for lake model selection - units = 1 - dimensions = () - type = integer - intent = in -[lake_t2m] - standard_name = temperature_at_2m_from_clm_lake - long_name = temperature at 2m from clm lake - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[lake_q2m] - standard_name = specific_humidity_at_2m_from_clm_lake - long_name = specific humidity at 2m from clm lake - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[kdt] - standard_name = index_of_timestep - long_name = current forecast iteration - units = index - dimensions = () - type = integer - intent = in -[me] - standard_name = mpi_rank - long_name = current MPI-rank - units = index - dimensions = () - type = integer - intent = in [f10m] standard_name = ratio_of_wind_at_surface_adjacent_layer_to_wind_at_10m long_name = ratio of fm10 and fm From 405fc8518a54b4527c0bda30c4efc6c5c9c3a20c Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Mon, 28 Nov 2022 19:23:53 +0000 Subject: [PATCH 065/380] remove flake changes --- physics/GFS_phys_time_vary.fv3.F90 | 2 +- physics/flake.F90 | 83 ++------ physics/flake_driver.F90 | 314 ++++++++++------------------- physics/flake_driver.meta | 272 ++----------------------- 4 files changed, 154 insertions(+), 517 deletions(-) diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index f55416738..6a10a837f 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -677,7 +677,7 @@ subroutine GFS_phys_time_vary_init ( endif lsm_init !Lake model - if((lkm==1 .or. lkm==2) .and. (iopt_lake==iopt_lake_flake .or. iopt_lake==iopt_lake_clm)) then + if(lkm>0 .and. iopt_lake>0) then ! A lake model is enabled. do i = 1, im !if (lakefrac(i) > 0.0 .and. lakedepth(i) > 1.0 ) then diff --git a/physics/flake.F90 b/physics/flake.F90 index 1117afa16..557e22949 100644 --- a/physics/flake.F90 +++ b/physics/flake.F90 @@ -87,8 +87,7 @@ MODULE flake_albedo_ref albedo_water_ref = 0.07 , & ! Water albedo_whiteice_ref = 0.60 , & ! White ice albedo_blueice_ref = 0.10 , & ! Blue ice -! albedo_drysnow_ref = 0.60 , & ! Dry snow - albedo_drysnow_ref = 0.90 , & ! Dry snow + albedo_drysnow_ref = 0.60 , & ! Dry snow albedo_meltingsnow_ref = 0.10 ! Melting snow ! Empirical parameters. @@ -1531,11 +1530,7 @@ SUBROUTINE flake_main ( depthw, depthbs, T_bs, par_Coriolis, & flk_str_1 = flk_str_1 - CTT/CT*( (Q_bot_flk+I_bot_flk-I_HH_flk)/tpl_rho_w_r/tpl_c_w - & depth_bs * ( 1.0 - CT ) * (T_bot_n_flk-T_bot_p_flk)/del_time ) flk_str_2 = CTT * (T_bot_p_flk-T_bot_2_in) - if(abs(flk_str_2)<0.01) then - d_h_D_dt = 0.0 - else - d_h_D_dt = flk_str_1/flk_str_2 - endif + d_h_D_dt = flk_str_1/flk_str_2 ! compute d_T_H_dt flk_str_1 = (Q_bot_flk+I_bot_flk-I_HH_flk)/tpl_rho_w_r/tpl_c_w @@ -1860,8 +1855,7 @@ MODULE SfcFlx ! similarity relations and in the expressions for the roughness lengths. REAL (KIND = kind_phys), PARAMETER :: & c_Karman = 0.40 , & ! The von Karman constant -! Pr_neutral = 1.0 , & ! Turbulent Prandtl number at neutral static stability - Pr_neutral = 0.9 , & ! Turbulent Prandtl number at neutral static stability + Pr_neutral = 1.0 , & ! Turbulent Prandtl number at neutral static stability Sc_neutral = 1.0 , & ! Turbulent Schmidt number at neutral static stability c_MO_u_stab = 5.0 , & ! Constant of the MO theory (wind, stable stratification) c_MO_t_stab = 5.0 , & ! Constant of the MO theory (temperature, stable stratification) @@ -2472,37 +2466,18 @@ SUBROUTINE SfcFlx_momsenlat ( height_u, height_tq, fetch, & ELSE ! Convection psi_u = (1.0-c_MO_t_conv*R_z*ZoL)**c_MO_t_exp psi_t = (1.0-c_MO_t_conv*R_z*ZoL*MIN(z0t_sf/height_tq, 1.0))**c_MO_t_exp -! psi_t = 2.0*LOG((1.0+psi_t)/(1.0+psi_u)) - psi_t = abs(2.0*LOG((1.0+psi_t)/(1.0+psi_u))) + psi_t = 2.0*LOG((1.0+psi_t)/(1.0+psi_u)) psi_u = (1.0-c_MO_q_conv*R_z*ZoL)**c_MO_q_exp psi_q = (1.0-c_MO_q_conv*R_z*ZoL*MIN(z0q_sf/height_tq, 1.0))**c_MO_q_exp -! psi_q = 2.0*LOG((1.0+psi_q)/(1.0+psi_u)) - psi_q = abs(2.0*LOG((1.0+psi_q)/(1.0+psi_u))) -! write(0,*) 'psi_q= ',psi_q + psi_q = 2.0*LOG((1.0+psi_q)/(1.0+psi_u)) !_dbg ! print*(*,*) 'CONV: psi_t = ', psi_t, ' psi_q = ', psi_q !_dbg END IF Q_sen_tur = -(T_a-T_s)*u_star_st*c_Karman/Pr_neutral & / MAX(c_small_sf, LOG(height_tq/z0t_sf)+psi_t) -if(MAX(c_small_sf, LOG(height_tq/z0t_sf)+psi_t) .lt. 10E-6) then - write(0,*)'inside flake' - write(0,*) Q_sen_tur, T_a, T_s, u_star_st, c_Karman, Pr_neutral - write(0,*) c_small_sf,height_tq,z0t_sf,psi_t - write(0,*) 'nominator= ', (T_a-T_s)*u_star_st*c_Karman/Pr_neutral - write(0,*) 'denominator= ',MAX(c_small_sf, LOG(height_tq/z0t_sf)+psi_t) -endif Q_lat_tur = -(q_a-q_s)*u_star_st*c_Karman/Sc_neutral & / MAX(c_small_sf, LOG(height_tq/z0q_sf)+psi_q) -if(Q_lat_tur .gt. 6.0E-4) then - Q_lat_tur = -(q_a-q_s)*u_star_st*c_Karman/3.0 & - / MAX(c_small_sf, LOG(height_tq/z0q_sf)+psi_q) - write(0,*) 'Q_lat_tur= ',Q_lat_tur - write(0,135) q_a,q_s,u_star_st,c_Karman - write(0,136) MAX(c_small_sf,LOG(height_tq/z0q_sf)+psi_q),c_small_sf, LOG(height_tq/z0q_sf),psi_q -endif -135 format(1x,4(f16.4)) -136 format(1x,4(f16.4)) END IF Turb_Fluxes @@ -2547,19 +2522,13 @@ SUBROUTINE SfcFlx_momsenlat ( height_u, height_tq, fetch, & Q_momentum = Q_momentum*rho_a !Q_sensible = Q_sensible*rho_a*tpsf_c_a_p -!write(0,*) 'Q_sensible= ',Q_sensible Q_watvap = Q_latent*rho_a -!Q_latent = tpsf_L_evap +Q_latent = tpsf_L_evap IF(h_ice.GE.h_Ice_min_flk) Q_latent = Q_latent + tpl_L_f ! Add latent heat of fusion over ice -!Q_latent = Q_watvap*Q_latent -Q_latent = Q_watvap*tpsf_L_evap -if(Q_latent .gt. 2000.00) then - write(0,145) 'final Q_watvap= ',Q_watvap, 'tpsf_L_evap= ',tpsf_L_evap, 'Q_latent= ', Q_latent -endif -!Q_latent = Q_watvap*Q_latent -145 format(A17,E12.5,1x,A13,1x,f10.2,1x,A10,1x,E12.4) +Q_latent = Q_watvap*Q_latent + ! Set "*_sf" variables to make fluxes accessible to driving routines that use "SfcFlx" u_star_a_sf = u_star_st Q_mom_a_sf = Q_momentum @@ -2568,7 +2537,7 @@ SUBROUTINE SfcFlx_momsenlat ( height_u, height_tq, fetch, & Q_watvap_a_sf = Q_watvap !write(85,127) Q_sensible, Q_watvap, Q_latent - 127 format(1x, 3(f16.5,1x)) + 127 format(1x, 3(f16.9,1x)) !------------------------------------------------------------------------------ ! End calculations @@ -2962,7 +2931,7 @@ SUBROUTINE flake_interface ( dMsnowdt_in, I_atm_in, Q_atm_lw_in, height_u_in, he T_snow_out, T_ice_out, T_mnw_out, T_wML_out, T_bot_out, & T_B1_out, C_T_out, h_snow_out, h_ice_out, h_ML_out, & - H_B1_out, T_sfc_n, hflx_out, evap_out, gflx_out, lflx_out, & + H_B1_out, T_sfc_n, hflx_out, evap_out, & T_bot_2_in, T_bot_2_out,ustar, q_sfc, chh, cmm ) @@ -3004,11 +2973,11 @@ SUBROUTINE flake_interface ( dMsnowdt_in, I_atm_in, Q_atm_lw_in, height_u_in, he USE flake_derivedtypes ! Definitions of several derived TYPEs -!USE flake_parameters , ONLY : & -! tpl_T_f , & ! Fresh water freezing point [K] -! tpl_rho_w_r , & ! Maximum density of fresh water [kg m^{-3}] -! h_Snow_min_flk , & ! Minimum snow thickness [m] -! h_Ice_min_flk ! Minimum ice thickness [m] +USE flake_parameters , ONLY : & + tpl_T_f , & ! Fresh water freezing point [K] + tpl_rho_w_r , & ! Maximum density of fresh water [kg m^{-3}] + h_Snow_min_flk , & ! Minimum snow thickness [m] + h_Ice_min_flk ! Minimum ice thickness [m] USE flake_paramoptic_ref ! Reference values of the optical characteristics ! of the lake water, lake ice and snow @@ -3134,8 +3103,6 @@ SUBROUTINE flake_interface ( dMsnowdt_in, I_atm_in, Q_atm_lw_in, height_u_in, he T_sfc_n , & ! Updated surface temperature [K] hflx_out , & ! sensibl heat flux evap_out , & ! Latent heat flux - gflx_out , & ! flux from to water - lflx_out , & ! latent heat flux T_bot_2_out , & ! Bottom temperature ustar , & q_sfc , & @@ -3149,21 +3116,16 @@ SUBROUTINE flake_interface ( dMsnowdt_in, I_atm_in, Q_atm_lw_in, height_u_in, he Q_sensible , & ! Sensible heat flux [W m^{-2}] Q_latent , & ! Latent heat flux [W m^{-2}] Q_watvap , & ! Flux of water vapour [kg m^{-2} s^{-1}] - Q_w_flux , & ! flux from ice to water rho_a ! ADDED by Shaobo Zhang LOGICAL lflk_botsed_use !REAL (KIND = kind_phys) :: T_bot_2_in, T_bot_2_out -REAL (KIND = kind_phys), parameter :: tpl_rho_w_r = 1.0E+03 -REAL (KIND = kind_phys), parameter :: tpl_T_f = 273.15 -REAL (KIND = kind_phys), parameter :: h_Snow_min_flk = 1.0E-5 -REAL (KIND = kind_phys), parameter :: h_Ice_min_flk = 1.0E-9 + !============================================================================== ! Start calculations !------------------------------------------------------------------------------ -! lflk_botsed_use = .TRUE. - lflk_botsed_use = .FALSE. + lflk_botsed_use = .TRUE. !------------------------------------------------------------------------------ ! Set albedos of the lake water, lake ice and snow !------------------------------------------------------------------------------ @@ -3177,10 +3139,9 @@ SUBROUTINE flake_interface ( dMsnowdt_in, I_atm_in, Q_atm_lw_in, height_u_in, he ! Snow is not considered !albedo_snow = albedo_ice albedo_ice = albedo_whiteice_ref -!albedo_snow = albedo_ice -albedo_snow = albedo_drysnow_ref +albedo_snow = albedo_ice opticpar_water%extincoef_optic(1) = water_extinc -!write(0,*)'albedo= ',albedo_water,albedo_ice,albedo_snow +!print*,'albedo= ',albedo_water,albedo_ice,albedo_snow !------------------------------------------------------------------------------ ! Set optical characteristics of the lake water, lake ice and snow @@ -3243,8 +3204,7 @@ SUBROUTINE flake_interface ( dMsnowdt_in, I_atm_in, Q_atm_lw_in, height_u_in, he CALL SfcFlx_momsenlat ( height_u_in, height_tq_in, fetch, & U_a_in, T_a_in, q_a_in, T_sfc_p, P_a_in, h_ice_p_flk, & Q_momentum, Q_sensible, Q_latent, Q_watvap, q_sfc, rho_a ) -!write(0,*)'tpl_rho_w_r= ', tpl_rho_w_r -!write(0,*) 'Q_momentum= ',Q_momentum + u_star_w_flk = SQRT(-Q_momentum/tpl_rho_w_r) ustar = u_star_w_flk @@ -3294,9 +3254,6 @@ SUBROUTINE flake_interface ( dMsnowdt_in, I_atm_in, Q_atm_lw_in, height_u_in, he H_B1_out = H_B1_n_flk hflx_out = Q_sensible evap_out = Q_watvap -!evap_out = Q_latent -gflx_out = Q_w_flk -lflx_out = Q_latent chh = ch * U_a_in * rho_a cmm = cm * U_a_in diff --git a/physics/flake_driver.F90 b/physics/flake_driver.F90 index a277783fb..46065939d 100644 --- a/physics/flake_driver.F90 +++ b/physics/flake_driver.F90 @@ -49,17 +49,13 @@ end subroutine flake_driver_finalize !! SUBROUTINE flake_driver_run ( & ! ---- Inputs - im, ps, t1, q1, wind, min_lakeice, & - dlwflx, dswsfc, lakedepth, & - use_lake_model, snow, xlat, delt, zlvl, elev, & - wet, yearlen, julian, imon, & - flag_iter, first_time_step, flag_restart, & - weasd, & + im, ps, t1, q1, wind, & + dlwflx, dswsfc, weasd, lakedepth, & + use_lake_model, xlat, delt, zlvl, elev, & + wet, flag_iter, yearlen, julian, imon, & ! ---- in/outs - snwdph, hice, tsurf, t_sfc, fice, hflx, evap, & - lflx, gflx, ustar, qsfc, ch, cm, chh, cmm, & - h_ML, t_wML, t_mnw, H_B, T_B, t_bot1, & - t_bot2, c_t, T_snow, T_ice, tsurf_ice, & + snwdph, hice, tsurf, fice, T_sfc, hflx, evap, & + ustar, qsfc, ch, cm, chh, cmm, & errmsg, errflg ) !============================================================================== @@ -88,41 +84,37 @@ SUBROUTINE flake_driver_run ( & real (kind=kind_phys), dimension(:), intent(in) :: ps, wind, & & t1, q1, dlwflx, dswsfc, zlvl, elev - real (kind=kind_phys), intent(in) :: delt, min_lakeice + real (kind=kind_phys), intent(in) :: delt real (kind=kind_phys), dimension(:), intent(in) :: & - & xlat, lakedepth, snow + & xlat, weasd, lakedepth - real (kind=kind_phys), dimension(:), intent(in) :: weasd - - real (kind=kind_phys),dimension(:),intent(inout) :: & - & snwdph, hice, tsurf, t_sfc, hflx, evap, fice, ustar, qsfc, & - & ch, cm, chh, cmm, h_ML, t_wML, t_mnw, H_B, T_B, & - & t_bot1, t_bot2, c_t, T_snow, T_ice, tsurf_ice, lflx, gflx + real (kind=kind_phys),dimension(:),intent(inout) :: & + & snwdph, hice, tsurf, t_sfc, hflx, evap, fice, ustar, qsfc, & + & ch, cm, chh, cmm real (kind=kind_phys), intent(in) :: julian logical, dimension(:), intent(in) :: flag_iter, wet integer, dimension(:), intent(in) :: use_lake_model - logical, intent(in) :: flag_restart, first_time_step - character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg ! --- locals - real (kind=kind_phys), parameter :: lake_pct_min = 0.1 + + real (kind=kind_phys) , parameter :: lake_pct_min = 0.1 real (kind=kind_phys), dimension(im) :: & -! T_snow , & ! Temperature at the air-snow interface [K] -! T_ice , & ! Temperature at the snow-ice or air-ice interface [K] -! T_mnw , & ! Mean temperature of the water column [K] -! T_wML , & ! Mixed-layer temperature [K] -! T_bot , & ! Temperature at the water-bottom sediment interface [K] -! T_B , & ! Temperature at the upper layer of the sediments [K] -! C_T , & ! Shape factor (thermocline) + T_snow , & ! Temperature at the air-snow interface [K] + T_ice , & ! Temperature at the snow-ice or air-ice interface [K] + T_mnw , & ! Mean temperature of the water column [K] + T_wML , & ! Mixed-layer temperature [K] + T_bot , & ! Temperature at the water-bottom sediment interface [K] + T_B1 , & ! Temperature at the upper layer of the sediments [K] + C_T , & ! Shape factor (thermocline) fetch , & ! Typical wind fetch [m] -! h_ML , & ! Thickness of the mixed-layer [m] -! H_B1 , & ! Thickness of the upper layer of bottom sediments [m] + h_ML , & ! Thickness of the mixed-layer [m] + H_B1 , & ! Thickness of the upper layer of bottom sediments [m] w_albedo , & ! w_extinc @@ -155,7 +147,7 @@ SUBROUTINE flake_driver_run ( & T_mnw_in , & ! Mean temperature of the water column [K] T_wML_in , & ! Mixed-layer temperature [K] T_bot_in , & ! Temperature at the water-bottom sediment interface [K] - T_B_in , & ! Temperature at the bottom of the upper layer of the sediments [K] + T_B1_in , & ! Temperature at the bottom of the upper layer of the sediments [K] C_T_in , & ! Shape factor (thermocline) h_snow_in , & ! Snow thickness [m] h_ice_in , & ! Ice thickness [m] @@ -173,7 +165,7 @@ SUBROUTINE flake_driver_run ( & T_mnw_out , & ! Mean temperature of the water column [K] T_wML_out , & ! Mixed-layer temperature [K] T_bot_out , & ! Temperature at the water-bottom sediment interface [K] - T_B_out , & ! Temperature at the bottom of the upper layer of the sediments [K] + T_B1_out , & ! Temperature at the bottom of the upper layer of the sediments [K] C_T_out , & ! Shape factor (thermocline) h_snow_out , & ! Snow thickness [m] h_ice_out , & ! Ice thickness [m] @@ -190,19 +182,17 @@ SUBROUTINE flake_driver_run ( & Q_momentum , & ! Momentum flux [N m^{-2}] Q_SHT_flx , & ! Sensible heat flux [W m^{-2}] Q_LHT_flx , & ! Latent heat flux [W m^{-2}] - Q_watvap , & ! Flux of water vapour [kg m^{-2} s^{-1}] - Q_gflx , & ! Flux from ice to water [W m^{-2}] - Q_lflx ! latent fluxes [W m^{-2}] + Q_watvap ! Flux of water vapour [kg m^{-2} s^{-1}] REAL (KIND = kind_phys) :: & - lake_depth_max, T_bot_2_in, T_bot_2_out, dlat,tb,tr,tt,temp,temp2 + lake_depth_max, T_bot_2_in, T_bot_2_out, dxlat,tb,tr,tt,temp,temp2 real (kind=kind_phys), parameter :: pi=4.0_kind_phys*atan(1.0_kind_phys) real (kind=kind_phys), parameter :: degrad=180.0_kind_phys/pi real (kind=kind_phys), parameter :: Kbar = 3.5_kind_phys, DelK = 3.0_kind_phys, & KbaroDelK = Kbar / DelK - REAL (KIND = kind_phys) :: x, y, w !temperarory variables used for Tbot and Tsfc + REAL (KIND = kind_phys) :: x, y !temperarory variables used for Tbot and Tsfc !initilizations INTEGER :: i,ipr,iter @@ -215,17 +205,15 @@ SUBROUTINE flake_driver_run ( & ! Start calculations !------------------------------------------------------------------------------ ! FLake_write need to assign original value to make the model somooth - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 ! --- ... set flag for lake points do_flake = .false. do i = 1, im - flag(i) = flag_iter(i) .and. use_lake_model(i) .gt. 0 - do_flake = flag(i) .or. do_flake + flag(i) = wet(i) .and. flag_iter(i) .and. use_lake_model(i)>0 + do_flake = flag(i) .or. do_flake enddo + if (.not. do_flake) return lake_depth_max = 60.0 @@ -242,61 +230,61 @@ SUBROUTINE flake_driver_run ( & temp2 = sin((pi+pi)*(julian-151)/244) do i = 1, im - if (flag(i) .and. lakedepth(i) >1.0) then - if(.not.flag_restart .and. first_time_step) then - T_ice(i) = 273.15 - T_snow(i) = 273.15 - C_T(i) = 0.50 - dlat = abs(xlat(i)) - if(dlat .lt. 1.40) then - tt = (((21.181*dlat-51.376)*dlat+20.808)*dlat-3.8408)*dlat+29.554 - tt = tt -0.0038*elev(i)+273.15 - tb = (((-29.794*dlat+96.91)*dlat-86.129)*dlat-7.1921)*dlat+28.176 - tb = tb -0.0038*elev(i)+273.15 - w = (((2.5467*dlat-7.4683)*dlat+5.2465)*dlat+0.4360)*dlat+0.0643 - else - tt = 4.0+273.15-0.0038*elev(i) - tb = 0.05+273.15-0.0038*elev(i) - w = 0.207312 - endif - if(tsurf(i) > 400.00) then - write(0,*) tsurf(i) - write(0,*) 'Surface temperature initial is bad' - tsurf(i) = tt - write(0,*) tsurf(i) - endif - T_sfc(i) = 0.05*tt + 0.95* tsurf(i) - + if (flag(i)) then + T_ice(i) = 273.15 + T_snow(i) = 273.15 + fetch(i) = 2.0E+03 + C_T(i) = 0.50 + + dxlat = degrad*abs(xlat(i)) + tt = 29.275+(0.0813-0.0052*dxlat)*dxlat-0.0038*elev(i)+273.15 + tb = 29.075-(0.7566-0.0051*dxlat)*dxlat-0.0038*elev(i)+273.15 +! if (fice(i).le.0.0) then +! h_ice(i) = 0.0 +! h_snow(i)= 0.0 +! endif + if (snwdph(i) > 0.0 .or. hice(i) > 0.0) then + if (tsurf(i) < T_ice(i)) then + T_sfc(i) = T_ice(i) + else + T_sfc(i) = tsurf(i) + endif + else +! if (tsurf(i) < tt) then +! T_sfc(i) = tt +! else +! T_sfc(i) = tsurf(i) +! endif + T_sfc(i) = 0.1*tt + 0.9* tsurf(i) + endif +! ! Add empirical climatology of lake Tsfc and Tbot to the current Tsfc and Tbot ! to make sure Tsfc and Tbot are warmer than Tair in Winter or colder than Tair ! in Summer - if (xlat(i) >= 0.0) then - T_sfc(i) = T_sfc(i) + 0.05*y*w - tb = tb + 0.005*y*w - else - T_sfc(i) = T_sfc(i) - 0.5*y*w - tb = tb - 0.005*y*w - endif - - t_bot1(i) = tb - t_bot2(i) = tb - T_B(i) = tb - - T_mnw(i) = C_T(i)*T_sfc(i) + (1-C_T(i))*t_bot1(i) - T_wML(i) = C_T(i)*T_sfc(i) + (1-C_T(i))*t_bot1(i) - h_ML(i) = C_T(i)* min ( lakedepth(i), lake_depth_max ) - H_B(i) = min ( lakedepth(i),4.0) - hflx(i) = 0.0 - lflx(i) = 0.0 - evap(i) = 0.0 - chh = ch(i) * wind(i) * 1.225 !(kg/m3) - cmm = cm(i) * wind(i) - endif !end of .not.flag_restart + if (xlat(i) >= 0.0) then + T_sfc(i) = T_sfc(i) + 0.3*y + tb = tb + 0.05*y + else + T_sfc(i) = T_sfc(i) - 0.3*y + tb = tb - 0.05*y + endif + T_bot(i) = tb + T_B1(i) = tb + +! if (lakedepth(i) < 10.0) then +! T_bot(i) = T_sfc(i) +! T_B1(i) = T_bot(i) +! endif + + T_mnw(i) = C_T(i)*T_sfc(i) + (1-C_T(i))*T_bot(i) + T_wML(i) = C_T(i)*T_sfc(i) + (1-C_T(i))*T_bot(i) + h_ML(i) = C_T(i)* min ( lakedepth(i), lake_depth_max ) + H_B1(i) = min ( lakedepth(i),4.0) + hflx(i) = 0.0 + evap(i) = 0.0 - fetch(i) = 2.0E+03 ! compute albedo as a function of julian day and latitude -! write(0,*) ' xlat= ',xlat(i), temp w_albedo(I) = 0.06/cos((xlat(i)-temp)/1.2) ! w_albedo(I) = 0.06 ! compute water extinction coefficient as a function of julian day @@ -307,26 +295,24 @@ SUBROUTINE flake_driver_run ( & endif ! w_extinc(i) = 3.0 -! write(0,1002) julian,xlat(i),w_albedo(I),w_extinc(i),elev(i),tsurf(i),T_sfc(i),t_bot1(i) -! write(0,1003) use_lake_model(i),i,lakedepth(i), snwdph(i), hice(i), fice(i) -! write(0,1004) ps(i), wind(i), t1(i), q1(i), dlwflx(i), dswsfc(i), zlvl(i) +! write(65,1002) julian,xlat(i),w_albedo(I),w_extinc(i),lakedepth(i),elev(i),tb,tt,tsurf(i),T_sfc(i) +! print 1002 julian,xlat(i),w_albedo(I),w_extinc(i),lakedepth(i),elev(i),tb,tt,tsurf(i),T_sfc(i) +! print*,'inside flake driver' +! print*, julian,xlat(i),w_albedo(I),w_extinc(i),lakedepth(i),elev(i),tb,tt,tsurf(i),T_sfc(i) endif !flag enddo - 1002 format ( 'julian=',F6.2,1x,F8.3,1x,2(E7.2,1x),E7.2,1x,3(E7.2,1x)) - 1003 format ( 'use_lake_model=',I2,1x,I3,1x,F6.4,1x,F9.4,1x,2(F8.4,1x),F7.4) - 1004 format ( 'pressure',F12.2,1x,F6.2,1x,F7.2,1x,F7.4,1x,2(F8.2,1x),F8.4) + 1001 format ( 'At icount=', i5, ' x = ', f5.2,5x, 'y = ', & + 1p, e12.3) +! 1002 format ( ' julian= ',F6.2,1x,5(F8.4,1x),3(f11.4,1x)) + 1002 format (I4,1x,3(f8.4,1x),6(f11.4,1x)) + + ! ! call lake interface do i=1,im - if (flag(i) .and. lakedepth(i) > 1.0) then -! write(0,*) 'flag(i)= ', i, flag(i) -! if(weasd(i) < 0.0 .or. hice(i) < 0.0) weasd(i) =0.0 - if(snwdph(i) < 0.0) snwdph(i) =0.0 -! dMsnowdt_in = 10.0*0.001*weasd(i)/delt -! dMsnowdt_in = snow(i)/delt - dMsnowdt_in = snow(i)*0.001 - if(dMsnowdt_in < 0.0) dMsnowdt_in=0.0 + if (flag(i)) then + dMsnowdt_in = weasd(i)/delt I_atm_in = dswsfc(i) Q_atm_lw_in = dlwflx(i) height_u_in = zlvl(i) @@ -343,36 +329,27 @@ SUBROUTINE flake_driver_run ( & depth_w = min ( lakedepth(i), lake_depth_max ) depth_bs_in = max ( 4.0, min ( depth_w * 0.2, 10.0 ) ) fetch_in = fetch(i) - T_bs_in = T_bot1(i) + T_bs_in = T_bot(i) par_Coriolis = 2 * 7.2921 / 100000. * sin ( xlat(i) ) del_time = delt -! if(lakedepth(i).lt.10) then -! T_sfc(i) = t1(i) -! T_bs_in = T_sfc(i) -! T_B(i) = T_bs_in -! endif - - do iter=1,5 !interation loop + do iter=1,10 !interation loop T_snow_in = T_snow(i) T_ice_in = T_ice(i) T_mnw_in = T_mnw(i) T_wML_in = T_wML(i) - T_bot_in = t_bot1(i) - T_B_in = T_B(i) + T_bot_in = T_bot(i) + T_B1_in = T_B1(i) C_T_in = C_T(i) h_snow_in = snwdph(i) h_ice_in = hice(i) h_ML_in = h_ML(i) - H_B1_in = H_B(i) + H_B1_in = H_B1(i) T_sfc_in = T_sfc(i) - tsurf_ice(i)= T_ice(i) - T_bot_2_in = t_bot2(i) + T_bot_2_in = T_bot(i) Q_SHT_flx = hflx(i) Q_watvap = evap(i) - Q_gflx = 0.0 - Q_lflx = 0.0 !------------------------------------------------------------------------------ ! Set the rate of snow accumulation @@ -382,13 +359,13 @@ SUBROUTINE flake_driver_run ( & height_tq_in, U_a_in, T_a_in, q_a_in, P_a_in, & depth_w, fetch_in, depth_bs_in, T_bs_in, par_Coriolis, del_time, & - T_snow_in, T_ice_in, T_mnw_in, T_wML_in, T_bot_in, T_B_in, & + T_snow_in, T_ice_in, T_mnw_in, T_wML_in, T_bot_in, T_B1_in, & C_T_in, h_snow_in, h_ice_in, h_ML_in, H_B1_in, T_sfc_in, & ch_in, cm_in, albedo_water, water_extinc, & ! T_snow_out, T_ice_out, T_mnw_out, T_wML_out, T_bot_out, & - T_B_out, C_T_out, h_snow_out, h_ice_out, h_ML_out, & - H_B1_out, T_sfc_out, Q_SHT_flx, Q_watvap, Q_gflx, Q_lflx, & + T_B1_out, C_T_out, h_snow_out, h_ice_out, h_ML_out, & + H_B1_out, T_sfc_out, Q_SHT_flx, Q_watvap, & ! T_bot_2_in, T_bot_2_out,u_star, q_sfc,chh_out,cmm_out ) @@ -401,13 +378,11 @@ SUBROUTINE flake_driver_run ( & T_wML(i) = T_wML_out T_sfc(i) = T_sfc_out Tsurf(i) = T_sfc_out - tsurf_ice(i) = T_ice(i) - t_bot1(i) = T_bot_out - t_bot2(i) = T_bot_2_out - T_B(i) = T_B_out + T_bot(i) = T_bot_out + T_B1(i) = T_B1_out C_T(i) = C_T_out h_ML(i) = h_ML_out - H_B(i) = H_B1_out + H_B1(i) = H_B1_out ustar(i) = u_star qsfc(i) = q_sfc chh(i) = chh_out @@ -416,91 +391,26 @@ SUBROUTINE flake_driver_run ( & hice(i) = h_ice_out evap(i) = Q_watvap hflx(i) = Q_SHT_flx - gflx(i) = Q_gflx - lflx(i) = Q_lflx -! if(lflx(i) > 2500.00 .or. Tsurf(i) > 350.00) then -! write(0,125) i,lflx(i), Tsurf(i),ps(i), wind(i), & -! & t1(i), q1(i), dlwflx(i), dswsfc(i),hflx(i) -! endif -! fice(i) = fice(i)+0.01*(h_ice_out-h_ice_in) -! if(fice(i) .lt. min_lakeice ) then -! fice(i) = 0.0 -! elseif(fice(i) .gt. 1.0) then -! fice(i) = 1.0 -! endif + + if (hice(i) > 0.0 .or. snwdph(i) > 0.0) then + fice(i) = 1.0 + else + fice(i) = 0.0 + endif enddo !iter loop -! endif !endif use_lake_model endif !endif of flag enddo -125 format(1x,i3,1x,9(1x,f10.3)) +!125 format(1x,i2,1x,i2,1x,i2,1x,6(1x,f14.8)) !126 format(1x,i2,1x,i2,1x,6(1x,f14.8)) !127 format(1x,i2,2(1x,f16.9)) !------------------------------------------------------------------------------ ! End calculations !============================================================================== - END SUBROUTINE flake_driver_run - -end module flake_driver - -module flake_driver_post - use machine, only: kind_phys - implicit none - private - public flake_driver_post_init, flake_driver_post_finalize, flake_driver_post_run - -contains - subroutine flake_driver_post_init() - end subroutine flake_driver_post_init - - subroutine flake_driver_post_finalize() - end subroutine flake_driver_post_finalize - -!> \section arg_table_flake_driver_post Argument Table -!! \htmlinclude flake_driver_post.html -!! -subroutine flake_driver_post_run (im, use_lake_model, h_ML, T_wML, & - Tsurf, lakedepth, xz, zm, tref, tsfco, & - errmsg, errflg) - -!use machine , only : kind_phys -!============================================================================== - - implicit none - integer, intent(in) :: im -! integer, dimension(im), intent(in) :: islmsk - - real (kind=kind_phys), dimension(:), intent(in) :: & - & lakedepth, tsurf, h_ML, t_wML - - real (kind=kind_phys),dimension(:),intent(inout) :: & - & xz, zm, tref, tsfco - - integer, dimension(:), intent(in) :: use_lake_model - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - integer :: i - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - do I=1, im - if(use_lake_model(i).eq.2) then - write(0,*)'flake-post-use-lake-model= ',use_lake_model(i) - xz(i) = lakedepth(i) - zm(i) = h_ML(i) - tref(i) = tsurf(i) - tsfco(i) = t_wML(i) - endif - enddo - - -end subroutine flake_driver_post_run +END SUBROUTINE flake_driver_run !--------------------------------- -end module flake_driver_post + end module flake_driver diff --git a/physics/flake_driver.meta b/physics/flake_driver.meta index 94335a62d..c0fa96320 100644 --- a/physics/flake_driver.meta +++ b/physics/flake_driver.meta @@ -86,17 +86,9 @@ type = real kind = kind_phys intent = in -[min_lakeice] - standard_name = min_lake_ice_area_fraction - long_name = minimum lake ice value - units = frac - dimensions = () - type = real - kind = kind_phys - intent = in [dlwflx] - standard_name = surface_downwelling_longwave_flux - long_name = surface downwelling longwave flux at current time + standard_name = surface_downwelling_longwave_flux_absorbed_by_ground_over_water + long_name = total sky surface downward longwave flux absorbed by the ground over water units = W m-2 dimensions = (horizontal_loop_extent) type = real @@ -110,6 +102,14 @@ type = real kind = kind_phys intent = in +[weasd] + standard_name = water_equivalent_accumulated_snow_depth_over_ice + long_name = water equiv of acc snow depth over ice + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [lakedepth] standard_name = lake_depth long_name = lake depth @@ -125,14 +125,6 @@ dimensions = (horizontal_loop_extent) type = integer intent = in -[snow] - standard_name = lwe_thickness_of_snow_amount_on_dynamics_timestep - long_name = snow fall at this time step - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in [xlat] standard_name = latitude long_name = latitude @@ -172,6 +164,13 @@ dimensions = (horizontal_loop_extent) type = logical intent = in +[flag_iter] + standard_name = flag_for_iteration + long_name = flag for iteration + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in [yearlen] standard_name = number_of_days_in_current_year long_name = number of days in a year @@ -194,35 +193,6 @@ dimensions = () type = integer intent = in -[flag_iter] - standard_name = flag_for_iteration - long_name = flag for iteration - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in -[first_time_step] - standard_name = flag_for_first_timestep - long_name = flag for first time step for time integration loop (cold/warmstart) - units = flag - dimensions = () - type = logical - intent = in -[flag_restart] - standard_name = flag_for_restart - long_name = flag for restart (warmstart) or coldstart - units = flag - dimensions = () - type = logical - intent = in -[weasd] - standard_name = water_equivalent_accumulated_snow_depth_over_ice - long_name = water equiv of acc snow depth over ice - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout [snwdph] standard_name = surface_snow_thickness_water_equivalent_over_ice long_name = water equivalent snow depth over ice @@ -240,8 +210,8 @@ kind = kind_phys intent = inout [tsurf] - standard_name = surface_skin_temperature_over_water - long_name = surface skin temperature over water + standard_name = surface_skin_temperature_after_iteration_over_water + long_name = surface skin temperature after iteration over water units = K dimensions = (horizontal_loop_extent) type = real @@ -256,8 +226,8 @@ kind = kind_phys intent = inout [t_sfc] - standard_name = surface_skin_temperature_after_iteration_over_water - long_name = surface skin temperature after iteration over water + standard_name = surface_skin_temperature_over_water + long_name = surface skin temperature over water units = K dimensions = (horizontal_loop_extent) type = real @@ -279,22 +249,6 @@ type = real kind = kind_phys intent = inout -[lflx] - standard_name = surface_upward_potential_latent_heat_flux_over_water - long_name = surface upward potential latent heat flux over water - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[gflx] - standard_name = upward_heat_flux_in_soil_over_water - long_name = soil heat flux over water - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout [ustar] standard_name = surface_friction_velocity_over_water long_name = surface friction velocity over water @@ -343,190 +297,6 @@ type = real kind = kind_phys intent = inout -[h_ML] - standard_name = mixed_layer_depth_of_lakes - long_name = depth of lake mixing layer - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[t_wML] - standard_name = lake_mixed_layer_temperature - long_name = temperature of lake mixing layer - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[t_mnw] - standard_name = mean_temperature_of_the_water_column - long_name = thee mean temperature of the water column - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[H_B] - standard_name = the_thermally_active_layer_depth_of_the_bottom_sediment - long_name = the depth of the thermally active layer of the bottom sediment - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[T_B] - standard_name = temperature_at_the_bottom_of_the_sediment_upper_layer - long_name = the temperature at the bottom of the sediment upper layer - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[t_bot1] - standard_name = lake_bottom_temperature - long_name = the temperature at the water-bottom sediment interface - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[t_bot2] - standard_name = temperature_for_bottom_layer_of_water - long_name = the temperature at the lake bottom layer water - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[c_t] - standard_name = shape_factor_of_water_temperature_vertical_profile - long_name = the shape factor of water temperature vertical profile - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[T_snow] - standard_name = temperature_of_snow_on_lake - long_name = the temperature of snow on a lake - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[T_ice] - standard_name = surface_skin_temperature_over_ice - long_name = surface skin temperature over ice - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[tsurf_ice] - standard_name = surface_skin_temperature_after_iteration_over_ice - long_name = surface skin temperature after iteration over ice - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - -######################################################################## -[ccpp-table-properties] - name = flake_driver_post - type = scheme - dependencies = machine.F -######################################################################## -[ccpp-arg-table] - name = flake_driver_post_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[lakedepth] - standard_name = lake_depth - long_name = lake depth - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[tsurf] - standard_name = surface_skin_temperature_after_iteration_over_water - long_name = surface skin temperature after iteration over water - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[h_ML] - standard_name = mixed_layer_depth_of_lakes - long_name = depth of lake mixing layer - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[t_wML] - standard_name = lake_mixed_layer_temperature - long_name = temperature of lake mixing layer - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[xz] - standard_name = diurnal_thermocline_layer_thickness - long_name = diurnal thermocline layer thickness - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[zm] - standard_name = ocean_mixed_layer_thickness - long_name = mixed layer thickness - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[tref] - standard_name = reference_sea_surface_temperature - long_name = reference/foundation temperature - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[tfco] - standard_name = sea_surface_temperature - long_name = sea surface temperature - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From c4980ce8c17a66d76fdaac3404458091ec5a9116 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Tue, 29 Nov 2022 22:32:25 +0000 Subject: [PATCH 066/380] put some changes back in --- physics/GFS_surface_composites_post.F90 | 65 +++++++++++++++++++------ physics/sfc_diag.f | 14 +++++- physics/sfc_diag.meta | 44 +++++++++++++++++ 3 files changed, 108 insertions(+), 15 deletions(-) diff --git a/physics/GFS_surface_composites_post.F90 b/physics/GFS_surface_composites_post.F90 index 868db390f..c63b623d4 100644 --- a/physics/GFS_surface_composites_post.F90 +++ b/physics/GFS_surface_composites_post.F90 @@ -269,8 +269,37 @@ subroutine GFS_surface_composites_post_run ( else ! not fractional grid do i=1,im - if (islmsk(i) == 1) then + + if(frac_ice .and. use_lake_model(i)>0 .and. iopt_lake==iopt_lake_clm) then + if(dry(i)) then + call composite_land + else if(icy(i)) then + call composite_icy(.true.) + call composite_wet_and_icy + else + call composite_wet + endif + else if (islmsk(i) == 1) then !-- land + call composite_land + elseif (islmsk(i) == 0) then + !-- water + call composite_wet + else ! islmsk(i) == 2 + !-- ice + call composite_icy(use_lake_model(i)>0 .and. iopt_lake==iopt_lake_clm) + call composite_wet_and_icy + endif + enddo + + endif fractional_grid + + ! --- compositing done + + contains + + subroutine composite_land + implicit none zorl(i) = zorll(i) cd(i) = cd_lnd(i) cdq(i) = cdq_lnd(i) @@ -295,8 +324,10 @@ subroutine GFS_surface_composites_post_run ( qss(i) = qss_lnd(i) hice(i) = zero cice(i) = zero - elseif (islmsk(i) == 0) then - !-- water + end subroutine composite_land + + subroutine composite_wet + implicit none zorl(i) = zorlo(i) cd(i) = cd_wat(i) cdq(i) = cdq_wat(i) @@ -322,8 +353,11 @@ subroutine GFS_surface_composites_post_run ( qss(i) = qss_wat(i) hice(i) = zero cice(i) = zero - else ! islmsk(i) == 2 - !-- ice + end subroutine composite_wet + + subroutine composite_icy(is_clm) + implicit none + logical, intent(in) :: is_clm zorl(i) = zorli(i) cd(i) = cd_ice(i) cdq(i) = cdq_ice(i) @@ -338,12 +372,20 @@ subroutine GFS_surface_composites_post_run ( chh(i) = chh_ice(i) gflx(i) = gflx_ice(i) ep1d(i) = ep1d_ice(i) - weasd(i) = weasd_ice(i) * cice(i) - snowd(i) = snowd_ice(i) * cice(i) + if(is_clm) then + weasd(i) = weasd_ice(i) + snowd(i) = snowd_ice(i) + else + weasd(i) = weasd_ice(i) * cice(i) + snowd(i) = snowd_ice(i) * cice(i) + endif qss(i) = qss_ice(i) evap(i) = evap_ice(i) hflx(i) = hflx_ice(i) -! + end subroutine composite_icy + + subroutine composite_wet_and_icy + implicit none txi = cice(i) txo = one - txi evap(i) = txi * evap_ice(i) + txo * evap_wat(i) @@ -372,12 +414,7 @@ subroutine GFS_surface_composites_post_run ( do k=1,min(kice,km) ! store tiice in stc to reduce output in the nonfrac grid case stc(i,k) = tiice(i,k) enddo - endif - enddo - - endif fractional_grid - - ! --- compositing done + end subroutine composite_wet_and_icy end subroutine GFS_surface_composites_post_run diff --git a/physics/sfc_diag.f b/physics/sfc_diag.f index 045ad75b0..fae405048 100644 --- a/physics/sfc_diag.f +++ b/physics/sfc_diag.f @@ -13,6 +13,8 @@ module sfc_diag subroutine sfc_diag_run & & (im,grav,cp,eps,epsm1,ps,u1,v1,t1,q1,prslki, & & evap,fm,fh,fm10,fh2,tskin,qsurf,thsfc_loc, & + & use_lake_model,iopt_lake,iopt_lake_clm, & + & lake_t2m,lake_q2m,use_lake2m, & & f10m,u10m,v10m,t2m,q2m,errmsg,errflg & & ) ! @@ -20,14 +22,18 @@ subroutine sfc_diag_run & use funcphys, only : fpvs implicit none ! - integer, intent(in) :: im + integer, intent(in) :: im, iopt_lake, iopt_lake_clm logical, intent(in) :: thsfc_loc ! Flag for reference pot. temp. + logical, intent(in) :: use_lake2m real(kind=kind_phys), intent(in) :: grav,cp,eps,epsm1 real(kind=kind_phys), dimension(:), intent(in) :: & & ps, u1, v1, t1, q1, tskin, & & qsurf, prslki, evap, fm, fh, fm10, fh2 real(kind=kind_phys), dimension(:), intent(out) :: & & f10m, u10m, v10m, t2m, q2m + real(kind=kind_phys), dimension(:), intent(in) :: lake_t2m, & + & lake_q2m + integer, dimension(:), intent(in) :: use_lake_model character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg ! @@ -58,6 +64,11 @@ subroutine sfc_diag_run & ! f10m(i) = min(f10m(i),1.) u10m(i) = f10m(i) * u1(i) v10m(i) = f10m(i) * v1(i) + use_clm_2m: if(use_lake_model(i)>0 .and. use_lake2m .and. & + & iopt_lake==iopt_lake_clm) then + t2m(i) = lake_t2m(i) + q2m(i) = lake_q2m(i) + else fhi = fh2(i) / fh(i) ! t2m(i) = tskin(i)*(1. - fhi) + t1(i) * prslki(i) * fhi ! sig2k = 1. - (grav+grav) / (cp * t2m(i)) @@ -81,6 +92,7 @@ subroutine sfc_diag_run & qss = fpvs(t2m(i)) qss = eps * qss / (ps(i) + epsm1 * qss) q2m(i) = min(q2m(i),qss) + endif use_clm_2m enddo return diff --git a/physics/sfc_diag.meta b/physics/sfc_diag.meta index dd3bf79b8..a6f28c865 100644 --- a/physics/sfc_diag.meta +++ b/physics/sfc_diag.meta @@ -157,6 +157,50 @@ dimensions = () type = logical intent = in +[use_lake_model] + standard_name = flag_for_using_lake_model + long_name = flag indicating lake points using a lake model + units = flag + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[iopt_lake] + standard_name = control_for_lake_model_selection + long_name = control for lake model selection + units = 1 + dimensions = () + type = integer + intent = in +[iopt_lake_clm] + standard_name = clm_lake_model_control_selection_value + long_name = value that indicates clm lake model in the control for lake model selection + units = 1 + dimensions = () + type = integer + intent = in +[lake_t2m] + standard_name = temperature_at_2m_from_clm_lake + long_name = temperature at 2m from clm lake + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[lake_q2m] + standard_name = specific_humidity_at_2m_from_clm_lake + long_name = specific humidity at 2m from clm lake + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[use_lake2m] + standard_name = use_2m_diagnostics_calculated_by_lake_model + long_name = model 2m diagnostics use the temperature and humidity calculated by the lake model + units = flag + dimensions = () + type = integer + intent = in [f10m] standard_name = ratio_of_wind_at_surface_adjacent_layer_to_wind_at_10m long_name = ratio of fm10 and fm From e41e718d63dfddff8851e26aefd52648e0f967a2 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Wed, 30 Nov 2022 00:42:29 +0000 Subject: [PATCH 067/380] put flake back in --- physics/GFS_surface_composites_post.F90 | 10 +- physics/flake.F90 | 83 +++++-- physics/flake_driver.F90 | 314 +++++++++++++++--------- physics/flake_driver.meta | 272 ++++++++++++++++++-- 4 files changed, 520 insertions(+), 159 deletions(-) diff --git a/physics/GFS_surface_composites_post.F90 b/physics/GFS_surface_composites_post.F90 index c63b623d4..9683eac83 100644 --- a/physics/GFS_surface_composites_post.F90 +++ b/physics/GFS_surface_composites_post.F90 @@ -270,11 +270,9 @@ subroutine GFS_surface_composites_post_run ( do i=1,im - if(frac_ice .and. use_lake_model(i)>0 .and. iopt_lake==iopt_lake_clm) then - if(dry(i)) then - call composite_land - else if(icy(i)) then - call composite_icy(.true.) + if (use_lake_model(i)>0) then + if(frac_ice .and. icy(i)) then + call composite_icy(iopt_lake==iopt_lake_clm) call composite_wet_and_icy else call composite_wet @@ -287,7 +285,7 @@ subroutine GFS_surface_composites_post_run ( call composite_wet else ! islmsk(i) == 2 !-- ice - call composite_icy(use_lake_model(i)>0 .and. iopt_lake==iopt_lake_clm) + call composite_icy(.false.) call composite_wet_and_icy endif enddo diff --git a/physics/flake.F90 b/physics/flake.F90 index 557e22949..1117afa16 100644 --- a/physics/flake.F90 +++ b/physics/flake.F90 @@ -87,7 +87,8 @@ MODULE flake_albedo_ref albedo_water_ref = 0.07 , & ! Water albedo_whiteice_ref = 0.60 , & ! White ice albedo_blueice_ref = 0.10 , & ! Blue ice - albedo_drysnow_ref = 0.60 , & ! Dry snow +! albedo_drysnow_ref = 0.60 , & ! Dry snow + albedo_drysnow_ref = 0.90 , & ! Dry snow albedo_meltingsnow_ref = 0.10 ! Melting snow ! Empirical parameters. @@ -1530,7 +1531,11 @@ SUBROUTINE flake_main ( depthw, depthbs, T_bs, par_Coriolis, & flk_str_1 = flk_str_1 - CTT/CT*( (Q_bot_flk+I_bot_flk-I_HH_flk)/tpl_rho_w_r/tpl_c_w - & depth_bs * ( 1.0 - CT ) * (T_bot_n_flk-T_bot_p_flk)/del_time ) flk_str_2 = CTT * (T_bot_p_flk-T_bot_2_in) - d_h_D_dt = flk_str_1/flk_str_2 + if(abs(flk_str_2)<0.01) then + d_h_D_dt = 0.0 + else + d_h_D_dt = flk_str_1/flk_str_2 + endif ! compute d_T_H_dt flk_str_1 = (Q_bot_flk+I_bot_flk-I_HH_flk)/tpl_rho_w_r/tpl_c_w @@ -1855,7 +1860,8 @@ MODULE SfcFlx ! similarity relations and in the expressions for the roughness lengths. REAL (KIND = kind_phys), PARAMETER :: & c_Karman = 0.40 , & ! The von Karman constant - Pr_neutral = 1.0 , & ! Turbulent Prandtl number at neutral static stability +! Pr_neutral = 1.0 , & ! Turbulent Prandtl number at neutral static stability + Pr_neutral = 0.9 , & ! Turbulent Prandtl number at neutral static stability Sc_neutral = 1.0 , & ! Turbulent Schmidt number at neutral static stability c_MO_u_stab = 5.0 , & ! Constant of the MO theory (wind, stable stratification) c_MO_t_stab = 5.0 , & ! Constant of the MO theory (temperature, stable stratification) @@ -2466,18 +2472,37 @@ SUBROUTINE SfcFlx_momsenlat ( height_u, height_tq, fetch, & ELSE ! Convection psi_u = (1.0-c_MO_t_conv*R_z*ZoL)**c_MO_t_exp psi_t = (1.0-c_MO_t_conv*R_z*ZoL*MIN(z0t_sf/height_tq, 1.0))**c_MO_t_exp - psi_t = 2.0*LOG((1.0+psi_t)/(1.0+psi_u)) +! psi_t = 2.0*LOG((1.0+psi_t)/(1.0+psi_u)) + psi_t = abs(2.0*LOG((1.0+psi_t)/(1.0+psi_u))) psi_u = (1.0-c_MO_q_conv*R_z*ZoL)**c_MO_q_exp psi_q = (1.0-c_MO_q_conv*R_z*ZoL*MIN(z0q_sf/height_tq, 1.0))**c_MO_q_exp - psi_q = 2.0*LOG((1.0+psi_q)/(1.0+psi_u)) +! psi_q = 2.0*LOG((1.0+psi_q)/(1.0+psi_u)) + psi_q = abs(2.0*LOG((1.0+psi_q)/(1.0+psi_u))) +! write(0,*) 'psi_q= ',psi_q !_dbg ! print*(*,*) 'CONV: psi_t = ', psi_t, ' psi_q = ', psi_q !_dbg END IF Q_sen_tur = -(T_a-T_s)*u_star_st*c_Karman/Pr_neutral & / MAX(c_small_sf, LOG(height_tq/z0t_sf)+psi_t) +if(MAX(c_small_sf, LOG(height_tq/z0t_sf)+psi_t) .lt. 10E-6) then + write(0,*)'inside flake' + write(0,*) Q_sen_tur, T_a, T_s, u_star_st, c_Karman, Pr_neutral + write(0,*) c_small_sf,height_tq,z0t_sf,psi_t + write(0,*) 'nominator= ', (T_a-T_s)*u_star_st*c_Karman/Pr_neutral + write(0,*) 'denominator= ',MAX(c_small_sf, LOG(height_tq/z0t_sf)+psi_t) +endif Q_lat_tur = -(q_a-q_s)*u_star_st*c_Karman/Sc_neutral & / MAX(c_small_sf, LOG(height_tq/z0q_sf)+psi_q) +if(Q_lat_tur .gt. 6.0E-4) then + Q_lat_tur = -(q_a-q_s)*u_star_st*c_Karman/3.0 & + / MAX(c_small_sf, LOG(height_tq/z0q_sf)+psi_q) + write(0,*) 'Q_lat_tur= ',Q_lat_tur + write(0,135) q_a,q_s,u_star_st,c_Karman + write(0,136) MAX(c_small_sf,LOG(height_tq/z0q_sf)+psi_q),c_small_sf, LOG(height_tq/z0q_sf),psi_q +endif +135 format(1x,4(f16.4)) +136 format(1x,4(f16.4)) END IF Turb_Fluxes @@ -2522,13 +2547,19 @@ SUBROUTINE SfcFlx_momsenlat ( height_u, height_tq, fetch, & Q_momentum = Q_momentum*rho_a !Q_sensible = Q_sensible*rho_a*tpsf_c_a_p +!write(0,*) 'Q_sensible= ',Q_sensible Q_watvap = Q_latent*rho_a -Q_latent = tpsf_L_evap +!Q_latent = tpsf_L_evap IF(h_ice.GE.h_Ice_min_flk) Q_latent = Q_latent + tpl_L_f ! Add latent heat of fusion over ice -Q_latent = Q_watvap*Q_latent - +!Q_latent = Q_watvap*Q_latent +Q_latent = Q_watvap*tpsf_L_evap +if(Q_latent .gt. 2000.00) then + write(0,145) 'final Q_watvap= ',Q_watvap, 'tpsf_L_evap= ',tpsf_L_evap, 'Q_latent= ', Q_latent +endif +!Q_latent = Q_watvap*Q_latent +145 format(A17,E12.5,1x,A13,1x,f10.2,1x,A10,1x,E12.4) ! Set "*_sf" variables to make fluxes accessible to driving routines that use "SfcFlx" u_star_a_sf = u_star_st Q_mom_a_sf = Q_momentum @@ -2537,7 +2568,7 @@ SUBROUTINE SfcFlx_momsenlat ( height_u, height_tq, fetch, & Q_watvap_a_sf = Q_watvap !write(85,127) Q_sensible, Q_watvap, Q_latent - 127 format(1x, 3(f16.9,1x)) + 127 format(1x, 3(f16.5,1x)) !------------------------------------------------------------------------------ ! End calculations @@ -2931,7 +2962,7 @@ SUBROUTINE flake_interface ( dMsnowdt_in, I_atm_in, Q_atm_lw_in, height_u_in, he T_snow_out, T_ice_out, T_mnw_out, T_wML_out, T_bot_out, & T_B1_out, C_T_out, h_snow_out, h_ice_out, h_ML_out, & - H_B1_out, T_sfc_n, hflx_out, evap_out, & + H_B1_out, T_sfc_n, hflx_out, evap_out, gflx_out, lflx_out, & T_bot_2_in, T_bot_2_out,ustar, q_sfc, chh, cmm ) @@ -2973,11 +3004,11 @@ SUBROUTINE flake_interface ( dMsnowdt_in, I_atm_in, Q_atm_lw_in, height_u_in, he USE flake_derivedtypes ! Definitions of several derived TYPEs -USE flake_parameters , ONLY : & - tpl_T_f , & ! Fresh water freezing point [K] - tpl_rho_w_r , & ! Maximum density of fresh water [kg m^{-3}] - h_Snow_min_flk , & ! Minimum snow thickness [m] - h_Ice_min_flk ! Minimum ice thickness [m] +!USE flake_parameters , ONLY : & +! tpl_T_f , & ! Fresh water freezing point [K] +! tpl_rho_w_r , & ! Maximum density of fresh water [kg m^{-3}] +! h_Snow_min_flk , & ! Minimum snow thickness [m] +! h_Ice_min_flk ! Minimum ice thickness [m] USE flake_paramoptic_ref ! Reference values of the optical characteristics ! of the lake water, lake ice and snow @@ -3103,6 +3134,8 @@ SUBROUTINE flake_interface ( dMsnowdt_in, I_atm_in, Q_atm_lw_in, height_u_in, he T_sfc_n , & ! Updated surface temperature [K] hflx_out , & ! sensibl heat flux evap_out , & ! Latent heat flux + gflx_out , & ! flux from to water + lflx_out , & ! latent heat flux T_bot_2_out , & ! Bottom temperature ustar , & q_sfc , & @@ -3116,16 +3149,21 @@ SUBROUTINE flake_interface ( dMsnowdt_in, I_atm_in, Q_atm_lw_in, height_u_in, he Q_sensible , & ! Sensible heat flux [W m^{-2}] Q_latent , & ! Latent heat flux [W m^{-2}] Q_watvap , & ! Flux of water vapour [kg m^{-2} s^{-1}] + Q_w_flux , & ! flux from ice to water rho_a ! ADDED by Shaobo Zhang LOGICAL lflk_botsed_use !REAL (KIND = kind_phys) :: T_bot_2_in, T_bot_2_out - +REAL (KIND = kind_phys), parameter :: tpl_rho_w_r = 1.0E+03 +REAL (KIND = kind_phys), parameter :: tpl_T_f = 273.15 +REAL (KIND = kind_phys), parameter :: h_Snow_min_flk = 1.0E-5 +REAL (KIND = kind_phys), parameter :: h_Ice_min_flk = 1.0E-9 !============================================================================== ! Start calculations !------------------------------------------------------------------------------ - lflk_botsed_use = .TRUE. +! lflk_botsed_use = .TRUE. + lflk_botsed_use = .FALSE. !------------------------------------------------------------------------------ ! Set albedos of the lake water, lake ice and snow !------------------------------------------------------------------------------ @@ -3139,9 +3177,10 @@ SUBROUTINE flake_interface ( dMsnowdt_in, I_atm_in, Q_atm_lw_in, height_u_in, he ! Snow is not considered !albedo_snow = albedo_ice albedo_ice = albedo_whiteice_ref -albedo_snow = albedo_ice +!albedo_snow = albedo_ice +albedo_snow = albedo_drysnow_ref opticpar_water%extincoef_optic(1) = water_extinc -!print*,'albedo= ',albedo_water,albedo_ice,albedo_snow +!write(0,*)'albedo= ',albedo_water,albedo_ice,albedo_snow !------------------------------------------------------------------------------ ! Set optical characteristics of the lake water, lake ice and snow @@ -3204,7 +3243,8 @@ SUBROUTINE flake_interface ( dMsnowdt_in, I_atm_in, Q_atm_lw_in, height_u_in, he CALL SfcFlx_momsenlat ( height_u_in, height_tq_in, fetch, & U_a_in, T_a_in, q_a_in, T_sfc_p, P_a_in, h_ice_p_flk, & Q_momentum, Q_sensible, Q_latent, Q_watvap, q_sfc, rho_a ) - +!write(0,*)'tpl_rho_w_r= ', tpl_rho_w_r +!write(0,*) 'Q_momentum= ',Q_momentum u_star_w_flk = SQRT(-Q_momentum/tpl_rho_w_r) ustar = u_star_w_flk @@ -3254,6 +3294,9 @@ SUBROUTINE flake_interface ( dMsnowdt_in, I_atm_in, Q_atm_lw_in, height_u_in, he H_B1_out = H_B1_n_flk hflx_out = Q_sensible evap_out = Q_watvap +!evap_out = Q_latent +gflx_out = Q_w_flk +lflx_out = Q_latent chh = ch * U_a_in * rho_a cmm = cm * U_a_in diff --git a/physics/flake_driver.F90 b/physics/flake_driver.F90 index 46065939d..a277783fb 100644 --- a/physics/flake_driver.F90 +++ b/physics/flake_driver.F90 @@ -49,13 +49,17 @@ end subroutine flake_driver_finalize !! SUBROUTINE flake_driver_run ( & ! ---- Inputs - im, ps, t1, q1, wind, & - dlwflx, dswsfc, weasd, lakedepth, & - use_lake_model, xlat, delt, zlvl, elev, & - wet, flag_iter, yearlen, julian, imon, & + im, ps, t1, q1, wind, min_lakeice, & + dlwflx, dswsfc, lakedepth, & + use_lake_model, snow, xlat, delt, zlvl, elev, & + wet, yearlen, julian, imon, & + flag_iter, first_time_step, flag_restart, & + weasd, & ! ---- in/outs - snwdph, hice, tsurf, fice, T_sfc, hflx, evap, & - ustar, qsfc, ch, cm, chh, cmm, & + snwdph, hice, tsurf, t_sfc, fice, hflx, evap, & + lflx, gflx, ustar, qsfc, ch, cm, chh, cmm, & + h_ML, t_wML, t_mnw, H_B, T_B, t_bot1, & + t_bot2, c_t, T_snow, T_ice, tsurf_ice, & errmsg, errflg ) !============================================================================== @@ -84,37 +88,41 @@ SUBROUTINE flake_driver_run ( & real (kind=kind_phys), dimension(:), intent(in) :: ps, wind, & & t1, q1, dlwflx, dswsfc, zlvl, elev - real (kind=kind_phys), intent(in) :: delt + real (kind=kind_phys), intent(in) :: delt, min_lakeice real (kind=kind_phys), dimension(:), intent(in) :: & - & xlat, weasd, lakedepth + & xlat, lakedepth, snow - real (kind=kind_phys),dimension(:),intent(inout) :: & - & snwdph, hice, tsurf, t_sfc, hflx, evap, fice, ustar, qsfc, & - & ch, cm, chh, cmm + real (kind=kind_phys), dimension(:), intent(in) :: weasd + + real (kind=kind_phys),dimension(:),intent(inout) :: & + & snwdph, hice, tsurf, t_sfc, hflx, evap, fice, ustar, qsfc, & + & ch, cm, chh, cmm, h_ML, t_wML, t_mnw, H_B, T_B, & + & t_bot1, t_bot2, c_t, T_snow, T_ice, tsurf_ice, lflx, gflx real (kind=kind_phys), intent(in) :: julian logical, dimension(:), intent(in) :: flag_iter, wet integer, dimension(:), intent(in) :: use_lake_model + logical, intent(in) :: flag_restart, first_time_step + character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg ! --- locals - - real (kind=kind_phys) , parameter :: lake_pct_min = 0.1 + real (kind=kind_phys), parameter :: lake_pct_min = 0.1 real (kind=kind_phys), dimension(im) :: & - T_snow , & ! Temperature at the air-snow interface [K] - T_ice , & ! Temperature at the snow-ice or air-ice interface [K] - T_mnw , & ! Mean temperature of the water column [K] - T_wML , & ! Mixed-layer temperature [K] - T_bot , & ! Temperature at the water-bottom sediment interface [K] - T_B1 , & ! Temperature at the upper layer of the sediments [K] - C_T , & ! Shape factor (thermocline) +! T_snow , & ! Temperature at the air-snow interface [K] +! T_ice , & ! Temperature at the snow-ice or air-ice interface [K] +! T_mnw , & ! Mean temperature of the water column [K] +! T_wML , & ! Mixed-layer temperature [K] +! T_bot , & ! Temperature at the water-bottom sediment interface [K] +! T_B , & ! Temperature at the upper layer of the sediments [K] +! C_T , & ! Shape factor (thermocline) fetch , & ! Typical wind fetch [m] - h_ML , & ! Thickness of the mixed-layer [m] - H_B1 , & ! Thickness of the upper layer of bottom sediments [m] +! h_ML , & ! Thickness of the mixed-layer [m] +! H_B1 , & ! Thickness of the upper layer of bottom sediments [m] w_albedo , & ! w_extinc @@ -147,7 +155,7 @@ SUBROUTINE flake_driver_run ( & T_mnw_in , & ! Mean temperature of the water column [K] T_wML_in , & ! Mixed-layer temperature [K] T_bot_in , & ! Temperature at the water-bottom sediment interface [K] - T_B1_in , & ! Temperature at the bottom of the upper layer of the sediments [K] + T_B_in , & ! Temperature at the bottom of the upper layer of the sediments [K] C_T_in , & ! Shape factor (thermocline) h_snow_in , & ! Snow thickness [m] h_ice_in , & ! Ice thickness [m] @@ -165,7 +173,7 @@ SUBROUTINE flake_driver_run ( & T_mnw_out , & ! Mean temperature of the water column [K] T_wML_out , & ! Mixed-layer temperature [K] T_bot_out , & ! Temperature at the water-bottom sediment interface [K] - T_B1_out , & ! Temperature at the bottom of the upper layer of the sediments [K] + T_B_out , & ! Temperature at the bottom of the upper layer of the sediments [K] C_T_out , & ! Shape factor (thermocline) h_snow_out , & ! Snow thickness [m] h_ice_out , & ! Ice thickness [m] @@ -182,17 +190,19 @@ SUBROUTINE flake_driver_run ( & Q_momentum , & ! Momentum flux [N m^{-2}] Q_SHT_flx , & ! Sensible heat flux [W m^{-2}] Q_LHT_flx , & ! Latent heat flux [W m^{-2}] - Q_watvap ! Flux of water vapour [kg m^{-2} s^{-1}] + Q_watvap , & ! Flux of water vapour [kg m^{-2} s^{-1}] + Q_gflx , & ! Flux from ice to water [W m^{-2}] + Q_lflx ! latent fluxes [W m^{-2}] REAL (KIND = kind_phys) :: & - lake_depth_max, T_bot_2_in, T_bot_2_out, dxlat,tb,tr,tt,temp,temp2 + lake_depth_max, T_bot_2_in, T_bot_2_out, dlat,tb,tr,tt,temp,temp2 real (kind=kind_phys), parameter :: pi=4.0_kind_phys*atan(1.0_kind_phys) real (kind=kind_phys), parameter :: degrad=180.0_kind_phys/pi real (kind=kind_phys), parameter :: Kbar = 3.5_kind_phys, DelK = 3.0_kind_phys, & KbaroDelK = Kbar / DelK - REAL (KIND = kind_phys) :: x, y !temperarory variables used for Tbot and Tsfc + REAL (KIND = kind_phys) :: x, y, w !temperarory variables used for Tbot and Tsfc !initilizations INTEGER :: i,ipr,iter @@ -205,15 +215,17 @@ SUBROUTINE flake_driver_run ( & ! Start calculations !------------------------------------------------------------------------------ ! FLake_write need to assign original value to make the model somooth + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 ! --- ... set flag for lake points do_flake = .false. do i = 1, im - flag(i) = wet(i) .and. flag_iter(i) .and. use_lake_model(i)>0 - do_flake = flag(i) .or. do_flake + flag(i) = flag_iter(i) .and. use_lake_model(i) .gt. 0 + do_flake = flag(i) .or. do_flake enddo - if (.not. do_flake) return lake_depth_max = 60.0 @@ -230,61 +242,61 @@ SUBROUTINE flake_driver_run ( & temp2 = sin((pi+pi)*(julian-151)/244) do i = 1, im - if (flag(i)) then - T_ice(i) = 273.15 - T_snow(i) = 273.15 - fetch(i) = 2.0E+03 - C_T(i) = 0.50 - - dxlat = degrad*abs(xlat(i)) - tt = 29.275+(0.0813-0.0052*dxlat)*dxlat-0.0038*elev(i)+273.15 - tb = 29.075-(0.7566-0.0051*dxlat)*dxlat-0.0038*elev(i)+273.15 -! if (fice(i).le.0.0) then -! h_ice(i) = 0.0 -! h_snow(i)= 0.0 -! endif - if (snwdph(i) > 0.0 .or. hice(i) > 0.0) then - if (tsurf(i) < T_ice(i)) then - T_sfc(i) = T_ice(i) - else - T_sfc(i) = tsurf(i) - endif - else -! if (tsurf(i) < tt) then -! T_sfc(i) = tt -! else -! T_sfc(i) = tsurf(i) -! endif - T_sfc(i) = 0.1*tt + 0.9* tsurf(i) - endif -! + if (flag(i) .and. lakedepth(i) >1.0) then + if(.not.flag_restart .and. first_time_step) then + T_ice(i) = 273.15 + T_snow(i) = 273.15 + C_T(i) = 0.50 + dlat = abs(xlat(i)) + if(dlat .lt. 1.40) then + tt = (((21.181*dlat-51.376)*dlat+20.808)*dlat-3.8408)*dlat+29.554 + tt = tt -0.0038*elev(i)+273.15 + tb = (((-29.794*dlat+96.91)*dlat-86.129)*dlat-7.1921)*dlat+28.176 + tb = tb -0.0038*elev(i)+273.15 + w = (((2.5467*dlat-7.4683)*dlat+5.2465)*dlat+0.4360)*dlat+0.0643 + else + tt = 4.0+273.15-0.0038*elev(i) + tb = 0.05+273.15-0.0038*elev(i) + w = 0.207312 + endif + if(tsurf(i) > 400.00) then + write(0,*) tsurf(i) + write(0,*) 'Surface temperature initial is bad' + tsurf(i) = tt + write(0,*) tsurf(i) + endif + T_sfc(i) = 0.05*tt + 0.95* tsurf(i) + ! Add empirical climatology of lake Tsfc and Tbot to the current Tsfc and Tbot ! to make sure Tsfc and Tbot are warmer than Tair in Winter or colder than Tair ! in Summer - if (xlat(i) >= 0.0) then - T_sfc(i) = T_sfc(i) + 0.3*y - tb = tb + 0.05*y - else - T_sfc(i) = T_sfc(i) - 0.3*y - tb = tb - 0.05*y - endif - T_bot(i) = tb - T_B1(i) = tb - -! if (lakedepth(i) < 10.0) then -! T_bot(i) = T_sfc(i) -! T_B1(i) = T_bot(i) -! endif - - T_mnw(i) = C_T(i)*T_sfc(i) + (1-C_T(i))*T_bot(i) - T_wML(i) = C_T(i)*T_sfc(i) + (1-C_T(i))*T_bot(i) - h_ML(i) = C_T(i)* min ( lakedepth(i), lake_depth_max ) - H_B1(i) = min ( lakedepth(i),4.0) - hflx(i) = 0.0 - evap(i) = 0.0 + if (xlat(i) >= 0.0) then + T_sfc(i) = T_sfc(i) + 0.05*y*w + tb = tb + 0.005*y*w + else + T_sfc(i) = T_sfc(i) - 0.5*y*w + tb = tb - 0.005*y*w + endif + + t_bot1(i) = tb + t_bot2(i) = tb + T_B(i) = tb + + T_mnw(i) = C_T(i)*T_sfc(i) + (1-C_T(i))*t_bot1(i) + T_wML(i) = C_T(i)*T_sfc(i) + (1-C_T(i))*t_bot1(i) + h_ML(i) = C_T(i)* min ( lakedepth(i), lake_depth_max ) + H_B(i) = min ( lakedepth(i),4.0) + hflx(i) = 0.0 + lflx(i) = 0.0 + evap(i) = 0.0 + chh = ch(i) * wind(i) * 1.225 !(kg/m3) + cmm = cm(i) * wind(i) + endif !end of .not.flag_restart + fetch(i) = 2.0E+03 ! compute albedo as a function of julian day and latitude +! write(0,*) ' xlat= ',xlat(i), temp w_albedo(I) = 0.06/cos((xlat(i)-temp)/1.2) ! w_albedo(I) = 0.06 ! compute water extinction coefficient as a function of julian day @@ -295,24 +307,26 @@ SUBROUTINE flake_driver_run ( & endif ! w_extinc(i) = 3.0 -! write(65,1002) julian,xlat(i),w_albedo(I),w_extinc(i),lakedepth(i),elev(i),tb,tt,tsurf(i),T_sfc(i) -! print 1002 julian,xlat(i),w_albedo(I),w_extinc(i),lakedepth(i),elev(i),tb,tt,tsurf(i),T_sfc(i) -! print*,'inside flake driver' -! print*, julian,xlat(i),w_albedo(I),w_extinc(i),lakedepth(i),elev(i),tb,tt,tsurf(i),T_sfc(i) +! write(0,1002) julian,xlat(i),w_albedo(I),w_extinc(i),elev(i),tsurf(i),T_sfc(i),t_bot1(i) +! write(0,1003) use_lake_model(i),i,lakedepth(i), snwdph(i), hice(i), fice(i) +! write(0,1004) ps(i), wind(i), t1(i), q1(i), dlwflx(i), dswsfc(i), zlvl(i) endif !flag enddo - 1001 format ( 'At icount=', i5, ' x = ', f5.2,5x, 'y = ', & - 1p, e12.3) -! 1002 format ( ' julian= ',F6.2,1x,5(F8.4,1x),3(f11.4,1x)) - 1002 format (I4,1x,3(f8.4,1x),6(f11.4,1x)) - - + 1002 format ( 'julian=',F6.2,1x,F8.3,1x,2(E7.2,1x),E7.2,1x,3(E7.2,1x)) + 1003 format ( 'use_lake_model=',I2,1x,I3,1x,F6.4,1x,F9.4,1x,2(F8.4,1x),F7.4) + 1004 format ( 'pressure',F12.2,1x,F6.2,1x,F7.2,1x,F7.4,1x,2(F8.2,1x),F8.4) ! ! call lake interface do i=1,im - if (flag(i)) then - dMsnowdt_in = weasd(i)/delt + if (flag(i) .and. lakedepth(i) > 1.0) then +! write(0,*) 'flag(i)= ', i, flag(i) +! if(weasd(i) < 0.0 .or. hice(i) < 0.0) weasd(i) =0.0 + if(snwdph(i) < 0.0) snwdph(i) =0.0 +! dMsnowdt_in = 10.0*0.001*weasd(i)/delt +! dMsnowdt_in = snow(i)/delt + dMsnowdt_in = snow(i)*0.001 + if(dMsnowdt_in < 0.0) dMsnowdt_in=0.0 I_atm_in = dswsfc(i) Q_atm_lw_in = dlwflx(i) height_u_in = zlvl(i) @@ -329,27 +343,36 @@ SUBROUTINE flake_driver_run ( & depth_w = min ( lakedepth(i), lake_depth_max ) depth_bs_in = max ( 4.0, min ( depth_w * 0.2, 10.0 ) ) fetch_in = fetch(i) - T_bs_in = T_bot(i) + T_bs_in = T_bot1(i) par_Coriolis = 2 * 7.2921 / 100000. * sin ( xlat(i) ) del_time = delt - do iter=1,10 !interation loop +! if(lakedepth(i).lt.10) then +! T_sfc(i) = t1(i) +! T_bs_in = T_sfc(i) +! T_B(i) = T_bs_in +! endif + + do iter=1,5 !interation loop T_snow_in = T_snow(i) T_ice_in = T_ice(i) T_mnw_in = T_mnw(i) T_wML_in = T_wML(i) - T_bot_in = T_bot(i) - T_B1_in = T_B1(i) + T_bot_in = t_bot1(i) + T_B_in = T_B(i) C_T_in = C_T(i) h_snow_in = snwdph(i) h_ice_in = hice(i) h_ML_in = h_ML(i) - H_B1_in = H_B1(i) + H_B1_in = H_B(i) T_sfc_in = T_sfc(i) + tsurf_ice(i)= T_ice(i) - T_bot_2_in = T_bot(i) + T_bot_2_in = t_bot2(i) Q_SHT_flx = hflx(i) Q_watvap = evap(i) + Q_gflx = 0.0 + Q_lflx = 0.0 !------------------------------------------------------------------------------ ! Set the rate of snow accumulation @@ -359,13 +382,13 @@ SUBROUTINE flake_driver_run ( & height_tq_in, U_a_in, T_a_in, q_a_in, P_a_in, & depth_w, fetch_in, depth_bs_in, T_bs_in, par_Coriolis, del_time, & - T_snow_in, T_ice_in, T_mnw_in, T_wML_in, T_bot_in, T_B1_in, & + T_snow_in, T_ice_in, T_mnw_in, T_wML_in, T_bot_in, T_B_in, & C_T_in, h_snow_in, h_ice_in, h_ML_in, H_B1_in, T_sfc_in, & ch_in, cm_in, albedo_water, water_extinc, & ! T_snow_out, T_ice_out, T_mnw_out, T_wML_out, T_bot_out, & - T_B1_out, C_T_out, h_snow_out, h_ice_out, h_ML_out, & - H_B1_out, T_sfc_out, Q_SHT_flx, Q_watvap, & + T_B_out, C_T_out, h_snow_out, h_ice_out, h_ML_out, & + H_B1_out, T_sfc_out, Q_SHT_flx, Q_watvap, Q_gflx, Q_lflx, & ! T_bot_2_in, T_bot_2_out,u_star, q_sfc,chh_out,cmm_out ) @@ -378,11 +401,13 @@ SUBROUTINE flake_driver_run ( & T_wML(i) = T_wML_out T_sfc(i) = T_sfc_out Tsurf(i) = T_sfc_out - T_bot(i) = T_bot_out - T_B1(i) = T_B1_out + tsurf_ice(i) = T_ice(i) + t_bot1(i) = T_bot_out + t_bot2(i) = T_bot_2_out + T_B(i) = T_B_out C_T(i) = C_T_out h_ML(i) = h_ML_out - H_B1(i) = H_B1_out + H_B(i) = H_B1_out ustar(i) = u_star qsfc(i) = q_sfc chh(i) = chh_out @@ -391,26 +416,91 @@ SUBROUTINE flake_driver_run ( & hice(i) = h_ice_out evap(i) = Q_watvap hflx(i) = Q_SHT_flx - - if (hice(i) > 0.0 .or. snwdph(i) > 0.0) then - fice(i) = 1.0 - else - fice(i) = 0.0 - endif + gflx(i) = Q_gflx + lflx(i) = Q_lflx +! if(lflx(i) > 2500.00 .or. Tsurf(i) > 350.00) then +! write(0,125) i,lflx(i), Tsurf(i),ps(i), wind(i), & +! & t1(i), q1(i), dlwflx(i), dswsfc(i),hflx(i) +! endif +! fice(i) = fice(i)+0.01*(h_ice_out-h_ice_in) +! if(fice(i) .lt. min_lakeice ) then +! fice(i) = 0.0 +! elseif(fice(i) .gt. 1.0) then +! fice(i) = 1.0 +! endif enddo !iter loop +! endif !endif use_lake_model endif !endif of flag enddo -!125 format(1x,i2,1x,i2,1x,i2,1x,6(1x,f14.8)) +125 format(1x,i3,1x,9(1x,f10.3)) !126 format(1x,i2,1x,i2,1x,6(1x,f14.8)) !127 format(1x,i2,2(1x,f16.9)) !------------------------------------------------------------------------------ ! End calculations !============================================================================== -END SUBROUTINE flake_driver_run + END SUBROUTINE flake_driver_run + +end module flake_driver + +module flake_driver_post + use machine, only: kind_phys + implicit none + private + public flake_driver_post_init, flake_driver_post_finalize, flake_driver_post_run + +contains + subroutine flake_driver_post_init() + end subroutine flake_driver_post_init + + subroutine flake_driver_post_finalize() + end subroutine flake_driver_post_finalize + +!> \section arg_table_flake_driver_post Argument Table +!! \htmlinclude flake_driver_post.html +!! +subroutine flake_driver_post_run (im, use_lake_model, h_ML, T_wML, & + Tsurf, lakedepth, xz, zm, tref, tsfco, & + errmsg, errflg) + +!use machine , only : kind_phys +!============================================================================== + + implicit none + integer, intent(in) :: im +! integer, dimension(im), intent(in) :: islmsk + + real (kind=kind_phys), dimension(:), intent(in) :: & + & lakedepth, tsurf, h_ML, t_wML + + real (kind=kind_phys),dimension(:),intent(inout) :: & + & xz, zm, tref, tsfco + + integer, dimension(:), intent(in) :: use_lake_model + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + integer :: i + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + do I=1, im + if(use_lake_model(i).eq.2) then + write(0,*)'flake-post-use-lake-model= ',use_lake_model(i) + xz(i) = lakedepth(i) + zm(i) = h_ML(i) + tref(i) = tsurf(i) + tsfco(i) = t_wML(i) + endif + enddo + + +end subroutine flake_driver_post_run !--------------------------------- - end module flake_driver +end module flake_driver_post diff --git a/physics/flake_driver.meta b/physics/flake_driver.meta index c0fa96320..94335a62d 100644 --- a/physics/flake_driver.meta +++ b/physics/flake_driver.meta @@ -86,9 +86,17 @@ type = real kind = kind_phys intent = in +[min_lakeice] + standard_name = min_lake_ice_area_fraction + long_name = minimum lake ice value + units = frac + dimensions = () + type = real + kind = kind_phys + intent = in [dlwflx] - standard_name = surface_downwelling_longwave_flux_absorbed_by_ground_over_water - long_name = total sky surface downward longwave flux absorbed by the ground over water + standard_name = surface_downwelling_longwave_flux + long_name = surface downwelling longwave flux at current time units = W m-2 dimensions = (horizontal_loop_extent) type = real @@ -102,14 +110,6 @@ type = real kind = kind_phys intent = in -[weasd] - standard_name = water_equivalent_accumulated_snow_depth_over_ice - long_name = water equiv of acc snow depth over ice - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in [lakedepth] standard_name = lake_depth long_name = lake depth @@ -125,6 +125,14 @@ dimensions = (horizontal_loop_extent) type = integer intent = in +[snow] + standard_name = lwe_thickness_of_snow_amount_on_dynamics_timestep + long_name = snow fall at this time step + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [xlat] standard_name = latitude long_name = latitude @@ -164,13 +172,6 @@ dimensions = (horizontal_loop_extent) type = logical intent = in -[flag_iter] - standard_name = flag_for_iteration - long_name = flag for iteration - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in [yearlen] standard_name = number_of_days_in_current_year long_name = number of days in a year @@ -193,6 +194,35 @@ dimensions = () type = integer intent = in +[flag_iter] + standard_name = flag_for_iteration + long_name = flag for iteration + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in +[first_time_step] + standard_name = flag_for_first_timestep + long_name = flag for first time step for time integration loop (cold/warmstart) + units = flag + dimensions = () + type = logical + intent = in +[flag_restart] + standard_name = flag_for_restart + long_name = flag for restart (warmstart) or coldstart + units = flag + dimensions = () + type = logical + intent = in +[weasd] + standard_name = water_equivalent_accumulated_snow_depth_over_ice + long_name = water equiv of acc snow depth over ice + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout [snwdph] standard_name = surface_snow_thickness_water_equivalent_over_ice long_name = water equivalent snow depth over ice @@ -210,8 +240,8 @@ kind = kind_phys intent = inout [tsurf] - standard_name = surface_skin_temperature_after_iteration_over_water - long_name = surface skin temperature after iteration over water + standard_name = surface_skin_temperature_over_water + long_name = surface skin temperature over water units = K dimensions = (horizontal_loop_extent) type = real @@ -226,8 +256,8 @@ kind = kind_phys intent = inout [t_sfc] - standard_name = surface_skin_temperature_over_water - long_name = surface skin temperature over water + standard_name = surface_skin_temperature_after_iteration_over_water + long_name = surface skin temperature after iteration over water units = K dimensions = (horizontal_loop_extent) type = real @@ -249,6 +279,22 @@ type = real kind = kind_phys intent = inout +[lflx] + standard_name = surface_upward_potential_latent_heat_flux_over_water + long_name = surface upward potential latent heat flux over water + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[gflx] + standard_name = upward_heat_flux_in_soil_over_water + long_name = soil heat flux over water + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout [ustar] standard_name = surface_friction_velocity_over_water long_name = surface friction velocity over water @@ -297,6 +343,190 @@ type = real kind = kind_phys intent = inout +[h_ML] + standard_name = mixed_layer_depth_of_lakes + long_name = depth of lake mixing layer + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[t_wML] + standard_name = lake_mixed_layer_temperature + long_name = temperature of lake mixing layer + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[t_mnw] + standard_name = mean_temperature_of_the_water_column + long_name = thee mean temperature of the water column + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[H_B] + standard_name = the_thermally_active_layer_depth_of_the_bottom_sediment + long_name = the depth of the thermally active layer of the bottom sediment + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[T_B] + standard_name = temperature_at_the_bottom_of_the_sediment_upper_layer + long_name = the temperature at the bottom of the sediment upper layer + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[t_bot1] + standard_name = lake_bottom_temperature + long_name = the temperature at the water-bottom sediment interface + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[t_bot2] + standard_name = temperature_for_bottom_layer_of_water + long_name = the temperature at the lake bottom layer water + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[c_t] + standard_name = shape_factor_of_water_temperature_vertical_profile + long_name = the shape factor of water temperature vertical profile + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[T_snow] + standard_name = temperature_of_snow_on_lake + long_name = the temperature of snow on a lake + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[T_ice] + standard_name = surface_skin_temperature_over_ice + long_name = surface skin temperature over ice + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[tsurf_ice] + standard_name = surface_skin_temperature_after_iteration_over_ice + long_name = surface skin temperature after iteration over ice + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out + +######################################################################## +[ccpp-table-properties] + name = flake_driver_post + type = scheme + dependencies = machine.F +######################################################################## +[ccpp-arg-table] + name = flake_driver_post_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[lakedepth] + standard_name = lake_depth + long_name = lake depth + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[tsurf] + standard_name = surface_skin_temperature_after_iteration_over_water + long_name = surface skin temperature after iteration over water + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[h_ML] + standard_name = mixed_layer_depth_of_lakes + long_name = depth of lake mixing layer + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[t_wML] + standard_name = lake_mixed_layer_temperature + long_name = temperature of lake mixing layer + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[xz] + standard_name = diurnal_thermocline_layer_thickness + long_name = diurnal thermocline layer thickness + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[zm] + standard_name = ocean_mixed_layer_thickness + long_name = mixed layer thickness + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[tref] + standard_name = reference_sea_surface_temperature + long_name = reference/foundation temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[tfco] + standard_name = sea_surface_temperature + long_name = sea surface temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 7a5b0818c4eb38082c32eadaa7f8baf479f24adf Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Tue, 22 Nov 2022 09:40:39 -0500 Subject: [PATCH 068/380] Merge pull request #9 from dustinswales/add_cnvcldcnd_mp2rad_cplng Couple convective cloud to radiation --- physics/GFS_rrtmgp_cloud_mp.F90 | 49 +++++++++++++++++++++++--------- physics/GFS_rrtmgp_cloud_mp.meta | 15 ++++++++++ physics/radiation_clouds.f | 16 ++++++----- 3 files changed, 59 insertions(+), 21 deletions(-) diff --git a/physics/GFS_rrtmgp_cloud_mp.F90 b/physics/GFS_rrtmgp_cloud_mp.F90 index 2acf8b4da..c76f40da1 100644 --- a/physics/GFS_rrtmgp_cloud_mp.F90 +++ b/physics/GFS_rrtmgp_cloud_mp.F90 @@ -50,11 +50,12 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic relhum, lsmask, xlon, xlat, dx, tv_lay, effrin_cldliq, effrin_cldice, & effrin_cldrain, effrin_cldsnow, tracer, cnv_mixratio, cld_cnv_frac, qci_conv, & deltaZ, deltaZc, deltaP, qc_mynn, qi_mynn, cld_pbl_frac, con_g, con_rd, con_eps, & - con_ttp, doGP_cldoptics_PADE, doGP_cldoptics_LUT, cld_frac, cld_lwp, cld_reliq, & + con_ttp, doGP_cldoptics_PADE, doGP_cldoptics_LUT, doGP_smearclds, & + cld_frac, cld_lwp, cld_reliq, & cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, cld_rerain, precip_frac, & cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, cld_cnv_reice, cld_pbl_lwp, & cld_pbl_reliq, cld_pbl_iwp, cld_pbl_reice, lwp_ex, iwp_ex, lwp_fc, iwp_fc, & - errmsg, errflg) + cldfra2d, errmsg, errflg) implicit none ! Inputs @@ -92,7 +93,8 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic uni_cld, & ! Flag for unified cloud scheme lmfdeep2, & ! Flag for mass flux deep convection doGP_cldoptics_LUT, & ! Flag to do GP cloud-optics (LUTs) - doGP_cldoptics_PADE ! (PADE approximation) + doGP_cldoptics_PADE, & ! (PADE approximation) + doGP_smearclds ! If true, add sgs clouds to gridmean clouds real(kind_phys), intent(in) :: & con_g, & ! Physical constant: gravitational constant con_rd, & ! Physical constant: gas-constant for dry air @@ -135,6 +137,8 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic iwp_ex, & ! Total ice water path from explicit microphysics lwp_fc, & ! Total liquid water path from cloud fraction scheme iwp_fc ! Total ice water path from cloud fraction scheme + real(kind_phys), dimension(:), intent(out) :: & + cldfra2d ! Instantaneous 2D (max-in-column) cloud fraction real(kind_phys), dimension(:,:),intent(inout) :: & cld_frac, & ! Cloud-fraction for stratiform clouds cld_lwp, & ! Water path for stratiform liquid cloud-particles @@ -267,8 +271,9 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic endif call cloud_mp_thompson(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_cldrain,& i_cldsnow, i_cldgrpl, p_lev, p_lay, tv_lay, t_lay, tracer, qs_lay, q_lay, & - relhum, con_g, con_rd, con_eps, alpha0, lwp_ex, iwp_ex, lwp_fc, iwp_fc, & - cld_frac, cld_lwp, cld_iwp, cld_swp, cld_rwp, cond_cfrac_onRH = .true.) + relhum, con_ttp, con_g, con_rd, con_eps, alpha0, cnv_mixratio, lwp_ex, & + iwp_ex, lwp_fc, iwp_fc, cld_frac, cld_lwp, cld_iwp, cld_swp, cld_rwp, & + cond_cfrac_onRH = .true., doGP_smearclds = doGP_smearclds) endif ! Bound effective radii for RRTMGP, LUT's for cloud-optics go from @@ -293,6 +298,14 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic endif endif + ! Instantaneous 2D (max-in-column) cloud fraction + do iCol = 1, nCol + cldfra2d(iCol) = 0._kind_phys + do iLay = 1, nLev-1 + cldfra2d(iCol) = max(cldfra2d(iCol), cld_frac(iCol,iLay)) + enddo + enddo + precip_frac(1:nCol,1:nLev) = cld_frac(1:nCol,1:nLev) end subroutine GFS_rrtmgp_cloud_mp_run @@ -659,13 +672,14 @@ end subroutine cloud_mp_uni !! \section cloud_mp_thompson_gen General Algorithm subroutine cloud_mp_thompson(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_cldrain,& i_cldsnow, i_cldgrpl, p_lev, p_lay, tv_lay, t_lay, tracer, qs_lay, q_lay, relhum, & - con_g, con_rd, con_eps, alpha0, lwp_ex, iwp_ex, lwp_fc, iwp_fc, cld_frac, cld_lwp,& - cld_iwp, cld_swp, cld_rwp, cond_cfrac_onRH) + con_ttp, con_g, con_rd, con_eps, alpha0, cnv_mixratio, lwp_ex, iwp_ex, lwp_fc, & + iwp_fc, cld_frac, cld_lwp, cld_iwp, cld_swp, cld_rwp, cond_cfrac_onRH, doGP_smearclds) implicit none ! Inputs logical, intent(in), optional :: & - cond_cfrac_onRH + cond_cfrac_onRH, & ! If true, cloud-fracion set to unity when rh>99% + doGP_smearclds ! If true, add sgs clouds to gridmean clouds integer, intent(in) :: & nCol, & ! Number of horizontal grid points nLev, & ! Number of vertical layers @@ -677,6 +691,7 @@ subroutine cloud_mp_thompson(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_c i_cldsnow, & ! cloud snow amount. i_cldgrpl ! cloud groupel amount. real(kind_phys), intent(in) :: & + con_ttp, & ! Triple point temperature of water (K) con_g, & ! Physical constant: gravitational constant con_rd, & ! Physical constant: gas-constant for dry air con_eps, & ! Physical constant: gas constant air / gas constant H2O @@ -687,7 +702,8 @@ subroutine cloud_mp_thompson(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_c qs_lay, & ! Saturation vapor pressure (Pa) q_lay, & ! water-vapor mixing ratio (kg/kg) relhum, & ! Relative humidity - p_lay ! Pressure at model-layers (Pa) + p_lay, & ! Pressure at model-layers (Pa) + cnv_mixratio ! Convective cloud mixing-ratio (kg/kg) real(kind_phys), dimension(:,:), intent(in) :: & p_lev ! Pressure at model-level interfaces (Pa) real(kind_phys), dimension(:,:,:),intent(in) :: & @@ -707,16 +723,15 @@ subroutine cloud_mp_thompson(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_c cld_rwp ! Cloud rain water path ! Local variables - real(kind_phys) :: tem1, pfac, cld_mr, deltaP + real(kind_phys) :: tem1, pfac, cld_mr, deltaP, tem2 real(kind_phys), dimension(nCol, nLev, min(4,ncnd)) :: cld_condensate integer :: iCol,iLay,l ! Cloud condensate cld_condensate(1:nCol,1:nLev,1) = tracer(1:nCol,1:nLev,i_cldliq) ! -liquid water cld_condensate(1:nCol,1:nLev,2) = tracer(1:nCol,1:nLev,i_cldice) ! -ice water - cld_condensate(1:nCol,1:nLev,3) = tracer(1:nCol,1:nLev,i_cldrain) ! -rain water - cld_condensate(1:nCol,1:nLev,4) = tracer(1:nCol,1:nLev,i_cldsnow) + &! -snow + grapuel - tracer(1:nCol,1:nLev,i_cldgrpl) + cld_condensate(1:nCol,1:nLev,3) = tracer(1:nCol,1:nLev,i_cldrain) ! -rain hydrometeors + cld_condensate(1:nCol,1:nLev,4) = tracer(1:nCol,1:nLev,i_cldsnow) ! -snow hydrometeors cld_lwp(:,:) = 0.0 cld_iwp(:,:) = 0.0 @@ -726,6 +741,12 @@ subroutine cloud_mp_thompson(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_c tem1 = 1.0e5/con_g do iLay = 1, nLev-1 do iCol = 1, nCol + ! Add convective cloud to gridmean cloud? + if (doGP_smearclds) then + tem2 = min(1.0, max(0.0, (con_ttp-t_lay(iCol,iLay))*0.05)) + cld_condensate(iCol,iLay,1) = cld_condensate(iCol,iLay,1) + cnv_mixratio(iCol,iLay)*(1._kind_phys - tem2) + cld_condensate(iCol,iLay,2) = cld_condensate(iCol,iLay,2) + cnv_mixratio(iCol,iLay)*tem2 + endif ! Compute liquid/ice condensate path from mixing ratios (kg/kg)->(g/m2) deltaP = abs(p_lev(iCol,iLay+1)-p_lev(iCol,iLay))*0.01 cld_lwp(iCol,iLay) = max(0., cld_condensate(iCol,iLay,1) * tem1 * deltaP) @@ -738,7 +759,7 @@ subroutine cloud_mp_thompson(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_c cld_frac(iCol,iLay) = 1._kind_phys else cld_mr = cld_condensate(iCol,iLay,1) + cld_condensate(iCol,iLay,2) + & - cld_condensate(iCol,iLay,4) + cld_condensate(iCol,iLay,3) + cld_condensate(iCol,iLay,4) cld_frac(iCol,iLay) = cld_frac_XuRandall(p_lay(iCol,iLay), & qs_lay(iCol,iLay), relhum(iCol,iLay), cld_mr, alpha0) endif diff --git a/physics/GFS_rrtmgp_cloud_mp.meta b/physics/GFS_rrtmgp_cloud_mp.meta index 4f48d53ef..1eb870da8 100644 --- a/physics/GFS_rrtmgp_cloud_mp.meta +++ b/physics/GFS_rrtmgp_cloud_mp.meta @@ -462,6 +462,13 @@ dimensions = () type = logical intent = in +[doGP_smearclds] + standard_name = flag_for_implicit_sgs_cloud_in_RRTMGP + long_name = logical flag to impicit SGS cloud in RRTMGP + units = flag + dimensions = () + type = logical + intent = in [cld_frac] standard_name = total_cloud_fraction long_name = layer total cloud fraction @@ -646,6 +653,14 @@ type = real kind = kind_phys intent = inout +[cldfra2d] + standard_name = max_in_column_cloud_fraction + long_name = instantaneous 2D (max-in-column) cloud fraction + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index 47b9b79fa..bf255ce00 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -2160,7 +2160,7 @@ subroutine progcld_thompson_wsm6 & integer :: i, k, id, nf ! --- constant values - real (kind=kind_phys), parameter :: xrc3 = 200. + real (kind=kind_phys), parameter :: xrc3 = 100. ! !===> ... begin here @@ -2177,7 +2177,7 @@ subroutine progcld_thompson_wsm6 & rei (i,k) = re_ice(i,k) rer (i,k) = rrain_def ! default rain radius to 1000 micron res (i,k) = re_snow(i,K) -! tem2d (i,k) = min( 1.0, max( 0.0, (con_ttp-tlyr(i,k))*0.05 ) ) + tem2d (i,k) = min( 1.0, max( 0.0, (con_ttp-tlyr(i,k))*0.05 ) ) clwf(i,k) = 0.0 enddo enddo @@ -2208,12 +2208,14 @@ subroutine progcld_thompson_wsm6 & enddo enddo -!> - Compute cloud liquid/ice condensate path in \f$ g/m^2 \f$ . - +!> - Compute total-cloud liquid/ice condensate path in \f$ g/m^2 \f$. +!> The total condensate includes convective condensate. do k = 1, NLAY-1 do i = 1, IX - cwp(i,k) = max(0.0, clw(i,k,ntcw) * gfac * delp(i,k)) - cip(i,k) = max(0.0, clw(i,k,ntiw) * gfac * delp(i,k)) + cwp(i,k) = max(0.0, (clw(i,k,ntcw)+cnvw(i,k)* + & (1.-tem2d(i,k))) * gfac * delp(i,k)) + cip(i,k) = max(0.0, (clw(i,k,ntiw) + cnvw(i,k)* + & tem2d(i,k)) *gfac * delp(i,k)) crp(i,k) = max(0.0, clw(i,k,ntrw) * gfac * delp(i,k)) csp(i,k) = max(0.0, clw(i,k,ntsw) * gfac * delp(i,k)) enddo @@ -3902,7 +3904,7 @@ subroutine cloud_fraction_mass_flx_2 & clwmin = 0.0 do k = 1, NLAY-1 do i = 1, IX - clwt = 1.0e-10 * (plyr(i,k)*0.001) + clwt = 1.0e-6 * (plyr(i,k)*0.001) if (clwf(i,k) > clwt) then if(rhly(i,k) > 0.99) then From f44c410d78b2444cdafdc1852f0f75c0b6fe12f5 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 1 Dec 2022 03:49:36 +0000 Subject: [PATCH 069/380] skin_temperature_from_clm_lake_model -> skin_temperature_from_lake_model --- physics/clm_lake.meta | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/clm_lake.meta b/physics/clm_lake.meta index 0c8a3af33..a7b6155b4 100644 --- a/physics/clm_lake.meta +++ b/physics/clm_lake.meta @@ -624,8 +624,8 @@ kind = kind_phys intent = inout [t_grnd2d] - standard_name = skin_temperature_from_clm_lake_model - long_name = skin_temperature_from_clm_lake_model + standard_name = skin_temperature_from_lake_model + long_name = skin_temperature_from_lake_model units = K dimensions = (horizontal_loop_extent) type = real From 1ab05051c85c31fe33588b964cc82c32c32b7496 Mon Sep 17 00:00:00 2001 From: Helin Wei Date: Fri, 2 Dec 2022 15:18:41 -0500 Subject: [PATCH 070/380] merge with noahmp_table branch --- physics/noahmp_tables.f90 | 2035 +++++++++++++++++++++---------------- physics/noahmpdrv.F90 | 14 +- physics/noahmptable.tbl | 774 ++++++++++++++ 3 files changed, 1920 insertions(+), 903 deletions(-) create mode 100644 physics/noahmptable.tbl diff --git a/physics/noahmp_tables.f90 b/physics/noahmp_tables.f90 index 0e9f64af1..f43ea8608 100644 --- a/physics/noahmp_tables.f90 +++ b/physics/noahmp_tables.f90 @@ -13,991 +13,243 @@ module noahmp_tables integer, private, parameter :: mvt = 30 ! use 30 instead of 27 integer, private, parameter :: mband = 2 -! integer, private, parameter :: msc = 8 integer, private, parameter :: msc = 20 integer, private, parameter :: max_soiltyp = 30 integer, private, parameter :: ncrop = 5 integer, private, parameter :: nstage = 8 - - integer :: i - integer, private, parameter :: slcats = 30 + integer, private, parameter :: num_slope = 9 ! mptable.tbl vegetation parameters - integer :: isurban_table = 13 - integer :: iswater_table = 17 - integer :: isbarren_table = 16 - integer :: isice_table = 15 - integer :: iscrop_table = 12 - integer :: eblforest_table = 2 - integer :: natural_table = 14 - integer :: low_density_residential_table = 31 - integer :: high_density_residential_table = 32 - integer :: high_intensity_industrial_table = 33 - -! + integer :: isurban_table + integer :: iswater_table + integer :: isbarren_table + integer :: isice_table + integer :: iscrop_table + integer :: eblforest_table + integer :: natural_table + integer :: lcz_1_table + integer :: lcz_2_table + integer :: lcz_3_table + integer :: lcz_4_table + integer :: lcz_5_table + integer :: lcz_6_table + integer :: lcz_7_table + integer :: lcz_8_table + integer :: lcz_9_table + integer :: lcz_10_table + integer :: lcz_11_table real :: ch2op_table(mvt) !< maximum intercepted h2o per unit lai+sai (mm) - - data ( ch2op_table(i),i=1,mvt) / 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, & - & 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, & - & 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, & - & 0.1, 0.1, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / - real :: dleaf_table(mvt) !< characteristic leaf dimension (m) - data ( dleaf_table(i),i=1,mvt) / 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, & - & 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, & - & 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, & - & 0.04, 0.04, 0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / - real :: z0mvt_table(mvt) !< momentum roughness length (m) - data ( z0mvt_table(i),i=1,mvt) / 1.09, 1.10, 0.85, 0.80, 0.80, 0.20, & - & 0.06, 0.60, 0.50, 0.12, 0.30, 0.15, & - & 1.00, 0.14, 0.00, 0.00, 0.00, 0.30, & - & 0.20, 0.03, 0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / - -! - real :: hvt_table(mvt) !< top of canopy (m) - data ( hvt_table(i),i=1,mvt) / 20.0, 20.0, 18.0, 16.0, 16.0, 1.10, & - & 1.10, 13.0, 10.0, 1.00, 5.00, 2.00, & - & 15.0, 1.50, 0.00, 0.00, 0.00, 4.00, & - & 2.00, 0.50, 0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / - real :: hvb_table(mvt) !< bottom of canopy (m) - data ( hvb_table(i),i=1,mvt) / 8.50, 8.00, 7.00, 11.5, 10.0, 0.10, & - & 0.10, 0.10, 0.10, 0.05, 0.10, 0.10, & - & 1.00, 0.10, 0.00, 0.00, 0.00, 0.30, & - & 0.20, 0.10, 0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / - real :: den_table(mvt) !< tree density (no. of trunks per m2) - data ( den_table (i),i=1,mvt) / 0.28, 0.02, 0.28, 0.10, 0.10, 10.0, & - & 10.0, 10.0, 0.02, 100., 5.05, 25.0, & - & 0.01, 25.0, 0.00, 0.01, 0.01, 1.00, & - & 1.00, 1.00, 0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / -! real :: rc_table(mvt) !< tree crown radius (m) - - data ( rc_table (i),i=1,mvt) / 1.20, 3.60, 1.20, 1.40, 1.40, 0.12, & - & 0.12, 0.12, 3.00, 0.03, 0.75, 0.08, & - & 1.00, 0.08, 0.00, 0.01, 0.01, 0.30, & - & 0.30, 0.30, 0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / - real :: mfsno_table(mvt) !< snowmelt curve parameter () - data ( mfsno_table(i),i=1,mvt) / 1.00, 1.00, 1.00, 1.00, 1.00, 2.00, & - & 2.00, 2.00, 2.00, 2.00, 3.00, 3.00, & - & 4.00, 4.00, 2.50, 3.00, 3.00, 3.50, & - & 3.50, 3.50, 0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / - real :: scffac_table(mvt) !< snow cover factor (m) - data (scffac_table(i),i=1,mvt) / 0.005, 0.005, 0.005, 0.005, 0.005, & - & 0.008, 0.008, 0.010, 0.010, 0.010, & - & 0.010, 0.007, 0.021, 0.013, 0.015, & - & 0.008, 0.015, 0.015, 0.015, 0.015, & - & 0.000, 0.000, 0.000, 0.000, 0.000, & - & 0.000, 0.000, 0.000, 0.000, 0.000 / - -! - real :: saim_table(mvt,12) !< monthly stem area index, one-sided - - data (saim_table (i,1),i=1,mvt) / 0.4, 0.5, 0.3, 0.4, 0.4, 0.3, & - & 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, & - & 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, & - & 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / - - -! &_______________________________________________________________________& - - data (saim_table (i,2),i=1,mvt) / 0.4, 0.5, 0.3, 0.4, 0.4, 0.3, & - & 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, & - & 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, & - & 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / - - data (saim_table (i,3),i=1,mvt) / 0.4, 0.5, 0.3, 0.4, 0.4, 0.3, & - & 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, & - & 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, & - & 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / - - data (saim_table (i,4),i=1,mvt) / 0.3, 0.5, 0.4, 0.4, 0.4, 0.3, & - & 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, & - & 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, & - & 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / - -! &_______________________________________________________________________& - - data (saim_table (i,5),i=1,mvt) / 0.4, 0.5, 0.4, 0.4, 0.4, 0.3, & - & 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, & - & 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, & - & 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / - - data (saim_table (i,6),i=1,mvt) / 0.5, 0.5, 0.7, 0.4, 0.4, 0.3, & - & 0.2, 0.4, 0.4, 0.4, 0.4, 0.3, & - & 0.0, 0.4, 0.0, 0.0, 0.0, 0.2, & - & 0.2, 0.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / - - data (saim_table (i,7),i=1,mvt) / 0.5, 0.5, 1.3, 0.9, 0.7, 0.6, & - & 0.4, 0.7, 0.8, 0.8, 0.6, 0.4, & - & 0.0, 0.6, 0.0, 0.0, 0.0, 0.4, & - & 0.4, 0.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / - -! &_______________________________________________________________________& - - data (saim_table (i,8),i=1,mvt) / 0.6, 0.5, 1.2, 1.2, 0.8, 0.9, & - & 0.6, 1.2, 1.2, 1.3, 0.9, 0.5, & - & 0.0, 0.9, 0.0, 0.0, 0.0, 0.6, & - & 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / - - data (saim_table (i,9),i=1,mvt) / 0.6, 0.5, 1.0, 1.6, 1.0, 1.2, & - & 0.8, 1.4, 1.3, 1.1, 0.9, 0.4, & - & 0.0, 0.7, 0.0, 0.0, 0.0, 0.8, & - & 0.7, 0.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / - - data (saim_table (i,10),i=1,mvt) / 0.7, 0.5, 0.8, 1.4, 1.0, 0.9, & - & 0.7, 1.1, 0.7, 0.4, 0.6, 0.3, & - & 0.0, 0.3, 0.0, 0.0, 0.0, 0.7, & - & 0.5, 0.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / - -! &_______________________________________________________________________& - - data (saim_table (i,11),i=1,mvt) / 0.6, 0.5, 0.6, 0.6, 0.5, 0.4, & - & 0.3, 0.5, 0.4, 0.4, 0.4, 0.3, & - & 0.0, 0.3, 0.0, 0.0, 0.0, 0.3, & - & 0.3, 0.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / - - data (saim_table (i,12),i=1,mvt) / 0.5, 0.5, 0.5, 0.4, 0.4, 0.3, & - & 0.2, 0.4, 0.4, 0.4, 0.3, 0.3, & - & 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, & - & 0.2, 0.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / - -!! lai real :: laim_table(mvt,12) !< monthly leaf area index, one-sided - - data (laim_table (i,1),i=1,mvt) / 4.0, 4.5, 0.0, 0.0, 2.0, 0.0, & - & 0.0, 0.2, 0.3, 0.4, 0.2, 0.0, & - & 0.0, 0.2, 0.0, 0.0, 0.0, 1.0, & - & 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / - -! &_______________________________________________________________________& - - data (laim_table (i,2),i=1,mvt) / 4.0, 4.5, 0.0, 0.0, 2.0, 0.0, & - & 0.0, 0.2, 0.3, 0.5, 0.3, 0.0, & - & 0.0, 0.3, 0.0, 0.0, 0.0, 1.0, & - & 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / - - data (laim_table (i,3),i=1,mvt) / 4.0, 4.5, 0.0, 0.3, 2.2, 0.3, & - & 0.2, 0.4, 0.5, 0.6, 0.3, 0.0, & - & 0.0, 0.3, 0.0, 0.0, 0.0, 1.1, & - & 0.7, 0.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / - - data (laim_table (i,4),i=1,mvt) / 4.0, 4.5, 0.6, 1.2, 2.6, 0.9, & - & 0.6, 1.0, 0.8, 0.7, 0.5, 0.0, & - & 0.0, 0.4, 0.0, 0.0, 0.0, 1.3, & - & 0.8, 0.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / - -! &_______________________________________________________________________& - - data (laim_table (i,5),i=1,mvt) / 4.0, 4.5, 1.2, 3.0, 3.5, 2.2, & - & 1.5, 2.4, 1.8, 1.2, 1.5, 1.0, & - & 0.0, 1.1, 0.0, 0.0, 0.0, 1.7, & - & 1.2, 0.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / - - data (laim_table (i,6),i=1,mvt) / 4.0, 4.5, 2.0, 4.7, 4.3, 3.5, & - & 2.3, 4.1, 3.6, 3.0, 2.9, 2.0, & - & 0.0, 2.5, 0.0, 0.0, 0.0, 2.1, & - & 1.8, 0.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / - - data (laim_table (i,7),i=1,mvt) / 4.0, 4.5, 2.6, 4.5, 4.3, 3.5, & - & 2.3, 4.1, 3.8, 3.5, 3.5, 3.0, & - & 0.0, 3.2, 0.0, 0.0, 0.0, 2.1, & - & 1.8, 0.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / - -! &_______________________________________________________________________& - - data (laim_table (i,8),i=1,mvt) / 4.0, 4.5, 1.7, 3.4, 3.7, 2.5, & - & 1.7, 2.7, 2.1, 1.5, 2.7, 3.0, & - & 0.0, 2.2, 0.0, 0.0, 0.0, 1.8, & - & 1.3, 0.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / - - data (laim_table (i,9),i=1,mvt) / 4.0, 4.5, 1.0, 1.2, 2.6, 0.9, & - & 0.6, 1.0, 0.9, 0.7, 1.2, 1.5, & - & 0.0, 1.1, 0.0, 0.0, 0.0, 1.3, & - & 0.8, 0.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / - - data (laim_table (i,10),i=1,mvt) / 4.0, 4.5, 0.5, 0.3, 2.2, 0.3, & - & 0.2, 0.4, 0.5, 0.6, 0.3, 0.0, & - & 0.0, 0.3, 0.0, 0.0, 0.0, 1.1, & - & 0.7, 0.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / - -! &_______________________________________________________________________& - - data (laim_table (i,11),i=1,mvt) / 4.0, 4.5, 0.2, 0.0, 2.0, 0.0, & - & 0.0, 0.2, 0.3, 0.5, 0.3, 0.0, & - & 0.0, 0.3, 0.0, 0.0, 0.0, 1.0, & - & 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / - - data (laim_table (i,12),i=1,mvt) / 4.0, 4.5, 0.0, 0.0, 2.0, 0.0, & - & 0.0, 0.2, 0.3, 0.4, 0.2, 0.0, & - & 0.0, 0.2, 0.0, 0.0, 0.0, 1.0, & - & 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / - real :: sla_table(mvt) !< single-side leaf area per kg [m2/kg] - data ( sla_table (i),i=1,mvt) / 80, 80, 80, 80, 80, 60, & - & 60, 60, 50, 60, 80, 80, & - & 60, 80, 0, 0, 0, 80, & - & 80, 80, 0, 0, 0, 0, & - & 0, 0, 0, 0, 0, 0 / - real :: dilefc_table(mvt) !< coeficient for leaf stress death [1/s] - data (dilefc_table (i),i=1,mvt) / 1.20, 0.50, 1.80, 0.60, 0.80, 0.20, & - & 0.20, 0.20, 0.50, 0.20, 0.4, 0.50, & - & 0.00, 0.35, 0.00, 0.00, 0.00, 0.30, & - & 0.40, 0.30, 0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / - real :: dilefw_table(mvt) !< coeficient for leaf stress death [1/s] - data (dilefw_table(i),i=1,mvt) / 0.20, 4.00, 0.20, 0.20, 0.20, 0.20, & - & 0.20, 0.20, 0.50, 0.10, 0.2, 0.20, & - & 0.00, 0.20, 0.00, 0.00, 0.00, 0.20, & - & 0.20, 0.20, 0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / - real :: fragr_table(mvt) !< fraction of growth respiration !original was 0.3 - data ( fragr_table(i),i=1,mvt) / 0.10, 0.20, 0.10, 0.20, 0.10, 0.20, & - & 0.20, 0.20, 0.20, 0.20, 0.1, 0.20, & - & 0.00, 0.20, 0.00, 0.10, 0.00, 0.10, & - & 0.10, 0.10, 0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / - real :: ltovrc_table(mvt) !< leaf turnover [1/s] - data ( ltovrc_table(i),i=1,mvt) / 0.5, 0.55, 0.2, 0.55, 0.5, 0.65, & - & 0.65, 0.65, 0.65, 0.50, 1.4, 1.6, & - & 0.0, 1.2, 0.0, 0.0, 0.0, 1.3, & - & 1.4, 1.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / -! real :: c3psn_table(mvt) !< photosynthetic pathway: 0. = c4, 1. = c3 - data ( c3psn_table (i),i=1,mvt) / 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, & - & 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, & - & 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, & - & 1.0, 1.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / - real :: kc25_table(mvt) !< co2 michaelis-menten constant at 25c (pa) - data ( kc25_table (i),i=1,mvt) / 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, & - & 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, & - & 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, & - & 30.0, 30.0, 0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / - real :: akc_table(mvt) !< q10 for kc25 - data ( akc_table (i),i=1,mvt) / 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, & - & 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, & - & 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, & - & 2.1, 2.1, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / - - real :: ko25_table(mvt) !< o2 michaelis-menten constant at 25c (pa) - data ( ko25_table (i),i=1,mvt) / 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, & - & 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, & - & 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, & - & 3.e4, 3.e4, 0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / - - real :: ako_table(mvt) !< q10 for ko25 - data ( ako_table (i),i=1,mvt) / 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, & - & 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, & - & 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, & - & 1.2, 1.2, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / - real :: vcmx25_table(mvt) !< maximum rate of carboxylation at 25c (umol co2/m**2/s) - data ( vcmx25_table(i),i=1,mvt) / 50.0, 60.0, 60.0, 60.0, 55.0, 40.0, & - & 40.0, 40.0, 40.0, 40.0, 50.0, 80.0, & - & 0.00, 60.0, 0.00, 0.00, 0.00, 50.0, & - & 50.0, 50.0, 0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / - - real :: avcmx_table(mvt) !< q10 for vcmx25 - data ( avcmx_table (i),i=1,mvt) / 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, & - & 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, & - & 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, & - & 2.4, 2.4, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / - - - real :: bp_table(mvt) !< minimum leaf conductance (umol/m**2/s) - data ( bp_table (i),i=1,mvt) / 2.e3, 2.e3, 2.e3, 2.e3, 2.e3, 2.e3, & - & 2.e3, 2.e3, 2.e3, 2.e3, 2.e3, 2.e3, & - & 1.e15, 2.e3,1.e15, 2.e3,1.e15, 2.e3, & - & 2.e3, 2.e3, 0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / - real :: mp_table(mvt) !< slope of conductance-to-photosynthesis relationship - data ( mp_table (i),i=1,mvt) / 6., 9., 6., 9., 9., 9., & - & 9., 9., 9., 9., 9., 9., & - & 9., 9., 9., 9., 9., 9., & - & 9., 9., 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / - real :: qe25_table(mvt) !< quantum efficiency at 25c (umol co2 / umo photon) - data ( qe25_table (i),i=1,mvt) / 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, & - & 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, & - & 0.00, 0.06, 0.00, 0.06, 0.00, 0.06, & - & 0.06, 0.06, 0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / - real :: aqe_table(mvt) !< q10 for qe25 - data ( aqe_table (i),i=1,mvt) / 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, & - & 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, & - & 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, & - & 1.0, 1.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / - real :: rmf25_table(mvt) !< leaf maintenance respiration at 25c (umol co2/m**2/s) - data ( rmf25_table (i),i=1,mvt) / 3.00, 0.65, 4.00, 3.00, 3.00, 0.26, & - & 0.26, 0.26, 0.80, 1.80, 3.2, 1.00, & - & 0.00, 1.45, 0.00, 0.00, 0.00, 3.00, & - & 3.00, 3.00, 0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / - real :: rms25_table(mvt) !< stem maintenance respiration at 25c (umol co2/kg bio/s) - data ( rms25_table (i),i=1,mvt) / 0.90, 0.30, 0.64, 0.10, 0.80, 0.10, & - & 0.10, 0.10, 0.32, 0.10, 0.10, 0.10, & - & 0.00, 0.10, 0.00, 0.00, 0.00, 0.10, & - & 0.10, 0.00, 0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / - real :: rmr25_table(mvt) !< root maintenance respiration at 25c (umol co2/kg bio/s) - data ( rmr25_table (i),i=1,mvt) / 0.36, 0.05, 0.05, 0.01, 0.03, 0.00, & - & 0.00, 0.00, 0.01, 1.20, 0.0, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 2.11, & - & 2.11, 0.00, 0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / - real :: arm_table(mvt) !< q10 for maintenance respiration - data ( arm_table (i),i=1,mvt) / 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, & - & 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, & - & 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, & - & 2.0, 2.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / - real :: folnmx_table(mvt) !< foliage nitrogen concentration when f(n)=1 (%) - data (folnmx_table (i),i=1,mvt) / 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, & - & 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, & - & 0.00, 1.5, 0.00, 1.5, 0.00, 1.5, & - & 1.5, 1.5, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / - real :: tmin_table(mvt) !< minimum temperature for photosynthesis (k) - data ( tmin_table (i),i=1,mvt) / 265, 273, 268, 273, 268, 273, & - & 273, 273, 273, 273, 268, 273, & - & 0, 273, 0, 0, 0, 268, & - & 268, 268, 0, 0, 0, 0, & - & 0, 0, 0, 0, 0, 0 / - -! real :: xl_table(mvt) !< leaf/stem orientation index - data ( xl_table (i),i=1,mvt) / 0.010,0.010,0.010,0.250,0.250,0.010, & - & 0.010, 0.010, 0.010, -0.30, -0.025, -0.30, & - & 0.000, -0.30, 0.000, 0.000, 0.000, 0.250, & - & 0.250, 0.250, 0.000, 0.000, 0.000, 0.000, & - & 0.001, 0.001, 0.000, 0.000, 0.000, 0.000 / -! real :: rhol_table(mvt,mband) !< leaf reflectance: 1=vis, 2=nir - - data ( rhol_table (i,1),i=1,mvt) / 0.07, 0.10, 0.07, 0.10, 0.10, 0.07, & - & 0.07, 0.07, 0.10, 0.11, 0.105, 0.11, & - & 0.00, 0.11, 0.00, 0.00, 0.00, 0.10, & - & 0.10, 0.10, 0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / - -! &_______________________________________________________________________& - - data ( rhol_table (i,2),i=1,mvt) / 0.35, 0.45, 0.35, 0.45, 0.45, 0.35, & - & 0.35, 0.35, 0.45, 0.58, 0.515, 0.58, & - & 0.00, 0.58, 0.00, 0.00, 0.00, 0.45, & - & 0.45, 0.45, 0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / - real :: rhos_table(mvt,mband) !< stem reflectance: 1=vis, 2=nir - - data ( rhos_table (i,1),i=1,mvt) / 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, & - & 0.16, 0.16, 0.16, 0.36, 0.26, 0.36, & - & 0.00, 0.36, 0.00, 0.00, 0.00, 0.16, & - & 0.16,0.16, 0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / - - data ( rhos_table (i,2),i=1,mvt) / 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, & - & 0.39, 0.39, 0.39, 0.58, 0.485, 0.58, & - & 0.00, 0.58, 0.00, 0.00, 0.00, 0.39, & - & 0.39, 0.39, 0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / - -! &_______________________________________________________________________& - real :: taul_table(mvt,mband) !< leaf transmittance: 1=vis, 2=nir -! - data ( taul_table (i,1),i=1,mvt) / 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, & - & 0.05, 0.05, 0.05, 0.07, 0.06, 0.07, & - & 0.00, 0.07, 0.00, 0.00, 0.00, 0.05, & - & 0.05, 0.05,0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / - - data ( taul_table (i,2),i=1,mvt) / 0.10, 0.25, 0.10, 0.25, 0.25, 0.10, & - & 0.10, 0.10, 0.25, 0.25, 0.25, 0.25, & - & 0.00, 0.25, 0.00, 0.00, 0.00, 0.25, & - & 0.25, 0.25, 0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / - real :: taus_table(mvt,mband) !< stem transmittance: 1=vis, 2=nir - data(taus_table (i,1),i=1,mvt) / 0.001,0.001,0.001,0.001,0.001, 0.001, & - & 0.001, 0.001, 0.001, 0.220, 0.1105,0.220, & - & 0.000, 0.220, 0.000, 0.000, 0.000, 0.001, & - & 0.001, 0.001, 0.000, 0.000, 0.000, 0.000, & - & 0.001, 0.001, 0.000, 0.000, 0.000, 0.000 / - - - data(taus_table (i,2),i=1,mvt) / 0.001,0.001,0.001,0.001,0.001, 0.001, & - & 0.001, 0.001, 0.001, 0.380, 0.1905, 0.380, & - & 0.000, 0.380, 0.000, 0.000, 0.000, 0.001, & - & 0.001, 0.001, 0.000, 0.000, 0.000, 0.000, & - & 0.001, 0.001, 0.000, 0.000, 0.000, 0.000 / - real :: mrp_table(mvt) !< microbial respiration parameter (umol co2 /kg c/ s) - data ( mrp_table (i),i=1,mvt) / 0.37, 0.23, 0.37, 0.40, 0.30, 0.19, & - & 0.19, 0.19, 0.40, 0.17,0.285, 0.23, & - & 0.00, 0.23, 0.00, 0.00, 0.00, 0.23, & - & 0.20, 0.00, 0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / - -! real :: cwpvt_table(mvt) !< empirical canopy wind parameter - data ( cwpvt_table (i),i=1,mvt) / 0.09, 0.335, 0.09, 0.335, 0.145, 0.50, & - & 1.00, 0.65, 0.50, 2.50, 0.585, 0.835, & - & 0.835, 0.835, 0.09, 0.09, 0.09, 0.335, & - & 0.50, 0.09, 0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / - real :: wrrat_table(mvt) !< wood to non-wood ratio - data ( wrrat_table (i),i=1,mvt) / 30.0, 30.0, 30.0, 30.0, 30.0, 3.00, & - & 3.00, 3.00, 3.00, 0.00, 15.0, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 3.00, & - & 3.00, 0.00, 0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / - real :: wdpool_table(mvt) !< wood pool (switch 1 or 0) depending on woody or not [-] - data ( wdpool_table(i),i=1,mvt) / 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, & - & 1.00, 1.00, 1.00, 0.00, 0.5, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 1.00, & - & 1.00, 0.00, 0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / - real :: tdlef_table(mvt) !< characteristic t for leaf freezing [k] - data ( tdlef_table (i),i=1,mvt) / 278, 278, 268, 278, 268, 278, & - & 278, 278, 278, 278, 268, 278, & - & 278, 278, 0, 0, 0, 268, & - & 268, 268, 0, 0, 0, 0, & - & 0, 0, 0, 0, 0, 0 / - real :: nroot_table(mvt) !< number of soil layers with root present - data ( nroot_table (i),i=1,mvt) / 4, 4, 4, 4, 4, 3, & - & 3, 3, 3, 3, 2, 3, & - & 1, 3, 1, 1, 0, 3, & - & 3, 2, 0, 0, 0, 0, & - & 0, 0, 0, 0, 0, 0 / - real :: rgl_table(mvt) !< parameter used in radiation stress function - data ( rgl_table (i),i=1,mvt) / 30.0, 30.0, 30.0, 30.0, 30.0, 100.0,& - & 100.0, 100.0, 65.0, 100.0, 65.0, 100.0, & - & 999.0, 100.0, 999.0, 999.0, 30.0, 100.0, & - & 100.0, 100.0, 0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / - real :: rs_table(mvt) !< minimum stomatal resistance [s m-1] - data ( rs_table (i),i=1,mvt) / 125.0, 150.0,150.0,100.0,125.0,300.0,& - & 170.0,300.0, 70.0, 40.0, 70.0, 40.0, & - & 200.0, 40.0, 999.0,999.0,100.0,150.0, & - & 150.0, 200.0,0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / - real :: hs_table(mvt) !< parameter used in vapor pressure deficit function - data ( hs_table (i),i=1,mvt) / 47.35,41.69,47.35,54.53,51.93,42.00, & - & 39.18, 42.00, 54.53, 36.35, 55.97, 36.25, & - & 999.0, 36.25, 999.0, 999.0, 51.75, 42.00, & - & 42.00, 42.00, 0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / - - real :: topt_table(mvt) !< optimum transpiration air temperature [k] - data ( topt_table (i),i=1,mvt) / 298.0,298.0,298.0,298.0,298.0,298.0, & - & 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, & - & 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, & - & 298.0, 298.0, 0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / - real :: rsmax_table(mvt) !< maximal stomatal resistance [s m-1] - data ( rsmax_table (i),i=1,mvt) / 5000., 5000.,5000.,5000.,5000.,5000.,& - & 5000., 5000., 5000., 5000., 5000., 5000., & - & 5000., 5000., 5000., 5000., 5000., 5000., & - & 5000., 5000., 0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / - -!!!!!!!!!!!!!! Wield not defined but read !!!!!!!!!!!!!!!!1 - - real :: slarea_table(mvt) - - data (slarea_table (i),i=1,mvt) / 0.0090,0.0200,0.0200,0.0258,0.0223, & - & 0.0227, 0.0188, 0.0227, 0.0236, 0.0060, & - & 0.0295, 0.0200, 0.0228, 0.0223, 0.02, & - & 0.02, 0.0422, 0.02, 0.02, 0.02, & - & 0.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0 / - -! &_______________________________________________________________________& - - real :: esp1_table(mvt) - - data (esp1_table (i),i=1,mvt) / 0.46, 0.00, 0.00,46.86,30.98, 21.62, & - & 0.11, 21.62, 22.80, 0.02, 0.815, 0.00, & - & 41.87, 0.04, 0.0, 0.0, 2.31, 0.0, & - & 0.0, 0.0,0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / - - real :: esp2_table(mvt) - - data (esp2_table (i),i=1,mvt) / 3.34, 0.00, 0.00, 0.38, 0.96, 0.92, & - & 0.22, 0.92, 0.59, 0.05, 0.535, 0.00, & - & 0.98, 0.09, 0.0, 0.0, 1.47, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / - - - real :: esp3_table(mvt) - - data (esp3_table (i),i=1,mvt) / 1.85, 0.00, 0.00, 1.84, 1.84, 1.73, & - & 1.26, 1.73, 1.37, 0.03, 0.605, 0.00, & - & 1.82, 0.05, 0.0, 0.0, 1.70, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / - - -! &_______________________________________________________________________& - - real :: esp4_table(mvt) - - data (esp4_table (i),i=1,mvt) / 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / - real :: esp5_table(mvt) - - data (esp5_table (i),i=1,mvt) / 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / - -!!!!!!!!!!!!!!!!!!! what are the tables used for !!!!!!!!!!!!!! ! soilparm.tbl parameters - real :: bexp_table(max_soiltyp) - - data (bexp_table(i), i=1,slcats) /2.79, 4.26, 4.74, 5.33, 3.86, 5.25,& - & 6.77, 8.72, 8.17, 10.73, 10.39, 11.55, & - & 5.25, 0.0, 2.79, 4.26, 11.55, 2.79, & - & 2.79, 0.00, 0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + integer :: slcats + real :: bexp_table(max_soiltyp) real :: smcdry_table(max_soiltyp) - data (smcdry_table(i), i=1,slcats) /0.010, 0.028, 0.047, 0.084, 0.061,& - & 0.066, 0.069, 0.120, 0.103, 0.100, 0.126, 0.138, & - & 0.066, 0.0, 0.006, 0.028, 0.030, 0.006, & - & 0.010, 0.000, 0.000, 0.000, 0.000, 0.000, & - & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000 / - real :: f1_table(max_soiltyp) - - data (f1_table(i), i=1,slcats) /-0.472, -1.044, -0.569, 0.162, 0.162, & - & -0.327, -1.491, -1.118, -1.297, -3.209, -1.916, -2.138, & - & -0.327, 0.000, -1.111, -1.044, -10.472, -0.472, & - & -0.472, 0.000, 0.000, 0.000, 0.000, 0.000, & - & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000 / - real :: smcmax_table(max_soiltyp) - - data (smcmax_table(i), i=1,slcats) /0.339, 0.421, 0.434, 0.476, 0.484,& - & 0.439, 0.404, 0.464, 0.465, 0.406, 0.468, 0.468, & - & 0.439, 1.000, 0.200, 0.421, 0.468, 0.200, & - & 0.339, 0.339, 0.000, 0.000, 0.000, 0.000, & - & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000 / - real :: smcref_table(max_soiltyp) - - data (smcref_table(i), i=1,slcats) /0.192, 0.283, 0.312, 0.360, 0.347, & - & 0.329, 0.315, 0.387, 0.382, 0.338, 0.404, 0.412, & - & 0.329, 0.000, 0.170, 0.283, 0.454, 0.170, & - & 0.192, 0.000, 0.000, 0.000, 0.000, 0.000, & - & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000 / - real :: psisat_table(max_soiltyp) - - data (psisat_table(i), i=1,slcats) /0.069, 0.036, 0.141, 0.759, 0.955, & - & 0.355, 0.135, 0.617, 0.263, 0.098, 0.324, 0.468, & - & 0.355, 0.00, 0.069, 0.036, 0.468, 0.069, & - & 0.069, 0.00, 0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / - real :: dksat_table(max_soiltyp) - - data (dksat_table(i), i=1,slcats) /4.66e-5, 1.41e-5, 5.23e-6, 2.81e-6, & - & 2.18e-6, 3.38e-6, 4.45e-6, 2.03e-6, 2.45e-6,7.22e-6, & - & 1.34e-6, 9.74e-7, 3.38e-6, 0.00, 1.41e-4, & - & 1.41e-5, 9.74e-7, 1.41e-4, 4.66e-5,0.0, & - & 0.00, 0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00 / - real :: dwsat_table(max_soiltyp) - - data (dwsat_table(i), i=1,slcats) / 2.65e-5, 5.14e-6, 8.05e-6, & - & 2.39e-5, 1.66e-5, 1.43e-5, 1.01e-5, 2.35e-5, 1.13e-5, 1.87e-5, & - & 9.64e-6, 1.12e-5, 1.43e-5, 0.00, 1.36e-4, 5.14e-6, & - & 1.12e-5, 1.36e-4, 2.65e-5, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00 / - real :: smcwlt_table(max_soiltyp) - - data (smcwlt_table(i), i=1,slcats) /0.010, 0.028, 0.047, 0.084, 0.061,& - & 0.066, 0.069, 0.120, 0.103, 0.100, 0.126, 0.138, & - & 0.066, 0.000, 0.006, 0.028, 0.030, 0.006, & - & 0.010, 0.000, 0.000, 0.000, 0.000, 0.000, & - & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000 / - real :: quartz_table(max_soiltyp) - - data (quartz_table(i), i=1,slcats) /0.92, 0.82, 0.60, 0.25, 0.10, & - & 0.40, 0.60, 0.10, 0.35, 0.52, 0.10, & - & 0.25, 0.05, 0.60, 0.07, 0.25, 0.60, & - & 0.52, 0.92, 0.00, 0.00, 0.00, 0.00,0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / - + real :: bvic_table(max_soiltyp) !vic model infiltration parameter (-) for opt_run=6 + real :: axaj_table(max_soiltyp) !Xinanjiang: Tension water distribution inflection parameter [-] for opt_run=7 + real :: bxaj_table(max_soiltyp) !Xinanjiang: Tension water distribution shape parameter [-] for opt_run=7 + real :: xxaj_table(max_soiltyp) !Xinanjiang: Free water distribution shape parameter [-] for opt_run=7 + real :: bdvic_table(max_soiltyp) !VIC model infiltration parameter (-) + real :: gdvic_table(max_soiltyp) !mean capilary drive (m) + real :: bbvic_table(max_soiltyp) !heterogeniety parameter for DVIC infiltration [-] ! genparm.tbl parameters - real :: slope_table(9) !< slope factor for soil drainage - data (slope_table(i), i=1,9) /0.1, 0.6, 1.0, 0.35, 0.55, 0.8, & - & 0.63, 0.0, 0.0 / + real :: slope_table(num_slope) !< slope factor for soil drainage - real :: csoil_table = 2.00e+6 !< soil heat capacity [j m-3 k-1] - real :: refdk_table = 2.0e-6 !< parameter in the surface runoff parameterization - real :: refkdt_table = 3.0 !< parameter in the surface runoff parameterization - real :: frzk_table =0.15 !< frozen ground parameter - real :: zbot_table = -8.0 !< depth [m] of lower boundary soil temperature - real :: czil_table = 0.1 !< parameter used in the calculation of the roughness length for heat + real :: csoil_table !< soil heat capacity [j m-3 k-1] + real :: refdk_table !< parameter in the surface runoff parameterization + real :: refkdt_table !< parameter in the surface runoff parameterization + real :: frzk_table !< frozen ground parameter + real :: zbot_table !< depth [m] of lower boundary soil temperature + real :: czil_table !< parameter used in the calculation of the roughness length for heat ! mptable.tbl radiation parameters -! &_______________________________________________________________________& real :: albsat_table(msc,mband) !< saturated soil albedos: 1=vis, 2=nir -! data(albsat_table(i,1),i=1,8)/0.15,0.11,0.10,0.09,0.08,0.07,0.06,0.05/ -! data(albsat_table(i,2),i=1,8)/0.30,0.22,0.20,0.18,0.16,0.14,0.12,0.10/ - - data(albsat_table(i,1),i=1,20) /0.25,0.23,0.21,0.20,0.19,0.18,0.17,0.16,& - & 0.15,0.14,0.13,0.12,0.11,0.10,0.09,0.08,0.07,0.06,0.05,0.04 / - - data(albsat_table(i,2),i=1,20) /0.50,0.46,0.42,0.40,0.38,0.36,0.34,0.32,& - & 0.30,0.28,0.26,0.24,0.22,0.20,0.18,0.16,0.14,0.12,0.10,0.08 / - real :: albdry_table(msc,mband) !< dry soil albedos: 1=vis, 2=nir -! data(albdry_table(i,1),i=1,8)/0.27,0.22,0.20,0.18,0.16,0.14,0.12,0.10/ -! data(albdry_table(i,2),i=1,8)/0.54,0.44,0.40,0.36,0.32,0.28,0.24,0.20/ - - data(albdry_table(i,1),i=1,20) /0.36,0.34,0.32,0.31,0.30,0.29,0.28,0.27,& - & 0.26,0.25,0.24,0.23,0.22,0.20,0.18,0.16,0.14,0.12,0.10,0.08/ - - data(albdry_table(i,2),i=1,20) /0.61,0.57,0.53,0.51,0.49,0.48,0.45,0.43,& - & 0.41,0.39,0.37,0.35,0.33,0.31,0.29,0.27,0.25,0.23,0.21,0.16/ - real :: albice_table(mband) !< albedo land ice: 1=vis, 2=nir - data (albice_table(i),i=1,mband) /0.80, 0.55/ - real :: alblak_table(mband) !< albedo frozen lakes: 1=vis, 2=nir - data (alblak_table(i),i=1,mband) /0.60, 0.40/ - real :: omegas_table(mband) !< two-stream parameter omega for snow - data (omegas_table(i),i=1,mband) /0.8, 0.4/ - - real :: betads_table = 0.5 !< two-stream parameter betad for snow - real :: betais_table = 0.5 !< two-stream parameter betad for snow - - real :: eg_table(2) !< emissivity - data eg_table /0.97, 0.98 / - - real :: betads, betais - data betads, betais /0.5, 0.5/ - + real :: betads_table !< two-stream parameter betad for snow + real :: betais_table !< two-stream parameter betad for snow + real :: eg_table(2) !< emissivity ! mptable.tbl global parameters - real :: co2_table = 395.e-06 !< co2 partial pressure - real :: o2_table = 0.209 !< o2 partial pressure - real :: timean_table = 10.5 !< gridcell mean topgraphic index (global mean) - real :: fsatmx_table = 0.38 !< maximum surface saturated fraction (global mean) - - real :: z0sno_table = 0.002 !< snow surface roughness length (m) (0.002) - real :: ssi_table = 0.03 !< liquid water holding capacity for snowpack (m3/m3) (0.03) - real :: snow_ret_fac_table = 5.e-5 !< snowpack water release timescale factor (1/s) - real :: swemx_table = 1.00 !< new snow mass to fully cover old snow (mm) - - real :: tau0_table = 1.e6 !< tau0 from yang97 eqn. 10a - real :: grain_growth_table = 5000. !< growth from vapor diffusion yang97 eqn. 10b - real :: extra_growth_table = 10. !< extra growth near freezing yang97 eqn. 10c - real :: dirt_soot_table = 0.3 !< dirt and soot term yang97 eqn. 10d - real :: bats_cosz_table = 2.0 !< zenith angle snow albedo adjustment; b in yang97 eqn. 15 - real :: bats_vis_new_table = 0.95 !< new snow visible albedo - real :: bats_nir_new_table = 0.65 !< new snow nir albedo - real :: bats_vis_age_table = 0.2 !< age factor for diffuse visible snow albedo yang97 eqn. 17 - real :: bats_nir_age_table = 0.5 !< age factor for diffuse nir snow albedo yang97 eqn. 18 - real :: bats_vis_dir_table = 0.4 !< cosz factor for direct visible snow albedo yang97 eqn. 15 - real :: bats_nir_dir_table = 0.4 !< cosz factor for direct nir snow albedo yang97 eqn. 16 - real :: rsurf_snow_table = 50.0 !< surface resistance for snow(s/m) - real :: rsurf_exp_table = 5.0 !< exponent in the shape parameter for soil resistance option 1 - real :: snow_emis_table = 0.95 !< surface emissivity - - -! Noah mp crops -! mptable.tbl crop parameters -! ! NCROP = 5 -! 1: Corn -! 2: Soybean -! 3: Sorghum -! 4: Rice -! 5: Winter wheat + real :: co2_table !< co2 partial pressure + real :: o2_table !< o2 partial pressure + real :: timean_table !< gridcell mean topgraphic index (global mean) + real :: fsatmx_table !< maximum surface saturated fraction (global mean) + real :: z0sno_table !< snow surface roughness length (m) (0.002) + real :: ssi_table !< liquid water holding capacity for snowpack (m3/m3) (0.03) + real :: snow_ret_fac_table !< snowpack water release timescale factor (1/s) + real :: snow_emis_table !< surface emissivity + real :: swemx_table !< new snow mass to fully cover old snow (mm) + real :: tau0_table !< tau0 from yang97 eqn. 10a + real :: grain_growth_table !< growth from vapor diffusion yang97 eqn. 10b + real :: extra_growth_table !< extra growth near freezing yang97 eqn. 10c + real :: dirt_soot_table !< dirt and soot term yang97 eqn. 10d + real :: bats_cosz_table !< zenith angle snow albedo adjustment; b in yang97 eqn. 15 + real :: bats_vis_new_table !< new snow visible albedo + real :: bats_nir_new_table !< new snow nir albedo + real :: bats_vis_age_table !< age factor for diffuse visible snow albedo yang97 eqn. 17 + real :: bats_nir_age_table !< age factor for diffuse nir snow albedo yang97 eqn. 18 + real :: bats_vis_dir_table !< cosz factor for direct visible snow albedo yang97 eqn. 15 + real :: bats_nir_dir_table !< cosz factor for direct nir snow albedo yang97 eqn. 16 + real :: rsurf_snow_table !< surface resistance for snow(s/m) + real :: rsurf_exp_table !< exponent in the shape parameter for soil resistance option 1 + +! mptable.tbl irrigation parameters + + real :: irr_frac_table ! irrigation Fraction + integer :: irr_har_table ! number of days before harvest date to stop irrigation + real :: irr_lai_table ! Minimum lai to trigger irrigation + real :: irr_mad_table ! management allowable deficit (0-1) + real :: filoss_table ! fraction of flood irrigation loss (0-1) + real :: sprir_rate_table ! mm/h, sprinkler irrigation rate + real :: micir_rate_table ! mm/h, micro irrigation rate + real :: firtfac_table ! flood application rate factor + real :: ir_rain_table ! maximum precipitation to stop irrigation trigger +! mptable.tbl crop parameters -! &_______________________________________________________________________& + integer :: default_crop_table ! Default crop index integer :: pltday_table(ncrop) !< planting date - data (pltday_table(i), i=1,5) /130,111,111,111,111/ - integer :: hsday_table(ncrop) !< harvest date - data (hsday_table(i),i=1,5) /280,300,300,300,300/ - real :: plantpop_table(ncrop) !< plant density [per ha] - used? - data (plantpop_table(i),i=1,5) /78.0,78.0,78.0,78.0,78.0/ - real :: irri_table(ncrop) !< irrigation strategy 0= non-irrigation 1=irrigation (no water-stress) - data (irri_table(i),i=1,5) /0.0,0.0,0.0,0.0,0.0/ real :: gddtbase_table(ncrop) !< base temperature for gdd accumulation [c] - data (gddtbase_table(i),i=1,5) /10.0,10.0,10.0,10.0,10.0/ - real :: gddtcut_table(ncrop) !< upper temperature for gdd accumulation [c] - data (gddtcut_table(i),i=1,5) /30.0,30.0,30.0,30.0,30.0/ - real :: gdds1_table(ncrop) !< gdd from seeding to emergence - data (gdds1_table(i),i=1,5) /60.0,50.0,50.0,50.0,50.0/ - real :: gdds2_table(ncrop) !< gdd from seeding to initial vegetative - data (gdds2_table(i),i=1,5) /675.0,718.0,718.0,718.0,718.0/ - real :: gdds3_table(ncrop) !< gdd from seeding to post vegetative - data (gdds3_table(i),i=1,5) /1183.0,933.0,933.0,933.0,933.0/ - real :: gdds4_table(ncrop) !< gdd from seeding to intial reproductive - data (gdds4_table(i),i=1,5) /1253.0,1103.0,1103.0,1103.0,1103.0/ - real :: gdds5_table(ncrop) !< gdd from seeding to pysical maturity - data (gdds5_table(i),i=1,5) /1605.0,1555.0,1555.0,1555.0,1555.0/ - integer :: c3c4_table(ncrop) !< photosynthetic pathway: 1. = c3 2. = c4 - data (c3c4_table(i),i=1,5) /2.0,1.0,2.0,2.0,2.0/ + real :: c3psni_table(ncrop) !photosynthetic pathway: 0. = c4, 1. = c3 ! Zhe Zhang 2020-07-03 + real :: kc25i_table(ncrop) !co2 michaelis-menten constant at 25c (pa) + real :: akci_table(ncrop) !q10 for kc25 + real :: ko25i_table(ncrop) !o2 michaelis-menten constant at 25c (pa) + real :: akoi_table(ncrop) !q10 for ko25 + real :: vcmx25i_table(ncrop) !maximum rate of carboxylation at 25c (umol co2/m**2/s) + real :: avcmxi_table(ncrop) !q10 for vcmx25 + real :: bpi_table(ncrop) !minimum leaf conductance (umol/m**2/s) + real :: mpi_table(ncrop) !slope of conductance-to-photosynthesis relationship + real :: qe25i_table(ncrop) !quantum efficiency at 25c (umol co2 / umol photon) + real :: folnmxi_table(ncrop) !foliage nitrogen concentration when + integer :: c3c4_table(ncrop) !< photosynthetic pathway: 1. = c3 2. = c4 real :: aref_table(ncrop) !< reference maximum co2 assimulation rate - data (aref_table(i),i=1,5) /7.0,7.0,7.0,7.0,7.0/ - real :: psnrf_table(ncrop) !< co2 assimulation reduction factor(0-1) (caused by non-modeling part,e.g.pest,weeds) - data (psnrf_table(i),i=1,5) /0.85,0.85,0.85,0.85,0.85/ - real :: i2par_table(ncrop) !< fraction of incoming solar radiation to photosynthetically active radiation - data (i2par_table(i),i=1,5) / 0.5,0.5,0.5,0.5,0.5/ - real :: tassim0_table(ncrop) !< minimum temperature for co2 assimulation [c] - data (tassim0_table(i),i=1,5) /8.0,8.0,8.0,8.0,8.0/ - real :: tassim1_table(ncrop) !< co2 assimulation linearly increasing until temperature reaches t1 [c] - data (tassim1_table(i),i=1,5) /18.0,18.0,18.0,18.0,18.0/ - real :: tassim2_table(ncrop) !< co2 assmilation rate remain at aref until temperature reaches t2 [c] - data (tassim2_table(i),i=1,5) /30.0,30.0,30.0,30.0,30.0/ - real :: k_table(ncrop) !< light extinction coefficient - data ( k_table(i),i=1,5) /0.55,0.55,0.55,0.55,0.55/ - real :: epsi_table(ncrop) !< initial light use efficiency - data (epsi_table(i),i=1,5) /12.5,12.5,12.5,12.5,12.5/ real :: q10mr_table(ncrop) !< q10 for maintainance respiration - data (q10mr_table(i),i=1,5) /2.0,2.0,2.0,2.0,2.0/ - real :: foln_mx_table(ncrop) !< foliage nitrogen concentration when f(n)=1 (%) - data (foln_mx_table(i),i=1,5) /1.5,1.5,1.5,1.5,1.5/ - real :: lefreez_table(ncrop) !< characteristic t for leaf freezing [k] - data (lefreez_table(i),i=1,5) /268,268,268,268,268/ - real :: dile_fc_table(ncrop,nstage) !< coeficient for temperature leaf stress death [1/s] - data (dile_fc_table(i,1),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - data (dile_fc_table(i,2),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - data (dile_fc_table(i,3),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - data (dile_fc_table(i,4),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - data (dile_fc_table(i,5),i=1,5) /0.5,0.5,0.5,0.5,0.5/ - data (dile_fc_table(i,6),i=1,5) /0.5,0.5,0.5,0.5,0.5/ - data (dile_fc_table(i,7),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - data (dile_fc_table(i,8),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - real :: dile_fw_table(ncrop,nstage) !< coeficient for water leaf stress death [1/s] - data (dile_fw_table(i,1),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - data (dile_fw_table(i,2),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - data (dile_fw_table(i,3),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - data (dile_fw_table(i,4),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - data (dile_fw_table(i,5),i=1,5) /0.2,0.2,0.2,0.2,0.2/ - data (dile_fw_table(i,6),i=1,5) /0.2,0.2,0.2,0.2,0.2/ - data (dile_fw_table(i,7),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - data (dile_fw_table(i,8),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - real :: fra_gr_table(ncrop) !< fraction of growth respiration - data (fra_gr_table(i),i=1,5) /0.2,0.2,0.2,0.2,0.2/ real :: lf_ovrc_table(ncrop,nstage) !< fraction of leaf turnover [1/s] - data (lf_ovrc_table(i,1),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - data (lf_ovrc_table(i,2),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - data (lf_ovrc_table(i,3),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - data (lf_ovrc_table(i,4),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - data (lf_ovrc_table(i,5),i=1,5) /0.2,0.48,0.48,0.48,0.48/ - data (lf_ovrc_table(i,6),i=1,5) /0.3,0.48,0.48,0.48,0.48/ - data (lf_ovrc_table(i,7),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - data (lf_ovrc_table(i,8),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - real :: st_ovrc_table(ncrop,nstage) !< fraction of stem turnover [1/s] - data (st_ovrc_table(i,1),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - data (st_ovrc_table(i,2),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - data (st_ovrc_table(i,3),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - data (st_ovrc_table(i,4),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - data (st_ovrc_table(i,5),i=1,5) /0.12,0.12,0.12,0.12,0.12/ - data (st_ovrc_table(i,6),i=1,5) /0.06,0.06,0.06,0.06,0.06/ - data (st_ovrc_table(i,7),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - data (st_ovrc_table(i,8),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - real :: rt_ovrc_table(ncrop,nstage) !< fraction of root tunrover [1/s] - data (rt_ovrc_table(i,1),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - data (rt_ovrc_table(i,2),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - data (rt_ovrc_table(i,3),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - data (rt_ovrc_table(i,4),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - data (rt_ovrc_table(i,5),i=1,5) /0.12,0.12,0.12,0.12,0.12/ - data (rt_ovrc_table(i,6),i=1,5) /0.06,0.06,0.06,0.06,0.06/ - data (rt_ovrc_table(i,7),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - data (rt_ovrc_table(i,8),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - real :: lfmr25_table(ncrop) !< leaf maintenance respiration at 25c [umol co2/m**2 /s] - data (lfmr25_table(i),i=1,5) /1.0,1.0,1.0,1.0,1.0/ - real :: stmr25_table(ncrop) !< stem maintenance respiration at 25c [umol co2/kg bio/s] - data (stmr25_table(i),i=1,5) /0.05,0.1,0.1,0.1,0.1/ - real :: rtmr25_table(ncrop) !< root maintenance respiration at 25c [umol co2/kg bio/s] - data (rtmr25_table(i),i=1,5) /0.05,0.0,0.0,0.0,0.0/ - real :: grainmr25_table(ncrop) !< grain maintenance respiration at 25c [umol co2/kg bio/s] - data (grainmr25_table(i),i=1,5) /0.0,0.1,0.1,0.1,0.1/ real :: lfpt_table(ncrop,nstage) !< fraction of carbohydrate flux to leaf - data (lfpt_table(i,1),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - data (lfpt_table(i,2),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - data (lfpt_table(i,3),i=1,5) /0.4,0.4,0.4,0.4,0.4/ - data (lfpt_table(i,4),i=1,5) /0.2,0.2,0.2,0.2,0.2/ - data (lfpt_table(i,5),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - data (lfpt_table(i,6),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - data (lfpt_table(i,7),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - data (lfpt_table(i,8),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - - real :: stpt_table(ncrop,nstage) !< fraction of carbohydrate flux to stem - data (stpt_table(i,1),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - data (stpt_table(i,2),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - data (stpt_table(i,3),i=1,5) /0.2,0.2,0.2,0.2,0.2/ - data (stpt_table(i,4),i=1,5) /0.5,0.5,0.5,0.5,0.5/ - data (stpt_table(i,5),i=1,5) /0.0,0.15,0.15,0.15,0.15/ - data (stpt_table(i,6),i=1,5) /0.0,0.05,0.05,0.05,0.05/ - data (stpt_table(i,7),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - data (stpt_table(i,8),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - - real :: rtpt_table(ncrop,nstage) !< fraction of carbohydrate flux to root - data (rtpt_table(i,1),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - data (rtpt_table(i,2),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - data (rtpt_table(i,3),i=1,5) /0.34,0.4,0.4,0.4,0.4/ - data (rtpt_table(i,4),i=1,5) /0.3,0.3,0.3,0.3,0.3/ - data (rtpt_table(i,5),i=1,5) /0.05,0.05,0.05,0.05,0.05/ - data (rtpt_table(i,6),i=1,5) /0.0,0.05,0.05,0.05,0.05/ - data (rtpt_table(i,7),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - data (rtpt_table(i,8),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - real :: grainpt_table(ncrop,nstage) !< fraction of carbohydrate flux to grain - data (grainpt_table(i,1),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - data (grainpt_table(i,2),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - data (grainpt_table(i,3),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - data (grainpt_table(i,4),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - data (grainpt_table(i,5),i=1,5) /0.95,0.8,0.8,0.8,0.8/ - data (grainpt_table(i,6),i=1,5) /1.0,0.9,0.9,0.9,0.9/ - data (grainpt_table(i,7),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - data (grainpt_table(i,8),i=1,5) /0.0,0.0,0.0,0.0,0.0/ - + real :: lfct_table(ncrop,nstage) ! fraction of carbohydrate translocation from leaf to grain ! Zhe Zhang 2020-07-13 + real :: stct_table(ncrop,nstage) ! stem to grain + real :: rtct_table(ncrop,nstage) ! root to grain real :: bio2lai_table(ncrop) !< leaf are per living leaf biomass [m^2/kg] - data (bio2lai_table(i),i=1,5) /0.035,0.015,0.015,0.015,0.015/ + +! tile drainage parameters + real :: tdsmc_fac_table(max_soiltyp) + real :: td_dc_table(max_soiltyp) + integer :: td_depth_table(max_soiltyp) + integer :: drain_layer_opt_table + real :: td_dcoef_table(max_soiltyp) + real :: td_d_table(max_soiltyp) + real :: td_adepth_table(max_soiltyp) + real :: td_radi_table(max_soiltyp) + real :: td_spac_table(max_soiltyp) + real :: td_ddrain_table(max_soiltyp) + real :: klat_fac_table(max_soiltyp) ! mptable.tbl optional parameters @@ -1005,55 +257,1040 @@ module noahmp_tables ! Saxton and Rawls 2006 Pedo-transfer function coefficients !------------------------------------------------------------------------------ - real :: sr2006_theta_1500t_a = -0.024 !< sand coefficient - real :: sr2006_theta_1500t_b = 0.487 !< clay coefficient - real :: sr2006_theta_1500t_c = 0.006 !< orgm coefficient - real :: sr2006_theta_1500t_d = 0.005 !< sand*orgm coefficient - real :: sr2006_theta_1500t_e = -0.013 !< clay*orgm coefficient - real :: sr2006_theta_1500t_f = 0.068 !< sand*clay coefficient - real :: sr2006_theta_1500t_g = 0.031 !< constant adjustment - - real :: sr2006_theta_1500_a = 0.14 !< theta_1500t coefficient - real :: sr2006_theta_1500_b = -0.02 !< constant adjustment - - real :: sr2006_theta_33t_a = -0.251 !< sand coefficient - real :: sr2006_theta_33t_b = 0.195 !< clay coefficient - real :: sr2006_theta_33t_c = 0.011 !< orgm coefficient - real :: sr2006_theta_33t_d = 0.006 !< sand*orgm coefficient - real :: sr2006_theta_33t_e = -0.027 !< clay*orgm coefficient - real :: sr2006_theta_33t_f = 0.452 !< sand*clay coefficient - real :: sr2006_theta_33t_g = 0.299 !< constant adjustment - - real :: sr2006_theta_33_a = 1.283 !< theta_33t*theta_33t coefficient - real :: sr2006_theta_33_b = -0.374 !< theta_33t coefficient - real :: sr2006_theta_33_c = -0.015 !< constant adjustment - - real :: sr2006_theta_s33t_a = 0.278 !< sand coefficient - real :: sr2006_theta_s33t_b = 0.034 !< clay coefficient - real :: sr2006_theta_s33t_c = 0.022 !< orgm coefficient - real :: sr2006_theta_s33t_d = -0.018 !< sand*orgm coefficient - real :: sr2006_theta_s33t_e = -0.027 !< clay*orgm coefficient - real :: sr2006_theta_s33t_f = -0.584 !< sand*clay coefficient - real :: sr2006_theta_s33t_g = 0.078 !< constant adjustment - - real :: sr2006_theta_s33_a = 0.636 !< theta_s33t coefficient - real :: sr2006_theta_s33_b = -0.107 !< constant adjustment - - real :: sr2006_psi_et_a = -21.67 !< sand coefficient - real :: sr2006_psi_et_b = -27.93 !< clay coefficient - real :: sr2006_psi_et_c = -81.97 !< theta_s33 coefficient - real :: sr2006_psi_et_d = 71.12 !< sand*theta_s33 coefficient - real :: sr2006_psi_et_e = 8.29 !< clay*theta_s33 coefficient - real :: sr2006_psi_et_f = 14.05 !< sand*clay coefficient - real :: sr2006_psi_et_g = 27.16 !< constant adjustment - - real :: sr2006_psi_e_a = 0.02 !< psi_et*psi_et coefficient - real :: sr2006_psi_e_b = -0.113 !< psi_et coefficient - real :: sr2006_psi_e_c = -0.7 !< constant adjustment - - real :: sr2006_smcmax_a = -0.097 !< sand adjustment - real :: sr2006_smcmax_b = 0.043 !< constant adjustment + real :: sr2006_theta_1500t_a !< sand coefficient + real :: sr2006_theta_1500t_b !< clay coefficient + real :: sr2006_theta_1500t_c !< orgm coefficient + real :: sr2006_theta_1500t_d !< sand*orgm coefficient + real :: sr2006_theta_1500t_e !< clay*orgm coefficient + real :: sr2006_theta_1500t_f !< sand*clay coefficient + real :: sr2006_theta_1500t_g !< constant adjustment + + real :: sr2006_theta_1500_a !< theta_1500t coefficient + real :: sr2006_theta_1500_b !< constant adjustment + + real :: sr2006_theta_33t_a !< sand coefficient + real :: sr2006_theta_33t_b !< clay coefficient + real :: sr2006_theta_33t_c !< orgm coefficient + real :: sr2006_theta_33t_d !< sand*orgm coefficient + real :: sr2006_theta_33t_e !< clay*orgm coefficient + real :: sr2006_theta_33t_f !< sand*clay coefficient + real :: sr2006_theta_33t_g !< constant adjustment + + real :: sr2006_theta_33_a !< theta_33t*theta_33t coefficient + real :: sr2006_theta_33_b !< theta_33t coefficient + real :: sr2006_theta_33_c !< constant adjustment + + real :: sr2006_theta_s33t_a !< sand coefficient + real :: sr2006_theta_s33t_b !< clay coefficient + real :: sr2006_theta_s33t_c !< orgm coefficient + real :: sr2006_theta_s33t_d !< sand*orgm coefficient + real :: sr2006_theta_s33t_e !< clay*orgm coefficient + real :: sr2006_theta_s33t_f !< sand*clay coefficient + real :: sr2006_theta_s33t_g !< constant adjustment + + real :: sr2006_theta_s33_a !< theta_s33t coefficient + real :: sr2006_theta_s33_b !< constant adjustment + + real :: sr2006_psi_et_a !< sand coefficient + real :: sr2006_psi_et_b !< clay coefficient + real :: sr2006_psi_et_c !< theta_s33 coefficient + real :: sr2006_psi_et_d !< sand*theta_s33 coefficient + real :: sr2006_psi_et_e !< clay*theta_s33 coefficient + real :: sr2006_psi_et_f !< sand*clay coefficient + real :: sr2006_psi_et_g !< constant adjustment + + real :: sr2006_psi_e_a !< psi_et*psi_et coefficient + real :: sr2006_psi_e_b !< psi_et coefficient + real :: sr2006_psi_e_c !< constant adjustment + + real :: sr2006_smcmax_a !< sand adjustment + real :: sr2006_smcmax_b !< constant adjustment + +contains + + subroutine read_mp_table_parameters(dataset_identifier) + implicit none + + + ! vegetation parameters + character(len=256) :: dataset_identifier + character(len=256) :: veg_dataset_description + logical :: file_named + integer :: ierr, ik, im + integer :: nveg, isurban, iswater, isbarren, isice, iscrop, eblforest, natural + integer :: lcz_1, lcz_2, lcz_3, lcz_4, lcz_5, lcz_6, lcz_7, lcz_8, lcz_9, lcz_10, lcz_11 + real, dimension(mvt) :: sai_jan, sai_feb, sai_mar, sai_apr, sai_may, sai_jun, sai_jul, sai_aug, & + sai_sep, sai_oct, sai_nov, sai_dec, lai_jan, lai_feb, lai_mar, lai_apr, & + lai_may, lai_jun, lai_jul, lai_aug, lai_sep, lai_oct, lai_nov, lai_dec, & + rhol_vis, rhol_nir, rhos_vis, rhos_nir, taul_vis, taul_nir, taus_vis, taus_nir,& + ch2op, dleaf, z0mvt, hvt, hvb, den, rc, mfsno, scffac, xl, cwpvt, c3psn, kc25, & + akc, ko25, ako, avcmx, aqe, ltovrc, dilefc, dilefw, rmf25, sla, fragr, tmin, & + vcmx25, tdlef, bp, mp, qe25, rms25, rmr25, arm, folnmx, wdpool, wrrat, mrp, & + nroot, rgl, rs, hs, topt, rsmax, rtovrc, rswoodc, bf, wstrc, laimin, & + xsamin, eps1, eps2, eps3, eps4, eps5 + namelist / noahmp_usgs_veg_categories / veg_dataset_description, nveg + namelist / noahmp_usgs_parameters / isurban, iswater, isbarren, isice, iscrop, eblforest, natural, & + lcz_1, lcz_2, lcz_3, lcz_4, lcz_5, lcz_6, lcz_7, lcz_8, lcz_9, lcz_10, lcz_11, & + ch2op, dleaf, z0mvt, hvt, hvb, den, rc, mfsno, scffac, xl, cwpvt, c3psn, kc25, & + akc, ko25, ako, avcmx, aqe, ltovrc, dilefc, dilefw, rmf25, sla, fragr, tmin, & + vcmx25, tdlef, bp, mp, qe25, rms25, rmr25, arm, folnmx, wdpool, wrrat, mrp, & + nroot, rgl, rs, hs, topt, rsmax, rtovrc, rswoodc, bf, wstrc, laimin, & + xsamin, sai_jan, sai_feb, sai_mar, sai_apr, sai_may, & + sai_jun, sai_jul, sai_aug, sai_sep, sai_oct, sai_nov, sai_dec, lai_jan, & + lai_feb, lai_mar, lai_apr, lai_may, lai_jun, lai_jul, lai_aug, lai_sep, & + lai_oct, lai_nov, lai_dec, rhol_vis, rhol_nir, rhos_vis, rhos_nir, taul_vis, & + taul_nir, taus_vis, taus_nir, eps1, eps2, eps3, eps4, eps5 + namelist / noahmp_modis_veg_categories / veg_dataset_description, nveg + namelist / noahmp_modis_parameters / isurban, iswater, isbarren, isice, iscrop, eblforest, natural, & + lcz_1, lcz_2, lcz_3, lcz_4, lcz_5, lcz_6, lcz_7, lcz_8, lcz_9, lcz_10, lcz_11, & + ch2op, dleaf, z0mvt, hvt, hvb, den, rc, mfsno, scffac, xl, cwpvt, c3psn, kc25, & + akc, ko25, ako, avcmx, aqe, ltovrc, dilefc, dilefw, rmf25, sla, fragr, tmin, & + vcmx25, tdlef, bp, mp, qe25, rms25, rmr25, arm, folnmx, wdpool, wrrat, mrp, & + nroot, rgl, rs, hs, topt, rsmax, rtovrc, rswoodc, bf, wstrc, laimin, & + xsamin, sai_jan, sai_feb, sai_mar, sai_apr, sai_may, & + sai_jun, sai_jul, sai_aug, sai_sep, sai_oct, sai_nov, sai_dec, lai_jan, & + lai_feb, lai_mar, lai_apr, lai_may, lai_jun, lai_jul, lai_aug, lai_sep, & + lai_oct, lai_nov, lai_dec, rhol_vis, rhol_nir, rhos_vis, rhos_nir, taul_vis, & + taul_nir, taus_vis, taus_nir, eps1, eps2, eps3, eps4, eps5 + ! soil parameters + character(len=256) :: message + character(len=10) :: sltype + integer :: slcats + real, dimension(max_soiltyp) :: bb, drysmc, maxsmc, refsmc, satpsi, satdk, satdw, wltsmc, qtz, & + bvic, axaj, bxaj, xxaj, bdvic, bbvic, gdvic, hc + namelist / noahmp_stas_soil_categories / sltype, slcats + namelist / noahmp_soil_stas_parameters / bb, drysmc, maxsmc, refsmc, satpsi, satdk, satdw, wltsmc, qtz, & + bvic, axaj, bxaj, xxaj, bdvic, bbvic, gdvic + namelist / noahmp_soil_stas_ruc_parameters / bb, drysmc, hc, maxsmc, refsmc, satpsi, satdk, satdw, wltsmc, qtz, & + bvic, axaj, bxaj, xxaj, bdvic, bbvic, gdvic + + ! general parameters + real :: csoil_data, refdk_data, refkdt_data, frzk_data, zbot_data, czil_data + real, dimension(num_slope) :: slope_data + namelist / noahmp_general_parameters / slope_data, csoil_data, refdk_data, refkdt_data, frzk_data, zbot_data, & + czil_data + + ! radiation parameters + real :: betads, betais, eice + real, dimension(mband) :: albice, alblak, omegas + real, dimension(2) :: eg + real, dimension(msc) :: albsat_vis, albsat_nir, albdry_vis, albdry_nir + namelist / noahmp_rad_parameters / albsat_vis, albsat_nir, albdry_vis, albdry_nir, albice, alblak, omegas, & + betads, betais, eg, eice + + ! global parameters + real :: co2, o2, timean, fsatmx, z0sno, ssi, snow_ret_fac ,snow_emis, swemx, tau0, & + grain_growth, extra_growth, dirt_soot, bats_cosz, bats_vis_new, & + bats_nir_new, bats_vis_age, bats_nir_age, bats_vis_dir, bats_nir_dir, & + rsurf_snow, rsurf_exp, c2_snowcompact, c3_snowcompact, c4_snowcompact, & + c5_snowcompact, dm_snowcompact, eta0_snowcompact, snliqmaxfrac, swemaxgla, & + wslmax, rous, cmic, snowden_max, class_alb_ref, class_sno_age, class_alb_new,& + psiwlt, z0soil, z0lake + namelist / noahmp_global_parameters / co2, o2, timean, fsatmx, z0sno, ssi, snow_ret_fac ,snow_emis, swemx, tau0, & + grain_growth, extra_growth, dirt_soot, bats_cosz, bats_vis_new, & + bats_nir_new, bats_vis_age, bats_nir_age, bats_vis_dir, bats_nir_dir, & + rsurf_snow, rsurf_exp, c2_snowcompact, c3_snowcompact, c4_snowcompact, & + c5_snowcompact, dm_snowcompact, eta0_snowcompact, snliqmaxfrac, swemaxgla, & + wslmax, rous, cmic, snowden_max, class_alb_ref, class_sno_age, class_alb_new,& + psiwlt, z0soil, z0lake + + ! irrigation parameters + integer :: irr_har + real :: irr_frac, irr_lai, irr_mad, filoss, sprir_rate, micir_rate, firtfac, ir_rain + namelist / noahmp_irrigation_parameters / irr_frac, irr_har, irr_lai, irr_mad, filoss, sprir_rate, micir_rate, firtfac,& + ir_rain + + ! crop parameters + integer :: default_crop + integer , dimension(ncrop) :: pltday, hsday + real, dimension(ncrop) :: plantpop, irri, gddtbase, gddtcut, gdds1, gdds2, gdds3, gdds4, gdds5, c3psni,& + kc25i, akci, ko25i, akoi, avcmxi, vcmx25i, bpi, mpi, folnmxi, qe25i, aref, & + psnrf, i2par, tassim0, tassim1, tassim2, k, epsi, q10mr, lefreez, & + dile_fc_s1, dile_fc_s2, dile_fc_s3, dile_fc_s4, dile_fc_s5, dile_fc_s6, & + dile_fc_s7, dile_fc_s8, dile_fw_s1, dile_fw_s2, dile_fw_s3, dile_fw_s4, & + dile_fw_s5, dile_fw_s6, dile_fw_s7, dile_fw_s8, fra_gr, lf_ovrc_s1, & + lf_ovrc_s2, lf_ovrc_s3, lf_ovrc_s4, lf_ovrc_s5, lf_ovrc_s6, lf_ovrc_s7, & + lf_ovrc_s8, st_ovrc_s1, st_ovrc_s2, st_ovrc_s3, st_ovrc_s4, st_ovrc_s5, & + st_ovrc_s6, st_ovrc_s7, st_ovrc_s8, rt_ovrc_s1, rt_ovrc_s2, rt_ovrc_s3, & + rt_ovrc_s4, rt_ovrc_s5, rt_ovrc_s6, rt_ovrc_s7, rt_ovrc_s8, lfmr25, stmr25, & + rtmr25, grainmr25, lfpt_s1, lfpt_s2, lfpt_s3, lfpt_s4, lfpt_s5, lfpt_s6, & + lfpt_s7, lfpt_s8, stpt_s1, stpt_s2, stpt_s3, stpt_s4, stpt_s5, stpt_s6, & + stpt_s7, stpt_s8, rtpt_s1, rtpt_s2, rtpt_s3, rtpt_s4, rtpt_s5, rtpt_s6, & + rtpt_s7, rtpt_s8, grainpt_s1, grainpt_s2, grainpt_s3, grainpt_s4, grainpt_s5,& + grainpt_s6, grainpt_s7, grainpt_s8, lfct_s1, lfct_s2, lfct_s3, lfct_s4, & + lfct_s5, lfct_s6, lfct_s7, lfct_s8, stct_s1, stct_s2, stct_s3, stct_s4, & + stct_s5, stct_s6, stct_s7, stct_s8, rtct_s1, rtct_s2, rtct_s3, rtct_s4, & + rtct_s5, rtct_s6, rtct_s7, rtct_s8, bio2lai + namelist / noahmp_crop_parameters / default_crop, pltday, hsday, plantpop, irri, gddtbase, gddtcut, gdds1, gdds2,& + gdds3, gdds4, gdds5, c3psni, kc25i, akci, ko25i, akoi, avcmxi, vcmx25i, bpi, & + mpi, folnmxi, qe25i, aref, psnrf, i2par, tassim0, tassim1, tassim2, k, & + epsi,q10mr, lefreez, dile_fc_s1, dile_fc_s2, dile_fc_s3, dile_fc_s4, & + dile_fc_s5, dile_fc_s6, dile_fc_s7, dile_fc_s8, dile_fw_s1, dile_fw_s2, & + dile_fw_s3, dile_fw_s4, dile_fw_s5, dile_fw_s6, dile_fw_s7, dile_fw_s8, & + fra_gr, lf_ovrc_s1, lf_ovrc_s2, lf_ovrc_s3, lf_ovrc_s4, lf_ovrc_s5, & + lf_ovrc_s6, lf_ovrc_s7, lf_ovrc_s8, st_ovrc_s1, st_ovrc_s2, st_ovrc_s3, & + st_ovrc_s4, st_ovrc_s5, st_ovrc_s6, st_ovrc_s7, st_ovrc_s8, rt_ovrc_s1, & + rt_ovrc_s2, rt_ovrc_s3, rt_ovrc_s4, rt_ovrc_s5, rt_ovrc_s6, rt_ovrc_s7, & + rt_ovrc_s8, lfmr25, stmr25, rtmr25, grainmr25, lfpt_s1, lfpt_s2, lfpt_s3, & + lfpt_s4, lfpt_s5, lfpt_s6, lfpt_s7, lfpt_s8, stpt_s1, stpt_s2, stpt_s3, & + stpt_s4, stpt_s5, stpt_s6, stpt_s7, stpt_s8, rtpt_s1, rtpt_s2, rtpt_s3, & + rtpt_s4, rtpt_s5, rtpt_s6, rtpt_s7, rtpt_s8, grainpt_s1, grainpt_s2, & + grainpt_s3, grainpt_s4, grainpt_s5, grainpt_s6, grainpt_s7, grainpt_s8, & + lfct_s1, lfct_s2, lfct_s3, lfct_s4, lfct_s5, lfct_s6, lfct_s7, lfct_s8, & + stct_s1, stct_s2, stct_s3, stct_s4, stct_s5, stct_s6, stct_s7, stct_s8, & + rtct_s1, rtct_s2, rtct_s3, rtct_s4, rtct_s5, rtct_s6, rtct_s7, rtct_s8, & + bio2lai + + ! tile drainage parameters + integer :: nsoiltype, drain_layer_opt + integer , dimension(max_soiltyp) :: td_depth + real, dimension(max_soiltyp) :: tdsmc_fac, td_dc, td_dcoef, td_d, td_adepth, td_radi, td_spac, & + td_ddrain, klat_fac + namelist / noahmp_tiledrain_parameters / nsoiltype, drain_layer_opt, tdsmc_fac, td_depth, td_dc, td_dcoef, td_d,& + td_adepth, td_radi, td_spac, td_ddrain, klat_fac + + ! optional parameters + real :: sr2006_theta_1500t_a, sr2006_theta_1500t_b, sr2006_theta_1500t_c, & + sr2006_theta_1500t_d, sr2006_theta_1500t_e, sr2006_theta_1500t_f, & + sr2006_theta_1500t_g, sr2006_theta_1500_a , sr2006_theta_1500_b, & + sr2006_theta_33t_a, sr2006_theta_33t_b, sr2006_theta_33t_c, & + sr2006_theta_33t_d, sr2006_theta_33t_e, sr2006_theta_33t_f, & + sr2006_theta_33t_g, sr2006_theta_33_a, sr2006_theta_33_b, & + sr2006_theta_33_c, sr2006_theta_s33t_a, sr2006_theta_s33t_b, & + sr2006_theta_s33t_c, sr2006_theta_s33t_d, sr2006_theta_s33t_e, & + sr2006_theta_s33t_f, sr2006_theta_s33t_g, sr2006_theta_s33_a, & + sr2006_theta_s33_b, sr2006_psi_et_a, sr2006_psi_et_b, sr2006_psi_et_c, & + sr2006_psi_et_d, sr2006_psi_et_e, sr2006_psi_et_f, sr2006_psi_et_g, & + sr2006_psi_e_a, sr2006_psi_e_b, sr2006_psi_e_c, sr2006_smcmax_a, & + sr2006_smcmax_b + namelist / noahmp_optional_parameters / sr2006_theta_1500t_a, sr2006_theta_1500t_b, sr2006_theta_1500t_c, & + sr2006_theta_1500t_d, sr2006_theta_1500t_e, sr2006_theta_1500t_f, & + sr2006_theta_1500t_g, sr2006_theta_1500_a, sr2006_theta_1500_b, & + sr2006_theta_33t_a, sr2006_theta_33t_b, sr2006_theta_33t_c, & + sr2006_theta_33t_d, sr2006_theta_33t_e, sr2006_theta_33t_f, & + sr2006_theta_33t_g, sr2006_theta_33_a, sr2006_theta_33_b, & + sr2006_theta_33_c, sr2006_theta_s33t_a, sr2006_theta_s33t_b, & + sr2006_theta_s33t_c, sr2006_theta_s33t_d, sr2006_theta_s33t_e, & + sr2006_theta_s33t_f, sr2006_theta_s33t_g, sr2006_theta_s33_a, & + sr2006_theta_s33_b, sr2006_psi_et_a, sr2006_psi_et_b, sr2006_psi_et_c, & + sr2006_psi_et_d, sr2006_psi_et_e, sr2006_psi_et_f, sr2006_psi_et_g, & + sr2006_psi_e_a, sr2006_psi_e_b, sr2006_psi_e_c, sr2006_smcmax_a, & + sr2006_smcmax_b + + ! initialize our variables to bad values, so that if the namelist read fails, we come to a screeching halt as soon as we try to use anything. + ! vegetation parameters + isurban_table = -99999 + iswater_table = -99999 + isbarren_table = -99999 + isice_table = -99999 + iscrop_table = -99999 + eblforest_table = -99999 + natural_table = -99999 + lcz_1_table = -99999 + lcz_2_table = -99999 + lcz_3_table = -99999 + lcz_4_table = -99999 + lcz_5_table = -99999 + lcz_6_table = -99999 + lcz_7_table = -99999 + lcz_8_table = -99999 + lcz_9_table = -99999 + lcz_10_table = -99999 + lcz_11_table = -99999 + ch2op_table = -1.0e36 + dleaf_table = -1.0e36 + z0mvt_table = -1.0e36 + hvt_table = -1.0e36 + hvb_table = -1.0e36 + den_table = -1.0e36 + rc_table = -1.0e36 + mfsno_table = -1.0e36 + scffac_table = -1.0e36 + rhol_table = -1.0e36 + rhos_table = -1.0e36 + taul_table = -1.0e36 + taus_table = -1.0e36 + xl_table = -1.0e36 + cwpvt_table = -1.0e36 + c3psn_table = -1.0e36 + kc25_table = -1.0e36 + akc_table = -1.0e36 + ko25_table = -1.0e36 + ako_table = -1.0e36 + avcmx_table = -1.0e36 + aqe_table = -1.0e36 + ltovrc_table = -1.0e36 + dilefc_table = -1.0e36 + dilefw_table = -1.0e36 + rmf25_table = -1.0e36 + sla_table = -1.0e36 + fragr_table = -1.0e36 + tmin_table = -1.0e36 + vcmx25_table = -1.0e36 + tdlef_table = -1.0e36 + bp_table = -1.0e36 + mp_table = -1.0e36 + qe25_table = -1.0e36 + rms25_table = -1.0e36 + rmr25_table = -1.0e36 + arm_table = -1.0e36 + folnmx_table = -1.0e36 + wdpool_table = -1.0e36 + wrrat_table = -1.0e36 + mrp_table = -1.0e36 + saim_table = -1.0e36 + laim_table = -1.0e36 + nroot_table = -1.0e36 + rgl_table = -1.0e36 + rs_table = -1.0e36 + hs_table = -1.0e36 + topt_table = -1.0e36 + rsmax_table = -1.0e36 + ! not used in the current ufs version +! rtovrc_table = -1.0e36 +! rswoodc_table = -1.0e36 +! bf_table = -1.0e36 +! wstrc_table = -1.0e36 +! laimin_table = -1.0e36 +! xsamin_table = -1.0e36 + + ! soil parameters + + bexp_table = -1.0e36 + smcdry_table = -1.0e36 + f1_table = -1.0e36 + smcmax_table = -1.0e36 + smcref_table = -1.0e36 + psisat_table = -1.0e36 + dksat_table = -1.0e36 + dwsat_table = -1.0e36 + smcwlt_table = -1.0e36 + quartz_table = -1.0e36 + bvic_table = -1.0e36 + axaj_table = -1.0e36 + bxaj_table = -1.0e36 + xxaj_table = -1.0e36 + bdvic_table = -1.0e36 + gdvic_table = -1.0e36 + bbvic_table = -1.0e36 + + ! general parameters + slope_table = -1.0e36 + csoil_table = -1.0e36 + refdk_table = -1.0e36 + refkdt_table = -1.0e36 + frzk_table = -1.0e36 + zbot_table = -1.0e36 + czil_table = -1.0e36 + + ! radiation parameters + albsat_table = -1.0e36 + albdry_table = -1.0e36 + albice_table = -1.0e36 + alblak_table = -1.0e36 + omegas_table = -1.0e36 + betads_table = -1.0e36 + betais_table = -1.0e36 + eg_table = -1.0e36 +! eice_table = -1.0e36 + + ! global parameters + co2_table = -1.0e36 + o2_table = -1.0e36 + timean_table = -1.0e36 + fsatmx_table = -1.0e36 + z0sno_table = -1.0e36 + ssi_table = -1.0e36 +snow_ret_fac_table = -1.0e36 + snow_emis_table = -1.0e36 + swemx_table = -1.0e36 + tau0_table = -1.0e36 +grain_growth_table = -1.0e36 +extra_growth_table = -1.0e36 + dirt_soot_table = -1.0e36 + bats_cosz_table = -1.0e36 +bats_vis_new_table = -1.0e36 +bats_nir_new_table = -1.0e36 +bats_vis_age_table = -1.0e36 +bats_nir_age_table = -1.0e36 +bats_vis_dir_table = -1.0e36 +bats_nir_dir_table = -1.0e36 +rsurf_snow_table = -1.0e36 + rsurf_exp_table = -1.0e36 + +! c2_snowcompact_table = -1.0e36 +! c3_snowcompact_table = -1.0e36 +! c4_snowcompact_table = -1.0e36 +! c5_snowcompact_table = -1.0e36 +! dm_snowcompact_table = -1.0e36 +! eta0_snowcompact_table = -1.0e36 +! snliqmaxfrac_table = -1.0e36 +! swemaxgla_table = -1.0e36 +! wslmax_table = -1.0e36 +! rous_table = -1.0e36 +! cmic_table = -1.0e36 +! snowden_max_table = -1.0e36 +! class_alb_ref_table = -1.0e36 +! class_sno_age_table = -1.0e36 +! class_alb_new_table = -1.0e36 +! psiwlt_table = -1.0e36 +! z0soil_table = -1.0e36 +! z0lake_table = -1.0e36 + + ! irrigation parameters + irr_har_table = -99999 ! number of days before harvest date to stop irrigation + irr_frac_table = -1.0e36 ! irrigation fraction + irr_lai_table = -1.0e36 ! minimum lai to trigger irrigation + irr_mad_table = -1.0e36 ! management allowable deficit (0-1) + filoss_table = -1.0e36 ! fraction of flood irrigation loss (0-1) + sprir_rate_table = -1.0e36 ! mm/h, sprinkler irrigation rate + micir_rate_table = -1.0e36 ! mm/h, micro irrigation rate + firtfac_table = -1.0e36 ! flood application rate factor + ir_rain_table = -1.0e36 ! maximum precipitation to stop irrigation trigger + + ! crop parameters + default_crop_table = -99999 + pltday_table = -99999 + hsday_table = -99999 + plantpop_table = -1.0e36 + irri_table = -1.0e36 + gddtbase_table = -1.0e36 + gddtcut_table = -1.0e36 + gdds1_table = -1.0e36 + gdds2_table = -1.0e36 + gdds3_table = -1.0e36 + gdds4_table = -1.0e36 + gdds5_table = -1.0e36 + c3psni_table = -1.0e36 ! parameter from psn copied from stomata ! zhe zhang 2020-07-13 + kc25i_table = -1.0e36 + akci_table = -1.0e36 + ko25i_table = -1.0e36 + akoi_table = -1.0e36 + avcmxi_table = -1.0e36 + vcmx25i_table = -1.0e36 + bpi_table = -1.0e36 + mpi_table = -1.0e36 + folnmxi_table = -1.0e36 + qe25i_table = -1.0e36 ! ends here +!??? c3c4_table = -99999 + aref_table = -1.0e36 + psnrf_table = -1.0e36 + i2par_table = -1.0e36 + tassim0_table = -1.0e36 + tassim1_table = -1.0e36 + tassim2_table = -1.0e36 + k_table = -1.0e36 + epsi_table = -1.0e36 + q10mr_table = -1.0e36 + foln_mx_table = -1.0e36 + lefreez_table = -1.0e36 + dile_fc_table = -1.0e36 + dile_fw_table = -1.0e36 + fra_gr_table = -1.0e36 + lf_ovrc_table = -1.0e36 + st_ovrc_table = -1.0e36 + rt_ovrc_table = -1.0e36 + lfmr25_table = -1.0e36 + stmr25_table = -1.0e36 + rtmr25_table = -1.0e36 + grainmr25_table = -1.0e36 + lfpt_table = -1.0e36 + stpt_table = -1.0e36 + rtpt_table = -1.0e36 + grainpt_table = -1.0e36 + lfct_table = -1.0e36 ! convert start + stct_table = -1.0e36 + rtct_table = -1.0e36 ! convert end + bio2lai_table = -1.0e36 + + ! tile drainage parameters + + drain_layer_opt_table = -99999 + td_depth_table = -99999 + tdsmc_fac_table = -1.0e36 + td_dc_table = -1.0e36 + td_dcoef_table = -1.0e36 + td_d_table = -1.0e36 + td_adepth_table = -1.0e36 + td_radi_table = -1.0e36 + td_spac_table = -1.0e36 + td_ddrain_table = -1.0e36 + klat_fac_table = -1.0e36 + + ! optional parameters +! sr2006_theta_1500t_a_table = -1.0e36 +! sr2006_theta_1500t_b_table = -1.0e36 +! sr2006_theta_1500t_c_table = -1.0e36 +! sr2006_theta_1500t_d_table = -1.0e36 +! sr2006_theta_1500t_e_table = -1.0e36 +! sr2006_theta_1500t_f_table = -1.0e36 +! sr2006_theta_1500t_g_table = -1.0e36 +! sr2006_theta_1500_a_table = -1.0e36 +! sr2006_theta_1500_b_table = -1.0e36 +! sr2006_theta_33t_a_table = -1.0e36 +! sr2006_theta_33t_b_table = -1.0e36 +! sr2006_theta_33t_c_table = -1.0e36 +! sr2006_theta_33t_d_table = -1.0e36 +! sr2006_theta_33t_e_table = -1.0e36 +! sr2006_theta_33t_f_table = -1.0e36 +! sr2006_theta_33t_g_table = -1.0e36 +! sr2006_theta_33_a_table = -1.0e36 +! sr2006_theta_33_b_table = -1.0e36 +! sr2006_theta_33_c_table = -1.0e36 +! sr2006_theta_s33t_a_table = -1.0e36 +! sr2006_theta_s33t_b_table = -1.0e36 +! sr2006_theta_s33t_c_table = -1.0e36 +! sr2006_theta_s33t_d_table = -1.0e36 +! sr2006_theta_s33t_e_table = -1.0e36 +! sr2006_theta_s33t_f_table = -1.0e36 +! sr2006_theta_s33t_g_table = -1.0e36 +! sr2006_theta_s33_a_table = -1.0e36 +! sr2006_theta_s33_b_table = -1.0e36 +! sr2006_psi_et_a_table = -1.0e36 +! sr2006_psi_et_b_table = -1.0e36 +! sr2006_psi_et_c_table = -1.0e36 +! sr2006_psi_et_d_table = -1.0e36 +! sr2006_psi_et_e_table = -1.0e36 +! sr2006_psi_et_f_table = -1.0e36 +! sr2006_psi_et_g_table = -1.0e36 +! sr2006_psi_e_a_table = -1.0e36 +! sr2006_psi_e_b_table = -1.0e36 +! sr2006_psi_e_c_table = -1.0e36 +! sr2006_smcmax_a_table = -1.0e36 +! sr2006_smcmax_b_table = -1.0e36 + + !--------------------------------------------------------------- + ! transfer values from table to input variables + !--------------------------------------------------------------- + + !---------------- noahmptable.tbl vegetation parameters + + dataset_identifier = "modified_igbp_modis_noah" + + inquire( file='noahmptable.tbl', exist=file_named ) + if ( file_named ) then + open(15, file="noahmptable.tbl", status='old', form='formatted', action='read', iostat=ierr) + else + open(15, status='old', form='formatted', action='read', iostat=ierr) + end if + if ( ierr /= 0 ) then + write(*,'("warning: cannot find file noahmptable.tbl")') + endif + + if ( trim(dataset_identifier) == "usgs" ) then + read(15, noahmp_usgs_veg_categories) + read(15, noahmp_usgs_parameters) + elseif ( trim(dataset_identifier) == "modified_igbp_modis_noah" ) then + read(15,noahmp_modis_veg_categories) + read(15,noahmp_modis_parameters) + else + write(*,'("warning: unrecognized dataset_identifier in subroutine readnoahmptable")') + write(*,'("warning: dataset_identifier = ''", a, "''")') trim(dataset_identifier) + endif + close(15) + + + ! assign values + isurban_table = isurban + iswater_table = iswater + isbarren_table = isbarren + isice_table = isice + iscrop_table = iscrop + eblforest_table = eblforest + natural_table = natural + lcz_1_table = lcz_1 + lcz_2_table = lcz_2 + lcz_3_table = lcz_3 + lcz_4_table = lcz_4 + lcz_5_table = lcz_5 + lcz_6_table = lcz_6 + lcz_7_table = lcz_7 + lcz_8_table = lcz_8 + lcz_9_table = lcz_9 + lcz_10_table = lcz_10 + lcz_11_table = lcz_11 + ch2op_table (1:nveg) = ch2op (1:nveg) + dleaf_table (1:nveg) = dleaf (1:nveg) + z0mvt_table (1:nveg) = z0mvt (1:nveg) + hvt_table (1:nveg) = hvt (1:nveg) + hvb_table (1:nveg) = hvb (1:nveg) + den_table (1:nveg) = den (1:nveg) + rc_table (1:nveg) = rc (1:nveg) + mfsno_table (1:nveg) = mfsno (1:nveg) + scffac_table (1:nveg) = scffac (1:nveg) + xl_table (1:nveg) = xl (1:nveg) + cwpvt_table (1:nveg) = cwpvt (1:nveg) + c3psn_table (1:nveg) = c3psn (1:nveg) + kc25_table (1:nveg) = kc25 (1:nveg) + akc_table (1:nveg) = akc (1:nveg) + ko25_table (1:nveg) = ko25 (1:nveg) + ako_table (1:nveg) = ako (1:nveg) + avcmx_table (1:nveg) = avcmx (1:nveg) + aqe_table (1:nveg) = aqe (1:nveg) + ltovrc_table (1:nveg) = ltovrc (1:nveg) + dilefc_table (1:nveg) = dilefc (1:nveg) + dilefw_table (1:nveg) = dilefw (1:nveg) + rmf25_table (1:nveg) = rmf25 (1:nveg) + sla_table (1:nveg) = sla (1:nveg) + fragr_table (1:nveg) = fragr (1:nveg) + tmin_table (1:nveg) = tmin (1:nveg) + vcmx25_table (1:nveg) = vcmx25 (1:nveg) + tdlef_table (1:nveg) = tdlef (1:nveg) + bp_table (1:nveg) = bp (1:nveg) + mp_table (1:nveg) = mp (1:nveg) + qe25_table (1:nveg) = qe25 (1:nveg) + rms25_table (1:nveg) = rms25 (1:nveg) + rmr25_table (1:nveg) = rmr25 (1:nveg) + arm_table (1:nveg) = arm (1:nveg) + folnmx_table (1:nveg) = folnmx (1:nveg) + wdpool_table (1:nveg) = wdpool (1:nveg) + wrrat_table (1:nveg) = wrrat (1:nveg) + mrp_table (1:nveg) = mrp (1:nveg) + nroot_table (1:nveg) = nroot (1:nveg) + rgl_table (1:nveg) = rgl (1:nveg) + rs_table (1:nveg) = rs (1:nveg) + hs_table (1:nveg) = hs (1:nveg) + topt_table (1:nveg) = topt (1:nveg) + rsmax_table (1:nveg) = rsmax (1:nveg) +! rtovrc_table (1:nveg) = rtovrc (1:nveg) +! rswoodc_table(1:nveg) = rswoodc(1:nveg) +! bf_table (1:nveg) = bf (1:nveg) +! wstrc_table (1:nveg) = wstrc (1:nveg) +! laimin_table (1:nveg) = laimin (1:nveg) +! xsamin_table (1:nveg) = xsamin (1:nveg) + + saim_table(1:nveg, 1) = sai_jan(1:nveg) + saim_table(1:nveg, 2) = sai_feb(1:nveg) + saim_table(1:nveg, 3) = sai_mar(1:nveg) + saim_table(1:nveg, 4) = sai_apr(1:nveg) + saim_table(1:nveg, 5) = sai_may(1:nveg) + saim_table(1:nveg, 6) = sai_jun(1:nveg) + saim_table(1:nveg, 7) = sai_jul(1:nveg) + saim_table(1:nveg, 8) = sai_aug(1:nveg) + saim_table(1:nveg, 9) = sai_sep(1:nveg) + saim_table(1:nveg,10) = sai_oct(1:nveg) + saim_table(1:nveg,11) = sai_nov(1:nveg) + saim_table(1:nveg,12) = sai_dec(1:nveg) + laim_table(1:nveg, 1) = lai_jan(1:nveg) + laim_table(1:nveg, 2) = lai_feb(1:nveg) + laim_table(1:nveg, 3) = lai_mar(1:nveg) + laim_table(1:nveg, 4) = lai_apr(1:nveg) + laim_table(1:nveg, 5) = lai_may(1:nveg) + laim_table(1:nveg, 6) = lai_jun(1:nveg) + laim_table(1:nveg, 7) = lai_jul(1:nveg) + laim_table(1:nveg, 8) = lai_aug(1:nveg) + laim_table(1:nveg, 9) = lai_sep(1:nveg) + laim_table(1:nveg,10) = lai_oct(1:nveg) + laim_table(1:nveg,11) = lai_nov(1:nveg) + laim_table(1:nveg,12) = lai_dec(1:nveg) + rhol_table(1:nveg,1) = rhol_vis(1:nveg) !leaf reflectance: 1=vis, 2=nir + rhol_table(1:nveg,2) = rhol_nir(1:nveg) !leaf reflectance: 1=vis, 2=nir + rhos_table(1:nveg,1) = rhos_vis(1:nveg) !stem reflectance: 1=vis, 2=nir + rhos_table(1:nveg,2) = rhos_nir(1:nveg) !stem reflectance: 1=vis, 2=nir + taul_table(1:nveg,1) = taul_vis(1:nveg) !leaf transmittance: 1=vis, 2=nir + taul_table(1:nveg,2) = taul_nir(1:nveg) !leaf transmittance: 1=vis, 2=nir + taus_table(1:nveg,1) = taus_vis(1:nveg) !stem transmittance: 1=vis, 2=nir + taus_table(1:nveg,2) = taus_nir(1:nveg) !stem transmittance: 1=vis, 2=nir + + !---------------- noahmptable.tbl soil parameters + inquire( file='noahmptable.tbl', exist=file_named ) + if ( file_named ) then + open(15, file="noahmptable.tbl", status='old', form='formatted', action='read', iostat=ierr) + else + open(15, status='old', form='formatted', action='read', iostat=ierr) + end if + if ( ierr /= 0 ) then + write(*,'("warning: cannot find file noahmptable.tbl")') + endif + read(15, noahmp_stas_soil_categories) + if ( trim(sltype) == "stas" ) then + read(15, noahmp_soil_stas_parameters) + elseif ( trim(sltype) == "stas_ruc" ) then + read(15, noahmp_soil_stas_ruc_parameters) + else + write(*,'("warning: unrecognized soiltype in subroutine readnoahmptable")') + write(*,'("warning: dataset_identifier = ''", a, "''")') trim(sltype) + endif + close(15) + + ! assign values +! slcats_table = slcats + bexp_table (1:slcats) = bb (1:slcats) + smcdry_table(1:slcats) = drysmc(1:slcats) + smcmax_table(1:slcats) = maxsmc(1:slcats) + smcref_table(1:slcats) = refsmc(1:slcats) + psisat_table(1:slcats) = satpsi(1:slcats) + dksat_table (1:slcats) = satdk (1:slcats) + dwsat_table (1:slcats) = satdw (1:slcats) + smcwlt_table(1:slcats) = wltsmc(1:slcats) + quartz_table(1:slcats) = qtz (1:slcats) + bvic_table (1:slcats) = bvic (1:slcats) + axaj_table (1:slcats) = axaj (1:slcats) + bxaj_table (1:slcats) = bxaj (1:slcats) + xxaj_table (1:slcats) = xxaj (1:slcats) + bdvic_table (1:slcats) = bdvic (1:slcats) + gdvic_table (1:slcats) = gdvic (1:slcats) + bbvic_table (1:slcats) = bbvic (1:slcats) + + !---------------- noahmptable.tbl general parameters + inquire( file='noahmptable.tbl', exist=file_named ) + if ( file_named ) then + open(15, file="noahmptable.tbl", status='old', form='formatted', action='read', iostat=ierr) + else + open(15, status='old', form='formatted', action='read', iostat=ierr) + end if + if ( ierr /= 0 ) then + write(*,'("warning: cannot find file noahmptable.tbl")') + endif + read(15, noahmp_general_parameters) + close(15) + + ! assign values + slope_table(1:num_slope) = slope_data(1:num_slope) + csoil_table = csoil_data + refdk_table = refdk_data + refkdt_table = refkdt_data + frzk_table = frzk_data + zbot_table = zbot_data + czil_table = czil_data + + !---------------- noahmptable.tbl radiation parameters + inquire( file='noahmptable.tbl', exist=file_named ) + if ( file_named ) then + open(15, file="noahmptable.tbl", status='old', form='formatted', action='read', iostat=ierr) + else + open(15, status='old', form='formatted', action='read', iostat=ierr) + end if + if (ierr /= 0) then + write(*,'("warning: cannot find file noahmptable.tbl")') + endif + read(15,noahmp_rad_parameters) + close(15) + + ! assign values + albsat_table(:,1) = albsat_vis ! saturated soil albedos: 1=vis, 2=nir + albsat_table(:,2) = albsat_nir ! saturated soil albedos: 1=vis, 2=nir + albdry_table(:,1) = albdry_vis ! dry soil albedos: 1=vis, 2=nir + albdry_table(:,2) = albdry_nir ! dry soil albedos: 1=vis, 2=nir + albice_table = albice + alblak_table = alblak + omegas_table = omegas + betads_table = betads + betais_table = betais + eg_table = eg +! eice_table = eice + + !---------------- noahmptable.tbl global parameters + inquire( file='noahmptable.tbl', exist=file_named ) + if ( file_named ) then + open(15, file="noahmptable.tbl", status='old', form='formatted', action='read', iostat=ierr) + else + open(15, status='old', form='formatted', action='read', iostat=ierr) + end if + if (ierr /= 0) then + write(*,'("warning: cannot find file noahmptable.tbl")') + endif + read(15,noahmp_global_parameters) + close(15) + + ! assign values + co2_table = co2 + o2_table = o2 + timean_table = timean + fsatmx_table = fsatmx + z0sno_table = z0sno + ssi_table = ssi + snow_ret_fac_table = snow_ret_fac + snow_emis_table = snow_emis + swemx_table = swemx + tau0_table = tau0 + grain_growth_table = grain_growth + extra_growth_table = extra_growth + dirt_soot_table = dirt_soot + bats_cosz_table = bats_cosz + bats_vis_new_table = bats_vis_new + bats_nir_new_table = bats_nir_new + bats_vis_age_table = bats_vis_age + bats_nir_age_table = bats_nir_age + bats_vis_dir_table = bats_vis_dir + bats_nir_dir_table = bats_nir_dir + rsurf_snow_table = rsurf_snow + rsurf_exp_table = rsurf_exp +! c2_snowcompact_table = c2_snowcompact +! c3_snowcompact_table = c3_snowcompact +! c4_snowcompact_table = c4_snowcompact +! c5_snowcompact_table = c5_snowcompact +! dm_snowcompact_table = dm_snowcompact +! eta0_snowcompact_table = eta0_snowcompact +! snliqmaxfrac_table = snliqmaxfrac +! swemaxgla_table = swemaxgla +! wslmax_table = wslmax +! rous_table = rous +! cmic_table = cmic +! snowden_max_table = snowden_max +! class_alb_ref_table = class_alb_ref +! class_sno_age_table = class_sno_age +! class_alb_new_table = class_alb_new +! psiwlt_table = psiwlt +! z0soil_table = z0soil +! z0lake_table = z0lake + + !---------------- noahmptable.tbl irrigation parameters + inquire( file='noahmptable.tbl', exist=file_named ) + if ( file_named ) then + open(15, file="noahmptable.tbl", status='old', form='formatted', action='read', iostat=ierr) + else + open(15, status='old', form='formatted', action='read', iostat=ierr) + end if + if (ierr /= 0) then + write(*,'("warning: cannot find file noahmptable.tbl")') + endif + read(15,noahmp_irrigation_parameters) + close(15) + + ! assign values + irr_frac_table = irr_frac + irr_har_table = irr_har + irr_lai_table = irr_lai + irr_mad_table = irr_mad + filoss_table = filoss + sprir_rate_table = sprir_rate + micir_rate_table = micir_rate + firtfac_table = firtfac + ir_rain_table = ir_rain + + !---------------- noahmptable.tbl crop parameters + inquire( file='noahmptable.tbl', exist=file_named ) + if ( file_named ) then + open(15, file="noahmptable.tbl", status='old', form='formatted', action='read', iostat=ierr) + else + open(15, status='old', form='formatted', action='read', iostat=ierr) + end if + if (ierr /= 0) then + write(*,'("warning: cannot find file noahmptable.tbl")') + endif + read(15,noahmp_crop_parameters) + close(15) + + ! assign values + default_crop_table = default_crop + pltday_table = pltday + hsday_table = hsday + plantpop_table = plantpop + irri_table = irri + gddtbase_table = gddtbase + gddtcut_table = gddtcut + gdds1_table = gdds1 + gdds2_table = gdds2 + gdds3_table = gdds3 + gdds4_table = gdds4 + gdds5_table = gdds5 + c3psni_table (1:5) = c3psni (1:5) + kc25i_table (1:5) = kc25i (1:5) + akci_table (1:5) = akci (1:5) + ko25i_table (1:5) = ko25i (1:5) + akoi_table (1:5) = akoi (1:5) + avcmxi_table (1:5) = avcmxi (1:5) + vcmx25i_table(1:5) = vcmx25i(1:5) + bpi_table (1:5) = bpi (1:5) + mpi_table (1:5) = mpi (1:5) + folnmxi_table(1:5) = folnmxi(1:5) + qe25i_table (1:5) = qe25i (1:5) + aref_table = aref + psnrf_table = psnrf + i2par_table = i2par + tassim0_table = tassim0 + tassim1_table = tassim1 + tassim2_table = tassim2 + k_table = k + epsi_table = epsi + q10mr_table = q10mr + lefreez_table = lefreez + fra_gr_table = fra_gr + lfmr25_table = lfmr25 + stmr25_table = stmr25 + rtmr25_table = rtmr25 + grainmr25_table = grainmr25 + bio2lai_table = bio2lai + dile_fc_table(:,1) = dile_fc_s1 + dile_fc_table(:,2) = dile_fc_s2 + dile_fc_table(:,3) = dile_fc_s3 + dile_fc_table(:,4) = dile_fc_s4 + dile_fc_table(:,5) = dile_fc_s5 + dile_fc_table(:,6) = dile_fc_s6 + dile_fc_table(:,7) = dile_fc_s7 + dile_fc_table(:,8) = dile_fc_s8 + dile_fw_table(:,1) = dile_fw_s1 + dile_fw_table(:,2) = dile_fw_s2 + dile_fw_table(:,3) = dile_fw_s3 + dile_fw_table(:,4) = dile_fw_s4 + dile_fw_table(:,5) = dile_fw_s5 + dile_fw_table(:,6) = dile_fw_s6 + dile_fw_table(:,7) = dile_fw_s7 + dile_fw_table(:,8) = dile_fw_s8 + lf_ovrc_table(:,1) = lf_ovrc_s1 + lf_ovrc_table(:,2) = lf_ovrc_s2 + lf_ovrc_table(:,3) = lf_ovrc_s3 + lf_ovrc_table(:,4) = lf_ovrc_s4 + lf_ovrc_table(:,5) = lf_ovrc_s5 + lf_ovrc_table(:,6) = lf_ovrc_s6 + lf_ovrc_table(:,7) = lf_ovrc_s7 + lf_ovrc_table(:,8) = lf_ovrc_s8 + st_ovrc_table(:,1) = st_ovrc_s1 + st_ovrc_table(:,2) = st_ovrc_s2 + st_ovrc_table(:,3) = st_ovrc_s3 + st_ovrc_table(:,4) = st_ovrc_s4 + st_ovrc_table(:,5) = st_ovrc_s5 + st_ovrc_table(:,6) = st_ovrc_s6 + st_ovrc_table(:,7) = st_ovrc_s7 + st_ovrc_table(:,8) = st_ovrc_s8 + rt_ovrc_table(:,1) = rt_ovrc_s1 + rt_ovrc_table(:,2) = rt_ovrc_s2 + rt_ovrc_table(:,3) = rt_ovrc_s3 + rt_ovrc_table(:,4) = rt_ovrc_s4 + rt_ovrc_table(:,5) = rt_ovrc_s5 + rt_ovrc_table(:,6) = rt_ovrc_s6 + rt_ovrc_table(:,7) = rt_ovrc_s7 + rt_ovrc_table(:,8) = rt_ovrc_s8 + lfpt_table (:,1) = lfpt_s1 + lfpt_table (:,2) = lfpt_s2 + lfpt_table (:,3) = lfpt_s3 + lfpt_table (:,4) = lfpt_s4 + lfpt_table (:,5) = lfpt_s5 + lfpt_table (:,6) = lfpt_s6 + lfpt_table (:,7) = lfpt_s7 + lfpt_table (:,8) = lfpt_s8 + stpt_table (:,1) = stpt_s1 + stpt_table (:,2) = stpt_s2 + stpt_table (:,3) = stpt_s3 + stpt_table (:,4) = stpt_s4 + stpt_table (:,5) = stpt_s5 + stpt_table (:,6) = stpt_s6 + stpt_table (:,7) = stpt_s7 + stpt_table (:,8) = stpt_s8 + rtpt_table (:,1) = rtpt_s1 + rtpt_table (:,2) = rtpt_s2 + rtpt_table (:,3) = rtpt_s3 + rtpt_table (:,4) = rtpt_s4 + rtpt_table (:,5) = rtpt_s5 + rtpt_table (:,6) = rtpt_s6 + rtpt_table (:,7) = rtpt_s7 + rtpt_table (:,8) = rtpt_s8 + grainpt_table(:,1) = grainpt_s1 + grainpt_table(:,2) = grainpt_s2 + grainpt_table(:,3) = grainpt_s3 + grainpt_table(:,4) = grainpt_s4 + grainpt_table(:,5) = grainpt_s5 + grainpt_table(:,6) = grainpt_s6 + grainpt_table(:,7) = grainpt_s7 + grainpt_table(:,8) = grainpt_s8 + lfct_table (:,1) = lfct_s1 + lfct_table (:,2) = lfct_s2 + lfct_table (:,3) = lfct_s3 + lfct_table (:,4) = lfct_s4 + lfct_table (:,5) = lfct_s5 + lfct_table (:,6) = lfct_s6 + lfct_table (:,7) = lfct_s7 + lfct_table (:,8) = lfct_s8 + stct_table (:,1) = stct_s1 + stct_table (:,2) = stct_s2 + stct_table (:,3) = stct_s3 + stct_table (:,4) = stct_s4 + stct_table (:,5) = stct_s5 + stct_table (:,6) = stct_s6 + stct_table (:,7) = stct_s7 + stct_table (:,8) = stct_s8 + rtct_table (:,1) = rtct_s1 + rtct_table (:,2) = rtct_s2 + rtct_table (:,3) = rtct_s3 + rtct_table (:,4) = rtct_s4 + rtct_table (:,5) = rtct_s5 + rtct_table (:,6) = rtct_s6 + rtct_table (:,7) = rtct_s7 + rtct_table (:,8) = rtct_s8 + + !---------------- noahmptable.tbl tile drainage parameters + inquire( file='noahmptable.tbl', exist=file_named ) + if ( file_named ) then + open(15, file="noahmptable.tbl", status='old', form='formatted', action='read', iostat=ierr) + else + open(15, status='old', form='formatted', action='read', iostat=ierr) + end if + if (ierr /= 0) then + write(*,'("warning: cannot find file noahmptable.tbl")') + endif + read(15,noahmp_tiledrain_parameters) + close(15) + + ! assign values + drain_layer_opt_table = drain_layer_opt + tdsmc_fac_table(1:nsoiltype) = tdsmc_fac(1:nsoiltype) + td_depth_table (1:nsoiltype) = td_depth (1:nsoiltype) + td_dc_table (1:nsoiltype) = td_dc (1:nsoiltype) + td_dcoef_table (1:nsoiltype) = td_dcoef (1:nsoiltype) + td_d_table (1:nsoiltype) = td_d (1:nsoiltype) + td_adepth_table(1:nsoiltype) = td_adepth(1:nsoiltype) + td_radi_table (1:nsoiltype) = td_radi (1:nsoiltype) + td_spac_table (1:nsoiltype) = td_spac (1:nsoiltype) + td_ddrain_table(1:nsoiltype) = td_ddrain(1:nsoiltype) + klat_fac_table (1:nsoiltype) = klat_fac (1:nsoiltype) + + !---------------- noahmptable.tbl optional parameters + inquire( file='noahmptable.tbl', exist=file_named ) + if ( file_named ) then + open(15, file="noahmptable.tbl", status='old', form='formatted', action='read', iostat=ierr) + else + open(15, status='old', form='formatted', action='read', iostat=ierr) + end if + if (ierr /= 0) then + write(*,'("warning: cannot find file noahmptable.tbl")') + endif + read(15,noahmp_optional_parameters) + close(15) + + ! assign values +! sr2006_theta_1500t_a_table = sr2006_theta_1500t_a +! sr2006_theta_1500t_b_table = sr2006_theta_1500t_b +! sr2006_theta_1500t_c_table = sr2006_theta_1500t_c +! sr2006_theta_1500t_d_table = sr2006_theta_1500t_d +! sr2006_theta_1500t_e_table = sr2006_theta_1500t_e +! sr2006_theta_1500t_f_table = sr2006_theta_1500t_f +! sr2006_theta_1500t_g_table = sr2006_theta_1500t_g +! sr2006_theta_1500_a_table = sr2006_theta_1500_a +! sr2006_theta_1500_b_table = sr2006_theta_1500_b +! sr2006_theta_33t_a_table = sr2006_theta_33t_a +! sr2006_theta_33t_b_table = sr2006_theta_33t_b +! sr2006_theta_33t_c_table = sr2006_theta_33t_c +! sr2006_theta_33t_d_table = sr2006_theta_33t_d +! sr2006_theta_33t_e_table = sr2006_theta_33t_e +! sr2006_theta_33t_f_table = sr2006_theta_33t_f +! sr2006_theta_33t_g_table = sr2006_theta_33t_g +! sr2006_theta_33_a_table = sr2006_theta_33_a +! sr2006_theta_33_b_table = sr2006_theta_33_b +! sr2006_theta_33_c_table = sr2006_theta_33_c +! sr2006_theta_s33t_a_table = sr2006_theta_s33t_a +! sr2006_theta_s33t_b_table = sr2006_theta_s33t_b +! sr2006_theta_s33t_c_table = sr2006_theta_s33t_c +! sr2006_theta_s33t_d_table = sr2006_theta_s33t_d +! sr2006_theta_s33t_e_table = sr2006_theta_s33t_e +! sr2006_theta_s33t_f_table = sr2006_theta_s33t_f +! sr2006_theta_s33t_g_table = sr2006_theta_s33t_g +! sr2006_theta_s33_a_table = sr2006_theta_s33_a +! sr2006_theta_s33_b_table = sr2006_theta_s33_b +! sr2006_psi_et_a_table = sr2006_psi_et_a +! sr2006_psi_et_b_table = sr2006_psi_et_b +! sr2006_psi_et_c_table = sr2006_psi_et_c +! sr2006_psi_et_d_table = sr2006_psi_et_d +! sr2006_psi_et_e_table = sr2006_psi_et_e +! sr2006_psi_et_f_table = sr2006_psi_et_f +! sr2006_psi_et_g_table = sr2006_psi_et_g +! sr2006_psi_e_a_table = sr2006_psi_e_a +! sr2006_psi_e_b_table = sr2006_psi_e_b +! sr2006_psi_e_c_table = sr2006_psi_e_c +! sr2006_smcmax_a_table = sr2006_smcmax_a +! sr2006_smcmax_b_table = sr2006_smcmax_b + + end subroutine read_mp_table_parameters - end module noahmp_tables diff --git a/physics/noahmpdrv.F90 b/physics/noahmpdrv.F90 index dfdbd1bc6..865849e8f 100644 --- a/physics/noahmpdrv.F90 +++ b/physics/noahmpdrv.F90 @@ -169,10 +169,11 @@ subroutine noahmpdrv_run & use sfc_diff, only : stability ! use module_sf_noahmplsm use module_sf_noahmp_glacier - use noahmp_tables, only : isice_table, co2_table, o2_table, & - isurban_table, smcref_table, smcdry_table, & - smcmax_table, co2_table, o2_table, & - saim_table, laim_table +! use noahmp_tables, only : isice_table, co2_table, o2_table, & +! isurban_table, smcref_table, smcdry_table, & +! smcmax_table, co2_table, o2_table, & +! saim_table, laim_table + use noahmp_tables implicit none @@ -563,6 +564,7 @@ subroutine noahmpdrv_run & integer :: soil_category(nsoil) integer :: slope_category integer :: soil_color_category + character(len=256) :: dataset_identifier real (kind=kind_phys) :: spec_humidity_sat ! saturation specific humidity real (kind=kind_phys) :: vapor_pressure_sat ! saturation vapor pressure @@ -620,6 +622,8 @@ subroutine noahmpdrv_run & ! --- noah-mp input variables (except snow_ice_frac_old done later) ! + dataset_identifier = "modified_igbp_modis_noah" + i_location = i j_location = -9999 latitude = xlatin(i) @@ -757,6 +761,8 @@ subroutine noahmpdrv_run & soil_color_category = soilcol(i) ! soil_color_category = 4 + call read_mp_table_parameters(dataset_identifier) + call transfer_mp_parameters(vegetation_category, soil_category, & slope_category, soil_color_category, crop_type,parameters) diff --git a/physics/noahmptable.tbl b/physics/noahmptable.tbl new file mode 100644 index 000000000..e9952c754 --- /dev/null +++ b/physics/noahmptable.tbl @@ -0,0 +1,774 @@ +&noahmp_usgs_veg_categories + veg_dataset_description = "usgs" + nveg = 27 +/ +&noahmp_usgs_parameters + ! nveg = 27 + ! 1: urban and built-up land + ! 2: dryland cropland and pasture + ! 3: irrigated cropland and pasture + ! 4: mixed dryland/irrigated cropland and pasture + ! 5: cropland/grassland mosaic + ! 6: cropland/woodland mosaic + ! 7: grassland + ! 8: shrubland + ! 9: mixed shrubland/grassland + ! 10: savanna + ! 11: deciduous broadleaf forest + ! 12: deciduous needleleaf forest + ! 13: evergreen broadleaf forest + ! 14: evergreen needleleaf forest + ! 15: mixed forest + ! 16: water bodies + ! 17: herbaceous wetland + ! 18: wooded wetland + ! 19: barren or sparsely vegetated + ! 20: herbaceous tundra + ! 21: wooded tundra + ! 22: mixed tundra + ! 23: bare ground tundra + ! 24: snow or ice + ! 25: playa + ! 26: lava + ! 27: white sand + + isurban = 1 + iswater = 16 + isbarren = 19 + isice = 24 + iscrop = 2 + eblforest = 13 + natural = 5 + lcz_1 = 31 + lcz_2 = 32 + lcz_3 = 33 + lcz_4 = 34 + lcz_5 = 35 + lcz_6 = 36 + lcz_7 = 37 + lcz_8 = 38 + lcz_9 = 39 + lcz_10 = 40 + lcz_11 = 41 + + !--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- + ! 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 + !--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- + ch2op = 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, + dleaf = 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, + z0mvt = 1.00, 0.15, 0.15, 0.15, 0.14, 0.50, 0.12, 0.06, 0.09, 0.50, 0.80, 0.85, 1.10, 1.09, 0.80, 0.00, 0.12, 0.50, 0.00, 0.10, 0.30, 0.20, 0.03, 0.00, 0.01, 0.00, 0.00, + hvt = 15.0, 2.00, 2.00, 2.00, 1.50, 8.00, 1.00, 1.10, 1.10, 10.0, 16.0, 18.0, 20.0, 20.0, 16.0, 0.00, 0.50, 10.0, 0.00, 0.50, 4.00, 2.00, 0.50, 0.00, 0.10, 0.00, 0.00, + hvb = 1.00, 0.10, 0.10, 0.10, 0.10, 0.15, 0.05, 0.10, 0.10, 0.10, 11.5, 7.00, 8.00, 8.50, 10.0, 0.00, 0.05, 0.10, 0.00, 0.10, 0.10, 0.10, 0.10, 0.00, 0.10, 0.00, 0.00, + den = 0.01, 25.0, 25.0, 25.0, 25.0, 25.0, 100., 10.0, 10.0, 0.02, 0.10, 0.28, 0.02, 0.28, 0.10, 0.01, 10.0, 0.10, 0.01, 1.00, 1.00, 1.00, 1.00, 0.00, 0.01, 0.01, 0.01, + rc = 1.00, 0.08, 0.08, 0.08, 0.08, 0.08, 0.03, 0.12, 0.12, 3.00, 1.40, 1.20, 3.60, 1.20, 1.40, 0.01, 0.10, 1.40, 0.01, 0.30, 0.30, 0.30, 0.30, 0.00, 0.01, 0.01, 0.01, +!mfsno = 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, +! c. he 12/17/2020: optimized mfsno values dependent on land type based on evaluation with snotel swe and modis scf, surface albedo + mfsno = 4.00, 3.00, 3.00, 3.00, 4.00, 4.00, 2.00, 2.00, 2.00, 2.00, 1.00, 1.00, 1.00, 1.00, 1.00, 3.00, 3.00, 3.00, 3.00, 3.50, 3.50, 3.50, 3.50, 2.50, 3.50, 3.50, 3.50, +! c. he 12/17/2020: optimized snow cover factor (m) in scf formulation to replace original constant 2.5*z0,z0=0.002m, based on evaluation with snotel swe and modis scf, surface albedo + scffac= 0.042, 0.014, 0.014, 0.014, 0.026, 0.026, 0.020, 0.018, 0.016, 0.020, 0.008, 0.008, 0.008, 0.008, 0.008, 0.030, 0.020, 0.020, 0.016, 0.030, 0.030, 0.030, 0.030, 0.030, 0.030, 0.030, 0.030, + + ! row 1: vis + ! row 2: near ir + rhol_vis=0.00, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.07, 0.10, 0.10, 0.10, 0.07, 0.10, 0.07, 0.10, 0.00, 0.11, 0.10, 0.00, 0.10, 0.10, 0.10, 0.10, 0.00, 0.10, 0.00, 0.00, + rhol_nir=0.00, 0.58, 0.58, 0.58, 0.58, 0.58, 0.58, 0.35, 0.45, 0.45, 0.45, 0.35, 0.45, 0.35, 0.45, 0.00, 0.58, 0.45, 0.00, 0.45, 0.45, 0.45, 0.45, 0.00, 0.45, 0.00, 0.00, + + ! row 1: vis + ! row 2: near ir + rhos_vis=0.00, 0.36, 0.36, 0.36, 0.36, 0.36, 0.36, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.00, 0.36, 0.16, 0.00, 0.16, 0.16, 0.16, 0.16, 0.00, 0.16, 0.00, 0.00, + rhos_nir=0.00, 0.58, 0.58, 0.58, 0.58, 0.58, 0.58, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.00, 0.58, 0.39, 0.00, 0.39, 0.39, 0.39, 0.39, 0.00, 0.39, 0.00, 0.00, + + ! row 1: vis + ! row 2: near ir + taul_vis=0.00, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.00, 0.07, 0.05, 0.00, 0.05, 0.05, 0.05, 0.05, 0.00, 0.05, 0.00, 0.00, + taul_nir=0.00, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.10, 0.10, 0.25, 0.25, 0.10, 0.25, 0.10, 0.25, 0.00, 0.25, 0.25, 0.00, 0.25, 0.25, 0.25, 0.25, 0.00, 0.25, 0.00, 0.00, + + ! row 1: vis + ! row 2: near ir + taus_vis=0.00, 0.220, 0.220, 0.220, 0.220, 0.220, 0.220, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.000, 0.220, 0.001, 0.000, 0.220, 0.001, 0.001, 0.001, 0.000, 0.001, 0.000, 0.000, + taus_nir=0.00, 0.380, 0.380, 0.380, 0.380, 0.380, 0.380, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.000, 0.380, 0.001, 0.000, 0.380, 0.001, 0.001, 0.001, 0.000, 0.001, 0.000, 0.000, + + xl = 0.000, -0.30, -0.30, -0.30, -0.30, -0.30, -0.30, 0.010, 0.250, 0.010, 0.250, 0.010, 0.010, 0.010, 0.250, 0.000, -0.30, 0.250, 0.000, -0.30, 0.250, 0.250, 0.250, 0.000, 0.250, 0.000, 0.000, + ! make cwpvt vegetation dependent according to j. goudriaan, crop micrometeorology: a simulation study (simulation monographs), 1977). c. he, 12/17/2020 + cwpvt = 0.18, 1.67, 1.67, 1.67, 1.67, 0.5, 5.0, 1.0, 2.0, 1.0, 0.67, 0.18, 0.67, 0.18, 0.29, 0.18, 1.67, 0.67, 0.18, 1.67, 0.67, 1.00, 0.18, 0.18, 0.18, 0.18, 0.18, + c3psn = 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, + kc25 = 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, + akc = 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, + ko25 = 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, + ako = 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, + avcmx = 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, + aqe = 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, + + ltovrc= 0.0, 1.2, 1.2, 1.2, 1.2, 1.30, 0.50, 0.65, 0.70, 0.65, 0.55, 0.2, 0.55, 0.5, 0.5, 0.0, 1.4, 1.4, 0.0, 1.2, 1.3, 1.4, 1.0, 0.0, 1.0, 0.0, 0.0, + dilefc= 0.00, 0.50, 0.50, 0.50, 0.35, 0.20, 0.20, 0.20, 0.50, 0.50, 0.60, 1.80, 0.50, 1.20, 0.80, 0.00, 0.40, 0.40, 0.00, 0.40, 0.30, 0.40, 0.30, 0.00, 0.30, 0.00, 0.00, + dilefw= 0.00, 0.20, 0.20, 0.20, 0.20, 0.20, 0.10, 0.20, 0.20, 0.50, 0.20, 0.20, 4.00, 0.20, 0.20, 0.00, 0.20, 0.20, 0.00, 0.20, 0.20, 0.20, 0.20, 0.00, 0.20, 0.00, 0.00, + rmf25 = 0.00, 1.00, 1.40, 1.45, 1.45, 1.45, 1.80, 0.26, 0.26, 0.80, 3.00, 4.00, 0.65, 3.00, 3.00, 0.00, 3.20, 3.20, 0.00, 3.20, 3.00, 3.00, 3.00, 0.00, 3.00, 0.00, 0.00, + sla = 60, 80, 80, 80, 80, 80, 60, 60, 60, 50, 80, 80, 80, 80, 80, 0, 80, 80, 0, 80, 80, 80, 80, 0, 80, 0, 0, + fragr = 0.00, 0.20, 0.20, 0.20, 0.20, 0.20, 0.20, 0.20, 0.20, 0.20, 0.20, 0.10, 0.20, 0.10, 0.10, 0.00, 0.10, 0.10, 0.10, 0.10, 0.10, 0.10, 0.10, 0.00, 0.10, 0.00, 0.00, + tmin = 0, 273, 273, 273, 273, 273, 273, 273, 273, 273, 273, 268, 273, 265, 268, 0, 268, 268, 0, 268, 268, 268, 268, 0, 268, 0, 0, + vcmx25= 0.00, 80.0, 80.0, 80.0, 60.0, 70.0, 40.0, 40.0, 40.0, 40.0, 60.0, 60.0, 60.0, 50.0, 55.0, 0.00, 50.0, 50.0, 0.00, 50.0, 50.0, 50.0, 50.0, 0.00, 50.0, 0.00, 0.00, + tdlef = 278, 278, 278, 278, 278, 278, 278, 278, 278, 278, 278, 268, 278, 278, 268, 0, 268, 268, 0, 268, 268, 268, 268, 0, 268, 0, 0, + bp = 1.e15, 2.e3, 2.e3, 2.e3, 2.e3, 2.e3, 2.e3, 2.e3, 2.e3, 2.e3, 2.e3, 2.e3, 2.e3, 2.e3, 2.e3, 1.e15, 2.e3, 2.e3, 2.e3, 2.e3, 2.e3, 2.e3, 2.e3, 1.e15, 2.e3, 1.e15, 1.e15, + mp = 9., 9., 9., 9., 9., 9., 9., 9., 9., 9., 9., 6., 9., 6., 9., 9., 9., 9., 9., 9., 9., 9., 9., 9., 9., 9., 9., + qe25 = 0., 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.00, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.00, 0.06, 0.00, 0.00, + rms25 = 0.00, 0.10, 0.10, 0.10, 0.10, 0.10, 0.10, 0.10, 0.10, 0.32, 0.10, 0.64, 0.30, 0.90, 0.80, 0.00, 0.10, 0.10, 0.00, 0.10, 0.10, 0.10, 0.00, 0.00, 0.00, 0.00, 0.00, + rmr25 = 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 1.20, 0.00, 0.00, 0.01, 0.01, 0.05, 0.05, 0.36, 0.03, 0.00, 0.00, 0.00, 0.00, 2.11, 2.11, 2.11, 0.00, 0.00, 0.00, 0.00, 0.00, + arm = 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, + folnmx= 0.00, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 0.00, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 0.00, 1.5, 0.00, 0.00, + wdpool= 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 0.00, 0.00, 1.00, 0.00, 0.00, 1.00, 1.00, 0.00, 0.00, 0.00, 0.00, 0.00, + wrrat = 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 3.00, 3.00, 3.00, 30.0, 30.0, 30.0, 30.0, 30.0, 0.00, 0.00, 30.0, 0.00, 0.00, 3.00, 3.00, 0.00, 0.00, 0.00, 0.00, 0.00, + mrp = 0.00, 0.23, 0.23, 0.23, 0.23, 0.23, 0.17, 0.19, 0.19, 0.40, 0.40, 0.37, 0.23, 0.37, 0.30, 0.00, 0.17, 0.40, 0.00, 0.17, 0.23, 0.20, 0.00, 0.00, 0.20, 0.00, 0.00, + nroot = 1, 3, 3, 3, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 0, 2, 2, 1, 3, 3, 3, 2, 1, 1, 0, 0, + rgl = 999.0, 100.0, 100.0, 100.0, 100.0, 65.0, 100.0, 100.0, 100.0, 65.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 100.0, 30.0, 999.0, 100.0, 100.0, 100.0, 100.0, 999.0, 100.0, 999.0, 999.0, + rs = 200.0, 40.0, 40.0, 40.0, 40.0, 70.0, 40.0, 300.0, 170.0, 70.0, 100.0, 150.0, 150.0, 125.0, 125.0, 100.0, 40.0, 100.0, 999.0, 150.0, 150.0, 150.0, 200.0, 999.0, 40.0, 999.0, 999.0, + hs = 999.0, 36.25, 36.25, 36.25, 36.25, 44.14, 36.35, 42.00, 39.18, 54.53, 54.53, 47.35, 41.69, 47.35, 51.93, 51.75, 60.00, 51.93, 999.0, 42.00, 42.00, 42.00, 42.00, 999.0, 36.25, 999.0, 999.0, + topt = 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, + rsmax = 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., + rtovrc = 2.e-8,2.e-8, 2.e-8, 2.e-8, 2.e-8, 2.e-8, 2.e-8, 2.e-8, 2.e-8, 2.e-8, 2.e-8, 2.e-8, 2.e-8, 2.e-8, 2.e-8, 2.e-8, 2.e-8, 2.e-8, 2.e-8, 2.e-8, 2.e-8, 2.e-8, 2.e-8, 2.e-8, 2.e-8, 2.e-8, 2.e-8, + rswoodc= 3.e-10,3.e-10,3.e-10,3.e-10,3.e-10,3.e-10,3.e-10,3.e-10,3.e-10,3.e-10,3.e-10,3.e-10,3.e-10,3.e-10,3.e-10,3.e-10,3.e-10,3.e-10,3.e-10,3.e-10,3.e-10,3.e-10,3.e-10,3.e-10,3.e-10,3.e-10,3.e-10, + bf = 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, + wstrc = 100.0,100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, + laimin = 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, + xsamin = 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, + +! monthly values, one row for each month: + sai_jan = 0.0, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.2, 0.2, 0.3, 0.4, 0.3, 0.5, 0.4, 0.4, 0.0, 0.2, 0.3, 0.0, 0.1, 0.2, 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, + sai_feb = 0.0, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.2, 0.2, 0.3, 0.4, 0.3, 0.5, 0.4, 0.4, 0.0, 0.2, 0.3, 0.0, 0.1, 0.2, 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, + sai_mar = 0.0, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.2, 0.2, 0.3, 0.4, 0.3, 0.5, 0.4, 0.4, 0.0, 0.2, 0.3, 0.0, 0.1, 0.2, 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, + sai_apr = 0.0, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.2, 0.2, 0.3, 0.4, 0.4, 0.5, 0.3, 0.4, 0.0, 0.2, 0.3, 0.0, 0.1, 0.2, 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, + sai_may = 0.0, 0.2, 0.2, 0.2, 0.3, 0.3, 0.3, 0.2, 0.2, 0.3, 0.4, 0.4, 0.5, 0.4, 0.4, 0.0, 0.3, 0.3, 0.0, 0.1, 0.2, 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, + sai_jun = 0.0, 0.3, 0.3, 0.3, 0.4, 0.4, 0.4, 0.2, 0.3, 0.4, 0.4, 0.7, 0.5, 0.5, 0.4, 0.0, 0.4, 0.4, 0.0, 0.2, 0.2, 0.2, 0.0, 0.0, 0.0, 0.0, 0.0, + sai_jul = 0.0, 0.4, 0.4, 0.4, 0.6, 0.6, 0.8, 0.4, 0.6, 0.8, 0.9, 1.3, 0.5, 0.5, 0.7, 0.0, 0.6, 0.6, 0.0, 0.4, 0.4, 0.4, 0.0, 0.0, 0.0, 0.0, 0.0, + sai_aug = 0.0, 0.5, 0.5, 0.5, 0.9, 0.9, 1.3, 0.6, 0.9, 1.2, 1.2, 1.2, 0.5, 0.6, 0.8, 0.0, 0.9, 0.9, 0.0, 0.6, 0.6, 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, + sai_sep = 0.0, 0.4, 0.4, 0.4, 0.7, 1.0, 1.1, 0.8, 1.0, 1.3, 1.6, 1.0, 0.5, 0.6, 1.0, 0.0, 0.7, 1.0, 0.0, 0.7, 0.8, 0.7, 0.0, 0.0, 0.0, 0.0, 0.0, + sai_oct = 0.0, 0.3, 0.3, 0.3, 0.3, 0.8, 0.4, 0.7, 0.6, 0.7, 1.4, 0.8, 0.5, 0.7, 1.0, 0.0, 0.3, 0.8, 0.0, 0.5, 0.7, 0.5, 0.0, 0.0, 0.0, 0.0, 0.0, + sai_nov = 0.0, 0.3, 0.3, 0.3, 0.3, 0.4, 0.4, 0.3, 0.3, 0.4, 0.6, 0.6, 0.5, 0.6, 0.5, 0.0, 0.3, 0.4, 0.0, 0.3, 0.3, 0.3, 0.0, 0.0, 0.0, 0.0, 0.0, + sai_dec = 0.0, 0.3, 0.3, 0.3, 0.3, 0.3, 0.4, 0.2, 0.3, 0.4, 0.4, 0.5, 0.5, 0.5, 0.4, 0.0, 0.3, 0.4, 0.0, 0.2, 0.2, 0.2, 0.0, 0.0, 0.0, 0.0, 0.0, + + lai_jan = 0.0, 0.0, 0.0, 0.0, 0.2, 0.0, 0.4, 0.0, 0.2, 0.3, 0.0, 0.0, 4.5, 4.0, 2.0, 0.0, 0.2, 0.2, 0.0, 0.2, 1.0, 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, + lai_feb = 0.0, 0.0, 0.0, 0.0, 0.3, 0.0, 0.5, 0.0, 0.3, 0.3, 0.0, 0.0, 4.5, 4.0, 2.0, 0.0, 0.3, 0.3, 0.0, 0.3, 1.0, 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, + lai_mar = 0.0, 0.0, 0.0, 0.0, 0.3, 0.2, 0.6, 0.2, 0.4, 0.5, 0.3, 0.0, 4.5, 4.0, 2.2, 0.0, 0.3, 0.3, 0.0, 0.3, 1.1, 0.7, 0.0, 0.0, 0.0, 0.0, 0.0, + lai_apr = 0.0, 0.0, 0.0, 0.0, 0.4, 0.6, 0.7, 0.6, 0.7, 0.8, 1.2, 0.6, 4.5, 4.0, 2.6, 0.0, 0.4, 0.6, 0.0, 0.4, 1.3, 0.8, 0.0, 0.0, 0.0, 0.0, 0.0, + lai_may = 0.0, 1.0, 1.0, 1.0, 1.1, 2.0, 1.2, 1.5, 1.4, 1.8, 3.0, 1.2, 4.5, 4.0, 3.5, 0.0, 1.1, 2.0, 0.0, 0.6, 1.7, 1.2, 0.0, 0.0, 0.0, 0.0, 0.0, + lai_jun = 0.0, 2.0, 2.0, 2.0, 2.5, 3.3, 3.0, 2.3, 2.6, 3.6, 4.7, 2.0, 4.5, 4.0, 4.3, 0.0, 2.5, 3.3, 0.0, 1.5, 2.1, 1.8, 0.0, 0.0, 0.0, 0.0, 0.0, + lai_jul = 0.0, 3.0, 3.0, 3.0, 3.2, 3.7, 3.5, 2.3, 2.9, 3.8, 4.5, 2.6, 4.5, 4.0, 4.3, 0.0, 3.2, 3.7, 0.0, 1.7, 2.1, 1.8, 0.0, 0.0, 0.0, 0.0, 0.0, + lai_aug = 0.0, 3.0, 3.0, 3.0, 2.2, 3.2, 1.5, 1.7, 1.6, 2.1, 3.4, 1.7, 4.5, 4.0, 3.7, 0.0, 2.2, 3.2, 0.0, 0.8, 1.8, 1.3, 0.0, 0.0, 0.0, 0.0, 0.0, + lai_sep = 0.0, 1.5, 1.5, 1.5, 1.1, 1.3, 0.7, 0.6, 0.7, 0.9, 1.2, 1.0, 4.5, 4.0, 2.6, 0.0, 1.1, 1.3, 0.0, 0.4, 1.3, 0.8, 0.0, 0.0, 0.0, 0.0, 0.0, + lai_oct = 0.0, 0.0, 0.0, 0.0, 0.3, 0.2, 0.6, 0.2, 0.4, 0.5, 0.3, 0.5, 4.5, 4.0, 2.2, 0.0, 0.3, 0.3, 0.0, 0.3, 1.1, 0.7, 0.0, 0.0, 0.0, 0.0, 0.0, + lai_nov = 0.0, 0.0, 0.0, 0.0, 0.3, 0.0, 0.5, 0.0, 0.3, 0.3, 0.0, 0.2, 4.5, 4.0, 2.0, 0.0, 0.3, 0.3, 0.0, 0.2, 1.0, 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, + lai_dec = 0.0, 0.0, 0.0, 0.0, 0.2, 0.0, 0.4, 0.0, 0.2, 0.3, 0.0, 0.0, 4.5, 4.0, 2.0, 0.0, 0.2, 0.2, 0.0, 0.2, 1.0, 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, + +! five types, one row for each type (bvoc currently not active). + eps1 = 41.87, 0.00, 0.00, 2.52, 0.04, 17.11, 0.02, 21.62, 0.11, 22.80, 46.86, 0.00, 0.00, 0.46, 30.98, 2.31, 1.63, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, + eps2 = 0.98, 0.00, 0.00, 0.16, 0.09, 0.28, 0.05, 0.92, 0.22, 0.59, 0.38, 0.00, 0.00, 3.34, 0.96, 1.47, 1.07, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, + eps3 = 1.82, 0.00, 0.00, 0.23, 0.05, 0.81, 0.03, 1.73, 1.26, 1.37, 1.84, 0.00, 0.00, 1.85, 1.84, 1.70, 1.21, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, + eps4 = 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, + eps5 = 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, +/ + +&noahmp_modis_veg_categories + veg_dataset_description = "modified igbp modis noah" + nveg = 20 +/ + +&noahmp_modis_parameters +! 1 'evergreen needleleaf forest' -> usgs 14 +! 2, 'evergreen broadleaf forest' -> usgs 13 +! 3, 'deciduous needleleaf forest' -> usgs 12 +! 4, 'deciduous broadleaf forest' -> usgs 11 +! 5, 'mixed forests' -> usgs 15 +! 6, 'closed shrublands' -> usgs 8 "shrubland" +! 7, 'open shrublands' -> usgs 9 "shrubland/grassland" +! 8, 'woody savannas' -> usgs 8 "shrubland" +! 9, 'savannas' -> usgs 10 +! 10, 'grasslands' -> usgs 7 +! 11 'permanent wetlands' -> avg of usgs 17 and 18 (herb. wooded wetland) +! 12, 'croplands' -> usgs 2 "dryland cropland" +! 13, 'urban and built-up' -> usgs 1 +! 14 'cropland/natural vegetation mosaic' -> usgs 5 "cropland/grassland" +! 15, 'snow and ice' -> usgs 24 +! 16, 'barren or sparsely vegetated' -> usgs 19 +! 17, 'water' -> usgs 16 +! 18, 'wooded tundra' -> usgs 21 +! 19, 'mixed tundra' -> usgs 22 +! 20, 'barren tundra' -> usgs 23 + + isurban = 13 + iswater = 17 + isbarren = 16 + isice = 15 + iscrop = 12 + eblforest = 2 + natural = 14 + lcz_1 = 31 + lcz_2 = 32 + lcz_3 = 33 + lcz_4 = 34 + lcz_5 = 35 + lcz_6 = 36 + lcz_7 = 37 + lcz_8 = 38 + lcz_9 = 39 + lcz_10 = 40 + lcz_11 = 41 + !--------------------------------------------------------------------------------------------------------------------------------------------------------------------- + ! 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 + !--------------------------------------------------------------------------------------------------------------------------------------------------------------------- + ch2op = 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, + dleaf = 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, + z0mvt = 1.09, 1.10, 0.85, 0.80, 0.80, 0.20, 0.06, 0.60, 0.50, 0.12, 0.30, 0.15, 1.00, 0.14, 0.00, 0.00, 0.00, 0.30, 0.20, 0.03, + hvt = 20.0, 20.0, 18.0, 16.0, 16.0, 1.10, 1.10, 13.0, 10.0, 1.00, 5.00, 2.00, 15.0, 1.50, 0.00, 0.00, 0.00, 4.00, 2.00, 0.50, + hvb = 8.50, 8.00, 7.00, 11.5, 10.0, 0.10, 0.10, 0.10, 0.10, 0.05, 0.10, 0.10, 1.00, 0.10, 0.00, 0.00, 0.00, 0.30, 0.20, 0.10, + den = 0.28, 0.02, 0.28, 0.10, 0.10, 10.0, 10.0, 10.0, 0.02, 100., 5.05, 25.0, 0.01, 25.0, 0.00, 0.01, 0.01, 1.00, 1.00, 1.00, + rc = 1.20, 3.60, 1.20, 1.40, 1.40, 0.12, 0.12, 0.12, 3.00, 0.03, 0.75, 0.08, 1.00, 0.08, 0.00, 0.01, 0.01, 0.30, 0.30, 0.30, +!mfsno = 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, +! c. he 12/17/2020: optimized mfsno values dependent on land type based on evaluation with snotel swe and modis scf, surface albedo + mfsno = 1.00, 1.00, 1.00, 1.00, 1.00, 2.00, 2.00, 2.00, 2.00, 2.00, 3.00, 3.00, 4.00, 4.00, 2.50, 3.00, 3.00, 3.50, 3.50, 3.50, +! c. he 12/17/2020: optimized snow cover factor (m) in scf formulation to replace original constant 2.5*z0,z0=0.002m, based on evaluation with snotel swe and modis scf, surface albedo + scffac = 0.008, 0.008, 0.008, 0.008, 0.008, 0.016, 0.016, 0.020, 0.020, 0.020, 0.020, 0.014, 0.042, 0.026, 0.030, 0.016, 0.030, 0.030, 0.030, 0.030, + + ! row 1: vis + ! row 2: near ir + rhol_vis=0.07, 0.10, 0.07, 0.10, 0.10, 0.07, 0.07, 0.07, 0.10, 0.11, 0.105, 0.11, 0.00, 0.11, 0.00, 0.00, 0.00, 0.10, 0.10, 0.10, + rhol_nir=0.35, 0.45, 0.35, 0.45, 0.45, 0.35, 0.35, 0.35, 0.45, 0.58, 0.515, 0.58, 0.00, 0.58, 0.00, 0.00, 0.00, 0.45, 0.45, 0.45, + + ! row 1: vis + ! row 2: near ir + rhos_vis=0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.36, 0.26, 0.36, 0.00, 0.36, 0.00, 0.00, 0.00, 0.16, 0.16, 0.16, + rhos_nir=0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.58, 0.485, 0.58, 0.00, 0.58, 0.00, 0.00, 0.00, 0.39, 0.39, 0.39, + + ! row 1: vis + ! row 2: near ir + taul_vis=0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.07, 0.06, 0.07, 0.00, 0.07, 0.00, 0.00, 0.00, 0.05, 0.05, 0.05, + taul_nir=0.10, 0.25, 0.10, 0.25, 0.25, 0.10, 0.10, 0.10, 0.25, 0.25, 0.25, 0.25, 0.00, 0.25, 0.00, 0.00, 0.00, 0.25, 0.25, 0.25, + + ! row 1: vis + ! row 2: near ir + taus_vis=0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.220, 0.1105, 0.220, 0.000, 0.220, 0.000, 0.000, 0.000, 0.001, 0.001, 0.001, + taus_nir=0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.380, 0.1905, 0.380, 0.000, 0.380, 0.000, 0.000, 0.000, 0.001, 0.001, 0.001, + + xl = 0.010, 0.010, 0.010, 0.250, 0.250, 0.010, 0.010, 0.010, 0.010, -0.30, -0.025, -0.30, 0.000, -0.30, 0.000, 0.000, 0.000, 0.250, 0.250, 0.250, +! make cwpvt vegetation dependent according to j. goudriaan, crop micrometeorology: a simulation study (simulation monographs), 1977). c. he, 12/17/2020 + cwpvt = 0.18, 0.67, 0.18, 0.67, 0.29, 1.0, 2.0, 1.3, 1.0, 5.0, 1.17, 1.67, 1.67, 1.67, 0.18, 0.18, 0.18, 0.67, 1.0, 0.18, + c3psn = 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, + kc25 = 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, + akc = 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, + ko25 = 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, + ako = 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, + avcmx = 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, + aqe = 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, + + ltovrc= 0.5, 0.55, 0.2, 0.55, 0.5, 0.65, 0.65, 0.65, 0.65, 0.50, 1.4, 1.6, 0.0, 1.2, 0.0, 0.0, 0.0, 1.3, 1.4, 1.0, + dilefc= 1.20, 0.50, 1.80, 0.60, 0.80, 0.20, 0.20, 0.20, 0.50, 0.20, 0.4, 0.50, 0.00, 0.35, 0.00, 0.00, 0.00, 0.30, 0.40, 0.30, + dilefw= 0.20, 4.00, 0.20, 0.20, 0.20, 0.20, 0.20, 0.20, 0.50, 0.10, 0.2, 0.20, 0.00, 0.20, 0.00, 0.00, 0.00, 0.20, 0.20, 0.20, + rmf25 = 3.00, 0.65, 4.00, 3.00, 3.00, 0.26, 0.26, 0.26, 0.80, 1.80, 3.2, 1.00, 0.00, 1.45, 0.00, 0.00, 0.00, 3.00, 3.00, 3.00, + sla = 80, 80, 80, 80, 80, 60, 60, 60, 50, 60, 80, 80, 60, 80, 0, 0, 0, 80, 80, 80, + fragr = 0.10, 0.20, 0.10, 0.20, 0.10, 0.20, 0.20, 0.20, 0.20, 0.20, 0.1, 0.20, 0.00, 0.20, 0.00, 0.10, 0.00, 0.10, 0.10, 0.10, + tmin = 265, 273, 268, 273, 268, 273, 273, 273, 273, 273, 268, 273, 0, 273, 0, 0, 0, 268, 268, 268, + vcmx25= 50.0, 60.0, 60.0, 60.0, 55.0, 40.0, 40.0, 40.0, 40.0, 40.0, 50.0, 80.0, 0.00, 60.0, 0.00, 0.00, 0.00, 50.0, 50.0, 50.0, + tdlef = 278, 278, 268, 278, 268, 278, 278, 278, 278, 278, 268, 278, 278, 278, 0, 0, 0, 268, 268, 268, + bp = 2.e3, 2.e3, 2.e3, 2.e3, 2.e3, 2.e3, 2.e3, 2.e3, 2.e3, 2.e3, 2.e3, 2.e3, 1.e15, 2.e3, 1.e15, 2.e3, 1.e15, 2.e3, 2.e3, 2.e3, + mp = 6., 9., 6., 9., 9., 9., 9., 9., 9., 9., 9., 9., 9., 9., 9., 9., 9., 9., 9., 9., + qe25 = 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.00, 0.06, 0.00, 0.06, 0.00, 0.06, 0.06, 0.06, + rms25 = 0.90, 0.30, 0.64, 0.10, 0.80, 0.10, 0.10, 0.10, 0.32, 0.10, 0.10, 0.10, 0.00, 0.10, 0.00, 0.00, 0.00, 0.10, 0.10, 0.00, + rmr25 = 0.36, 0.05, 0.05, 0.01, 0.03, 0.00, 0.00, 0.00, 0.01, 1.20, 0.0, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 2.11, 2.11, 0.00, + arm = 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, + folnmx= 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 0.00, 1.5, 0.00, 1.5, 0.00, 1.5, 1.5, 1.5, + wdpool= 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 0.00, 0.5, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 1.00, 1.00, 0.00, + wrrat = 30.0, 30.0, 30.0, 30.0, 30.0, 3.00, 3.00, 3.00, 3.00, 0.00, 15.0, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 3.00, 3.00, 0.00, + mrp = 0.37, 0.23, 0.37, 0.40, 0.30, 0.19, 0.19, 0.19, 0.40, 0.17, 0.285, 0.23, 0.00, 0.23, 0.00, 0.00, 0.00, 0.23, 0.20, 0.00, + nroot = 4, 4, 4, 4, 4, 3, 3, 3, 3, 3, 2, 3, 1, 3, 1, 1, 0, 3, 3, 2, + rgl = 30.0, 30.0, 30.0, 30.0, 30.0, 100.0, 100.0, 100.0, 65.0, 100.0, 65.0, 100.0, 999.0, 100.0, 999.0, 999.0, 30.0, 100.0, 100.0, 100.0, + rs = 125.0, 150.0, 150.0, 100.0, 125.0, 300.0, 170.0, 300.0, 70.0, 40.0, 70.0, 40.0, 200.0, 40.0, 999.0, 999.0, 100.0, 150.0, 150.0, 200.0, + hs = 47.35, 41.69, 47.35, 54.53, 51.93, 42.00, 39.18, 42.00, 54.53, 36.35, 55.97, 36.25, 999.0, 36.25, 999.0, 999.0, 51.75, 42.00, 42.00, 42.00, + topt = 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, + rsmax = 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., + rtovrc = 2.e-8, 2.e-8, 2.e-8, 2.e-8, 2.e-8, 2.e-8, 2.e-8, 2.e-8, 2.e-8, 2.e-8, 2.e-8, 2.e-8, 2.e-8, 2.e-8, 2.e-8, 2.e-8, 2.e-8, 2.e-8, 2.e-8, 2.e-8, + rswoodc= 3.e-10,3.e-10,3.e-10, 3.e-10, 3.e-10, 3.e-10, 3.e-10, 3.e-10, 3.e-10, 3.e-10, 3.e-10, 3.e-10, 3.e-10, 3.e-10, 3.e-10, 3.e-10, 3.e-10, 3.e-10, 3.e-10, 3.e-10, + bf = 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, + wstrc = 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, + laimin = 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, + xsamin = 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, + +! monthly values, one row for each month: + sai_jan = 0.4, 0.5, 0.3, 0.4, 0.4, 0.3, 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, 0.1, 0.0, + sai_feb = 0.4, 0.5, 0.3, 0.4, 0.4, 0.3, 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, 0.1, 0.0, + sai_mar = 0.4, 0.5, 0.3, 0.4, 0.4, 0.3, 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, 0.1, 0.0, + sai_apr = 0.3, 0.5, 0.4, 0.4, 0.4, 0.3, 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, 0.1, 0.0, + sai_may = 0.4, 0.5, 0.4, 0.4, 0.4, 0.3, 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, 0.1, 0.0, + sai_jun = 0.5, 0.5, 0.7, 0.4, 0.4, 0.3, 0.2, 0.4, 0.4, 0.4, 0.4, 0.3, 0.0, 0.4, 0.0, 0.0, 0.0, 0.2, 0.2, 0.0, + sai_jul = 0.5, 0.5, 1.3, 0.9, 0.7, 0.6, 0.4, 0.7, 0.8, 0.8, 0.6, 0.4, 0.0, 0.6, 0.0, 0.0, 0.0, 0.4, 0.4, 0.0, + sai_aug = 0.6, 0.5, 1.2, 1.2, 0.8, 0.9, 0.6, 1.2, 1.2, 1.3, 0.9, 0.5, 0.0, 0.9, 0.0, 0.0, 0.0, 0.6, 0.6, 0.0, + sai_sep = 0.6, 0.5, 1.0, 1.6, 1.0, 1.2, 0.8, 1.4, 1.3, 1.1, 0.9, 0.4, 0.0, 0.7, 0.0, 0.0, 0.0, 0.8, 0.7, 0.0, + sai_oct = 0.7, 0.5, 0.8, 1.4, 1.0, 0.9, 0.7, 1.1, 0.7, 0.4, 0.6, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.7, 0.5, 0.0, + sai_nov = 0.6, 0.5, 0.6, 0.6, 0.5, 0.4, 0.3, 0.5, 0.4, 0.4, 0.4, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.3, 0.3, 0.0, + sai_dec = 0.5, 0.5, 0.5, 0.4, 0.4, 0.3, 0.2, 0.4, 0.4, 0.4, 0.3, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, 0.2, 0.0, + + lai_jan = 4.0, 4.5, 0.0, 0.0, 2.0, 0.0, 0.0, 0.2, 0.3, 0.4, 0.2, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0, 1.0, 0.6, 0.0, + lai_feb = 4.0, 4.5, 0.0, 0.0, 2.0, 0.0, 0.0, 0.2, 0.3, 0.5, 0.3, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0, 1.0, 0.6, 0.0, + lai_mar = 4.0, 4.5, 0.0, 0.3, 2.2, 0.3, 0.2, 0.4, 0.5, 0.6, 0.3, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0, 1.1, 0.7, 0.0, + lai_apr = 4.0, 4.5, 0.6, 1.2, 2.6, 0.9, 0.6, 1.0, 0.8, 0.7, 0.5, 0.0, 0.0, 0.4, 0.0, 0.0, 0.0, 1.3, 0.8, 0.0, + lai_may = 4.0, 4.5, 1.2, 3.0, 3.5, 2.2, 1.5, 2.4, 1.8, 1.2, 1.5, 1.0, 0.0, 1.1, 0.0, 0.0, 0.0, 1.7, 1.2, 0.0, + lai_jun = 4.0, 4.5, 2.0, 4.7, 4.3, 3.5, 2.3, 4.1, 3.6, 3.0, 2.9, 2.0, 0.0, 2.5, 0.0, 0.0, 0.0, 2.1, 1.8, 0.0, + lai_jul = 4.0, 4.5, 2.6, 4.5, 4.3, 3.5, 2.3, 4.1, 3.8, 3.5, 3.5, 3.0, 0.0, 3.2, 0.0, 0.0, 0.0, 2.1, 1.8, 0.0, + lai_aug = 4.0, 4.5, 1.7, 3.4, 3.7, 2.5, 1.7, 2.7, 2.1, 1.5, 2.7, 3.0, 0.0, 2.2, 0.0, 0.0, 0.0, 1.8, 1.3, 0.0, + lai_sep = 4.0, 4.5, 1.0, 1.2, 2.6, 0.9, 0.6, 1.0, 0.9, 0.7, 1.2, 1.5, 0.0, 1.1, 0.0, 0.0, 0.0, 1.3, 0.8, 0.0, + lai_oct = 4.0, 4.5, 0.5, 0.3, 2.2, 0.3, 0.2, 0.4, 0.5, 0.6, 0.3, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0, 1.1, 0.7, 0.0, + lai_nov = 4.0, 4.5, 0.2, 0.0, 2.0, 0.0, 0.0, 0.2, 0.3, 0.5, 0.3, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0, 1.0, 0.6, 0.0, + lai_dec = 4.0, 4.5, 0.0, 0.0, 2.0, 0.0, 0.0, 0.2, 0.3, 0.4, 0.2, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0, 1.0, 0.6, 0.0, + +! five types, one row for each type (bvoc currently not active). + eps1 = 0.46, 0.00, 0.00, 46.86, 30.98, 21.62, 0.11, 21.62, 22.80, 0.02, 0.815, 0.00, 41.87, 0.04, 0.0, 0.0, 2.31, 0.0, 0.0, 0.0, + eps2 = 3.34, 0.00, 0.00, 0.38, 0.96, 0.92, 0.22, 0.92, 0.59, 0.05, 0.535, 0.00, 0.98, 0.09, 0.0, 0.0, 1.47, 0.0, 0.0, 0.0, + eps3 = 1.85, 0.00, 0.00, 1.84, 1.84, 1.73, 1.26, 1.73, 1.37, 0.03, 0.605, 0.00, 1.82, 0.05, 0.0, 0.0, 1.70, 0.0, 0.0, 0.0, + eps4 = 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, + eps5 = 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, + +/ + +&noahmp_rad_parameters + !-------------------------------------------------------------------------------------------------------------------------------------------------------------------------- + ! 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 soil color index for soil albedo + !-------------------------------------------------------------------------------------------------------------------------------------------------------------------------- + albsat_vis = 0.25, 0.23, 0.21, 0.20, 0.19, 0.18, 0.17, 0.16, 0.15, 0.14, 0.13, 0.12, 0.11, 0.10, 0.09, 0.08, 0.07, 0.06, 0.05, 0.04 ! saturated soil albedos + albsat_nir = 0.50, 0.46, 0.42, 0.40, 0.38, 0.36, 0.34, 0.32, 0.30, 0.28, 0.26, 0.24, 0.22, 0.20, 0.18, 0.16, 0.14, 0.12, 0.10, 0.08 ! saturated soil albedos + albdry_vis = 0.36, 0.34, 0.32, 0.31, 0.30, 0.29, 0.28, 0.27, 0.26, 0.25, 0.24, 0.23, 0.22, 0.20, 0.18, 0.16, 0.14, 0.12, 0.10, 0.08 ! dry soil albedos + albdry_nir = 0.61, 0.57, 0.53, 0.51, 0.49, 0.48, 0.45, 0.43, 0.41, 0.39, 0.37, 0.35, 0.33, 0.31, 0.29, 0.27, 0.25, 0.23, 0.21, 0.16 ! dry soil albedos + albice = 0.80, 0.55 ! albedo land ice: 1=vis, 2=nir + alblak = 0.60, 0.40 ! albedo frozen lakes: 1=vis, 2=nir + omegas = 0.8 , 0.4 ! two-stream parameter omega for snow + betads = 0.5 ! two-stream parameter betad for snow + betais = 0.5 ! two-stream parameter betai for snow + eg = 0.97, 0.98 ! emissivity soil surface 1-soil;2-lake + eice = 0.98 ! emissivity ice surface +/ + +&noahmp_global_parameters + +! atmospheric constituants + + co2 = 395.e-06 !co2 partial pressure + o2 = 0.209 !o2 partial pressure + +! runoff parameters used for simtop and simgm: + + timean = 10.5 !gridcell mean topgraphic index (global mean) + fsatmx = 0.38 !maximum surface saturated fraction (global mean) + +! adjustable parameters for snow processes + + z0sno = 0.002 !snow surface roughness length (m) (0.002) + ssi = 0.03 !liquid water holding capacity for snowpack (m3/m3) (0.03) + snow_ret_fac = 5.e-5 !snowpack water release timescale factor (1/s) + snow_emis = 0.95 !snow emissivity (bring from hard-coded value of 1.0 to here) + swemx = 1.00 !new snow mass to fully cover old snow (mm) + !equivalent to 10mm depth (density = 100 kg/m3) + tau0 = 1.e6 !tau0 from yang97 eqn. 10a + grain_growth = 5000. !growth from vapor diffusion yang97 eqn. 10b + extra_growth = 10. !extra growth near freezing yang97 eqn. 10c + dirt_soot = 0.3 !dirt and soot term yang97 eqn. 10d + bats_cosz = 2.0 !zenith angle snow albedo adjustment; b in yang97 eqn. 15 + bats_vis_new = 0.95 !new snow visible albedo + bats_nir_new = 0.65 !new snow nir albedo + bats_vis_age = 0.2 !age factor for diffuse visible snow albedo yang97 eqn. 17 + bats_nir_age = 0.5 !age factor for diffuse nir snow albedo yang97 eqn. 18 + bats_vis_dir = 0.4 !cosz factor for direct visible snow albedo yang97 eqn. 15 + bats_nir_dir = 0.4 !cosz factor for direct nir snow albedo yang97 eqn. 16 + rsurf_snow = 50.0 !surface resistence for snow [s/m] + rsurf_exp = 5.0 !exponent in the shape parameter for soil resistance option 1 + c2_snowcompact = 21.e-3 !overburden snow compaction parameter (m3/kg) cenlin + c3_snowcompact = 2.5e-6 !snow desctructive metamorphism compaction parameter1 [1/s] cenlin + c4_snowcompact = 0.04 !snow desctructive metamorphism compaction parameter2 [1/k] cenlin + c5_snowcompact = 2.0 !snow desctructive metamorphism compaction parameter3 cenlin + dm_snowcompact = 100.0 !upper limit on destructive metamorphism compaction [kg/m3] cenlin + eta0_snowcompact = 0.8e+6 !snow viscosity coefficient [kg-s/m2], anderson1979: 0.52e6~1.38e6 cenlin + snliqmaxfrac = 0.4 !maximum liquid water fraction in snow cenlin + swemaxgla = 5000.0 ! maximum swe allowed at glaciers (mm) cenlin + wslmax = 5000.0 ! maximum lake water storage (mm) cenlin + rous = 0.20 ! specific yield [-] for niu et al. 2007 groundwater scheme (optrunoffsubsurface=1) + cmic = 0.20 ! microprore content (0.0-1.0), 0.0: close to free drainage + snowden_max = 120.0 ! maximum fresh snowfall density (kg/m3) + class_alb_ref = 0.55 ! reference snow albedo in class scheme + class_sno_age = 3600.0 ! snow aging e-folding time (s) in class albedo scheme + class_alb_new = 0.84 ! fresh snow albedo in class scheme + psiwlt = -150.0 !metric potential for wilting point (m) + z0soil = 0.002 ! bare-soil roughness length (m) (i.e., under the canopy) + z0lake = 0.01 ! lake surface roughness length (m) +/ + +&noahmp_irrigation_parameters +irr_frac = 0.10 ! irrigation fraction +irr_har = 20 ! number of days before harvest date to stop irrigation +irr_lai = 0.50 ! minimum lai to trigger irrigation +irr_mad = 0.60 ! management allowable deficit (0-1) +filoss = 0.10 ! fraction of flood irrigation loss (0-1) +sprir_rate = 6.40 ! mm/h, sprinkler irrigation rate +micir_rate = 1.38 ! mm/h, micro irrigation rate +firtfac = 1.00 ! flood application rate factor +ir_rain = 1.00 ! maximum precipitation [mm/hr] to stop irrigation trigger +/ + +&noahmp_crop_parameters + + ! ncrop = 5 + ! 1: corn + ! 2: soybean + ! 3: sorghum + ! 4: rice + ! 5: winter wheat + +default_crop = 0 ! the default crop type(1-5); if zero, use generic dynamic vegetation + +!---------------------------------------------------------- +! 1 2 3 4 5 +!---------------------------------------------------------- + +pltday = 111, 131, 111, 111, 111, ! planting date +hsday = 300, 280, 300, 300, 300, ! harvest date +plantpop = 78.0, 78.0, 78.0, 78.0, 78.0, ! plant density [per ha] - used? +gddtbase = 10.0, 10.0, 10.0, 10.0, 10.0, ! base temperature for gdd accumulation [c] +gddtcut = 30.0, 30.0, 30.0, 30.0, 30.0, ! upper temperature for gdd accumulation [c] +gdds1 = 50.0, 60.0, 50.0, 50.0, 50.0, ! gdd from seeding to emergence +gdds2 = 625.0, 675.0, 718.0, 718.0, 718.0, ! gdd from seeding to initial vegetative +gdds3 = 933.0, 1183.0, 933.0, 933.0, 933.0, ! gdd from seeding to post vegetative +gdds4 = 1103.0, 1253.0, 1103.0, 1103.0, 1103.0, ! gdd from seeding to intial reproductive +gdds5 = 1555.0, 1605.0, 1555.0, 1555.0, 1555.0, ! gdd from seeding to pysical maturity +c3psni = 0.0, 1.0, 1.0, 1.0, 1.0, ! transfer crop-specific photosynthetic parameters +kc25i = 30.0, 30.0, 30.0, 30.0, 30.0, ! zhe zhang +akci = 2.1, 2.1, 2.1, 2.1, 2.1, ! 2020-02-05 +ko25i = 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, ! +akoi = 1.2, 1.2, 1.2, 1.2, 1.2, ! +avcmxi = 2.4, 2.4, 2.4, 2.4, 2.4, ! +vcmx25i = 60.0, 80.0, 60.0, 60.0, 55.0, ! +bpi = 4.e4, 1.e4, 2.e3, 2.e3, 2.e3, ! +mpi = 4., 9., 6., 9., 9., ! +folnmxi = 1.5, 1.5, 1.5, 1.5, 1.5, ! foliage nitrogen concentration when f(n)=1 (%) +qe25i = 0.05, 0.06, 0.06, 0.06, 0.06, ! +aref = 7.0, 7.0, 7.0, 7.0, 7.0, ! reference maximum co2 assimilation rate +psnrf = 0.85, 0.85, 0.85, 0.85, 0.85, ! co2 assimilation reduction factor(0-1) (caused by non-modeling part,e.g.pest,weeds) +i2par = 0.5, 0.5, 0.5, 0.5, 0.5, ! fraction of incoming solar radiation to photosynthetically active radiation +tassim0 = 8.0, 8.0, 8.0, 8.0, 8.0, ! minimum temperature for co2 assimilation [c] +tassim1 = 18.0, 18.0, 18.0, 18.0, 18.0, ! co2 assimilation linearly increasing until temperature reaches t1 [c] +tassim2 = 30.0, 30.0, 30.0, 30.0, 30.0, ! co2 assmilation rate remain at aref until temperature reaches t2 [c] +k = 0.55, 0.55, 0.55, 0.55, 0.55, ! light extinction coefficient +epsi = 12.5, 12.5, 12.5, 12.5, 12.5, ! initial light use efficiency + +q10mr = 2.0, 2.0, 2.0, 2.0, 2.0, ! q10 for maintainance respiration +lefreez = 268, 268, 268, 268, 268, ! characteristic t for leaf freezing [k] + +dile_fc_s1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! coeficient for temperature leaf stress death [1/s] +dile_fc_s2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! one row for each of 8 stages +dile_fc_s3 = 0.0, 0.0, 0.0, 0.0, 0.0, +dile_fc_s4 = 0.0, 0.0, 0.0, 0.0, 0.0, +dile_fc_s5 = 0.5, 0.5, 0.5, 0.5, 0.5, +dile_fc_s6 = 0.5, 0.5, 0.5, 0.5, 0.5, +dile_fc_s7 = 0.0, 0.0, 0.0, 0.0, 0.0, +dile_fc_s8 = 0.0, 0.0, 0.0, 0.0, 0.0, + +dile_fw_s1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! coeficient for water leaf stress death [1/s] +dile_fw_s2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! one row for each of 8 stages +dile_fw_s3 = 0.0, 0.0, 0.0, 0.0, 0.0, +dile_fw_s4 = 0.0, 0.0, 0.0, 0.0, 0.0, +dile_fw_s5 = 0.2, 0.2, 0.2, 0.2, 0.2, +dile_fw_s6 = 0.2, 0.2, 0.2, 0.2, 0.2, +dile_fw_s7 = 0.0, 0.0, 0.0, 0.0, 0.0, +dile_fw_s8 = 0.0, 0.0, 0.0, 0.0, 0.0, + +fra_gr = 0.2, 0.2, 0.2, 0.2, 0.2, ! fraction of growth respiration + +lf_ovrc_s1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of leaf turnover [1/s] +lf_ovrc_s2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! one row for each of 8 stages +lf_ovrc_s3 = 0.0, 0.0, 0.0, 0.0, 0.0, +lf_ovrc_s4 = 0.0, 0.0, 0.0, 0.0, 0.0, +lf_ovrc_s5 = 0.2, 0.2, 0.48, 0.48, 0.48, +lf_ovrc_s6 = 0.3, 0.3, 0.48, 0.48, 0.48, +lf_ovrc_s7 = 0.0, 0.0, 0.0, 0.0, 0.0, +lf_ovrc_s8 = 0.0, 0.0, 0.0, 0.0, 0.0, + +st_ovrc_s1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of stem turnover [1/s] +st_ovrc_s2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! one row for each of 8 stages +st_ovrc_s3 = 0.0, 0.0, 0.0, 0.0, 0.0, +st_ovrc_s4 = 0.0, 0.0, 0.0, 0.0, 0.0, +st_ovrc_s5 = 0.2, 0.12, 0.12, 0.12, 0.12, +st_ovrc_s6 = 0.3, 0.06, 0.06, 0.06, 0.06, +st_ovrc_s7 = 0.0, 0.0, 0.0, 0.0, 0.0, +st_ovrc_s8 = 0.0, 0.0, 0.0, 0.0, 0.0, + +rt_ovrc_s1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of root tunrover [1/s] +rt_ovrc_s2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! one row for each of 8 stages +rt_ovrc_s3 = 0.0, 0.0, 0.0, 0.0, 0.0, +rt_ovrc_s4 = 0.0, 0.0, 0.0, 0.0, 0.0, +rt_ovrc_s5 = 0.12, 0.12, 0.12, 0.12, 0.12, +rt_ovrc_s6 = 0.06, 0.06, 0.06, 0.06, 0.06, +rt_ovrc_s7 = 0.0, 0.0, 0.0, 0.0, 0.0, +rt_ovrc_s8 = 0.0, 0.0, 0.0, 0.0, 0.0, + +lfmr25 = 0.8, 1.0, 1.0, 1.0, 1.0, ! leaf maintenance respiration at 25c [umol co2/m**2 /s] +stmr25 = 0.05, 0.05, 0.1, 0.1, 0.1, ! stem maintenance respiration at 25c [umol co2/kg bio/s] +rtmr25 = 0.05, 0.05, 0.0, 0.0, 0.0, ! root maintenance respiration at 25c [umol co2/kg bio/s] +grainmr25 = 0.0, 0.0, 0.1, 0.1, 0.1, ! grain maintenance respiration at 25c [umol co2/kg bio/s] + +lfpt_s1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to leaf +lfpt_s2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! one row for each of 8 stages +lfpt_s3 = 0.36, 0.4, 0.4, 0.4, 0.4, +lfpt_s4 = 0.1, 0.2, 0.2, 0.2, 0.2, +lfpt_s5 = 0.0, 0.0, 0.0, 0.0, 0.0, +lfpt_s6 = 0.0, 0.0, 0.0, 0.0, 0.0, +lfpt_s7 = 0.0, 0.0, 0.0, 0.0, 0.0, +lfpt_s8 = 0.0, 0.0, 0.0, 0.0, 0.0, + +stpt_s1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to stem +stpt_s2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! one row for each of 8 stages +stpt_s3 = 0.24, 0.2, 0.2, 0.2, 0.2, +stpt_s4 = 0.6, 0.5, 0.5, 0.5, 0.5, +stpt_s5 = 0.0, 0.0, 0.15, 0.15, 0.15, +stpt_s6 = 0.0, 0.0, 0.05, 0.05, 0.05, +stpt_s7 = 0.0, 0.0, 0.0, 0.0, 0.0, +stpt_s8 = 0.0, 0.0, 0.0, 0.0, 0.0, + +rtpt_s1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to root +rtpt_s2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! one row for each of 8 stages +rtpt_s3 = 0.4, 0.4, 0.4, 0.4, 0.4, +rtpt_s4 = 0.3, 0.3, 0.3, 0.3, 0.3, +rtpt_s5 = 0.05, 0.05, 0.05, 0.05, 0.05, +rtpt_s6 = 0.0, 0.0, 0.05, 0.05, 0.05, +rtpt_s7 = 0.0, 0.0, 0.0, 0.0, 0.0, +rtpt_s8 = 0.0, 0.0, 0.0, 0.0, 0.0, + +grainpt_s1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to grain +grainpt_s2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! one row for each of 8 stages +grainpt_s3 = 0.0, 0.0, 0.0, 0.0, 0.0, +grainpt_s4 = 0.0, 0.0, 0.0, 0.0, 0.0, +grainpt_s5 = 0.95, 0.95, 0.8, 0.8, 0.8, +grainpt_s6 = 1.0, 1.0, 0.9, 0.9, 0.9, +grainpt_s7 = 0.0, 0.0, 0.0, 0.0, 0.0, +grainpt_s8 = 0.0, 0.0, 0.0, 0.0, 0.0, + +lfct_s1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! carbohydrate translocation +lfct_s2 = 0.0, 0.0, 0.0, 0.0, 0.0, +lfct_s3 = 0.0, 0.0, 0.4, 0.4, 0.4, +lfct_s4 = 0.0, 0.0, 0.3, 0.3, 0.3, +lfct_s5 = 0.0, 0.0, 0.05, 0.05, 0.05, +lfct_s6 = 0.0, 0.0, 0.05, 0.05, 0.05, +lfct_s7 = 0.0, 0.0, 0.0, 0.0, 0.0, +lfct_s8 = 0.0, 0.0, 0.0, 0.0, 0.0, + +stct_s1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! carbohydrate translocation +stct_s2 = 0.0, 0.0, 0.0, 0.0, 0.0, +stct_s3 = 0.0, 0.0, 0.4, 0.4, 0.4, +stct_s4 = 0.0, 0.0, 0.3, 0.3, 0.3, +stct_s5 = 0.0, 0.0, 0.05, 0.05, 0.05, +stct_s6 = 0.0, 0.0, 0.05, 0.05, 0.05, +stct_s7 = 0.0, 0.0, 0.0, 0.0, 0.0, +stct_s8 = 0.0, 0.0, 0.0, 0.0, 0.0, + +rtct_s1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! carbohydrate translocation +rtct_s2 = 0.0, 0.0, 0.0, 0.0, 0.0, +rtct_s3 = 0.0, 0.0, 0.4, 0.4, 0.4, +rtct_s4 = 0.0, 0.0, 0.3, 0.3, 0.3, +rtct_s5 = 0.0, 0.0, 0.05, 0.05, 0.05, +rtct_s6 = 0.0, 0.0, 0.05, 0.05, 0.05, +rtct_s7 = 0.0, 0.0, 0.0, 0.0, 0.0, +rtct_s8 = 0.0, 0.0, 0.0, 0.0, 0.0, + +bio2lai = 0.015, 0.030, 0.015, 0.015, 0.015, ! leaf are per living leaf biomass [m^2/kg] + +/ + +&noahmp_tiledrain_parameters +!-----------------------------------! +! for simple drainage model ! +!-----------------------------------! +nsoiltype = 19 ! num_soil_types +drain_layer_opt = 4 + ! 0 - from one specified layer by td_depth, + ! 1 - from layers 1 & 2, + ! 2 - from layer layers 1, 2, and 3 + ! 3 - from layer 2 and 3 + ! 4 - from layer layers 3, 4 + ! 5 - from all the four layers +!-------------------------------------------------------------------------------------------------------------------------------------------------------------------- ! +! 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 ! +!-------------------------------------------------------------------------------------------------------------------------------------------------------------------- ! +tdsmc_fac = 0.90, 0.90, 0.90, 0.90, 0.90, 1.25, 0.90, 1.0, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90 ! corresponds to number of soil types soilparam.tbl +td_depth = 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4 ! depth of drain tube from the soil surface +td_dc = 20., 20., 20., 20., 20., 20., 20., 20., 20., 20., 20., 20., 20., 20., 20., 20., 20., 20., 20. ! drainage coefficient (mm d^-1) +!-------------------------------------------------------------------------------------------------------------------------------------------------------------------- ! +! +!-------------------------------------! +! for hooghoudt tile drain model ! +!-------------------------------------! +!-------------------------------------------------------------------------------------------------------------------------------------------------------------------- +td_dcoef = 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07 ! m d^-1, drainage coefficent +td_d = 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00 ! m, depth to impe layer from drain water level (d) +td_adepth = 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, 2.00 ! m, actual depth of imp layer from land surface +td_radi = 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07 ! m, effective radius of drains (ro) +td_spac = 60.0, 55.0, 45.0, 20.0, 25.0, 30.0, 40.0, 16.0, 18.0, 50.0, 15.0, 10.0, 35.0, 10.0, 60.0, 60.0, 10.0, 60.0, 60.0 ! m, distance between two drain tubes or tiles (l) +td_ddrain = 1.20, 1.20, 1.20, 1.20, 1.20, 1.20, 1.20, 1.20, 1.20, 1.20, 1.20, 1.20, 1.20, 1.20, 1.20, 1.20, 1.20, 1.20, 1.20 ! m, depth of drain +klat_fac = 1.30, 1.80, 2.10, 2.60, 2.90, 2.50, 2.30, 3.00, 2.70, 2.00, 3.10, 3.30, 2.50, 1.00, 1.00, 1.80, 4.00, 1.00, 1.30 ! multiplication factor to lateral hyd.cond +!-------------------------------------------------------------------------------------------------------------------------------------------------------------------- + +/ + +&noahmp_optional_parameters + + !------------------------------------------------------------------------------ + ! saxton and rawls 2006 pedo-transfer function coefficients + !------------------------------------------------------------------------------ + + sr2006_theta_1500t_a = -0.024 ! sand coefficient + sr2006_theta_1500t_b = 0.487 ! clay coefficient + sr2006_theta_1500t_c = 0.006 ! orgm coefficient + sr2006_theta_1500t_d = 0.005 ! sand*orgm coefficient + sr2006_theta_1500t_e = -0.013 ! clay*orgm coefficient + sr2006_theta_1500t_f = 0.068 ! sand*clay coefficient + sr2006_theta_1500t_g = 0.031 ! constant adjustment + + sr2006_theta_1500_a = 0.14 ! theta_1500t coefficient + sr2006_theta_1500_b = -0.02 ! constant adjustment + + sr2006_theta_33t_a = -0.251 ! sand coefficient + sr2006_theta_33t_b = 0.195 ! clay coefficient + sr2006_theta_33t_c = 0.011 ! orgm coefficient + sr2006_theta_33t_d = 0.006 ! sand*orgm coefficient + sr2006_theta_33t_e = -0.027 ! clay*orgm coefficient + sr2006_theta_33t_f = 0.452 ! sand*clay coefficient + sr2006_theta_33t_g = 0.299 ! constant adjustment + + sr2006_theta_33_a = 1.283 ! theta_33t*theta_33t coefficient + sr2006_theta_33_b = -0.374 ! theta_33t coefficient + sr2006_theta_33_c = -0.015 ! constant adjustment + + sr2006_theta_s33t_a = 0.278 ! sand coefficient + sr2006_theta_s33t_b = 0.034 ! clay coefficient + sr2006_theta_s33t_c = 0.022 ! orgm coefficient + sr2006_theta_s33t_d = -0.018 ! sand*orgm coefficient + sr2006_theta_s33t_e = -0.027 ! clay*orgm coefficient + sr2006_theta_s33t_f = -0.584 ! sand*clay coefficient + sr2006_theta_s33t_g = 0.078 ! constant adjustment + + sr2006_theta_s33_a = 0.636 ! theta_s33t coefficient + sr2006_theta_s33_b = -0.107 ! constant adjustment + + sr2006_psi_et_a = -21.67 ! sand coefficient + sr2006_psi_et_b = -27.93 ! clay coefficient + sr2006_psi_et_c = -81.97 ! theta_s33 coefficient + sr2006_psi_et_d = 71.12 ! sand*theta_s33 coefficient + sr2006_psi_et_e = 8.29 ! clay*theta_s33 coefficient + sr2006_psi_et_f = 14.05 ! sand*clay coefficient + sr2006_psi_et_g = 27.16 ! constant adjustment + + sr2006_psi_e_a = 0.02 ! psi_et*psi_et coefficient + sr2006_psi_e_b = -0.113 ! psi_et coefficient + sr2006_psi_e_c = -0.7 ! constant adjustment + + sr2006_smcmax_a = -0.097 ! sand adjustment + sr2006_smcmax_b = 0.043 ! constant adjustment + +/ + +&noahmp_general_parameters + !------------------------------------------------- + ! this part is originally from genparm.tbl + !------------------------------------------------- +slope_data = 0.1, 0.6, 1.0, 0.35, 0.55, 0.8, 0.63, 0.0, 0.0 ! slope factor for soil drainage (9 different slope types) +csoil_data = 2.00e+6 ! soil heat capacity [j m-3 k-1] +refdk_data = 2.0e-6 ! parameter in the surface runoff parameterization +refkdt_data = 3.0 ! parameter in the surface runoff parameterization +frzk_data = 0.15 ! frozen ground parameter +zbot_data = -8.0 ! depth [m] of lower boundary soil temperature +czil_data = 0.1 ! parameter used in the calculation of the roughness length for heat + +/ + +&noahmp_stas_soil_categories + sltype = "stas" ! "stas" or "stas_ruc" + slcats = 19 !num_soil_types +/ + +&noahmp_soil_stas_parameters +! 19 total soil types considered by noahmp +! 1: sand +! 2: loamy sand +! 3: sandy loam +! 4: silt loam +! 5: silt +! 6: loam +! 7: sandy clay loam +! 8: silty clay loam +! 9: clay loam +! 10: sandy clay +! 11: silty clay +! 12: clay +! 13: organic material +! 14: water +! 15: bedrock +! 16: other(land-ice) +! 17: playa +! 18: lava +! 19: white sand +!-------------------------------------------------------------------------------------------------------------------------------------------------------------------- ! +! soil type: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 ! +!-------------------------------------------------------------------------------------------------------------------------------------------------------------------- ! + bb = 2.790, 4.260, 4.740, 5.330, 3.860, 5.250, 6.770, 8.720, 8.170, 10.730, 10.390, 11.550, 5.250, 0.000, 2.790, 4.260, 11.550, 2.790, 2.790 + drysmc = 0.010, 0.028, 0.047, 0.084, 0.061, 0.066, 0.069, 0.120, 0.103, 0.100, 0.126, 0.138, 0.066, 0.000, 0.006, 0.028, 0.030, 0.006, 0.010 + maxsmc = 0.339, 0.421, 0.434, 0.476, 0.484, 0.439, 0.404, 0.464, 0.465, 0.406, 0.468, 0.468, 0.439, 1.000, 0.200, 0.421, 0.468, 0.200, 0.339 + refsmc = 0.192, 0.283, 0.312, 0.360, 0.347, 0.329, 0.315, 0.387, 0.382, 0.338, 0.404, 0.412, 0.329, 0.000, 0.170, 0.283, 0.454, 0.170, 0.192 + satpsi = 0.069, 0.036, 0.141, 0.759, 0.955, 0.355, 0.135, 0.617, 0.263, 0.098, 0.324, 0.468, 0.355, 0.000, 0.069, 0.036, 0.468, 0.069, 0.069 + satdk = 4.66e-05, 1.41e-05, 5.23e-06, 2.81e-06, 2.18e-06, 3.38e-06, 4.45e-06, 2.03e-06, 2.45e-06, 7.22e-06, 1.34e-06, 9.74e-07, 3.38e-06, 0.00e+00, 1.41e-04, 1.41e-05, 9.74e-07, 1.41e-04, 4.66e-05 + satdw = 2.65e-05, 5.14e-06, 8.05e-06, 2.39e-05, 1.66e-05, 1.43e-05, 1.01e-05, 2.35e-05, 1.13e-05, 1.87e-05, 9.64e-06, 1.12e-05, 1.43e-05, 0.00e+00, 1.36e-04, 5.14e-06, 1.12e-05, 1.36e-04, 2.65e-05 + wltsmc = 0.010, 0.028, 0.047, 0.084, 0.061, 0.066, 0.069, 0.120, 0.103, 0.100, 0.126, 0.138, 0.066, 0.000, 0.006, 0.028, 0.030, 0.006, 0.010 + qtz = 0.920, 0.820, 0.600, 0.250, 0.100, 0.400, 0.600, 0.100, 0.350, 0.520, 0.100, 0.250, 0.050, 0.600, 0.070, 0.250, 0.600, 0.520, 0.920 + bvic = 0.050, 0.080, 0.090, 0.250, 0.150, 0.180, 0.200, 0.220, 0.230, 0.250, 0.280, 0.300, 0.260, 0.000, 1.000, 1.000, 1.000, 0.350, 0.150 + axaj = 0.009, 0.010, 0.009, 0.010, 0.012, 0.013, 0.014, 0.015, 0.016, 0.015, 0.016, 0.017, 0.012, 0.001, 0.017, 0.017, 0.017, 0.015, 0.009 + bxaj = 0.050, 0.080, 0.090, 0.250, 0.150, 0.180, 0.200, 0.220, 0.230, 0.250, 0.280, 0.300, 0.260, 0.000, 1.000, 1.000, 1.000, 0.350, 0.150 + xxaj = 0.050, 0.080, 0.090, 0.250, 0.150, 0.180, 0.200, 0.220, 0.230, 0.250, 0.280, 0.300, 0.260, 0.000, 1.000, 1.000, 1.000, 0.350, 0.150 + bdvic = 0.050, 0.080, 0.090, 0.250, 0.150, 0.180, 0.200, 0.220, 0.230, 0.250, 0.280, 0.300, 0.260, 0.000, 1.000, 1.000, 1.000, 0.350, 0.150 + bbvic = 1.000, 1.010, 1.020, 1.025, 1.000, 1.000, 1.032, 1.035, 1.040, 1.042, 1.045, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000 + gdvic = 0.050, 0.070, 0.130, 0.200, 0.170, 0.110, 0.260, 0.350, 0.260, 0.300, 0.380, 0.410, 0.500, 0.001, 0.010, 0.001, 0.001, 0.050, 0.020 + +/ + +&noahmp_soil_stas_ruc_parameters +! 19 total soil types considered by noahmp +! 1: sand +! 2: loamy sand +! 3: sandy loam +! 4: silt loam +! 5: silt +! 6: loam +! 7: sandy clay loam +! 8: silty clay loam +! 9: clay loam +! 10: sandy clay +! 11: silty clay +! 12: clay +! 13: organic material +! 14: water +! 15: bedrock +! 16: other(land-ice) +! 17: playa +! 18: lava +! 19: white sand +!-------------------------------------------------------------------------------------------------------------------------------------------------------------------- ! +! soil type: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 ! +!-------------------------------------------------------------------------------------------------------------------------------------------------------------------- ! + bb = 4.050, 4.380, 4.900, 5.300, 5.300, 5.390, 7.120, 7.750, 5.390, 10.400, 10.400, 11.400, 5.390, 0.000, 4.050, 4.900, 11.400, 4.050, 4.050 + drysmc = 0.002, 0.035, 0.041, 0.034, 0.034, 0.050, 0.068, 0.060, 0.050, 0.070, 0.070, 0.068, 0.027, 0.000, 0.004, 0.065, 0.030, 0.006, 0.010 + hc = 1.470, 1.410, 1.340, 1.270, 1.270, 1.210, 1.180, 1.320, 1.210, 1.180, 1.150, 1.090, 1.210, 4.180, 2.030, 2.100, 1.410, 1.410, 1.470 + maxsmc = 0.395, 0.410, 0.435, 0.485, 0.485, 0.451, 0.420, 0.477, 0.451, 0.426, 0.492, 0.482, 0.451, 1.000, 0.200, 0.435, 0.468, 0.200, 0.339 + refsmc = 0.174, 0.179, 0.249, 0.369, 0.369, 0.314, 0.299, 0.357, 0.314, 0.316, 0.409, 0.400, 0.314, 1.000, 0.100, 0.249, 0.454, 0.170, 0.236 + satpsi = 0.121, 0.090, 0.218, 0.786, 0.786, 0.478, 0.299, 0.356, 0.478, 0.153, 0.490, 0.405, 0.478, 0.000, 0.121, 0.218, 0.468, 0.069, 0.069 + satdk = 1.76e-04, 1.56e-04, 3.47e-05, 7.20e-06, 7.20e-06, 6.95e-06, 6.30e-06, 1.70e-06, 6.95e-06, 2.17e-06, 1.03e-06, 1.28e-06, 6.95e-06, 0.00e+00, 1.41e-04, 3.47e-05, 9.74e-07, 1.41e-04, 1.76e-04 + satdw = 6.08e-07, 5.14e-06, 8.05e-06, 2.39e-05, 2.39e-05, 1.43e-05, 9.90e-06, 2.37e-05, 1.43e-05, 1.87e-05, 9.64e-06, 1.12e-05, 1.43e-05, 0.00e+00, 1.36e-04, 5.14e-06, 1.12e-05, 1.36e-04, 6.08e-07 + wltsmc = 0.033, 0.055, 0.095, 0.143, 0.143, 0.137, 0.148, 0.170, 0.137, 0.158, 0.190, 0.198, 0.117, 0.000, 0.006, 0.114, 0.030, 0.006, 0.060 + qtz = 0.920, 0.820, 0.600, 0.250, 0.100, 0.400, 0.600, 0.100, 0.400, 0.520, 0.100, 0.250, 0.050, 0.000, 0.600, 0.050, 0.600, 0.520, 0.920 + bvic = 0.050, 0.080, 0.090, 0.100, 0.150, 0.180, 0.200, 0.220, 0.230, 0.250, 0.280, 0.300, 0.260, 0.000, 1.000, 1.000, 1.000, 0.350, 0.150 + axaj = 0.009, 0.010, 0.009, 0.010, 0.012, 0.013, 0.014, 0.015, 0.016, 0.015, 0.016, 0.017, 0.012, 0.001, 0.017, 0.017, 0.017, 0.015, 0.009 + bxaj = 0.050, 0.080, 0.090, 0.250, 0.150, 0.180, 0.200, 0.220, 0.230, 0.250, 0.280, 0.300, 0.260, 0.000, 1.000, 1.000, 1.000, 0.350, 0.150 + xxaj = 0.050, 0.080, 0.090, 0.250, 0.150, 0.180, 0.200, 0.220, 0.230, 0.250, 0.280, 0.300, 0.260, 0.000, 1.000, 1.000, 1.000, 0.350, 0.150 + bdvic = 0.050, 0.080, 0.090, 0.100, 0.150, 0.180, 0.200, 0.220, 0.230, 0.250, 0.280, 0.300, 0.260, 0.000, 1.000, 1.000, 1.000, 0.350, 0.150 + bbvic = 1.000, 1.010, 1.020, 1.025, 1.000, 1.000, 1.032, 1.035, 1.040, 1.042, 1.045, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000 + gdvic = 0.050, 0.070, 0.130, 0.200, 0.170, 0.110, 0.260, 0.350, 0.260, 0.300, 0.380, 0.410, 0.500, 0.001, 0.010, 0.001, 0.001, 0.050, 0.020 + +/ + From d825523423d9c3dd0dc4c4fcc90d2253156ea77b Mon Sep 17 00:00:00 2001 From: drnimbusrain Date: Mon, 5 Dec 2022 18:40:07 +0000 Subject: [PATCH 071/380] First draft commit of canopy turbulence effects in hedmf.f --- physics/canopy_utils_mod.f | 52 +++++++++++++++++++++ physics/hedmf.f | 93 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 145 insertions(+) create mode 100644 physics/canopy_utils_mod.f diff --git a/physics/canopy_utils_mod.f b/physics/canopy_utils_mod.f new file mode 100644 index 000000000..4ccfd1fff --- /dev/null +++ b/physics/canopy_utils_mod.f @@ -0,0 +1,52 @@ + module canopy_utils_mod + + implicit none + + + contains + +!-------------------------------------------------------------------------- + + function IntegrateTrapezoid(x, y) + !! Calculates the integral of an array y with respect to x + !using the trapezoid + !! approximation. Note that the mesh spacing of x does not + !have to be uniform. + real, intent(in) :: x(:) !! Variable x + real, intent(in) :: y(size(x)) !! Function y(x) + real :: IntegrateTrapezoid !! Integral ∫y(x)·dx + ! Integrate using the trapezoidal rule + associate(n => size(x)) + IntegrateTrapezoid = sum((y(1+1:n-0) + y(1+0:n-1))* + & (x(1+1:n-0) - x(1+0:n-1)))/2 + end associate + end function + +! --------------------------------------------------------------------------- + + function interp_linear1_internal(x,y,xout) result(yout) + !! Interpolates for the y value at the desired x value, + !! given x and y values around the desired point. + + implicit none + + real, intent(IN) :: x(2), y(2), xout + real :: yout + real :: alph + + if ( xout .lt. x(1) .or. xout .gt. x(2) ) then + write(*,*) "interp1: xout < x0 or xout > x1 !" + write(*,*) "xout = ",xout + write(*,*) "x0 = ",x(1) + write(*,*) "x1 = ",x(2) + stop + end if + + alph = (xout - x(1)) / (x(2) - x(1)) + yout = y(1) + alph*(y(2) - y(1)) + + return + + end function interp_linear1_internal + + end module canopy_utils_mod diff --git a/physics/hedmf.f b/physics/hedmf.f index 4b010a121..4989e8164 100644 --- a/physics/hedmf.f +++ b/physics/hedmf.f @@ -8,6 +8,8 @@ module hedmf use tridi_mod use mfpbl_mod + !PCC CANOPY + use canopy_utils_mod contains @@ -247,6 +249,8 @@ subroutine hedmf_run (im,km,ntrac,ntcw,dv,du,tau,rtg, & parameter (zstblmax = 2500., qlcr=3.5e-5) ! parameter (actei = 0.23) parameter (actei = 0.7) + !PCC CANOPY + parameter (PICAN = 3.1415927) c c----------------------------------------------------------------------- c @@ -1004,6 +1008,95 @@ subroutine hedmf_run (im,km,ntrac,ntcw,dv,du,tau,rtg, & enddo ! I loop endif ! not (hurr_pbl and moninq_fac < 0) ! + !PCC CANOPY + do k = 1, kmpbl + do i=1,im + if(k < kpbl(i)) then + IF (k .EQ. 1) THEN !first model layer +! IF ( LAI .LT. 0.1 +! & .OR. FCH .LT. 0.5 +! & .OR. FCH .LT. 10.0 +! & .OR. MAX(0.0, 1.0 - FRT) .GT. 0.5 +! & .OR. POPU .GT. 10000.0 +! & .OR. EXP(-0.5*LAI*CLU).GT. 0.45 +! & .AND. FCH .LT. 18.0 ) THEN !not contigous +! canopy +! dktx(i,k)= dkt(i,k) +! ELSE ! There is a contiguous forest canopy, +! apply correction over canopy layers + +!Raupauch M. R. A Practical Lagrangian method for relating scalar +!concentrations to +! source distributions in vegetation canopies. Q. J. R. Meteor. Soc. +! (1989), 115, pp 609-632 + + HOL = FCH/MOL !local canopy stability parameter (hc/MOL) + ZCAN = ZFL ! Initialize canopy top (m) = First model layer above canopy + COUNTCAN = 0 ! Initialize canopy layers + DO WHILE (ZCAN.GE.0.5) !canopy threshold >= 0.5 m + ! TLCAN = Lagrangian timescale + TLCAN = (FCH/USTAR) * ( + & (0.256 * (ZCAN-(0.75*FCH))/FCH ) + + & (0.492*EXP((-0.256*ZCAN/FCH)/0.492)) ) + IF ( HOL .LT. -0.1 ) THEN !UNSTABLE + IF ( ZCAN/FCH .GT. 1.25 ) THEN !SIGMACAN = Eulerian vertical velocity variance + SIGMACAN = 1.25*USTAR + END IF + IF ( ZCAN/FCH .GE. 0.175 .AND. ZCAN/FCH .LE. 1.25 ) THEN + SIGMACAN = USTAR * ( 0.75 + (0.5 * COS((PICAN/1.06818) * + & (1.25 - (ZCAN/FCH)))) ) + END IF + IF ( ZCAN/FCH .LT. 0.175 ) THEN + SIGMACAN = 0.25*USTAR + END IF + END IF + IF ( HOL .GE. -0.1 .AND. HOL .LT. 0.1 ) THEN !NEUTRAL + IF ( ZCAN/FCH .GT. 1.25 ) THEN + SIGMACAN = 1.0*USTAR + END IF + IF ( ZCAN/FCH .GE. 0.175 .AND. ZCAN/FCH .LE. 1.25 ) THEN + SIGMACAN = USTAR * ( 0.625 + (0.375* COS((PICAN/1.06818) * + & (1.25 - (ZCAN/FCH)))) ) + END IF + IF ( ZCAN/FCH .LT. 0.175 ) THEN + SIGMACAN = 0.25*USTAR + END IF + END IF + IF ( HOL .GE. 0.1 .AND. HOL .LT. 0.9 ) THEN !STABLE + IF ( ZCAN/FCH .GT. 1.25 ) THEN + SIGMACAN = 0.25*(4.375 - (3.75*HOL))*USTAR + END IF + IF ( ZCAN/FCH .GE. 0.175 .AND. ZCAN/FCH .LE. 1.25 ) THEN + RRCAN=4.375-(3.75*HOL) + AACAN=(0.125*RRCAN) + 0.125 + BBCAN=(0.125*RRCAN) - 0.125 + SIGMACAN = USTAR * ( AACAN + (BBCAN * COS((PICAN/1.06818) * + & (1.25 - (ZCAN/FCH)))) ) + END IF + IF ( ZCAN/FCH .LT. 0.175 ) THEN + SIGMACAN = 0.25*USTAR + END IF + END IF + IF ( HOL .GE. 0.9 ) THEN !VERY STABLE + SIGMACAN = 0.25*USTAR + END IF + IF ( ZCAN .EQ. ZFL ) THEN ! First model layer above canopy + EDDYVEST1 = (SIGMACAN*SIGMACAN)*TLCAN + ELSE IF ( ZCAN .LE. FCH ) THEN !in-canopy layers and set arrays + COUNTCAN = COUNTCAN + 1 + ZCANX (COUNTCAN) = ZCAN + EDDYVESTX (COUNTCAN) = (SIGMACAN*SIGMACAN)*TLCAN + END IF + ZCAN = ZCAN-0.5 !step down in-canopy resolution of 0.5m + END DO !end loop on canopy layers + EDDYVEST_INT = IntegrateTrapezoid((ZCANX(COUNTCAN:1:-1)/FCH),EDDYVESTX(COUNTCAN:1:-1)) + dktx(i,k)= (dkt(i,k)/EDDYVEST1) * EDDYVEST_INT !Scale to resolved eddy diffusivity +! END IF !contigous canopy conditions + END IF ! first model layer scaled canopy + endif !(k < kpbl(i)) + enddo !i + enddo !k + ! compute diffusion coefficients based on local scheme above pbl !> ## Compute diffusion coefficients above the PBL top !! Diffusion coefficients above the PBL top are computed as a function of local stability (gradient Richardson number), shear, and a length scale from Louis (1979) \cite louis_1979 : From 574ad4e3d1a130cf9c7bbf6212baec7fc1493646 Mon Sep 17 00:00:00 2001 From: drnimbusrain Date: Mon, 5 Dec 2022 18:44:52 +0000 Subject: [PATCH 072/380] Fixed non-ascii character --- physics/canopy_utils_mod.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/canopy_utils_mod.f b/physics/canopy_utils_mod.f index 4ccfd1fff..b34202ae8 100644 --- a/physics/canopy_utils_mod.f +++ b/physics/canopy_utils_mod.f @@ -14,7 +14,7 @@ function IntegrateTrapezoid(x, y) !have to be uniform. real, intent(in) :: x(:) !! Variable x real, intent(in) :: y(size(x)) !! Function y(x) - real :: IntegrateTrapezoid !! Integral ∫y(x)·dx + real :: IntegrateTrapezoid !! Integral of y(x)·dx ! Integrate using the trapezoidal rule associate(n => size(x)) IntegrateTrapezoid = sum((y(1+1:n-0) + y(1+0:n-1))* From 166571509dc4fe17044afd2a33df79625938688e Mon Sep 17 00:00:00 2001 From: drnimbusrain Date: Tue, 6 Dec 2022 09:32:50 -0500 Subject: [PATCH 073/380] Changed from canopy in hedmf to satmedmvdifq for GFSv16. --- physics/hedmf.f | 93 ----------------------------------------- physics/satmedmfvdifq.F | 90 +++++++++++++++++++++++++++++++++++++++ 2 files changed, 90 insertions(+), 93 deletions(-) diff --git a/physics/hedmf.f b/physics/hedmf.f index 4989e8164..4b010a121 100644 --- a/physics/hedmf.f +++ b/physics/hedmf.f @@ -8,8 +8,6 @@ module hedmf use tridi_mod use mfpbl_mod - !PCC CANOPY - use canopy_utils_mod contains @@ -249,8 +247,6 @@ subroutine hedmf_run (im,km,ntrac,ntcw,dv,du,tau,rtg, & parameter (zstblmax = 2500., qlcr=3.5e-5) ! parameter (actei = 0.23) parameter (actei = 0.7) - !PCC CANOPY - parameter (PICAN = 3.1415927) c c----------------------------------------------------------------------- c @@ -1008,95 +1004,6 @@ subroutine hedmf_run (im,km,ntrac,ntcw,dv,du,tau,rtg, & enddo ! I loop endif ! not (hurr_pbl and moninq_fac < 0) ! - !PCC CANOPY - do k = 1, kmpbl - do i=1,im - if(k < kpbl(i)) then - IF (k .EQ. 1) THEN !first model layer -! IF ( LAI .LT. 0.1 -! & .OR. FCH .LT. 0.5 -! & .OR. FCH .LT. 10.0 -! & .OR. MAX(0.0, 1.0 - FRT) .GT. 0.5 -! & .OR. POPU .GT. 10000.0 -! & .OR. EXP(-0.5*LAI*CLU).GT. 0.45 -! & .AND. FCH .LT. 18.0 ) THEN !not contigous -! canopy -! dktx(i,k)= dkt(i,k) -! ELSE ! There is a contiguous forest canopy, -! apply correction over canopy layers - -!Raupauch M. R. A Practical Lagrangian method for relating scalar -!concentrations to -! source distributions in vegetation canopies. Q. J. R. Meteor. Soc. -! (1989), 115, pp 609-632 - - HOL = FCH/MOL !local canopy stability parameter (hc/MOL) - ZCAN = ZFL ! Initialize canopy top (m) = First model layer above canopy - COUNTCAN = 0 ! Initialize canopy layers - DO WHILE (ZCAN.GE.0.5) !canopy threshold >= 0.5 m - ! TLCAN = Lagrangian timescale - TLCAN = (FCH/USTAR) * ( - & (0.256 * (ZCAN-(0.75*FCH))/FCH ) + - & (0.492*EXP((-0.256*ZCAN/FCH)/0.492)) ) - IF ( HOL .LT. -0.1 ) THEN !UNSTABLE - IF ( ZCAN/FCH .GT. 1.25 ) THEN !SIGMACAN = Eulerian vertical velocity variance - SIGMACAN = 1.25*USTAR - END IF - IF ( ZCAN/FCH .GE. 0.175 .AND. ZCAN/FCH .LE. 1.25 ) THEN - SIGMACAN = USTAR * ( 0.75 + (0.5 * COS((PICAN/1.06818) * - & (1.25 - (ZCAN/FCH)))) ) - END IF - IF ( ZCAN/FCH .LT. 0.175 ) THEN - SIGMACAN = 0.25*USTAR - END IF - END IF - IF ( HOL .GE. -0.1 .AND. HOL .LT. 0.1 ) THEN !NEUTRAL - IF ( ZCAN/FCH .GT. 1.25 ) THEN - SIGMACAN = 1.0*USTAR - END IF - IF ( ZCAN/FCH .GE. 0.175 .AND. ZCAN/FCH .LE. 1.25 ) THEN - SIGMACAN = USTAR * ( 0.625 + (0.375* COS((PICAN/1.06818) * - & (1.25 - (ZCAN/FCH)))) ) - END IF - IF ( ZCAN/FCH .LT. 0.175 ) THEN - SIGMACAN = 0.25*USTAR - END IF - END IF - IF ( HOL .GE. 0.1 .AND. HOL .LT. 0.9 ) THEN !STABLE - IF ( ZCAN/FCH .GT. 1.25 ) THEN - SIGMACAN = 0.25*(4.375 - (3.75*HOL))*USTAR - END IF - IF ( ZCAN/FCH .GE. 0.175 .AND. ZCAN/FCH .LE. 1.25 ) THEN - RRCAN=4.375-(3.75*HOL) - AACAN=(0.125*RRCAN) + 0.125 - BBCAN=(0.125*RRCAN) - 0.125 - SIGMACAN = USTAR * ( AACAN + (BBCAN * COS((PICAN/1.06818) * - & (1.25 - (ZCAN/FCH)))) ) - END IF - IF ( ZCAN/FCH .LT. 0.175 ) THEN - SIGMACAN = 0.25*USTAR - END IF - END IF - IF ( HOL .GE. 0.9 ) THEN !VERY STABLE - SIGMACAN = 0.25*USTAR - END IF - IF ( ZCAN .EQ. ZFL ) THEN ! First model layer above canopy - EDDYVEST1 = (SIGMACAN*SIGMACAN)*TLCAN - ELSE IF ( ZCAN .LE. FCH ) THEN !in-canopy layers and set arrays - COUNTCAN = COUNTCAN + 1 - ZCANX (COUNTCAN) = ZCAN - EDDYVESTX (COUNTCAN) = (SIGMACAN*SIGMACAN)*TLCAN - END IF - ZCAN = ZCAN-0.5 !step down in-canopy resolution of 0.5m - END DO !end loop on canopy layers - EDDYVEST_INT = IntegrateTrapezoid((ZCANX(COUNTCAN:1:-1)/FCH),EDDYVESTX(COUNTCAN:1:-1)) - dktx(i,k)= (dkt(i,k)/EDDYVEST1) * EDDYVEST_INT !Scale to resolved eddy diffusivity -! END IF !contigous canopy conditions - END IF ! first model layer scaled canopy - endif !(k < kpbl(i)) - enddo !i - enddo !k - ! compute diffusion coefficients based on local scheme above pbl !> ## Compute diffusion coefficients above the PBL top !! Diffusion coefficients above the PBL top are computed as a function of local stability (gradient Richardson number), shear, and a length scale from Louis (1979) \cite louis_1979 : diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index 1c524b800..89cd8b97e 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -7,6 +7,9 @@ module satmedmfvdifq use mfpbltq_mod use tridi_mod use mfscuq_mod + !PCC CANOPY + use canopy_utils_mod + contains !> \defgroup module_satmedmfvdifq GFS TKE-EDMF PBL Module @@ -262,6 +265,8 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & parameter(ck0=0.4,ck1=0.15,ch0=0.4,ch1=0.15) parameter(ce0=0.4,cs0=0.2) parameter(rchck=1.5,ndt=20) + !PCC CANOPY + parameter (PICAN = 3.1415927) gravi = 1.0 / grav g = grav @@ -1192,6 +1197,91 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & ! enddo enddo + !PCC CANOPY + do k = 1, 1km1 + do i=1,im + IF (k .EQ. 1) THEN !first model layer +! Check for Contiguous Canopy Grid Cells +! IF ( LAI .LT. 0.1 +! & .OR. FCH .LT. 0.5 +! & .OR. FCH .LT. 10.0 +! & .OR. MAX(0.0, 1.0 - FRT) .GT. 0.5 +! & .OR. POPU .GT. 10000.0 +! & .OR. EXP(-0.5*LAI*CLU).GT. 0.45 +! & .AND. FCH .LT. 18.0 ) THEN !not contigous +! canopy +! dktx(i,k)= dkt(i,k) +! ELSE ! There is a contiguous forest canopy, +! apply correction over canopy layers +!Raupauch M. R. A Practical Lagrangian method for relating scalar +!concentrations to +! source distributions in vegetation canopies. Q. J. R. Meteor. Soc. +! (1989), 115, pp 609-632 + HOL = FCH/MOL !local canopy stability parameter (hc/MOL) + ZCAN = ZFL ! Initialize canopy top (m) = First model layer above canopy + COUNTCAN = 0 ! Initialize canopy layers + DO WHILE (ZCAN.GE.0.5) !canopy threshold >= 0.5 m + ! TLCAN = Lagrangian timescale + TLCAN = (FCH/USTAR) * ( + & (0.256 * (ZCAN-(0.75*FCH))/FCH ) + + & (0.492*EXP((-0.256*ZCAN/FCH)/0.492)) ) + IF ( HOL .LT. -0.1 ) THEN !UNSTABLE + IF ( ZCAN/FCH .GT. 1.25 ) THEN !SIGMACAN = Eulerian vertical velocity variance + SIGMACAN = 1.25*USTAR + END IF + IF ( ZCAN/FCH .GE. 0.175 .AND. ZCAN/FCH .LE. 1.25 ) THEN + SIGMACAN = USTAR * ( 0.75 + (0.5 * COS((PICAN/1.06818) * + & (1.25 - (ZCAN/FCH)))) ) + END IF + IF ( ZCAN/FCH .LT. 0.175 ) THEN + SIGMACAN = 0.25*USTAR + END IF + END IF + IF ( HOL .GE. -0.1 .AND. HOL .LT. 0.1 ) THEN !NEUTRAL + IF ( ZCAN/FCH .GT. 1.25 ) THEN + SIGMACAN = 1.0*USTAR + END IF + IF ( ZCAN/FCH .GE. 0.175 .AND. ZCAN/FCH .LE. 1.25 ) THEN + SIGMACAN = USTAR * ( 0.625 + (0.375* COS((PICAN/1.06818) * + & (1.25 - (ZCAN/FCH)))) ) + END IF + IF ( ZCAN/FCH .LT. 0.175 ) THEN + SIGMACAN = 0.25*USTAR + END IF + END IF + IF ( HOL .GE. 0.1 .AND. HOL .LT. 0.9 ) THEN !STABLE + IF ( ZCAN/FCH .GT. 1.25 ) THEN + SIGMACAN = 0.25*(4.375 - (3.75*HOL))*USTAR + END IF + IF ( ZCAN/FCH .GE. 0.175 .AND. ZCAN/FCH .LE. 1.25 ) THEN + RRCAN=4.375-(3.75*HOL) + AACAN=(0.125*RRCAN) + 0.125 + BBCAN=(0.125*RRCAN) - 0.125 + SIGMACAN = USTAR * ( AACAN + (BBCAN * COS((PICAN/1.06818) * + & (1.25 - (ZCAN/FCH)))) ) + END IF + IF ( ZCAN/FCH .LT. 0.175 ) THEN + SIGMACAN = 0.25*USTAR + END IF + END IF + IF ( HOL .GE. 0.9 ) THEN !VERY STABLE + SIGMACAN = 0.25*USTAR + END IF + IF ( ZCAN .EQ. ZFL ) THEN ! First model layer above canopy + EDDYVEST1 = (SIGMACAN*SIGMACAN)*TLCAN + ELSE IF ( ZCAN .LE. FCH ) THEN !in-canopy layers and set arrays + COUNTCAN = COUNTCAN + 1 + ZCANX (COUNTCAN) = ZCAN + EDDYVESTX (COUNTCAN) = (SIGMACAN*SIGMACAN)*TLCAN + END IF + ZCAN = ZCAN-0.5 !step down in-canopy resolution of 0.5m + END DO !end loop on canopy layers + EDDYVEST_INT = IntegrateTrapezoid((ZCANX(COUNTCAN:1:-1)/FCH),EDDYVESTX(COUNTCAN:1:-1)) + dktx(i,k)= (dkt(i,k)/EDDYVEST1) * EDDYVEST_INT !Scale to resolved eddy diffusivity +! END IF !contigous canopy conditions + END IF ! first model layer scaled canopy + enddo !i + enddo !k !> ## Compute TKE. !! - Compute a minimum TKE deduced from background diffusivity for momentum. ! From 1c587a377944e2101220d7e5f6ba25a1f551ac8b Mon Sep 17 00:00:00 2001 From: drnimbusrain Date: Tue, 6 Dec 2022 10:27:26 -0500 Subject: [PATCH 074/380] Added more arguments for canopy varibles. --- physics/satmedmfvdifq.F | 64 ++++++++++++++++++++++++++--------------- 1 file changed, 41 insertions(+), 23 deletions(-) diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index 89cd8b97e..ba6bd9cdf 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -7,7 +7,7 @@ module satmedmfvdifq use mfpbltq_mod use tridi_mod use mfscuq_mod - !PCC CANOPY + !PCC_CANOPY use canopy_utils_mod contains @@ -79,6 +79,9 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & & dspheat,dusfc,dvsfc,dtsfc,dqsfc,hpbl,dkt,dku, & & kinver,xkzm_m,xkzm_h,xkzm_s,dspfac,bl_upfr,bl_dnfr, & & rlmx,elmx,sfc_rlm, & + !PCC_CANOPY------------------------------------ + & canheight, & + !---------------------------------------------- & ntqv,dtend,dtidx,index_of_temperature,index_of_x_wind, & & index_of_y_wind,index_of_process_pbl,gen_tend,ldiag3d, & & errmsg,errflg) @@ -101,6 +104,9 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & real(kind=kind_phys), intent(in) :: delt, xkzm_m, xkzm_h, xkzm_s real(kind=kind_phys), intent(in) :: dspfac, bl_upfr, bl_dnfr real(kind=kind_phys), intent(in) :: rlmx, elmx + !PCC_CANOPY------------------------------------ + real(kind=kind_phys), intent(in) :: canheight(:) + !---------------------------------------------- real(kind=kind_phys), intent(inout) :: dv(:,:), du(:,:), & & tdt(:,:), rtg(:,:,:), tmf(:,:) real(kind=kind_phys), intent(in) :: & @@ -245,6 +251,15 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & real(kind=kind_phys) qlcr, zstblmax, hcrinv ! real(kind=kind_phys) h1 + + !PCC_CANOPY------------------------------------ + integer COUNTCAN + real(kind=kind_phys) FCH, MOL, HOL, + & SIGMACAN, RRCAN, BBCAN + & AACAN, ZCAN, EDDYVEST1, + & ZCANX, EDDVESTX, + & EDDYVEST_INT + !---------------------------------------------- !! parameter(wfac=7.0,cfac=4.5) parameter(gamcrt=3.,gamcrq=0.,sfcfrac=0.1) @@ -265,9 +280,9 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & parameter(ck0=0.4,ck1=0.15,ch0=0.4,ch1=0.15) parameter(ce0=0.4,cs0=0.2) parameter(rchck=1.5,ndt=20) - !PCC CANOPY + !PCC_CANOPY------------------------------------ parameter (PICAN = 3.1415927) - + !---------------------------------------------- gravi = 1.0 / grav g = grav gocp = g / cp @@ -1197,7 +1212,7 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & ! enddo enddo - !PCC CANOPY + !PCC_CANOPY------------------------------------ do k = 1, 1km1 do i=1,im IF (k .EQ. 1) THEN !first model layer @@ -1208,64 +1223,66 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & ! & .OR. MAX(0.0, 1.0 - FRT) .GT. 0.5 ! & .OR. POPU .GT. 10000.0 ! & .OR. EXP(-0.5*LAI*CLU).GT. 0.45 -! & .AND. FCH .LT. 18.0 ) THEN !not contigous -! canopy -! dktx(i,k)= dkt(i,k) +! & .AND. FCH .LT. 18.0 ) THEN !not a contigous canopy cell +! dkt(i,k)= dkt(i,k) +! dkq(i,k)= dkq(i,k) ! ELSE ! There is a contiguous forest canopy, ! apply correction over canopy layers !Raupauch M. R. A Practical Lagrangian method for relating scalar !concentrations to ! source distributions in vegetation canopies. Q. J. R. Meteor. Soc. ! (1989), 115, pp 609-632 + FCH = canheight(i) !Input canopy height for grid cell i + MOL = zol(i)/zl(i,k) !Monin-Obukhov Length HOL = FCH/MOL !local canopy stability parameter (hc/MOL) - ZCAN = ZFL ! Initialize canopy top (m) = First model layer above canopy - COUNTCAN = 0 ! Initialize canopy layers + ZCAN = zl(i,k) ! Initialize canopy top (m) = First model layer height above canopy + COUNTCAN = 0 ! Initialize canopy layers DO WHILE (ZCAN.GE.0.5) !canopy threshold >= 0.5 m ! TLCAN = Lagrangian timescale - TLCAN = (FCH/USTAR) * ( + TLCAN = (FCH/ustar(i)) * ( & (0.256 * (ZCAN-(0.75*FCH))/FCH ) + & (0.492*EXP((-0.256*ZCAN/FCH)/0.492)) ) - IF ( HOL .LT. -0.1 ) THEN !UNSTABLE + IF ( HOL .LT. -0.1 ) THEN !STRONG UNSTABLE IF ( ZCAN/FCH .GT. 1.25 ) THEN !SIGMACAN = Eulerian vertical velocity variance - SIGMACAN = 1.25*USTAR + SIGMACAN = 1.25*ustar(i) END IF IF ( ZCAN/FCH .GE. 0.175 .AND. ZCAN/FCH .LE. 1.25 ) THEN - SIGMACAN = USTAR * ( 0.75 + (0.5 * COS((PICAN/1.06818) * + SIGMACAN = ustar(i) * ( 0.75 + (0.5 * COS((PICAN/1.06818) * & (1.25 - (ZCAN/FCH)))) ) END IF IF ( ZCAN/FCH .LT. 0.175 ) THEN - SIGMACAN = 0.25*USTAR + SIGMACAN = 0.25*ustar(i) END IF END IF - IF ( HOL .GE. -0.1 .AND. HOL .LT. 0.1 ) THEN !NEUTRAL + IF ( HOL .GE. -0.1 .AND. HOL .LT. 0.1 ) THEN !WEAKLY UNSTABLE to NEUTRAL IF ( ZCAN/FCH .GT. 1.25 ) THEN - SIGMACAN = 1.0*USTAR + SIGMACAN = 1.0*ustar(i) END IF IF ( ZCAN/FCH .GE. 0.175 .AND. ZCAN/FCH .LE. 1.25 ) THEN - SIGMACAN = USTAR * ( 0.625 + (0.375* COS((PICAN/1.06818) * + SIGMACAN = ustar(i) * ( 0.625 + (0.375* COS((PICAN/1.06818) * & (1.25 - (ZCAN/FCH)))) ) END IF IF ( ZCAN/FCH .LT. 0.175 ) THEN - SIGMACAN = 0.25*USTAR + SIGMACAN = 0.25*ustar(i) END IF END IF IF ( HOL .GE. 0.1 .AND. HOL .LT. 0.9 ) THEN !STABLE IF ( ZCAN/FCH .GT. 1.25 ) THEN - SIGMACAN = 0.25*(4.375 - (3.75*HOL))*USTAR + SIGMACAN = 0.25*(4.375 - (3.75*HOL))*ustar(i) END IF IF ( ZCAN/FCH .GE. 0.175 .AND. ZCAN/FCH .LE. 1.25 ) THEN RRCAN=4.375-(3.75*HOL) AACAN=(0.125*RRCAN) + 0.125 BBCAN=(0.125*RRCAN) - 0.125 - SIGMACAN = USTAR * ( AACAN + (BBCAN * COS((PICAN/1.06818) * + SIGMACAN = ustar(i) * ( AACAN + (BBCAN * COS((PICAN/1.06818) * & (1.25 - (ZCAN/FCH)))) ) END IF IF ( ZCAN/FCH .LT. 0.175 ) THEN - SIGMACAN = 0.25*USTAR + SIGMACAN = 0.25*ustar(i) END IF END IF IF ( HOL .GE. 0.9 ) THEN !VERY STABLE - SIGMACAN = 0.25*USTAR + SIGMACAN = 0.25*ustar(i) END IF IF ( ZCAN .EQ. ZFL ) THEN ! First model layer above canopy EDDYVEST1 = (SIGMACAN*SIGMACAN)*TLCAN @@ -1277,7 +1294,8 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & ZCAN = ZCAN-0.5 !step down in-canopy resolution of 0.5m END DO !end loop on canopy layers EDDYVEST_INT = IntegrateTrapezoid((ZCANX(COUNTCAN:1:-1)/FCH),EDDYVESTX(COUNTCAN:1:-1)) - dktx(i,k)= (dkt(i,k)/EDDYVEST1) * EDDYVEST_INT !Scale to resolved eddy diffusivity + dkt(i,k)= (dkt(i,k)/EDDYVEST1) * EDDYVEST_INT !Scale dkt to resolved eddy diffusivity + dkq(i,k)= (dkq(i,k)/EDDYVEST1) * EDDYVEST_INT !Scale dku to resolved eddy diffusivity ! END IF !contigous canopy conditions END IF ! first model layer scaled canopy enddo !i From fe808c6794f31c9a828e860413759bbe919375a2 Mon Sep 17 00:00:00 2001 From: drnimbusrain Date: Tue, 6 Dec 2022 13:33:56 -0500 Subject: [PATCH 075/380] Fixed non-ascii character. --- physics/canopy_utils_mod.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/canopy_utils_mod.f b/physics/canopy_utils_mod.f index b34202ae8..f10a3f7c5 100644 --- a/physics/canopy_utils_mod.f +++ b/physics/canopy_utils_mod.f @@ -14,7 +14,7 @@ function IntegrateTrapezoid(x, y) !have to be uniform. real, intent(in) :: x(:) !! Variable x real, intent(in) :: y(size(x)) !! Function y(x) - real :: IntegrateTrapezoid !! Integral of y(x)·dx + real :: IntegrateTrapezoid !! Integral of y(x)dx ! Integrate using the trapezoidal rule associate(n => size(x)) IntegrateTrapezoid = sum((y(1+1:n-0) + y(1+0:n-1))* From 8f7f329f01fcb7a88e7240f77740bfef0e94de57 Mon Sep 17 00:00:00 2001 From: Eric Aligo Date: Thu, 8 Dec 2022 19:09:10 +0000 Subject: [PATCH 076/380] New winter wx diags, variable precip ice density computed in MP_generic instead of RUC LSM, variable precip ice density optional use for NOAH MP and NOAH LSM, change radar_reset to fullradar_diag since original name did not make sense. --- physics/GFS_MP_generic_post.F90 | 87 ++++++++++++++++++++++++++++++-- physics/GFS_MP_generic_post.meta | 70 +++++++++++++++++++++++++ physics/GFS_debug.F90 | 2 +- physics/lsm_noah.f | 24 ++++----- physics/lsm_noah.meta | 15 ++++++ physics/lsm_ruc.F90 | 12 +++-- physics/lsm_ruc.meta | 8 +++ physics/module_mp_thompson.F90 | 6 +-- physics/module_sf_noahmplsm.f90 | 8 +-- physics/module_sf_ruclsm.F90 | 26 +++++----- physics/mp_thompson.F90 | 10 ++-- physics/mp_thompson.meta | 6 +-- physics/noahmpdrv.F90 | 5 +- physics/noahmpdrv.meta | 8 +++ physics/sflx.f | 25 ++++++--- 15 files changed, 253 insertions(+), 59 deletions(-) diff --git a/physics/GFS_MP_generic_post.F90 b/physics/GFS_MP_generic_post.F90 index b7e65bc8b..edfecf927 100644 --- a/physics/GFS_MP_generic_post.F90 +++ b/physics/GFS_MP_generic_post.F90 @@ -20,10 +20,11 @@ module GFS_MP_generic_post !> @{ subroutine GFS_MP_generic_post_run( & im, levs, kdt, nrcm, nncl, ntcw, ntrac, imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_nssl, & - imp_physics_mg, imp_physics_fer_hires, cal_pre, cplflx, cplchm, cpllnd, progsigma, con_g, rainmin, dtf, frain, rainc, & + imp_physics_mg, imp_physics_fer_hires, cal_pre, cplflx, cplchm, cpllnd, progsigma, con_g, rainmin, dtf, frain, rainc, & rain1, rann, xlat, xlon, gt0, gq0, prsl, prsi, phii, tsfc, ice, snow, graupel, save_t, save_q, rain0, ice0, snow0,& graupel0, del, rain, domr_diag, domzr_diag, domip_diag, doms_diag, tprcp, srflag, sr, cnvprcp, totprcp, totice, & totsnw, totgrp, cnvprcpb, totprcpb, toticeb, totsnwb, totgrpb, rain_cpl, rainc_cpl, snow_cpl, pwat, & + acfrzrn, acfrzrnb, acgraup, acgraupb, acsnow, acsnowb, rhonewsn1, vrbliceden_noah, iopt_snf, & drain_cpl, dsnow_cpl, lsm, lsm_ruc, lsm_noahmp, raincprv, rainncprv, iceprv, snowprv, & graupelprv, draincprv, drainncprv, diceprv, dsnowprv, dgraupelprv, dtp, dfi_radar_max_intervals, & dtend, dtidx, index_of_temperature, index_of_process_mp,ldiag3d, qdiag3d,dqdt_qmicro, lssav, num_dfi_radar, & @@ -37,7 +38,7 @@ subroutine GFS_MP_generic_post_run( integer, intent(in) :: im, levs, kdt, nrcm, nncl, ntcw, ntrac, num_dfi_radar, index_of_process_dfi_radar integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_mg, imp_physics_fer_hires integer, intent(in) :: imp_physics_nssl - logical, intent(in) :: cal_pre, lssav, ldiag3d, qdiag3d, cplflx, cplchm, cpllnd, progsigma + logical, intent(in) :: cal_pre, lssav, ldiag3d, qdiag3d, cplflx, cplchm, cpllnd, progsigma, vrbliceden_noah integer, intent(in) :: index_of_temperature,index_of_process_mp integer :: dfi_radar_max_intervals @@ -70,7 +71,7 @@ subroutine GFS_MP_generic_post_run( real(kind=kind_phys), dimension(:), intent(inout) :: drain_cpl, dsnow_cpl ! Rainfall variables previous time step - integer, intent(in) :: lsm, lsm_ruc, lsm_noahmp + integer, intent(in) :: lsm, lsm_ruc, lsm_noahmp, iopt_snf real(kind=kind_phys), dimension(:), intent(inout) :: raincprv real(kind=kind_phys), dimension(:), intent(inout) :: rainncprv real(kind=kind_phys), dimension(:), intent(inout) :: iceprv @@ -81,6 +82,13 @@ subroutine GFS_MP_generic_post_run( real(kind=kind_phys), dimension(:), intent(inout) :: diceprv real(kind=kind_phys), dimension(:), intent(inout) :: dsnowprv real(kind=kind_phys), dimension(:), intent(inout) :: dgraupelprv + real(kind=kind_phys), dimension(:), intent(inout) :: acfrzrn + real(kind=kind_phys), dimension(:), intent(inout) :: acfrzrnb + real(kind=kind_phys), dimension(:), intent(inout) :: acgraup + real(kind=kind_phys), dimension(:), intent(inout) :: acgraupb + real(kind=kind_phys), dimension(:), intent(inout) :: acsnow + real(kind=kind_phys), dimension(:), intent(inout) :: acsnowb + real(kind=kind_phys), dimension(:), intent(inout) :: rhonewsn1 real(kind=kind_phys), dimension(:,:), intent(inout) :: dqdt_qmicro real(kind=kind_phys), dimension(:,:), intent(inout) :: prevsq real(kind=kind_phys), intent(in) :: dtp @@ -101,6 +109,10 @@ subroutine GFS_MP_generic_post_run( real(kind=kind_phys) :: crain, csnow, onebg, tem, total_precip, tem1, tem2, ttend real(kind=kind_phys), dimension(im) :: domr, domzr, domip, doms, t850, work1 + real :: snowrat,grauprat,icerat,curat,prcpncfr,prcpcufr + real :: rhonewsnow,rhoprcpice,rhonewgr,rhonewice + real(kind=kind_phys), parameter :: rhowater = 1000.0_kind_phys + ! Initialize CCPP error handling variables errmsg = '' errflg = 0 @@ -111,6 +123,75 @@ subroutine GFS_MP_generic_post_run( rain(i) = rainc(i) + frain * rain1(i) ! time-step convective plus explicit enddo +!aligo compute surface snowfall, graupel/sleet, freezing rain and precip ice density + if (imp_physics == imp_physics_gfdl .or. imp_physics == imp_physics_thompson .or. imp_physics == imp_physics_nssl ) then + do i = 1, im +! write(0,*)'freezing rain gt0(1),gt0(levs):',gt0(1,1),gt0(1,levs) + if (gt0(i,1) .le. 273) then + acfrzrn(i) = acfrzrn(i) + rain0(i) + acfrzrnb(i) = acfrzrnb(i) + rain0(i) + endif + acsnow(i) = acsnow(i) + snow0(i) + acsnowb(i) = acsnowb(i) + snow0(i) + acgraup(i) = acgraup(i) + graupel0(i) + acgraupb(i) = acgraupb(i) + graupel0(i) + enddo +!Compute the variable precip ice density for specific LSM schemes and options +! if ( lsm .ne. 2 .or. iopt_snf .ne. 5) then +! write(0,*)'aligo,lsm,iopt_snf :',lsm,iopt_snf +! endif + if ( lsm == lsm_ruc .or. lsm == lsm_noahmp .and. iopt_snf == 5 .or. vrbliceden_noah == .true.) then +! write(0,*)'lsm,iopt_snf,vrbliceden_noah: ',lsm,iopt_snf,vrbliceden_noah + snowrat = 0. + grauprat = 0. + icerat = 0. + prcpncfr = 0. + prcpcufr = 0. + curat = 0. + prcpncfr = 0. + prcpcufr = 0. + rhonewsnow = 0. + rhonewgr = 0. + rhonewice = 0. + rhoprcpice = 0. + do i = 1, im + rhonewsn1(i)= 200. + prcpncfr = rain1(i)*sr(i) + if(sr(i) > 0..and. gt0(i,1) < 273.) then + prcpcufr = max(0.,rainc(i)*sr(i)) + else + if(gt0(i,1) < 273.) then + prcpcufr = max(0.,rainc(i)) + else + prcpcufr = 0. + endif ! gt0(i,1) < 273. + endif ! frzfrac > 0. +! + if((prcpncfr + prcpcufr) > 0.) then +! -- calculate snow, graupel and ice fractions in falling frozen precip + snowrat=min(1.,max(0.,snow0(i)/(prcpncfr + prcpcufr))) + grauprat=min(1.,max(0.,graupel0(i)/(prcpncfr + prcpcufr))) + icerat=min(1.,max(0.,(prcpncfr-snow0(i)-graupel0(i)) & + /(prcpncfr + prcpcufr))) + curat=min(1.,max(0.,(prcpcufr/(prcpncfr + prcpcufr)))) + + rhonewsnow=min(125.,1000.0/max(8.,(17.*tanh((276.65-gt0(i,1))*0.15)))) + rhonewgr=min(500.,rhowater/max(2.,(3.5*tanh((274.15-gt0(i,1))*0.3333)))) + rhonewice=rhonewsnow + +!--- compute density of "precip ice" from weighted contribution +! of snow, graupel and ice fractions + + rhoprcpice = min(500.,max(58.8,(rhonewsnow*snowrat + & + rhonewgr*grauprat + rhonewice*icerat + rhonewgr*curat))) + +! from now on rhonewsn1 is the density of falling frozen precipitation + rhonewsn1(i)=rhoprcpice + endif + enddo + endif + endif + !> - If requested (e.g. Zhao-Carr MP scheme), call calpreciptype() to calculate dominant !! precipitation type. ! DH* TODO - Fix wrong code in non-CCPP build (GFS_physics_driver) diff --git a/physics/GFS_MP_generic_post.meta b/physics/GFS_MP_generic_post.meta index 5216b7157..46dfe66d6 100644 --- a/physics/GFS_MP_generic_post.meta +++ b/physics/GFS_MP_generic_post.meta @@ -278,6 +278,76 @@ type = real kind = kind_phys intent = inout +[acfrzrn] + standard_name = lwe_thickness_of_sfc_freezing_rain_amount + long_name = accumulated surface freezing rain + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[acfrzrnb] + standard_name = lwe_thickness_of_sfc_freezing_rain_amount_in_bucket + long_name = accumulated surface freezing rain in bucket + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[acgraup] + standard_name = lwe_thickness_of_sfc_graupel_amount + long_name = accumulated surface graupel + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[acgraupb] + standard_name = lwe_thickness_of_sfc_graupel_amount_in_bucket + long_name = accumulated surface graupel in bucket + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[acsnow] + standard_name = lwe_thickness_of_sfc_snow_amount + long_name = accumulated surface snow + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[acsnowb] + standard_name = lwe_thickness_of_sfc_snow_amount_in_bucket + long_name = accumulated surface snow in bucket + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[rhonewsn1] + standard_name = lwe_density_of_precip_ice + long_name = density of precipitation ice + units = kg m-3 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[vrbliceden_noah] + standard_name = flag_for_vrbl_prcp_ice_den + long_name = flag for variable precip ice density + units = flag + dimensions = () + type = logical + intent = in +[iopt_snf] + standard_name = control_for_land_surface_scheme_precipitation_type_partition + long_name = choice for precipitation partition option (see noahmp module for definition) + units = index + dimensions = () + type = integer + intent = in [save_t] standard_name = air_temperature_save long_name = air temperature before entering a physics scheme diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 5e6419256..5387e6300 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -1285,7 +1285,7 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%qss_ice ', Interstitial%qss_ice ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%qss_land ', Interstitial%qss_land ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%qss_water ', Interstitial%qss_water ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%radar_reset ', Interstitial%radar_reset ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%fullradar_diag ', Interstitial%fullradar_diag ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%raddt ', Interstitial%raddt ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%raincd ', Interstitial%raincd ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%raincs ', Interstitial%raincs ) diff --git a/physics/lsm_noah.f b/physics/lsm_noah.f index 246f81654..bc12aa64e 100644 --- a/physics/lsm_noah.f +++ b/physics/lsm_noah.f @@ -220,7 +220,8 @@ subroutine lsm_noah_run & & lheatstrg, isot, ivegsrc, & & bexppert, xlaipert, vegfpert,pertvegf, & ! sfc perts, mgehne & albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, & - & adjvisbmd, adjnirbmd, adjvisdfd, adjnirdfd, & + & adjvisbmd, adjnirbmd, adjvisdfd, adjnirdfd, rhonewsn1, & + & vrbliceden_noah, & ! --- in/outs: & weasd, snwdph, tskin, tprcp, srflag, smc, stc, slc, & & canopy, trans, tsurf, zorl, & @@ -252,7 +253,7 @@ subroutine lsm_noah_run & & -1.0_kind_phys, -2.0_kind_phys / ! --- input: - integer, intent(in) :: im, km, isot, ivegsrc + integer, intent(in) :: im, km, isot, ivegsrc real (kind=kind_phys), intent(in) :: grav, cp, hvap, rd, eps, & & epsm1, rvrdm1 real (kind=kind_phys), intent(in) :: pertvegf @@ -265,13 +266,13 @@ subroutine lsm_noah_run & & snoalb, sfalb, zf, & & bexppert, xlaipert, vegfpert, & & albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, & - & adjvisbmd, adjnirbmd, adjvisdfd, adjnirdfd + & adjvisbmd, adjnirbmd, adjvisdfd, adjnirdfd, rhonewsn1 real (kind=kind_phys), intent(in) :: delt logical, dimension(:), intent(in) :: flag_iter, flag_guess, land - logical, intent(in) :: lheatstrg + logical, intent(in) :: lheatstrg, vrbliceden_noah ! --- in/out: real (kind=kind_phys), dimension(:), intent(inout) :: weasd, & @@ -292,7 +293,7 @@ subroutine lsm_noah_run & ! --- locals: real (kind=kind_phys), dimension(im) :: rch, rho, & & q0, qs1, theta1, weasd_old, snwdph_old, & - & tprcp_old, srflag_old, tskin_old, canopy_old + & tprcp_old, srflag_old, tskin_old, canopy_old real (kind=kind_phys), dimension(km) :: et, sldpth, stsoil, & & smsoil, slsoil @@ -309,8 +310,8 @@ subroutine lsm_noah_run & & smcdry, smcref, smcmax, sneqv, snoalb1d, snowh, & & snomlt, sncovr, soilw, soilm, ssoil, tsea, th2, tbot, & & xlai, zlvl, swdn, tem, z0, bexpp, xlaip, vegfp, & - & mv, sv, alphav, betav, vegftmp, cpinv, hvapi, elocp - + & mv, sv, alphav, betav, vegftmp, cpinv, hvapi, elocp, & + & rhonewsn integer :: couple, ice, nsoil, nroot, slope, stype, vtype integer :: i, k, iflag ! @@ -326,7 +327,7 @@ subroutine lsm_noah_run & errflg = 0 !> - Save land-related prognostic fields for guess run. - +!aligo do i = 1, im if (land(i) .and. flag_guess(i)) then weasd_old(i) = weasd(i) @@ -335,7 +336,6 @@ subroutine lsm_noah_run & canopy_old(i) = canopy(i) tprcp_old(i) = tprcp(i) srflag_old(i) = srflag(i) - do k = 1, km smc_old(i,k) = smc(i,k) stc_old(i,k) = stc(i,k) @@ -361,7 +361,6 @@ subroutine lsm_noah_run & sbsno(i) = zero snowc(i) = zero snohf(i) = zero - !> - Initialize variables wind, q, and rh at level 1. q0(i) = max(q1(i), qmin) !* q1=specific humidity at level 1 (kg/kg) @@ -371,7 +370,6 @@ subroutine lsm_noah_run & qs1(i) = fpvs( t1(i) ) !* qs1=sat. humidity at level 1 (kg/kg) qs1(i) = max(eps*qs1(i) / (prsl1(i)+epsm1*qs1(i)), qmin) q0 (i) = min(qs1(i), q0(i)) - do k = 1, km zsoil(i,k) = zsoil_noah(k) enddo @@ -524,7 +522,8 @@ subroutine lsm_noah_run & !> - Apply perturbation of soil type b parameter and leave area index. bexpp = bexppert(i) ! sfc perts, mgehne xlaip = xlaipert(i) ! sfc perts, mgehne - +!> - New snow depth variables + rhonewsn = rhonewsn1(i) !> - Call Noah LSM gfssflx(). call gfssflx & ! ccppdox: these is sflx in mpbl @@ -533,6 +532,7 @@ subroutine lsm_noah_run & & swdn, solnet, lwdn, sfcems, sfcprs, sfctmp, & & sfcspd, prcp, q2, q2sat, dqsdt2, th2, ivegsrc, & & vtype, stype, slope, shdmin1d, alb, snoalb1d, & + & rhonewsn, vrbliceden_noah, & & bexpp, xlaip, & ! sfc-perts, mgehne & lheatstrg, & ! --- input/outputs: diff --git a/physics/lsm_noah.meta b/physics/lsm_noah.meta index 2ce7c3e6c..2235dda88 100644 --- a/physics/lsm_noah.meta +++ b/physics/lsm_noah.meta @@ -486,6 +486,21 @@ type = real kind = kind_phys intent = in +[rhonewsn1] + standard_name = lwe_density_of_precip_ice + long_name = density of precipitation ice + units = kg m-3 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[vrbliceden_noah] + standard_name = flag_for_vrbl_prcp_ice_den + long_name = flag for variable precip ice density + units = flag + dimensions = () + type = logical + intent = in [weasd] standard_name = water_equivalent_accumulated_snow_depth_over_land long_name = water equiv of acc snow depth over land diff --git a/physics/lsm_ruc.F90 b/physics/lsm_ruc.F90 index 99b6c2b41..6aae4feac 100644 --- a/physics/lsm_ruc.F90 +++ b/physics/lsm_ruc.F90 @@ -331,7 +331,7 @@ subroutine lsm_ruc_run & ! inputs & prsl1, zf, wind, shdmin, shdmax, & & srflag, sfalb_lnd_bck, snoalb, & & isot, ivegsrc, fice, smcwlt2, smcref2, & - & min_lakeice, min_seaice, oceanfrac, & + & min_lakeice, min_seaice, oceanfrac, rhonewsn1, & ! --- constants & con_cp, con_rd, con_rv, con_g, con_pi, con_hvap, & & con_fvirt, & @@ -418,7 +418,7 @@ subroutine lsm_ruc_run & ! inputs ! --- in real (kind=kind_phys), dimension(:), intent(in) :: & - & rainnc, rainc, ice, snow, graupel + & rainnc, rainc, ice, snow, graupel, rhonewsn1 ! --- in/out: ! --- on RUC levels real (kind=kind_phys), dimension(:,:), intent(inout) :: & @@ -494,7 +494,8 @@ subroutine lsm_ruc_run & ! inputs & soilt_lnd, tbot, & & xlai, swdn, z0_lnd, znt_lnd, rhosnfr, infiltr, & & precipfr, snfallac_lnd, acsn, & - & qsfc_lnd, qsg_lnd, qvg_lnd, qcg_lnd, soilt1_lnd, chklowq + & qsfc_lnd, qsg_lnd, qvg_lnd, qcg_lnd, soilt1_lnd, chklowq, & + & rhonewsn ! ice real (kind=kind_phys),dimension (im,1) :: & & albbck_ice, alb_ice, chs_ice, flhc_ice, flqc_ice, & @@ -845,6 +846,7 @@ subroutine lsm_ruc_run & ! inputs rainncv(i,j) = rhoh2o * rainnc(i) ! total time-step explicit precip graupelncv(i,j) = rhoh2o * graupel(i) snowncv(i,j) = rhoh2o * snow(i) + rhonewsn(i,j) = rhonewsn1(i) if (debug_print) then !-- diagnostics for a test point with known lat/lon if (abs(xlat_d(i)-testptlat).lt.2.5 .and. & @@ -1125,7 +1127,7 @@ subroutine lsm_ruc_run & ! inputs & conflx2(i,1,j), sfcprs(i,1,j), sfctmp(i,1,j), q2(i,1,j), & & qcatm(i,1,j), rho2(i,1,j), semis_bck(i,j), lwdn(i,j), & & swdn(i,j), solnet_lnd(i,j), sfcems_lnd(i,j), chklowq(i,j), & - & chs_lnd(i,j), flqc_lnd(i,j), flhc_lnd(i,j), & + & chs_lnd(i,j), flqc_lnd(i,j), flhc_lnd(i,j), rhonewsn(i,j), & ! --- input/outputs: & wet(i,j), cmc(i,j), shdfac(i,j), alb_lnd(i,j), znt_lnd(i,j), & & z0_lnd(i,j), snoalb1d_lnd(i,j), albbck_lnd(i,j), & @@ -1399,7 +1401,7 @@ subroutine lsm_ruc_run & ! inputs & conflx2(i,1,j), sfcprs(i,1,j), sfctmp(i,1,j), q2(i,1,j), & & qcatm(i,1,j), rho2(i,1,j), semis_bck(i,j), lwdn(i,j), & & swdn(i,j), solnet_ice(i,j), sfcems_ice(i,j), chklowq(i,j), & - & chs_ice(i,j), flqc_ice(i,j), flhc_ice(i,j), & + & chs_ice(i,j), flqc_ice(i,j), flhc_ice(i,j), rhonewsn(i,j), & ! --- input/outputs: & wet_ice(i,j), cmc(i,j), shdfac(i,j), alb_ice(i,j), & & znt_ice(i,j), z0_ice(i,j), snoalb1d_ice(i,j), & diff --git a/physics/lsm_ruc.meta b/physics/lsm_ruc.meta index 587fda681..3fe40f419 100644 --- a/physics/lsm_ruc.meta +++ b/physics/lsm_ruc.meta @@ -952,6 +952,14 @@ type = real kind = kind_phys intent = in +[rhonewsn1] + standard_name = lwe_density_of_precip_ice + long_name = density of precipitation ice + units = kg m-3 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [con_cp] standard_name = specific_heat_of_dry_air_at_constant_pressure long_name = specific heat !of dry air at constant pressure diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index 70c48feba..b828c9ab0 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -1003,7 +1003,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & ids,ide, jds,jde, kds,kde, & ! domain dims ims,ime, jms,jme, kms,kme, & ! memory dims its,ite, jts,jte, kts,kte, & ! tile dims - reset_dBZ, istep, nsteps, & + fullradar_diag, istep, nsteps, & errmsg, errflg, & ! Extended diagnostics, array pointers ! only associated if ext_diag flag is .true. @@ -1070,7 +1070,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & INTEGER, INTENT(IN) :: decfl ! To support subcycling: current step and maximum number of steps INTEGER, INTENT (IN) :: istep, nsteps - LOGICAL, INTENT (IN) :: reset_dBZ + LOGICAL, INTENT (IN) :: fullradar_diag ! Extended diagnostics, array pointers only associated if ext_diag flag is .true. LOGICAL, INTENT (IN) :: ext_diag LOGICAL, OPTIONAL, INTENT(IN):: aero_ind_fdb @@ -1677,7 +1677,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & if (diagflag .and. do_radar_ref == 1) then ! ! Only set melti to true at the output times - if (reset_dBZ) then + if (fullradar_diag) then melti=.true. else melti=.false. diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 1da30f156..5146c56e6 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -218,6 +218,7 @@ module module_sf_noahmplsm real (kind=kind_phys) :: saim(12) !< monthly stem area index, one-sided real (kind=kind_phys) :: laim(12) !< monthly leaf area index, one-sided real (kind=kind_phys) :: sla !< single-side leaf area per kg [m2/kg] + real (kind=kind_phys) :: prcpiceden !< precipitation ice density [kg/m^3] real (kind=kind_phys) :: dilefc !< coeficient for leaf stress death [1/s] real (kind=kind_phys) :: dilefw !< coeficient for leaf stress death [1/s] real (kind=kind_phys) :: fragr !< fraction of growth respiration !original was 0.3 @@ -1068,13 +1069,14 @@ subroutine atm (parameters,sfcprs ,sfctmp ,q2 , ! fresh snow density bdfall = min(120.,67.92+51.25*exp((sfctmp-tfrz)/2.59)) !mb/an: change to min - if(opt_snf == 4) then + if(opt_snf == 4 .or. opt_snf == 5) then prcp_frozen = prcpsnow + prcpgrpl + prcphail if(prcpnonc > 0. .and. prcp_frozen > 0.) then fpice = min(1.0,prcp_frozen/prcpnonc) fpice = max(0.0,fpice) - bdfall = bdfall*(prcpsnow/prcp_frozen) + rho_grpl*(prcpgrpl/prcp_frozen) + & - rho_hail*(prcphail/prcp_frozen) + if(opt_snf==4) bdfall = bdfall*(prcpsnow/prcp_frozen) + rho_grpl*(prcpgrpl/prcp_frozen) + & + rho_hail*(prcphail/prcp_frozen) + if(opt_snf==5) bdfall = parameters%prcpiceden else fpice = 0.0 endif diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 9a6363c08..6c417d6fd 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -57,8 +57,8 @@ SUBROUTINE LSMRUC( & rhosnf,precipfr, & Z3D,P8W,T3D,QV3D,QC3D,RHO3D,EMISBCK, & GLW,GSWdn,GSW,EMISS,CHKLOWQ, CHS, & - FLQC,FLHC,MAVAIL,CANWAT,VEGFRA,ALB,ZNT, & - Z0,SNOALB,ALBBCK,LAI, & + FLQC,FLHC,rhonewsn,MAVAIL,CANWAT,VEGFRA,ALB, & + ZNT,Z0,SNOALB,ALBBCK,LAI, & landusef, nlcat, & ! mosaic_lu, mosaic_soil, & soilctop, nscat, & QSFC,QSG,QVG,QCG,DEW,SOILT1,TSNAV, & @@ -191,7 +191,8 @@ SUBROUTINE LSMRUC( & INTENT(IN ) :: GRAUPELNCV, & SNOWNCV, & RAINCV, & - RAINNCV + RAINNCV, & + RHONEWSN ! REAL, DIMENSION( ims:ime , jms:jme ), & ! INTENT(IN ) :: lakemask ! INTEGER, INTENT(IN ) :: LakeModel @@ -301,7 +302,6 @@ SUBROUTINE LSMRUC( & !--- soil/snow properties REAL & :: RHOCS, & - RHONEWSN, & RHOSN, & RHOSNFALL, & BCLH, & @@ -684,7 +684,6 @@ SUBROUTINE LSMRUC( & NROOT= 4 ! ! rooting depth - RHONEWSN = 200. if(SNOW(i,j).gt.0. .and. SNOWH(i,j).gt.0.) then RHOSN = SNOW(i,j)/SNOWH(i,j) else @@ -895,7 +894,7 @@ SUBROUTINE LSMRUC( & nzs,nddzs,nroot,meltfactor, & !added meltfactor iland,isoil,ivgtyp(i,j),isltyp(i,j), & PRCPMS, NEWSNMS,SNWE,SNHEI,SNOWFRAC, & - RHOSN,RHONEWSN,RHOSNFALL, & + RHOSN,RHONEWSN(I,J),RHOSNFALL, & snowrat,grauprat,icerat,curat, & PATM,TABS,QVATM,QCATM,RHO, & GLW(I,J),GSWdn(i,j),GSW(I,J), & @@ -1190,7 +1189,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia nddzs !nddzs=2*(nzs-2) REAL, INTENT(IN ) :: DELT,CONFLX,meltfactor - REAL, INTENT(IN ) :: C1SN,C2SN + REAL, INTENT(IN ) :: C1SN,C2SN,RHONEWSN LOGICAL, INTENT(IN ) :: myj, debug_print !--- 3-D Atmospheric variables REAL , & @@ -1282,7 +1281,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia EVAPL, & INFILTR, & RHOSN, & - RHONEWSN, & rhosnfall, & snowrat, & grauprat, & @@ -1494,19 +1492,19 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia !--- 27 Feb 2014 - empirical formulations from John M. Brown ! rhonewsn=min(250.,rhowater/max(4.179,(13.*tanh((274.15-Tabs)*0.3333)))) !--- 13 Mar 2018 - formulation from Trevor Elcott - rhonewsn=min(125.,1000.0/max(8.,(17.*tanh((276.65-Tabs)*0.15)))) - rhonewgr=min(500.,rhowater/max(2.,(3.5*tanh((274.15-Tabs)*0.3333)))) - rhonewice=rhonewsn +!aligo rhonewsn=min(125.,1000.0/max(8.,(17.*tanh((276.65-Tabs)*0.15)))) +!aligo rhonewgr=min(500.,rhowater/max(2.,(3.5*tanh((274.15-Tabs)*0.3333)))) +!aligo rhonewice=rhonewsn !--- compute density of "snowfall" from weighted contribution ! of snow, graupel and ice fractions - rhosnfall = min(500.,max(58.8,(rhonewsn*snowrat + & +!aligo rhosnfall = min(500.,max(58.8,(rhonewsn*snowrat + & !13mar18 rhosnfall = min(500.,max(76.9,(rhonewsn*snowrat + & - rhonewgr*grauprat + rhonewice*icerat + rhonewgr*curat))) +!aligo rhonewgr*grauprat + rhonewice*icerat + rhonewgr*curat))) ! from now on rhonewsn is the density of falling frozen precipitation - rhonewsn=rhosnfall +!aligo rhonewsn=rhosnfall !*** Define average snow density of the snow pack considering !*** the amount of fresh snow (eq. 9 in Koren et al.(1999) diff --git a/physics/mp_thompson.F90 b/physics/mp_thompson.F90 index 727098a05..aee97ef60 100644 --- a/physics/mp_thompson.F90 +++ b/physics/mp_thompson.F90 @@ -326,8 +326,8 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & dt_inner, & first_time_step, istep, nsteps, & prcp, rain, graupel, ice, snow, sr, & - refl_10cm, reset_dBZ, do_radar_ref, & - aerfld, & + refl_10cm, fullradar_diag, & + do_radar_ref, aerfld, & mpicomm, mpirank, mpiroot, blkno, & ext_diag, diag3d, reset_diag3d, & spp_wts_mp, spp_mp, n_var_spp, & @@ -357,7 +357,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & real(kind_phys), intent(inout) :: ni(:,:) real(kind_phys), intent(inout) :: nr(:,:) ! Aerosols - logical, intent(in) :: is_aerosol_aware, reset_dBZ + logical, intent(in) :: is_aerosol_aware, fullradar_diag logical, intent(in) :: merra2_aerosol_aware real(kind_phys), optional, intent(inout) :: nc(:,:) real(kind_phys), optional, intent(inout) :: nwfa(:,:) @@ -705,7 +705,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, & ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & - reset_dBZ=reset_dBZ, istep=istep, nsteps=nsteps, & + fullradar_diag=fullradar_diag, astep=istep, nsteps=nsteps, & first_time_step=first_time_step, errmsg=errmsg, errflg=errflg, & ! Extended diagnostics ext_diag=ext_diag, & @@ -744,7 +744,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, & ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & - reset_dBZ=reset_dBZ, istep=istep, nsteps=nsteps, & + fullradar_diag=fullradar_diag, istep=istep, nsteps=nsteps, & first_time_step=first_time_step, errmsg=errmsg, errflg=errflg, & ! Extended diagnostics ext_diag=ext_diag, & diff --git a/physics/mp_thompson.meta b/physics/mp_thompson.meta index 1f459bb88..744405c03 100644 --- a/physics/mp_thompson.meta +++ b/physics/mp_thompson.meta @@ -610,9 +610,9 @@ type = real kind = kind_phys intent = out -[reset_dBZ] - standard_name = flag_for_resetting_radar_reflectivity_calculation - long_name = flag for resetting radar reflectivity calculation +[fullradar_diag] + standard_name = flag_for_computing_full_radar_reflectivity + long_name = flag for computing full radar reflectivity units = flag dimensions = () type = logical diff --git a/physics/noahmpdrv.F90 b/physics/noahmpdrv.F90 index fed823ead..e223ffbec 100644 --- a/physics/noahmpdrv.F90 +++ b/physics/noahmpdrv.F90 @@ -138,7 +138,7 @@ subroutine noahmpdrv_run & idveg, iopt_crs, iopt_btr, iopt_run, iopt_sfc, iopt_frz, & iopt_inf, iopt_rad, iopt_alb, iopt_snf, iopt_tbot, & iopt_stc, iopt_trs,xlatin, xcoszin, iyrlen, julian, garea, & - rainn_mp, rainc_mp, snow_mp, graupel_mp, ice_mp, & + rainn_mp, rainc_mp, snow_mp, graupel_mp, ice_mp, rhonewsn1,& con_hvap, con_cp, con_jcal, rhoh2o, con_eps, con_epsm1, & con_fvirt, con_rd, con_hfus, thsfc_loc, & @@ -262,6 +262,7 @@ subroutine noahmpdrv_run & real(kind=kind_phys), dimension(:) , intent(in) :: snow_mp ! microphysics snow [mm] real(kind=kind_phys), dimension(:) , intent(in) :: graupel_mp ! microphysics graupel [mm] real(kind=kind_phys), dimension(:) , intent(in) :: ice_mp ! microphysics ice/hail [mm] + real(kind=kind_phys), dimension(:) , intent(in) :: rhonewsn1 ! precipitation ice density (kg/m^3) real(kind=kind_phys) , intent(in) :: con_hvap ! latent heat condensation [J/kg] real(kind=kind_phys) , intent(in) :: con_cp ! specific heat air [J/kg/K] real(kind=kind_phys) , intent(in) :: con_jcal ! joules per calorie (not used) @@ -757,7 +758,7 @@ subroutine noahmpdrv_run & call transfer_mp_parameters(vegetation_category, soil_category, & slope_category, soil_color_category, crop_type,parameters) - + parameters%prcpiceden = rhonewsn1(i) call noahmp_options(idveg ,iopt_crs, iopt_btr , iopt_run, iopt_sfc, & iopt_frz, iopt_inf , iopt_rad, iopt_alb, & iopt_snf, iopt_tbot, iopt_stc, iopt_rsf, & diff --git a/physics/noahmpdrv.meta b/physics/noahmpdrv.meta index 3235b7c90..82d72386f 100644 --- a/physics/noahmpdrv.meta +++ b/physics/noahmpdrv.meta @@ -532,6 +532,14 @@ type = real kind = kind_phys intent = in +[rhonewsn1] + standard_name = lwe_density_of_precip_ice + long_name = density of precipitation ice + units = kg m-3 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [con_hvap] standard_name = latent_heat_of_vaporization_of_water_at_0C long_name = latent heat of evaporation/sublimation diff --git a/physics/sflx.f b/physics/sflx.f index a020e217a..56a8cfd70 100644 --- a/physics/sflx.f +++ b/physics/sflx.f @@ -116,6 +116,7 @@ subroutine gfssflx &! --- input & swdn, swnet, lwdn, sfcems, sfcprs, sfctmp, & & sfcspd, prcp, q2, q2sat, dqsdt2, th2, ivegsrc, & & vegtyp, soiltyp, slopetyp, shdmin, alb, snoalb, & + & rhonewsn, vrbliceden_noah, & & bexpp, xlaip, & ! sfc-perts, mgehne & lheatstrg, &! --- input/outputs: & tbot, cmc, t1, stc, smc, sh2o, sneqv, ch, cm,z0, &! --- outputs: @@ -310,9 +311,9 @@ subroutine gfssflx &! --- input real (kind=kind_phys), intent(in) :: ffrozp, dt, zlvl, lwdn, & & sldpth(nsoil), swdn, swnet, sfcems, sfcprs, sfctmp, & & sfcspd, prcp, q2, q2sat, dqsdt2, th2, shdmin, alb, snoalb, & - & bexpp, xlaip & !sfc-perts, mgehne + & bexpp, xlaip, rhonewsn & !sfc-perts, mgehne - logical, intent(in) :: lheatstrg + logical, intent(in) :: lheatstrg, vrbliceden_noah ! --- input/outputs: real (kind=kind_phys), intent(inout) :: tbot, cmc, t1, sneqv, & @@ -564,7 +565,7 @@ subroutine gfssflx &! --- input !! using old and new snow. call snow_new ! --- inputs: ! -! ( sfctmp, sn_new, ! +! ( sfctmp, sn_new, rhonewsn, vrbliceden_noah, ! ! --- input/outputs: ! ! snowh, sndens ) ! @@ -877,7 +878,11 @@ subroutine gfssflx &! --- input ! smc, ssoil, runoff1, runoff2, runoff3, edir, ec, et, ! ! ett, snomlt, drip, dew, flx1, flx3, esnow ) ! +! run-total accumulated snow based on snowfall and snowmelt in [m] + endif + + !> - Noah LSM post-processing: !> - Calculate sensible heat (h) for return to parent model. @@ -2851,7 +2856,7 @@ end subroutine snopac subroutine snow_new !................................... ! --- inputs: -! & ( sfctmp, sn_new, & +! & ( sfctmp, sn_new, rhonewsn, vrbliceden_noah, & ! --- input/outputs: ! & snowh, sndens & ! & ) @@ -2900,10 +2905,14 @@ subroutine snow_new ! snowcovered and glacierized basin', 6th nordic hydrological ! conference, vemadolen, sweden, 1980, 172-177pp. - if (tempc <= -15.0) then - dsnew = 0.05 - else - dsnew = 0.05 + 0.0017*(tempc + 15.0)**1.5 + if(vrbliceden_noah == .false.) then + if (tempc <= -15.0) then + dsnew = 0.05 + else + dsnew = 0.05 + 0.0017*(tempc + 15.0)**1.5 + endif + elseif(vrbliceden_noah == .true.) then + dsnew = rhonewsn*0.001 endif ! --- ... adjustment of snow density depending on new snowfall From 33f4922398a896c9c69b4b9852a13d6febd86706 Mon Sep 17 00:00:00 2001 From: Eric Aligo Date: Fri, 9 Dec 2022 15:41:18 +0000 Subject: [PATCH 077/380] Fix typo --- physics/mp_thompson.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/mp_thompson.F90 b/physics/mp_thompson.F90 index aee97ef60..e62e8a596 100644 --- a/physics/mp_thompson.F90 +++ b/physics/mp_thompson.F90 @@ -705,7 +705,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, & ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & - fullradar_diag=fullradar_diag, astep=istep, nsteps=nsteps, & + fullradar_diag=fullradar_diag, istep=istep, nsteps=nsteps, & first_time_step=first_time_step, errmsg=errmsg, errflg=errflg, & ! Extended diagnostics ext_diag=ext_diag, & From f72f38b13992eb127a32bb5f18ca2a3ea7c5ebfd Mon Sep 17 00:00:00 2001 From: Eric Aligo Date: Mon, 12 Dec 2022 14:58:26 +0000 Subject: [PATCH 078/380] Rename winter wx diags --- physics/GFS_MP_generic_post.F90 | 26 +++++++++++++------------- physics/GFS_MP_generic_post.meta | 12 ++++++------ 2 files changed, 19 insertions(+), 19 deletions(-) diff --git a/physics/GFS_MP_generic_post.F90 b/physics/GFS_MP_generic_post.F90 index edfecf927..fd78a27b8 100644 --- a/physics/GFS_MP_generic_post.F90 +++ b/physics/GFS_MP_generic_post.F90 @@ -24,7 +24,7 @@ subroutine GFS_MP_generic_post_run( rain1, rann, xlat, xlon, gt0, gq0, prsl, prsi, phii, tsfc, ice, snow, graupel, save_t, save_q, rain0, ice0, snow0,& graupel0, del, rain, domr_diag, domzr_diag, domip_diag, doms_diag, tprcp, srflag, sr, cnvprcp, totprcp, totice, & totsnw, totgrp, cnvprcpb, totprcpb, toticeb, totsnwb, totgrpb, rain_cpl, rainc_cpl, snow_cpl, pwat, & - acfrzrn, acfrzrnb, acgraup, acgraupb, acsnow, acsnowb, rhonewsn1, vrbliceden_noah, iopt_snf, & + frzr, frzrb, frozr, frozrb, tsnowp, tsnowpb, rhonewsn1, vrbliceden_noah, iopt_snf, & drain_cpl, dsnow_cpl, lsm, lsm_ruc, lsm_noahmp, raincprv, rainncprv, iceprv, snowprv, & graupelprv, draincprv, drainncprv, diceprv, dsnowprv, dgraupelprv, dtp, dfi_radar_max_intervals, & dtend, dtidx, index_of_temperature, index_of_process_mp,ldiag3d, qdiag3d,dqdt_qmicro, lssav, num_dfi_radar, & @@ -82,12 +82,12 @@ subroutine GFS_MP_generic_post_run( real(kind=kind_phys), dimension(:), intent(inout) :: diceprv real(kind=kind_phys), dimension(:), intent(inout) :: dsnowprv real(kind=kind_phys), dimension(:), intent(inout) :: dgraupelprv - real(kind=kind_phys), dimension(:), intent(inout) :: acfrzrn - real(kind=kind_phys), dimension(:), intent(inout) :: acfrzrnb - real(kind=kind_phys), dimension(:), intent(inout) :: acgraup - real(kind=kind_phys), dimension(:), intent(inout) :: acgraupb - real(kind=kind_phys), dimension(:), intent(inout) :: acsnow - real(kind=kind_phys), dimension(:), intent(inout) :: acsnowb + real(kind=kind_phys), dimension(:), intent(inout) :: frzr + real(kind=kind_phys), dimension(:), intent(inout) :: frzrb + real(kind=kind_phys), dimension(:), intent(inout) :: frozr + real(kind=kind_phys), dimension(:), intent(inout) :: frozrb + real(kind=kind_phys), dimension(:), intent(inout) :: tsnowp + real(kind=kind_phys), dimension(:), intent(inout) :: tsnowpb real(kind=kind_phys), dimension(:), intent(inout) :: rhonewsn1 real(kind=kind_phys), dimension(:,:), intent(inout) :: dqdt_qmicro real(kind=kind_phys), dimension(:,:), intent(inout) :: prevsq @@ -128,13 +128,13 @@ subroutine GFS_MP_generic_post_run( do i = 1, im ! write(0,*)'freezing rain gt0(1),gt0(levs):',gt0(1,1),gt0(1,levs) if (gt0(i,1) .le. 273) then - acfrzrn(i) = acfrzrn(i) + rain0(i) - acfrzrnb(i) = acfrzrnb(i) + rain0(i) + frzr(i) = frzr(i) + rain0(i) + frzrb(i) = frzrb(i) + rain0(i) endif - acsnow(i) = acsnow(i) + snow0(i) - acsnowb(i) = acsnowb(i) + snow0(i) - acgraup(i) = acgraup(i) + graupel0(i) - acgraupb(i) = acgraupb(i) + graupel0(i) + tsnowp(i) = tsnowp(i) + snow0(i) + tsnowpb(i) = tsnowpb(i) + snow0(i) + frozr(i) = frozr(i) + graupel0(i) + frozrb(i) = frozrb(i) + graupel0(i) enddo !Compute the variable precip ice density for specific LSM schemes and options ! if ( lsm .ne. 2 .or. iopt_snf .ne. 5) then diff --git a/physics/GFS_MP_generic_post.meta b/physics/GFS_MP_generic_post.meta index 46dfe66d6..6b2fb5392 100644 --- a/physics/GFS_MP_generic_post.meta +++ b/physics/GFS_MP_generic_post.meta @@ -278,7 +278,7 @@ type = real kind = kind_phys intent = inout -[acfrzrn] +[frzr] standard_name = lwe_thickness_of_sfc_freezing_rain_amount long_name = accumulated surface freezing rain units = m @@ -286,7 +286,7 @@ type = real kind = kind_phys intent = inout -[acfrzrnb] +[frzrb] standard_name = lwe_thickness_of_sfc_freezing_rain_amount_in_bucket long_name = accumulated surface freezing rain in bucket units = m @@ -294,7 +294,7 @@ type = real kind = kind_phys intent = inout -[acgraup] +[frozr] standard_name = lwe_thickness_of_sfc_graupel_amount long_name = accumulated surface graupel units = m @@ -302,7 +302,7 @@ type = real kind = kind_phys intent = inout -[acgraupb] +[frozrb] standard_name = lwe_thickness_of_sfc_graupel_amount_in_bucket long_name = accumulated surface graupel in bucket units = m @@ -310,7 +310,7 @@ type = real kind = kind_phys intent = inout -[acsnow] +[tsnowp] standard_name = lwe_thickness_of_sfc_snow_amount long_name = accumulated surface snow units = m @@ -318,7 +318,7 @@ type = real kind = kind_phys intent = inout -[acsnowb] +[tsnowpb] standard_name = lwe_thickness_of_sfc_snow_amount_in_bucket long_name = accumulated surface snow in bucket units = m From 634ebb1a46238198b32ef98b8aaefe6ce9843bf3 Mon Sep 17 00:00:00 2001 From: drnimbusrain Date: Mon, 12 Dec 2022 10:41:44 -0500 Subject: [PATCH 079/380] Added canopy height grid cell conidtion. --- physics/satmedmfvdifq.F | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index ba6bd9cdf..dd17adcfe 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -1215,8 +1215,10 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & !PCC_CANOPY------------------------------------ do k = 1, 1km1 do i=1,im + FCH = canheight(i) !Input canopy height for grid cell i IF (k .EQ. 1) THEN !first model layer ! Check for Contiguous Canopy Grid Cells + IF ( FCH .LT. 10.0 ! IF ( LAI .LT. 0.1 ! & .OR. FCH .LT. 0.5 ! & .OR. FCH .LT. 10.0 @@ -1224,15 +1226,14 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & ! & .OR. POPU .GT. 10000.0 ! & .OR. EXP(-0.5*LAI*CLU).GT. 0.45 ! & .AND. FCH .LT. 18.0 ) THEN !not a contigous canopy cell -! dkt(i,k)= dkt(i,k) -! dkq(i,k)= dkq(i,k) -! ELSE ! There is a contiguous forest canopy, + dkt(i,k)= dkt(i,k) + dkq(i,k)= dkq(i,k) + ELSE ! There is a contiguous forest canopy, ! apply correction over canopy layers !Raupauch M. R. A Practical Lagrangian method for relating scalar !concentrations to ! source distributions in vegetation canopies. Q. J. R. Meteor. Soc. ! (1989), 115, pp 609-632 - FCH = canheight(i) !Input canopy height for grid cell i MOL = zol(i)/zl(i,k) !Monin-Obukhov Length HOL = FCH/MOL !local canopy stability parameter (hc/MOL) ZCAN = zl(i,k) ! Initialize canopy top (m) = First model layer height above canopy @@ -1296,7 +1297,7 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & EDDYVEST_INT = IntegrateTrapezoid((ZCANX(COUNTCAN:1:-1)/FCH),EDDYVESTX(COUNTCAN:1:-1)) dkt(i,k)= (dkt(i,k)/EDDYVEST1) * EDDYVEST_INT !Scale dkt to resolved eddy diffusivity dkq(i,k)= (dkq(i,k)/EDDYVEST1) * EDDYVEST_INT !Scale dku to resolved eddy diffusivity -! END IF !contigous canopy conditions + END IF !contigous canopy conditions END IF ! first model layer scaled canopy enddo !i enddo !k From d083f87f42f0adafbd37add81b79440e3e166ed7 Mon Sep 17 00:00:00 2001 From: dustinswales Date: Mon, 19 Dec 2022 17:12:20 -0700 Subject: [PATCH 080/380] Bugfox in argument list --- physics/radiation_clouds.f | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index 07ef01a1a..81a845fd2 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -723,7 +723,7 @@ subroutine radiation_clouds_prop & call progcld_thompson_wsm6 (plyr,plvl,tlyr,qlyr,qstl, & ! --- inputs & rhly,tracer1,xlat,xlon,slmsk,dz,delp, & & ntrac-1, ntcw-1,ntiw-1,ntrw-1, & - & ntsw-1,ntgl-1, & + & ntsw-1,ntgl-1,con_ttp, & & IX, NLAY, NLP1, uni_cld, lmfshal, lmfdeep2, & & cldcov(:,1:NLAY), cnvw, effrl_inout, & & effri_inout, effrs_inout, & @@ -796,7 +796,7 @@ subroutine radiation_clouds_prop & call progcld_thompson_wsm6 (plyr,plvl,tlyr,qlyr,qstl, & ! --- inputs & rhly,tracer1,xlat,xlon,slmsk,dz,delp, & & ntrac-1, ntcw-1,ntiw-1,ntrw-1, & - & ntsw-1,ntgl-1, & + & ntsw-1,ntgl-1,con_ttp, & & IX, NLAY, NLP1, uni_cld, lmfshal, lmfdeep2, & & cldcov(:,1:NLAY), cnvw, effrl, effri, effrs, & & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & @@ -1958,7 +1958,7 @@ end subroutine progcld_fer_hires subroutine progcld_thompson_wsm6 & & ( plyr,plvl,tlyr,qlyr,qstl,rhly,clw, & ! --- inputs: & xlat,xlon,slmsk,dz,delp, & - & ntrac,ntcw,ntiw,ntrw,ntsw,ntgl, & + & ntrac,ntcw,ntiw,ntrw,ntsw,ntgl,con_ttp, & & IX, NLAY, NLP1, & & uni_cld, lmfshal, lmfdeep2, cldcov, cnvw, & & re_cloud,re_ice,re_snow, & @@ -2058,7 +2058,7 @@ subroutine progcld_thompson_wsm6 & real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & & slmsk - + real (kind=kind_phys), intent(in) :: con_ttp ! --- inputs/outputs real (kind=kind_phys), dimension(:,:), intent(inout) :: & From ae748c93ebf0807a50af29225da87f95b8493620 Mon Sep 17 00:00:00 2001 From: Helin Wei Date: Fri, 30 Dec 2022 12:38:13 -0500 Subject: [PATCH 081/380] fixed inout in meta files --- physics/GFS_phys_time_vary.fv3.meta | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/GFS_phys_time_vary.fv3.meta b/physics/GFS_phys_time_vary.fv3.meta index 202ef9853..a1fdd5c49 100644 --- a/physics/GFS_phys_time_vary.fv3.meta +++ b/physics/GFS_phys_time_vary.fv3.meta @@ -1718,7 +1718,7 @@ units = index dimensions = (horizontal_dimension) type = integer - intent = in + intent = inout [shdmin] standard_name = min_vegetation_area_fraction long_name = min fractional coverage of green vegetation From 560f998871340120ab302c4be534a9169597e724 Mon Sep 17 00:00:00 2001 From: Eric Aligo Date: Thu, 5 Jan 2023 20:25:02 +0000 Subject: [PATCH 082/380] minor touchups --- physics/GFS_MP_generic_post.F90 | 15 ++++----------- physics/lsm_noah.f | 1 - physics/module_sf_ruclsm.F90 | 12 ++++++------ physics/sflx.f | 4 ++-- 4 files changed, 12 insertions(+), 20 deletions(-) diff --git a/physics/GFS_MP_generic_post.F90 b/physics/GFS_MP_generic_post.F90 index fd78a27b8..6ed96e764 100644 --- a/physics/GFS_MP_generic_post.F90 +++ b/physics/GFS_MP_generic_post.F90 @@ -20,11 +20,11 @@ module GFS_MP_generic_post !> @{ subroutine GFS_MP_generic_post_run( & im, levs, kdt, nrcm, nncl, ntcw, ntrac, imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_nssl, & - imp_physics_mg, imp_physics_fer_hires, cal_pre, cplflx, cplchm, cpllnd, progsigma, con_g, rainmin, dtf, frain, rainc, & + imp_physics_mg, imp_physics_fer_hires, cal_pre, cplflx, cplchm, cpllnd, progsigma, con_g, rainmin, dtf, frain, rainc, & rain1, rann, xlat, xlon, gt0, gq0, prsl, prsi, phii, tsfc, ice, snow, graupel, save_t, save_q, rain0, ice0, snow0,& graupel0, del, rain, domr_diag, domzr_diag, domip_diag, doms_diag, tprcp, srflag, sr, cnvprcp, totprcp, totice, & totsnw, totgrp, cnvprcpb, totprcpb, toticeb, totsnwb, totgrpb, rain_cpl, rainc_cpl, snow_cpl, pwat, & - frzr, frzrb, frozr, frozrb, tsnowp, tsnowpb, rhonewsn1, vrbliceden_noah, iopt_snf, & + frzr, frzrb, frozr, frozrb, tsnowp, tsnowpb, rhonewsn1, vrbliceden_noah, iopt_snf, & drain_cpl, dsnow_cpl, lsm, lsm_ruc, lsm_noahmp, raincprv, rainncprv, iceprv, snowprv, & graupelprv, draincprv, drainncprv, diceprv, dsnowprv, dgraupelprv, dtp, dfi_radar_max_intervals, & dtend, dtidx, index_of_temperature, index_of_process_mp,ldiag3d, qdiag3d,dqdt_qmicro, lssav, num_dfi_radar, & @@ -109,7 +109,7 @@ subroutine GFS_MP_generic_post_run( real(kind=kind_phys) :: crain, csnow, onebg, tem, total_precip, tem1, tem2, ttend real(kind=kind_phys), dimension(im) :: domr, domzr, domip, doms, t850, work1 - real :: snowrat,grauprat,icerat,curat,prcpncfr,prcpcufr + real :: snowrat,grauprat,icerat,curat,prcpncfr,prcpcufr real :: rhonewsnow,rhoprcpice,rhonewgr,rhonewice real(kind=kind_phys), parameter :: rhowater = 1000.0_kind_phys @@ -123,10 +123,9 @@ subroutine GFS_MP_generic_post_run( rain(i) = rainc(i) + frain * rain1(i) ! time-step convective plus explicit enddo -!aligo compute surface snowfall, graupel/sleet, freezing rain and precip ice density +! compute surface snowfall, graupel/sleet, freezing rain and precip ice density if (imp_physics == imp_physics_gfdl .or. imp_physics == imp_physics_thompson .or. imp_physics == imp_physics_nssl ) then do i = 1, im -! write(0,*)'freezing rain gt0(1),gt0(levs):',gt0(1,1),gt0(1,levs) if (gt0(i,1) .le. 273) then frzr(i) = frzr(i) + rain0(i) frzrb(i) = frzrb(i) + rain0(i) @@ -137,11 +136,7 @@ subroutine GFS_MP_generic_post_run( frozrb(i) = frozrb(i) + graupel0(i) enddo !Compute the variable precip ice density for specific LSM schemes and options -! if ( lsm .ne. 2 .or. iopt_snf .ne. 5) then -! write(0,*)'aligo,lsm,iopt_snf :',lsm,iopt_snf -! endif if ( lsm == lsm_ruc .or. lsm == lsm_noahmp .and. iopt_snf == 5 .or. vrbliceden_noah == .true.) then -! write(0,*)'lsm,iopt_snf,vrbliceden_noah: ',lsm,iopt_snf,vrbliceden_noah snowrat = 0. grauprat = 0. icerat = 0. @@ -178,13 +173,11 @@ subroutine GFS_MP_generic_post_run( rhonewsnow=min(125.,1000.0/max(8.,(17.*tanh((276.65-gt0(i,1))*0.15)))) rhonewgr=min(500.,rhowater/max(2.,(3.5*tanh((274.15-gt0(i,1))*0.3333)))) rhonewice=rhonewsnow - !--- compute density of "precip ice" from weighted contribution ! of snow, graupel and ice fractions rhoprcpice = min(500.,max(58.8,(rhonewsnow*snowrat + & rhonewgr*grauprat + rhonewice*icerat + rhonewgr*curat))) - ! from now on rhonewsn1 is the density of falling frozen precipitation rhonewsn1(i)=rhoprcpice endif diff --git a/physics/lsm_noah.f b/physics/lsm_noah.f index bc12aa64e..3e66c86fb 100644 --- a/physics/lsm_noah.f +++ b/physics/lsm_noah.f @@ -327,7 +327,6 @@ subroutine lsm_noah_run & errflg = 0 !> - Save land-related prognostic fields for guess run. -!aligo do i = 1, im if (land(i) .and. flag_guess(i)) then weasd_old(i) = weasd(i) diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 6c417d6fd..73fe23c0d 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -1492,19 +1492,19 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia !--- 27 Feb 2014 - empirical formulations from John M. Brown ! rhonewsn=min(250.,rhowater/max(4.179,(13.*tanh((274.15-Tabs)*0.3333)))) !--- 13 Mar 2018 - formulation from Trevor Elcott -!aligo rhonewsn=min(125.,1000.0/max(8.,(17.*tanh((276.65-Tabs)*0.15)))) -!aligo rhonewgr=min(500.,rhowater/max(2.,(3.5*tanh((274.15-Tabs)*0.3333)))) -!aligo rhonewice=rhonewsn +! rhonewsn=min(125.,1000.0/max(8.,(17.*tanh((276.65-Tabs)*0.15)))) +! rhonewgr=min(500.,rhowater/max(2.,(3.5*tanh((274.15-Tabs)*0.3333)))) +! rhonewice=rhonewsn !--- compute density of "snowfall" from weighted contribution ! of snow, graupel and ice fractions -!aligo rhosnfall = min(500.,max(58.8,(rhonewsn*snowrat + & +! rhosnfall = min(500.,max(58.8,(rhonewsn*snowrat + & !13mar18 rhosnfall = min(500.,max(76.9,(rhonewsn*snowrat + & -!aligo rhonewgr*grauprat + rhonewice*icerat + rhonewgr*curat))) +! rhonewgr*grauprat + rhonewice*icerat + rhonewgr*curat))) ! from now on rhonewsn is the density of falling frozen precipitation -!aligo rhonewsn=rhosnfall +! rhonewsn=rhosnfall !*** Define average snow density of the snow pack considering !*** the amount of fresh snow (eq. 9 in Koren et al.(1999) diff --git a/physics/sflx.f b/physics/sflx.f index 56a8cfd70..ae302be1c 100644 --- a/physics/sflx.f +++ b/physics/sflx.f @@ -2905,13 +2905,13 @@ subroutine snow_new ! snowcovered and glacierized basin', 6th nordic hydrological ! conference, vemadolen, sweden, 1980, 172-177pp. - if(vrbliceden_noah == .false.) then + if(.not. vrbliceden_noah) then if (tempc <= -15.0) then dsnew = 0.05 else dsnew = 0.05 + 0.0017*(tempc + 15.0)**1.5 endif - elseif(vrbliceden_noah == .true.) then + else dsnew = rhonewsn*0.001 endif From 2f3d69a121aca341aa6e9b8cabac8eb8892c7541 Mon Sep 17 00:00:00 2001 From: Eric Aligo Date: Thu, 5 Jan 2023 21:18:24 +0000 Subject: [PATCH 083/380] removed commented out lines related to old computation of precip ice density --- physics/module_sf_ruclsm.F90 | 6 ------ 1 file changed, 6 deletions(-) diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 73fe23c0d..a0280e500 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -1492,19 +1492,13 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia !--- 27 Feb 2014 - empirical formulations from John M. Brown ! rhonewsn=min(250.,rhowater/max(4.179,(13.*tanh((274.15-Tabs)*0.3333)))) !--- 13 Mar 2018 - formulation from Trevor Elcott -! rhonewsn=min(125.,1000.0/max(8.,(17.*tanh((276.65-Tabs)*0.15)))) -! rhonewgr=min(500.,rhowater/max(2.,(3.5*tanh((274.15-Tabs)*0.3333)))) -! rhonewice=rhonewsn !--- compute density of "snowfall" from weighted contribution ! of snow, graupel and ice fractions -! rhosnfall = min(500.,max(58.8,(rhonewsn*snowrat + & !13mar18 rhosnfall = min(500.,max(76.9,(rhonewsn*snowrat + & -! rhonewgr*grauprat + rhonewice*icerat + rhonewgr*curat))) ! from now on rhonewsn is the density of falling frozen precipitation -! rhonewsn=rhosnfall !*** Define average snow density of the snow pack considering !*** the amount of fresh snow (eq. 9 in Koren et al.(1999) From 5eaa95f9beec430046babcf17f11d6e260315e30 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Wed, 11 Jan 2023 12:04:01 -0700 Subject: [PATCH 084/380] remove unused frozen precip density in RUC; update many CCPP standard names --- physics/GFS_MP_generic_post.F90 | 15 +++++++-------- physics/GFS_MP_generic_post.meta | 24 ++++++++++++++++-------- physics/lsm_noah.meta | 4 ++-- physics/lsm_ruc.F90 | 12 +++++------- physics/lsm_ruc.meta | 10 +--------- physics/module_sf_ruclsm.F90 | 14 +++----------- physics/mp_thompson.meta | 2 +- physics/noahmpdrv.meta | 2 +- 8 files changed, 36 insertions(+), 47 deletions(-) diff --git a/physics/GFS_MP_generic_post.F90 b/physics/GFS_MP_generic_post.F90 index 6ed96e764..d9d205720 100644 --- a/physics/GFS_MP_generic_post.F90 +++ b/physics/GFS_MP_generic_post.F90 @@ -20,11 +20,11 @@ module GFS_MP_generic_post !> @{ subroutine GFS_MP_generic_post_run( & im, levs, kdt, nrcm, nncl, ntcw, ntrac, imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_nssl, & - imp_physics_mg, imp_physics_fer_hires, cal_pre, cplflx, cplchm, cpllnd, progsigma, con_g, rainmin, dtf, frain, rainc, & - rain1, rann, xlat, xlon, gt0, gq0, prsl, prsi, phii, tsfc, ice, snow, graupel, save_t, save_q, rain0, ice0, snow0,& - graupel0, del, rain, domr_diag, domzr_diag, domip_diag, doms_diag, tprcp, srflag, sr, cnvprcp, totprcp, totice, & - totsnw, totgrp, cnvprcpb, totprcpb, toticeb, totsnwb, totgrpb, rain_cpl, rainc_cpl, snow_cpl, pwat, & - frzr, frzrb, frozr, frozrb, tsnowp, tsnowpb, rhonewsn1, vrbliceden_noah, iopt_snf, & + imp_physics_mg, imp_physics_fer_hires, cal_pre, cplflx, cplchm, cpllnd, progsigma, con_g, rhowater, rainmin, dtf, & + frain, rainc, rain1, rann, xlat, xlon, gt0, gq0, prsl, prsi, phii, tsfc, ice, snow, graupel, save_t, save_q, & + rain0, ice0, snow0, graupel0, del, rain, domr_diag, domzr_diag, domip_diag, doms_diag, tprcp, srflag, sr, cnvprcp,& + totprcp, totice, totsnw, totgrp, cnvprcpb, totprcpb, toticeb, totsnwb, totgrpb, rain_cpl, rainc_cpl, snow_cpl, & + pwat, frzr, frzrb, frozr, frozrb, tsnowp, tsnowpb, rhonewsn1, vrbliceden_noah, iopt_snf, & drain_cpl, dsnow_cpl, lsm, lsm_ruc, lsm_noahmp, raincprv, rainncprv, iceprv, snowprv, & graupelprv, draincprv, drainncprv, diceprv, dsnowprv, dgraupelprv, dtp, dfi_radar_max_intervals, & dtend, dtidx, index_of_temperature, index_of_process_mp,ldiag3d, qdiag3d,dqdt_qmicro, lssav, num_dfi_radar, & @@ -47,7 +47,7 @@ subroutine GFS_MP_generic_post_run( integer :: ix_dfi_radar(:) real(kind=kind_phys), dimension(:,:), intent(inout) :: gt0 - real(kind=kind_phys), intent(in) :: dtf, frain, con_g, rainmin + real(kind=kind_phys), intent(in) :: dtf, frain, con_g, rainmin, rhowater real(kind=kind_phys), dimension(:), intent(in) :: rain1, xlat, xlon, tsfc real(kind=kind_phys), dimension(:), intent(inout) :: ice, snow, graupel, rainc real(kind=kind_phys), dimension(:), intent(in) :: rain0, ice0, snow0, graupel0 @@ -111,7 +111,6 @@ subroutine GFS_MP_generic_post_run( real :: snowrat,grauprat,icerat,curat,prcpncfr,prcpcufr real :: rhonewsnow,rhoprcpice,rhonewgr,rhonewice - real(kind=kind_phys), parameter :: rhowater = 1000.0_kind_phys ! Initialize CCPP error handling variables errmsg = '' @@ -136,7 +135,7 @@ subroutine GFS_MP_generic_post_run( frozrb(i) = frozrb(i) + graupel0(i) enddo !Compute the variable precip ice density for specific LSM schemes and options - if ( lsm == lsm_ruc .or. lsm == lsm_noahmp .and. iopt_snf == 5 .or. vrbliceden_noah == .true.) then + if ( lsm == lsm_ruc .or. (lsm == lsm_noahmp .and. iopt_snf == 5) .or. vrbliceden_noah == .true.) then snowrat = 0. grauprat = 0. icerat = 0. diff --git a/physics/GFS_MP_generic_post.meta b/physics/GFS_MP_generic_post.meta index 6b2fb5392..107b528a2 100644 --- a/physics/GFS_MP_generic_post.meta +++ b/physics/GFS_MP_generic_post.meta @@ -150,6 +150,14 @@ type = real kind = kind_phys intent = in +[rhowater] + standard_name = fresh_liquid_water_density_at_0c + long_name = density of liquid water + units = kg m-3 + dimensions = () + type = real + kind = kind_phys + intent = in [dtf] standard_name = timestep_for_dynamics long_name = dynamics timestep @@ -279,7 +287,7 @@ kind = kind_phys intent = inout [frzr] - standard_name = lwe_thickness_of_sfc_freezing_rain_amount + standard_name = lwe_thickness_of_surface_freezing_rain_amount long_name = accumulated surface freezing rain units = m dimensions = (horizontal_loop_extent) @@ -287,7 +295,7 @@ kind = kind_phys intent = inout [frzrb] - standard_name = lwe_thickness_of_sfc_freezing_rain_amount_in_bucket + standard_name = lwe_thickness_of_surface_freezing_rain_amount_in_bucket long_name = accumulated surface freezing rain in bucket units = m dimensions = (horizontal_loop_extent) @@ -295,7 +303,7 @@ kind = kind_phys intent = inout [frozr] - standard_name = lwe_thickness_of_sfc_graupel_amount + standard_name = lwe_thickness_of_surface_graupel_amount long_name = accumulated surface graupel units = m dimensions = (horizontal_loop_extent) @@ -303,7 +311,7 @@ kind = kind_phys intent = inout [frozrb] - standard_name = lwe_thickness_of_sfc_graupel_amount_in_bucket + standard_name = lwe_thickness_of_surface_graupel_amount_in_bucket long_name = accumulated surface graupel in bucket units = m dimensions = (horizontal_loop_extent) @@ -311,7 +319,7 @@ kind = kind_phys intent = inout [tsnowp] - standard_name = lwe_thickness_of_sfc_snow_amount + standard_name = lwe_thickness_of_surface_snow_amount long_name = accumulated surface snow units = m dimensions = (horizontal_loop_extent) @@ -319,7 +327,7 @@ kind = kind_phys intent = inout [tsnowpb] - standard_name = lwe_thickness_of_sfc_snow_amount_in_bucket + standard_name = lwe_thickness_of_surface_snow_amount_in_bucket long_name = accumulated surface snow in bucket units = m dimensions = (horizontal_loop_extent) @@ -327,7 +335,7 @@ kind = kind_phys intent = inout [rhonewsn1] - standard_name = lwe_density_of_precip_ice + standard_name = surface_frozen_precipitation_density long_name = density of precipitation ice units = kg m-3 dimensions = (horizontal_loop_extent) @@ -335,7 +343,7 @@ kind = kind_phys intent = inout [vrbliceden_noah] - standard_name = flag_for_vrbl_prcp_ice_den + standard_name = do_variable_surface_frozen_precipitation_density long_name = flag for variable precip ice density units = flag dimensions = () diff --git a/physics/lsm_noah.meta b/physics/lsm_noah.meta index 2235dda88..9c93586da 100644 --- a/physics/lsm_noah.meta +++ b/physics/lsm_noah.meta @@ -487,7 +487,7 @@ kind = kind_phys intent = in [rhonewsn1] - standard_name = lwe_density_of_precip_ice + standard_name = surface_frozen_precipitation_density long_name = density of precipitation ice units = kg m-3 dimensions = (horizontal_loop_extent) @@ -495,7 +495,7 @@ kind = kind_phys intent = in [vrbliceden_noah] - standard_name = flag_for_vrbl_prcp_ice_den + standard_name = do_variable_surface_frozen_precipitation_density long_name = flag for variable precip ice density units = flag dimensions = () diff --git a/physics/lsm_ruc.F90 b/physics/lsm_ruc.F90 index 6aae4feac..3cf12eb29 100644 --- a/physics/lsm_ruc.F90 +++ b/physics/lsm_ruc.F90 @@ -355,7 +355,7 @@ subroutine lsm_ruc_run & ! inputs & cm_ice, ch_ice, snowfallac_ice, & & albdvis_ice, albdnir_ice, albivis_ice, albinir_ice, & ! --- out - & rhosnf, sbsno, & + & sbsno, & & cmm_lnd, chh_lnd, cmm_ice, chh_ice, & ! & flag_iter, flag_guess, flag_init, lsm_cold_start, & @@ -426,7 +426,7 @@ subroutine lsm_ruc_run & ! inputs ! --- output: real (kind=kind_phys), dimension(:), intent(inout) :: & - & rhosnf, runof, drain, runoff, srunoff, evbs, evcw, & + & runof, drain, runoff, srunoff, evbs, evcw, & & stm, wetness, semisbase, semis_lnd, semis_ice, & & sfalb_lnd, sfalb_ice, & ! for land @@ -492,7 +492,7 @@ subroutine lsm_ruc_run & ! inputs & sneqv_lnd, snoalb1d_lnd, snowh_lnd, snoh_lnd, tsnav_lnd, & & snomlt_lnd, sncovr_lnd, soilw, soilm, ssoil_lnd, & & soilt_lnd, tbot, & - & xlai, swdn, z0_lnd, znt_lnd, rhosnfr, infiltr, & + & xlai, swdn, z0_lnd, znt_lnd, infiltr, & & precipfr, snfallac_lnd, acsn, & & qsfc_lnd, qsg_lnd, qvg_lnd, qcg_lnd, soilt1_lnd, chklowq, & & rhonewsn @@ -747,7 +747,6 @@ subroutine lsm_ruc_run & ! inputs acrunoff(i,j) = 0.0 snfallac_lnd(i,j) = 0.0 snfallac_ice(i,j) = 0.0 - rhosnfr(i,j) = 0.0 precipfr(i,j) = 0.0 endif @@ -1122,7 +1121,7 @@ subroutine lsm_ruc_run & ! inputs & zs, prcp(i,j), sneqv_lnd(i,j), snowh_lnd(i,j), & & sncovr_lnd(i,j), & & ffrozp(i,j), frpcpn, & - & rhosnfr(i,j), precipfr(i,j), & + & precipfr(i,j), & ! --- inputs: & conflx2(i,1,j), sfcprs(i,1,j), sfctmp(i,1,j), q2(i,1,j), & & qcatm(i,1,j), rho2(i,1,j), semis_bck(i,j), lwdn(i,j), & @@ -1246,7 +1245,6 @@ subroutine lsm_ruc_run & ! inputs sfcqv_lnd(i) = qvg_lnd(i,j) sfcqc_lnd(i) = qcg_lnd(i,j) ! --- ... units [m/s] = [g m-2 s-1] - rhosnf(i) = rhosnfr(i,j) !acsnow(i) = acsn(i,j) ! kg m-2 ! --- ... accumulated total runoff and surface runoff @@ -1396,7 +1394,7 @@ subroutine lsm_ruc_run & ! inputs & zs, prcp(i,j), sneqv_ice(i,j), snowh_ice(i,j), & & sncovr_ice(i,j), & & ffrozp(i,j), frpcpn, & - & rhosnfr(i,j), precipfr(i,j), & + & precipfr(i,j), & ! --- inputs: & conflx2(i,1,j), sfcprs(i,1,j), sfctmp(i,1,j), q2(i,1,j), & & qcatm(i,1,j), rho2(i,1,j), semis_bck(i,j), lwdn(i,j), & diff --git a/physics/lsm_ruc.meta b/physics/lsm_ruc.meta index 3fe40f419..28a3545c9 100644 --- a/physics/lsm_ruc.meta +++ b/physics/lsm_ruc.meta @@ -953,7 +953,7 @@ kind = kind_phys intent = in [rhonewsn1] - standard_name = lwe_density_of_precip_ice + standard_name = surface_frozen_precipitation_density long_name = density of precipitation ice units = kg m-3 dimensions = (horizontal_loop_extent) @@ -1512,14 +1512,6 @@ type = real kind = kind_phys intent = out -[rhosnf] - standard_name = frozen_precipitation_density - long_name = density of frozen precipitation - units = kg m-3 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout [sbsno] standard_name = snow_deposition_sublimation_upward_latent_heat_flux long_name = latent heat flux from snow depo/subl diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index a0280e500..857408979 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -54,7 +54,7 @@ SUBROUTINE LSMRUC( & DT,init,lsm_cold_start,KTAU,iter,NSL, & graupelncv,snowncv,rainncv,raincv, & ZS,RAINBL,SNOW,SNOWH,SNOWC,FRZFRAC,frpcpn, & - rhosnf,precipfr, & + precipfr, & Z3D,P8W,T3D,QV3D,QC3D,RHO3D,EMISBCK, & GLW,GSWdn,GSW,EMISS,CHKLOWQ, CHS, & FLQC,FLHC,rhonewsn,MAVAIL,CANWAT,VEGFRA,ALB, & @@ -296,14 +296,12 @@ SUBROUTINE LSMRUC( & SMFR3D REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: & - RHOSNF, & !RHO of snowfall PRECIPFR, & ! time-step frozen precip SNOWFALLAC !--- soil/snow properties REAL & :: RHOCS, & RHOSN, & - RHOSNFALL, & BCLH, & DQM, & KSAT, & @@ -457,7 +455,6 @@ SUBROUTINE LSMRUC( & ACSNOW(i,j) = 0. SNOWFALLAC(i,j) = 0. PRECIPFR(i,j) = 0. - RHOSNF(i,j) = -1.e3 ! non-zero flag SNFLX(i,j) = 0. DEW (i,j) = 0. PC (i,j) = 0. @@ -622,7 +619,6 @@ SUBROUTINE LSMRUC( & CANWATR=CANWAT(I,J)*1.E-3 SNOWFRAC=SNOWC(I,J) - RHOSNFALL=RHOSNF(I,J) snowold(i,j)=snwe !----- @@ -894,7 +890,7 @@ SUBROUTINE LSMRUC( & nzs,nddzs,nroot,meltfactor, & !added meltfactor iland,isoil,ivgtyp(i,j),isltyp(i,j), & PRCPMS, NEWSNMS,SNWE,SNHEI,SNOWFRAC, & - RHOSN,RHONEWSN(I,J),RHOSNFALL, & + RHOSN,RHONEWSN(I,J), & snowrat,grauprat,icerat,curat, & PATM,TABS,QVATM,QCATM,RHO, & GLW(I,J),GSWdn(i,j),GSW(I,J), & @@ -1073,9 +1069,6 @@ SUBROUTINE LSMRUC( & SNOWC(I,J)=SNOWFRAC -!--- RHOSNF - density of snowfall - RHOSNF(I,J)=RHOSNFALL - ! Accumulated moisture flux [kg/m^2] SFCEVP (I,J) = SFCEVP (I,J) + QFX (I,J) * DT @@ -1161,7 +1154,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia nzs,nddzs,nroot,meltfactor, & ILAND,ISOIL,IVGTYP,ISLTYP,PRCPMS, & NEWSNMS,SNWE,SNHEI,SNOWFRAC, & - RHOSN,RHONEWSN,RHOSNFALL, & + RHOSN,RHONEWSN, & snowrat,grauprat,icerat,curat, & PATM,TABS,QVATM,QCATM,rho, & GLW,GSWdn,GSW,EMISS,EMISBCK,QKMS,TKMS,PC, & @@ -1281,7 +1274,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia EVAPL, & INFILTR, & RHOSN, & - rhosnfall, & snowrat, & grauprat, & icerat, & diff --git a/physics/mp_thompson.meta b/physics/mp_thompson.meta index 744405c03..691698281 100644 --- a/physics/mp_thompson.meta +++ b/physics/mp_thompson.meta @@ -611,7 +611,7 @@ kind = kind_phys intent = out [fullradar_diag] - standard_name = flag_for_computing_full_radar_reflectivity + standard_name = do_full_radar_reflectivity long_name = flag for computing full radar reflectivity units = flag dimensions = () diff --git a/physics/noahmpdrv.meta b/physics/noahmpdrv.meta index 82d72386f..b8c4a8307 100644 --- a/physics/noahmpdrv.meta +++ b/physics/noahmpdrv.meta @@ -533,7 +533,7 @@ kind = kind_phys intent = in [rhonewsn1] - standard_name = lwe_density_of_precip_ice + standard_name = surface_frozen_precipitation_density long_name = density of precipitation ice units = kg m-3 dimensions = (horizontal_loop_extent) From 8abbcba7b74856e0adf62650af9a4e5806c709b3 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Wed, 11 Jan 2023 17:45:15 -0700 Subject: [PATCH 085/380] address standard name clash for lwe of surface snow --- physics/GFS_MP_generic_post.meta | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/physics/GFS_MP_generic_post.meta b/physics/GFS_MP_generic_post.meta index 107b528a2..c71b61ed0 100644 --- a/physics/GFS_MP_generic_post.meta +++ b/physics/GFS_MP_generic_post.meta @@ -287,7 +287,7 @@ kind = kind_phys intent = inout [frzr] - standard_name = lwe_thickness_of_surface_freezing_rain_amount + standard_name = cumulative_lwe_thickness_of_surface_freezing_rain_amount long_name = accumulated surface freezing rain units = m dimensions = (horizontal_loop_extent) @@ -295,7 +295,7 @@ kind = kind_phys intent = inout [frzrb] - standard_name = lwe_thickness_of_surface_freezing_rain_amount_in_bucket + standard_name = cumulative_lwe_thickness_of_surface_freezing_rain_amount_in_bucket long_name = accumulated surface freezing rain in bucket units = m dimensions = (horizontal_loop_extent) @@ -303,7 +303,7 @@ kind = kind_phys intent = inout [frozr] - standard_name = lwe_thickness_of_surface_graupel_amount + standard_name = cumulative_lwe_thickness_of_surface_graupel_amount long_name = accumulated surface graupel units = m dimensions = (horizontal_loop_extent) @@ -311,7 +311,7 @@ kind = kind_phys intent = inout [frozrb] - standard_name = lwe_thickness_of_surface_graupel_amount_in_bucket + standard_name = cumulative_lwe_thickness_of_surface_graupel_amount_in_bucket long_name = accumulated surface graupel in bucket units = m dimensions = (horizontal_loop_extent) @@ -319,7 +319,7 @@ kind = kind_phys intent = inout [tsnowp] - standard_name = lwe_thickness_of_surface_snow_amount + standard_name = cumulative_lwe_thickness_of_surface_snow_amount long_name = accumulated surface snow units = m dimensions = (horizontal_loop_extent) @@ -327,7 +327,7 @@ kind = kind_phys intent = inout [tsnowpb] - standard_name = lwe_thickness_of_surface_snow_amount_in_bucket + standard_name = cumulative_lwe_thickness_of_surface_snow_amount_in_bucket long_name = accumulated surface snow in bucket units = m dimensions = (horizontal_loop_extent) From 1441ed48342554e76aaa70caeb19fd4001cd9074 Mon Sep 17 00:00:00 2001 From: dustinswales Date: Fri, 13 Jan 2023 10:32:28 -0700 Subject: [PATCH 086/380] Commit before sync with upstream --- physics/rrtmgp_sw_main.F90 | 97 ++++++++++++++++++++------------------ 1 file changed, 52 insertions(+), 45 deletions(-) diff --git a/physics/rrtmgp_sw_main.F90 b/physics/rrtmgp_sw_main.F90 index 114a3001a..6477fab51 100644 --- a/physics/rrtmgp_sw_main.F90 +++ b/physics/rrtmgp_sw_main.F90 @@ -226,6 +226,7 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ real(kind_phys), dimension(sw_gas_props%get_ngpt(),nLay,rrtmgp_phys_blksz) :: rng3D,rng3D2 real(kind_phys), dimension(sw_gas_props%get_ngpt()*nLay) :: rng2D logical, dimension(rrtmgp_phys_blksz,nLay,sw_gas_props%get_ngpt()) :: maskMCICA + logical :: cloudy_column, clear_column real(kind_phys), dimension(sw_gas_props%get_nband(),rrtmgp_phys_blksz) :: & sfc_alb_dir, sfc_alb_dif real(kind_phys), dimension(rrtmgp_phys_blksz,nLay+1,sw_gas_props%get_nband()),target :: & @@ -270,6 +271,9 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ if (zcf0(iblck) > oneminus) zcf0(iblck) = 1._kind_phys zcf1(iblck) = 1._kind_phys - zcf0(iblck) enddo + cloudy_column = any(zcf1 .gt. eps) + clear_column = .true. + if (cloudy_column) clear_column = .false. ! ################################################################################### ! @@ -385,7 +389,7 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ ! Compute optics for cloud(s) and precipitation, sample clouds... ! ! ################################################################################### - if (any(zcf1 .gt. eps)) then + if (cloudy_column) then ! Gridmean/mp-clouds call check_error_msg('rrtmgp_sw_main_cloud_optics',sw_cloud_props%cloud_optics(& cld_lwp(iCols,:), & ! IN - Cloud liquid water path @@ -523,70 +527,73 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ call check_error_msg('rrtmgp_sw_main_cloud_sampling',& draw_samples(maskMCICA, .true., & sw_optical_props_cloudsByBand, sw_optical_props_clouds)) - endif + endif ! cloudy_column ! ################################################################################### ! ! Compute clear-sky fluxes (gaseous+aerosol) ! ! ################################################################################### - ! Increment + ! Increment optics (always) sw_optical_props_aerosol_local%tau = aersw_tau(iCols,:,:) sw_optical_props_aerosol_local%ssa = aersw_ssa(iCols,:,:) sw_optical_props_aerosol_local%g = aersw_g(iCols,:,:) call check_error_msg('rrtmgp_sw_main_increment_aerosol_to_clrsky', & sw_optical_props_aerosol_local%increment(sw_optical_props_accum)) - ! Delta-scale - !call check_error_msg('rrtmgp_sw_main_delta_scale',sw_optical_props_accum%delta_scale()) - - ! Compute fluxes - call check_error_msg('rrtmgp_sw_main_rte_sw_clrsky',rte_sw( & - sw_optical_props_accum, & ! IN - optical-properties - top_at_1, & ! IN - veritcal ordering flag - coszen(iCols), & ! IN - Cosine of solar zenith angle - toa_src_sw, & ! IN - incident solar flux at TOA - sfc_alb_dir, & ! IN - Shortwave surface albedo (direct) - sfc_alb_dif, & ! IN - Shortwave surface albedo (diffuse) - flux_clrsky)) ! OUT - Fluxes, clear-sky, 3D (1,nLay,nBand) - - ! Store fluxes - fluxswUP_clrsky(iCols,:) = sum(flux_clrsky%bnd_flux_up, dim=3) - fluxswDOWN_clrsky(iCols,:) = sum(flux_clrsky%bnd_flux_dn, dim=3) + ! Compute clear-sky fluxes (Yes for no-clouds. Optional for cloudy scenes) + if (clear_column .or. doSWclrsky) then + call check_error_msg('rrtmgp_sw_main_rte_sw_clrsky',rte_sw( & + sw_optical_props_accum, & ! IN - optical-properties + top_at_1, & ! IN - veritcal ordering flag + coszen(iCols), & ! IN - Cosine of solar zenith angle + toa_src_sw, & ! IN - incident solar flux at TOA + sfc_alb_dir, & ! IN - Shortwave surface albedo (direct) + sfc_alb_dif, & ! IN - Shortwave surface albedo (diffuse) + flux_clrsky)) ! OUT - Fluxes, clear-sky, 3D (1,nLay,nBand) + + ! Store fluxes + fluxswUP_clrsky(iCols,:) = sum(flux_clrsky%bnd_flux_up, dim=3) + fluxswDOWN_clrsky(iCols,:) = sum(flux_clrsky%bnd_flux_dn, dim=3) - ! Compute surface downward beam/diffused flux components - do iblck = 1, rrtmgp_phys_blksz - do iBand=1,sw_gas_props%get_nband() - flux_dir = flux_clrsky%bnd_flux_dn(iblck,iSFC,iBand) - flux_dif = 0._kind_phys - ! Near-IR bands - if (iBand < ibd) then - scmpsw_clrsky(iblck)%nirbm = scmpsw_clrsky(iblck)%nirbm + flux_dir - scmpsw_clrsky(iblck)%nirdf = scmpsw_clrsky(iblck)%nirdf + flux_dif - endif - ! Transition band - if (iBand == ibd) then - scmpsw_clrsky(iblck)%nirbm = scmpsw_clrsky(iblck)%nirbm + flux_dir*0.5_kind_phys - scmpsw_clrsky(iblck)%nirdf = scmpsw_clrsky(iblck)%nirdf + flux_dif*0.5_kind_phys - scmpsw_clrsky(iblck)%visbm = scmpsw_clrsky(iblck)%visbm + flux_dir*0.5_kind_phys - scmpsw_clrsky(iblck)%visdf = scmpsw_clrsky(iblck)%visdf + flux_dif*0.5_kind_phys - endif - ! UV-VIS bands - if (iBand > ibd) then - scmpsw_clrsky(iblck)%visbm = scmpsw_clrsky(iblck)%visbm + flux_dir - scmpsw_clrsky(iblck)%visdf = scmpsw_clrsky(iblck)%visdf + flux_dif - endif - ! uv-b surface downward flux - scmpsw_clrsky(iblck)%uvbfc = flux_clrsky%bnd_flux_dn(iblck,iSFC,ibd_uv) + ! Compute surface downward beam/diffused flux components + do iblck = 1, rrtmgp_phys_blksz + do iBand=1,sw_gas_props%get_nband() + flux_dir = flux_clrsky%bnd_flux_dn(iblck,iSFC,iBand) + flux_dif = 0._kind_phys + ! Near-IR bands + if (iBand < ibd) then + scmpsw_clrsky(iblck)%nirbm = scmpsw_clrsky(iblck)%nirbm + flux_dir + scmpsw_clrsky(iblck)%nirdf = scmpsw_clrsky(iblck)%nirdf + flux_dif + endif + ! Transition band + if (iBand == ibd) then + scmpsw_clrsky(iblck)%nirbm = scmpsw_clrsky(iblck)%nirbm + flux_dir*0.5_kind_phys + scmpsw_clrsky(iblck)%nirdf = scmpsw_clrsky(iblck)%nirdf + flux_dif*0.5_kind_phys + scmpsw_clrsky(iblck)%visbm = scmpsw_clrsky(iblck)%visbm + flux_dir*0.5_kind_phys + scmpsw_clrsky(iblck)%visdf = scmpsw_clrsky(iblck)%visdf + flux_dif*0.5_kind_phys + endif + ! UV-VIS bands + if (iBand > ibd) then + scmpsw_clrsky(iblck)%visbm = scmpsw_clrsky(iblck)%visbm + flux_dir + scmpsw_clrsky(iblck)%visdf = scmpsw_clrsky(iblck)%visdf + flux_dif + endif + ! uv-b surface downward flux + scmpsw_clrsky(iblck)%uvbfc = flux_clrsky%bnd_flux_dn(iblck,iSFC,ibd_uv) + enddo enddo - enddo + else + fluxswUP_clrsky(iCols,:) = 0._kind_phys + fluxswDOWN_clrsky(iCols,:) = 0._kind_phys + scmpsw = cmpfsw_type( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 ) + endif ! ################################################################################### ! ! All-sky fluxes (clear-sky + clouds + precipitation) ! ! ################################################################################### - if (any(zcf1 .gt. eps)) then + if (cloudy_column) then ! Delta scale !call check_error_msg('rrtmgp_sw_main_delta_scale',sw_optical_props_clouds%delta_scale()) From e259523a1cf51c41fed5066ecbc76b52faf93022 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Wed, 18 Jan 2023 16:51:09 -0500 Subject: [PATCH 087/380] add back RUC LSM internal surface frozen precip density and option to use externally-calculated value --- physics/lsm_ruc.F90 | 17 ++++++++------ physics/lsm_ruc.meta | 15 ++++++++++++ physics/module_sf_ruclsm.F90 | 44 ++++++++++++++++++++++++++---------- 3 files changed, 57 insertions(+), 19 deletions(-) diff --git a/physics/lsm_ruc.F90 b/physics/lsm_ruc.F90 index 3cf12eb29..d065c154a 100644 --- a/physics/lsm_ruc.F90 +++ b/physics/lsm_ruc.F90 @@ -323,8 +323,8 @@ end subroutine lsm_ruc_finalize subroutine lsm_ruc_run & ! inputs & ( iter, me, master, delt, kdt, im, nlev, lsm_ruc, lsm, & & imp_physics, imp_physics_gfdl, imp_physics_thompson, & - & imp_physics_nssl, & - & do_mynnsfclay, lsoil_ruc, lsoil, rdlai, xlat_d, xlon_d, zs,& + & imp_physics_nssl, do_mynnsfclay, vrbliceden, & + & lsoil_ruc, lsoil, rdlai, xlat_d, xlon_d, zs, & & t1, q1, qc, stype, vtype, sigmaf, laixy, & & dlwflx, dswsfc, tg3, coszen, land, icy, use_lake, & & rainnc, rainc, ice, snow, graupel, & @@ -355,7 +355,7 @@ subroutine lsm_ruc_run & ! inputs & cm_ice, ch_ice, snowfallac_ice, & & albdvis_ice, albdnir_ice, albivis_ice, albinir_ice, & ! --- out - & sbsno, & + & rhosnf, sbsno, & & cmm_lnd, chh_lnd, cmm_ice, chh_ice, & ! & flag_iter, flag_guess, flag_init, lsm_cold_start, & @@ -397,6 +397,7 @@ subroutine lsm_ruc_run & ! inputs logical, dimension(:), intent(in) :: flag_cice logical, intent(in) :: frac_grid logical, intent(in) :: do_mynnsfclay + logical, intent(in) :: vrbliceden logical, intent(in) :: rdlai @@ -426,7 +427,7 @@ subroutine lsm_ruc_run & ! inputs ! --- output: real (kind=kind_phys), dimension(:), intent(inout) :: & - & runof, drain, runoff, srunoff, evbs, evcw, & + & rhosnf, runof, drain, runoff, srunoff, evbs, evcw, & & stm, wetness, semisbase, semis_lnd, semis_ice, & & sfalb_lnd, sfalb_ice, & ! for land @@ -492,7 +493,7 @@ subroutine lsm_ruc_run & ! inputs & sneqv_lnd, snoalb1d_lnd, snowh_lnd, snoh_lnd, tsnav_lnd, & & snomlt_lnd, sncovr_lnd, soilw, soilm, ssoil_lnd, & & soilt_lnd, tbot, & - & xlai, swdn, z0_lnd, znt_lnd, infiltr, & + & xlai, swdn, z0_lnd, znt_lnd, rhosnfr, infiltr, & & precipfr, snfallac_lnd, acsn, & & qsfc_lnd, qsg_lnd, qvg_lnd, qcg_lnd, soilt1_lnd, chklowq, & & rhonewsn @@ -747,6 +748,7 @@ subroutine lsm_ruc_run & ! inputs acrunoff(i,j) = 0.0 snfallac_lnd(i,j) = 0.0 snfallac_ice(i,j) = 0.0 + rhosnfr(i,j) = 0.0 precipfr(i,j) = 0.0 endif @@ -1121,7 +1123,7 @@ subroutine lsm_ruc_run & ! inputs & zs, prcp(i,j), sneqv_lnd(i,j), snowh_lnd(i,j), & & sncovr_lnd(i,j), & & ffrozp(i,j), frpcpn, & - & precipfr(i,j), & + & rhosnfr(i,j), precipfr(i,j), vrbliceden, & ! --- inputs: & conflx2(i,1,j), sfcprs(i,1,j), sfctmp(i,1,j), q2(i,1,j), & & qcatm(i,1,j), rho2(i,1,j), semis_bck(i,j), lwdn(i,j), & @@ -1245,6 +1247,7 @@ subroutine lsm_ruc_run & ! inputs sfcqv_lnd(i) = qvg_lnd(i,j) sfcqc_lnd(i) = qcg_lnd(i,j) ! --- ... units [m/s] = [g m-2 s-1] + rhosnf(i) = rhosnfr(i,j) !acsnow(i) = acsn(i,j) ! kg m-2 ! --- ... accumulated total runoff and surface runoff @@ -1394,7 +1397,7 @@ subroutine lsm_ruc_run & ! inputs & zs, prcp(i,j), sneqv_ice(i,j), snowh_ice(i,j), & & sncovr_ice(i,j), & & ffrozp(i,j), frpcpn, & - & precipfr(i,j), & + & rhosnfr(i,j), precipfr(i,j), vrbliceden, & ! --- inputs: & conflx2(i,1,j), sfcprs(i,1,j), sfctmp(i,1,j), q2(i,1,j), & & qcatm(i,1,j), rho2(i,1,j), semis_bck(i,j), lwdn(i,j), & diff --git a/physics/lsm_ruc.meta b/physics/lsm_ruc.meta index 28a3545c9..2fd4f8f77 100644 --- a/physics/lsm_ruc.meta +++ b/physics/lsm_ruc.meta @@ -634,6 +634,13 @@ dimensions = () type = logical intent = in +[vrbliceden] + standard_name = do_variable_surface_frozen_precipitation_density + long_name = flag for variable precip ice density + units = flag + dimensions = () + type = logical + intent = in [lsoil_ruc] standard_name = vertical_dimension_of_soil_internal_to_land_surface_scheme long_name = number of soil layers internal to land surface model @@ -1512,6 +1519,14 @@ type = real kind = kind_phys intent = out +[rhosnf] + standard_name = lsm_internal_surface_frozen_precipitation_density + long_name = density of frozen precipitation + units = kg m-3 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout [sbsno] standard_name = snow_deposition_sublimation_upward_latent_heat_flux long_name = latent heat flux from snow depo/subl diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 857408979..bf7a0bf8e 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -54,11 +54,11 @@ SUBROUTINE LSMRUC( & DT,init,lsm_cold_start,KTAU,iter,NSL, & graupelncv,snowncv,rainncv,raincv, & ZS,RAINBL,SNOW,SNOWH,SNOWC,FRZFRAC,frpcpn, & - precipfr, & + rhosnf,precipfr,vrbliceden, & Z3D,P8W,T3D,QV3D,QC3D,RHO3D,EMISBCK, & GLW,GSWdn,GSW,EMISS,CHKLOWQ, CHS, & - FLQC,FLHC,rhonewsn,MAVAIL,CANWAT,VEGFRA,ALB, & - ZNT,Z0,SNOALB,ALBBCK,LAI, & + FLQC,FLHC,rhonewsn_ex,MAVAIL,CANWAT,VEGFRA, & + ALB, ZNT,Z0,SNOALB,ALBBCK,LAI, & landusef, nlcat, & ! mosaic_lu, mosaic_soil, & soilctop, nscat, & QSFC,QSG,QVG,QCG,DEW,SOILT1,TSNAV, & @@ -157,7 +157,7 @@ SUBROUTINE LSMRUC( & ! INTEGER, PARAMETER :: nddzs=2*(nzss-2) REAL, INTENT(IN ) :: DT - LOGICAL, INTENT(IN ) :: myj,frpcpn,init,lsm_cold_start + LOGICAL, INTENT(IN ) :: myj,frpcpn,init,lsm_cold_start,vrbliceden INTEGER, INTENT(IN ) :: NLCAT, NSCAT ! , mosaic_lu, mosaic_soil INTEGER, INTENT(IN ) :: ktau, iter, nsl, isice, iswater, & ims,ime, jms,jme, kms,kme, & @@ -192,7 +192,7 @@ SUBROUTINE LSMRUC( & SNOWNCV, & RAINCV, & RAINNCV, & - RHONEWSN + RHONEWSN_ex !externally-calculated srf frz precip density ! REAL, DIMENSION( ims:ime , jms:jme ), & ! INTENT(IN ) :: lakemask ! INTEGER, INTENT(IN ) :: LakeModel @@ -296,12 +296,15 @@ SUBROUTINE LSMRUC( & SMFR3D REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: & + RHOSNF, & !RHO of snowfall PRECIPFR, & ! time-step frozen precip SNOWFALLAC !--- soil/snow properties REAL & :: RHOCS, & + RHONEWSN, & RHOSN, & + RHOSNFALL, & BCLH, & DQM, & KSAT, & @@ -455,6 +458,7 @@ SUBROUTINE LSMRUC( & ACSNOW(i,j) = 0. SNOWFALLAC(i,j) = 0. PRECIPFR(i,j) = 0. + RHOSNF(i,j) = -1.e3 ! non-zero flag SNFLX(i,j) = 0. DEW (i,j) = 0. PC (i,j) = 0. @@ -619,6 +623,7 @@ SUBROUTINE LSMRUC( & CANWATR=CANWAT(I,J)*1.E-3 SNOWFRAC=SNOWC(I,J) + RHOSNFALL=RHOSNF(I,J) snowold(i,j)=snwe !----- @@ -680,6 +685,7 @@ SUBROUTINE LSMRUC( & NROOT= 4 ! ! rooting depth + RHONEWSN = 200. if(SNOW(i,j).gt.0. .and. SNOWH(i,j).gt.0.) then RHOSN = SNOW(i,j)/SNOWH(i,j) else @@ -890,8 +896,8 @@ SUBROUTINE LSMRUC( & nzs,nddzs,nroot,meltfactor, & !added meltfactor iland,isoil,ivgtyp(i,j),isltyp(i,j), & PRCPMS, NEWSNMS,SNWE,SNHEI,SNOWFRAC, & - RHOSN,RHONEWSN(I,J), & - snowrat,grauprat,icerat,curat, & + vrbliceden,RHOSN,RHONEWSN_ex(I,J),RHONEWSN, & + RHOSNFALL,snowrat,grauprat,icerat,curat, & PATM,TABS,QVATM,QCATM,RHO, & GLW(I,J),GSWdn(i,j),GSW(I,J), & EMISSL(I,J),EMISBCK(I,J), & @@ -1069,6 +1075,9 @@ SUBROUTINE LSMRUC( & SNOWC(I,J)=SNOWFRAC +!--- RHOSNF - density of snowfall + RHOSNF(I,J)=RHOSNFALL + ! Accumulated moisture flux [kg/m^2] SFCEVP (I,J) = SFCEVP (I,J) + QFX (I,J) * DT @@ -1154,7 +1163,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia nzs,nddzs,nroot,meltfactor, & ILAND,ISOIL,IVGTYP,ISLTYP,PRCPMS, & NEWSNMS,SNWE,SNHEI,SNOWFRAC, & - RHOSN,RHONEWSN, & + vrbliceden,RHOSN,RHONEWSN_ex,RHONEWSN,RHOSNFALL, & snowrat,grauprat,icerat,curat, & PATM,TABS,QVATM,QCATM,rho, & GLW,GSWdn,GSW,EMISS,EMISBCK,QKMS,TKMS,PC, & @@ -1182,8 +1191,8 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia nddzs !nddzs=2*(nzs-2) REAL, INTENT(IN ) :: DELT,CONFLX,meltfactor - REAL, INTENT(IN ) :: C1SN,C2SN,RHONEWSN - LOGICAL, INTENT(IN ) :: myj, debug_print + REAL, INTENT(IN ) :: C1SN,C2SN,RHONEWSN_ex + LOGICAL, INTENT(IN ) :: myj, debug_print, vrbliceden !--- 3-D Atmospheric variables REAL , & INTENT(IN ) :: PATM, & @@ -1273,7 +1282,9 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia EETA, & EVAPL, & INFILTR, & - RHOSN, & + RHOSN, & + RHONEWSN, & + rhosnfall, & snowrat, & grauprat, & icerat, & @@ -1484,13 +1495,22 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia !--- 27 Feb 2014 - empirical formulations from John M. Brown ! rhonewsn=min(250.,rhowater/max(4.179,(13.*tanh((274.15-Tabs)*0.3333)))) !--- 13 Mar 2018 - formulation from Trevor Elcott - + if (vrbliceden) then + rhonewsn = rhonewsn_ex + else + rhonewsn=min(125.,1000.0/max(8.,(17.*tanh((276.65-Tabs)*0.15)))) + rhonewgr=min(500.,rhowater/max(2.,(3.5*tanh((274.15-Tabs)*0.3333)))) + rhonewice=rhonewsn !--- compute density of "snowfall" from weighted contribution ! of snow, graupel and ice fractions + rhosnfall = min(500.,max(58.8,(rhonewsn*snowrat + & !13mar18 rhosnfall = min(500.,max(76.9,(rhonewsn*snowrat + & + rhonewgr*grauprat + rhonewice*icerat + rhonewgr*curat))) ! from now on rhonewsn is the density of falling frozen precipitation + rhonewsn=rhosnfall + end if !*** Define average snow density of the snow pack considering !*** the amount of fresh snow (eq. 9 in Koren et al.(1999) From c96fee620e54758250d145fb776b759c2c6c61bc Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Thu, 19 Jan 2023 10:28:11 -0500 Subject: [PATCH 088/380] update initialization of rhosnfr in lsm_ruc.F90 --- physics/lsm_ruc.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/lsm_ruc.F90 b/physics/lsm_ruc.F90 index d065c154a..21b805d9c 100644 --- a/physics/lsm_ruc.F90 +++ b/physics/lsm_ruc.F90 @@ -748,7 +748,7 @@ subroutine lsm_ruc_run & ! inputs acrunoff(i,j) = 0.0 snfallac_lnd(i,j) = 0.0 snfallac_ice(i,j) = 0.0 - rhosnfr(i,j) = 0.0 + rhosnfr(i,j) = -1.e3 precipfr(i,j) = 0.0 endif From cb0afb8c8b9de7b97e37d593225fe2dc81c9f6d8 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Thu, 19 Jan 2023 20:46:52 -0500 Subject: [PATCH 089/380] use updated exticeden flag --- physics/GFS_MP_generic_post.F90 | 8 ++++---- physics/GFS_MP_generic_post.meta | 13 +++---------- physics/lsm_noah.f | 6 +++--- physics/lsm_noah.meta | 6 +++--- physics/lsm_ruc.F90 | 8 ++++---- physics/lsm_ruc.meta | 6 +++--- physics/module_sf_ruclsm.F90 | 12 ++++++------ physics/sflx.f | 10 +++++----- 8 files changed, 31 insertions(+), 38 deletions(-) diff --git a/physics/GFS_MP_generic_post.F90 b/physics/GFS_MP_generic_post.F90 index d9d205720..1a04c74ba 100644 --- a/physics/GFS_MP_generic_post.F90 +++ b/physics/GFS_MP_generic_post.F90 @@ -24,7 +24,7 @@ subroutine GFS_MP_generic_post_run( frain, rainc, rain1, rann, xlat, xlon, gt0, gq0, prsl, prsi, phii, tsfc, ice, snow, graupel, save_t, save_q, & rain0, ice0, snow0, graupel0, del, rain, domr_diag, domzr_diag, domip_diag, doms_diag, tprcp, srflag, sr, cnvprcp,& totprcp, totice, totsnw, totgrp, cnvprcpb, totprcpb, toticeb, totsnwb, totgrpb, rain_cpl, rainc_cpl, snow_cpl, & - pwat, frzr, frzrb, frozr, frozrb, tsnowp, tsnowpb, rhonewsn1, vrbliceden_noah, iopt_snf, & + pwat, frzr, frzrb, frozr, frozrb, tsnowp, tsnowpb, rhonewsn1, exticeden, & drain_cpl, dsnow_cpl, lsm, lsm_ruc, lsm_noahmp, raincprv, rainncprv, iceprv, snowprv, & graupelprv, draincprv, drainncprv, diceprv, dsnowprv, dgraupelprv, dtp, dfi_radar_max_intervals, & dtend, dtidx, index_of_temperature, index_of_process_mp,ldiag3d, qdiag3d,dqdt_qmicro, lssav, num_dfi_radar, & @@ -38,7 +38,7 @@ subroutine GFS_MP_generic_post_run( integer, intent(in) :: im, levs, kdt, nrcm, nncl, ntcw, ntrac, num_dfi_radar, index_of_process_dfi_radar integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_mg, imp_physics_fer_hires integer, intent(in) :: imp_physics_nssl - logical, intent(in) :: cal_pre, lssav, ldiag3d, qdiag3d, cplflx, cplchm, cpllnd, progsigma, vrbliceden_noah + logical, intent(in) :: cal_pre, lssav, ldiag3d, qdiag3d, cplflx, cplchm, cpllnd, progsigma, exticeden integer, intent(in) :: index_of_temperature,index_of_process_mp integer :: dfi_radar_max_intervals @@ -71,7 +71,7 @@ subroutine GFS_MP_generic_post_run( real(kind=kind_phys), dimension(:), intent(inout) :: drain_cpl, dsnow_cpl ! Rainfall variables previous time step - integer, intent(in) :: lsm, lsm_ruc, lsm_noahmp, iopt_snf + integer, intent(in) :: lsm, lsm_ruc, lsm_noahmp real(kind=kind_phys), dimension(:), intent(inout) :: raincprv real(kind=kind_phys), dimension(:), intent(inout) :: rainncprv real(kind=kind_phys), dimension(:), intent(inout) :: iceprv @@ -135,7 +135,7 @@ subroutine GFS_MP_generic_post_run( frozrb(i) = frozrb(i) + graupel0(i) enddo !Compute the variable precip ice density for specific LSM schemes and options - if ( lsm == lsm_ruc .or. (lsm == lsm_noahmp .and. iopt_snf == 5) .or. vrbliceden_noah == .true.) then + if (exticeden) then snowrat = 0. grauprat = 0. icerat = 0. diff --git a/physics/GFS_MP_generic_post.meta b/physics/GFS_MP_generic_post.meta index c71b61ed0..fa1cfafe0 100644 --- a/physics/GFS_MP_generic_post.meta +++ b/physics/GFS_MP_generic_post.meta @@ -342,20 +342,13 @@ type = real kind = kind_phys intent = inout -[vrbliceden_noah] - standard_name = do_variable_surface_frozen_precipitation_density - long_name = flag for variable precip ice density +[exticeden] + standard_name = do_external_surface_frozen_precipitation_density + long_name = flag for calculating frozen precip ice density outside of the LSM units = flag dimensions = () type = logical intent = in -[iopt_snf] - standard_name = control_for_land_surface_scheme_precipitation_type_partition - long_name = choice for precipitation partition option (see noahmp module for definition) - units = index - dimensions = () - type = integer - intent = in [save_t] standard_name = air_temperature_save long_name = air temperature before entering a physics scheme diff --git a/physics/lsm_noah.f b/physics/lsm_noah.f index 3e66c86fb..e145fa94b 100644 --- a/physics/lsm_noah.f +++ b/physics/lsm_noah.f @@ -221,7 +221,7 @@ subroutine lsm_noah_run & & bexppert, xlaipert, vegfpert,pertvegf, & ! sfc perts, mgehne & albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, & & adjvisbmd, adjnirbmd, adjvisdfd, adjnirdfd, rhonewsn1, & - & vrbliceden_noah, & + & exticeden, & ! --- in/outs: & weasd, snwdph, tskin, tprcp, srflag, smc, stc, slc, & & canopy, trans, tsurf, zorl, & @@ -272,7 +272,7 @@ subroutine lsm_noah_run & logical, dimension(:), intent(in) :: flag_iter, flag_guess, land - logical, intent(in) :: lheatstrg, vrbliceden_noah + logical, intent(in) :: lheatstrg, exticeden ! --- in/out: real (kind=kind_phys), dimension(:), intent(inout) :: weasd, & @@ -531,7 +531,7 @@ subroutine lsm_noah_run & & swdn, solnet, lwdn, sfcems, sfcprs, sfctmp, & & sfcspd, prcp, q2, q2sat, dqsdt2, th2, ivegsrc, & & vtype, stype, slope, shdmin1d, alb, snoalb1d, & - & rhonewsn, vrbliceden_noah, & + & rhonewsn, exticeden, & & bexpp, xlaip, & ! sfc-perts, mgehne & lheatstrg, & ! --- input/outputs: diff --git a/physics/lsm_noah.meta b/physics/lsm_noah.meta index 9c93586da..e059a22c6 100644 --- a/physics/lsm_noah.meta +++ b/physics/lsm_noah.meta @@ -494,9 +494,9 @@ type = real kind = kind_phys intent = in -[vrbliceden_noah] - standard_name = do_variable_surface_frozen_precipitation_density - long_name = flag for variable precip ice density +[exticeden] + standard_name = do_external_surface_frozen_precipitation_density + long_name = flag for calculating frozen precip ice density outside of the LSM units = flag dimensions = () type = logical diff --git a/physics/lsm_ruc.F90 b/physics/lsm_ruc.F90 index 21b805d9c..f4c2a8be6 100644 --- a/physics/lsm_ruc.F90 +++ b/physics/lsm_ruc.F90 @@ -323,7 +323,7 @@ end subroutine lsm_ruc_finalize subroutine lsm_ruc_run & ! inputs & ( iter, me, master, delt, kdt, im, nlev, lsm_ruc, lsm, & & imp_physics, imp_physics_gfdl, imp_physics_thompson, & - & imp_physics_nssl, do_mynnsfclay, vrbliceden, & + & imp_physics_nssl, do_mynnsfclay, exticeden, & & lsoil_ruc, lsoil, rdlai, xlat_d, xlon_d, zs, & & t1, q1, qc, stype, vtype, sigmaf, laixy, & & dlwflx, dswsfc, tg3, coszen, land, icy, use_lake, & @@ -397,7 +397,7 @@ subroutine lsm_ruc_run & ! inputs logical, dimension(:), intent(in) :: flag_cice logical, intent(in) :: frac_grid logical, intent(in) :: do_mynnsfclay - logical, intent(in) :: vrbliceden + logical, intent(in) :: exticeden logical, intent(in) :: rdlai @@ -1123,7 +1123,7 @@ subroutine lsm_ruc_run & ! inputs & zs, prcp(i,j), sneqv_lnd(i,j), snowh_lnd(i,j), & & sncovr_lnd(i,j), & & ffrozp(i,j), frpcpn, & - & rhosnfr(i,j), precipfr(i,j), vrbliceden, & + & rhosnfr(i,j), precipfr(i,j), exticeden, & ! --- inputs: & conflx2(i,1,j), sfcprs(i,1,j), sfctmp(i,1,j), q2(i,1,j), & & qcatm(i,1,j), rho2(i,1,j), semis_bck(i,j), lwdn(i,j), & @@ -1397,7 +1397,7 @@ subroutine lsm_ruc_run & ! inputs & zs, prcp(i,j), sneqv_ice(i,j), snowh_ice(i,j), & & sncovr_ice(i,j), & & ffrozp(i,j), frpcpn, & - & rhosnfr(i,j), precipfr(i,j), vrbliceden, & + & rhosnfr(i,j), precipfr(i,j), exticeden, & ! --- inputs: & conflx2(i,1,j), sfcprs(i,1,j), sfctmp(i,1,j), q2(i,1,j), & & qcatm(i,1,j), rho2(i,1,j), semis_bck(i,j), lwdn(i,j), & diff --git a/physics/lsm_ruc.meta b/physics/lsm_ruc.meta index 2fd4f8f77..0d22f8d4a 100644 --- a/physics/lsm_ruc.meta +++ b/physics/lsm_ruc.meta @@ -634,9 +634,9 @@ dimensions = () type = logical intent = in -[vrbliceden] - standard_name = do_variable_surface_frozen_precipitation_density - long_name = flag for variable precip ice density +[exticeden] + standard_name = do_external_surface_frozen_precipitation_density + long_name = flag for calculating frozen precip ice density outside of the LSM units = flag dimensions = () type = logical diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index bf7a0bf8e..cf0d6f015 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -54,7 +54,7 @@ SUBROUTINE LSMRUC( & DT,init,lsm_cold_start,KTAU,iter,NSL, & graupelncv,snowncv,rainncv,raincv, & ZS,RAINBL,SNOW,SNOWH,SNOWC,FRZFRAC,frpcpn, & - rhosnf,precipfr,vrbliceden, & + rhosnf,precipfr,exticeden, & Z3D,P8W,T3D,QV3D,QC3D,RHO3D,EMISBCK, & GLW,GSWdn,GSW,EMISS,CHKLOWQ, CHS, & FLQC,FLHC,rhonewsn_ex,MAVAIL,CANWAT,VEGFRA, & @@ -157,7 +157,7 @@ SUBROUTINE LSMRUC( & ! INTEGER, PARAMETER :: nddzs=2*(nzss-2) REAL, INTENT(IN ) :: DT - LOGICAL, INTENT(IN ) :: myj,frpcpn,init,lsm_cold_start,vrbliceden + LOGICAL, INTENT(IN ) :: myj,frpcpn,init,lsm_cold_start,exticeden INTEGER, INTENT(IN ) :: NLCAT, NSCAT ! , mosaic_lu, mosaic_soil INTEGER, INTENT(IN ) :: ktau, iter, nsl, isice, iswater, & ims,ime, jms,jme, kms,kme, & @@ -896,7 +896,7 @@ SUBROUTINE LSMRUC( & nzs,nddzs,nroot,meltfactor, & !added meltfactor iland,isoil,ivgtyp(i,j),isltyp(i,j), & PRCPMS, NEWSNMS,SNWE,SNHEI,SNOWFRAC, & - vrbliceden,RHOSN,RHONEWSN_ex(I,J),RHONEWSN, & + exticeden,RHOSN,RHONEWSN_ex(I,J),RHONEWSN, & RHOSNFALL,snowrat,grauprat,icerat,curat, & PATM,TABS,QVATM,QCATM,RHO, & GLW(I,J),GSWdn(i,j),GSW(I,J), & @@ -1163,7 +1163,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia nzs,nddzs,nroot,meltfactor, & ILAND,ISOIL,IVGTYP,ISLTYP,PRCPMS, & NEWSNMS,SNWE,SNHEI,SNOWFRAC, & - vrbliceden,RHOSN,RHONEWSN_ex,RHONEWSN,RHOSNFALL, & + exticeden,RHOSN,RHONEWSN_ex,RHONEWSN,RHOSNFALL, & snowrat,grauprat,icerat,curat, & PATM,TABS,QVATM,QCATM,rho, & GLW,GSWdn,GSW,EMISS,EMISBCK,QKMS,TKMS,PC, & @@ -1192,7 +1192,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia REAL, INTENT(IN ) :: DELT,CONFLX,meltfactor REAL, INTENT(IN ) :: C1SN,C2SN,RHONEWSN_ex - LOGICAL, INTENT(IN ) :: myj, debug_print, vrbliceden + LOGICAL, INTENT(IN ) :: myj, debug_print, exticeden !--- 3-D Atmospheric variables REAL , & INTENT(IN ) :: PATM, & @@ -1495,7 +1495,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia !--- 27 Feb 2014 - empirical formulations from John M. Brown ! rhonewsn=min(250.,rhowater/max(4.179,(13.*tanh((274.15-Tabs)*0.3333)))) !--- 13 Mar 2018 - formulation from Trevor Elcott - if (vrbliceden) then + if (exticeden) then rhonewsn = rhonewsn_ex else rhonewsn=min(125.,1000.0/max(8.,(17.*tanh((276.65-Tabs)*0.15)))) diff --git a/physics/sflx.f b/physics/sflx.f index ae302be1c..df22d128f 100644 --- a/physics/sflx.f +++ b/physics/sflx.f @@ -116,7 +116,7 @@ subroutine gfssflx &! --- input & swdn, swnet, lwdn, sfcems, sfcprs, sfctmp, & & sfcspd, prcp, q2, q2sat, dqsdt2, th2, ivegsrc, & & vegtyp, soiltyp, slopetyp, shdmin, alb, snoalb, & - & rhonewsn, vrbliceden_noah, & + & rhonewsn, exticeden, & & bexpp, xlaip, & ! sfc-perts, mgehne & lheatstrg, &! --- input/outputs: & tbot, cmc, t1, stc, smc, sh2o, sneqv, ch, cm,z0, &! --- outputs: @@ -313,7 +313,7 @@ subroutine gfssflx &! --- input & sfcspd, prcp, q2, q2sat, dqsdt2, th2, shdmin, alb, snoalb, & & bexpp, xlaip, rhonewsn & !sfc-perts, mgehne - logical, intent(in) :: lheatstrg, vrbliceden_noah + logical, intent(in) :: lheatstrg, exticeden ! --- input/outputs: real (kind=kind_phys), intent(inout) :: tbot, cmc, t1, sneqv, & @@ -565,7 +565,7 @@ subroutine gfssflx &! --- input !! using old and new snow. call snow_new ! --- inputs: ! -! ( sfctmp, sn_new, rhonewsn, vrbliceden_noah, ! +! ( sfctmp, sn_new, rhonewsn, exticeden, ! ! --- input/outputs: ! ! snowh, sndens ) ! @@ -2856,7 +2856,7 @@ end subroutine snopac subroutine snow_new !................................... ! --- inputs: -! & ( sfctmp, sn_new, rhonewsn, vrbliceden_noah, & +! & ( sfctmp, sn_new, rhonewsn, exticeden, & ! --- input/outputs: ! & snowh, sndens & ! & ) @@ -2905,7 +2905,7 @@ subroutine snow_new ! snowcovered and glacierized basin', 6th nordic hydrological ! conference, vemadolen, sweden, 1980, 172-177pp. - if(.not. vrbliceden_noah) then + if(.not. exticeden) then if (tempc <= -15.0) then dsnew = 0.05 else From 45ed3770b3a390a5285499fd727c46cee4c1e53a Mon Sep 17 00:00:00 2001 From: "Chunxi.Zhang-NOAA" Date: Wed, 25 Jan 2023 21:54:32 +0000 Subject: [PATCH 090/380] Bug fix for cloud effective radius for convective clouds (HR1) --- physics/radiation_clouds.f | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index bf255ce00..7255f1578 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -2212,10 +2212,16 @@ subroutine progcld_thompson_wsm6 & !> The total condensate includes convective condensate. do k = 1, NLAY-1 do i = 1, IX - cwp(i,k) = max(0.0, (clw(i,k,ntcw)+cnvw(i,k)* - & (1.-tem2d(i,k))) * gfac * delp(i,k)) - cip(i,k) = max(0.0, (clw(i,k,ntiw) + cnvw(i,k)* - & tem2d(i,k)) *gfac * delp(i,k)) + tem1 = cnvw(i,k)*(1.-tem2d(i,k)) + cwp(i,k) = max(0.0, (clw(i,k,ntcw)+tem1) * + & gfac * delp(i,k)) + if(tem1 > 1.e-12 .and. clw(i,k,ntcw) < 1.e-12) + & rew(i,k)=reliq_def + tem2 = cnvw(i,k)*tem2d(i,k) + cip(i,k) = max(0.0, (clw(i,k,ntiw) + tem2 ) + & *gfac * delp(i,k)) + if(tem2 > 1.e-12 .and. clw(i,k,ntiw) < 1.e-12) + & rei(i,k)=reice_def crp(i,k) = max(0.0, clw(i,k,ntrw) * gfac * delp(i,k)) csp(i,k) = max(0.0, clw(i,k,ntsw) * gfac * delp(i,k)) enddo From 0befb4120a2e6b559100304d529ba0114c5dd42b Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Wed, 25 Jan 2023 23:25:04 +0000 Subject: [PATCH 091/380] Added documenation back into scheme file. --- physics/GFS_rrtmgp_cloud_mp.F90 | 158 +++++++++++++++++--------------- 1 file changed, 83 insertions(+), 75 deletions(-) diff --git a/physics/GFS_rrtmgp_cloud_mp.F90 b/physics/GFS_rrtmgp_cloud_mp.F90 index b294f21b6..32104b7f8 100644 --- a/physics/GFS_rrtmgp_cloud_mp.F90 +++ b/physics/GFS_rrtmgp_cloud_mp.F90 @@ -1,5 +1,10 @@ -! ######################################################################################## -! ######################################################################################## +!> \file GFS_rrtmgp_cloud_mp.F90 +!! +!> \defgroup GFS_rrtmgp_cloud_mp GFS_rrtmgp_cloud_mp.F90 +!! +!! \brief This module contains the interface for ALL cloud microphysics assumptions and +!! the RRTMGP radiation scheme. Specific details below in subroutines. +!! module GFS_rrtmgp_cloud_mp use machine, only: kind_phys use radiation_tools, only: check_error_msg @@ -26,15 +31,21 @@ module GFS_rrtmgp_cloud_mp contains +!>\defgroup gfs_rrtmgp_cloud_mp_mod GFS RRTMGP Cloud MP Module !! \section arg_table_GFS_rrtmgp_cloud_mp_run !! \htmlinclude GFS_rrtmgp_cloud_mp_run_html !! - ! ###################################################################################### - ! ###################################################################################### +!> \ingroup GFS_rrtmgp_cloud_mp +!! +!! Here the cloud-radiative properties (optical-path, particle-size and sometimes cloud- +!! fraction) are computed for cloud producing physics schemes (e.g GFDL-MP, Thompson-MP, +!! MYNN-EDMF-pbl, GF-convective, and SAMF-convective clouds). +!! +!! \section GFS_rrtmgp_cloud_mp_run subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, & i_cldrain, i_cldsnow, i_cldgrpl, i_cldtot, i_cldliq_nc, i_cldice_nc, i_twa, kdt, & imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_samf, doSWrad, doLWrad, effr_in, lmfshal, & - ltaerosol,mraerosol, icloud, imp_physics, imp_physics_thompson, imp_physics_gfdl, & + ltaerosol,mraerosol, icloud, imp_physics, imp_physics_thompson, imp_physics_gfdl, & lgfdlmprad, do_mynnedmf, uni_cld, lmfdeep2, p_lev, p_lay, t_lay, qs_lay, q_lay, & relhum, lsmask, xlon, xlat, dx, tv_lay, effrin_cldliq, effrin_cldice, & effrin_cldrain, effrin_cldsnow, tracer, cnv_mixratio, cld_cnv_frac, qci_conv, & @@ -299,22 +310,22 @@ subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldic end subroutine GFS_rrtmgp_cloud_mp_run - ! ###################################################################################### - ! Compute cloud radiative properties for Grell-Freitas convective cloud scheme. - ! (Adopted from module_SGSCloud_RadPre) - ! - ! - The total convective cloud condensate is partitoned by phase, using temperature, into - ! liquid/ice convective cloud mixing-ratios. Compute convective cloud LWP and IWP's. - ! - ! - The liquid and ice cloud effective particle sizes are assigned reference values*. - ! *TODO* Find references, include DOIs, parameterize magic numbers, etc... - ! - ! - The convective cloud-fraction is computed using Xu-Randall (1996). - ! (DJS asks: Does the GF scheme produce a cloud-fraction? If so, maybe use instead of - ! Xu-Randall? Xu-Randall is consistent with the Thompson MP scheme, but - ! not GFDL-EMC) - ! - ! ###################################################################################### +!> \ingroup GFS_rrtmgp_cloud_mp +!! Compute cloud radiative properties for Grell-Freitas convective cloud scheme. +!! (Adopted from module_SGSCloud_RadPre) +!! +!! - The total convective cloud condensate is partitoned by phase, using temperature, into +!! liquid/ice convective cloud mixing-ratios. Compute convective cloud LWP and IWP's. +!! +!! - The liquid and ice cloud effective particle sizes are assigned reference values*. +!! *TODO* Find references, include DOIs, parameterize magic numbers, etc... +!! +!! - The convective cloud-fraction is computed using Xu-Randall (1996). +!! (DJS asks: Does the GF scheme produce a cloud-fraction? If so, maybe use instead of +!! Xu-Randall? Xu-Randall is consistent with the Thompson MP scheme, but +!! not GFDL-EMC) +!! +!! \section cloud_mp_GF_gen General Algorithm subroutine cloud_mp_GF(nCol, nLev, lsmask, t_lay, p_lev, p_lay, qs_lay, relhum, & qci_conv, con_ttp, con_g, alpha0, cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, & cld_cnv_reice, cld_cnv_frac) @@ -379,17 +390,17 @@ subroutine cloud_mp_GF(nCol, nLev, lsmask, t_lay, p_lev, p_lay, qs_lay, relhum, enddo end subroutine cloud_mp_GF - ! ###################################################################################### - ! Compute cloud radiative properties for MYNN-EDMF PBL cloud scheme. - ! (Adopted from module_SGSCloud_RadPre) - ! - ! - Cloud-fraction, liquid, and ice condensate mixing-ratios from MYNN-EDMF cloud scheme - ! are provided as inputs. Cloud LWP and IWP are computed. - ! - ! - The liquid and ice cloud effective particle sizes are assigned reference values*. - ! *TODO* Find references, include DOIs, parameterize magic numbers, etc... - ! - ! ###################################################################################### +!> \ingroup GFS_rrtmgp_cloud_mp +!! Compute cloud radiative properties for MYNN-EDMF PBL cloud scheme. +!! (Adopted from module_SGSCloud_RadPre) +!! +!! - Cloud-fraction, liquid, and ice condensate mixing-ratios from MYNN-EDMF cloud scheme +!! are provided as inputs. Cloud LWP and IWP are computed. +!! +!! - The liquid and ice cloud effective particle sizes are assigned reference values*. +!! *TODO* Find references, include DOIs, parameterize magic numbers, etc... +!! +!! \section cloud_mp_MYNN_gen General Algorithm subroutine cloud_mp_MYNN(nCol, nLev, lsmask, t_lay, p_lev, p_lay, qs_lay, relhum, & qc_mynn, qi_mynn, con_ttp, con_g, cld_pbl_lwp, cld_pbl_reliq, cld_pbl_iwp, & cld_pbl_reice, cld_pbl_frac) @@ -451,18 +462,19 @@ subroutine cloud_mp_MYNN(nCol, nLev, lsmask, t_lay, p_lev, p_lay, qs_lay, relhum enddo end subroutine cloud_mp_MYNN - ! ###################################################################################### - ! Compute cloud radiative properties for SAMF convective cloud scheme. - ! - ! - The total-cloud convective mixing-ratio is partitioned by phase into liquid/ice - ! cloud properties. LWP and IWP are computed. - ! - ! - The liquid and ice cloud effective particle sizes are assigned reference values. - ! - ! - The convective cloud-fraction is computed using Xu-Randall (1996). - ! (DJS asks: Does the SAMF scheme produce a cloud-fraction?) - ! - ! ###################################################################################### + +!> \ingroup GFS_rrtmgp_cloud_mp +!! Compute cloud radiative properties for SAMF convective cloud scheme. +!! +!! - The total-cloud convective mixing-ratio is partitioned by phase into liquid/ice +!! cloud properties. LWP and IWP are computed. +!! +!! - The liquid and ice cloud effective particle sizes are assigned reference values. +!! +!! - The convective cloud-fraction is computed using Xu-Randall (1996). +!! (DJS asks: Does the SAMF scheme produce a cloud-fraction?) +!! +!! \section cloud_mp_SAMF_gen General Algorithm subroutine cloud_mp_SAMF(nCol, nLev, t_lay, p_lev, p_lay, qs_lay, relhum, & cnv_mixratio, con_ttp, con_g, alpha0, cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, & cld_cnv_reice, cld_cnv_frac) @@ -515,16 +527,12 @@ subroutine cloud_mp_SAMF(nCol, nLev, t_lay, p_lev, p_lay, qs_lay, relhum, end subroutine cloud_mp_SAMF - ! ###################################################################################### - ! This routine computes the cloud radiative properties for a "unified cloud". - ! - ! - "unified cloud" implies that the cloud-fraction is PROVIDED. - ! - ! - The cloud water path is computed for all provided cloud mixing-ratios and hydrometeors. - ! - ! - If particle sizes are provided, they are used. If not, default values are assigned. - ! - ! ###################################################################################### +!> \ingroup GFS_rrtmgp_cloud_mp +!! This routine computes the cloud radiative properties for a "unified cloud". +!! - "unified cloud" implies that the cloud-fraction is PROVIDED. +!! - The cloud water path is computed for all provided cloud mixing-ratios and hydrometeors. +!! - If particle sizes are provided, they are used. If not, default values are assigned. +!! \section cloud_mp_uni_gen General Algorithm subroutine cloud_mp_uni(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_cldrain, & i_cldsnow, i_cldgrpl, i_cldtot, effr_in, kdt, lsmask, p_lev, p_lay, t_lay, tv_lay,& effrin_cldliq, effrin_cldice, effrin_cldsnow, tracer, con_g, con_rd, con_ttp, & @@ -650,19 +658,19 @@ subroutine cloud_mp_uni(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_cldrai enddo ! nLev end subroutine cloud_mp_uni - ! ###################################################################################### - ! This routine computes the cloud radiative properties for the Thompson cloud micro- - ! physics scheme. - ! - ! - The cloud water path is computed for all provided cloud mixing-ratios and hydrometeors. - ! - ! - There are no assumptions about particle size applied here. Effective particle sizes - ! are updated prior to this routine, see cmp_reff_Thompson(). - ! - ! - The cloud-fraction is computed using Xu-Randall** (1996). - ! **Additionally, Conditioned on relative-humidity** - ! - ! ###################################################################################### +!> \ingroup GFS_rrtmgp_cloud_mp +!! This routine computes the cloud radiative properties for the Thompson cloud micro- +!! physics scheme. +!! +!! - The cloud water path is computed for all provided cloud mixing-ratios and hydrometeors. +!! +!! - There are no assumptions about particle size applied here. Effective particle sizes +!! are updated prior to this routine, see cmp_reff_Thompson(). +!! +!! - The cloud-fraction is computed using Xu-Randall** (1996). +!! **Additionally, Conditioned on relative-humidity** +!! +!! \section cloud_mp_thompson_gen General Algorithm subroutine cloud_mp_thompson(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_cldrain,& i_cldsnow, i_cldgrpl, p_lev, p_lay, tv_lay, t_lay, tracer, qs_lay, q_lay, relhum, & con_ttp, con_g, con_rd, con_eps, alpha0, cnv_mixratio, lwp_ex, iwp_ex, lwp_fc, & @@ -783,14 +791,14 @@ subroutine cloud_mp_thompson(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_c end subroutine cloud_mp_thompson - ! ###################################################################################### - ! This function computes the cloud-fraction following. - ! Xu-Randall(1996) A Semiempirical Cloudiness Parameterization for Use in Climate Models - ! https://doi.org/10.1175/1520-0469(1996)053<3084:ASCPFU>2.0.CO;2 - ! - ! cld_frac = {1-exp[-alpha*cld_mr/((1-relhum)*qs_lay)**lambda]}*relhum**P - ! - ! ###################################################################################### +!> \ingroup GFS_rrtmgp_cloud_mp +!! This function computes the cloud-fraction following. +!! Xu-Randall(1996) A Semiempirical Cloudiness Parameterization for Use in Climate Models +!! https://doi.org/10.1175/1520-0469(1996)053<3084:ASCPFU>2.0.CO;2 +!! +!! cld_frac = {1-exp[-alpha*cld_mr/((1-relhum)*qs_lay)**lambda]}*relhum**P +!! +!! \section cld_frac_XuRandall_gen General Algorithm function cld_frac_XuRandall(p_lay, qs_lay, relhum, cld_mr, alpha) implicit none ! Inputs From 0a053a06806f72da2082aca50e3c19b7252a1d53 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Wed, 25 Jan 2023 23:37:52 +0000 Subject: [PATCH 092/380] Address reviewers comments --- physics/GFS_rrtmgp_post.F90 | 4 ++-- physics/GFS_rrtmgp_post.meta | 4 ++-- physics/GFS_rrtmgp_pre.F90 | 9 ++++++--- physics/GFS_rrtmgp_pre.meta | 6 +++--- 4 files changed, 13 insertions(+), 10 deletions(-) diff --git a/physics/GFS_rrtmgp_post.F90 b/physics/GFS_rrtmgp_post.F90 index 42161e4d6..22fe2fc21 100644 --- a/physics/GFS_rrtmgp_post.F90 +++ b/physics/GFS_rrtmgp_post.F90 @@ -124,9 +124,9 @@ subroutine GFS_rrtmgp_post_run (nCol, nLev, nDay, iSFC, iTOA, idxday, doLWrad, d sfcflw ! LW radiation fluxes at sfc type(sfcfsw_type), dimension(:), intent(inout) :: & sfcfsw ! SW radiation fluxes at sfc - type(topfsw_type), dimension(:), intent(out) :: & + type(topfsw_type), dimension(:), intent(inout) :: & topfsw ! SW fluxes at top atmosphere - type(topflw_type), dimension(:), intent(out) :: & + type(topflw_type), dimension(:), intent(inout) :: & topflw ! LW fluxes at top atmosphere character(len=*), intent(out) :: & errmsg ! CCPP error message diff --git a/physics/GFS_rrtmgp_post.meta b/physics/GFS_rrtmgp_post.meta index 0caa1c387..e4bc3e5dc 100644 --- a/physics/GFS_rrtmgp_post.meta +++ b/physics/GFS_rrtmgp_post.meta @@ -358,7 +358,7 @@ units = W m-2 dimensions = (horizontal_loop_extent) type = topflw_type - intent = out + intent = inout [nirbmdi] standard_name = surface_downwelling_direct_nir_shortwave_flux_on_radiation_timestep long_name = sfc nir beam sw downward flux @@ -460,7 +460,7 @@ units = W m-2 dimensions = (horizontal_loop_extent) type = topfsw_type - intent = out + intent = inout [htrswc] standard_name = tendency_of_air_temperature_due_to_shortwave_heating_assuming_clear_sky_on_radiation_timestep long_name = clear sky sw heating rates diff --git a/physics/GFS_rrtmgp_pre.F90 b/physics/GFS_rrtmgp_pre.F90 index 7de803015..8e115b774 100644 --- a/physics/GFS_rrtmgp_pre.F90 +++ b/physics/GFS_rrtmgp_pre.F90 @@ -165,10 +165,11 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, doSWrad, doLWrad, fhswr, fhl errmsg ! Error message integer, intent(out) :: & errflg, & ! Error flag - iSFC, & ! Vertical index for surface - iTOA, & ! Vertical index for TOA nDay - logical, intent(out) :: & + integer, intent(inout) :: & + iSFC, & ! Vertical index for surface + iTOA ! Vertical index for TOA + logical, intent(inout) :: & top_at_1 ! Vertical ordering flag real(kind_phys), intent(inout) :: & raddt ! Radiation time-step @@ -208,6 +209,8 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, doSWrad, doLWrad, fhswr, fhl errmsg = '' errflg = 0 + nday = 0 + idxday = 0 if (.not. (doSWrad .or. doLWrad)) return ! ####################################################################################### diff --git a/physics/GFS_rrtmgp_pre.meta b/physics/GFS_rrtmgp_pre.meta index f77ac89db..455010e58 100644 --- a/physics/GFS_rrtmgp_pre.meta +++ b/physics/GFS_rrtmgp_pre.meta @@ -315,21 +315,21 @@ units = flag dimensions = () type = logical - intent = out + intent = inout [iSFC] standard_name = vertical_index_for_surface_in_RRTMGP long_name = index for surface layer in RRTMGP units = flag dimensions = () type = integer - intent = out + intent = inout [iTOA] standard_name = vertical_index_for_TOA_in_RRTMGP long_name = index for TOA layer in RRTMGP units = flag dimensions = () type = integer - intent = out + intent = inout [tsfc_radtime] standard_name = surface_skin_temperature_on_radiation_timestep long_name = surface skin temperature on radiation timestep From 377c0ba8b54a1427cb0127634b5c857f7f0c928a Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Thu, 26 Jan 2023 16:40:38 +0000 Subject: [PATCH 093/380] Address more reviewers comments --- physics/rrtmgp_sw_main.F90 | 3 ++- physics/rrtmgp_sw_main.meta | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/physics/rrtmgp_sw_main.F90 b/physics/rrtmgp_sw_main.F90 index 6477fab51..1a5b31e9e 100644 --- a/physics/rrtmgp_sw_main.F90 +++ b/physics/rrtmgp_sw_main.F90 @@ -200,7 +200,7 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ errmsg ! CCPP error message integer, intent(out) :: & errflg ! CCPP error flag - real(kind_phys), dimension(:,:), intent(out) :: & + real(kind_phys), dimension(:,:), intent(inout) :: & cldtausw ! Approx 10.mu band layer cloud optical depth real(kind_phys), dimension(:,:), intent(inout) :: & fluxswUP_allsky, & ! RRTMGP upward all-sky flux profiles (W/m2) @@ -304,6 +304,7 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ endif scmpsw_clrsky= cmpfsw_type( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 ) scmpsw_allsky= cmpfsw_type( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 ) + cldtausw = 0._kind_phys ! ty_fluxes_byband fluxSW_up_allsky = 0._kind_phys diff --git a/physics/rrtmgp_sw_main.meta b/physics/rrtmgp_sw_main.meta index c0be1658f..4ca6cc716 100644 --- a/physics/rrtmgp_sw_main.meta +++ b/physics/rrtmgp_sw_main.meta @@ -646,7 +646,7 @@ dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys - intent = out + intent = inout [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 5a34c967a5e28c8bd0ab8de02f65427023d38f7b Mon Sep 17 00:00:00 2001 From: Samuel Trahan Date: Tue, 31 Jan 2023 23:03:04 +0000 Subject: [PATCH 094/380] GSL lightning threat index --- physics/maximum_hourly_diagnostics.F90 | 82 +++++++++++++++++++++++-- physics/maximum_hourly_diagnostics.meta | 71 +++++++++++++++++++++ 2 files changed, 149 insertions(+), 4 deletions(-) diff --git a/physics/maximum_hourly_diagnostics.F90 b/physics/maximum_hourly_diagnostics.F90 index fb3a400e6..373c09467 100644 --- a/physics/maximum_hourly_diagnostics.F90 +++ b/physics/maximum_hourly_diagnostics.F90 @@ -29,11 +29,13 @@ subroutine maximum_hourly_diagnostics_run(im, levs, reset, lradar, imp_physics, gt0, refl_10cm, refdmax, refdmax263k, u10m, v10m, & u10max, v10max, spd10max, pgr, t2m, q2m, t02max, & t02min, rh02max, rh02min, dtp, rain, pratemax, & + lightning_threat, ltg1_max,ltg2_max,ltg3_max, & + vvl, phii, qgraupel, qsnowwat, qicewat, & errmsg, errflg) ! Interface variables integer, intent(in) :: im, levs - logical, intent(in) :: reset, lradar + logical, intent(in) :: reset, lradar, lightning_threat integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_fer_hires, & imp_physics_nssl real(kind_phys), intent(in ) :: con_g @@ -55,20 +57,28 @@ subroutine maximum_hourly_diagnostics_run(im, levs, reset, lradar, imp_physics, real(kind_phys), intent(inout) :: rh02max(:) real(kind_phys), intent(inout) :: rh02min(:) real(kind_phys), intent(in ) :: dtp - real(kind_phys), intent(in ) :: rain(im) - real(kind_phys), intent(inout) :: pratemax(im) + real(kind_phys), intent(in ) :: rain(:) + real(kind_phys), intent(inout) :: pratemax(:) + + real(kind_phys), intent(in), dimension(:,:) :: phii, qgraupel, qsnowwat, qicewat, vvl + real(kind_phys), intent(inout), dimension(:) :: ltg1_max, ltg2_max, ltg3_max character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg ! Local variables real(kind_phys), dimension(:), allocatable :: refd, refd263k - real(kind_phys) :: tem, pshltr, QCQ, rh02 + real(kind_phys) :: tem, pshltr, QCQ, rh02, dP, Q integer :: i ! Initialize CCPP error handling variables errmsg = '' errflg = 0 +!Lightning threat indices + if (lightning_threat) then + call lightning_threat_indices + endif + !Calculate hourly max 1-km agl and -10C reflectivity if (lradar .and. (imp_physics == imp_physics_gfdl .or. & imp_physics == imp_physics_thompson .or. & @@ -134,6 +144,70 @@ subroutine maximum_hourly_diagnostics_run(im, levs, reset, lradar, imp_physics, pratemax(i) = max(pratemax(i),(3.6E6/dtp)*rain(i)) enddo + contains + + subroutine lightning_threat_indices + implicit none + REAL(kind_phys), PARAMETER :: clim1=1.50 + REAL(kind_phys), PARAMETER :: clim2=0.40*1.22 + REAL(kind_phys), PARAMETER :: clim3=0.02*1.22 + ! coef1 and coef2 are modified from the values given + ! in McCaul et al. + ! coef1 is x 1000 x 1.22 + ! coef2 is x 1.22 + ! are these tuning factors, scale factors?? + ! McCaul et al. used a 2-km WRF simulation + REAL(kind_phys), PARAMETER :: coef1=0.042*1000.*1.22 + REAL(kind_phys), PARAMETER :: coef2=0.20*1.22 + + REAL(kind_phys) :: totice_colint(im), msft(im), ltg1, ltg2 + LOGICAL :: ltg1_calc(im) + integer :: k, i + + totice_colint = 0 + ltg1_calc = .false. + msft = 1. + ! get area (m^2) in units of km^2 + ! msft = 1.E-6*area + do k=levs,2,-1 + do i=1,im + dP = phii(i,k) - phii(i,k+1) + Q = qgraupel(i,k) + qsnowwat(i,k) + qicewat(i,k) + totice_colint(i) = totice_colint(i) + Q * dP / con_g + + IF ( .not.ltg1_calc(i) ) THEN + IF ( 0.5*(phii(i,k-1) - phii(i,k+1)) < 258.15 ) THEN + ltg1_calc(i) = .true. + + ltg1 = coef1*vvl(i,k)* & + (( qgraupel(i,k-1) + qgraupel(i,k) )*0.5 )/msft(i) + + IF ( ltg1 .LT. clim1 ) ltg1 = 0. + + IF ( ltg1 .GT. ltg1_max(i) ) THEN + ltg1_max(i) = ltg1 + ENDIF + ENDIF + ENDIF + enddo + enddo + + do i=1,im + ltg2 = coef2 * totice_colint(i) / msft(i) + + IF ( ltg2 .LT. clim2 ) ltg2 = 0. + + IF ( ltg2 .GT. ltg2_max(i) ) THEN + ltg2_max(i) = ltg2 + ENDIF + + ltg3_max(i) = 0.95 * ltg1_max(i) + 0.05 * ltg2_max(i) + + IF ( ltg3_max(i) .LT. clim3 ) ltg3_max(i) = 0. + enddo + + end subroutine lightning_threat_indices + end subroutine maximum_hourly_diagnostics_run subroutine max_fields(phil,ref3D,grav,im,levs,refd,tk,refd263k) diff --git a/physics/maximum_hourly_diagnostics.meta b/physics/maximum_hourly_diagnostics.meta index 391dbde52..33f7eb8f0 100644 --- a/physics/maximum_hourly_diagnostics.meta +++ b/physics/maximum_hourly_diagnostics.meta @@ -238,6 +238,77 @@ type = real kind = kind_phys intent = inout +[vvl] + standard_name = lagrangian_tendency_of_air_pressure + long_name = layer mean vertical velocity + units = Pa s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[qgraupel] + standard_name = graupel_mixing_ratio + long_name = ratio of mass of graupel to mass of dry air plus vapor (without condensates) + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[qsnowwat] + standard_name = snow_mixing_ratio + long_name = ratio of mass of snow water to mass of dry air plus vapor (without condensates) + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[qicewat] + standard_name = cloud_ice_mixing_ratio + long_name = ratio of mass of ice water to mass of dry air plus vapor (without condensates) + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[lightning_threat] + standard_name = lightning_threat_indices_enabled + long_name = lightning threat indices enabled + units = flag + dimensions = () + type = logical + intent = in +[ltg1_max] + standard_name = gsl_lightning_threat_index_1 + long_name = GSL lightning threat index 1 + units = flashes 5 min-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[ltg2_max] + standard_name = gsl_lightning_threat_index_2 + long_name = GSL lightning threat index 2 + units = flashes 5 min-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[ltg3_max] + standard_name = gsl_lightning_threat_index_3 + long_name = GSL lightning threat index 3 + units = flashes 5 min-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[phii] + standard_name = geopotential_at_interface + long_name = geopotential at model layer interfaces + units = m2 s-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 07159470f9254c2dd2a33c46011a5e40aa3a15e9 Mon Sep 17 00:00:00 2001 From: Samuel Trahan Date: Wed, 1 Feb 2023 20:40:32 +0000 Subject: [PATCH 095/380] many changes; code almost works --- physics/maximum_hourly_diagnostics.F90 | 39 +++++++++++++++++++------ physics/maximum_hourly_diagnostics.meta | 15 +++++++--- 2 files changed, 41 insertions(+), 13 deletions(-) diff --git a/physics/maximum_hourly_diagnostics.F90 b/physics/maximum_hourly_diagnostics.F90 index 373c09467..f03ad330f 100644 --- a/physics/maximum_hourly_diagnostics.F90 +++ b/physics/maximum_hourly_diagnostics.F90 @@ -30,11 +30,11 @@ subroutine maximum_hourly_diagnostics_run(im, levs, reset, lradar, imp_physics, u10max, v10max, spd10max, pgr, t2m, q2m, t02max, & t02min, rh02max, rh02min, dtp, rain, pratemax, & lightning_threat, ltg1_max,ltg2_max,ltg3_max, & - vvl, phii, qgraupel, qsnowwat, qicewat, & - errmsg, errflg) + wgrs, phii, qgraupel, qsnowwat, qicewat, & + kdt, errmsg, errflg) ! Interface variables - integer, intent(in) :: im, levs + integer, intent(in) :: im, levs, kdt logical, intent(in) :: reset, lradar, lightning_threat integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_fer_hires, & imp_physics_nssl @@ -60,7 +60,7 @@ subroutine maximum_hourly_diagnostics_run(im, levs, reset, lradar, imp_physics, real(kind_phys), intent(in ) :: rain(:) real(kind_phys), intent(inout) :: pratemax(:) - real(kind_phys), intent(in), dimension(:,:) :: phii, qgraupel, qsnowwat, qicewat, vvl + real(kind_phys), intent(in), dimension(:,:) :: phii, qgraupel, qsnowwat, qicewat, wgrs real(kind_phys), intent(inout), dimension(:) :: ltg1_max, ltg2_max, ltg3_max character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -76,6 +76,7 @@ subroutine maximum_hourly_diagnostics_run(im, levs, reset, lradar, imp_physics, !Lightning threat indices if (lightning_threat) then + print *,'call lightning_threat_indices' call lightning_threat_indices endif @@ -160,27 +161,38 @@ subroutine lightning_threat_indices REAL(kind_phys), PARAMETER :: coef1=0.042*1000.*1.22 REAL(kind_phys), PARAMETER :: coef2=0.20*1.22 - REAL(kind_phys) :: totice_colint(im), msft(im), ltg1, ltg2 + REAL(kind_phys) :: totice_colint(im), msft(im), ltg1, ltg2, high_ltg1, high_wgrs, high_graupel LOGICAL :: ltg1_calc(im) - integer :: k, i + integer :: k, i, count + + count = 0 + high_ltg1 = 0 + high_wgrs = 0 + high_graupel = 0 totice_colint = 0 ltg1_calc = .false. msft = 1. ! get area (m^2) in units of km^2 ! msft = 1.E-6*area - do k=levs,2,-1 + do k=2,levs do i=1,im - dP = phii(i,k) - phii(i,k+1) + dP = phii(i,k+1) - phii(i,k) Q = qgraupel(i,k) + qsnowwat(i,k) + qicewat(i,k) totice_colint(i) = totice_colint(i) + Q * dP / con_g IF ( .not.ltg1_calc(i) ) THEN IF ( 0.5*(phii(i,k-1) - phii(i,k+1)) < 258.15 ) THEN + count = count + 1 ltg1_calc(i) = .true. - ltg1 = coef1*vvl(i,k)* & + ltg1 = coef1*wgrs(i,k)* & (( qgraupel(i,k-1) + qgraupel(i,k) )*0.5 )/msft(i) + high_ltg1 = max(high_ltg1, ltg1) + high_graupel = max(high_graupel, qgraupel(i,k)) + if(abs(wgrs(i,k)) > high_wgrs) then + high_wgrs = wgrs(i,k) + endif IF ( ltg1 .LT. clim1 ) ltg1 = 0. @@ -192,6 +204,15 @@ subroutine lightning_threat_indices enddo enddo + if(count > 0) then + if(high_ltg1 == 0 .and. high_wgrs == 0 .and. high_graupel == 0) then + print *, 'high ltg1, wgrs, and graupel are all 0' + else +183 format('high_ltg1 = ',F30.23,' high_wgrs = ',F30.23,' high_graupel = ',F30.23) + print 183, high_ltg1, high_wgrs, high_graupel + endif + endif + do i=1,im ltg2 = coef2 * totice_colint(i) / msft(i) diff --git a/physics/maximum_hourly_diagnostics.meta b/physics/maximum_hourly_diagnostics.meta index 33f7eb8f0..107281a48 100644 --- a/physics/maximum_hourly_diagnostics.meta +++ b/physics/maximum_hourly_diagnostics.meta @@ -238,10 +238,10 @@ type = real kind = kind_phys intent = inout -[vvl] - standard_name = lagrangian_tendency_of_air_pressure - long_name = layer mean vertical velocity - units = Pa s-1 +[wgrs] + standard_name = z_wind + long_name = vertical wind + units = m s-1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys @@ -309,6 +309,13 @@ type = real kind = kind_phys intent = in +[kdt] + standard_name = index_of_timestep + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 4e66f9f23ccc2948ff7eab983a0671dba1e7f332 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Wed, 1 Feb 2023 22:55:33 +0000 Subject: [PATCH 096/380] revise a debug print --- physics/maximum_hourly_diagnostics.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/maximum_hourly_diagnostics.F90 b/physics/maximum_hourly_diagnostics.F90 index f03ad330f..08f793aad 100644 --- a/physics/maximum_hourly_diagnostics.F90 +++ b/physics/maximum_hourly_diagnostics.F90 @@ -205,8 +205,8 @@ subroutine lightning_threat_indices enddo if(count > 0) then - if(high_ltg1 == 0 .and. high_wgrs == 0 .and. high_graupel == 0) then - print *, 'high ltg1, wgrs, and graupel are all 0' + if(abs(high_wgrs) < 0.1 .or. high_graupel < 1e-4) then + !print *, 'low wgrs or graupel' else 183 format('high_ltg1 = ',F30.23,' high_wgrs = ',F30.23,' high_graupel = ',F30.23) print 183, high_ltg1, high_wgrs, high_graupel From 662eeb1e34bd6f2b59c4c4a4dc257fb816ef8be6 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Fri, 3 Feb 2023 17:09:07 +0000 Subject: [PATCH 097/380] Interface changes for SP build in GP --- physics/rrtmgp_lw_main.F90 | 16 ++++++++-------- physics/rrtmgp_sw_main.F90 | 16 ++++++++-------- 2 files changed, 16 insertions(+), 16 deletions(-) diff --git a/physics/rrtmgp_lw_main.F90 b/physics/rrtmgp_lw_main.F90 index d6b0ab630..c0bc99d35 100644 --- a/physics/rrtmgp_lw_main.F90 +++ b/physics/rrtmgp_lw_main.F90 @@ -7,7 +7,7 @@ !! ! ########################################################################################### module rrtmgp_lw_main - use machine, only: kind_phys + use machine, only: kind_phys, kind_dbl_prec use mo_optical_props, only: ty_optical_props_1scl, ty_optical_props_2str use mo_cloud_optics, only: ty_cloud_optics use mo_rte_lw, only: rte_lw @@ -234,9 +234,9 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, real(kind_phys), dimension(rrtmgp_phys_blksz) :: zcf0, zcf1 logical, dimension(rrtmgp_phys_blksz,nLay,lw_gas_props%get_ngpt()) :: maskMCICA real(kind_phys), dimension(rrtmgp_phys_blksz) :: tau_rain, tau_snow - real(kind_phys), dimension(lw_gas_props%get_ngpt()) :: rng1D - real(kind_phys), dimension(lw_gas_props%get_ngpt(),nLay,rrtmgp_phys_blksz) :: rng3D,rng3D2 - real(kind_phys), dimension(lw_gas_props%get_ngpt()*nLay) :: rng2D + real(kind_dbl_prec), dimension(lw_gas_props%get_ngpt()) :: rng1D + real(kind_dbl_prec), dimension(lw_gas_props%get_ngpt(),nLay,rrtmgp_phys_blksz) :: rng3D,rng3D2 + real(kind_dbl_prec), dimension(lw_gas_props%get_ngpt()*nLay) :: rng2D real(kind_phys), dimension(rrtmgp_phys_blksz,nLay+1,lw_gas_props%get_nband()),target :: & fluxLW_up_allsky, fluxLW_up_clrsky, fluxLW_dn_allsky, fluxLW_dn_clrsky real(kind_phys), dimension(rrtmgp_phys_blksz,lw_gas_props%get_ngpt()) :: lw_Ds @@ -464,7 +464,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, ! Cloud-overlap. ! Maximum-random, random or maximum. if (iovr == iovr_maxrand .or. iovr == iovr_rand .or. iovr == iovr_max) then - call sampled_mask(rng3D, cld_frac(iCol:iCol2,:), maskMCICA) + call sampled_mask(real(rng3D,kind=kind_phys), cld_frac(iCol:iCol2,:), maskMCICA) endif ! Exponential decorrelation length overlap if (iovr == iovr_dcorr) then @@ -475,12 +475,12 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, rng3D2(:,:,ix) = reshape(source = rng2D,shape=[lw_gas_props%get_ngpt(),nLay]) enddo ! - call sampled_mask(rng3D, cld_frac(iCol:iCol2,:), maskMCICA, & - overlap_param = cloud_overlap_param(iCol:iCol2,1:nLay-1), randoms2 = rng3D2) + call sampled_mask(real(rng3D,kind=kind_phys), cld_frac(iCol:iCol2,:), maskMCICA, & + overlap_param = cloud_overlap_param(iCol:iCol2,1:nLay-1), randoms2 = real(rng3D2, kind=kind_phys)) endif ! Exponential or Exponential-random if (iovr == iovr_exp .or. iovr == iovr_exprand) then - call sampled_mask(rng3D, cld_frac(iCol:iCol2,:), maskMCICA, & + call sampled_mask(real(rng3D,kind=kind_phys), cld_frac(iCol:iCol2,:), maskMCICA, & overlap_param = cloud_overlap_param(iCol:iCol2,1:nLay-1)) endif ! Sampling. Map band optical depth to each g-point using McICA diff --git a/physics/rrtmgp_sw_main.F90 b/physics/rrtmgp_sw_main.F90 index 1a5b31e9e..b25e093e7 100644 --- a/physics/rrtmgp_sw_main.F90 +++ b/physics/rrtmgp_sw_main.F90 @@ -1,7 +1,7 @@ ! ########################################################################################### ! ########################################################################################### module rrtmgp_sw_main - use machine, only: kind_phys + use machine, only: kind_phys, kind_dbl_prec use mo_optical_props, only: ty_optical_props_2str use mo_cloud_optics, only: ty_cloud_optics use module_radsw_parameters, only: cmpfsw_type @@ -222,9 +222,9 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ real(kind_phys) :: tau_rain, tau_snow, ssa_rain, ssa_snow, asy_rain, asy_snow, & tau_prec, asy_prec, ssa_prec, asyw, ssaw, za1, za2, flux_dir, flux_dif real(kind_phys), dimension(rrtmgp_phys_blksz) :: zcf0, zcf1 - real(kind_phys), dimension(sw_gas_props%get_ngpt()) :: rng1D - real(kind_phys), dimension(sw_gas_props%get_ngpt(),nLay,rrtmgp_phys_blksz) :: rng3D,rng3D2 - real(kind_phys), dimension(sw_gas_props%get_ngpt()*nLay) :: rng2D + real(kind_dbl_prec), dimension(sw_gas_props%get_ngpt()) :: rng1D + real(kind_dbl_prec), dimension(sw_gas_props%get_ngpt(),nLay,rrtmgp_phys_blksz) :: rng3D,rng3D2 + real(kind_dbl_prec), dimension(sw_gas_props%get_ngpt()*nLay) :: rng2D logical, dimension(rrtmgp_phys_blksz,nLay,sw_gas_props%get_ngpt()) :: maskMCICA logical :: cloudy_column, clear_column real(kind_phys), dimension(sw_gas_props%get_nband(),rrtmgp_phys_blksz) :: & @@ -505,7 +505,7 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ ! Cloud-overlap. ! Maximum-random, random or maximum. if (iovr == iovr_maxrand .or. iovr == iovr_rand .or. iovr == iovr_max) then - call sampled_mask(rng3D, cld_frac(iCols,:), maskMCICA) + call sampled_mask(real(rng3D, kind=kind_phys), cld_frac(iCols,:), maskMCICA) endif ! Exponential decorrelation length overlap if (iovr == iovr_dcorr) then @@ -516,12 +516,12 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ rng3D2(:,:,iblck) = reshape(source = rng2D,shape=[sw_gas_props%get_ngpt(),nLay]) enddo ! - call sampled_mask(rng3D, cld_frac(iCols,:), maskMCICA, & - overlap_param = cloud_overlap_param(iCols,1:nLay-1), randoms2 = rng3D2) + call sampled_mask(real(rng3D, kind=kind_phys), cld_frac(iCols,:), maskMCICA, & + overlap_param = cloud_overlap_param(iCols,1:nLay-1), randoms2 = real(rng3D2, kind=kind_phys)) endif ! Exponential or Exponential-random if (iovr == iovr_exp .or. iovr == iovr_exprand) then - call sampled_mask(rng3D, cld_frac(iCols,:), maskMCICA, & + call sampled_mask(real(rng3D, kind=kind_phys), cld_frac(iCols,:), maskMCICA, & overlap_param = cloud_overlap_param(iCols,1:nLay-1)) endif ! Sampling. Map band optical depth to each g-point using McICA From 08dd5a623396ace4ad6987e96f31dbc12199670e Mon Sep 17 00:00:00 2001 From: drnimbusrain Date: Tue, 7 Feb 2023 11:15:19 -0500 Subject: [PATCH 098/380] Updated to modify TKE instead of K for canopy. --- physics/satmedmfvdifq.F | 265 ++++++++++++++++++++++++++-------------- 1 file changed, 176 insertions(+), 89 deletions(-) diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index dd17adcfe..37cc87764 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -1212,95 +1212,97 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & ! enddo enddo - !PCC_CANOPY------------------------------------ - do k = 1, 1km1 - do i=1,im - FCH = canheight(i) !Input canopy height for grid cell i - IF (k .EQ. 1) THEN !first model layer -! Check for Contiguous Canopy Grid Cells - IF ( FCH .LT. 10.0 -! IF ( LAI .LT. 0.1 -! & .OR. FCH .LT. 0.5 -! & .OR. FCH .LT. 10.0 -! & .OR. MAX(0.0, 1.0 - FRT) .GT. 0.5 -! & .OR. POPU .GT. 10000.0 -! & .OR. EXP(-0.5*LAI*CLU).GT. 0.45 -! & .AND. FCH .LT. 18.0 ) THEN !not a contigous canopy cell - dkt(i,k)= dkt(i,k) - dkq(i,k)= dkq(i,k) - ELSE ! There is a contiguous forest canopy, -! apply correction over canopy layers -!Raupauch M. R. A Practical Lagrangian method for relating scalar -!concentrations to -! source distributions in vegetation canopies. Q. J. R. Meteor. Soc. -! (1989), 115, pp 609-632 - MOL = zol(i)/zl(i,k) !Monin-Obukhov Length - HOL = FCH/MOL !local canopy stability parameter (hc/MOL) - ZCAN = zl(i,k) ! Initialize canopy top (m) = First model layer height above canopy - COUNTCAN = 0 ! Initialize canopy layers - DO WHILE (ZCAN.GE.0.5) !canopy threshold >= 0.5 m - ! TLCAN = Lagrangian timescale - TLCAN = (FCH/ustar(i)) * ( - & (0.256 * (ZCAN-(0.75*FCH))/FCH ) + - & (0.492*EXP((-0.256*ZCAN/FCH)/0.492)) ) - IF ( HOL .LT. -0.1 ) THEN !STRONG UNSTABLE - IF ( ZCAN/FCH .GT. 1.25 ) THEN !SIGMACAN = Eulerian vertical velocity variance - SIGMACAN = 1.25*ustar(i) - END IF - IF ( ZCAN/FCH .GE. 0.175 .AND. ZCAN/FCH .LE. 1.25 ) THEN - SIGMACAN = ustar(i) * ( 0.75 + (0.5 * COS((PICAN/1.06818) * - & (1.25 - (ZCAN/FCH)))) ) - END IF - IF ( ZCAN/FCH .LT. 0.175 ) THEN - SIGMACAN = 0.25*ustar(i) - END IF - END IF - IF ( HOL .GE. -0.1 .AND. HOL .LT. 0.1 ) THEN !WEAKLY UNSTABLE to NEUTRAL - IF ( ZCAN/FCH .GT. 1.25 ) THEN - SIGMACAN = 1.0*ustar(i) - END IF - IF ( ZCAN/FCH .GE. 0.175 .AND. ZCAN/FCH .LE. 1.25 ) THEN - SIGMACAN = ustar(i) * ( 0.625 + (0.375* COS((PICAN/1.06818) * - & (1.25 - (ZCAN/FCH)))) ) - END IF - IF ( ZCAN/FCH .LT. 0.175 ) THEN - SIGMACAN = 0.25*ustar(i) - END IF - END IF - IF ( HOL .GE. 0.1 .AND. HOL .LT. 0.9 ) THEN !STABLE - IF ( ZCAN/FCH .GT. 1.25 ) THEN - SIGMACAN = 0.25*(4.375 - (3.75*HOL))*ustar(i) - END IF - IF ( ZCAN/FCH .GE. 0.175 .AND. ZCAN/FCH .LE. 1.25 ) THEN - RRCAN=4.375-(3.75*HOL) - AACAN=(0.125*RRCAN) + 0.125 - BBCAN=(0.125*RRCAN) - 0.125 - SIGMACAN = ustar(i) * ( AACAN + (BBCAN * COS((PICAN/1.06818) * - & (1.25 - (ZCAN/FCH)))) ) - END IF - IF ( ZCAN/FCH .LT. 0.175 ) THEN - SIGMACAN = 0.25*ustar(i) - END IF - END IF - IF ( HOL .GE. 0.9 ) THEN !VERY STABLE - SIGMACAN = 0.25*ustar(i) - END IF - IF ( ZCAN .EQ. ZFL ) THEN ! First model layer above canopy - EDDYVEST1 = (SIGMACAN*SIGMACAN)*TLCAN - ELSE IF ( ZCAN .LE. FCH ) THEN !in-canopy layers and set arrays - COUNTCAN = COUNTCAN + 1 - ZCANX (COUNTCAN) = ZCAN - EDDYVESTX (COUNTCAN) = (SIGMACAN*SIGMACAN)*TLCAN - END IF - ZCAN = ZCAN-0.5 !step down in-canopy resolution of 0.5m - END DO !end loop on canopy layers - EDDYVEST_INT = IntegrateTrapezoid((ZCANX(COUNTCAN:1:-1)/FCH),EDDYVESTX(COUNTCAN:1:-1)) - dkt(i,k)= (dkt(i,k)/EDDYVEST1) * EDDYVEST_INT !Scale dkt to resolved eddy diffusivity - dkq(i,k)= (dkq(i,k)/EDDYVEST1) * EDDYVEST_INT !Scale dku to resolved eddy diffusivity - END IF !contigous canopy conditions - END IF ! first model layer scaled canopy - enddo !i - enddo !k +! !PCC_CANOPY------------------------------------ +! do k = 1, 1km1 +! do i=1,im +! FCH = canheight(i) !Input canopy height for grid cell i +! IF (k .EQ. 1) THEN !first model layer +!! Check for Contiguous Canopy Grid Cells +! IF ( FCH .LT. 0.5 +!! IF ( LAI .LT. 0.1 +!! & .OR. FCH .LT. 0.5 +!! & .OR. FCH .LT. 10.0 +!! & .OR. MAX(0.0, 1.0 - FRT) .GT. 0.5 +!! & .OR. POPU .GT. 10000.0 +!! & .OR. EXP(-0.5*LAI*CLU).GT. 0.45 +!! & .AND. FCH .LT. 18.0 ) THEN !not a contigous canopy cell +! dkt(i,k)= dkt(i,k) +! dkq(i,k)= dkq(i,k) +! dku(i,k)= dku(i,k) +! ELSE ! There is a contiguous forest canopy, +!! apply correction over canopy layers +!!Raupauch M. R. A Practical Lagrangian method for relating scalar +!!concentrations to +!! source distributions in vegetation canopies. Q. J. R. Meteor. Soc. +!! (1989), 115, pp 609-632 +! MOL = zol(i)/zl(i,k) !Monin-Obukhov Length +! HOL = FCH/MOL !local canopy stability parameter (hc/MOL) +! ZCAN = zl(i,k) ! Initialize canopy top (m) = First model layer height above canopy +! COUNTCAN = 0 ! Initialize canopy layers +! DO WHILE (ZCAN.GE.0.5) !canopy threshold >= 0.5 m +! ! TLCAN = Lagrangian timescale +! TLCAN = (FCH/ustar(i)) * ( +! & (0.256 * (ZCAN-(0.75*FCH))/FCH ) + +! & (0.492*EXP((-0.256*ZCAN/FCH)/0.492)) ) +! IF ( HOL .LT. -0.1 ) THEN !STRONG UNSTABLE +! IF ( ZCAN/FCH .GT. 1.25 ) THEN !SIGMACAN = Eulerian vertical velocity variance +! SIGMACAN = 1.25*ustar(i) +! END IF +! IF ( ZCAN/FCH .GE. 0.175 .AND. ZCAN/FCH .LE. 1.25 ) THEN +! SIGMACAN = ustar(i) * ( 0.75 + (0.5 * COS((PICAN/1.06818) * +! & (1.25 - (ZCAN/FCH)))) ) +! END IF +! IF ( ZCAN/FCH .LT. 0.175 ) THEN +! SIGMACAN = 0.25*ustar(i) +! END IF +! END IF +! IF ( HOL .GE. -0.1 .AND. HOL .LT. 0.1 ) THEN !WEAKLY UNSTABLE to NEUTRAL +! IF ( ZCAN/FCH .GT. 1.25 ) THEN +! SIGMACAN = 1.0*ustar(i) +! END IF +! IF ( ZCAN/FCH .GE. 0.175 .AND. ZCAN/FCH .LE. 1.25 ) THEN +! SIGMACAN = ustar(i) * ( 0.625 + (0.375* COS((PICAN/1.06818) * +! & (1.25 - (ZCAN/FCH)))) ) +! END IF +! IF ( ZCAN/FCH .LT. 0.175 ) THEN +! SIGMACAN = 0.25*ustar(i) +! END IF +! END IF +! IF ( HOL .GE. 0.1 .AND. HOL .LT. 0.9 ) THEN !STABLE +! IF ( ZCAN/FCH .GT. 1.25 ) THEN +! SIGMACAN = 0.25*(4.375 - (3.75*HOL))*ustar(i) +! END IF +! IF ( ZCAN/FCH .GE. 0.175 .AND. ZCAN/FCH .LE. 1.25 ) THEN +! RRCAN=4.375-(3.75*HOL) +! AACAN=(0.125*RRCAN) + 0.125 +! BBCAN=(0.125*RRCAN) - 0.125 +! SIGMACAN = ustar(i) * ( AACAN + (BBCAN * COS((PICAN/1.06818) * +! & (1.25 - (ZCAN/FCH)))) ) +! END IF +! IF ( ZCAN/FCH .LT. 0.175 ) THEN +! SIGMACAN = 0.25*ustar(i) +! END IF +! END IF +! IF ( HOL .GE. 0.9 ) THEN !VERY STABLE +! SIGMACAN = 0.25*ustar(i) +! END IF +! IF ( ZCAN .EQ. ZFL ) THEN ! First model layer above canopy +! EDDYVEST1 = (SIGMACAN*SIGMACAN)*TLCAN +! ELSE IF ( ZCAN .LE. FCH ) THEN !in-canopy layers and set arrays +! COUNTCAN = COUNTCAN + 1 +! ZCANX (COUNTCAN) = ZCAN +! EDDYVESTX (COUNTCAN) = (SIGMACAN*SIGMACAN)*TLCAN +! END IF +! ZCAN = ZCAN-0.5 !step down in-canopy resolution of 0.5m +! END DO !end loop on canopy layers +! EDDYVEST_INT = IntegrateTrapezoid((ZCANX(COUNTCAN:1:-1)/FCH),EDDYVESTX(COUNTCAN:1:-1)) +! dkt(i,k)= (dkt(i,k)/EDDYVEST1) * EDDYVEST_INT !Scale dkt to resolved eddy diffusivity +! dkq(i,k)= (dkq(i,k)/EDDYVEST1) * EDDYVEST_INT !Scale dkq to resolved eddy diffusivity +! dku(i,k)= (dkq(i,k)/EDDYVEST1) * EDDYVEST_INT !Scale dku to resolved eddy diffusivity +! END IF !contigous canopy conditions +! END IF ! first model layer scaled canopy +! enddo !i +! enddo !k !> ## Compute TKE. !! - Compute a minimum TKE deduced from background diffusivity for momentum. ! @@ -1571,8 +1573,93 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & do k=1,kps do i=1,im tkeh(i,k) = 0.5 * (tke(i,k)+tke(i,k+1)) + !PCC_CANOPY + FCH = canheight(i) !Input canopy height for grid cell i + IF (k .EQ. 1) THEN !first model layer +! Check for Contiguous Canopy Grid Cells + IF ( FCH .LT. 0.5 +! IF ( LAI .LT. 0.1 +! & .OR. FCH .LT. 0.5 +! & .OR. FCH .LT. 10.0 +! & .OR. MAX(0.0, 1.0 - FRT) .GT. 0.5 +! & .OR. POPU .GT. 10000.0 +! & .OR. EXP(-0.5*LAI*CLU).GT. 0.45 +! & .AND. FCH .LT. 18.0 ) THEN !not a contigous canopy cell + tkeh(i,k) = tkeh(i,k) + ELSE ! There is a contiguous forest canopy, +! apply correction over canopy layers +!Raupauch M. R. A Practical Lagrangian method for relating scalar +!concentrations to +! source distributions in vegetation canopies. Q. J. R. Meteor. Soc. +! (1989), 115, pp 609-632 + MOL = zol(i)/zl(i,k) !Monin-Obukhov Length + HOL = FCH/MOL !local canopy stability parameter (hc/MOL) + ZCAN = zl(i,k) ! Initialize canopy top (m) = First model layer height above canopy + COUNTCAN = 0 ! Initialize canopy layers + DO WHILE (ZCAN.GE.0.5) !canopy threshold >= 0.5 m + ! TLCAN = Lagrangian timescale + TLCAN = (FCH/ustar(i)) * ( + & (0.256 * (ZCAN-(0.75*FCH))/FCH ) + + & (0.492*EXP((-0.256*ZCAN/FCH)/0.492)) ) + IF ( HOL .LT. -0.1 ) THEN !STRONG UNSTABLE + IF ( ZCAN/FCH .GT. 1.25 ) THEN !SIGMACAN = Eulerian vertical velocity variance + SIGMACAN = 1.25*ustar(i) + END IF + IF ( ZCAN/FCH .GE. 0.175 .AND. ZCAN/FCH .LE. 1.25 ) THEN + SIGMACAN = ustar(i) * ( 0.75 + (0.5 * COS((PICAN/1.06818) * + & (1.25 - (ZCAN/FCH)))) ) + END IF + IF ( ZCAN/FCH .LT. 0.175 ) THEN + SIGMACAN = 0.25*ustar(i) + END IF + END IF + IF ( HOL .GE. -0.1 .AND. HOL .LT. 0.1 ) THEN !WEAKLY UNSTABLE to NEUTRAL + IF ( ZCAN/FCH .GT. 1.25 ) THEN + SIGMACAN = 1.0*ustar(i) + END IF + IF ( ZCAN/FCH .GE. 0.175 .AND. ZCAN/FCH .LE. 1.25 ) THEN + SIGMACAN = ustar(i) * ( 0.625 + (0.375* COS((PICAN/1.06818) * + & (1.25 - (ZCAN/FCH)))) ) + END IF + IF ( ZCAN/FCH .LT. 0.175 ) THEN + SIGMACAN = 0.25*ustar(i) + END IF + END IF + IF ( HOL .GE. 0.1 .AND. HOL .LT. 0.9 ) THEN !STABLE + IF ( ZCAN/FCH .GT. 1.25 ) THEN + SIGMACAN = 0.25*(4.375 - (3.75*HOL))*ustar(i) + END IF + IF ( ZCAN/FCH .GE. 0.175 .AND. ZCAN/FCH .LE. 1.25 ) THEN + RRCAN=4.375-(3.75*HOL) + AACAN=(0.125*RRCAN) + 0.125 + BBCAN=(0.125*RRCAN) - 0.125 + SIGMACAN = ustar(i) * ( AACAN + (BBCAN * COS((PICAN/1.06818) * + & (1.25 - (ZCAN/FCH)))) ) + END IF + IF ( ZCAN/FCH .LT. 0.175 ) THEN + SIGMACAN = 0.25*ustar(i) + END IF + END IF + IF ( HOL .GE. 0.9 ) THEN !VERY STABLE + SIGMACAN = 0.25*ustar(i) + END IF + IF ( ZCAN .EQ. ZFL ) THEN ! First model layer above canopy + EDDYVEST1 = (SIGMACAN*SIGMACAN)*TLCAN + ELSE IF ( ZCAN .LE. FCH ) THEN !in-canopy layers and set arrays + COUNTCAN = COUNTCAN + 1 + ZCANX (COUNTCAN) = ZCAN + EDDYVESTX (COUNTCAN) = (SIGMACAN*SIGMACAN)*TLCAN + END IF + ZCAN = ZCAN-0.5 !step down in-canopy resolution of 0.5m + END DO !end loop on canopy layers + EDDYVEST_INT = IntegrateTrapezoid((ZCANX(COUNTCAN:1:-1)/FCH),EDDYVESTX(COUNTCAN:1:-1)) + tkeh(i,k)= (tkeh(i,k)/EDDYVEST1) * EDDYVEST_INT !Scale tke to fractional K profile + !at layer centers, tkeh + END IF !contigous canopy conditions + END IF ! first model layer scaled canopy enddo enddo + do k=1,kps do i=1,im e_diff(i,k) = tke(i,k) - tke(i,k+1) From 22d3fd7341a4fe83c7773172fdf2169ae5bf228c Mon Sep 17 00:00:00 2001 From: drnimbusrain Date: Tue, 7 Feb 2023 11:25:42 -0500 Subject: [PATCH 099/380] Rolled back to modifying K directly for canopy effects. --- physics/satmedmfvdifq.F | 266 ++++++++++++++-------------------------- 1 file changed, 91 insertions(+), 175 deletions(-) diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index 37cc87764..edf66d094 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -1212,97 +1212,97 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & ! enddo enddo -! !PCC_CANOPY------------------------------------ -! do k = 1, 1km1 -! do i=1,im -! FCH = canheight(i) !Input canopy height for grid cell i -! IF (k .EQ. 1) THEN !first model layer -!! Check for Contiguous Canopy Grid Cells -! IF ( FCH .LT. 0.5 -!! IF ( LAI .LT. 0.1 -!! & .OR. FCH .LT. 0.5 -!! & .OR. FCH .LT. 10.0 -!! & .OR. MAX(0.0, 1.0 - FRT) .GT. 0.5 -!! & .OR. POPU .GT. 10000.0 -!! & .OR. EXP(-0.5*LAI*CLU).GT. 0.45 -!! & .AND. FCH .LT. 18.0 ) THEN !not a contigous canopy cell -! dkt(i,k)= dkt(i,k) -! dkq(i,k)= dkq(i,k) -! dku(i,k)= dku(i,k) -! ELSE ! There is a contiguous forest canopy, -!! apply correction over canopy layers -!!Raupauch M. R. A Practical Lagrangian method for relating scalar -!!concentrations to -!! source distributions in vegetation canopies. Q. J. R. Meteor. Soc. -!! (1989), 115, pp 609-632 -! MOL = zol(i)/zl(i,k) !Monin-Obukhov Length -! HOL = FCH/MOL !local canopy stability parameter (hc/MOL) -! ZCAN = zl(i,k) ! Initialize canopy top (m) = First model layer height above canopy -! COUNTCAN = 0 ! Initialize canopy layers -! DO WHILE (ZCAN.GE.0.5) !canopy threshold >= 0.5 m -! ! TLCAN = Lagrangian timescale -! TLCAN = (FCH/ustar(i)) * ( -! & (0.256 * (ZCAN-(0.75*FCH))/FCH ) + -! & (0.492*EXP((-0.256*ZCAN/FCH)/0.492)) ) -! IF ( HOL .LT. -0.1 ) THEN !STRONG UNSTABLE -! IF ( ZCAN/FCH .GT. 1.25 ) THEN !SIGMACAN = Eulerian vertical velocity variance -! SIGMACAN = 1.25*ustar(i) -! END IF -! IF ( ZCAN/FCH .GE. 0.175 .AND. ZCAN/FCH .LE. 1.25 ) THEN -! SIGMACAN = ustar(i) * ( 0.75 + (0.5 * COS((PICAN/1.06818) * -! & (1.25 - (ZCAN/FCH)))) ) -! END IF -! IF ( ZCAN/FCH .LT. 0.175 ) THEN -! SIGMACAN = 0.25*ustar(i) -! END IF -! END IF -! IF ( HOL .GE. -0.1 .AND. HOL .LT. 0.1 ) THEN !WEAKLY UNSTABLE to NEUTRAL -! IF ( ZCAN/FCH .GT. 1.25 ) THEN -! SIGMACAN = 1.0*ustar(i) -! END IF -! IF ( ZCAN/FCH .GE. 0.175 .AND. ZCAN/FCH .LE. 1.25 ) THEN -! SIGMACAN = ustar(i) * ( 0.625 + (0.375* COS((PICAN/1.06818) * -! & (1.25 - (ZCAN/FCH)))) ) -! END IF -! IF ( ZCAN/FCH .LT. 0.175 ) THEN -! SIGMACAN = 0.25*ustar(i) -! END IF -! END IF -! IF ( HOL .GE. 0.1 .AND. HOL .LT. 0.9 ) THEN !STABLE -! IF ( ZCAN/FCH .GT. 1.25 ) THEN -! SIGMACAN = 0.25*(4.375 - (3.75*HOL))*ustar(i) -! END IF -! IF ( ZCAN/FCH .GE. 0.175 .AND. ZCAN/FCH .LE. 1.25 ) THEN -! RRCAN=4.375-(3.75*HOL) -! AACAN=(0.125*RRCAN) + 0.125 -! BBCAN=(0.125*RRCAN) - 0.125 -! SIGMACAN = ustar(i) * ( AACAN + (BBCAN * COS((PICAN/1.06818) * -! & (1.25 - (ZCAN/FCH)))) ) -! END IF -! IF ( ZCAN/FCH .LT. 0.175 ) THEN -! SIGMACAN = 0.25*ustar(i) -! END IF -! END IF -! IF ( HOL .GE. 0.9 ) THEN !VERY STABLE -! SIGMACAN = 0.25*ustar(i) -! END IF -! IF ( ZCAN .EQ. ZFL ) THEN ! First model layer above canopy -! EDDYVEST1 = (SIGMACAN*SIGMACAN)*TLCAN -! ELSE IF ( ZCAN .LE. FCH ) THEN !in-canopy layers and set arrays -! COUNTCAN = COUNTCAN + 1 -! ZCANX (COUNTCAN) = ZCAN -! EDDYVESTX (COUNTCAN) = (SIGMACAN*SIGMACAN)*TLCAN -! END IF -! ZCAN = ZCAN-0.5 !step down in-canopy resolution of 0.5m -! END DO !end loop on canopy layers -! EDDYVEST_INT = IntegrateTrapezoid((ZCANX(COUNTCAN:1:-1)/FCH),EDDYVESTX(COUNTCAN:1:-1)) -! dkt(i,k)= (dkt(i,k)/EDDYVEST1) * EDDYVEST_INT !Scale dkt to resolved eddy diffusivity -! dkq(i,k)= (dkq(i,k)/EDDYVEST1) * EDDYVEST_INT !Scale dkq to resolved eddy diffusivity -! dku(i,k)= (dkq(i,k)/EDDYVEST1) * EDDYVEST_INT !Scale dku to resolved eddy diffusivity -! END IF !contigous canopy conditions -! END IF ! first model layer scaled canopy -! enddo !i -! enddo !k + !PCC_CANOPY------------------------------------ + do k = 1, 1km1 + do i=1,im + FCH = canheight(i) !Input canopy height for grid cell i + IF (k .EQ. 1) THEN !first model layer +! Check for Contiguous Canopy Grid Cells + IF ( FCH .LT. 0.5 +! IF ( LAI .LT. 0.1 +! & .OR. FCH .LT. 0.5 +! & .OR. FCH .LT. 10.0 +! & .OR. MAX(0.0, 1.0 - FRT) .GT. 0.5 +! & .OR. POPU .GT. 10000.0 +! & .OR. EXP(-0.5*LAI*CLU).GT. 0.45 +! & .AND. FCH .LT. 18.0 ) THEN !not a contigous canopy cell + dkt(i,k)= dkt(i,k) + dkq(i,k)= dkq(i,k) + dku(i,k)= dku(i,k) + ELSE ! There is a contiguous forest canopy, +! apply correction over canopy layers +!Raupauch M. R. A Practical Lagrangian method for relating scalar +!concentrations to +! source distributions in vegetation canopies. Q. J. R. Meteor. Soc. +! (1989), 115, pp 609-632 + MOL = zol(i)/zl(i,k) !Monin-Obukhov Length + HOL = FCH/MOL !local canopy stability parameter (hc/MOL) + ZCAN = zl(i,k) ! Initialize canopy top (m) = First model layer height above canopy + COUNTCAN = 0 ! Initialize canopy layers + DO WHILE (ZCAN.GE.0.5) !canopy threshold >= 0.5 m + ! TLCAN = Lagrangian timescale + TLCAN = (FCH/ustar(i)) * ( + & (0.256 * (ZCAN-(0.75*FCH))/FCH ) + + & (0.492*EXP((-0.256*ZCAN/FCH)/0.492)) ) + IF ( HOL .LT. -0.1 ) THEN !STRONG UNSTABLE + IF ( ZCAN/FCH .GT. 1.25 ) THEN !SIGMACAN = Eulerian vertical velocity variance + SIGMACAN = 1.25*ustar(i) + END IF + IF ( ZCAN/FCH .GE. 0.175 .AND. ZCAN/FCH .LE. 1.25 ) THEN + SIGMACAN = ustar(i) * ( 0.75 + (0.5 * COS((PICAN/1.06818) * + & (1.25 - (ZCAN/FCH)))) ) + END IF + IF ( ZCAN/FCH .LT. 0.175 ) THEN + SIGMACAN = 0.25*ustar(i) + END IF + END IF + IF ( HOL .GE. -0.1 .AND. HOL .LT. 0.1 ) THEN !WEAKLY UNSTABLE to NEUTRAL + IF ( ZCAN/FCH .GT. 1.25 ) THEN + SIGMACAN = 1.0*ustar(i) + END IF + IF ( ZCAN/FCH .GE. 0.175 .AND. ZCAN/FCH .LE. 1.25 ) THEN + SIGMACAN = ustar(i) * ( 0.625 + (0.375* COS((PICAN/1.06818) * + & (1.25 - (ZCAN/FCH)))) ) + END IF + IF ( ZCAN/FCH .LT. 0.175 ) THEN + SIGMACAN = 0.25*ustar(i) + END IF + END IF + IF ( HOL .GE. 0.1 .AND. HOL .LT. 0.9 ) THEN !STABLE + IF ( ZCAN/FCH .GT. 1.25 ) THEN + SIGMACAN = 0.25*(4.375 - (3.75*HOL))*ustar(i) + END IF + IF ( ZCAN/FCH .GE. 0.175 .AND. ZCAN/FCH .LE. 1.25 ) THEN + RRCAN=4.375-(3.75*HOL) + AACAN=(0.125*RRCAN) + 0.125 + BBCAN=(0.125*RRCAN) - 0.125 + SIGMACAN = ustar(i) * ( AACAN + (BBCAN * COS((PICAN/1.06818) * + & (1.25 - (ZCAN/FCH)))) ) + END IF + IF ( ZCAN/FCH .LT. 0.175 ) THEN + SIGMACAN = 0.25*ustar(i) + END IF + END IF + IF ( HOL .GE. 0.9 ) THEN !VERY STABLE + SIGMACAN = 0.25*ustar(i) + END IF + IF ( ZCAN .EQ. ZFL ) THEN ! First model layer above canopy + EDDYVEST1 = (SIGMACAN*SIGMACAN)*TLCAN + ELSE IF ( ZCAN .LE. FCH ) THEN !in-canopy layers and set arrays + COUNTCAN = COUNTCAN + 1 + ZCANX (COUNTCAN) = ZCAN + EDDYVESTX (COUNTCAN) = (SIGMACAN*SIGMACAN)*TLCAN + END IF + ZCAN = ZCAN-0.5 !step down in-canopy resolution of 0.5m + END DO !end loop on canopy layers + EDDYVEST_INT = IntegrateTrapezoid((ZCANX(COUNTCAN:1:-1)/FCH),EDDYVESTX(COUNTCAN:1:-1)) + dkt(i,k)= (dkt(i,k)/EDDYVEST1) * EDDYVEST_INT !Scale dkt to resolved eddy diffusivity + dkq(i,k)= (dkq(i,k)/EDDYVEST1) * EDDYVEST_INT !Scale dkq to resolved eddy diffusivity + dku(i,k)= (dkq(i,k)/EDDYVEST1) * EDDYVEST_INT !Scale dku to resolved eddy diffusivity + END IF !contigous canopy conditions + END IF ! first model layer scaled canopy + enddo !i + enddo !k !> ## Compute TKE. !! - Compute a minimum TKE deduced from background diffusivity for momentum. ! @@ -1573,90 +1573,6 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & do k=1,kps do i=1,im tkeh(i,k) = 0.5 * (tke(i,k)+tke(i,k+1)) - !PCC_CANOPY - FCH = canheight(i) !Input canopy height for grid cell i - IF (k .EQ. 1) THEN !first model layer -! Check for Contiguous Canopy Grid Cells - IF ( FCH .LT. 0.5 -! IF ( LAI .LT. 0.1 -! & .OR. FCH .LT. 0.5 -! & .OR. FCH .LT. 10.0 -! & .OR. MAX(0.0, 1.0 - FRT) .GT. 0.5 -! & .OR. POPU .GT. 10000.0 -! & .OR. EXP(-0.5*LAI*CLU).GT. 0.45 -! & .AND. FCH .LT. 18.0 ) THEN !not a contigous canopy cell - tkeh(i,k) = tkeh(i,k) - ELSE ! There is a contiguous forest canopy, -! apply correction over canopy layers -!Raupauch M. R. A Practical Lagrangian method for relating scalar -!concentrations to -! source distributions in vegetation canopies. Q. J. R. Meteor. Soc. -! (1989), 115, pp 609-632 - MOL = zol(i)/zl(i,k) !Monin-Obukhov Length - HOL = FCH/MOL !local canopy stability parameter (hc/MOL) - ZCAN = zl(i,k) ! Initialize canopy top (m) = First model layer height above canopy - COUNTCAN = 0 ! Initialize canopy layers - DO WHILE (ZCAN.GE.0.5) !canopy threshold >= 0.5 m - ! TLCAN = Lagrangian timescale - TLCAN = (FCH/ustar(i)) * ( - & (0.256 * (ZCAN-(0.75*FCH))/FCH ) + - & (0.492*EXP((-0.256*ZCAN/FCH)/0.492)) ) - IF ( HOL .LT. -0.1 ) THEN !STRONG UNSTABLE - IF ( ZCAN/FCH .GT. 1.25 ) THEN !SIGMACAN = Eulerian vertical velocity variance - SIGMACAN = 1.25*ustar(i) - END IF - IF ( ZCAN/FCH .GE. 0.175 .AND. ZCAN/FCH .LE. 1.25 ) THEN - SIGMACAN = ustar(i) * ( 0.75 + (0.5 * COS((PICAN/1.06818) * - & (1.25 - (ZCAN/FCH)))) ) - END IF - IF ( ZCAN/FCH .LT. 0.175 ) THEN - SIGMACAN = 0.25*ustar(i) - END IF - END IF - IF ( HOL .GE. -0.1 .AND. HOL .LT. 0.1 ) THEN !WEAKLY UNSTABLE to NEUTRAL - IF ( ZCAN/FCH .GT. 1.25 ) THEN - SIGMACAN = 1.0*ustar(i) - END IF - IF ( ZCAN/FCH .GE. 0.175 .AND. ZCAN/FCH .LE. 1.25 ) THEN - SIGMACAN = ustar(i) * ( 0.625 + (0.375* COS((PICAN/1.06818) * - & (1.25 - (ZCAN/FCH)))) ) - END IF - IF ( ZCAN/FCH .LT. 0.175 ) THEN - SIGMACAN = 0.25*ustar(i) - END IF - END IF - IF ( HOL .GE. 0.1 .AND. HOL .LT. 0.9 ) THEN !STABLE - IF ( ZCAN/FCH .GT. 1.25 ) THEN - SIGMACAN = 0.25*(4.375 - (3.75*HOL))*ustar(i) - END IF - IF ( ZCAN/FCH .GE. 0.175 .AND. ZCAN/FCH .LE. 1.25 ) THEN - RRCAN=4.375-(3.75*HOL) - AACAN=(0.125*RRCAN) + 0.125 - BBCAN=(0.125*RRCAN) - 0.125 - SIGMACAN = ustar(i) * ( AACAN + (BBCAN * COS((PICAN/1.06818) * - & (1.25 - (ZCAN/FCH)))) ) - END IF - IF ( ZCAN/FCH .LT. 0.175 ) THEN - SIGMACAN = 0.25*ustar(i) - END IF - END IF - IF ( HOL .GE. 0.9 ) THEN !VERY STABLE - SIGMACAN = 0.25*ustar(i) - END IF - IF ( ZCAN .EQ. ZFL ) THEN ! First model layer above canopy - EDDYVEST1 = (SIGMACAN*SIGMACAN)*TLCAN - ELSE IF ( ZCAN .LE. FCH ) THEN !in-canopy layers and set arrays - COUNTCAN = COUNTCAN + 1 - ZCANX (COUNTCAN) = ZCAN - EDDYVESTX (COUNTCAN) = (SIGMACAN*SIGMACAN)*TLCAN - END IF - ZCAN = ZCAN-0.5 !step down in-canopy resolution of 0.5m - END DO !end loop on canopy layers - EDDYVEST_INT = IntegrateTrapezoid((ZCANX(COUNTCAN:1:-1)/FCH),EDDYVESTX(COUNTCAN:1:-1)) - tkeh(i,k)= (tkeh(i,k)/EDDYVEST1) * EDDYVEST_INT !Scale tke to fractional K profile - !at layer centers, tkeh - END IF !contigous canopy conditions - END IF ! first model layer scaled canopy enddo enddo From 2ffa0f547335fe127be678d72509b8bbeed63e21 Mon Sep 17 00:00:00 2001 From: ChunxiZhang-NOAA <49283036+ChunxiZhang-NOAA@users.noreply.github.com> Date: Tue, 7 Feb 2023 09:49:16 -0500 Subject: [PATCH 100/380] Merge pull request #34 from dustinswales/rrtmgp_refactor RRTMGP refactoring --- .gitmodules | 2 +- CMakeLists.txt | 12 - physics/GFS_rrtmgp_cloud_mp.F90 | 48 +- physics/GFS_rrtmgp_cloud_mp.meta | 6 +- physics/GFS_rrtmgp_lw_post.F90 | 188 ----- physics/GFS_rrtmgp_lw_post.meta | 253 ------- physics/GFS_rrtmgp_post.F90 | 394 ++++++++++ ...tmgp_sw_post.meta => GFS_rrtmgp_post.meta} | 191 ++++- physics/GFS_rrtmgp_pre.F90 | 118 +-- physics/GFS_rrtmgp_pre.meta | 136 ++-- physics/GFS_rrtmgp_setup.F90 | 6 +- physics/GFS_rrtmgp_setup.meta | 2 +- physics/GFS_rrtmgp_sw_post.F90 | 286 -------- physics/GFS_rrtmgp_sw_pre.F90 | 95 --- physics/GFS_rrtmgp_sw_pre.meta | 124 ---- physics/rrtmgp_aerosol_optics.F90 | 66 +- physics/rrtmgp_aerosol_optics.meta | 80 +- physics/rrtmgp_lw_cloud_optics.F90 | 218 +----- physics/rrtmgp_lw_cloud_optics.meta | 412 ----------- physics/rrtmgp_lw_cloud_sampling.F90 | 170 ----- physics/rrtmgp_lw_cloud_sampling.meta | 226 ------ physics/rrtmgp_lw_gas_optics.F90 | 121 +--- physics/rrtmgp_lw_gas_optics.meta | 203 ------ physics/rrtmgp_lw_main.F90 | 611 ++++++++++++++++ physics/rrtmgp_lw_main.meta | 641 ++++++++++++++++ physics/rrtmgp_lw_pre.F90 | 61 -- physics/rrtmgp_lw_pre.meta | 47 -- physics/rrtmgp_lw_rte.F90 | 208 ------ physics/rrtmgp_lw_rte.meta | 208 ------ physics/rrtmgp_sw_cloud_optics.F90 | 244 +------ physics/rrtmgp_sw_cloud_optics.meta | 393 ---------- physics/rrtmgp_sw_cloud_sampling.F90 | 174 ----- physics/rrtmgp_sw_cloud_sampling.meta | 240 ------ physics/rrtmgp_sw_gas_optics.F90 | 137 +--- physics/rrtmgp_sw_gas_optics.meta | 201 ------ physics/rrtmgp_sw_main.F90 | 683 ++++++++++++++++++ physics/rrtmgp_sw_main.meta | 664 +++++++++++++++++ physics/rrtmgp_sw_rte.F90 | 219 ------ physics/rrtmgp_sw_rte.meta | 240 ------ physics/rte-rrtmgp | 2 +- 40 files changed, 3470 insertions(+), 4860 deletions(-) delete mode 100644 physics/GFS_rrtmgp_lw_post.F90 delete mode 100644 physics/GFS_rrtmgp_lw_post.meta create mode 100644 physics/GFS_rrtmgp_post.F90 rename physics/{GFS_rrtmgp_sw_post.meta => GFS_rrtmgp_post.meta} (71%) delete mode 100644 physics/GFS_rrtmgp_sw_post.F90 delete mode 100644 physics/GFS_rrtmgp_sw_pre.F90 delete mode 100644 physics/GFS_rrtmgp_sw_pre.meta delete mode 100644 physics/rrtmgp_lw_cloud_optics.meta delete mode 100644 physics/rrtmgp_lw_cloud_sampling.F90 delete mode 100644 physics/rrtmgp_lw_cloud_sampling.meta delete mode 100644 physics/rrtmgp_lw_gas_optics.meta create mode 100644 physics/rrtmgp_lw_main.F90 create mode 100644 physics/rrtmgp_lw_main.meta delete mode 100644 physics/rrtmgp_lw_pre.F90 delete mode 100644 physics/rrtmgp_lw_pre.meta delete mode 100644 physics/rrtmgp_lw_rte.F90 delete mode 100644 physics/rrtmgp_lw_rte.meta delete mode 100644 physics/rrtmgp_sw_cloud_optics.meta delete mode 100644 physics/rrtmgp_sw_cloud_sampling.F90 delete mode 100644 physics/rrtmgp_sw_cloud_sampling.meta delete mode 100644 physics/rrtmgp_sw_gas_optics.meta create mode 100644 physics/rrtmgp_sw_main.F90 create mode 100644 physics/rrtmgp_sw_main.meta delete mode 100644 physics/rrtmgp_sw_rte.F90 delete mode 100644 physics/rrtmgp_sw_rte.meta diff --git a/.gitmodules b/.gitmodules index 75e5ea836..8758980ec 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,4 +1,4 @@ [submodule "physics/rte-rrtmgp"] path = physics/rte-rrtmgp url = https://github.com/earth-system-radiation/rte-rrtmgp - branch = dtc/ccpp + branch = main diff --git a/CMakeLists.txt b/CMakeLists.txt index d14778b06..482081614 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -81,14 +81,10 @@ get_filename_component(LOCAL_CURRENT_SOURCE_DIR ${FULL_PATH_TO_CMAKELISTS} DIREC # List of files that need to be compiled without OpenMP set(SCHEMES_OPENMP_OFF ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/mo_gas_optics.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/mo_rrtmgp_constants.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/mo_rrtmgp_util_reorder.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/mo_gas_concentrations.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/mo_rrtmgp_util_string.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/kernels/mo_gas_optics_kernels.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/kernels/mo_rrtmgp_util_reorder_kernels.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/mo_gas_optics_rrtmgp.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/tests/mo_testing_io.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/tests/clear_sky_regression.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/extensions/mo_rrtmgp_clr_all_sky.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/extensions/mo_fluxes_byband.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/extensions/solar_variability/mo_solar_variability.F90 @@ -97,14 +93,6 @@ set(SCHEMES_OPENMP_OFF ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/mo_ ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/extensions/mo_compute_bc.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/extensions/cloud_optics/mo_cloud_sampling.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/extensions/cloud_optics/mo_cloud_optics.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/examples/mo_load_coefficients.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/examples/rfmip-clear-sky/rrtmgp_rfmip_sw.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/examples/rfmip-clear-sky/mo_rfmip_io.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/examples/rfmip-clear-sky/rrtmgp_rfmip_lw.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/examples/mo_simple_netcdf.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/examples/all-sky/rrtmgp_allsky.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/examples/all-sky/mo_load_cloud_coefficients.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/examples/all-sky/mo_garand_atmos_io.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/mo_rte_config.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/mo_source_functions.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/mo_rte_sw.F90 diff --git a/physics/GFS_rrtmgp_cloud_mp.F90 b/physics/GFS_rrtmgp_cloud_mp.F90 index 9ca340763..32104b7f8 100644 --- a/physics/GFS_rrtmgp_cloud_mp.F90 +++ b/physics/GFS_rrtmgp_cloud_mp.F90 @@ -27,7 +27,7 @@ module GFS_rrtmgp_cloud_mp reice_min = 10.0, & ! Minimum ice size allowed by GFDL MP scheme reice_max = 150.0 ! Maximum ice size allowed by GFDL MP scheme - public GFS_rrtmgp_cloud_mp_run + public GFS_rrtmgp_cloud_mp_init, GFS_rrtmgp_cloud_mp_run, GFS_rrtmgp_cloud_mp_finalize contains @@ -45,7 +45,7 @@ module GFS_rrtmgp_cloud_mp subroutine GFS_rrtmgp_cloud_mp_run(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, & i_cldrain, i_cldsnow, i_cldgrpl, i_cldtot, i_cldliq_nc, i_cldice_nc, i_twa, kdt, & imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_samf, doSWrad, doLWrad, effr_in, lmfshal, & - ltaerosol,mraerosol, icloud, imp_physics, imp_physics_thompson, imp_physics_gfdl, & + ltaerosol,mraerosol, icloud, imp_physics, imp_physics_thompson, imp_physics_gfdl, & lgfdlmprad, do_mynnedmf, uni_cld, lmfdeep2, p_lev, p_lay, t_lay, qs_lay, q_lay, & relhum, lsmask, xlon, xlat, dx, tv_lay, effrin_cldliq, effrin_cldice, & effrin_cldrain, effrin_cldsnow, tracer, cnv_mixratio, cld_cnv_frac, qci_conv, & @@ -462,6 +462,7 @@ subroutine cloud_mp_MYNN(nCol, nLev, lsmask, t_lay, p_lev, p_lay, qs_lay, relhum enddo end subroutine cloud_mp_MYNN + !> \ingroup GFS_rrtmgp_cloud_mp !! Compute cloud radiative properties for SAMF convective cloud scheme. !! @@ -484,47 +485,48 @@ subroutine cloud_mp_SAMF(nCol, nLev, t_lay, p_lev, p_lay, qs_lay, relhum, nCol, & ! Number of horizontal grid points nLev ! Number of vertical layers real(kind_phys), intent(in) :: & - con_g, & ! Physical constant: gravitational constant - con_ttp, & ! Triple point temperature of water (K) + con_g, & ! Physical constant: gravity (m s-2) + con_ttp, & ! Triple point temperature of water (K) alpha0 ! real(kind_phys), dimension(:,:),intent(in) :: & - t_lay, & ! Temperature at layer centers (K) - p_lev, & ! Pressure at layer interfaces (Pa) - p_lay, & ! - qs_lay, & ! - relhum, & ! - cnv_mixratio ! Convective cloud mixing-ratio (kg/kg) + t_lay, & ! Temperature at layer-centers (K) + p_lev, & ! Pressure at layer-interfaces (Pa) + p_lay, & ! Presure at layer-centers (Pa) + qs_lay, & ! Specific-humidity at layer-centers (kg/kg) + relhum, & ! Relative-humidity (1) + cnv_mixratio ! Convective cloud mixing-ratio (kg/kg) ! Outputs real(kind_phys), dimension(:,:),intent(inout) :: & cld_cnv_lwp, & ! Convective cloud liquid water path cld_cnv_reliq, & ! Convective cloud liquid effective radius cld_cnv_iwp, & ! Convective cloud ice water path cld_cnv_reice, & ! Convective cloud ice effecive radius - cld_cnv_frac ! Convective cloud-fraction (1) + cld_cnv_frac ! Convective cloud-fraction ! Local integer :: iCol, iLay - real(kind_phys) :: tem1, deltaP, clwc + real(kind_phys) :: tem0, tem1, deltaP, clwc + tem0 = 1.0e5/con_g do iLay = 1, nLev do iCol = 1, nCol if (cnv_mixratio(iCol,iLay) > 0._kind_phys) then tem1 = min(1.0, max(0.0, (con_ttp-t_lay(iCol,iLay))*0.05)) deltaP = abs(p_lev(iCol,iLay+1)-p_lev(iCol,iLay))*0.01 - clwc = max(0.0, cnv_mixratio(iCol,iLay)) * con_g * deltaP - cld_cnv_iwp(iCol,iLay) = clwc * tem1 - cld_cnv_lwp(iCol,iLay) = clwc - cld_cnv_iwp(iCol,iLay) + clwc = max(0.0, cnv_mixratio(iCol,iLay)) * tem0 * deltaP + cld_cnv_iwp(iCol,iLay) = clwc * tem1 + cld_cnv_lwp(iCol,iLay) = clwc - cld_cnv_iwp(iCol,iLay) cld_cnv_reliq(iCol,iLay) = reliq_def cld_cnv_reice(iCol,iLay) = reice_def ! Xu-Randall (1996) cloud-fraction. - cld_cnv_frac(iCol,iLay) = cld_frac_XuRandall(p_lay(iCol,iLay), & + cld_cnv_frac(iCol,iLay) = cld_frac_XuRandall(p_lay(iCol,iLay), & qs_lay(iCol,iLay), relhum(iCol,iLay), cnv_mixratio(iCol,iLay), alpha0) endif enddo enddo end subroutine cloud_mp_SAMF - + !> \ingroup GFS_rrtmgp_cloud_mp !! This routine computes the cloud radiative properties for a "unified cloud". !! - "unified cloud" implies that the cloud-fraction is PROVIDED. @@ -656,7 +658,6 @@ subroutine cloud_mp_uni(nCol, nLev, nTracers, ncnd, i_cldliq, i_cldice, i_cldrai enddo ! nLev end subroutine cloud_mp_uni - !> \ingroup GFS_rrtmgp_cloud_mp !! This routine computes the cloud radiative properties for the Thompson cloud micro- !! physics scheme. @@ -834,11 +835,11 @@ function cld_frac_XuRandall(p_lay, qs_lay, relhum, cld_mr, alpha) return end function -!> \ingroup GFS_rrtmgp_cloud_mp -!! This routine is a wrapper to update the Thompson effective particle sizes used by the -!! RRTMGP radiation scheme. -!! -!! \section cmp_reff_Thompson_gen General Algorithm + ! ###################################################################################### + ! This routine is a wrapper to update the Thompson effective particle sizes used by the + ! RRTMGP radiation scheme. + ! + ! ###################################################################################### subroutine cmp_reff_Thompson(nLev, nCol, i_cldliq, i_cldice, i_cldsnow, i_cldice_nc, & i_cldliq_nc, i_twa, q_lay, p_lay, t_lay, tracer, con_eps, con_rd, ltaerosol, & mraerosol, lsmask, effrin_cldliq, effrin_cldice, effrin_cldsnow) @@ -922,4 +923,5 @@ subroutine cmp_reff_Thompson(nLev, nCol, i_cldliq, i_cldice, i_cldsnow, i_cldice enddo end subroutine cmp_reff_Thompson + end module GFS_rrtmgp_cloud_mp diff --git a/physics/GFS_rrtmgp_cloud_mp.meta b/physics/GFS_rrtmgp_cloud_mp.meta index 1eb870da8..b782e73b4 100644 --- a/physics/GFS_rrtmgp_cloud_mp.meta +++ b/physics/GFS_rrtmgp_cloud_mp.meta @@ -345,9 +345,9 @@ kind = kind_phys intent = inout [tracer] - standard_name = chemical_tracers - long_name = chemical tracers - units = g g-1 + standard_name = tracer_concentration + long_name = model layer mean tracer concentration + units = kg kg-1 dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) type = real kind = kind_phys diff --git a/physics/GFS_rrtmgp_lw_post.F90 b/physics/GFS_rrtmgp_lw_post.F90 deleted file mode 100644 index afd56dcf1..000000000 --- a/physics/GFS_rrtmgp_lw_post.F90 +++ /dev/null @@ -1,188 +0,0 @@ -!> \file GFS_rrtmgp_lw_post.F90 -!! -!> \defgroup GFS_rrtmgp_lw_post GFS_rrtmgp_lw_post.F90 -!! -!! \brief RRTMGP Longwave post-processing routine. -!! -module GFS_rrtmgp_lw_post - use machine, only: kind_phys - use module_radlw_parameters, only: topflw_type, sfcflw_type - use mo_heating_rates, only: compute_heating_rate - use radiation_tools, only: check_error_msg - implicit none - - public GFS_rrtmgp_lw_post_run - -contains - -!>\defgroup gfs_rrtmgp_lw_post_mod GFS RRTMGP-LW Post Module -!> \section arg_table_GFS_rrtmgp_lw_post_run -!! \htmlinclude GFS_rrtmgp_lw_post.html -!! -!! \ingroup GFS_rrtmgp_lw_post -!! -!! \brief The all-sky longwave radiation tendency is computed, the clear-sky tendency is computed -!! if requested. -!! -!! RRTMGP surface and TOA fluxes are copied to fields that persist between radiation/physics -!! calls. -!! -!! (optional) Save additional diagnostics. -!! -!! \section GFS_rrtmgp_lw_post_run - ! ######################################################################################## - subroutine GFS_rrtmgp_lw_post_run (nCol, nLev, lslwr, do_lw_clrsky_hr, save_diag, fhlwr, & - p_lev, t_lay, tsfa, fluxlwUP_allsky, fluxlwDOWN_allsky, fluxlwUP_clrsky, iSFC, iTOA,& - fluxlwDOWN_clrsky, raddt, cldsa, mtopa, mbota, cld_frac, cldtaulw, fluxr, sfcdlw, & - sfculw, sfcflw, tsflw, htrlw, htrlwu, topflw, htrlwc, errmsg, errflg) - - ! Inputs - integer, intent(in) :: & - nCol, & ! Horizontal loop extent - nLev, & ! Number of vertical layers - iSFC, & ! Vertical index for surface level - iTOA ! Vertical index for TOA level - logical, intent(in) :: & - lslwr, & ! Logical flags for lw radiation calls - do_lw_clrsky_hr, & ! Output clear-sky SW heating-rate? - save_diag ! Output radiation diagnostics? - real(kind_phys), intent(in) :: & - fhlwr ! Frequency for SW radiation - real(kind_phys), dimension(nCol), intent(in) :: & - tsfa ! Lowest model layer air temperature for radiation (K) - real(kind_phys), dimension(nCol, nLev), intent(in) :: & - t_lay ! Temperature @ model layer centers (K) - real(kind_phys), dimension(nCol, nLev+1), intent(in) :: & - p_lev, & ! Pressure @ model layer-interfaces (Pa) - fluxlwUP_allsky, & ! RRTMGP longwave all-sky flux (W/m2) - fluxlwDOWN_allsky, & ! RRTMGP longwave all-sky flux (W/m2) - fluxlwUP_clrsky, & ! RRTMGP longwave clear-sky flux (W/m2) - fluxlwDOWN_clrsky ! RRTMGP longwave clear-sky flux (W/m2) - real(kind_phys), intent(in) :: & - raddt ! Radiation time step - real(kind_phys), dimension(nCol,5), intent(in) :: & - cldsa ! Fraction of clouds for low, middle, high, total and BL - integer, dimension(nCol,3), intent(in) ::& - mbota, & ! vertical indices for low, middle and high cloud tops - mtopa ! vertical indices for low, middle and high cloud bases - real(kind_phys), dimension(nCol,nLev), intent(in) :: & - cld_frac, & ! Total cloud fraction in each layer - cldtaulw ! approx 10.mu band layer cloud optical depth - - real(kind=kind_phys), dimension(:,:), intent(inout) :: fluxr - - ! Outputs (mandatory) - real(kind_phys), dimension(nCol), intent(inout) :: & - sfcdlw, & ! Total sky sfc downward lw flux (W/m2) - sfculw, & ! Total sky sfc upward lw flux (W/m2) - tsflw ! surface air temp during lw calculation (K) - type(sfcflw_type), dimension(nCol), intent(inout) :: & - sfcflw ! LW radiation fluxes at sfc - real(kind_phys), dimension(nCol,nLev), intent(inout) :: & - htrlw, & ! LW all-sky heating rate - htrlwu ! Heating-rate updated in-between radiation calls. - type(topflw_type), dimension(nCol), intent(out) :: & - topflw ! lw_fluxes_top_atmosphere - character(len=*), intent(out) :: & - errmsg - integer, intent(out) :: & - errflg - - ! Outputs (optional) - real(kind_phys),dimension(nCol, nLev),intent(inout),optional :: & - htrlwc ! Longwave clear-sky heating-rate (K/sec) - - ! Local variables - integer :: i, j, k, itop, ibtc - real(kind_phys) :: tem0d, tem1, tem2 - real(kind_phys),dimension(nCol,nLev) :: hlwc - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (.not. lslwr) return - ! ####################################################################################### - ! Compute LW heating-rates. - ! ####################################################################################### - ! Clear-sky heating-rate (optional) - if (do_lw_clrsky_hr) then - call check_error_msg('GFS_rrtmgp_post',compute_heating_rate( & - fluxlwUP_clrsky, & ! IN - RRTMGP upward longwave clear-sky flux profiles (W/m2) - fluxlwDOWN_clrsky, & ! IN - RRTMGP downward longwave clear-sky flux profiles (W/m2) - p_lev, & ! IN - Pressure @ layer-interfaces (Pa) - htrlwc)) ! OUT - Longwave clear-sky heating rate (K/sec) - endif - - ! All-sky heating-rate (mandatory) - call check_error_msg('GFS_rrtmgp_post',compute_heating_rate( & - fluxlwUP_allsky, & ! IN - RRTMGP upward longwave all-sky flux profiles (W/m2) - fluxlwDOWN_allsky, & ! IN - RRTMGP downward longwave all-sky flux profiles (W/m2) - p_lev, & ! IN - Pressure @ layer-interfaces (Pa) - htrlw)) ! OUT - Longwave all-sky heating rate (K/sec) - - ! ####################################################################################### - ! Save LW outputs. - ! (Copy fluxes from RRTMGP types into model radiation types.) - ! ####################################################################################### - ! TOA fluxes - topflw(:)%upfxc = fluxlwUP_allsky(:,iTOA) - topflw(:)%upfx0 = fluxlwUP_clrsky(:,iTOA) - - ! Surface fluxes - sfcflw(:)%upfxc = fluxlwUP_allsky(:,iSFC) - sfcflw(:)%upfx0 = fluxlwUP_clrsky(:,iSFC) - sfcflw(:)%dnfxc = fluxlwDOWN_allsky(:,iSFC) - sfcflw(:)%dnfx0 = fluxlwDOWN_clrsky(:,iSFC) - - ! Save surface air temp for diurnal adjustment at model t-steps - tsflw (:) = tsfa(:) - - ! Radiation fluxes for other physics processes - sfcdlw(:) = sfcflw(:)%dnfxc - sfculw(:) = sfcflw(:)%upfxc - - ! Heating-rate at radiation timestep, used for adjustment between radiation calls. - htrlwu = htrlw - - ! ####################################################################################### - ! Save LW diagnostics - ! - For time averaged output quantities (including total-sky and clear-sky SW and LW - ! fluxes at TOA and surface; conventional 3-domain cloud amount, cloud top and base - ! pressure, and cloud top temperature; aerosols AOD, etc.), store computed results in - ! corresponding slots of array fluxr with appropriate time weights. - ! - Collect the fluxr data for wrtsfc - ! ####################################################################################### - if (save_diag) then - do i=1,nCol - ! LW all-sky fluxes - fluxr(i,1 ) = fluxr(i,1 ) + fhlwr * fluxlwUP_allsky( i,iTOA) ! total sky top lw up - fluxr(i,19) = fluxr(i,19) + fhlwr * fluxlwDOWN_allsky(i,iSFC) ! total sky sfc lw dn - fluxr(i,20) = fluxr(i,20) + fhlwr * fluxlwUP_allsky( i,iSFC) ! total sky sfc lw up - ! LW clear-sky fluxes - fluxr(i,28) = fluxr(i,28) + fhlwr * fluxlwUP_clrsky( i,iTOA) ! clear sky top lw up - fluxr(i,30) = fluxr(i,30) + fhlwr * fluxlwDOWN_clrsky(i,iSFC) ! clear sky sfc lw dn - fluxr(i,33) = fluxr(i,33) + fhlwr * fluxlwUP_clrsky( i,iSFC) ! clear sky sfc lw up - enddo - - ! Save cld frac,toplyr,botlyr and top temp, note that the order of h,m,l cloud is reversed for - ! the fluxr output. save interface pressure (pa) of top/bot - do j = 1, 3 - do i = 1, nCol - tem0d = raddt * cldsa(i,j) - itop = mtopa(i,j) - ibtc = mbota(i,j) - - ! Add optical depth and emissivity output - tem2 = 0. - do k=ibtc,itop - tem2 = tem2 + cldtaulw(i,k) ! approx 10. mu channel - enddo - fluxr(i,46-j) = fluxr(i,46-j) + tem0d * (1.0-exp(-tem2)) - enddo - enddo - endif - - end subroutine GFS_rrtmgp_lw_post_run - -end module GFS_rrtmgp_lw_post diff --git a/physics/GFS_rrtmgp_lw_post.meta b/physics/GFS_rrtmgp_lw_post.meta deleted file mode 100644 index d458b25f3..000000000 --- a/physics/GFS_rrtmgp_lw_post.meta +++ /dev/null @@ -1,253 +0,0 @@ -[ccpp-table-properties] - name = GFS_rrtmgp_lw_post - type = scheme - dependencies = iounitdef.f,machine.F,radiation_aerosols.f,radlw_param.f,rte-rrtmgp/extensions/mo_fluxes_byband.F90,radiation_tools.F90,rte-rrtmgp/rte/mo_fluxes.F90,rte-rrtmgp/rte/kernels/mo_fluxes_broadband_kernels.F90,rte-rrtmgp/extensions/mo_heating_rates.F90 - -######################################################################## -[ccpp-arg-table] - name = GFS_rrtmgp_lw_post_run - type = scheme -[nCol] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[nLev] - standard_name = vertical_layer_dimension - long_name = number of vertical levels - units = count - dimensions = () - type = integer - intent = in -[iSFC] - standard_name = vertical_index_for_surface_in_RRTMGP - long_name = index for surface layer in RRTMGP - units = flag - dimensions = () - type = integer - intent = in -[iTOA] - standard_name = vertical_index_for_TOA_in_RRTMGP - long_name = index for TOA layer in RRTMGP - units = flag - dimensions = () - type = integer - intent = in -[lslwr] - standard_name = flag_for_calling_longwave_radiation - long_name = logical flags for lw radiation calls - units = flag - dimensions = () - type = logical - intent = in -[do_lw_clrsky_hr] - standard_name = flag_for_output_of_tendency_of_air_temperature_due_to_longwave_heating_on_radiation_timestep_assuming_clear_sky - long_name = flag to output lw heating rate - units = flag - dimensions = () - type = logical - intent = in -[save_diag] - standard_name = flag_for_diagnostics - long_name = logical flag for storing diagnostics - units = flag - dimensions = () - type = logical - intent = in -[fhlwr] - standard_name = period_of_longwave_radiation_calls - long_name = frequency for longwave radiation - units = s - dimensions = () - type = real - kind = kind_phys - intent = in -[tsfa] - standard_name = surface_air_temperature_for_radiation - long_name = lowest model layer air temperature for radiation - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[t_lay] - standard_name = air_temperature_at_layer_for_RRTMGP - long_name = air temperature at vertical layer for radiation calculation - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[p_lev] - standard_name = air_pressure_at_interface_for_RRTMGP - long_name = air pressure level - units = Pa - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = in -[fluxlwUP_allsky] - standard_name = RRTMGP_lw_flux_profile_upward_allsky - long_name = RRTMGP upward longwave all-sky flux profile - units = W m-2 - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = in -[fluxlwDOWN_allsky] - standard_name = RRTMGP_lw_flux_profile_downward_allsky - long_name = RRTMGP downward longwave all-sky flux profile - units = W m-2 - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = in -[fluxlwUP_clrsky] - standard_name = RRTMGP_lw_flux_profile_upward_clrsky - long_name = RRTMGP upward longwave clr-sky flux profile - units = W m-2 - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = in -[fluxlwDOWN_clrsky] - standard_name = RRTMGP_lw_flux_profile_downward_clrsky - long_name = RRTMGP downward longwave clr-sky flux profile - units = W m-2 - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = in -[raddt] - standard_name = time_step_for_radiation - long_name = radiation time step - units = s - dimensions = () - type = real - kind = kind_phys - intent = in -[cldsa] - standard_name = cloud_area_fraction_for_radiation - long_name = fraction of clouds for low, middle, high, total and BL - units = frac - dimensions = (horizontal_loop_extent,5) - type = real - kind = kind_phys - intent = in -[mtopa] - standard_name = model_layer_number_at_cloud_top - long_name = vertical indices for low, middle and high cloud tops - units = index - dimensions = (horizontal_loop_extent,3) - type = integer - intent = in -[mbota] - standard_name = model_layer_number_at_cloud_base - long_name = vertical indices for low, middle and high cloud bases - units = index - dimensions = (horizontal_loop_extent,3) - type = integer - intent = in -[cld_frac] - standard_name = total_cloud_fraction - long_name = layer total cloud fraction - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cldtaulw] - standard_name = cloud_optical_depth_layers_at_10mu_band - long_name = approx 10mu band layer cloud optical depth - units = none - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[fluxr] - standard_name = cumulative_radiation_diagnostic - long_name = time-accumulated 2D radiation-related diagnostic fields - units = mixed - dimensions = (horizontal_loop_extent,number_of_diagnostics_variables_for_radiation) - type = real - kind = kind_phys - intent = inout -[sfcdlw] - standard_name = surface_downwelling_longwave_flux_on_radiation_timestep - long_name = total sky sfc downward lw flux - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[sfculw] - standard_name = surface_upwelling_longwave_flux_on_radiation_timestep - long_name = total sky sfc upward lw flux - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[sfcflw] - standard_name = surface_lw_fluxes_assuming_total_and_clear_sky_on_radiation_timestep - long_name = lw radiation fluxes at sfc - units = W m-2 - dimensions = (horizontal_loop_extent) - type = sfcflw_type - intent = inout -[tsflw] - standard_name = air_temperature_at_surface_adjacent_layer_on_radiation_timestep - long_name = surface air temp during lw calculation - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[htrlw] - standard_name = tendency_of_air_temperature_due_to_longwave_heating_on_radiation_timestep - long_name = total sky lw heating rate - units = K s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[htrlwu] - standard_name = updated_tendency_of_air_temperature_due_to_longwave_heating_on_physics_timestep - long_name = total sky longwave heating rate on physics time step - units = K s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[topflw] - standard_name = lw_fluxes_top_atmosphere - long_name = lw radiation fluxes at top - units = W m-2 - dimensions = (horizontal_loop_extent) - type = topflw_type - intent = out -[htrlwc] - standard_name = tendency_of_air_temperature_due_to_longwave_heating_assuming_clear_sky_on_radiation_timestep - long_name = longwave clear sky heating rate - units = K s-1 - dimensions = (horizontal_loop_extent,adjusted_vertical_layer_dimension_for_radiation) - type = real - kind = kind_phys - intent = inout -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out diff --git a/physics/GFS_rrtmgp_post.F90 b/physics/GFS_rrtmgp_post.F90 new file mode 100644 index 000000000..22fe2fc21 --- /dev/null +++ b/physics/GFS_rrtmgp_post.F90 @@ -0,0 +1,394 @@ +!> \file GFS_rrtmgp_post.F90 +!! +!> \defgroup GFS_rrtmgp_post GFS_rrtmgp_post.F90 +!! +!! \brief RRTMGP post-processing routine. +!! +module GFS_rrtmgp_post + use machine, only: kind_phys + use module_radlw_parameters, only: topflw_type, sfcflw_type + use module_radsw_parameters, only: topfsw_type, sfcfsw_type, cmpfsw_type + use mo_heating_rates, only: compute_heating_rate + use radiation_tools, only: check_error_msg + implicit none + + public GFS_rrtmgp_post_run + +contains + ! ######################################################################################## +!>\defgroup gfs_rrtmgp_post_mod GFS RRTMGP Post Module +!> \section arg_table_GFS_rrtmgp_post_run +!! \htmlinclude GFS_rrtmgp_post.html +!! +!! \ingroup GFS_rrtmgp_post +!! +!! \brief The all-sky radiation tendency is computed, the clear-sky tendency is computed +!! if requested. +!! +!! RRTMGP surface and TOA fluxes are copied to fields that persist between radiation/physics +!! calls. +!! +!! (optional) Save additional diagnostics. +!! +!! \section GFS_rrtmgp_post_run + ! ######################################################################################## + subroutine GFS_rrtmgp_post_run (nCol, nLev, nDay, iSFC, iTOA, idxday, doLWrad, doSWrad, & + do_lw_clrsky_hr, do_sw_clrsky_hr, save_diag, fhlwr, fhswr, sfc_alb_nir_dir, & + sfc_alb_nir_dif, sfc_alb_uvvis_dir, sfc_alb_uvvis_dif, p_lev, tsfa, coszen, coszdg, & + fluxlwDOWN_clrsky, fluxlwUP_allsky, fluxlwDOWN_allsky, fluxlwUP_clrsky, & + fluxswDOWN_clrsky, fluxswUP_allsky, fluxswDOWN_allsky, fluxswUP_clrsky, & + raddt, aerodp, cldsa, mtopa, mbota, cld_frac, cldtaulw, cldtausw, scmpsw, fluxr, & + sfcdlw, sfculw, sfcflw, tsflw, htrlw, htrlwu, topflw, nirbmdi, nirdfdi, visbmdi, & + visdfdi, nirbmui, nirdfui, visbmui, visdfui, sfcnsw, sfcdsw, htrsw, sfcfsw, topfsw, & + htrswc, htrlwc, errmsg, errflg) + + ! Inputs + integer, intent(in) :: & + nCol, & ! Horizontal loop extent + nLev, & ! Number of vertical layers + nDay, & ! Number of daylit columns + iSFC, & ! Vertical index for surface level + iTOA ! Vertical index for TOA level + integer, intent(in), dimension(:) :: & + idxday ! Index array for daytime points + integer, intent(in), dimension(:,:) :: & + mbota, & ! Vertical indices for low, middle and high cloud tops + mtopa ! ertical indices for low, middle and high cloud bases + logical, intent(in) :: & + doLWrad, & ! Logical flags for lw radiation calls + doSWrad, & ! Logical flags for sw radiation calls + do_lw_clrsky_hr, & ! Output clear-sky LW heating-rate? + do_sw_clrsky_hr, & ! Output clear-sky SW heating-rate? + save_diag ! Output radiation diagnostics? + real(kind_phys), intent(in) :: & + fhlwr, & ! Frequency for LW radiation calls + fhswr ! Frequency for SW radiation calls + real(kind_phys), dimension(:), intent(in) :: & + tsfa, & ! Lowest model layer air temperature for radiation (K) + coszen, & ! Cosine(SZA) + coszdg, & ! Cosine(SZA), daytime + sfc_alb_nir_dir, & ! Surface albedo (direct) + sfc_alb_nir_dif, & ! Surface albedo (diffuse) + sfc_alb_uvvis_dir, & ! Surface albedo (direct) + sfc_alb_uvvis_dif ! Surface albedo (diffuse) + real(kind_phys), dimension(:,:), intent(in) :: & + p_lev, & ! Pressure @ model layer-interfaces (Pa) + fluxlwUP_allsky, & ! RRTMGP longwave all-sky flux (W/m2) + fluxlwDOWN_allsky, & ! RRTMGP longwave all-sky flux (W/m2) + fluxlwUP_clrsky, & ! RRTMGP longwave clear-sky flux (W/m2) + fluxlwDOWN_clrsky, & ! RRTMGP longwave clear-sky flux (W/m2) + fluxswUP_allsky, & ! RRTMGP shortwave all-sky flux (W/m2) + fluxswDOWN_allsky, & ! RRTMGP shortwave all-sky flux (W/m2) + fluxswUP_clrsky, & ! RRTMGP shortwave clear-sky flux (W/m2) + fluxswDOWN_clrsky ! RRTMGP shortwave clear-sky flux (W/m2) + real(kind_phys), intent(in) :: & + raddt ! Radiation time step + real(kind_phys), dimension(:,:), intent(in) :: & + aerodp, & ! Vertical integrated optical depth for various aerosol species + cldsa, & ! Fraction of clouds for low, middle, high, total and BL + cld_frac, & ! Total cloud fraction in each layer + cldtaulw, & ! approx 10.mu band layer cloud optical depth + cldtausw ! approx .55mu band layer cloud optical depth + type(cmpfsw_type), dimension(:), intent(in) :: & + scmpsw ! 2D surface fluxes, components: + ! uvbfc - total sky downward uv-b flux at (W/m2) + ! uvbf0 - clear sky downward uv-b flux at (W/m2) + ! nirbm - downward nir direct beam flux (W/m2) + ! nirdf - downward nir diffused flux (W/m2) + ! visbm - downward uv+vis direct beam flux (W/m2) + ! visdf - downward uv+vis diffused flux (W/m2) + + + real(kind=kind_phys), dimension(:,:), intent(inout) :: fluxr + + ! Outputs (mandatory) + real(kind_phys), dimension(:), intent(inout) :: & + tsflw, & ! LW sfc air temp during calculation (K) + sfcdlw, & ! LW sfc all-sky downward flux (W/m2) + sfculw, & ! LW sfc all-sky upward flux (W/m2) + nirbmdi, & ! SW sfc nir beam downward flux (W/m2) + nirdfdi, & ! SW sfc nir diff downward flux (W/m2) + visbmdi, & ! SW sfc uv+vis beam downward flux (W/m2) + visdfdi, & ! SW sfc uv+vis diff downward flux (W/m2) + nirbmui, & ! SW sfc nir beam upward flux (W/m2) + nirdfui, & ! SW sfc nir diff upward flux (W/m2) + visbmui, & ! SW sfc uv+vis beam upward flux (W/m2) + visdfui, & ! SW sfc uv+vis diff upward flux (W/m2) + sfcnsw, & ! SW sfc all-sky net flux (W/m2) flux into ground + sfcdsw ! SW sfc all-sky downward flux (W/m2) + real(kind_phys), dimension(:,:), intent(inout) :: & + htrlw, & ! LW all-sky heating rate (K/s) + htrsw, & ! SW all-sky heating rate (K/s) + htrlwu ! LW all-sky heating-rate updated in-between radiation calls. + type(sfcflw_type), dimension(:), intent(inout) :: & + sfcflw ! LW radiation fluxes at sfc + type(sfcfsw_type), dimension(:), intent(inout) :: & + sfcfsw ! SW radiation fluxes at sfc + type(topfsw_type), dimension(:), intent(inout) :: & + topfsw ! SW fluxes at top atmosphere + type(topflw_type), dimension(:), intent(inout) :: & + topflw ! LW fluxes at top atmosphere + character(len=*), intent(out) :: & + errmsg ! CCPP error message + integer, intent(out) :: & + errflg ! CCPP error code + + ! Outputs (optional) + real(kind_phys),dimension(:,:),intent(inout),optional :: & + htrlwc, & ! LW clear-sky heating-rate (K/s) + htrswc ! SW clear-sky heating rate (K/s) + + ! Local variables + integer :: i, j, k, itop, ibtc + real(kind_phys) :: tem0d, tem1, tem2 + real(kind_phys), dimension(nDay, nLev) :: thetaTendClrSky, thetaTendAllSky + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (.not. (doLWrad .or. doSWrad)) return + + if (doLWRad) then + ! ####################################################################################### + ! Compute LW heating-rates. + ! ####################################################################################### + + ! Clear-sky heating-rate (optional) + if (do_lw_clrsky_hr) then + call check_error_msg('GFS_rrtmgp_post',compute_heating_rate( & + fluxlwUP_clrsky, & ! IN - RRTMGP upward longwave clear-sky flux profiles (W/m2) + fluxlwDOWN_clrsky, & ! IN - RRTMGP downward longwave clear-sky flux profiles (W/m2) + p_lev, & ! IN - Pressure @ layer-interfaces (Pa) + htrlwc)) ! OUT - Longwave clear-sky heating rate (K/sec) + endif + + ! All-sky heating-rate (mandatory) + call check_error_msg('GFS_rrtmgp_post',compute_heating_rate( & + fluxlwUP_allsky, & ! IN - RRTMGP upward longwave all-sky flux profiles (W/m2) + fluxlwDOWN_allsky, & ! IN - RRTMGP downward longwave all-sky flux profiles (W/m2) + p_lev, & ! IN - Pressure @ layer-interfaces (Pa) + htrlw)) ! OUT - Longwave all-sky heating rate (K/sec) + + ! ####################################################################################### + ! Save LW outputs. + ! (Copy fluxes from RRTMGP types into model radiation types.) + ! ####################################################################################### + ! TOA fluxes + + topflw(:)%upfxc = fluxlwUP_allsky(:,iTOA) + topflw(:)%upfx0 = fluxlwUP_clrsky(:,iTOA) + + ! Surface fluxes + sfcflw(:)%upfxc = fluxlwUP_allsky(:,iSFC) + sfcflw(:)%upfx0 = fluxlwUP_clrsky(:,iSFC) + sfcflw(:)%dnfxc = fluxlwDOWN_allsky(:,iSFC) + sfcflw(:)%dnfx0 = fluxlwDOWN_clrsky(:,iSFC) + + ! Save surface air temp for diurnal adjustment at model t-steps + tsflw (:) = tsfa(:) + + ! Radiation fluxes for other physics processes + sfcdlw(:) = sfcflw(:)%dnfxc + sfculw(:) = sfcflw(:)%upfxc + + ! Heating-rate at radiation timestep, used for adjustment between radiation calls. + htrlwu = htrlw + + ! ####################################################################################### + ! Save LW diagnostics + ! - For time averaged output quantities (including total-sky and clear-sky SW and LW + ! fluxes at TOA and surface; conventional 3-domain cloud amount, cloud top and base + ! pressure, and cloud top temperature; aerosols AOD, etc.), store computed results in + ! corresponding slots of array fluxr with appropriate time weights. + ! - Collect the fluxr data for wrtsfc + ! ####################################################################################### + if (save_diag) then + do i=1,nCol + ! LW all-sky fluxes + fluxr(i,1 ) = fluxr(i,1 ) + fhlwr * fluxlwUP_allsky( i,iTOA) ! total sky top lw up + fluxr(i,19) = fluxr(i,19) + fhlwr * fluxlwDOWN_allsky(i,iSFC) ! total sky sfc lw dn + fluxr(i,20) = fluxr(i,20) + fhlwr * fluxlwUP_allsky( i,iSFC) ! total sky sfc lw up + ! LW clear-sky fluxes + fluxr(i,28) = fluxr(i,28) + fhlwr * fluxlwUP_clrsky( i,iTOA) ! clear sky top lw up + fluxr(i,30) = fluxr(i,30) + fhlwr * fluxlwDOWN_clrsky(i,iSFC) ! clear sky sfc lw dn + fluxr(i,33) = fluxr(i,33) + fhlwr * fluxlwUP_clrsky( i,iSFC) ! clear sky sfc lw up + enddo + + ! Save cld frac,toplyr,botlyr and top temp, note that the order of h,m,l cloud is reversed for + ! the fluxr output. save interface pressure (pa) of top/bot + do j = 1, 3 + do i = 1, nCol + tem0d = raddt * cldsa(i,j) + itop = mtopa(i,j) + ibtc = mbota(i,j) + + ! Add optical depth and emissivity output + tem2 = 0. + do k=ibtc,itop + tem2 = tem2 + cldtaulw(i,k) ! approx 10. mu channel + enddo + fluxr(i,46-j) = fluxr(i,46-j) + tem0d * (1.0-exp(-tem2)) + enddo + enddo + endif + endif + ! ####################################################################################### + ! ####################################################################################### + ! ####################################################################################### + ! ####################################################################################### + ! ####################################################################################### + ! ####################################################################################### + if (doSWRad) then + if (nDay .gt. 0) then + ! ################################################################################# + ! Compute SW heating-rates + ! ################################################################################# + + ! Clear-sky heating-rate (optional) + if (do_sw_clrsky_hr) then + htrswc(:,:) = 0._kind_phys + call check_error_msg('GFS_rrtmgp_post',compute_heating_rate( & + fluxswUP_clrsky(idxday(1:nDay),:), & ! IN - Shortwave upward clear-sky flux profiles (W/m2) + fluxswDOWN_clrsky(idxday(1:nDay),:), & ! IN - Shortwave downward clear-sky flux profiles (W/m2) + p_lev(idxday(1:nDay),:), & ! IN - Pressure at model-interface (Pa) + thetaTendClrSky)) ! OUT - Clear-sky heating-rate (K/sec) + htrswc(idxday(1:nDay),:)=thetaTendClrSky !**NOTE** GP doesn't use radiation levels, it uses the model fields. Not sure if this is necessary + endif + + ! All-sky heating-rate (mandatory) + htrsw(:,:) = 0._kind_phys + call check_error_msg('GFS_rrtmgp_post',compute_heating_rate( & + fluxswUP_allsky(idxday(1:nDay),:), & ! IN - Shortwave upward all-sky flux profiles (W/m2) + fluxswDOWN_allsky(idxday(1:nDay),:), & ! IN - Shortwave downward all-sky flux profiles (W/m2) + p_lev(idxday(1:nDay),:), & ! IN - Pressure at model-interface (Pa) + thetaTendAllSky)) ! OUT - All-sky heating-rate (K/sec) + htrsw(idxday(1:nDay),:) = thetaTendAllSky + + ! ################################################################################# + ! Save SW outputs + ! (Copy fluxes from RRTMGP types into model radiation types.) + ! ################################################################################# + + ! TOA fluxes + topfsw(:)%upfxc = fluxswUP_allsky(:,iTOA) + topfsw(:)%upfx0 = fluxswUP_clrsky(:,iTOA) + topfsw(:)%dnfxc = fluxswDOWN_allsky(:,iTOA) + + ! Surface fluxes + sfcfsw(:)%upfxc = fluxswUP_allsky(:,iSFC) + sfcfsw(:)%upfx0 = fluxswUP_clrsky(:,iSFC) + sfcfsw(:)%dnfxc = fluxswDOWN_allsky(:,iSFC) + sfcfsw(:)%dnfx0 = fluxswDOWN_clrsky(:,iSFC) + + ! Surface down and up spectral component fluxes + ! - Save two spectral bands' surface downward and upward fluxes for output. + do i=1,nCol + nirbmdi(i) = scmpsw(i)%nirbm + nirdfdi(i) = scmpsw(i)%nirdf + visbmdi(i) = scmpsw(i)%visbm + visdfdi(i) = scmpsw(i)%visdf + nirbmui(i) = scmpsw(i)%nirbm * sfc_alb_nir_dir(i) + nirdfui(i) = scmpsw(i)%nirdf * sfc_alb_nir_dif(i) + visbmui(i) = scmpsw(i)%visbm * sfc_alb_uvvis_dir(i) + visdfui(i) = scmpsw(i)%visdf * sfc_alb_uvvis_dif(i) + enddo + else ! if_nday_block + ! ################################################################################# + ! Dark everywhere + ! ################################################################################# + htrsw(:,:) = 0.0 + sfcfsw = sfcfsw_type( 0.0, 0.0, 0.0, 0.0 ) + topfsw = topfsw_type( 0.0, 0.0, 0.0 ) + do i=1,nCol + nirbmdi(i) = 0.0 + nirdfdi(i) = 0.0 + visbmdi(i) = 0.0 + visdfdi(i) = 0.0 + nirbmui(i) = 0.0 + nirdfui(i) = 0.0 + visbmui(i) = 0.0 + visdfui(i) = 0.0 + enddo + + if (do_sw_clrsky_hr) then + htrswc(:,:) = 0 + endif + endif ! end_if_nday + + ! Radiation fluxes for other physics processes + do i=1,nCol + sfcnsw(i) = sfcfsw(i)%dnfxc - sfcfsw(i)%upfxc + sfcdsw(i) = sfcfsw(i)%dnfxc + enddo + + ! ################################################################################# + ! Save SW diagnostics + ! - For time averaged output quantities (including total-sky and clear-sky SW and LW + ! fluxes at TOA and surface; conventional 3-domain cloud amount, cloud top and base + ! pressure, and cloud top temperature; aerosols AOD, etc.), store computed results in + ! corresponding slots of array fluxr with appropriate time weights. + ! - Collect the fluxr data for wrtsfc + ! ################################################################################# + if (save_diag) then + do i=1,nCol + fluxr(i,34) = aerodp(i,1) ! total aod at 550nm + fluxr(i,35) = aerodp(i,2) ! DU aod at 550nm + fluxr(i,36) = aerodp(i,3) ! BC aod at 550nm + fluxr(i,37) = aerodp(i,4) ! OC aod at 550nm + fluxr(i,38) = aerodp(i,5) ! SU aod at 550nm + fluxr(i,39) = aerodp(i,6) ! SS aod at 550nm + if (coszen(i) > 0.) then + ! SW all-sky fluxes + tem0d = fhswr * coszdg(i) / coszen(i) + fluxr(i,2 ) = fluxr(i,2) + topfsw(i)%upfxc * tem0d ! total sky top sw up + fluxr(i,3 ) = fluxr(i,3) + sfcfsw(i)%upfxc * tem0d + fluxr(i,4 ) = fluxr(i,4) + sfcfsw(i)%dnfxc * tem0d ! total sky sfc sw dn + ! SW uv-b fluxes + fluxr(i,21) = fluxr(i,21) + scmpsw(i)%uvbfc * tem0d ! total sky uv-b sw dn + fluxr(i,22) = fluxr(i,22) + scmpsw(i)%uvbf0 * tem0d ! clear sky uv-b sw dn + ! SW TOA incoming fluxes + fluxr(i,23) = fluxr(i,23) + topfsw(i)%dnfxc * tem0d ! top sw dn + ! SW SFC flux components + fluxr(i,24) = fluxr(i,24) + visbmdi(i) * tem0d ! uv/vis beam sw dn + fluxr(i,25) = fluxr(i,25) + visdfdi(i) * tem0d ! uv/vis diff sw dn + fluxr(i,26) = fluxr(i,26) + nirbmdi(i) * tem0d ! nir beam sw dn + fluxr(i,27) = fluxr(i,27) + nirdfdi(i) * tem0d ! nir diff sw dn + ! SW clear-sky fluxes + fluxr(i,29) = fluxr(i,29) + topfsw(i)%upfx0 * tem0d + fluxr(i,31) = fluxr(i,31) + sfcfsw(i)%upfx0 * tem0d + fluxr(i,32) = fluxr(i,32) + sfcfsw(i)%dnfx0 * tem0d + endif + enddo + + ! Save total and boundary-layer clouds + do i=1,nCol + fluxr(i,17) = fluxr(i,17) + raddt * cldsa(i,4) + fluxr(i,18) = fluxr(i,18) + raddt * cldsa(i,5) + enddo + + ! Save cld frac,toplyr,botlyr and top temp, note that the order of h,m,l cloud + ! is reversed for the fluxr output. save interface pressure (pa) of top/bot + do j = 1, 3 + do i = 1, nCol + tem0d = raddt * cldsa(i,j) + itop = mtopa(i,j) + ibtc = mbota(i,j) + fluxr(i, 8-j) = fluxr(i, 8-j) + tem0d + fluxr(i,11-j) = fluxr(i,11-j) + tem0d * p_lev(i,itop) + fluxr(i,14-j) = fluxr(i,14-j) + tem0d * p_lev(i,ibtc) + fluxr(i,17-j) = fluxr(i,17-j) + tem0d * p_lev(i,itop) + + ! Add optical depth and emissivity output + tem1 = 0. + do k=ibtc,itop + tem1 = tem1 + cldtausw(i,k) ! approx .55 mu channel + enddo + fluxr(i,43-j) = fluxr(i,43-j) + tem0d * tem1 + enddo + enddo + endif + endif + + end subroutine GFS_rrtmgp_post_run +end module GFS_rrtmgp_post diff --git a/physics/GFS_rrtmgp_sw_post.meta b/physics/GFS_rrtmgp_post.meta similarity index 71% rename from physics/GFS_rrtmgp_sw_post.meta rename to physics/GFS_rrtmgp_post.meta index 7da3b10b0..e4bc3e5dc 100644 --- a/physics/GFS_rrtmgp_sw_post.meta +++ b/physics/GFS_rrtmgp_post.meta @@ -1,14 +1,13 @@ [ccpp-table-properties] - name = GFS_rrtmgp_sw_post + name = GFS_rrtmgp_post type = scheme - dependencies = iounitdef.f,machine.F,radiation_aerosols.f,radsw_param.f,rte-rrtmgp/extensions/mo_fluxes_byband.F90 - dependencies = rte-rrtmgp/rte/mo_fluxes.F90,rte-rrtmgp/rte/kernels/mo_fluxes_broadband_kernels.F90,rte-rrtmgp/extensions/mo_heating_rates.F90,radiation_tools.F90 + dependencies = iounitdef.f,machine.F,radiation_aerosols.f,radlw_param.f,radiation_tools.F90,rte-rrtmgp/extensions/mo_heating_rates.F90 ######################################################################## [ccpp-arg-table] - name = GFS_rrtmgp_sw_post_run + name = GFS_rrtmgp_post_run type = scheme -[ncol] +[nCol] standard_name = horizontal_loop_extent long_name = horizontal loop extent units = count @@ -50,7 +49,7 @@ dimensions = (horizontal_loop_extent) type = integer intent = in -[lsswr] +[doSWrad] standard_name = flag_for_calling_shortwave_radiation long_name = logical flags for sw radiation calls units = flag @@ -64,6 +63,20 @@ dimensions = () type = logical intent = in +[doLWrad] + standard_name = flag_for_calling_longwave_radiation + long_name = logical flags for lw radiation calls + units = flag + dimensions = () + type = logical + intent = in +[do_lw_clrsky_hr] + standard_name = flag_for_output_of_tendency_of_air_temperature_due_to_longwave_heating_on_radiation_timestep_assuming_clear_sky + long_name = flag to output lw heating rate + units = flag + dimensions = () + type = logical + intent = in [save_diag] standard_name = flag_for_diagnostics long_name = logical flag for storing diagnostics @@ -71,6 +84,14 @@ dimensions = () type = logical intent = in +[fhlwr] + standard_name = period_of_longwave_radiation_calls + long_name = frequency for longwave radiation + units = s + dimensions = () + type = real + kind = kind_phys + intent = in [fhswr] standard_name = period_of_shortwave_radiation_calls long_name = frequency for shortwave radiation @@ -95,22 +116,6 @@ type = real kind = kind_phys intent = in -[t_lay] - standard_name = air_temperature_at_layer_for_RRTMGP - long_name = air temperature at vertical layer for radiation calculation - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[p_lev] - standard_name = air_pressure_at_interface_for_RRTMGP - long_name = air pressure level - units = Pa - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = in [sfc_alb_nir_dir] standard_name = surface_albedo_due_to_near_IR_direct long_name = surface albedo due to near IR direct beam @@ -143,6 +148,54 @@ type = real kind = kind_phys intent = in +[tsfa] + standard_name = surface_air_temperature_for_radiation + long_name = lowest model layer air temperature for radiation + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[p_lev] + standard_name = air_pressure_at_interface_for_RRTMGP + long_name = air pressure level + units = Pa + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in +[fluxlwUP_allsky] + standard_name = RRTMGP_lw_flux_profile_upward_allsky + long_name = RRTMGP upward longwave all-sky flux profile + units = W m-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in +[fluxlwDOWN_allsky] + standard_name = RRTMGP_lw_flux_profile_downward_allsky + long_name = RRTMGP downward longwave all-sky flux profile + units = W m-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in +[fluxlwUP_clrsky] + standard_name = RRTMGP_lw_flux_profile_upward_clrsky + long_name = RRTMGP upward longwave clr-sky flux profile + units = W m-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in +[fluxlwDOWN_clrsky] + standard_name = RRTMGP_lw_flux_profile_downward_clrsky + long_name = RRTMGP downward longwave clr-sky flux profile + units = W m-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in [fluxswUP_allsky] standard_name = RRTMGP_sw_flux_profile_upward_allsky long_name = RRTMGP upward shortwave all-sky flux profile @@ -199,16 +252,16 @@ type = real kind = kind_phys intent = in -[mbota] - standard_name = model_layer_number_at_cloud_base - long_name = vertical indices for low, middle and high cloud bases +[mtopa] + standard_name = model_layer_number_at_cloud_top + long_name = vertical indices for low, middle and high cloud tops units = index dimensions = (horizontal_loop_extent,3) type = integer intent = in -[mtopa] - standard_name = model_layer_number_at_cloud_top - long_name = vertical indices for low, middle and high cloud tops +[mbota] + standard_name = model_layer_number_at_cloud_base + long_name = vertical indices for low, middle and high cloud bases units = index dimensions = (horizontal_loop_extent,3) type = integer @@ -221,6 +274,14 @@ type = real kind = kind_phys intent = in +[cldtaulw] + standard_name = cloud_optical_depth_layers_at_10mu_band + long_name = approx 10mu band layer cloud optical depth + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in [cldtausw] standard_name = cloud_optical_depth_layers_at_0p55mu_band long_name = approx .55mu band layer cloud optical depth @@ -229,6 +290,13 @@ type = real kind = kind_phys intent = in +[scmpsw] + standard_name = components_of_surface_downward_shortwave_fluxes + long_name = derived type for special components of surface downward shortwave fluxes + units = W m-2 + dimensions = (horizontal_loop_extent) + type = cmpfsw_type + intent = in [fluxr] standard_name = cumulative_radiation_diagnostic long_name = time-accumulated 2D radiation-related diagnostic fields @@ -237,6 +305,60 @@ type = real kind = kind_phys intent = inout +[sfcdlw] + standard_name = surface_downwelling_longwave_flux_on_radiation_timestep + long_name = total sky sfc downward lw flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[sfculw] + standard_name = surface_upwelling_longwave_flux_on_radiation_timestep + long_name = total sky sfc upward lw flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[sfcflw] + standard_name = surface_lw_fluxes_assuming_total_and_clear_sky_on_radiation_timestep + long_name = lw radiation fluxes at sfc + units = W m-2 + dimensions = (horizontal_loop_extent) + type = sfcflw_type + intent = inout +[tsflw] + standard_name = air_temperature_at_surface_adjacent_layer_on_radiation_timestep + long_name = surface air temp during lw calculation + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[htrlw] + standard_name = tendency_of_air_temperature_due_to_longwave_heating_on_radiation_timestep + long_name = total sky lw heating rate + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[htrlwu] + standard_name = updated_tendency_of_air_temperature_due_to_longwave_heating_on_physics_timestep + long_name = total sky longwave heating rate on physics time step + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[topflw] + standard_name = lw_fluxes_top_atmosphere + long_name = lw radiation fluxes at top + units = W m-2 + dimensions = (horizontal_loop_extent) + type = topflw_type + intent = inout [nirbmdi] standard_name = surface_downwelling_direct_nir_shortwave_flux_on_radiation_timestep long_name = sfc nir beam sw downward flux @@ -347,12 +469,13 @@ type = real kind = kind_phys intent = inout -[scmpsw] - standard_name = components_of_surface_downward_shortwave_fluxes - long_name = derived type for special components of surface downward shortwave fluxes - units = W m-2 - dimensions = (horizontal_loop_extent) - type = cmpfsw_type +[htrlwc] + standard_name = tendency_of_air_temperature_due_to_longwave_heating_assuming_clear_sky_on_radiation_timestep + long_name = longwave clear sky heating rate + units = K s-1 + dimensions = (horizontal_loop_extent,adjusted_vertical_layer_dimension_for_radiation) + type = real + kind = kind_phys intent = inout [errmsg] standard_name = ccpp_error_message diff --git a/physics/GFS_rrtmgp_pre.F90 b/physics/GFS_rrtmgp_pre.F90 index 755b977b3..8e115b774 100644 --- a/physics/GFS_rrtmgp_pre.F90 +++ b/physics/GFS_rrtmgp_pre.F90 @@ -15,9 +15,9 @@ module GFS_rrtmgp_pre NF_VGAS, & !< Number of active gas species getgases, & !< Routine to setup trace gases getozn !< Routine to setup ozone - ! RRTMGP types - use mo_gas_concentrations, only: ty_gas_concs use radiation_tools, only: check_error_msg,cmp_tlev + use rrtmgp_lw_gas_optics, only: lw_gas_props + implicit none real(kind_phys), parameter :: & amd = 28.9644_kind_phys, & !< Molecular weight of dry-air (g/mol) @@ -25,6 +25,9 @@ module GFS_rrtmgp_pre amo3 = 47.9982_kind_phys, & !< Modelular weight of ozone (g/mol) amdw = amd/amw, & !< Molecular weight of dry air / water vapor amdo3 = amd/amo3 !< Molecular weight of dry air / ozone + real(kind_phys), parameter :: eps = 1.0e-6_kind_phys + real(kind_phys), parameter :: oneminus = 1.0_kind_phys - eps + real(kind_phys), parameter :: ftiny = 1.0e-12_kind_phys ! Save trace gas indices. integer :: iStr_h2o, iStr_co2, iStr_o3, iStr_n2o, iStr_ch4, iStr_o2, iStr_ccl4, & @@ -111,27 +114,25 @@ end subroutine GFS_rrtmgp_pre_init !! !! \section GFS_rrtmgp_pre_run ! ######################################################################################### - subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhswr, fhlwr, & + subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, doSWrad, doLWrad, fhswr, fhlwr, & xlat, xlon, prsl, tgrs, prslk, prsi, qgrs, tsfc, coslat, sinlat, con_g, con_rd, & - con_eps, con_epsm1, con_fvirt, con_epsqs, solhr, minGPpres, maxGPpres, minGPtemp, & - maxGPtemp, raddt, p_lay, t_lay, p_lev, t_lev, tsfg, tsfa, qs_lay, q_lay, tv_lay, & - relhum, tracer, deltaZ, deltaZc, deltaP, active_gases_array, gas_concentrations, & - tsfc_radtime, coszen, coszdg, top_at_1, iSFC, iTOA, errmsg, errflg) + con_eps, con_epsm1, con_fvirt, con_epsqs, solhr, raddt, p_lay, t_lay, p_lev, t_lev, & + vmr_o2, vmr_h2o, vmr_o3, vmr_ch4, & + vmr_n2o, vmr_co2, tsfg, tsfa, qs_lay, q_lay, tv_lay, & + relhum, deltaZ, deltaZc, deltaP, active_gases_array, & + tsfc_radtime, coszen, coszdg, top_at_1, iSFC, iTOA, nDay, idxday, semis, & + sfc_emiss_byband, errmsg, errflg) ! Inputs integer, intent(in) :: & + me, & ! MPI rank nCol, & ! Number of horizontal grid points nLev, & ! Number of vertical layers - nTracers, & ! Number of tracers from model. i_o3 ! Index into tracer array for ozone logical, intent(in) :: & - lsswr, & ! Call SW radiation? - lslwr ! Call LW radiation + doSWrad, & ! Call SW radiation? + doLWrad ! Call LW radiation real(kind_phys), intent(in) :: & - minGPtemp, & ! Minimum temperature allowed in RRTMGP. - maxGPtemp, & ! Maximum ... - minGPpres, & ! Minimum pressure allowed in RRTMGP. - maxGPpres, & ! Maximum pressure allowed in RRTMGP. fhswr, & ! Frequency of SW radiation call. fhlwr ! Frequency of LW radiation call. real(kind_phys), intent(in) :: & @@ -147,7 +148,8 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw xlat, & ! Latitude tsfc, & ! Surface skin temperature (K) coslat, & ! Cosine(latitude) - sinlat ! Sine(latitude) + sinlat, & ! Sine(latitude) + semis real(kind_phys), dimension(:,:), intent(in) :: & prsl, & ! Pressure at model-layer centers (Pa) tgrs, & ! Temperature at model-layer centers (K) @@ -163,9 +165,11 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw errmsg ! Error message integer, intent(out) :: & errflg, & ! Error flag + nDay + integer, intent(inout) :: & iSFC, & ! Vertical index for surface iTOA ! Vertical index for TOA - logical, intent(out) :: & + logical, intent(inout) :: & top_at_1 ! Vertical ordering flag real(kind_phys), intent(inout) :: & raddt ! Radiation time-step @@ -175,6 +179,8 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw tsfc_radtime, & ! Surface temperature at radiation timestep coszen, & ! Cosine of SZA coszdg ! Cosine of SZA, daytime + integer, dimension(:), intent(inout) :: & + idxday ! Indices for daylit points real(kind_phys), dimension(:,:), intent(inout) :: & p_lay, & ! Pressure at model-layer t_lay, & ! Temperature at model layer @@ -186,15 +192,12 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw deltaZc, & ! Layer thickness (m) (between layer centers) deltaP, & ! Layer thickness (Pa) p_lev, & ! Pressure at model-interface - t_lev ! Temperature at model-interface - real(kind_phys), dimension(:,:,:),intent(inout) :: & - tracer ! Array containing trace gases - type(ty_gas_concs), intent(inout) :: & - gas_concentrations ! RRTMGP DDT: gas volumne mixing ratios + sfc_emiss_byband, & ! + t_lev, & ! Temperature at model-interface + vmr_o2, vmr_h2o, vmr_o3, vmr_ch4, vmr_n2o, vmr_co2 ! Local variables integer :: i, j, iCol, iBand, iLay, iLev, iSFC_ilev - real(kind_phys),dimension(nCol,nLev) :: vmr_o3, vmr_h2o real(kind_phys) :: es, tem1, tem2, pfac real(kind_phys), dimension(nLev+1) :: hgtb real(kind_phys), dimension(nLev) :: hgtc @@ -206,7 +209,9 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw errmsg = '' errflg = 0 - if (.not. (lsswr .or. lslwr)) return + nday = 0 + idxday = 0 + if (.not. (doSWrad .or. doLWrad)) return ! ####################################################################################### ! What is vertical ordering? @@ -242,27 +247,29 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw ! Bound temperature/pressure at layer centers. do iLay=1,nLev do iCol=1,NCOL - if (t_lay(iCol,iLay) .le. minGPtemp) then - t_lay(iCol,iLay) = minGPtemp + epsilon(minGPtemp) + if (t_lay(iCol,iLay) .le. lw_gas_props%get_temp_min()) then + t_lay(iCol,iLay) = lw_gas_props%get_temp_min() + epsilon(lw_gas_props%get_temp_min()) endif - if (p_lay(iCol,iLay) .le. minGPpres) then - p_lay(iCol,iLay) = minGPpres + epsilon(minGPpres) + if (p_lay(iCol,iLay) .le. lw_gas_props%get_press_min()) then + p_lay(iCol,iLay) = lw_gas_props%get_press_min() + epsilon(lw_gas_props%get_press_min()) endif - if (t_lay(iCol,iLay) .ge. maxGPtemp) then - t_lay(iCol,iLay) = maxGPtemp - epsilon(maxGPtemp) + if (t_lay(iCol,iLay) .ge. lw_gas_props%get_temp_max()) then + t_lay(iCol,iLay) = lw_gas_props%get_temp_max() - epsilon(lw_gas_props%get_temp_max()) endif - if (p_lay(iCol,iLay) .ge. maxGPpres) then - p_lay(iCol,iLay) = maxGPpres - epsilon(maxGPpres) + if (p_lay(iCol,iLay) .ge. lw_gas_props%get_press_max()) then + p_lay(iCol,iLay) = lw_gas_props%get_press_max() - epsilon(lw_gas_props%get_press_max()) endif enddo enddo ! Temperature at layer-interfaces - call cmp_tlev(nCol,nLev,minGPpres,p_lay,t_lay,p_lev,tsfc,t_lev) + call cmp_tlev(nCol,nLev,lw_gas_props%get_press_min(),p_lay,t_lay,p_lev,tsfc,t_lev) do iLev=1,nLev+1 do iCol=1,nCol - if (t_lev(iCol,iLev) .le. minGPtemp) t_lev(iCol,iLev) = minGPtemp + epsilon(minGPtemp) - if (t_lev(iCol,iLev) .ge. maxGPtemp) t_lev(iCol,iLev) = maxGPtemp - epsilon(maxGPtemp) + if (t_lev(iCol,iLev) .le. lw_gas_props%get_temp_min()) t_lev(iCol,iLev) = & + lw_gas_props%get_temp_min() + epsilon(lw_gas_props%get_temp_min()) + if (t_lev(iCol,iLev) .ge. lw_gas_props%get_temp_max()) t_lev(iCol,iLev) = & + lw_gas_props%get_temp_max() - epsilon(lw_gas_props%get_temp_max()) enddo enddo @@ -336,16 +343,11 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw ! ####################################################################################### ! Get layer ozone mass mixing ratio ! ####################################################################################### - ! First recast remaining all tracers (except sphum) forcing them all to be positive - do j = 2, nTracers - tracer(1:NCOL,:,j) = qgrs(1:NCOL,:,j) - where(tracer(:,:,j) .lt. 0.0) tracer(:,:,j) = 0._kind_phys - enddo if (i_o3 > 0) then do iLay=1,nlev do iCol=1,NCOL - o3_lay(iCol,iLay) = max( con_epsqs, tracer(iCol,iLay,i_o3) ) + o3_lay(iCol,iLay) = max( con_epsqs, qgrs(iCol,iLay,i_o3) ) enddo enddo ! OR Use climatological ozone data @@ -358,21 +360,14 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw ! ####################################################################################### ! Call getgases(), to set up non-prognostic gas volume mixing ratios (gas_vmr). call getgases (p_lev/100., xlon, xlat, nCol, nLev, gas_vmr) + vmr_o2 = gas_vmr(:,:,4) + vmr_ch4 = gas_vmr(:,:,3) + vmr_n2o = gas_vmr(:,:,2) + vmr_co2 = gas_vmr(:,:,1) ! Compute volume mixing-ratios for ozone (mmr) and specific-humidity. vmr_h2o = merge((q_lay/(1-q_lay))*amdw, 0., q_lay .ne. 1.) vmr_o3 = merge(o3_lay*amdo3, 0., o3_lay .gt. 0.) - - ! Populate RRTMGP DDT w/ gas-concentrations - gas_concentrations%ncol = nCol - gas_concentrations%nlay = nLev - gas_concentrations%gas_name(:) = active_gases_array(:) - gas_concentrations%concs(istr_o2)%conc(:,:) = gas_vmr(:,:,4) - gas_concentrations%concs(istr_co2)%conc(:,:) = gas_vmr(:,:,1) - gas_concentrations%concs(istr_ch4)%conc(:,:) = gas_vmr(:,:,3) - gas_concentrations%concs(istr_n2o)%conc(:,:) = gas_vmr(:,:,2) - gas_concentrations%concs(istr_h2o)%conc(:,:) = vmr_h2o(:,:) - gas_concentrations%concs(istr_o3)%conc(:,:) = vmr_o3(:,:) ! ####################################################################################### ! Radiation time step (output) (Is this really needed?) (Used by some diagnostics) @@ -388,10 +383,29 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhsw ! ####################################################################################### ! Compute cosine of zenith angle (only when SW is called) ! ####################################################################################### - if (lsswr) then + if (doSWrad) then call coszmn (xlon, sinlat, coslat, solhr, nCol, me, coszen, coszdg) + ! For SW gather daylit points + nday = 0 + idxday = 0 + do iCol = 1, nCol + if (coszen(iCol) >= 0.0001) then + nday = nday + 1 + idxday(nday) = iCol + endif + enddo + else + nday = 0 + idxday = 0 endif + ! ####################################################################################### + ! Surface emissivity + ! ####################################################################################### + do iBand=1,lw_gas_props%get_nband() + sfc_emiss_byband(iBand,:) = semis + enddo + end subroutine GFS_rrtmgp_pre_run end module GFS_rrtmgp_pre diff --git a/physics/GFS_rrtmgp_pre.meta b/physics/GFS_rrtmgp_pre.meta index 88face855..455010e58 100644 --- a/physics/GFS_rrtmgp_pre.meta +++ b/physics/GFS_rrtmgp_pre.meta @@ -72,21 +72,14 @@ dimensions = () type = integer intent = in -[nTracers] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in -[lsswr] +[doSWrad] standard_name = flag_for_calling_shortwave_radiation long_name = logical flags for sw radiation calls units = flag dimensions = () type = logical intent = in -[lslwr] +[doLWrad] standard_name = flag_for_calling_longwave_radiation long_name = logical flags for lw radiation calls units = flag @@ -252,38 +245,6 @@ type = real kind = kind_phys intent = in -[minGPpres] - standard_name = minimum_pressure_in_RRTMGP - long_name = minimum pressure allowed in RRTMGP - units = Pa - dimensions = () - type = real - kind = kind_phys - intent = in -[maxGPpres] - standard_name = maximum_pressure_in_RRTMGP - long_name = maximum pressure allowed in RRTMGP - units = Pa - dimensions = () - type = real - kind = kind_phys - intent = in -[minGPtemp] - standard_name = minimum_temperature_in_RRTMGP - long_name = minimum temperature allowed in RRTMGP - units = K - dimensions = () - type = real - kind = kind_phys - intent = in -[maxGPtemp] - standard_name = maximum_temperature_in_RRTMGP - long_name = maximum temperature allowed in RRTMGP - units = K - dimensions = () - type = real - kind = kind_phys - intent = in [raddt] standard_name = time_step_for_radiation long_name = radiation time step @@ -354,21 +315,21 @@ units = flag dimensions = () type = logical - intent = out + intent = inout [iSFC] standard_name = vertical_index_for_surface_in_RRTMGP long_name = index for surface layer in RRTMGP units = flag dimensions = () type = integer - intent = out + intent = inout [iTOA] standard_name = vertical_index_for_TOA_in_RRTMGP long_name = index for TOA layer in RRTMGP units = flag dimensions = () type = integer - intent = out + intent = inout [tsfc_radtime] standard_name = surface_skin_temperature_on_radiation_timestep long_name = surface skin temperature on radiation timestep @@ -425,11 +386,51 @@ type = real kind = kind_phys intent = inout -[tracer] - standard_name = chemical_tracers - long_name = chemical tracers - units = g g-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) +[vmr_o2] + standard_name = volume_mixing_ratio_for_o2 + long_name = molar mixing ratio of o2 in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[vmr_h2o] + standard_name = volume_mixing_ratio_for_h2o + long_name = molar mixing ratio of h2o in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[vmr_o3] + standard_name = volume_mixing_ratio_for_o3 + long_name = molar mixing ratio of o3 in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[vmr_ch4] + standard_name = volume_mixing_ratio_for_ch4 + long_name = molar mixing ratio of ch4 in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[vmr_n2o] + standard_name = volume_mixing_ratio_for_n2o + long_name = molar mixing ratio of n2o in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[vmr_co2] + standard_name = volume_mixing_ratio_for_co2 + long_name = molar mixing ratio of co2 in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout @@ -441,13 +442,6 @@ type = character kind = len=* intent = in -[gas_concentrations] - standard_name = Gas_concentrations_for_RRTMGP_suite - long_name = DDT containing gas concentrations for RRTMGP radiation scheme - units = DDT - dimensions = () - type = ty_gas_concs - intent = inout [coszdg] standard_name = cosine_of_solar_zenith_angle_on_radiation_timestep long_name = daytime mean cosz over rad call period @@ -464,6 +458,36 @@ type = real kind = kind_phys intent = inout +[semis] + standard_name = surface_longwave_emissivity + long_name = surface lw emissivity in fraction + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[sfc_emiss_byband] + standard_name = surface_emissivity_in_each_RRTMGP_LW_band + long_name = surface emissivity in each RRTMGP LW band + units = none + dimensions = (number_of_longwave_bands,horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[nday] + standard_name = daytime_points_dimension + long_name = daytime points dimension + units = count + dimensions = () + type = integer + intent = inout +[idxday] + standard_name = daytime_points + long_name = daytime points + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = inout [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/GFS_rrtmgp_setup.F90 b/physics/GFS_rrtmgp_setup.F90 index 3cd8af019..f028acca2 100644 --- a/physics/GFS_rrtmgp_setup.F90 +++ b/physics/GFS_rrtmgp_setup.F90 @@ -156,7 +156,7 @@ end subroutine GFS_rrtmgp_setup_init !> \section arg_table_GFS_rrtmgp_setup_timestep_init !! \htmlinclude GFS_rrtmgp_setup_timestep_init.html !! - subroutine GFS_rrtmgp_setup_timestep_init (idate, jdate, deltsw, deltim, lsswr, me, & + subroutine GFS_rrtmgp_setup_timestep_init (idate, jdate, deltsw, deltim, doSWrad, me, & slag, sdec, cdec, solcon, errmsg, errflg) ! Inputs @@ -164,7 +164,7 @@ subroutine GFS_rrtmgp_setup_timestep_init (idate, jdate, deltsw, deltim, lsswr, integer, intent(in) :: jdate(:) real(kind_phys), intent(in) :: deltsw real(kind_phys), intent(in) :: deltim - logical, intent(in) :: lsswr + logical, intent(in) :: doSWrad integer, intent(in) :: me ! Outputs @@ -222,7 +222,7 @@ subroutine GFS_rrtmgp_setup_timestep_init (idate, jdate, deltsw, deltim, lsswr, endif ! Update solar forcing... - if (lsswr) then + if (doSWrad) then if ( isolar == 0 .or. isolar == 10 ) then lsol_chg = .false. elseif ( iyear0 /= iyear ) then diff --git a/physics/GFS_rrtmgp_setup.meta b/physics/GFS_rrtmgp_setup.meta index 41bf63ac8..160430765 100644 --- a/physics/GFS_rrtmgp_setup.meta +++ b/physics/GFS_rrtmgp_setup.meta @@ -256,7 +256,7 @@ type = real kind = kind_phys intent = in -[lsswr] +[doSWrad] standard_name = flag_for_calling_shortwave_radiation long_name = logical flags for sw radiation calls units = flag diff --git a/physics/GFS_rrtmgp_sw_post.F90 b/physics/GFS_rrtmgp_sw_post.F90 deleted file mode 100644 index 87ddc719b..000000000 --- a/physics/GFS_rrtmgp_sw_post.F90 +++ /dev/null @@ -1,286 +0,0 @@ -!> \file GFS_rrtmgp_sw_post.F90 -!! -!> \defgroup GFS_rrtmgp_sw_post GFS_rrtmgp_sw_post.F90 -!! -!! \brief RRTMGP Shortwave post-processing routine. -!! -module GFS_rrtmgp_sw_post - use machine, only: kind_phys - use module_radiation_aerosols, only: NSPC1 - use module_radsw_parameters, only: topfsw_type, sfcfsw_type, cmpfsw_type - use mo_heating_rates, only: compute_heating_rate - use radiation_tools, only: check_error_msg - use rrtmgp_sw_gas_optics, only: sw_gas_props - implicit none - - public GFS_rrtmgp_sw_post_run - -contains - -!>\defgroup gfs_rrtmgp_sw_post_mod GFS RRTMGP-SW Post Module -!> \section arg_table_GFS_rrtmgp_sw_post_run -!! \htmlinclude GFS_rrtmgp_sw_post_run.html -!! -!> \ingroup GFS_rrtmgp_sw_post -!! RRTMGP Shortwave post-processing routine. -!! -!! \brief The all-sky shortwave radiation tendency is computed, the clear-sky tendency is -!! computed if requested. -!! -!! RRTMGP surface and TOA fluxes are copied to fields that persist between radiation/physics -!! calls. -!! -!! (optional) Save additional diagnostics. -!! -!! \section GFS_rrtmgp_sw_post_run - ! ######################################################################################### - subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky_hr, & - save_diag, fhswr, coszen, coszdg, t_lay, p_lev, sfc_alb_nir_dir, sfc_alb_nir_dif, & - sfc_alb_uvvis_dir, sfc_alb_uvvis_dif, fluxswUP_allsky, & - fluxswDOWN_allsky, fluxswUP_clrsky, fluxswDOWN_clrsky, raddt, aerodp, cldsa, mbota, & - mtopa, cld_frac, cldtausw, fluxr, iSFC, iTOA, & - nirbmdi, nirdfdi, visbmdi, visdfdi, nirbmui, nirdfui, visbmui, visdfui, sfcnsw, & - sfcdsw, htrsw, sfcfsw, topfsw, htrswc, scmpsw, errmsg, errflg) - - ! Inputs - integer, intent(in) :: & - nCol, & ! Horizontal loop extent - nLev, & ! Number of vertical layers - nDay, & ! Number of daylit columns - iSFC, & ! Vertical index for surface level - iTOA ! Vertical index for TOA level - integer, intent(in), dimension(nday) :: & - idxday ! Index array for daytime points - logical, intent(in) :: & - lsswr, & ! Call SW radiation? - do_sw_clrsky_hr, & ! Output clear-sky SW heating-rate? - save_diag ! Output radiation diagnostics? - real(kind_phys), intent(in) :: & - fhswr ! Frequency for SW radiation - real(kind_phys), dimension(nCol), intent(in) :: & - t_lay, & ! Temperature at model layer centers (K) - coszen, & ! Cosine(SZA) - coszdg ! Cosine(SZA), daytime - real(kind_phys), dimension(nCol, nLev+1), intent(in) :: & - p_lev ! Pressure @ model layer-interfaces (Pa) - real(kind_phys), dimension(ncol), intent(in) :: & - sfc_alb_nir_dir, & ! Surface albedo (direct) - sfc_alb_nir_dif, & ! Surface albedo (diffuse) - sfc_alb_uvvis_dir, & ! Surface albedo (direct) - sfc_alb_uvvis_dif ! Surface albedo (diffuse) - real(kind_phys), dimension(nCol, nLev+1), intent(in) :: & - fluxswUP_allsky, & ! SW All-sky flux (W/m2) - fluxswDOWN_allsky, & ! SW All-sky flux (W/m2) - fluxswUP_clrsky, & ! SW Clear-sky flux (W/m2) - fluxswDOWN_clrsky ! SW All-sky flux (W/m2) - real(kind_phys), intent(in) :: & - raddt ! Radiation time step - real(kind_phys), dimension(nCol,NSPC1), intent(in) :: & - aerodp ! Vertical integrated optical depth for various aerosol species - real(kind_phys), dimension(nCol,5), intent(in) :: & - cldsa ! Fraction of clouds for low, middle, high, total and BL - integer, dimension(nCol,3), intent(in) ::& - mbota, & ! vertical indices for low, middle and high cloud tops - mtopa ! vertical indices for low, middle and high cloud bases - real(kind_phys), dimension(nCol,nLev), intent(in) :: & - cld_frac, & ! Total cloud fraction in each layer - cldtausw ! approx .55mu band layer cloud optical depth - type(cmpfsw_type), dimension(nCol), intent(in) :: & - scmpsw ! 2D surface fluxes, components: - ! uvbfc - total sky downward uv-b flux at (W/m2) - ! uvbf0 - clear sky downward uv-b flux at (W/m2) - ! nirbm - downward nir direct beam flux (W/m2) - ! nirdf - downward nir diffused flux (W/m2) - ! visbm - downward uv+vis direct beam flux (W/m2) - ! visdf - downward uv+vis diffused flux (W/m2) - - real(kind=kind_phys), dimension(:,:), intent(inout) :: fluxr - - ! Outputs (mandatory) - real(kind_phys), dimension(nCol), intent(inout) :: & - nirbmdi, & ! sfc nir beam sw downward flux (W/m2) - nirdfdi, & ! sfc nir diff sw downward flux (W/m2) - visbmdi, & ! sfc uv+vis beam sw downward flux (W/m2) - visdfdi, & ! sfc uv+vis diff sw downward flux (W/m2) - nirbmui, & ! sfc nir beam sw upward flux (W/m2) - nirdfui, & ! sfc nir diff sw upward flux (W/m2) - visbmui, & ! sfc uv+vis beam sw upward flux (W/m2) - visdfui, & ! sfc uv+vis diff sw upward flux (W/m2) - sfcnsw, & ! total sky sfc netsw flx into ground - sfcdsw ! - real(kind_phys), dimension(nCol,nLev), intent(inout) :: & - htrsw ! SW all-sky heating rate - type(sfcfsw_type), dimension(nCol), intent(inout) :: & - sfcfsw ! sw radiation fluxes at sfc - type(topfsw_type), dimension(nCol), intent(inout) :: & - topfsw ! sw_fluxes_top_atmosphere - character(len=*), intent(out) :: & - errmsg - integer, intent(out) :: & - errflg - - ! Outputs (optional) - real(kind_phys),dimension(nCol, nLev),intent(inout),optional :: & - htrswc ! Clear-sky heating rate (K/s) - - ! Local variables - integer :: i, j, k, itop, ibtc - real(kind_phys) :: tem0d, tem1, tem2 - real(kind_phys), dimension(nDay, nLev) :: thetaTendClrSky, thetaTendAllSky - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (.not. lsswr) return - if (nDay .gt. 0) then - - ! ####################################################################################### - ! Compute SW heating-rates - ! ####################################################################################### - ! Clear-sky heating-rate (optional) - if (do_sw_clrsky_hr) then - htrswc(:,:) = 0._kind_phys - call check_error_msg('GFS_rrtmgp_post',compute_heating_rate( & - fluxswUP_clrsky(idxday(1:nDay),:), & ! IN - Shortwave upward clear-sky flux profiles (W/m2) - fluxswDOWN_clrsky(idxday(1:nDay),:), & ! IN - Shortwave downward clear-sky flux profiles (W/m2) - p_lev(idxday(1:nDay),:), & ! IN - Pressure at model-interface (Pa) - thetaTendClrSky)) ! OUT - Clear-sky heating-rate (K/sec) - htrswc(idxday(1:nDay),:)=thetaTendClrSky !**NOTE** GP doesn't use radiation levels, it uses the model fields. Not sure if this is necessary - endif - - ! All-sky heating-rate (mandatory) - htrsw(:,:) = 0._kind_phys - call check_error_msg('GFS_rrtmgp_post',compute_heating_rate( & - fluxswUP_allsky(idxday(1:nDay),:), & ! IN - Shortwave upward all-sky flux profiles (W/m2) - fluxswDOWN_allsky(idxday(1:nDay),:), & ! IN - Shortwave downward all-sky flux profiles (W/m2) - p_lev(idxday(1:nDay),:), & ! IN - Pressure at model-interface (Pa) - thetaTendAllSky)) ! OUT - All-sky heating-rate (K/sec) - htrsw(idxday(1:nDay),:) = thetaTendAllSky - - ! ####################################################################################### - ! Save SW outputs - ! (Copy fluxes from RRTMGP types into model radiation types.) - ! ####################################################################################### - - ! TOA fluxes - topfsw(:)%upfxc = fluxswUP_allsky(:,iTOA) - topfsw(:)%upfx0 = fluxswUP_clrsky(:,iTOA) - topfsw(:)%dnfxc = fluxswDOWN_allsky(:,iTOA) - - ! Surface fluxes - sfcfsw(:)%upfxc = fluxswUP_allsky(:,iSFC) - sfcfsw(:)%upfx0 = fluxswUP_clrsky(:,iSFC) - sfcfsw(:)%dnfxc = fluxswDOWN_allsky(:,iSFC) - sfcfsw(:)%dnfx0 = fluxswDOWN_clrsky(:,iSFC) - - ! Surface down and up spectral component fluxes - ! - Save two spectral bands' surface downward and upward fluxes for output. - do i=1,nCol - nirbmdi(i) = scmpsw(i)%nirbm - nirdfdi(i) = scmpsw(i)%nirdf - visbmdi(i) = scmpsw(i)%visbm - visdfdi(i) = scmpsw(i)%visdf - nirbmui(i) = scmpsw(i)%nirbm * sfc_alb_nir_dir(i) - nirdfui(i) = scmpsw(i)%nirdf * sfc_alb_nir_dif(i) - visbmui(i) = scmpsw(i)%visbm * sfc_alb_uvvis_dir(i) - visdfui(i) = scmpsw(i)%visdf * sfc_alb_uvvis_dif(i) - enddo - else ! if_nday_block - ! ####################################################################################### - ! Dark everywhere - ! ####################################################################################### - htrsw(:,:) = 0.0 - sfcfsw = sfcfsw_type( 0.0, 0.0, 0.0, 0.0 ) - topfsw = topfsw_type( 0.0, 0.0, 0.0 ) - do i=1,nCol - nirbmdi(i) = 0.0 - nirdfdi(i) = 0.0 - visbmdi(i) = 0.0 - visdfdi(i) = 0.0 - nirbmui(i) = 0.0 - nirdfui(i) = 0.0 - visbmui(i) = 0.0 - visdfui(i) = 0.0 - enddo - - if (do_sw_clrsky_hr) then - htrswc(:,:) = 0 - endif - endif ! end_if_nday - - ! Radiation fluxes for other physics processes - do i=1,nCol - sfcnsw(i) = sfcfsw(i)%dnfxc - sfcfsw(i)%upfxc - sfcdsw(i) = sfcfsw(i)%dnfxc - enddo - - ! ####################################################################################### - ! Save SW diagnostics - ! - For time averaged output quantities (including total-sky and clear-sky SW and LW - ! fluxes at TOA and surface; conventional 3-domain cloud amount, cloud top and base - ! pressure, and cloud top temperature; aerosols AOD, etc.), store computed results in - ! corresponding slots of array fluxr with appropriate time weights. - ! - Collect the fluxr data for wrtsfc - ! ####################################################################################### - if (save_diag) then - do i=1,nCol - fluxr(i,34) = aerodp(i,1) ! total aod at 550nm - fluxr(i,35) = aerodp(i,2) ! DU aod at 550nm - fluxr(i,36) = aerodp(i,3) ! BC aod at 550nm - fluxr(i,37) = aerodp(i,4) ! OC aod at 550nm - fluxr(i,38) = aerodp(i,5) ! SU aod at 550nm - fluxr(i,39) = aerodp(i,6) ! SS aod at 550nm - if (coszen(i) > 0.) then - ! SW all-sky fluxes - tem0d = fhswr * coszdg(i) / coszen(i) - fluxr(i,2 ) = fluxr(i,2) + topfsw(i)%upfxc * tem0d ! total sky top sw up - fluxr(i,3 ) = fluxr(i,3) + sfcfsw(i)%upfxc * tem0d - fluxr(i,4 ) = fluxr(i,4) + sfcfsw(i)%dnfxc * tem0d ! total sky sfc sw dn - ! SW uv-b fluxes - fluxr(i,21) = fluxr(i,21) + scmpsw(i)%uvbfc * tem0d ! total sky uv-b sw dn - fluxr(i,22) = fluxr(i,22) + scmpsw(i)%uvbf0 * tem0d ! clear sky uv-b sw dn - ! SW TOA incoming fluxes - fluxr(i,23) = fluxr(i,23) + topfsw(i)%dnfxc * tem0d ! top sw dn - ! SW SFC flux components - fluxr(i,24) = fluxr(i,24) + visbmdi(i) * tem0d ! uv/vis beam sw dn - fluxr(i,25) = fluxr(i,25) + visdfdi(i) * tem0d ! uv/vis diff sw dn - fluxr(i,26) = fluxr(i,26) + nirbmdi(i) * tem0d ! nir beam sw dn - fluxr(i,27) = fluxr(i,27) + nirdfdi(i) * tem0d ! nir diff sw dn - ! SW clear-sky fluxes - fluxr(i,29) = fluxr(i,29) + topfsw(i)%upfx0 * tem0d - fluxr(i,31) = fluxr(i,31) + sfcfsw(i)%upfx0 * tem0d - fluxr(i,32) = fluxr(i,32) + sfcfsw(i)%dnfx0 * tem0d - endif - enddo - - ! Save total and boundary-layer clouds - do i=1,nCol - fluxr(i,17) = fluxr(i,17) + raddt * cldsa(i,4) - fluxr(i,18) = fluxr(i,18) + raddt * cldsa(i,5) - enddo - - ! Save cld frac,toplyr,botlyr and top temp, note that the order of h,m,l cloud - ! is reversed for the fluxr output. save interface pressure (pa) of top/bot - do j = 1, 3 - do i = 1, nCol - tem0d = raddt * cldsa(i,j) - itop = mtopa(i,j) - ibtc = mbota(i,j) - fluxr(i, 8-j) = fluxr(i, 8-j) + tem0d - fluxr(i,11-j) = fluxr(i,11-j) + tem0d * p_lev(i,itop) - fluxr(i,14-j) = fluxr(i,14-j) + tem0d * p_lev(i,ibtc) - fluxr(i,17-j) = fluxr(i,17-j) + tem0d * p_lev(i,itop) - - ! Add optical depth and emissivity output - tem1 = 0. - do k=ibtc,itop - tem1 = tem1 + cldtausw(i,k) ! approx .55 mu channel - enddo - fluxr(i,43-j) = fluxr(i,43-j) + tem0d * tem1 - enddo - enddo - endif - end subroutine GFS_rrtmgp_sw_post_run - -end module GFS_rrtmgp_sw_post diff --git a/physics/GFS_rrtmgp_sw_pre.F90 b/physics/GFS_rrtmgp_sw_pre.F90 deleted file mode 100644 index 87d0f9ad1..000000000 --- a/physics/GFS_rrtmgp_sw_pre.F90 +++ /dev/null @@ -1,95 +0,0 @@ -!> \file GFS_rrtmgp_sw_pre.F90 -!! This file contains code to gather the sunlit points for the RRTMGP shortwave scheme. -!! -!> \defgroup GFS_rrtmgp_sw_pre RRTMGP Shortwave pre -!! -!! \brief *TODO* Combine with rrtmg_sw_pre.F90, maybe call sw_rad_pre.F90, use by both. -!! -module GFS_rrtmgp_sw_pre - use machine, only: kind_phys - use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp - use rrtmgp_sw_gas_optics, only: sw_gas_props - public GFS_rrtmgp_sw_pre_run -contains - -!> \section arg_table_GFS_rrtmgp_sw_pre_run -!! \htmlinclude GFS_rrtmgp_sw_pre.html -!! -!! \section GFS_rrtmgp_sw_pre RRTMGP shortwave pre routine -!! @{ -!! -!! Gather the sunlit points for shortwave radiation. -!! - ! ######################################################################################### - subroutine GFS_rrtmgp_sw_pre_run(nCol, doSWrad, coszen, nday, idxday, sfc_alb_nir_dir, & - sfc_alb_nir_dif, sfc_alb_uvvis_dir, sfc_alb_uvvis_dif, sfc_alb_nir_dir_byband, & - sfc_alb_nir_dif_byband, sfc_alb_uvvis_dir_byband, sfc_alb_uvvis_dif_byband, errmsg, & - errflg) - - ! Input - integer, intent(in) :: & - nCol ! Number of horizontal grid points - logical,intent(in) :: & - doSWrad ! Call RRTMGP SW radiation? - real(kind_phys), dimension(:), intent(in) :: & - coszen - real(kind_phys), dimension(:), intent(in) :: & - sfc_alb_nir_dir, & ! - sfc_alb_nir_dif, & ! - sfc_alb_uvvis_dir, & ! - sfc_alb_uvvis_dif ! - - ! Outputs - integer, intent(out) :: & - nday ! Number of daylit points - integer, dimension(:), intent(out) :: & - idxday ! Indices for daylit points - real(kind_phys), dimension(:,:), intent(out) :: & - sfc_alb_nir_dir_byband, & ! Surface albedo (direct) - sfc_alb_nir_dif_byband, & ! Surface albedo (diffuse) - sfc_alb_uvvis_dir_byband, & ! Surface albedo (direct) - sfc_alb_uvvis_dif_byband ! Surface albedo (diffuse) - character(len=*), intent(out) :: & - errmsg ! Error message - integer, intent(out) :: & - errflg ! Error flag - - ! Local variables - integer :: i, iBand - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (doSWrad) then - ! #################################################################################### - ! For SW gather daylit points - ! #################################################################################### - nday = 0 - idxday = 0 - do i = 1, nCol - if (coszen(i) >= 0.0001) then - nday = nday + 1 - idxday(nday) = i - endif - enddo - - ! Spread across all SW bands - do iBand=1,sw_gas_props%get_nband() - sfc_alb_nir_dir_byband(iBand,1:nCol) = sfc_alb_nir_dir(1:nCol) - sfc_alb_nir_dif_byband(iBand,1:nCol) = sfc_alb_nir_dif(1:nCol) - sfc_alb_uvvis_dir_byband(iBand,1:nCol) = sfc_alb_uvvis_dir(1:nCol) - sfc_alb_uvvis_dif_byband(iBand,1:nCol) = sfc_alb_uvvis_dif(1:nCol) - enddo - else - nday = 0 - idxday = 0 - sfc_alb_nir_dir_byband(:,1:nCol) = 0. - sfc_alb_nir_dif_byband(:,1:nCol) = 0. - sfc_alb_uvvis_dir_byband(:,1:nCol) = 0. - sfc_alb_uvvis_dif_byband(:,1:nCol) = 0. - endif - - end subroutine GFS_rrtmgp_sw_pre_run -!> @} -end module GFS_rrtmgp_sw_pre diff --git a/physics/GFS_rrtmgp_sw_pre.meta b/physics/GFS_rrtmgp_sw_pre.meta deleted file mode 100644 index 462ab5f18..000000000 --- a/physics/GFS_rrtmgp_sw_pre.meta +++ /dev/null @@ -1,124 +0,0 @@ -[ccpp-table-properties] - name = GFS_rrtmgp_sw_pre - type = scheme - dependencies = machine.F,radiation_astronomy.f,rrtmgp_sw_gas_optics.F90,rte-rrtmgp/rrtmgp/mo_gas_optics_rrtmgp.F90, - -######################################################################## -[ccpp-arg-table] - name = GFS_rrtmgp_sw_pre_run - type = scheme -[ncol] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[doSWrad] - standard_name = flag_for_calling_shortwave_radiation - long_name = logical flags for sw radiation calls - units = flag - dimensions = () - type = logical - intent = in -[nday] - standard_name = daytime_points_dimension - long_name = daytime points dimension - units = count - dimensions = () - type = integer - intent = out -[idxday] - standard_name = daytime_points - long_name = daytime points - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = out -[coszen] - standard_name = cosine_of_solar_zenith_angle_for_daytime_points_on_radiation_timestep - long_name = mean cos of zenith angle over rad call period - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[sfc_alb_nir_dir] - standard_name = surface_albedo_due_to_near_IR_direct - long_name = surface albedo due to near IR direct beam - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[sfc_alb_nir_dif] - standard_name = surface_albedo_due_to_near_IR_diffused - long_name = surface albedo due to near IR diffused beam - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[sfc_alb_uvvis_dir] - standard_name = surface_albedo_due_to_UV_and_VIS_direct - long_name = surface albedo due to UV+VIS direct beam - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[sfc_alb_uvvis_dif] - standard_name = surface_albedo_due_to_UV_and_VIS_diffused - long_name = surface albedo due to UV+VIS diffused beam - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[sfc_alb_nir_dir_byband] - standard_name = surface_albedo_nearIR_direct - long_name = near-IR (direct) surface albedo (sfc_alb_nir_dir) - units = none - dimensions = (number_of_shortwave_bands,horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[sfc_alb_nir_dif_byband] - standard_name = surface_albedo_nearIR_diffuse - long_name = near-IR (diffuse) surface albedo (sfc_alb_nir_dif) - units = none - dimensions = (number_of_shortwave_bands,horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[sfc_alb_uvvis_dir_byband] - standard_name = surface_albedo_uvvis_direct - long_name = UVVIS (direct) surface albedo (sfc_alb_uvvis_dir) - units = none - dimensions = (number_of_shortwave_bands,horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[sfc_alb_uvvis_dif_byband] - standard_name = surface_albedo_uvvis_diffuse - long_name = UVVIS (diffuse) surface albedo (sfc_alb_uvvis_dif) - units = none - dimensions = (number_of_shortwave_bands,horizontal_loop_extent) - type = real - kind = kind_phys - intent = out -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out diff --git a/physics/rrtmgp_aerosol_optics.F90 b/physics/rrtmgp_aerosol_optics.F90 index e2cc95994..cf3f7deea 100644 --- a/physics/rrtmgp_aerosol_optics.F90 +++ b/physics/rrtmgp_aerosol_optics.F90 @@ -3,16 +3,10 @@ module rrtmgp_aerosol_optics use machine, only: kind_phys - use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp - use mo_optical_props, only: ty_optical_props_2str, ty_optical_props_1scl use radiation_tools, only: check_error_msg use rrtmgp_sw_gas_optics, only: sw_gas_props use rrtmgp_lw_gas_optics, only: lw_gas_props - use module_radiation_aerosols, only: & - NF_AESW, & ! Number of optical-fields in SW output (3=tau+g+omega) - NF_AELW, & ! Number of optical-fields in LW output (3=tau+g+omega) - setaer, & ! Routine to compute aerosol radiative properties (tau,g,omega) - NSPC1 ! Number of species for vertically integrated aerosol optical-depth + use module_radiation_aerosols, only: setaer use netcdf implicit none @@ -30,9 +24,9 @@ module rrtmgp_aerosol_optics !! \section arg_table_rrtmgp_aerosol_optics_run !! \htmlinclude rrtmgp_aerosol_optics_run.html !! - subroutine rrtmgp_aerosol_optics_run(doSWrad, doLWrad, nCol, nLev, nTracer, nTracerAer, & - nDay, idxday, p_lev, p_lay, p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, & - aerodp, sw_optical_props_aerosol, lw_optical_props_aerosol, errmsg, errflg ) + subroutine rrtmgp_aerosol_optics_run(doSWrad, doLWrad, nCol, nLev, nDay, idxday, p_lev, & + p_lay, p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, & + aerodp, aerlw_tau, aerlw_ssa, aerlw_g, aersw_tau, aersw_ssa, aersw_g, errmsg, errflg ) ! Inputs logical, intent(in) :: & @@ -41,10 +35,8 @@ subroutine rrtmgp_aerosol_optics_run(doSWrad, doLWrad, nCol, nLev, nTracer, nTra integer, intent(in) :: & nCol, & ! Number of horizontal grid points nDay, & ! Number of daylit points - nLev, & ! Number of vertical layers - nTracer, & ! Number of tracers - nTracerAer ! Number of aerosol tracers - integer,intent(in),dimension(:) :: & + nLev ! Number of vertical layers + integer,dimension(:), intent(in) :: & idxday ! Indices for daylit points. real(kind_phys), dimension(:), intent(in) :: & lon, & ! Longitude @@ -65,19 +57,22 @@ subroutine rrtmgp_aerosol_optics_run(doSWrad, doLWrad, nCol, nLev, nTracer, nTra ! Outputs real(kind_phys), dimension(:,:), intent(out) :: & aerodp ! Vertical integrated optical depth for various aerosol species - type(ty_optical_props_2str),intent(out) :: & - sw_optical_props_aerosol ! RRTMGP DDT: Longwave aerosol optical properties (tau) - type(ty_optical_props_1scl),intent(inout) :: & - lw_optical_props_aerosol ! RRTMGP DDT: Longwave aerosol optical properties (tau) + real(kind_phys), dimension(:,:,:), intent(out) :: & + aerlw_tau, & ! Longwave aerosol optical depth + aerlw_ssa, & ! Longwave aerosol single scattering albedo + aerlw_g, & ! Longwave aerosol asymmetry parameter + aersw_tau, & ! Shortwave aerosol optical depth + aersw_ssa, & ! Shortwave aerosol single scattering albedo + aersw_g ! Shortwave aerosol asymmetry parameter integer, intent(out) :: & errflg ! CCPP error flag character(len=*), intent(out) :: & errmsg ! CCPP error message ! Local variables - real(kind_phys), dimension(nCol, nLev, lw_gas_props%get_nband(), NF_AELW) :: & + real(kind_phys), dimension(nCol, nLev, lw_gas_props%get_nband(), 3) :: & aerosolslw ! - real(kind_phys), dimension(nCol, nLev, sw_gas_props%get_nband(), NF_AESW) :: & + real(kind_phys), dimension(nCol, nLev, sw_gas_props%get_nband(), 3) :: & aerosolssw, aerosolssw2 integer :: iBand @@ -85,14 +80,14 @@ subroutine rrtmgp_aerosol_optics_run(doSWrad, doLWrad, nCol, nLev, nTracer, nTra errmsg = '' errflg = 0 - if (.not. doSWrad) return + if (.not. (doSWrad .or. doLWrad)) return ! Call module_radiation_aerosols::setaer(),to setup aerosols property profile call setaer(p_lev*0.01, p_lay*0.01, p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, nCol, nLev, & nLev+1, .true., .true., aerosolssw2, aerosolslw, aerodp) ! Shortwave - if (nDay .gt. 0) then + if (doSWrad .and. (nDay .gt. 0)) then ! Store aerosol optical properties ! SW. ! For RRTMGP SW the bands are now ordered from [IR(band) -> nIR -> UV], in RRTMG the @@ -103,26 +98,19 @@ subroutine rrtmgp_aerosol_optics_run(doSWrad, doLWrad, nCol, nLev, nTracer, nTra aerosolssw(1:nCol,:,2:sw_gas_props%get_nband(),1) = aerosolssw2(1:nCol,:,1:sw_gas_props%get_nband()-1,1) aerosolssw(1:nCol,:,2:sw_gas_props%get_nband(),2) = aerosolssw2(1:nCol,:,1:sw_gas_props%get_nband()-1,2) aerosolssw(1:nCol,:,2:sw_gas_props%get_nband(),3) = aerosolssw2(1:nCol,:,1:sw_gas_props%get_nband()-1,3) - - ! Allocate RRTMGP DDT: Aerosol optics [nCol,nlev,nBands] - call check_error_msg('rrtmgp_aerosol_optics_run',sw_optical_props_aerosol%alloc_2str( & - nDay, nlev, sw_gas_props%get_band_lims_wavenumber())) - - ! Copy aerosol optical information to RRTMGP DDT - sw_optical_props_aerosol%tau = aerosolssw(idxday(1:nday),:,:,1) - sw_optical_props_aerosol%ssa = aerosolssw(idxday(1:nday),:,:,2) - sw_optical_props_aerosol%g = aerosolssw(idxday(1:nday),:,:,3) + + ! Copy aerosol optical information/ + aersw_tau = aerosolssw(:,:,:,1) + aersw_ssa = aerosolssw(:,:,:,2) + aersw_g = aerosolssw(:,:,:,3) endif ! Longwave - if (.not. doLWrad) return - lw_optical_props_aerosol%tau = aerosolslw(:,:,:,1) * (1. - aerosolslw(:,:,:,2)) - - lw_optical_props_aerosol%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() - do iBand=1,lw_gas_props%get_nband() - lw_optical_props_aerosol%band2gpt(1:2,iBand) = iBand - lw_optical_props_aerosol%gpt2band(iBand) = iBand - end do + if (doLWrad) then + aerlw_tau = aerosolslw(:,:,:,1) + aerlw_ssa = aerosolslw(:,:,:,2) + aerlw_g = aerosolslw(:,:,:,3) + endif end subroutine rrtmgp_aerosol_optics_run !> @} diff --git a/physics/rrtmgp_aerosol_optics.meta b/physics/rrtmgp_aerosol_optics.meta index f0c37edc0..6dbf9c73c 100644 --- a/physics/rrtmgp_aerosol_optics.meta +++ b/physics/rrtmgp_aerosol_optics.meta @@ -35,20 +35,6 @@ dimensions = () type = integer intent = in -[nTracer] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in -[nTracerAer] - standard_name = number_of_aerosol_tracers_MG - long_name = number of aerosol tracers for Morrison Gettelman MP - units = count - dimensions = () - type = integer - intent = in [nday] standard_name = daytime_points_dimension long_name = daytime points dimension @@ -112,9 +98,9 @@ kind = kind_phys intent = in [tracer] - standard_name = chemical_tracers - long_name = chemical tracers - units = g g-1 + standard_name = tracer_concentration + long_name = model layer mean tracer concentration + units = kg kg-1 dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) type = real kind = kind_phys @@ -151,20 +137,54 @@ type = real kind = kind_phys intent = out -[sw_optical_props_aerosol] - standard_name = shortwave_optical_properties_for_aerosols - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str +[aersw_tau] + standard_name = aerosol_optical_depth_for_shortwave_bands_01_16 + long_name = aerosol optical depth for shortwave bands 01-16 + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_aerosol_bands_for_shortwave_radiation) + type = real + kind = kind_phys + intent = out +[aersw_ssa] + standard_name = aerosol_single_scattering_albedo_for_shortwave_bands_01_16 + long_name = aerosol single scattering albedo for shortwave bands 01-16 + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_aerosol_bands_for_shortwave_radiation) + type = real + kind = kind_phys + intent = out +[aersw_g] + standard_name = aerosol_asymmetry_parameter_for_shortwave_bands_01_16 + long_name = aerosol asymmetry parameter for shortwave bands 01-16 + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_aerosol_bands_for_shortwave_radiation) + type = real + kind = kind_phys + intent = out +[aerlw_tau] + standard_name = aerosol_optical_depth_for_longwave_bands_01_16 + long_name = aerosol optical depth for longwave bands 01-16 + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_aerosol_bands_for_longwave_radiation) + type = real + kind = kind_phys + intent = out +[aerlw_ssa] + standard_name = aerosol_single_scattering_albedo_for_longwave_bands_01_16 + long_name = aerosol single scattering albedo for longwave bands 01-16 + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_aerosol_bands_for_longwave_radiation) + type = real + kind = kind_phys + intent = out +[aerlw_g] + standard_name = aerosol_asymmetry_parameter_for_longwave_bands_01_16 + long_name = aerosol asymmetry parameter for longwave bands 01-16 + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_aerosol_bands_for_longwave_radiation) + type = real + kind = kind_phys intent = out -[lw_optical_props_aerosol] - standard_name = longwave_optical_properties_for_aerosols - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_1scl - intent = inout [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/rrtmgp_lw_cloud_optics.F90 b/physics/rrtmgp_lw_cloud_optics.F90 index 8bdd71696..9915c0040 100644 --- a/physics/rrtmgp_lw_cloud_optics.F90 +++ b/physics/rrtmgp_lw_cloud_optics.F90 @@ -12,8 +12,6 @@ module rrtmgp_lw_cloud_optics use machine, only: kind_phys use mo_rte_kind, only: wl use mo_cloud_optics, only: ty_cloud_optics - use mo_optical_props, only: ty_optical_props_1scl, ty_optical_props_2str - use mo_rrtmg_lw_cloud_optics, only: rrtmg_lw_cloud_optics use rrtmgp_lw_gas_optics, only: lw_gas_props use radiation_tools, only: check_error_msg use netcdf @@ -74,55 +72,42 @@ module rrtmgp_lw_cloud_optics contains -!>\defgroup rrtmgp_lw_cloud_optics_mod GFS RRTMGP-LW Cloud Optics Module -!> \section arg_table_rrtmgp_lw_cloud_optics_init -!! \htmlinclude rrtmgp_lw_cloud_optics.html -!! -!> \ingroup rrtmgp_lw_cloud_optics -!! -!! RRTMGP relies heavily on derived-data-types, which contain type-bound procedures -!! that are referenced frequently throughout the RRTMGP longwave scheme. The data needed -!! to compute the shortwave cloud optical properties are initialized here and loaded into -!! the RRTMGP DDT, ty_cloud_optics. -!! -!! \section rrtmgp_sw_cloud_optics_init - subroutine rrtmgp_lw_cloud_optics_init(nrghice, mpicomm, mpirank, mpiroot, & - doG_cldoptics, doGP_cldoptics_PADE, doGP_cldoptics_LUT, rrtmgp_root_dir, & - rrtmgp_lw_file_clouds, errmsg, errflg) + ! ###################################################################################### + ! SUBROUTINE rrtmgp_lw_cloud_optics_init() + ! ###################################################################################### + subroutine rrtmgp_lw_cloud_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_clouds, & + doGP_cldoptics_PADE, doGP_cldoptics_LUT, nrghice, mpicomm, mpirank, mpiroot, & + errmsg, errflg) ! Inputs + character(len=128),intent(in) :: & + rrtmgp_root_dir, & ! RTE-RRTMGP root directory + rrtmgp_lw_file_clouds ! RRTMGP file containing clouds optics data + logical, intent(in) :: & - doG_cldoptics, & ! Use legacy RRTMG cloud-optics? - doGP_cldoptics_PADE, & ! Use RRTMGP cloud-optics: PADE approximation? - doGP_cldoptics_LUT ! Use RRTMGP cloud-optics: LUTs? + doGP_cldoptics_PADE,& ! Use RRTMGP cloud-optics: PADE approximation? + doGP_cldoptics_LUT ! Use RRTMGP cloud-optics: LUTs? integer, intent(inout) :: & - nrghice ! Number of ice-roughness categories + nrghice ! Number of ice-roughness categories integer, intent(in) :: & - mpicomm, & ! MPI communicator - mpirank, & ! Current MPI rank - mpiroot ! Master MPI rank - character(len=128),intent(in) :: & - rrtmgp_root_dir, & ! RTE-RRTMGP root directory - rrtmgp_lw_file_clouds ! RRTMGP file containing coefficients used to compute clouds optical properties + mpicomm, & ! MPI communicator + mpirank, & ! Current MPI rank + mpiroot ! Master MPI rank ! Outputs character(len=*), intent(out) :: & - errmsg ! Error message + errmsg ! Error message integer, intent(out) :: & - errflg ! Error code + errflg ! Error code ! Local variables integer :: dimID,varID,status,ncid,mpierr character(len=264) :: lw_cloud_props_file - integer,parameter :: max_strlen=256, nrghice_default=2 ! Initialize errmsg = '' errflg = 0 - ! If not using RRTMGP cloud optics, return. - if (doG_cldoptics) return - ! Filenames are set in the physics_nml lw_cloud_props_file = trim(rrtmgp_root_dir)//trim(rrtmgp_lw_file_clouds) @@ -391,171 +376,4 @@ subroutine rrtmgp_lw_cloud_optics_init(nrghice, mpicomm, mpirank, mpiroot, call check_error_msg('lw_cloud_optics_init',lw_cloud_props%set_ice_roughness(nrghice)) end subroutine rrtmgp_lw_cloud_optics_init - ! ###################################################################################### -!> \section arg_table_rrtmgp_lw_cloud_optics_run -!! \htmlinclude rrtmgp_lw_cloud_optics.html -!! -!> \ingroup rrtmgp_lw_cloud_optics -!! -!! Compute longwave optical prperties (optical-depth) for ALL cloud types visible to RRTMGP. -!! -!! \section rrtmgp_lw_gas_optics_run - subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw, & - doGP_cldoptics_PADE, doGP_cldoptics_LUT, doGP_lwscat, do_mynnedmf, imfdeepcnv, & - imfdeepcnv_gf, imfdeepcnv_samf, nCol, nLev, nbndsGPlw , p_lay, cld_frac, cld_lwp, & - cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, cld_rerain, & - precip_frac, cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, cld_cnv_reice, cld_pbl_lwp, & - cld_pbl_reliq, cld_pbl_iwp, cld_pbl_reice, lon, lat, cldtaulw, & - lw_optical_props_cloudsByBand, lw_optical_props_cnvcloudsByBand, & - lw_optical_props_MYNNcloudsByBand, lw_optical_props_precipByBand, errmsg, errflg) - - ! Inputs - logical, intent(in) :: & - doLWrad, & ! Logical flag for longwave radiation call - doG_cldoptics, & ! Use legacy RRTMG cloud-optics? - doGP_cldoptics_PADE, & ! Use RRTMGP cloud-optics: PADE approximation? - doGP_cldoptics_LUT, & ! Use RRTMGP cloud-optics: LUTs? - doGP_lwscat, & ! Include scattering in LW cloud-optics? - do_mynnedmf ! - integer, intent(in) :: & - nbndsGPlw, & ! - nCol, & ! Number of horizontal gridpoints - nLev, & ! Number of vertical levels - icliq_lw, & ! Choice of treatment of liquid cloud optical properties (RRTMG legacy) - icice_lw, & ! Choice of treatment of ice cloud optical properties (RRTMG legacy) - imfdeepcnv, & ! - imfdeepcnv_gf, & ! - imfdeepcnv_samf ! - real(kind_phys), dimension(:), intent(in) :: & - lon, & ! Longitude - lat ! Latitude - real(kind_phys), dimension(:,:),intent(in) :: & - p_lay, & ! Layer pressure (Pa) - cld_frac, & ! Total cloud fraction by layer - cld_lwp, & ! Cloud liquid water path - cld_reliq, & ! Cloud liquid effective radius - cld_iwp, & ! Cloud ice water path - cld_reice, & ! Cloud ice effective radius - cld_swp, & ! Cloud snow water path - cld_resnow, & ! Cloud snow effective radius - cld_rwp, & ! Cloud rain water path - cld_rerain, & ! Cloud rain effective radius - precip_frac, & ! Precipitation fraction by layer. - cld_cnv_lwp, & ! Water path for convective liquid cloud-particles (microns) - cld_cnv_reliq, & ! Effective radius for convective liquid cloud-particles (microns) - cld_cnv_iwp, & ! Water path for convective ice cloud-particles (microns) - cld_cnv_reice, & ! Effective radius for convective ice cloud-particles (microns) - cld_pbl_lwp, & ! Water path for SGS PBL liquid cloud-particles - cld_pbl_reliq, & ! Effective radius for SGS PBL liquid cloud-particles - cld_pbl_iwp, & ! Water path for SGS PBL ice cloud-particles - cld_pbl_reice ! Effective radius for SGS PBL ice cloud-particles - - ! Outputs - character(len=*), intent(out) :: & - errmsg ! CCPP error message - integer, intent(out) :: & - errflg ! CCPP error flag - type(ty_optical_props_2str),intent(inout) :: & - lw_optical_props_cloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (clouds) - lw_optical_props_cnvcloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (convective cloud) - lw_optical_props_MYNNcloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (MYNN-PBL cloud) - lw_optical_props_precipByBand ! RRTMGP DDT: Longwave optical properties in each band (precipitation) - real(kind_phys), dimension(:,:), intent(inout) :: & - cldtaulw ! Approx 10.mu band layer cloud optical depth - - ! Local variables - real(kind_phys) :: tau_rain, tau_snow - real(kind_phys), dimension(ncol,nLev,nbndsGPlw) :: & - tau_cld, tau_precip - integer :: iCol, iLay, iBand - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - ! Initialize locals - tau_cld = 0._kind_phys - tau_precip = 0._kind_phys - - if (.not. doLWrad) return - - ! Compute cloud-optics for RTE. - if (doGP_cldoptics_PADE .or. doGP_cldoptics_LUT) then - - ! i) Cloud-optics. - lw_optical_props_cloudsByBand%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() - do iBand=1,lw_gas_props%get_nband() - lw_optical_props_cloudsByBand%band2gpt(1:2,iBand) = iBand - lw_optical_props_cloudsByBand%gpt2band(iBand) = iBand - end do - call check_error_msg('rrtmgp_lw_cloud_optics_run - clouds',lw_cloud_props%cloud_optics(& - cld_lwp, & ! IN - Cloud liquid water path (g/m2) - cld_iwp, & ! IN - Cloud ice water path (g/m2) - cld_reliq, & ! IN - Cloud liquid effective radius (microns) - cld_reice, & ! IN - Cloud ice effective radius (microns) - lw_optical_props_cloudsByBand)) ! OUT - RRTMGP DDT containing cloud radiative properties - ! in each band - ! ii) Convective cloud-optics - if (imfdeepcnv == imfdeepcnv_samf .or. imfdeepcnv == imfdeepcnv_gf) then - lw_optical_props_cnvcloudsByBand%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() - do iBand=1,lw_gas_props%get_nband() - lw_optical_props_cnvcloudsByBand%band2gpt(1:2,iBand) = iBand - lw_optical_props_cnvcloudsByBand%gpt2band(iBand) = iBand - end do - call check_error_msg('rrtmgp_lw_cnvcloud_optics_run - convective cloud',lw_cloud_props%cloud_optics(& - cld_cnv_lwp, & ! IN - Convective cloud liquid water path (g/m2) - cld_cnv_iwp, & ! IN - Convective cloud ice water path (g/m2) - cld_cnv_reliq, & ! IN - Convective cloud liquid effective radius (microns) - cld_cnv_reice, & ! IN - Convective cloud ice effective radius (microns) - lw_optical_props_cnvcloudsByBand)) ! OUT - RRTMGP DDT containing convective cloud radiative properties - ! in each band - endif - - ! iii) MYNN cloud-optics - if (do_mynnedmf) then - lw_optical_props_MYNNcloudsByBand%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() - do iBand=1,lw_gas_props%get_nband() - lw_optical_props_MYNNcloudsByBand%band2gpt(1:2,iBand) = iBand - lw_optical_props_MYNNcloudsByBand%gpt2band(iBand) = iBand - end do - call check_error_msg('rrtmgp_lw_MYNNcloud_optics_run - MYNN-EDMF cloud',lw_cloud_props%cloud_optics(& - cld_pbl_lwp, & ! IN - MYNN-EDMF PBL cloud liquid water path (g/m2) - cld_pbl_iwp, & ! IN - MYNN-EDMF PBL cloud ice water path (g/m2) - cld_pbl_reliq, & ! IN - MYNN-EDMF PBL cloud liquid effective radius (microns) - cld_pbl_reice, & ! IN - MYNN-EDMF PBL cloud ice effective radius (microns) - lw_optical_props_MYNNcloudsByBand)) ! OUT - RRTMGP DDT containing MYNN-EDMF PBL cloud radiative properties - ! in each band - endif - - ! iv) Cloud precipitation optics: rain and snow(+groupel) - lw_optical_props_precipByBand%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() - do iBand=1,lw_gas_props%get_nband() - lw_optical_props_precipByBand%band2gpt(1:2,iBand) = iBand - lw_optical_props_precipByBand%gpt2band(iBand) = iBand - end do - do iCol=1,nCol - do iLay=1,nLev - if (cld_frac(iCol,iLay) .gt. 0.) then - ! Rain optical-depth (No band dependence) - tau_rain = absrain*cld_rwp(iCol,iLay) - - ! Snow (+groupel) optical-depth (No band dependence) - if (cld_swp(iCol,iLay) .gt. 0. .and. cld_resnow(iCol,iLay) .gt. 10._kind_phys) then - tau_snow = abssnow0*1.05756*cld_swp(iCol,iLay)/cld_resnow(iCol,iLay) - else - tau_snow = 0.0 - endif - do iBand=1,nbndsGPlw - lw_optical_props_precipByBand%tau(iCol,iLay,iBand) = tau_rain + tau_snow - enddo - endif - enddo - enddo - endif - - ! All-sky LW optical depth ~10microns (DJS asks: Same as SW, move to cloud-diagnostics?) - cldtaulw = lw_optical_props_cloudsByBand%tau(:,:,7) - - end subroutine rrtmgp_lw_cloud_optics_run - end module rrtmgp_lw_cloud_optics diff --git a/physics/rrtmgp_lw_cloud_optics.meta b/physics/rrtmgp_lw_cloud_optics.meta deleted file mode 100644 index c58496dc5..000000000 --- a/physics/rrtmgp_lw_cloud_optics.meta +++ /dev/null @@ -1,412 +0,0 @@ -[ccpp-table-properties] - name = rrtmgp_lw_cloud_optics - type = scheme - dependencies = machine.F,rrtmg_lw_cloud_optics.F90,radiation_tools.F90 - -######################################################################## -[ccpp-arg-table] - name = rrtmgp_lw_cloud_optics_init - type = scheme -[doG_cldoptics] - standard_name = flag_to_calc_lw_cld_optics_using_RRTMG - long_name = logical flag to control cloud optics scheme. - units = flag - dimensions = () - type = logical - intent = in -[doGP_cldoptics_PADE] - standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_PADE - long_name = logical flag to control cloud optics scheme. - units = flag - dimensions = () - type = logical - intent = in -[doGP_cldoptics_LUT] - standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_LUT - long_name = logical flag to control cloud optics scheme. - units = flag - dimensions = () - type = logical - intent = in -[nrghice] - standard_name = number_of_ice_roughness_categories - long_name = number of ice-roughness categories in RRTMGP calculation - units = count - dimensions = () - type = integer - intent = inout -[rrtmgp_root_dir] - standard_name = directory_for_rte_rrtmgp_source_code - long_name = directory for rte+rrtmgp source code - units = none - dimensions = () - type = character - intent = in - kind = len=128 -[rrtmgp_lw_file_clouds] - standard_name = filename_of_rrtmgp_longwave_cloud_optics_coefficients - long_name = file containing coefficients for RRTMGP LW cloud optics - units = none - dimensions = () - type = character - intent = in - kind = len=128 -[mpirank] - standard_name = mpi_rank - long_name = current MPI rank - units = index - dimensions = () - type = integer - intent = in -[mpiroot] - standard_name = mpi_root - long_name = master MPI rank - units = index - dimensions = () - type = integer - intent = in -[mpicomm] - standard_name = mpi_communicator - long_name = MPI communicator - units = index - dimensions = () - type = integer - intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - -######################################################################## -[ccpp-arg-table] - name = rrtmgp_lw_cloud_optics_run - type = scheme -[doLWrad] - standard_name = flag_for_calling_longwave_radiation - long_name = logical flags for lw radiation calls - units = flag - dimensions = () - type = logical - intent = in -[doG_cldoptics] - standard_name = flag_to_calc_lw_cld_optics_using_RRTMG - long_name = logical flag to control cloud optics scheme. - units = flag - dimensions = () - type = logical - intent = in -[icliq_lw] - standard_name = flag_for_optical_property_for_liquid_clouds_for_longwave_radiation - long_name = lw optical property for liquid clouds - units = flag - dimensions = () - type = integer - intent = in -[icice_lw] - standard_name = flag_for_optical_property_for_ice_clouds_for_longwave_radiation - long_name = lw optical property for ice clouds - units = flag - dimensions = () - type = integer - intent = in -[doGP_cldoptics_PADE] - standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_PADE - long_name = logical flag to control cloud optics scheme. - units = flag - dimensions = () - type = logical - intent = in -[doGP_cldoptics_LUT] - standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_LUT - long_name = logical flag to control cloud optics scheme. - units = flag - dimensions = () - type = logical - intent = in -[doGP_lwscat] - standard_name = flag_to_include_longwave_scattering_in_cloud_optics - long_name = logical flag to control the addition of LW scattering in RRTMGP - units = flag - dimensions = () - type = logical - intent = in -[do_mynnedmf] - standard_name = flag_for_mellor_yamada_nakanishi_niino_pbl_scheme - long_name = flag to activate MYNN-EDMF - units = flag - dimensions = () - type = logical - intent = in -[imfdeepcnv] - standard_name = control_for_deep_convection_scheme - long_name = flag for mass-flux deep convection scheme - units = flag - dimensions = () - type = integer - intent = in -[imfdeepcnv_gf] - standard_name = identifier_for_grell_freitas_deep_convection - long_name = flag for Grell-Freitas deep convection scheme - units = flag - dimensions = () - type = integer - intent = in -[imfdeepcnv_samf] - standard_name = identifer_for_scale_aware_mass_flux_deep_convection - long_name = flag for SAMF deep convection scheme - units = flag - dimensions = () - type = integer - intent = in -[ncol] - standard_name = horizontal_loop_extent - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in -[nLev] - standard_name = vertical_layer_dimension - long_name = number of vertical levels - units = count - dimensions = () - type = integer - intent = in -[cld_frac] - standard_name = total_cloud_fraction - long_name = layer total cloud fraction - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - intent = in - kind = kind_phys -[cld_lwp] - standard_name = cloud_liquid_water_path - long_name = layer cloud liquid water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - intent = in - kind = kind_phys -[cld_reliq] - standard_name = mean_effective_radius_for_liquid_cloud - long_name = mean effective radius for liquid cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - intent = in - kind = kind_phys -[cld_iwp] - standard_name = cloud_ice_water_path - long_name = layer cloud ice water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - intent = in - kind = kind_phys -[cld_reice] - standard_name = mean_effective_radius_for_ice_cloud - long_name = mean effective radius for ice cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - intent = in - kind = kind_phys -[cld_swp] - standard_name = cloud_snow_water_path - long_name = cloud snow water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - intent = in - kind = kind_phys -[cld_resnow] - standard_name = mean_effective_radius_for_snow_flake - long_name = mean effective radius for snow flake - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - intent = in - kind = kind_phys -[cld_rwp] - standard_name = cloud_rain_water_path - long_name = cloud rain water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - intent = in - kind = kind_phys -[cld_rerain] - standard_name = mean_effective_radius_for_rain_drop - long_name = mean effective radius for rain drop - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - intent = in - kind = kind_phys -[precip_frac] - standard_name = precipitation_fraction_by_layer - long_name = precipitation fraction in each layer - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_cnv_lwp] - standard_name = convective_cloud_liquid_water_path - long_name = layer convective cloud liquid water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_cnv_iwp] - standard_name = convective_cloud_ice_water_path - long_name = layer convective cloud ice water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_cnv_reliq] - standard_name = mean_effective_radius_for_liquid_convective_cloud - long_name = mean effective radius for liquid convective cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_cnv_reice] - standard_name = mean_effective_radius_for_ice_convective_cloud - long_name = mean effective radius for ice convective cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_pbl_lwp] - standard_name = MYNN_SGS_cloud_liquid_water_path - long_name = layer convective cloud liquid water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_pbl_iwp] - standard_name = MYNN_SGS_cloud_ice_water_path - long_name = layer convective cloud ice water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_pbl_reliq] - standard_name = mean_effective_radius_for_liquid_MYNN_SGS_cloud - long_name = mean effective radius for liquid MYNN_SGS cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_pbl_reice] - standard_name = mean_effective_radius_for_ice_MYNN_SGS_cloud - long_name = mean effective radius for ice MYNN_SGS cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[p_lay] - standard_name = air_pressure_at_layer_for_RRTMGP - long_name = air pressure layer - units = Pa - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[nbndsGPlw] - standard_name = number_of_longwave_bands - long_name = number of lw bands used in RRTMGP - units = count - dimensions = () - type = integer - intent = in -[lon] - standard_name = longitude - long_name = longitude - units = radian - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[lat] - standard_name = latitude - long_name = latitude - units = radian - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[cldtaulw] - standard_name = cloud_optical_depth_layers_at_10mu_band - long_name = approx 10mu band layer cloud optical depth - units = none - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[lw_optical_props_cloudsByBand] - standard_name = longwave_optical_properties_for_cloudy_atmosphere_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = inout -[lw_optical_props_cnvcloudsByBand] - standard_name = longwave_optical_properties_for_convective_cloudy_atmosphere_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = inout -[lw_optical_props_MYNNcloudsByBand] - standard_name = longwave_optical_properties_for_MYNN_EDMF_PBL_cloudy_atmosphere_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = inout -[lw_optical_props_precipByBand] - standard_name = longwave_optical_properties_for_precipitation_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = inout -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - diff --git a/physics/rrtmgp_lw_cloud_sampling.F90 b/physics/rrtmgp_lw_cloud_sampling.F90 deleted file mode 100644 index 80fd3444a..000000000 --- a/physics/rrtmgp_lw_cloud_sampling.F90 +++ /dev/null @@ -1,170 +0,0 @@ -!> \file rrtmgp_lw_cloud_sampling.F90 -!! -!> \defgroup rrtmgp_lw_cloud_sampling rrtmgp_lw_cloud_sampling.F90 -!! -!! \brief -!! -module rrtmgp_lw_cloud_sampling - use machine, only: kind_phys, kind_dbl_prec - use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp - use mo_optical_props, only: ty_optical_props_2str - use rrtmgp_sampling, only: sampled_mask, draw_samples - use mersenne_twister, only: random_setseed, random_number, random_stat - use radiation_tools, only: check_error_msg - use rrtmgp_lw_gas_optics, only: lw_gas_props - use netcdf - - implicit none - -contains - -!>\defgroup rrtmgp_lw_cloud_sampling_mod GFS RRTMGP-LW Cloud Sampling Module -!> \section arg_table_rrtmgp_lw_cloud_sampling_run -!! \htmlinclude rrtmgp_lw_cloud_sampling_run.html -!! -!> \ingroup rrtmgp_lw_cloud_sampling -!! -!! \brief This routine performs the McICA cloud-sampling and maps the shortwave cloud- -!! optical properties, defined for each spectral band, to each spectral point (g-point). -!! -!! \section rrtmgp_lw_cloud_sampling_run - subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, icseed_lw, iovr,iovr_convcld,& - iovr_max, iovr_maxrand, iovr_rand, iovr_dcorr, iovr_exp, iovr_exprand, isubc_lw, & - cld_frac, precip_frac, cloud_overlap_param, precip_overlap_param, cld_cnv_frac, & - cnv_cloud_overlap_param, imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_samf, & - lw_optical_props_cloudsByBand, lw_optical_props_cnvcloudsByBand, & - lw_optical_props_precipByBand, lw_optical_props_clouds, lw_optical_props_cnvclouds, & - lw_optical_props_precip, errmsg, errflg) - - ! Inputs - logical, intent(in) :: & - doLWrad ! Logical flag for shortwave radiation call - integer, intent(in) :: & - nCol, & ! Number of horizontal gridpoints - nLev, & ! Number of vertical layers - imfdeepcnv, & ! - imfdeepcnv_gf, & ! - imfdeepcnv_samf, & ! - iovr, & ! Choice of cloud-overlap method - iovr_convcld, & ! Choice of convective cloud-overlap - iovr_max, & ! Flag for maximum cloud overlap method - iovr_maxrand, & ! Flag for maximum-random cloud overlap method - iovr_rand, & ! Flag for random cloud overlap method - iovr_dcorr, & ! Flag for decorrelation-length cloud overlap method - iovr_exp, & ! Flag for exponential cloud overlap method - iovr_exprand, & ! Flag for exponential-random cloud overlap method - isubc_lw - integer,intent(in),dimension(:) :: & - icseed_lw ! auxiliary special cloud related array when module - ! variable isubc_lw=2, it provides permutation seed - ! for each column profile that are used for generating - ! random numbers. when isubc_lw /=2, it will not be used. - real(kind_phys), dimension(:,:),intent(in) :: & - cld_frac, & ! Total cloud fraction by layer - cld_cnv_frac, & ! Convective cloud fraction by layer - precip_frac, & ! Precipitation fraction by layer - cloud_overlap_param, & ! Cloud overlap parameter - cnv_cloud_overlap_param, & ! Convective cloud overlap parameter - precip_overlap_param ! Precipitation overlap parameter - type(ty_optical_props_2str),intent(in) :: & - lw_optical_props_cloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (clouds) - lw_optical_props_cnvcloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (convective cloud) - lw_optical_props_precipByBand ! RRTMGP DDT: Longwave optical properties in each band (precipitation) - - ! Outputs - character(len=*), intent(out) :: & - errmsg ! CCPP error message - integer, intent(out) :: & - errflg ! CCPP error code - type(ty_optical_props_2str),intent(inout) :: & - lw_optical_props_clouds, & ! RRTMGP DDT: Shortwave optical properties by spectral point (clouds) - lw_optical_props_cnvclouds, & ! RRTMGP DDT: Shortwave optical properties by spectral point (convective cloud) - lw_optical_props_precip ! RRTMGP DDT: Shortwave optical properties by spectral point (precipitation) - - ! Local variables - integer :: iCol, iLay, iBand - integer,dimension(ncol) :: ipseed_lw - type(random_stat) :: rng_stat - real(kind_dbl_prec), dimension(lw_gas_props%get_ngpt(),nLev,ncol) :: rng3D,rng3D2 - real(kind_dbl_prec), dimension(lw_gas_props%get_ngpt()*nLev) :: rng2D - real(kind_dbl_prec), dimension(lw_gas_props%get_ngpt()) :: rng1D - logical, dimension(ncol,nLev,lw_gas_props%get_ngpt()) :: maskMCICA - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (.not. doLWrad) return - - ! #################################################################################### - ! First sample the clouds... - ! #################################################################################### - lw_optical_props_clouds%band2gpt = lw_gas_props%get_band_lims_gpoint() - lw_optical_props_clouds%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() - do iBand=1,lw_gas_props%get_nband() - lw_optical_props_clouds%gpt2band(lw_optical_props_clouds%band2gpt(1,iBand):lw_optical_props_clouds%band2gpt(2,iBand)) = iBand - end do - - ! Change random number seed value for each radiation invocation (isubc_lw =1 or 2). - if(isubc_lw == 1) then ! advance prescribed permutation seed - do iCol = 1, ncol - ipseed_lw(iCol) = lw_gas_props%get_ngpt() + iCol - enddo - elseif (isubc_lw == 2) then ! use input array of permutaion seeds - do iCol = 1, ncol - ipseed_lw(iCol) = icseed_lw(iCol) - enddo - endif - - ! Call RNG. Mersennse Twister accepts 1D array, so loop over columns and collapse along G-points - ! and layers. ([nGpts,nLev,nColumn]-> [nGpts*nLev]*nColumn) - do iCol=1,ncol - call random_setseed(ipseed_lw(icol),rng_stat) - ! Use same rng for each layer - if (iovr == iovr_max) then - call random_number(rng1D,rng_stat) - do iLay=1,nLev - rng3D(:,iLay,iCol) = rng1D - enddo - else - do iLay=1,nLev - call random_number(rng1D,rng_stat) - rng3D(:,iLay,iCol) = rng1D - enddo - endif - enddo - - ! Cloud-overlap. - ! Maximum-random, random or maximum. - if (iovr == iovr_maxrand .or. iovr == iovr_rand .or. iovr == iovr_max) then - call sampled_mask(real(rng3D, kind=kind_phys), cld_frac, maskMCICA) - endif - ! Exponential decorrelation length overlap - if (iovr == iovr_dcorr) then - ! Generate second RNG - do iCol=1,ncol - call random_setseed(ipseed_lw(icol),rng_stat) - call random_number(rng2D,rng_stat) - rng3D2(:,:,iCol) = reshape(source = rng2D,shape=[lw_gas_props%get_ngpt(),nLev]) - enddo - call sampled_mask(real(rng3D, kind=kind_phys), cld_frac, maskMCICA, & - overlap_param = cloud_overlap_param(:,1:nLev-1), & - randoms2 = real(rng3D2, kind=kind_phys)) - endif - ! Exponential or Exponential-random - if (iovr == iovr_exp .or. iovr == iovr_exprand) then - call sampled_mask(real(rng3D, kind=kind_phys), cld_frac, maskMCICA, & - overlap_param = cloud_overlap_param(:,1:nLev-1)) - endif - - ! - ! Sampling. Map band optical depth to each g-point using McICA - ! - call check_error_msg('rrtmgp_lw_cloud_sampling_run_draw_samples',& - draw_samples(maskMCICA, .true., & - lw_optical_props_cloudsByBand, & - lw_optical_props_clouds)) - - end subroutine rrtmgp_lw_cloud_sampling_run - -end module rrtmgp_lw_cloud_sampling diff --git a/physics/rrtmgp_lw_cloud_sampling.meta b/physics/rrtmgp_lw_cloud_sampling.meta deleted file mode 100644 index c1ae9d139..000000000 --- a/physics/rrtmgp_lw_cloud_sampling.meta +++ /dev/null @@ -1,226 +0,0 @@ -[ccpp-table-properties] - name = rrtmgp_lw_cloud_sampling - type = scheme - dependencies = machine.F,mersenne_twister.f,rrtmgp_sampling.F90,radiation_tools.F90 - -###################################################### -[ccpp-arg-table] - name = rrtmgp_lw_cloud_sampling_run - type = scheme -[doLWrad] - standard_name = flag_for_calling_longwave_radiation - long_name = logical flags for lw radiation calls - units = flag - dimensions = () - type = logical - intent = in -[imfdeepcnv] - standard_name = control_for_deep_convection_scheme - long_name = flag for mass-flux deep convection scheme - units = flag - dimensions = () - type = integer - intent = in -[imfdeepcnv_gf] - standard_name = identifier_for_grell_freitas_deep_convection - long_name = flag for Grell-Freitas deep convection scheme - units = flag - dimensions = () - type = integer - intent = in -[imfdeepcnv_samf] - standard_name = identifer_for_scale_aware_mass_flux_deep_convection - long_name = flag for SAMF deep convection scheme - units = flag - dimensions = () - type = integer - intent = in -[iovr_convcld] - standard_name = flag_for_convective_cloud_overlap_method_for_radiation - long_name = flag for convective cloud overlap method - units = flag - dimensions = () - type = integer - intent = in -[ncol] - standard_name = horizontal_loop_extent - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in -[nLev] - standard_name = vertical_layer_dimension - long_name = number of vertical levels - units = count - dimensions = () - type = integer - intent = in -[isubc_lw] - standard_name = flag_for_lw_clouds_sub_grid_approximation - long_name = flag for lw clouds sub-grid approximation - units = flag - dimensions = () - type = integer - intent = in -[iovr] - standard_name = flag_for_cloud_overlap_method_for_radiation - long_name = max-random overlap clouds - units = flag - dimensions = () - type = integer - intent = in -[iovr_maxrand] - standard_name = flag_for_maximum_random_cloud_overlap_method - long_name = choice of maximum-random cloud overlap method - units = flag - dimensions = () - type = integer - intent = in -[iovr_dcorr] - standard_name = flag_for_decorrelation_length_cloud_overlap_method - long_name = choice of decorrelation-length cloud overlap method - units = flag - dimensions = () - type = integer - intent = in -[iovr_exp] - standard_name = flag_for_exponential_cloud_overlap_method - long_name = choice of exponential cloud overlap method - units = flag - dimensions = () - type = integer - intent = in -[iovr_exprand] - standard_name = flag_for_exponential_random_cloud_overlap_method - long_name = choice of exponential-random cloud overlap method - units = flag - dimensions = () - type = integer - intent = in -[iovr_rand] - standard_name = flag_for_random_cloud_overlap_method - long_name = choice of random cloud overlap method - units = flag - dimensions = () - type = integer - intent = in -[iovr_max] - standard_name = flag_for_maximum_cloud_overlap_method - long_name = choice of maximum cloud overlap method - units = flag - dimensions = () - type = integer - intent = in -[icseed_lw] - standard_name = random_number_seed_for_mcica_longwave - long_name = seed for random number generation for longwave radiation - units = none - dimensions = (horizontal_loop_extent) - type = integer - intent = in -[cld_frac] - standard_name = total_cloud_fraction - long_name = layer total cloud fraction - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_cnv_frac] - standard_name = convective_cloud_fraction_for_RRTMGP - long_name = layer convective cloud fraction - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[precip_frac] - standard_name = precipitation_fraction_by_layer - long_name = precipitation fraction in each layer - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cloud_overlap_param] - standard_name = cloud_overlap_param - long_name = cloud overlap parameter - units = km - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cnv_cloud_overlap_param] - standard_name = convective_cloud_overlap_param - long_name = convective cloud overlap parameter - units = km - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[precip_overlap_param] - standard_name = precip_overlap_param - long_name = precipitation overlap parameter - units = km - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[lw_optical_props_cloudsByBand] - standard_name = longwave_optical_properties_for_cloudy_atmosphere_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = in -[lw_optical_props_cnvcloudsByBand] - standard_name = longwave_optical_properties_for_convective_cloudy_atmosphere_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = in -[lw_optical_props_precipByBand] - standard_name = longwave_optical_properties_for_precipitation_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = in -[lw_optical_props_clouds] - standard_name = longwave_optical_properties_for_cloudy_atmosphere - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = inout -[lw_optical_props_precip] - standard_name = longwave_optical_properties_for_precipitation - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = inout -[lw_optical_props_cnvclouds] - standard_name = longwave_optical_properties_for_convective_cloudy_atmosphere - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = inout -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out diff --git a/physics/rrtmgp_lw_gas_optics.F90 b/physics/rrtmgp_lw_gas_optics.F90 index fad01a336..8cd38f210 100644 --- a/physics/rrtmgp_lw_gas_optics.F90 +++ b/physics/rrtmgp_lw_gas_optics.F90 @@ -12,8 +12,6 @@ module rrtmgp_lw_gas_optics use mo_rte_kind, only: wl use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp use mo_gas_concentrations, only: ty_gas_concs - use mo_source_functions, only: ty_source_func_lw - use mo_optical_props, only: ty_optical_props_1scl use radiation_tools, only: check_error_msg use netcdf #ifdef MPI @@ -77,28 +75,18 @@ module rrtmgp_lw_gas_optics contains -!>\defgroup rrtmgp_lw_gas_optics_mod GFS RRTMGP-LW Gas Optics Module -!! \section arg_table_rrtmgp_lw_gas_optics_init -!! \htmlinclude rrtmgp_lw_gas_optics.html -!! -!> \ingroup rrtmgp_lw_gas_optics -!! -!! RRTMGP relies heavility on derived-data-types, which contain type-bound procedures -!! that are referenced frequently throughout the RRTMGP longwave scheme. The data needed -!! for the correlated k-distribution is also contained within this type. Within this module, -!! the full k-distribution data is read in, reduced by the "active gases" provided, and -!! loaded into the RRTMGP DDT, ty_gas_optics_rrtmgp. -!! -!! \section rrtmgp_lw_gas_optics_init - ! ###################################################################################### - subroutine rrtmgp_lw_gas_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, mpicomm, & - mpirank, mpiroot, minGPpres, maxGPpres, minGPtemp, maxGPtemp, active_gases_array, & - errmsg, errflg) + ! ######################################################################################### + ! SUBROUTINE rrtmgp_lw_gas_optics_init + ! ######################################################################################### + subroutine rrtmgp_lw_gas_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, & + active_gases_array, mpicomm, mpirank, mpiroot, errmsg, errflg) ! Inputs character(len=128),intent(in) :: & rrtmgp_root_dir, & ! RTE-RRTMGP root directory - rrtmgp_lw_file_gas ! RRTMGP file containing coefficients used to compute gaseous optical properties + rrtmgp_lw_file_gas ! RRTMGP file containing K-distribution data + character(len=*), dimension(:), intent(in) :: & + active_gases_array ! List of active gases from namelist as array integer,intent(in) :: & mpicomm, & ! MPI communicator mpirank, & ! Current MPI rank @@ -109,20 +97,12 @@ subroutine rrtmgp_lw_gas_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, mpicom errmsg ! CCPP error message integer, intent(out) :: & errflg ! CCPP error code - real(kind_phys), intent(out) :: & - minGPtemp, & ! Minimum temperature allowed by RRTMGP. - maxGPtemp, & ! Maximum ... - minGPpres, & ! Minimum pressure allowed by RRTMGP. - maxGPpres ! Maximum pressure allowed by RRTMGP. - character(len=*), dimension(:), intent(in) :: & - active_gases_array ! List of active gases from namelist as array ! Local variables - integer :: ncid, dimID, varID, status, iGas, ierr, ii, mpierr, iChar - integer,dimension(:),allocatable :: temp1, temp2, temp3, temp4, & - temp_log_array1, temp_log_array2, temp_log_array3, temp_log_array4 + integer :: ncid, dimID, varID, status, ii, mpierr, iChar + integer,dimension(:),allocatable :: temp1, temp2, temp3, temp4 character(len=264) :: lw_gas_props_file - type(ty_gas_concs) :: gas_concentrations ! RRTMGP DDT: trace gas concentrations (vmr) + type(ty_gas_concs) :: gas_concs ! RRTMGP DDT: trace gas concentrations (vmr) ! Initialize errmsg = '' @@ -455,9 +435,8 @@ subroutine rrtmgp_lw_gas_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, mpicom ! Initialize RRTMGP DDT's... ! ! ####################################################################################### - allocate(gas_concentrations%gas_name(1:size(active_gases_array))) - gas_concentrations%gas_name(:) = active_gases_array(:) - call check_error_msg('rrtmgp_lw_gas_optics_init',lw_gas_props%load(gas_concentrations, & + call check_error_msg('rrtmgp_lw_gas_optics_init_gas_concs',gas_concs%init(active_gases_array)) + call check_error_msg('rrtmgp_lw_gas_optics_init_load',lw_gas_props%load(gas_concs, & gas_namesLW, key_speciesLW, band2gptLW, band_limsLW, press_refLW, press_ref_tropLW,& temp_refLW, temp_ref_pLW, temp_ref_tLW, vmr_refLW, kmajorLW, kminor_lowerLW, & kminor_upperLW, gas_minorLW, identifier_minorLW, minor_gases_lowerLW, & @@ -467,80 +446,6 @@ subroutine rrtmgp_lw_gas_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, mpicom scale_by_complement_upperLW, kminor_start_lowerLW, kminor_start_upperLW, totplnkLW,& planck_fracLW, rayl_lowerLW, rayl_upperLW, optimal_angle_fitLW)) - ! The minimum pressure allowed in GP RTE calculations. Used to bound uppermost layer - ! temperature (GFS_rrtmgp_pre.F90) - minGPpres = lw_gas_props%get_press_min() - maxGPpres = lw_gas_props%get_press_max() - minGPtemp = lw_gas_props%get_temp_min() - maxGPtemp = lw_gas_props%get_temp_max() - end subroutine rrtmgp_lw_gas_optics_init -!> \section arg_table_rrtmgp_lw_gas_optics_run -!! \htmlinclude rrtmgp_lw_gas_optics_run.html -!! -!! Compute longwave optical prperties (optical-depth) for clear-sky conditions. -!! \section rrtmgp_lw_gas_optics_run - subroutine rrtmgp_lw_gas_optics_run(doLWrad, nCol, nLev, p_lay, p_lev, t_lay, t_lev, tsfg, & - gas_concentrations, lw_optical_props_clrsky, sources, errmsg, errflg) - - ! Inputs - logical, intent(in) :: & - doLWrad ! Flag to calculate LW irradiances - integer,intent(in) :: & - ncol, & ! Number of horizontal points - nLev ! Number of vertical levels - real(kind_phys), dimension(ncol,nLev), intent(in) :: & - p_lay, & ! Pressure @ model layer-centers (Pa) - t_lay ! Temperature (K) - real(kind_phys), dimension(ncol,nLev+1), intent(in) :: & - p_lev, & ! Pressure @ model layer-interfaces (Pa) - t_lev ! Temperature @ model levels - real(kind_phys), dimension(ncol), intent(in) :: & - tsfg ! Surface ground temperature (K) - type(ty_gas_concs),intent(in) :: & - gas_concentrations ! RRTMGP DDT: trace gas concentrations (vmr) - - ! Output - character(len=*), intent(out) :: & - errmsg ! CCPP error message - integer, intent(out) :: & - errflg ! CCPP error code - type(ty_optical_props_1scl),intent(inout) :: & - lw_optical_props_clrsky ! RRTMGP DDT: longwave clear-sky radiative properties - type(ty_source_func_lw),intent(inout) :: & - sources ! RRTMGP DDT: longwave source functions - - ! Local - integer :: ii - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (.not. doLWrad) return - - ! Copy spectral information into GP DDTs. - lw_optical_props_clrsky%band2gpt = lw_gas_props%get_band_lims_gpoint() - sources%band2gpt = lw_gas_props%get_band_lims_gpoint() - sources%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() - lw_optical_props_clrsky%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() - do ii=1,nbndsLW - lw_optical_props_clrsky%gpt2band(band2gptLW(1,ii):band2gptLW(2,ii)) = ii - sources%gpt2band(band2gptLW(1,ii):band2gptLW(2,ii)) = ii - end do - - ! Gas-optics - call check_error_msg('rrtmgp_lw_gas_optics_run',lw_gas_props%gas_optics(& - p_lay, & ! IN - Pressure @ layer-centers (Pa) - p_lev, & ! IN - Pressure @ layer-interfaces (Pa) - t_lay, & ! IN - Temperature @ layer-centers (K) - tsfg, & ! IN - Skin-temperature (K) - gas_concentrations, & ! IN - RRTMGP DDT: trace gas volumne mixing-ratios - lw_optical_props_clrsky, & ! OUT - RRTMGP DDT: longwave optical properties - sources, & ! OUT - RRTMGP DDT: source functions - tlev=t_lev)) ! IN - Temperature @ layer-interfaces (K) (optional) - - end subroutine rrtmgp_lw_gas_optics_run - end module rrtmgp_lw_gas_optics diff --git a/physics/rrtmgp_lw_gas_optics.meta b/physics/rrtmgp_lw_gas_optics.meta deleted file mode 100644 index 0b484b6ac..000000000 --- a/physics/rrtmgp_lw_gas_optics.meta +++ /dev/null @@ -1,203 +0,0 @@ -[ccpp-table-properties] - name = rrtmgp_lw_gas_optics - type = scheme - dependencies = machine.F,radiation_tools.F90,GFS_rrtmgp_pre.F90,rte-rrtmgp/rrtmgp/mo_gas_optics_rrtmgp.F90,rte-rrtmgp/rte/mo_rte_kind.F90,rte-rrtmgp/rrtmgp/mo_gas_concentrations.F90,rte-rrtmgp/rte/mo_optical_props.F90,rte-rrtmgp/rte/mo_source_functions.F90 - -######################################################################## -[ccpp-arg-table] - name = rrtmgp_lw_gas_optics_init - type = scheme -[rrtmgp_root_dir] - standard_name = directory_for_rte_rrtmgp_source_code - long_name = directory for rte+rrtmgp source code - units = none - dimensions = () - type = character - intent = in - kind = len=128 -[rrtmgp_lw_file_gas] - standard_name = filename_of_rrtmgp_longwave_k_distribution - long_name = file containing RRTMGP LW k-distribution - units = none - dimensions = () - type = character - intent = in - kind = len=128 -[mpirank] - standard_name = mpi_rank - long_name = current MPI rank - units = index - dimensions = () - type = integer - intent = in -[mpiroot] - standard_name = mpi_root - long_name = master MPI rank - units = index - dimensions = () - type = integer - intent = in -[mpicomm] - standard_name = mpi_communicator - long_name = MPI communicator - units = index - dimensions = () - type = integer - intent = in -[minGPpres] - standard_name = minimum_pressure_in_RRTMGP - long_name = minimum pressure allowed in RRTMGP - units = Pa - dimensions = () - type = real - kind = kind_phys - intent = out -[maxGPpres] - standard_name = maximum_pressure_in_RRTMGP - long_name = maximum pressure allowed in RRTMGP - units = Pa - dimensions = () - type = real - kind = kind_phys - intent = out -[minGPtemp] - standard_name = minimum_temperature_in_RRTMGP - long_name = minimum temperature allowed in RRTMGP - units = K - dimensions = () - type = real - kind = kind_phys - intent = out -[maxGPtemp] - standard_name = maximum_temperature_in_RRTMGP - long_name = maximum temperature allowed in RRTMGP - units = K - dimensions = () - type = real - kind = kind_phys - intent = out -[active_gases_array] - standard_name = list_of_active_gases_used_by_RRTMGP - long_name = list of active gases used by RRTMGP - units = none - dimensions = (number_of_active_gases_used_by_RRTMGP) - type = character - kind = len=* - intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - -######################################################################## -[ccpp-arg-table] - name = rrtmgp_lw_gas_optics_run - type = scheme -[doLWrad] - standard_name = flag_for_calling_longwave_radiation - long_name = flag to calculate LW irradiances - units = flag - dimensions = () - type = logical - intent = in -[ncol] - standard_name = horizontal_loop_extent - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in -[nLev] - standard_name = vertical_layer_dimension - long_name = number of vertical levels - units = count - dimensions = () - type = integer - intent = in -[p_lay] - standard_name = air_pressure_at_layer_for_RRTMGP - long_name = air pressure layer - units = Pa - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[p_lev] - standard_name = air_pressure_at_interface_for_RRTMGP - long_name = air pressure level - units = Pa - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = in -[t_lay] - standard_name = air_temperature_at_layer_for_RRTMGP - long_name = air temperature layer - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[t_lev] - standard_name = air_temperature_at_interface_for_RRTMGP - long_name = air temperature level - units = K - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = in -[tsfg] - standard_name = surface_ground_temperature_for_radiation - long_name = surface ground temperature for radiation - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[gas_concentrations] - standard_name = Gas_concentrations_for_RRTMGP_suite - long_name = DDT containing gas concentrations for RRTMGP radiation scheme - units = DDT - dimensions = () - type = ty_gas_concs - intent = in -[lw_optical_props_clrsky] - standard_name = longwave_optical_properties_for_clear_sky - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_1scl - intent = inout -[sources] - standard_name = longwave_source_function - long_name = Fortran DDT containing RRTMGP source functions - units = DDT - dimensions = () - type = ty_source_func_lw - intent = inout -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out diff --git a/physics/rrtmgp_lw_main.F90 b/physics/rrtmgp_lw_main.F90 new file mode 100644 index 000000000..c0bc99d35 --- /dev/null +++ b/physics/rrtmgp_lw_main.F90 @@ -0,0 +1,611 @@ +! ########################################################################################### +!> \file rrtmgp_lw_main.F90 +!! +!> \defgroup rrtmgp_lw_main rrtmgp_lw_main.F90 +!! +!! \brief This module contains the longwave RRTMGP radiation scheme. +!! +! ########################################################################################### +module rrtmgp_lw_main + use machine, only: kind_phys, kind_dbl_prec + use mo_optical_props, only: ty_optical_props_1scl, ty_optical_props_2str + use mo_cloud_optics, only: ty_cloud_optics + use mo_rte_lw, only: rte_lw + use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp + use mo_gas_concentrations, only: ty_gas_concs + use mo_fluxes_byband, only: ty_fluxes_byband + use mo_source_functions, only: ty_source_func_lw + use radiation_tools, only: check_error_msg + use rrtmgp_lw_gas_optics, only: lw_gas_props,rrtmgp_lw_gas_optics_init + use rrtmgp_lw_cloud_optics, only: lw_cloud_props, rrtmgp_lw_cloud_optics_init, abssnow0, & + abssnow1, absrain + use module_radiation_gases, only: NF_VGAS, getgases, getozn + use GFS_rrtmgp_pre, only: iStr_h2o, iStr_co2, iStr_o3, iStr_n2o, iStr_ch4, & + iStr_o2, iStr_ccl4, iStr_cfc11, iStr_cfc12, iStr_cfc22, & + eps, oneminus, ftiny + use mersenne_twister, only: random_setseed, random_number, random_stat + use rrtmgp_sampling, only: sampled_mask, draw_samples + implicit none + + type(ty_gas_concs) :: gas_concs + type(ty_optical_props_1scl) :: lw_optical_props_clrsky, lw_optical_props_aerosol_local + type(ty_optical_props_2str) :: lw_optical_props_clouds, lw_optical_props_cloudsByBand, & + lw_optical_props_cnvcloudsByBand, lw_optical_props_pblcloudsByBand, & + lw_optical_props_precipByBand + type(ty_source_func_lw) :: sources + + public rrtmgp_lw_main_init, rrtmgp_lw_main_run +contains + ! ######################################################################################### +!! \section arg_table_rrtmgp_lw_main_init +!! \htmlinclude rrtmgp_lw_main_int.html +!! +!> \ingroup rrtmgp_lw_main +!! +!! \brief +!! +!! \section rrtmgp_lw_main_init +!> @{ + ! ######################################################################################### + subroutine rrtmgp_lw_main_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, rrtmgp_lw_file_clouds,& + active_gases_array, doGP_cldoptics_PADE, doGP_cldoptics_LUT, doGP_sgs_pbl, & + doGP_sgs_cnv, nrghice, mpicomm, mpirank, mpiroot, nLay, rrtmgp_phys_blksz, & + errmsg, errflg) + + ! Inputs + character(len=128),intent(in) :: & + rrtmgp_root_dir, & ! RTE-RRTMGP root directory + rrtmgp_lw_file_clouds, & ! RRTMGP file containing coefficients used to compute + ! clouds optical properties + rrtmgp_lw_file_gas ! RRTMGP file containing coefficients used to compute + ! gaseous optical properties + character(len=*), dimension(:), intent(in) :: & + active_gases_array ! List of active gases from namelist as array) + logical, intent(in) :: & + doGP_cldoptics_PADE, & ! Use RRTMGP cloud-optics: PADE approximation? + doGP_cldoptics_LUT, & ! Use RRTMGP cloud-optics: LUTs? + doGP_sgs_pbl, & ! Flag to include sgs PBL clouds + doGP_sgs_cnv ! Flag to include sgs convective clouds + integer, intent(inout) :: & + nrghice ! Number of ice-roughness categories + integer,intent(in) :: & + mpicomm, & ! MPI communicator + mpirank, & ! Current MPI rank + mpiroot, & ! Master MPI rank + rrtmgp_phys_blksz, & ! Number of horizontal points to process at once. + nLay + + ! Outputs + character(len=*), intent(out) :: & + errmsg ! CCPP error message + integer, intent(out) :: & + errflg ! CCPP error code + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! RRTMGP longwave gas-optics (k-distribution) initialization + call rrtmgp_lw_gas_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, & + active_gases_array, mpicomm, mpirank, mpiroot, errmsg, errflg) + + ! RRTMGP longwave cloud-optics initialization + call rrtmgp_lw_cloud_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_clouds, & + doGP_cldoptics_PADE, doGP_cldoptics_LUT, nrghice, mpicomm, mpirank, mpiroot, & + errmsg, errflg) + + ! DDTs + + ! ty_gas_concs + call check_error_msg('rrtmgp_lw_main_gas_concs_init',gas_concs%init(active_gases_array)) + + ! ty_optical_props + call check_error_msg('rrtmgp_lw_main_gas_optics_init',& + lw_optical_props_clrsky%alloc_1scl(rrtmgp_phys_blksz, nLay, lw_gas_props)) + call check_error_msg('rrtmgp_lw_main_sources_init',& + sources%alloc(rrtmgp_phys_blksz, nLay, lw_gas_props)) + call check_error_msg('rrtmgp_lw_main_cloud_optics_init',& + lw_optical_props_cloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) + call check_error_msg('rrtmgp_lw_main_precip_optics_init',& + lw_optical_props_precipByBand%alloc_2str(rrtmgp_phys_blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) + call check_error_msg('rrtmgp_lw_mian_cloud_sampling_init', & + lw_optical_props_clouds%alloc_2str(rrtmgp_phys_blksz, nLay, lw_gas_props)) + call check_error_msg('rrtmgp_lw_main_aerosol_optics_init',& + lw_optical_props_aerosol_local%alloc_1scl(rrtmgp_phys_blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) + if (doGP_sgs_cnv) then + call check_error_msg('rrtmgp_lw_main_cnv_cloud_optics_init',& + lw_optical_props_cnvcloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) + endif + if (doGP_sgs_pbl) then + call check_error_msg('rrtmgp_lw_main_pbl_cloud_optics_init',& + lw_optical_props_pblcloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) + endif + + end subroutine rrtmgp_lw_main_init +!> @} + ! ###################################################################################### +!! \section arg_table_rrtmgp_lw_main_run +!! \htmlinclude rrtmgp_lw_main_run.html +!! +!> \ingroup rrtmgp_lw_main +!! +!! \brief +!! +!! \section rrtmgp_lw_main_run +!> @{ + ! ###################################################################################### + subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, & + use_LW_jacobian, doGP_sgs_cnv, doGP_sgs_pbl, nCol, nLay, nGases,rrtmgp_phys_blksz,& + nGauss_angles, icseed_lw, iovr, iovr_convcld, iovr_max, iovr_maxrand, iovr_rand, & + iovr_dcorr, iovr_exp, iovr_exprand, isubc_lw, semis, tsfg, p_lay, p_lev, t_lay, & + t_lev, vmr_o2, vmr_h2o, vmr_o3, vmr_ch4, vmr_n2o, vmr_co2, & + cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, & + cld_rwp, cld_rerain, precip_frac, cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, & + cld_cnv_reice, cld_pbl_lwp, cld_pbl_reliq, cld_pbl_iwp, cld_pbl_reice, & + cloud_overlap_param, active_gases_array, aerlw_tau, aerlw_ssa, aerlw_g, & + fluxlwUP_allsky, fluxlwDOWN_allsky, fluxlwUP_clrsky, fluxlwDOWN_clrsky, & + fluxlwUP_jac, fluxlwUP_radtime, fluxlwDOWN_radtime, errmsg, errflg) + + ! Inputs + logical, intent(in) :: & + doLWrad, & ! Flag to perform longwave calculation + doLWclrsky, & ! Flag to compute clear-sky fluxes + top_at_1, & ! Flag for vertical ordering convention + use_LW_jacobian, & ! Flag to compute Jacobian of longwave surface flux + doGP_sgs_pbl, & ! Flag to include sgs PBL clouds + doGP_sgs_cnv, & ! Flag to include sgs convective clouds + doGP_lwscat ! Flag to include scattering in clouds + integer,intent(in) :: & + nCol, & ! Number of horizontal points + nLay, & ! Number of vertical grid points. + nGases, & ! Number of active gases + rrtmgp_phys_blksz, & ! Number of horizontal points to process at once. + nGauss_angles, & ! Number of gaussian quadrature angles used + iovr, & ! Choice of cloud-overlap method + iovr_convcld, & ! Choice of convective cloud-overlap + iovr_max, & ! Flag for maximum cloud overlap method + iovr_maxrand, & ! Flag for maximum-random cloud overlap method + iovr_rand, & ! Flag for random cloud overlap method + iovr_dcorr, & ! Flag for decorrelation-length cloud overlap method + iovr_exp, & ! Flag for exponential cloud overlap method + iovr_exprand, & ! Flag for exponential-random cloud overlap method + isubc_lw ! Flag for cloud-seeding (rng) for cloud-sampling + integer,intent(in),dimension(:) :: & + icseed_lw ! Seed for random number generation for longwave radiation + real(kind_phys), dimension(:), intent(in) :: & + semis, & ! Surface-emissivity (1) + tsfg ! Skin temperature (K) + real(kind_phys), dimension(:,:), intent(in) :: & + p_lay, & ! Pressure @ model layer-centers (Pa) + t_lay, & ! Temperature (K) + p_lev, & ! Pressure @ model layer-interfaces (Pa) + t_lev, & ! Temperature @ model levels (K) + vmr_o2, & ! Molar-mixing ratio oxygen + vmr_h2o, & ! Molar-mixing ratio water vapor + vmr_o3, & ! Molar-mixing ratio ozone + vmr_ch4, & ! Molar-mixing ratio methane + vmr_n2o, & ! Molar-mixing ratio nitrous oxide + vmr_co2, & ! Molar-mixing ratio carbon dioxide + cld_frac, & ! Cloud-fraction for stratiform clouds + cld_lwp, & ! Water path for stratiform liquid cloud-particles + cld_reliq, & ! Effective radius for stratiform liquid cloud-particles + cld_iwp, & ! Water path for stratiform ice cloud-particles + cld_reice, & ! Effective radius for stratiform ice cloud-particles + cld_swp, & ! Water path for snow hydrometeors + cld_resnow, & ! Effective radius for snow hydrometeors + cld_rwp, & ! Water path for rain hydrometeors + cld_rerain, & ! Effective radius for rain hydrometeors + precip_frac, & ! Precipitation fraction (not active, currently precipitation optics uses cloud-fraction) + cld_cnv_lwp, & ! Water path for convective liquid cloud-particles + cld_cnv_reliq, & ! Effective radius for convective liquid cloud-particles + cld_cnv_iwp, & ! Water path for convective ice cloud-particles + cld_cnv_reice, & ! Effective radius for convective ice cloud-particles + cld_pbl_lwp, & ! Water path for PBL liquid cloud-particles + cld_pbl_reliq, & ! Effective radius for PBL liquid cloud-particles + cld_pbl_iwp, & ! Water path for PBL ice cloud-particles + cld_pbl_reice, & ! Effective radius for PBL ice cloud-particles + cloud_overlap_param ! Cloud overlap parameter + real(kind_phys), dimension(:,:,:), intent(in) :: & + aerlw_tau, & ! Aerosol optical depth + aerlw_ssa, & ! Aerosol single scattering albedo + aerlw_g ! Aerosol asymmetry paramter + character(len=*), dimension(:), intent(in) :: & + active_gases_array ! List of active gases from namelist as array + + ! Outputs + real(kind_phys), dimension(:,:), intent(inout) :: & + fluxlwUP_jac, & ! Jacobian of upwelling LW surface radiation (W/m2/K) + fluxlwUP_allsky, & ! All-sky flux (W/m2) + fluxlwDOWN_allsky, & ! All-sky flux (W/m2) + fluxlwUP_clrsky, & ! Clear-sky flux (W/m2) + fluxlwDOWN_clrsky, & ! All-sky flux (W/m2) + fluxlwUP_radtime, & ! Copy of fluxes (Used for coupling) + fluxlwDOWN_radtime ! + character(len=*), intent(out) :: & + errmsg ! CCPP error message + integer, intent(out) :: & + errflg ! CCPP error flag + + ! Local variables + type(ty_fluxes_byband) :: flux_allsky, flux_clrsky + integer :: iCol, iLay, iGas, iBand, iCol2, ix, iblck + integer, dimension(rrtmgp_phys_blksz) :: ipseed_lw + type(random_stat) :: rng_stat + real(kind_phys), dimension(rrtmgp_phys_blksz) :: zcf0, zcf1 + logical, dimension(rrtmgp_phys_blksz,nLay,lw_gas_props%get_ngpt()) :: maskMCICA + real(kind_phys), dimension(rrtmgp_phys_blksz) :: tau_rain, tau_snow + real(kind_dbl_prec), dimension(lw_gas_props%get_ngpt()) :: rng1D + real(kind_dbl_prec), dimension(lw_gas_props%get_ngpt(),nLay,rrtmgp_phys_blksz) :: rng3D,rng3D2 + real(kind_dbl_prec), dimension(lw_gas_props%get_ngpt()*nLay) :: rng2D + real(kind_phys), dimension(rrtmgp_phys_blksz,nLay+1,lw_gas_props%get_nband()),target :: & + fluxLW_up_allsky, fluxLW_up_clrsky, fluxLW_dn_allsky, fluxLW_dn_clrsky + real(kind_phys), dimension(rrtmgp_phys_blksz,lw_gas_props%get_ngpt()) :: lw_Ds + real(kind_phys), dimension(lw_gas_props%get_nband(),rrtmgp_phys_blksz) :: sfc_emiss_byband + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (.not. doLWrad) return + + ! ###################################################################################### + ! + ! Loop over all columns... + ! + ! ###################################################################################### + do iCol=1,nCol,rrtmgp_phys_blksz + iCol2 = iCol + rrtmgp_phys_blksz - 1 + + ! Initialize/reset + + ! ty_optical_props + lw_optical_props_clrsky%tau = 0._kind_phys + lw_optical_props_precipByBand%tau = 0._kind_phys + lw_optical_props_precipByBand%ssa = 0._kind_phys + lw_optical_props_precipByBand%g = 0._kind_phys + lw_optical_props_cloudsByBand%tau = 0._kind_phys + lw_optical_props_cloudsByBand%ssa = 0._kind_phys + lw_optical_props_cloudsByBand%g = 0._kind_phys + lw_optical_props_clouds%tau = 0._kind_phys + lw_optical_props_clouds%ssa = 0._kind_phys + lw_optical_props_clouds%g = 0._kind_phys + sources%sfc_source = 0._kind_phys + sources%lay_source = 0._kind_phys + sources%lev_source_inc = 0._kind_phys + sources%lev_source_dec = 0._kind_phys + sources%sfc_source_Jac = 0._kind_phys + fluxLW_up_allsky = 0._kind_phys + fluxLW_dn_allsky = 0._kind_phys + fluxLW_up_clrsky = 0._kind_phys + fluxLW_dn_clrsky = 0._kind_phys + if (doGP_sgs_cnv) lw_optical_props_cnvcloudsByBand%tau = 0._kind_phys + if (doGP_sgs_pbl) lw_optical_props_pblcloudsByBand%tau = 0._kind_phys + + ! ty_fluxes_byband + fluxLW_up_allsky = 0._kind_phys + fluxLW_dn_allsky = 0._kind_phys + fluxLW_up_clrsky = 0._kind_phys + fluxLW_dn_clrsky = 0._kind_phys + flux_allsky%bnd_flux_up => fluxLW_up_allsky + flux_allsky%bnd_flux_dn => fluxLW_dn_allsky + flux_clrsky%bnd_flux_up => fluxLW_up_clrsky + flux_clrsky%bnd_flux_dn => fluxLW_dn_clrsky + + ! ################################################################################### + ! + ! Set gas-concentrations + ! + ! ################################################################################### + call check_error_msg('rrtmgp_lw_main_set_vmr_o2', & + gas_concs%set_vmr(trim(active_gases_array(istr_o2)), vmr_o2(iCol:iCol2,:))) + call check_error_msg('rrtmgp_lw_main_set_vmr_co2', & + gas_concs%set_vmr(trim(active_gases_array(istr_co2)),vmr_co2(iCol:iCol2,:))) + call check_error_msg('rrtmgp_lw_main_set_vmr_ch4', & + gas_concs%set_vmr(trim(active_gases_array(istr_ch4)),vmr_ch4(iCol:iCol2,:))) + call check_error_msg('rrtmgp_lw_main_set_vmr_n2o', & + gas_concs%set_vmr(trim(active_gases_array(istr_n2o)),vmr_n2o(iCol:iCol2,:))) + call check_error_msg('rrtmgp_lw_main_set_vmr_h2o', & + gas_concs%set_vmr(trim(active_gases_array(istr_h2o)),vmr_h2o(iCol:iCol2,:))) + call check_error_msg('rrtmgp_lw_main_set_vmr_o3', & + gas_concs%set_vmr(trim(active_gases_array(istr_o3)), vmr_o3(iCol:iCol2,:))) + + ! ################################################################################### + ! + ! Surface emissity in each band + ! + ! ################################################################################### + ! Assign same emissivity to all band + do iblck=1,rrtmgp_phys_blksz + if (semis(iCol+iblck-1) > eps .and. semis(iCol+iblck-1) <= 1._kind_phys) then + do iBand=1,lw_gas_props%get_nband() + sfc_emiss_byband(iBand,iblck) = semis(iCol+iblck-1) + enddo + else + sfc_emiss_byband(1:lw_gas_props%get_nband(),iblck) = 1.0 + endif + enddo + + ! ################################################################################### + ! + ! Compute gas-optics... + ! + ! ################################################################################### + call check_error_msg('rrtmgp_lw_main_gas_optics',lw_gas_props%gas_optics(& + p_lay(iCol:iCol2,:), & ! IN - Pressure @ layer-centers (Pa) + p_lev(iCol:iCol2,:), & ! IN - Pressure @ layer-interfaces (Pa) + t_lay(iCol:iCol2,:), & ! IN - Temperature @ layer-centers (K) + tsfg(iCol:iCol2), & ! IN - Skin-temperature (K) + gas_concs, & ! IN - RRTMGP DDT: trace gas volumne mixing-ratios + lw_optical_props_clrsky, & ! OUT - RRTMGP DDT: longwave optical properties + sources, & ! OUT - RRTMGP DDT: source functions + tlev=t_lev(iCol:iCol2,:))) ! IN - Temperature @ layer-interfaces (K) (optional) + + ! ################################################################################### + ! + ! Compute cloud-optics... + ! + ! ################################################################################### + ! Create clear/cloudy indicator + zcf0(:) = 1._kind_phys + zcf1(:) = 1._kind_phys + do iblck = 1, rrtmgp_phys_blksz + do iLay=1,nLay + zcf0(iblck) = min(zcf0(iblck), 1._kind_phys - cld_frac(iCol+iblck-1,iLay)) + enddo + if (zcf0(iblck) <= ftiny) zcf0(iblck) = 0._kind_phys + if (zcf0(iblck) > oneminus) zcf0(iblck) = 1._kind_phys + zcf1(iblck) = 1._kind_phys - zcf0(iblck) + enddo + + if (any(zcf1 .gt. eps)) then + ! Microphysical (gridmean) cloud optics + call check_error_msg('rrtmgp_lw_main_cloud_optics',lw_cloud_props%cloud_optics(& + cld_lwp(iCol:iCol2,:), & ! IN - Cloud liquid water path (g/m2) + cld_iwp(iCol:iCol2,:), & ! IN - Cloud ice water path (g/m2) + cld_reliq(iCol:iCol2,:), & ! IN - Cloud liquid effective radius (microns) + cld_reice(iCol:iCol2,:), & ! IN - Cloud ice effective radius (microns) + lw_optical_props_cloudsByBand)) ! OUT - RRTMGP DDT containing cloud radiative properties + ! in each band + ! Include convective (subgrid scale) clouds? + if (doGP_sgs_cnv) then + ! Compute + call check_error_msg('rrtmgp_lw_main_cnv_cloud_optics',lw_cloud_props%cloud_optics(& + cld_cnv_lwp(iCol:iCol2,:), & ! IN - Convective cloud liquid water path (g/m2) + cld_cnv_iwp(iCol:iCol2,:), & ! IN - Convective cloud ice water path (g/m2) + cld_cnv_reliq(iCol:iCol2,:), & ! IN - Convective cloud liquid effective radius (microns) + cld_cnv_reice(iCol:iCol2,:), & ! IN - Convective cloud ice effective radius (microns) + lw_optical_props_cnvcloudsByBand)) ! OUT - RRTMGP DDT containing convective cloud radiative properties + ! in each band + ! Increment + call check_error_msg('rrtmgp_lw_main_increment_cnvclouds_to_clouds',& + lw_optical_props_cnvcloudsByBand%increment(lw_optical_props_cloudsByBand)) + endif + + ! Include PBL (subgrid scale) clouds? + if (doGP_sgs_pbl) then + ! Compute + call check_error_msg('rrtmgp_lw_main_pbl_cloud_optics',lw_cloud_props%cloud_optics(& + cld_pbl_lwp(iCol:iCol2,:), & ! IN - PBL cloud liquid water path (g/m2) + cld_pbl_iwp(iCol:iCol2,:), & ! IN - PBL cloud ice water path (g/m2) + cld_pbl_reliq(iCol:iCol2,:), & ! IN - PBL cloud liquid effective radius (microns) + cld_pbl_reice(iCol:iCol2,:), & ! IN - PBL cloud ice effective radius (microns) + lw_optical_props_pblcloudsByBand)) ! OUT - RRTMGP DDT containing PBL cloud radiative properties + ! in each band + ! Increment + call check_error_msg('rrtmgp_lw_main_increment_pblclouds_to_clouds',& + lw_optical_props_pblcloudsByBand%increment(lw_optical_props_cloudsByBand)) + endif + endif + + ! ################################################################################### + ! + ! Cloud precipitation optics: rain and snow(+groupel) + ! + ! ################################################################################### + tau_rain(:) = 0._kind_phys + tau_snow(:) = 0._kind_phys + do ix=1,rrtmgp_phys_blksz + do iLay=1,nLay + if (cld_frac(iCol+ix-1,iLay) .gt. eps) then + ! Rain optical-depth (No band dependence) + tau_rain(ix) = absrain*cld_rwp(iCol+ix-1,iLay) + + ! Snow (+groupel) optical-depth (No band dependence) + if (cld_swp(iCol+ix-1,iLay) .gt. 0. .and. cld_resnow(iCol+ix-1,iLay) .gt. 10._kind_phys) then + tau_snow(ix) = abssnow0*1.05756*cld_swp(iCol+ix-1,iLay)/cld_resnow(iCol+ix-1,iLay) + else + tau_snow(ix) = 0.0 + endif + do iBand=1,lw_gas_props%get_nband() + lw_optical_props_precipByBand%tau(ix,iLay,iBand) = tau_rain(ix) + tau_snow(ix) + enddo + endif + enddo + enddo + ! Increment + call check_error_msg('rrtmgp_lw_main_increment_precip_to_clouds',& + lw_optical_props_precipByBand%increment(lw_optical_props_cloudsByBand)) + + ! ################################################################################### + ! + ! Cloud-sampling + ! *Note* All of the included cloud-types are sampled together, not independently. + ! + ! ################################################################################### + if (any(zcf1 .gt. eps)) then + ! Change random number seed value for each radiation invocation (isubc_lw =1 or 2). + if(isubc_lw == 1) then ! advance prescribed permutation seed + do ix=1,rrtmgp_phys_blksz + ipseed_lw(ix) = lw_gas_props%get_ngpt() + iCol + ix - 1 + enddo + elseif (isubc_lw == 2) then ! use input array of permutaion seeds + do ix=1,rrtmgp_phys_blksz + ipseed_lw(ix) = icseed_lw(iCol+ix-1) + enddo + endif + + ! Call RNG + do ix=1,rrtmgp_phys_blksz + call random_setseed(ipseed_lw(ix),rng_stat) + ! Use same rng for each layer + if (iovr == iovr_max) then + call random_number(rng1D,rng_stat) + do iLay=1,nLay + rng3D(:,iLay,ix) = rng1D + enddo + else + do iLay=1,nLay + call random_number(rng1D,rng_stat) + rng3D(:,iLay,ix) = rng1D + enddo + endif + enddo + + ! Cloud-overlap. + ! Maximum-random, random or maximum. + if (iovr == iovr_maxrand .or. iovr == iovr_rand .or. iovr == iovr_max) then + call sampled_mask(real(rng3D,kind=kind_phys), cld_frac(iCol:iCol2,:), maskMCICA) + endif + ! Exponential decorrelation length overlap + if (iovr == iovr_dcorr) then + do ix=1,rrtmgp_phys_blksz + ! Generate second RNG + call random_setseed(ipseed_lw(ix),rng_stat) + call random_number(rng2D,rng_stat) + rng3D2(:,:,ix) = reshape(source = rng2D,shape=[lw_gas_props%get_ngpt(),nLay]) + enddo + ! + call sampled_mask(real(rng3D,kind=kind_phys), cld_frac(iCol:iCol2,:), maskMCICA, & + overlap_param = cloud_overlap_param(iCol:iCol2,1:nLay-1), randoms2 = real(rng3D2, kind=kind_phys)) + endif + ! Exponential or Exponential-random + if (iovr == iovr_exp .or. iovr == iovr_exprand) then + call sampled_mask(real(rng3D,kind=kind_phys), cld_frac(iCol:iCol2,:), maskMCICA, & + overlap_param = cloud_overlap_param(iCol:iCol2,1:nLay-1)) + endif + ! Sampling. Map band optical depth to each g-point using McICA + call check_error_msg('rrtmgp_lw_main_cloud_sampling',& + draw_samples(maskMCICA, .true., & + lw_optical_props_cloudsByBand, lw_optical_props_clouds)) + endif + + ! ################################################################################### + ! + ! Compute clear-sky fluxes (gaseous+aerosol) (optional) + ! + ! ################################################################################### + ! Increment + lw_optical_props_aerosol_local%tau = aerlw_tau(iCol:iCol2,:,:) + call check_error_msg('rrtmgp_lw_main_increment_aerosol_to_clrsky',& + lw_optical_props_aerosol_local%increment(lw_optical_props_clrsky)) + + ! Call RTE solver + if (doLWclrsky) then + call check_error_msg('rrtmgp_lw_main_opt_angle',& + lw_gas_props%compute_optimal_angles(lw_optical_props_clrsky,lw_Ds)) + if (nGauss_angles .gt. 1) then + call check_error_msg('rrtmgp_lw_main_lw_rte_clrsky',rte_lw( & + lw_optical_props_clrsky, & ! IN - optical-properties + top_at_1, & ! IN - veritcal ordering flag + sources, & ! IN - source function + sfc_emiss_byband, & ! IN - surface emissivity in each LW band + flux_clrsky, & ! OUT - Fluxes + n_gauss_angles = nGauss_angles)) ! IN - Number of angles in Gaussian quadrature + else + call check_error_msg('rrtmgp_lw_main_lw_rte_clrsky',rte_lw( & + lw_optical_props_clrsky, & ! IN - optical-properties + top_at_1, & ! IN - veritcal ordering flag + sources, & ! IN - source function + sfc_emiss_byband, & ! IN - surface emissivity in each LW band + flux_clrsky, & ! OUT - Fluxes + lw_Ds = lw_Ds)) + endif + + ! Store fluxes + fluxlwUP_clrsky(iCol:iCol2,:) = sum(flux_clrsky%bnd_flux_up, dim=3) + fluxlwDOWN_clrsky(iCol:iCol2,:) = sum(flux_clrsky%bnd_flux_dn, dim=3) + else + fluxlwUP_clrsky(iCol:iCol2,:) = 0.0 + fluxlwDOWN_clrsky(iCol:iCol2,:) = 0.0 + endif + + ! ################################################################################### + ! + ! All-sky fluxes (clear-sky + clouds + precipitation) + ! *Note* CCPP does not allow for polymorphic types, they are ambiguous to the CCPP + ! framework. rte-rrtmgp uses polymorphic types extensively, for example, querying the + ! type to determine physics configuration/pathway/etc... + ! + ! The logic in the code below is to satisfy the polymorphishm in the rte-rrtmgp code. + ! The rte-rrtmgp "increment" procedures are utilized to provide the correct type to the + ! rte solver (rte_lw). Rte_lw quieries the type determine if scattering is to be + ! included in the calculation. The increment procedures are called so that the correct + ! optical properties are inherited. ugh... + ! + ! ################################################################################### + + ! Include LW cloud-scattering? + if (doGP_lwscat) then + ! Increment + call check_error_msg('rrtmgp_lw_main_increment_clrsky_to_clouds',& + lw_optical_props_clrsky%increment(lw_optical_props_clouds)) + + if (use_LW_jacobian) then + ! Compute LW Jacobians + call check_error_msg('rrtmgp_lw_main_lw_rte_allsky',rte_lw( & + lw_optical_props_clouds, & ! IN - optical-properties + top_at_1, & ! IN - veritcal ordering flag + sources, & ! IN - source function + sfc_emiss_byband, & ! IN - surface emissivity in each LW band + flux_allsky, & ! OUT - Flxues + n_gauss_angles = nGauss_angles, & ! IN - Number of angles in Gaussian quadrature + flux_up_Jac = fluxlwUP_jac)) ! OUT - surface temperature flux (upward) Jacobian (W/m2/K) + else + call check_error_msg('rrtmgp_lw_main_lw_rte_allsky',rte_lw( & + lw_optical_props_clouds, & ! IN - optical-properties + top_at_1, & ! IN - veritcal ordering flag + sources, & ! IN - source function + sfc_emiss_byband, & ! IN - surface emissivity in each LW band + flux_allsky, & ! OUT - Flxues + n_gauss_angles = nGauss_angles)) ! IN - Number of angles in Gaussian quadrature + end if + ! No scattering in LW clouds. + else + ! Increment + call check_error_msg('rrtmgp_lw_main_increment_clouds_to_clrsky', & + lw_optical_props_clouds%increment(lw_optical_props_clrsky)) + + if (use_LW_jacobian) then + ! Compute LW Jacobians + call check_error_msg('rrtmgp_lw_rte_run',rte_lw( & + lw_optical_props_clrsky, & ! IN - optical-properties + top_at_1, & ! IN - veritcal ordering flag + sources, & ! IN - source function + sfc_emiss_byband, & ! IN - surface emissivity in each LW band + flux_allsky, & ! OUT - Flxues + n_gauss_angles = nGauss_angles, & ! IN - Number of angles in Gaussian quadrature + flux_up_Jac = fluxlwUP_jac)) ! OUT - surface temperature flux (upward) Jacobian (W/m2/K) + else + call check_error_msg('rrtmgp_lw_rte_run',rte_lw( & + lw_optical_props_clrsky, & ! IN - optical-properties + top_at_1, & ! IN - veritcal ordering flag + sources, & ! IN - source function + sfc_emiss_byband, & ! IN - surface emissivity in each LW band + flux_allsky, & ! OUT - Flxues + n_gauss_angles = nGauss_angles)) ! IN - Number of angles in Gaussian quadrature + end if + endif + + ! Store fluxes + fluxlwUP_allsky(iCol:iCol2,:) = sum(flux_allsky%bnd_flux_up, dim=3) + fluxlwDOWN_allsky(iCol:iCol2,:) = sum(flux_allsky%bnd_flux_dn, dim=3) + + ! Save fluxes for coupling + fluxlwUP_radtime(iCol:iCol2,:) = fluxlwUP_allsky(iCol:iCol2,:) + fluxlwDOWN_radtime(iCol:iCol2,:) = fluxlwDOWN_allsky(iCol:iCol2,:) + + enddo + + end subroutine rrtmgp_lw_main_run +!> @} +end module rrtmgp_lw_main diff --git a/physics/rrtmgp_lw_main.meta b/physics/rrtmgp_lw_main.meta new file mode 100644 index 000000000..a1a384b25 --- /dev/null +++ b/physics/rrtmgp_lw_main.meta @@ -0,0 +1,641 @@ +[ccpp-table-properties] + name = rrtmgp_lw_main + type = scheme + dependencies = machine.F,radiation_tools.F90,GFS_rrtmgp_pre.F90,rte-rrtmgp/rrtmgp/mo_gas_optics_rrtmgp.F90 + dependencies = rte-rrtmgp/rte/mo_rte_kind.F90,rte-rrtmgp/rrtmgp/mo_gas_concentrations.F90,rte-rrtmgp/rte/mo_optical_props.F90 + dependencies = rte-rrtmgp/rte/mo_source_functions.F90,rte-rrtmgp/rte/mo_rte_lw.F90,rte-rrtmgp/rte/mo_fluxes.F90 + dependencies = rte-rrtmgp/rte/kernels/mo_fluxes_broadband_kernels.F90, rte-rrtmgp/rte/kernels/mo_rte_solver_kernels.F90 + dependencies = mersenne_twister.f,rrtmgp_sampling.F90,rte-rrtmgp/extensions/mo_fluxes_byband.F90 + dependencies = rrtmgp_lw_gas_optics.F90, rrtmgp_lw_cloud_optics.F90 + +######################################################################## +[ccpp-arg-table] + name = rrtmgp_lw_main_init + type = scheme +[rrtmgp_root_dir] + standard_name = directory_for_rte_rrtmgp_source_code + long_name = directory for rte+rrtmgp source code + units = none + dimensions = () + type = character + intent = in + kind = len=128 +[rrtmgp_lw_file_gas] + standard_name = filename_of_rrtmgp_longwave_k_distribution + long_name = file containing RRTMGP LW k-distribution + units = none + dimensions = () + type = character + intent = in + kind = len=128 +[rrtmgp_lw_file_clouds] + standard_name = filename_of_rrtmgp_longwave_cloud_optics_coefficients + long_name = file containing coefficients for RRTMGP LW cloud optics + units = none + dimensions = () + type = character + intent = in + kind = len=128 +[doGP_cldoptics_PADE] + standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_PADE + long_name = logical flag to control cloud optics scheme. + units = flag + dimensions = () + type = logical + intent = in +[doGP_cldoptics_LUT] + standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_LUT + long_name = logical flag to control cloud optics scheme. + units = flag + dimensions = () + type = logical + intent = in +[doGP_sgs_cnv] + standard_name = flag_to_include_sgs_convective_cloud_in_RRTMGP + long_name = logical flag to control sgs convective cloud in RRTMGP + units = flag + dimensions = () + type = logical + intent = in +[doGP_sgs_pbl] + standard_name = flag_to_include_sgs_MYNN_EDMF_cloud_in_RRTMGP + long_name = logical flag to control MYNN-EDMF PBL cloud in RRTMGP + units = flag + dimensions = () + type = logical + intent = in +[nrghice] + standard_name = number_of_ice_roughness_categories + long_name = number of ice-roughness categories in RRTMGP calculation + units = count + dimensions = () + type = integer + intent = inout +[mpirank] + standard_name = mpi_rank + long_name = current MPI rank + units = index + dimensions = () + type = integer + intent = in +[mpiroot] + standard_name = mpi_root + long_name = master MPI rank + units = index + dimensions = () + type = integer + intent = in +[mpicomm] + standard_name = mpi_communicator + long_name = MPI communicator + units = index + dimensions = () + type = integer + intent = in +[rrtmgp_phys_blksz] + standard_name = number_of_columns_per_RRTMGP_LW_block + long_name = number of columns to process at a time by RRTMGP LW scheme + units = count + dimensions = () + type = integer + intent = in +[nLay] + standard_name = vertical_layer_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in +[active_gases_array] + standard_name = list_of_active_gases_used_by_RRTMGP + long_name = list of active gases used by RRTMGP + units = none + dimensions = (number_of_active_gases_used_by_RRTMGP) + type = character + kind = len=* + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out + +######################################################################## +[ccpp-arg-table] + name = rrtmgp_lw_main_run + type = scheme +[doLWrad] + standard_name = flag_for_calling_longwave_radiation + long_name = logical flags for lw radiation calls + units = flag + dimensions = () + type = logical + intent = in +[doLWclrsky] + standard_name = flag_for_output_of_tendency_of_air_temperature_due_to_longwave_heating_on_radiation_timestep_assuming_clear_sky + long_name = flag to output lw heating rate (Radtend%lwhc) + units = flag + dimensions = () + type = logical + intent = in +[top_at_1] + standard_name = flag_for_vertical_ordering_in_RRTMGP + long_name = flag for vertical ordering in RRTMGP + units = flag + dimensions = () + type = logical + intent = in +[use_LW_jacobian] + standard_name = flag_to_calc_RRTMGP_LW_jacobian + long_name = logical flag to control RRTMGP LW calculation + units = flag + dimensions = () + type = logical + intent = in +[doGP_lwscat] + standard_name = flag_to_include_longwave_scattering_in_cloud_optics + long_name = logical flag to control the addition of LW scattering in RRTMGP + units = flag + dimensions = () + type = logical + intent = in +[doGP_sgs_cnv] + standard_name = flag_to_include_sgs_convective_cloud_in_RRTMGP + long_name = logical flag to control sgs convective cloud in RRTMGP + units = flag + dimensions = () + type = logical + intent = in +[doGP_sgs_pbl] + standard_name = flag_to_include_sgs_MYNN_EDMF_cloud_in_RRTMGP + long_name = logical flag to control MYNN-EDMF PBL cloud in RRTMGP + units = flag + dimensions = () + type = logical + intent = in +[ncol] + standard_name = horizontal_loop_extent + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in +[rrtmgp_phys_blksz] + standard_name = number_of_columns_per_RRTMGP_LW_block + long_name = number of columns to process at a time by RRTMGP LW scheme + units = count + dimensions = () + type = integer + intent = in +[nLay] + standard_name = vertical_layer_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in +[nGauss_angles] + standard_name = number_of_gaussian_quadrature_angles_for_radiation + long_name = Number of angles used in Gaussian quadrature + units = count + dimensions = () + type = integer + intent = in +[nGases] + standard_name = number_of_active_gases_used_by_RRTMGP + long_name = number of gases available used by RRTMGP (Model%nGases) + units = count + dimensions = () + type = integer + intent = in +[isubc_lw] + standard_name = flag_for_lw_clouds_sub_grid_approximation + long_name = flag for lw clouds sub-grid approximation + units = flag + dimensions = () + type = integer + intent = in +[iovr] + standard_name = flag_for_cloud_overlap_method_for_radiation + long_name = max-random overlap clouds + units = flag + dimensions = () + type = integer + intent = in +[iovr_maxrand] + standard_name = flag_for_maximum_random_cloud_overlap_method + long_name = choice of maximum-random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_dcorr] + standard_name = flag_for_decorrelation_length_cloud_overlap_method + long_name = choice of decorrelation-length cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_exp] + standard_name = flag_for_exponential_cloud_overlap_method + long_name = choice of exponential cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_exprand] + standard_name = flag_for_exponential_random_cloud_overlap_method + long_name = choice of exponential-random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_rand] + standard_name = flag_for_random_cloud_overlap_method + long_name = choice of random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_max] + standard_name = flag_for_maximum_cloud_overlap_method + long_name = choice of maximum cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_convcld] + standard_name = flag_for_convective_cloud_overlap_method_for_radiation + long_name = flag for convective cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[icseed_lw] + standard_name = random_number_seed_for_mcica_longwave + long_name = seed for random number generation for longwave radiation + units = none + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[semis] + standard_name = surface_longwave_emissivity + long_name = surface lw emissivity in fraction + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[tsfg] + standard_name = surface_ground_temperature_for_radiation + long_name = surface ground temperature for radiation + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[p_lay] + standard_name = air_pressure_at_layer_for_RRTMGP + long_name = air pressure at vertical layer for radiation calculation + units = Pa + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[p_lev] + standard_name = air_pressure_at_interface_for_RRTMGP + long_name = air pressure at vertical interface for radiation calculation + units = Pa + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in +[t_lay] + standard_name = air_temperature_at_layer_for_RRTMGP + long_name = air temperature at vertical layer for radiation calculation + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[t_lev] + standard_name = air_temperature_at_interface_for_RRTMGP + long_name = air temperature at vertical interface for radiation calculation + units = K + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in +[vmr_o2] + standard_name = volume_mixing_ratio_for_o2 + long_name = molar mixing ratio of o2 in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[vmr_h2o] + standard_name = volume_mixing_ratio_for_h2o + long_name = molar mixing ratio of h2o in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[vmr_o3] + standard_name = volume_mixing_ratio_for_o3 + long_name = molar mixing ratio of o3 in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[vmr_ch4] + standard_name = volume_mixing_ratio_for_ch4 + long_name = molar mixing ratio of ch4 in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[vmr_n2o] + standard_name = volume_mixing_ratio_for_n2o + long_name = molar mixing ratio of n2o in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[vmr_co2] + standard_name = volume_mixing_ratio_for_co2 + long_name = molar mixing ratio of co2 in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_frac] + standard_name = total_cloud_fraction + long_name = layer total cloud fraction + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_lwp] + standard_name = cloud_liquid_water_path + long_name = layer cloud liquid water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_reliq] + standard_name = mean_effective_radius_for_liquid_cloud + long_name = mean effective radius for liquid cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_iwp] + standard_name = cloud_ice_water_path + long_name = layer cloud ice water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_reice] + standard_name = mean_effective_radius_for_ice_cloud + long_name = mean effective radius for ice cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_swp] + standard_name = cloud_snow_water_path + long_name = layer cloud snow water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_resnow] + standard_name = mean_effective_radius_for_snow_flake + long_name = mean effective radius for snow cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_rwp] + standard_name = cloud_rain_water_path + long_name = layer cloud rain water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_rerain] + standard_name = mean_effective_radius_for_rain_drop + long_name = mean effective radius for rain cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[precip_frac] + standard_name = precipitation_fraction_by_layer + long_name = precipitation fraction in each layer + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_cnv_lwp] + standard_name = convective_cloud_liquid_water_path + long_name = layer convective cloud liquid water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_cnv_iwp] + standard_name = convective_cloud_ice_water_path + long_name = layer convective cloud ice water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_cnv_reliq] + standard_name = mean_effective_radius_for_liquid_convective_cloud + long_name = mean effective radius for liquid convective cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_cnv_reice] + standard_name = mean_effective_radius_for_ice_convective_cloud + long_name = mean effective radius for ice convective cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_pbl_lwp] + standard_name = MYNN_SGS_cloud_liquid_water_path + long_name = layer convective cloud liquid water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_pbl_iwp] + standard_name = MYNN_SGS_cloud_ice_water_path + long_name = layer convective cloud ice water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_pbl_reliq] + standard_name = mean_effective_radius_for_liquid_MYNN_SGS_cloud + long_name = mean effective radius for liquid MYNN_SGS cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_pbl_reice] + standard_name = mean_effective_radius_for_ice_MYNN_SGS_cloud + long_name = mean effective radius for ice MYNN_SGS cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cloud_overlap_param] + standard_name = cloud_overlap_param + long_name = cloud overlap parameter + units = km + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[active_gases_array] + standard_name = list_of_active_gases_used_by_RRTMGP + long_name = list of active gases used by RRTMGP + units = none + dimensions = (number_of_active_gases_used_by_RRTMGP) + type = character + kind = len=* + intent = in +[aerlw_tau] + standard_name = aerosol_optical_depth_for_longwave_bands_01_16 + long_name = aerosol optical depth for longwave bands 01-16 + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_aerosol_bands_for_longwave_radiation) + type = real + kind = kind_phys + intent = in +[aerlw_ssa] + standard_name = aerosol_single_scattering_albedo_for_longwave_bands_01_16 + long_name = aerosol single scattering albedo for longwave bands 01-16 + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_aerosol_bands_for_longwave_radiation) + type = real + kind = kind_phys + intent = in +[aerlw_g] + standard_name = aerosol_asymmetry_parameter_for_longwave_bands_01_16 + long_name = aerosol asymmetry parameter for longwave bands 01-16 + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_aerosol_bands_for_longwave_radiation) + type = real + kind = kind_phys + intent = in +[fluxlwUP_radtime] + standard_name = RRTMGP_lw_flux_profile_upward_allsky_on_radiation_timestep + long_name = RRTMGP upward longwave all-sky flux profile + units = W m-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = inout +[fluxlwDOWN_radtime] + standard_name = RRTMGP_lw_flux_profile_downward_allsky_on_radiation_timestep + long_name = RRTMGP downward longwave all-sky flux profile + units = W m-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = inout +[fluxlwUP_allsky] + standard_name = RRTMGP_lw_flux_profile_upward_allsky + long_name = RRTMGP upward longwave all-sky flux profile + units = W m-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = inout +[fluxlwDOWN_allsky] + standard_name = RRTMGP_lw_flux_profile_downward_allsky + long_name = RRTMGP downward longwave all-sky flux profile + units = W m-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = inout +[fluxlwUP_clrsky] + standard_name = RRTMGP_lw_flux_profile_upward_clrsky + long_name = RRTMGP upward longwave clr-sky flux profile + units = W m-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = inout +[fluxlwDOWN_clrsky] + standard_name = RRTMGP_lw_flux_profile_downward_clrsky + long_name = RRTMGP downward longwave clr-sky flux profile + units = W m-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = inout +[fluxlwUP_jac] + standard_name = RRTMGP_jacobian_of_lw_flux_upward + long_name = RRTMGP Jacobian upward longwave flux profile + units = W m-2 K-1 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = inout +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out \ No newline at end of file diff --git a/physics/rrtmgp_lw_pre.F90 b/physics/rrtmgp_lw_pre.F90 deleted file mode 100644 index 1501ca319..000000000 --- a/physics/rrtmgp_lw_pre.F90 +++ /dev/null @@ -1,61 +0,0 @@ -!> \file rrtmgp_lw_pre.F90 -!! -!> \defgroup rrtmgp_lw_pre rrtmgp_lw_pre.F90 -!! -!! \brief RRTMGP Longwave pre-processing routine. -!! -module rrtmgp_lw_pre - use machine, only: & - kind_phys ! Working type - use mo_gas_optics_rrtmgp, only: & - ty_gas_optics_rrtmgp - use rrtmgp_lw_gas_optics, only: lw_gas_props - - implicit none - - public rrtmgp_lw_pre_run - -contains - -!>\defgroup rrtmgp_lw_pre_mode GFS RRTMGP-LW Pre Module -!> \section arg_table_rrtmgp_lw_pre_run -!! \htmlinclude rrtmgp_lw_pre_run.html -!! -!> \ingroup rrtmgp_lw_pre -!! -!! \brief -!! -!! \section rrtmgp_lw_pre_run - subroutine rrtmgp_lw_pre_run (doLWrad, semis, sfc_emiss_byband, errmsg, errflg) - - ! Inputs - logical, intent(in) :: & - doLWrad - real(kind_phys), dimension(:), intent(in) :: & - semis - - ! Outputs - real(kind_phys), dimension(:,:), intent(inout) :: & - sfc_emiss_byband ! Surface emissivity in each band - character(len=*), intent(out) :: & - errmsg ! Error message - integer, intent(out) :: & - errflg ! Error flag - - ! Local variables - integer :: iBand - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (.not. doLWrad) return - - ! Assign same emissivity to all bands - do iBand=1,lw_gas_props%get_nband() - sfc_emiss_byband(iBand,:) = semis - enddo - - end subroutine rrtmgp_lw_pre_run - -end module rrtmgp_lw_pre diff --git a/physics/rrtmgp_lw_pre.meta b/physics/rrtmgp_lw_pre.meta deleted file mode 100644 index aa2a06a0f..000000000 --- a/physics/rrtmgp_lw_pre.meta +++ /dev/null @@ -1,47 +0,0 @@ -[ccpp-table-properties] - name = rrtmgp_lw_pre - type = scheme - dependencies = iounitdef.f,machine.F - -######################################################################## -[ccpp-arg-table] - name = rrtmgp_lw_pre_run - type = scheme -[doLWrad] - standard_name = flag_for_calling_longwave_radiation - long_name = logical flags for lw radiation calls - units = flag - dimensions = () - type = logical - intent = in -[semis] - standard_name = surface_longwave_emissivity - long_name = surface lw emissivity in fraction - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[sfc_emiss_byband] - standard_name = surface_emissivity_in_each_RRTMGP_LW_band - long_name = surface emissivity in each RRTMGP LW band - units = none - dimensions = (number_of_longwave_bands,horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out diff --git a/physics/rrtmgp_lw_rte.F90 b/physics/rrtmgp_lw_rte.F90 deleted file mode 100644 index 9109a5780..000000000 --- a/physics/rrtmgp_lw_rte.F90 +++ /dev/null @@ -1,208 +0,0 @@ -!> \file rrtmgp_lw_rte.F90 -!! -!> \defgroup rrtmgp_lw_rte rrtmgp_lw_rte.F90 -!! -!! \brief This module contains the main rte longwave driver. -!! -module rrtmgp_lw_rte - use machine, only: kind_phys - use mo_optical_props, only: ty_optical_props_1scl, ty_optical_props_2str - use mo_rte_lw, only: rte_lw - use mo_fluxes_byband, only: ty_fluxes_byband - use mo_source_functions, only: ty_source_func_lw - use radiation_tools, only: check_error_msg - use rrtmgp_lw_gas_optics, only: lw_gas_props - implicit none - - public rrtmgp_lw_rte_run -contains - -!>\defgroup rrtmgp_lw_rte_mod GFS RRTMGP-LW RTE Module -!> \section arg_table_rrtmgp_lw_rte_run -!! \htmlinclude rrtmgp_lw_rte_run.html -!! -!> \ingroup rrtmgp_lw_rte -!! -!! \brief This routine takes all of the longwave optical properties ,ty_optical_props_1scl, -!! and computes the longwave radiative fluxes for cloudy and clear-sky conditions. -!! -!! \section rrtmgp_lw_rte_run - subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, nCol, & - nLev, top_at_1, doGP_sgs_cnv, doGP_sgs_mynn, sfc_emiss_byband, sources, & - lw_optical_props_clrsky, lw_optical_props_clouds, lw_optical_props_precipByBand, & - lw_optical_props_cnvcloudsByBand, lw_optical_props_MYNNcloudsByBand, & - lw_optical_props_aerosol, nGauss_angles, fluxlwUP_allsky, fluxlwDOWN_allsky, & - fluxlwUP_clrsky, fluxlwDOWN_clrsky, fluxlwUP_jac, fluxlwUP_radtime, & - fluxlwDOWN_radtime, errmsg, errflg) - - ! Inputs - logical, intent(in) :: & - top_at_1, & ! Vertical ordering flag - doLWrad, & ! Logical flag for longwave radiation call - doLWclrsky, & ! Compute clear-sky fluxes for clear-sky heating-rate? - use_LW_jacobian, & ! Compute Jacobian of LW to update radiative fluxes between radiation calls? - doGP_sgs_mynn, & ! Flag for sgs MYNN-EDMF PBL cloud scheme - doGP_sgs_cnv, & ! Flagg for sgs convective cloud scheme - doGP_lwscat ! Include scattering in LW cloud-optics? - integer, intent(in) :: & - nCol, & ! Number of horizontal gridpoints - nLev, & ! Number of vertical levels - nGauss_angles ! Number of angles used in Gaussian quadrature - real(kind_phys), dimension(:,:), intent(in) :: & - sfc_emiss_byband ! Surface emissivity in each band - type(ty_source_func_lw),intent(in) :: & - sources ! RRTMGP DDT: longwave source functions - type(ty_optical_props_1scl),intent(inout) :: & - lw_optical_props_aerosol, &! RRTMGP DDT: longwave aerosol optical properties - lw_optical_props_clrsky ! RRTMGP DDT: longwave clear-sky optical properties - type(ty_optical_props_2str),intent(inout) :: & - lw_optical_props_clouds, & ! RRTMGP DDT: longwave cloud optical properties - lw_optical_props_precipByBand, & ! RRTMGP DDT: longwave precipitation optical properties - lw_optical_props_cnvcloudsByBand, & ! RRTMGP DDT: longwave convective cloud optical properties - lw_optical_props_MYNNcloudsByBand ! RRTMGP DDT: longwave MYNN-EDMF PBL cloud optical properties - ! Outputs - real(kind_phys), dimension(:,:), intent(inout) :: & - fluxlwUP_jac, & ! Jacobian of upwelling LW surface radiation (W/m2/K) - fluxlwUP_allsky, & ! All-sky flux (W/m2) - fluxlwDOWN_allsky, & ! All-sky flux (W/m2) - fluxlwUP_clrsky, & ! Clear-sky flux (W/m2) - fluxlwDOWN_clrsky, & ! All-sky flux (W/m2) - fluxlwUP_radtime, & ! Copy of fluxes (Used for coupling) - fluxlwDOWN_radtime - character(len=*), intent(out) :: & - errmsg ! CCPP error message - integer, intent(out) :: & - errflg ! CCPP error flag - - ! Local variables - type(ty_fluxes_byband) :: & - flux_allsky, flux_clrsky - real(kind_phys), dimension(ncol,nLev+1,lw_gas_props%get_nband()),target :: & - fluxLW_up_allsky, fluxLW_up_clrsky, fluxLW_dn_allsky, fluxLW_dn_clrsky - real(kind_phys), dimension(nCol,lw_gas_props%get_ngpt()) :: lw_Ds - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (.not. doLWrad) return - - ! Initialize RRTMGP DDT containing 2D(3D) fluxes - flux_allsky%bnd_flux_up => fluxLW_up_allsky - flux_allsky%bnd_flux_dn => fluxLW_dn_allsky - flux_clrsky%bnd_flux_up => fluxLW_up_clrsky - flux_clrsky%bnd_flux_dn => fluxLW_dn_clrsky - - ! - ! Compute clear-sky fluxes (if requested) - ! - ! Add aerosol optics to gas optics - call check_error_msg('rrtmgp_lw_rte_run',lw_optical_props_aerosol%increment(lw_optical_props_clrsky)) - - ! Call RTE solver - if (doLWclrsky) then - call check_error_msg('rrtmgp_lw_rte_run_opt_angle',lw_gas_props%compute_optimal_angles(lw_optical_props_clrsky,lw_Ds)) - if (nGauss_angles .gt. 1) then - call check_error_msg('rrtmgp_lw_rte_run',rte_lw( & - lw_optical_props_clrsky, & ! IN - optical-properties - top_at_1, & ! IN - veritcal ordering flag - sources, & ! IN - source function - sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_clrsky, & ! OUT - Fluxes - n_gauss_angles = nGauss_angles)) ! IN - Number of angles in Gaussian quadrature - else - call check_error_msg('rrtmgp_lw_rte_run',rte_lw( & - lw_optical_props_clrsky, & ! IN - optical-properties - top_at_1, & ! IN - veritcal ordering flag - sources, & ! IN - source function - sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_clrsky, & ! OUT - Fluxes - lw_Ds = lw_Ds)) - endif - - ! Store fluxes - fluxlwUP_clrsky = sum(flux_clrsky%bnd_flux_up,dim=3) - fluxlwDOWN_clrsky = sum(flux_clrsky%bnd_flux_dn,dim=3) - else - fluxlwUP_clrsky = 0.0 - fluxlwDOWN_clrsky = 0.0 - endif - - ! - ! All-sky fluxes (clear-sky + clouds + precipitation) - ! - - ! Include convective cloud? - if (doGP_sgs_cnv) then - call check_error_msg('rrtmgp_lw_rte_run',lw_optical_props_cnvcloudsByBand%increment(lw_optical_props_clrsky)) - endif - - ! Include MYNN-EDMF PBL clouds? - if (doGP_sgs_mynn) then - call check_error_msg('rrtmgp_lw_rte_run',lw_optical_props_MYNNcloudsByBand%increment(lw_optical_props_clrsky)) - endif - - ! Add in precipitation - call check_error_msg('rrtmgp_lw_rte_run',lw_optical_props_precipByBand%increment(lw_optical_props_clouds)) - - ! Include LW cloud-scattering? - if (doGP_lwscat) then - ! Add clear-sky optics to cloud-optics (2-stream) - call check_error_msg('rrtmgp_lw_rte_run',lw_optical_props_clrsky%increment(lw_optical_props_clouds)) - - if (use_LW_jacobian) then - ! Compute LW Jacobians - call check_error_msg('rrtmgp_lw_rte_run',rte_lw( & - lw_optical_props_clouds, & ! IN - optical-properties - top_at_1, & ! IN - veritcal ordering flag - sources, & ! IN - source function - sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_allsky, & ! OUT - Flxues - n_gauss_angles = nGauss_angles, & ! IN - Number of angles in Gaussian quadrature - flux_up_Jac = fluxlwUP_jac)) ! OUT - surface temperature flux (upward) Jacobian (W/m2/K) - else - call check_error_msg('rrtmgp_lw_rte_run',rte_lw( & - lw_optical_props_clouds, & ! IN - optical-properties - top_at_1, & ! IN - veritcal ordering flag - sources, & ! IN - source function - sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_allsky, & ! OUT - Flxues - n_gauss_angles = nGauss_angles)) ! IN - Number of angles in Gaussian quadrature - end if - ! No scattering in LW clouds. - else - ! Add cloud optics to clear-sky optics (scalar) - call check_error_msg('rrtmgp_lw_rte_run',lw_optical_props_clouds%increment(lw_optical_props_clrsky)) - - if (use_LW_jacobian) then - ! Compute LW Jacobians - call check_error_msg('rrtmgp_lw_rte_run',rte_lw( & - lw_optical_props_clrsky, & ! IN - optical-properties - top_at_1, & ! IN - veritcal ordering flag - sources, & ! IN - source function - sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_allsky, & ! OUT - Flxues - n_gauss_angles = nGauss_angles, & ! IN - Number of angles in Gaussian quadrature - flux_up_Jac = fluxlwUP_jac)) ! OUT - surface temperature flux (upward) Jacobian (W/m2/K) - else - call check_error_msg('rrtmgp_lw_rte_run',rte_lw( & - lw_optical_props_clrsky, & ! IN - optical-properties - top_at_1, & ! IN - veritcal ordering flag - sources, & ! IN - source function - sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_allsky, & ! OUT - Flxues - n_gauss_angles = nGauss_angles)) ! IN - Number of angles in Gaussian quadrature - end if - endif - - ! Store fluxes - fluxlwUP_allsky = sum(flux_allsky%bnd_flux_up,dim=3) - fluxlwDOWN_allsky = sum(flux_allsky%bnd_flux_dn,dim=3) - - ! Save fluxes for coupling - fluxlwUP_radtime = fluxlwUP_allsky - fluxlwDOWN_radtime = fluxlwDOWN_allsky - - end subroutine rrtmgp_lw_rte_run - -end module rrtmgp_lw_rte diff --git a/physics/rrtmgp_lw_rte.meta b/physics/rrtmgp_lw_rte.meta deleted file mode 100644 index 0ad0754b5..000000000 --- a/physics/rrtmgp_lw_rte.meta +++ /dev/null @@ -1,208 +0,0 @@ -[ccpp-table-properties] - name = rrtmgp_lw_rte - type = scheme - dependencies = machine.F,rte-rrtmgp/rte/mo_rte_lw.F90,rte-rrtmgp/rte/mo_fluxes.F90,rte-rrtmgp/rte/kernels/mo_fluxes_broadband_kernels.F90,radiation_tools.F90 - dependencies = rte-rrtmgp/rte/kernels/mo_rte_solver_kernels.F90,rte-rrtmgp/extensions/mo_fluxes_byband.F90 - -######################################################################## -[ccpp-arg-table] - name = rrtmgp_lw_rte_run - type = scheme -[doLWrad] - standard_name = flag_for_calling_longwave_radiation - long_name = logical flags for lw radiation calls - units = flag - dimensions = () - type = logical - intent = in -[doLWclrsky] - standard_name = flag_for_output_of_tendency_of_air_temperature_due_to_longwave_heating_on_radiation_timestep_assuming_clear_sky - long_name = flag to output lw heating rate (Radtend%lwhc) - units = flag - dimensions = () - type = logical - intent = in -[use_LW_jacobian] - standard_name = flag_to_calc_RRTMGP_LW_jacobian - long_name = logical flag to control RRTMGP LW calculation - units = flag - dimensions = () - type = logical - intent = in -[doGP_lwscat] - standard_name = flag_to_include_longwave_scattering_in_cloud_optics - long_name = logical flag to control the addition of LW scattering in RRTMGP - units = flag - dimensions = () - type = logical - intent = in -[doGP_sgs_cnv] - standard_name = flag_to_include_sgs_convective_cloud_in_RRTMGP - long_name = logical flag to control sgs convective cloud in RRTMGP - units = flag - dimensions = () - type = logical - intent = in -[doGP_sgs_mynn] - standard_name = flag_to_include_sgs_MYNN_EDMF_cloud_in_RRTMGP - long_name = logical flag to control MYNN-EDMF PBL cloud in RRTMGP - units = flag - dimensions = () - type = logical - intent = in -[ncol] - standard_name = horizontal_loop_extent - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in -[nLev] - standard_name = vertical_layer_dimension - long_name = number of vertical levels - units = count - dimensions = () - type = integer - intent = in -[nGauss_angles] - standard_name = number_of_gaussian_quadrature_angles_for_radiation - long_name = Number of angles used in Gaussian quadrature - units = count - dimensions = () - type = integer - intent = in -[top_at_1] - standard_name = flag_for_vertical_ordering_in_RRTMGP - long_name = flag for vertical ordering in RRTMGP - units = flag - dimensions = () - type = logical - intent = in -[sfc_emiss_byband] - standard_name = surface_emissivity_in_each_RRTMGP_LW_band - long_name = surface emissivity in each RRTMGP LW band - units = none - dimensions = (number_of_longwave_bands,horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[lw_optical_props_clrsky] - standard_name = longwave_optical_properties_for_clear_sky - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_1scl - intent = inout -[lw_optical_props_clouds] - standard_name = longwave_optical_properties_for_cloudy_atmosphere - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = inout -[lw_optical_props_precipByBand] - standard_name = longwave_optical_properties_for_precipitation_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = inout -[lw_optical_props_cnvcloudsByBand] - standard_name = longwave_optical_properties_for_convective_cloudy_atmosphere_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = inout -[lw_optical_props_MYNNcloudsByBand] - standard_name = longwave_optical_properties_for_MYNN_EDMF_PBL_cloudy_atmosphere_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = inout -[lw_optical_props_aerosol] - standard_name = longwave_optical_properties_for_aerosols - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_1scl - intent = inout -[sources] - standard_name = longwave_source_function - long_name = Fortran DDT containing RRTMGP source functions - units = DDT - dimensions = () - type = ty_source_func_lw - intent = in -[fluxlwUP_radtime] - standard_name = RRTMGP_lw_flux_profile_upward_allsky_on_radiation_timestep - long_name = RRTMGP upward longwave all-sky flux profile - units = W m-2 - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = inout -[fluxlwDOWN_radtime] - standard_name = RRTMGP_lw_flux_profile_downward_allsky_on_radiation_timestep - long_name = RRTMGP downward longwave all-sky flux profile - units = W m-2 - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = inout -[fluxlwUP_allsky] - standard_name = RRTMGP_lw_flux_profile_upward_allsky - long_name = RRTMGP upward longwave all-sky flux profile - units = W m-2 - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = inout -[fluxlwDOWN_allsky] - standard_name = RRTMGP_lw_flux_profile_downward_allsky - long_name = RRTMGP downward longwave all-sky flux profile - units = W m-2 - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = inout -[fluxlwUP_clrsky] - standard_name = RRTMGP_lw_flux_profile_upward_clrsky - long_name = RRTMGP upward longwave clr-sky flux profile - units = W m-2 - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = inout -[fluxlwDOWN_clrsky] - standard_name = RRTMGP_lw_flux_profile_downward_clrsky - long_name = RRTMGP downward longwave clr-sky flux profile - units = W m-2 - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = inout -[fluxlwUP_jac] - standard_name = RRTMGP_jacobian_of_lw_flux_upward - long_name = RRTMGP Jacobian upward longwave flux profile - units = W m-2 K-1 - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = inout -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out diff --git a/physics/rrtmgp_sw_cloud_optics.F90 b/physics/rrtmgp_sw_cloud_optics.F90 index 3aab115cd..4293a7be6 100644 --- a/physics/rrtmgp_sw_cloud_optics.F90 +++ b/physics/rrtmgp_sw_cloud_optics.F90 @@ -1,18 +1,7 @@ -!> \file rrtmgp_sw_cloud_optics.F90 -!! -!> \defgroup rrtmgp_sw_cloud_optics rrtmgp_sw_cloud_optics.F90 -!! -!! \brief This module contains two routines: The first initializes data and functions -!! needed to compute the shortwave cloud radiative properteis in RRTMGP. The second routine -!! is a ccpp scheme within the "radiation loop", where the shortwave optical prperties -!! (optical-depth, single-scattering albedo, asymmetry parameter) are computed for ALL -!! cloud types visible to RRTMGP. module rrtmgp_sw_cloud_optics use machine, only: kind_phys use mo_rte_kind, only: wl use mo_cloud_optics, only: ty_cloud_optics - use mo_optical_props, only: ty_optical_props_2str - use mo_rrtmg_sw_cloud_optics, only: rrtmg_sw_cloud_optics use rrtmgp_sw_gas_optics, only: sw_gas_props use radiation_tools, only: check_error_msg use netcdf @@ -59,52 +48,41 @@ module rrtmgp_sw_cloud_optics pade_exticeSW, & ! PADE coefficients for shortwave ice extinction pade_ssaiceSW, & ! PADE coefficients for shortwave ice single scattering albedo pade_asyiceSW ! PADE coefficients for shortwave ice asymmetry parameter + real(kind_phys) :: & + radliq_lwrSW, & ! Liquid particle size lower bound for LUT interpolation + radliq_uprSW, & ! Liquid particle size upper bound for LUT interpolation + radice_lwrSW, & ! Ice particle size upper bound for LUT interpolation + radice_uprSW ! Ice particle size lower bound for LUT interpolation - ! Parameters used for rain and snow(+groupel) RRTMGP cloud-optics + ! Parameters used for rain and snow(+groupel) RRTMGP cloud-optics. *NOTE* Same as in RRTMG + ! Need to document these magic numbers below. real(kind_phys),parameter :: & - a0r = 3.07e-3, & ! - a0s = 0.0, & ! - a1s = 1.5 ! + a0r = 3.07e-3, & ! + a0s = 0.0, & ! + a1s = 1.5 ! real(kind_phys),dimension(:),allocatable :: b0r,b0s,b1s,c0r,c0s - real(kind_phys) :: & - radliq_lwrSW, & ! Liquid particle size lower bound for LUT interpolation - radliq_uprSW, & ! Liquid particle size upper bound for LUT interpolation - radice_lwrSW, & ! Ice particle size upper bound for LUT interpolation - radice_uprSW ! Ice particle size lower bound for LUT interpolation contains - -!>\defgroup rrtmgp_sw_cloud_optics_mod GFS RRTMGP-SW Cloud Optics Module -!> \section arg_table_rrtmgp_sw_cloud_optics_init -!! \htmlinclude rrtmgp_lw_cloud_optics.html -!! -!> \ingroup rrtmgp_sw_cloud_optics -!! -!! RRTMGP relies heavily on derived-data-types, which contain type-bound procedures -!! that are referenced frequently throughout the RRTMGP shortwave scheme. The data needed -!! to compute the shortwave cloud optical properties are initialized here and loaded into -!! the RRTMGP DDT, ty_cloud_optics. -!! -!! \section rrtmgp_sw_cloud_optics_init ! ###################################################################################### - subroutine rrtmgp_sw_cloud_optics_init(doG_cldoptics, doGP_cldoptics_PADE, & - doGP_cldoptics_LUT, nrghice, rrtmgp_root_dir, rrtmgp_sw_file_clouds, mpicomm, & - mpirank, mpiroot, errmsg, errflg) + ! SUBROUTINE sw_cloud_optics_init + ! ###################################################################################### + subroutine rrtmgp_sw_cloud_optics_init( rrtmgp_root_dir, rrtmgp_sw_file_clouds, & + doGP_cldoptics_PADE, doGP_cldoptics_LUT, nrghice, mpicomm, mpirank, mpiroot, & + errmsg, errflg) ! Inputs + character(len=128),intent(in) :: & + rrtmgp_root_dir, & ! RTE-RRTMGP root directory + rrtmgp_sw_file_clouds ! RRTMGP file containing cloud-optic data logical, intent(in) :: & - doG_cldoptics, & ! Use legacy RRTMG cloud-optics? - doGP_cldoptics_PADE, & ! Use RRTMGP cloud-optics: PADE approximation? - doGP_cldoptics_LUT ! Use RRTMGP cloud-optics: LUTs? + doGP_cldoptics_PADE,& ! Use RRTMGP cloud-optics: PADE approximation? + doGP_cldoptics_LUT ! Use RRTMGP cloud-optics: LUTs? integer, intent(inout) :: & nrghice ! Number of ice-roughness categories integer, intent(in) :: & mpicomm, & ! MPI communicator mpirank, & ! Current MPI rank mpiroot ! Master MPI rank - character(len=128),intent(in) :: & - rrtmgp_root_dir, & ! RTE-RRTMGP root directory - rrtmgp_sw_file_clouds ! RRTMGP file containing coefficients used to compute clouds optical properties ! Outputs character(len=*), intent(out) :: & @@ -120,8 +98,6 @@ subroutine rrtmgp_sw_cloud_optics_init(doG_cldoptics, doGP_cldoptics_PADE, errmsg = '' errflg = 0 - if (doG_cldoptics) return - ! Filenames are set in the physics_nml sw_cloud_props_file = trim(rrtmgp_root_dir)//trim(rrtmgp_sw_file_clouds) @@ -180,7 +156,7 @@ subroutine rrtmgp_sw_cloud_optics_init(doG_cldoptics, doGP_cldoptics_PADE, call mpi_bcast(nPairsSW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) #endif - ! Has the number of ice-roughnesses provided from the namelist? + ! Has the number of ice-roughnes categories been provided from the namelist? ! If so, override nrghice from cloud-optics file if (nrghice .ne. 0) nrghice_fromfileSW = nrghice #ifdef MPI @@ -404,182 +380,4 @@ subroutine rrtmgp_sw_cloud_optics_init(doG_cldoptics, doGP_cldoptics_PADE, 0.970, 0.970, 0.970, 0.700, 0.700, 0.700, 0.700/) end subroutine rrtmgp_sw_cloud_optics_init - -!> \section arg_table_rrtmgp_sw_cloud_optics_run -!! \htmlinclude rrtmgp_sw_cloud_optics.html -!! -!> \ingroup rrtmgp_sw_cloud_optics -!! -!! Compute shortwave optical prperties (optical-depth, single-scattering albedo, -!! asymmetry parameter) for ALL cloud types visible to RRTMGP. -!! -!! \section rrtmgp_sw_gas_optics_run - ! ###################################################################################### - subroutine rrtmgp_sw_cloud_optics_run(doSWrad, doG_cldoptics, icliq_sw, icice_sw, & - doGP_cldoptics_PADE, doGP_cldoptics_LUT, do_mynnedmf, imfdeepcnv, imfdeepcnv_gf, & - imfdeepcnv_samf, nCol, nLev, nDay, nbndsGPsw, idxday, cld_frac, cld_lwp, cld_reliq, & - cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, cld_rerain, precip_frac, & - cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, cld_cnv_reice, cld_pbl_lwp, cld_pbl_reliq, & - cld_pbl_iwp, cld_pbl_reice, sw_optical_props_cloudsByBand, & - sw_optical_props_cnvcloudsByBand, sw_optical_props_precipByBand, & - sw_optical_props_MYNNcloudsByBand, cldtausw, errmsg, errflg) - - ! Inputs - logical, intent(in) :: & - doSWrad, & ! Logical flag for shortwave radiation call - doG_cldoptics, & ! Use legacy RRTMG cloud-optics? - doGP_cldoptics_PADE, & ! Use RRTMGP cloud-optics: PADE approximation? - doGP_cldoptics_LUT, & ! Use RRTMGP cloud-optics: LUTs? - do_mynnedmf ! - integer, intent(in) :: & - nbndsGPsw, & ! Number of shortwave bands - nCol, & ! Number of horizontal gridpoints - nLev, & ! Number of vertical levels - nday, & ! Number of daylit points. - icliq_sw, & ! Choice of treatment of liquid cloud optical properties (RRTMG legacy) - icice_sw, & ! Choice of treatment of ice cloud optical properties (RRTMG legacy) - imfdeepcnv, & ! - imfdeepcnv_gf, & ! - imfdeepcnv_samf ! - integer,intent(in),dimension(:) :: & - idxday ! Indices for daylit points. - real(kind_phys), dimension(:,:),intent(in) :: & - cld_frac, & ! Total cloud fraction by layer - cld_lwp, & ! Cloud liquid water path - cld_reliq, & ! Cloud liquid effective radius - cld_iwp, & ! Cloud ice water path - cld_reice, & ! Cloud ice effective radius - cld_swp, & ! Cloud snow water path - cld_resnow, & ! Cloud snow effective radius - cld_rwp, & ! Cloud rain water path - cld_rerain, & ! Cloud rain effective radius - precip_frac, & ! Precipitation fraction by layer - cld_cnv_lwp, & ! Water path for convective liquid cloud-particles (microns) - cld_cnv_reliq, & ! Effective radius for convective liquid cloud-particles (microns) - cld_cnv_iwp, & ! Water path for convective ice cloud-particles (microns) - cld_cnv_reice, & ! Effective radius for convective ice cloud-particles (microns) - cld_pbl_lwp, & ! Water path for SGS PBL liquid cloud-particles - cld_pbl_reliq, & ! Effective radius for SGS PBL liquid cloud-particles - cld_pbl_iwp, & ! Water path for SGS PBL ice cloud-particles - cld_pbl_reice ! Effective radius for SGS PBL ice cloud-particles - ! Outputs - character(len=*), intent(out) :: & - errmsg ! CCPP error message - integer, intent(out) :: & - errflg ! CCPP error flag - type(ty_optical_props_2str),intent(out) :: & - sw_optical_props_cloudsByBand, & ! RRTMGP DDT: Shortwave optical properties in each band (clouds) - sw_optical_props_cnvcloudsByBand, & ! RRTMGP DDT: Shortwave optical properties in each band (convective cloud) - sw_optical_props_MYNNcloudsByBand,& ! RRTMGP DDT: Shortwave optical properties in each band (MYNN PBL cloud) - sw_optical_props_precipByBand ! RRTMGP DDT: Shortwave optical properties in each band (cloud precipitation) - real(kind_phys), dimension(:,:), intent(out) :: & - cldtausw ! Approx 10.mu band layer cloud optical depth - - ! Local variables - integer :: iDay, iLay, iBand - real(kind_phys) :: tau_rain, tau_snow, ssa_rain, ssa_snow, asy_rain, asy_snow, & - tau_prec, asy_prec, ssa_prec, asyw, ssaw, za1, za2 - real(kind_phys), dimension(nday,nLev,nbndsGPsw) :: & - tau_cld, ssa_cld, asy_cld, tau_precip, ssa_precip, asy_precip - type(ty_optical_props_2str) :: sw_optical_props_cloudsByBand_daylit - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (.not. doSWrad) return - - ! Only process sunlit points... - if (nDay .gt. 0) then - - ! Compute cloud/precipitation optics. - if (doGP_cldoptics_PADE .or. doGP_cldoptics_LUT) then - ! i) Cloud-optics. - call check_error_msg('rrtmgp_sw_cloud_optics_run - sw_optical_props_cloudsByBand',& - sw_optical_props_cloudsByBand%alloc_2str(nday, nLev, sw_cloud_props%get_band_lims_wavenumber())) - - call check_error_msg('rrtmgp_sw_cloud_optics_run - clouds',sw_cloud_props%cloud_optics(& - cld_lwp(idxday(1:nday),:), & ! IN - Cloud liquid water path - cld_iwp(idxday(1:nday),:), & ! IN - Cloud ice water path - cld_reliq(idxday(1:nday),:), & ! IN - Cloud liquid effective radius - cld_reice(idxday(1:nday),:), & ! IN - Cloud ice effective radius - sw_optical_props_cloudsByBand)) ! OUT - RRTMGP DDT: Shortwave optical properties, - ! in each band (tau,ssa,g) - - ! ii) Convective cloud-optics - if (imfdeepcnv == imfdeepcnv_samf .or. imfdeepcnv == imfdeepcnv_gf) then - call check_error_msg('rrtmgp_sw_cloud_optics_run - sw_optical_props_cnvcloudsByBand',& - sw_optical_props_cnvcloudsByBand%alloc_2str(nday, nLev, sw_cloud_props%get_band_lims_wavenumber())) - - call check_error_msg('rrtmgp_sw_cloud_optics_run - convective clouds',sw_cloud_props%cloud_optics(& - cld_cnv_lwp(idxday(1:nday),:), & ! IN - Convective cloud liquid water path - cld_cnv_iwp(idxday(1:nday),:), & ! IN - Convective cloud ice water path - cld_cnv_reliq(idxday(1:nday),:), & ! IN - Convective cloud liquid effective radius - cld_cnv_reice(idxday(1:nday),:), & ! IN - Convective cloud ice effective radius - sw_optical_props_cnvcloudsByBand)) ! OUT - RRTMGP DDT: Shortwave optical properties, - ! in each band (tau,ssa,g) - endif - - ! iii) MYNN cloud-optics - if (do_mynnedmf) then - call check_error_msg('rrtmgp_sw_cloud_optics_run - sw_optical_props_MYNNcloudsByBand',& - sw_optical_props_MYNNcloudsByBand%alloc_2str(nday, nLev, sw_cloud_props%get_band_lims_wavenumber())) - - call check_error_msg('rrtmgp_sw_MYNNcloud_optics_run - MYNN-EDMF cloud',sw_cloud_props%cloud_optics(& - cld_pbl_lwp(idxday(1:nday),:), & ! IN - MYNN-EDMF PBL cloud liquid water path (g/m2) - cld_pbl_iwp(idxday(1:nday),:), & ! IN - MYNN-EDMF PBL cloud ice water path (g/m2) - cld_pbl_reliq(idxday(1:nday),:), & ! IN - MYNN-EDMF PBL cloud liquid effective radius (microns) - cld_pbl_reice(idxday(1:nday),:), & ! IN - MYNN-EDMF PBL cloud ice effective radius (microns) - sw_optical_props_MYNNcloudsByBand)) ! OUT - RRTMGP DDT containing MYNN-EDMF PBL cloud radiative properties - ! in each band - endif - - ! iv) Cloud precipitation optics: rain and snow(+groupel) - call check_error_msg('rrtmgp_sw_cloud_optics_run - sw_optical_props_precipByBand',& - sw_optical_props_precipByBand%alloc_2str(nday, nLev, sw_cloud_props%get_band_lims_wavenumber())) - sw_optical_props_precipByBand%tau(:,:,:) = 0._kind_phys - sw_optical_props_precipByBand%ssa(:,:,:) = 1._kind_phys - sw_optical_props_precipByBand%g(:,:,:) = 0._kind_phys - - do iDay=1,nDay - do iLay=1,nLev - if (cld_frac(idxday(iDay),iLay) .gt. 1.e-12_kind_phys) then - ! Rain/Snow optical depth (No band dependence) - tau_rain = cld_rwp(idxday(iDay),iLay)*a0r - if (cld_swp(idxday(iDay),iLay) .gt. 0. .and. cld_resnow(idxday(iDay),iLay) .gt. 10._kind_phys) then - tau_snow = cld_swp(idxday(iDay),iLay)*1.09087*(a0s + a1s/(1.0315*cld_resnow(idxday(iDay),iLay))) ! fu's formula - else - tau_snow = 0._kind_phys - endif - - ! Rain/Snow single-scattering albedo and asymmetry (Band dependent) - do iBand=1,nbndsGPsw - ! By species - ssa_rain = tau_rain*(1.-b0r(iBand)) - asy_rain = ssa_rain*c0r(iBand) - ssa_snow = tau_snow*(1.-(b0s(iBand)+b1s(iBand)*1.0315*cld_resnow(idxday(iDay),iLay))) - asy_snow = ssa_snow*c0s(iBand) - ! Combine - tau_prec = max(1.e-12_kind_phys, tau_rain + tau_snow) - ssa_prec = max(1.e-12_kind_phys, ssa_rain + ssa_snow) - asy_prec = max(1.e-12_kind_phys, asy_rain + asy_snow) - asyw = asy_prec/max(1.e-12_kind_phys, ssa_prec) - ssaw = min(1._kind_phys-0.000001, ssa_prec/tau_prec) - za1 = asyw * asyw - za2 = ssaw * za1 - sw_optical_props_precipByBand%tau(iDay,iLay,iBand) = (1._kind_phys - za2) * tau_prec - sw_optical_props_precipByBand%ssa(iDay,iLay,iBand) = (ssaw - za2) / (1._kind_phys - za2) - sw_optical_props_precipByBand%g(iDay,iLay,iBand) = asyw/(1+asyw) - enddo - endif - enddo - enddo - endif - - ! All-sky SW optical depth ~0.55microns (DJS asks: Move to cloud diagnostics?) - cldtausw(idxday(1:nDay),:) = sw_optical_props_cloudsByBand%tau(:,:,11) - endif - - end subroutine rrtmgp_sw_cloud_optics_run - end module rrtmgp_sw_cloud_optics diff --git a/physics/rrtmgp_sw_cloud_optics.meta b/physics/rrtmgp_sw_cloud_optics.meta deleted file mode 100644 index 064b7cf80..000000000 --- a/physics/rrtmgp_sw_cloud_optics.meta +++ /dev/null @@ -1,393 +0,0 @@ -[ccpp-table-properties] - name = rrtmgp_sw_cloud_optics - type = scheme - dependencies = machine.F,rrtmg_sw_cloud_optics.F90,radiation_tools.F90 - -######################################################################## -[ccpp-arg-table] - name = rrtmgp_sw_cloud_optics_init - type = scheme -[doG_cldoptics] - standard_name = flag_to_calc_lw_cld_optics_using_RRTMG - long_name = logical flag to control cloud optics scheme. - units = flag - dimensions = () - type = logical - intent = in -[doGP_cldoptics_PADE] - standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_PADE - long_name = logical flag to control cloud optics scheme. - units = flag - dimensions = () - type = logical - intent = in -[doGP_cldoptics_LUT] - standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_LUT - long_name = logical flag to control cloud optics scheme. - units = flag - dimensions = () - type = logical - intent = in -[nrghice] - standard_name = number_of_ice_roughness_categories - long_name = number of ice-roughness categories in RRTMGP calculation - units = count - dimensions = () - type = integer - intent = inout -[rrtmgp_root_dir] - standard_name = directory_for_rte_rrtmgp_source_code - long_name = directory for rte+rrtmgp source code - units = none - dimensions = () - type = character - intent = in - kind = len=128 -[rrtmgp_sw_file_clouds] - standard_name = filename_of_rrtmgp_shortwave_cloud_optics_coefficients - long_name = file containing coefficients for RRTMGP SW cloud optics - units = none - dimensions = () - type = character - intent = in - kind = len=128 -[mpirank] - standard_name = mpi_rank - long_name = current MPI rank - units = index - dimensions = () - type = integer - intent = in -[mpiroot] - standard_name = mpi_root - long_name = master MPI rank - units = index - dimensions = () - type = integer - intent = in -[mpicomm] - standard_name = mpi_communicator - long_name = MPI communicator - units = index - dimensions = () - type = integer - intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out -######################################################################## -[ccpp-arg-table] - name = rrtmgp_sw_cloud_optics_run - type = scheme -[doSWrad] - standard_name = flag_for_calling_shortwave_radiation - long_name = logical flags for sw radiation calls - units = flag - dimensions = () - type = logical - intent = in -[ncol] - standard_name = horizontal_loop_extent - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in -[nLev] - standard_name = vertical_layer_dimension - long_name = number of vertical levels - units = count - dimensions = () - type = integer - intent = in -[doG_cldoptics] - standard_name = flag_to_calc_lw_cld_optics_using_RRTMG - long_name = logical flag to control cloud optics scheme. - units = flag - dimensions = () - type = logical - intent = in -[icliq_sw] - standard_name = control_for_shortwave_radiation_liquid_clouds - long_name = sw optical property for liquid clouds - units = flag - dimensions = () - type = integer - intent = in -[icice_sw] - standard_name = flag_for_optical_property_for_ice_clouds_for_shortwave_radiation - long_name = sw optical property for ice clouds - units = flag - dimensions = () - type = integer - intent = in -[doGP_cldoptics_PADE] - standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_PADE - long_name = logical flag to control cloud optics scheme. - units = flag - dimensions = () - type = logical - intent = in -[doGP_cldoptics_LUT] - standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_LUT - long_name = logical flag to control cloud optics scheme. - units = flag - dimensions = () - type = logical - intent = in -[do_mynnedmf] - standard_name = flag_for_mellor_yamada_nakanishi_niino_pbl_scheme - long_name = flag to activate MYNN-EDMF - units = flag - dimensions = () - type = logical - intent = in -[imfdeepcnv] - standard_name = control_for_deep_convection_scheme - long_name = flag for mass-flux deep convection scheme - units = flag - dimensions = () - type = integer - intent = in -[imfdeepcnv_gf] - standard_name = identifier_for_grell_freitas_deep_convection - long_name = flag for Grell-Freitas deep convection scheme - units = flag - dimensions = () - type = integer - intent = in -[imfdeepcnv_samf] - standard_name = identifer_for_scale_aware_mass_flux_deep_convection - long_name = flag for SAMF deep convection scheme - units = flag - dimensions = () - type = integer - intent = in -[cld_frac] - standard_name = total_cloud_fraction - long_name = layer total cloud fraction - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_lwp] - standard_name = cloud_liquid_water_path - long_name = layer cloud liquid water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_reliq] - standard_name = mean_effective_radius_for_liquid_cloud - long_name = mean effective radius for liquid cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_iwp] - standard_name = cloud_ice_water_path - long_name = layer cloud ice water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_reice] - standard_name = mean_effective_radius_for_ice_cloud - long_name = mean effective radius for ice cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_swp] - standard_name = cloud_snow_water_path - long_name = layer cloud snow water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_resnow] - standard_name = mean_effective_radius_for_snow_flake - long_name = mean effective radius for snow cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_rwp] - standard_name = cloud_rain_water_path - long_name = layer cloud rain water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_rerain] - standard_name = mean_effective_radius_for_rain_drop - long_name = mean effective radius for rain cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[precip_frac] - standard_name = precipitation_fraction_by_layer - long_name = precipitation fraction in each layer - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_cnv_lwp] - standard_name = convective_cloud_liquid_water_path - long_name = layer convective cloud liquid water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_cnv_iwp] - standard_name = convective_cloud_ice_water_path - long_name = layer convective cloud ice water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_cnv_reliq] - standard_name = mean_effective_radius_for_liquid_convective_cloud - long_name = mean effective radius for liquid convective cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_cnv_reice] - standard_name = mean_effective_radius_for_ice_convective_cloud - long_name = mean effective radius for ice convective cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_pbl_lwp] - standard_name = MYNN_SGS_cloud_liquid_water_path - long_name = layer convective cloud liquid water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_pbl_iwp] - standard_name = MYNN_SGS_cloud_ice_water_path - long_name = layer convective cloud ice water path - units = g m-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_pbl_reliq] - standard_name = mean_effective_radius_for_liquid_MYNN_SGS_cloud - long_name = mean effective radius for liquid MYNN_SGS cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_pbl_reice] - standard_name = mean_effective_radius_for_ice_MYNN_SGS_cloud - long_name = mean effective radius for ice MYNN_SGS cloud - units = um - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[nbndsGPsw] - standard_name = number_of_shortwave_bands - long_name = number of sw bands used in RRTMGP - units = count - dimensions = () - type = integer - intent = in -[nday] - standard_name = daytime_points_dimension - long_name = daytime points dimension - units = count - dimensions = () - type = integer - intent = in -[idxday] - standard_name = daytime_points - long_name = daytime points - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = in -[sw_optical_props_cloudsByBand] - standard_name = shortwave_optical_properties_for_cloudy_atmosphere_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = out -[sw_optical_props_cnvcloudsByBand] - standard_name = shortwave_optical_properties_for_convective_cloudy_atmosphere_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = out -[sw_optical_props_precipByBand] - standard_name = shortwave_optical_properties_for_precipitation_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = out -[sw_optical_props_MYNNcloudsByBand] - standard_name = shortwave_optical_properties_for_MYNN_EDMF_PBL_cloudy_atmosphere_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = out -[cldtausw] - standard_name = cloud_optical_depth_layers_at_0p55mu_band - long_name = approx .55mu band layer cloud optical depth - units = none - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = out -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out diff --git a/physics/rrtmgp_sw_cloud_sampling.F90 b/physics/rrtmgp_sw_cloud_sampling.F90 deleted file mode 100644 index 238ed7d1c..000000000 --- a/physics/rrtmgp_sw_cloud_sampling.F90 +++ /dev/null @@ -1,174 +0,0 @@ -!> \file rrtmgp_sw_cloud_sampling.F90 -!! -!> \defgroup rrtmgp_sw_cloud_sampling rrtmgp_sw_cloud_sampling.F90 -!! -module rrtmgp_sw_cloud_sampling - use machine, only: kind_phys, kind_dbl_prec - use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp - use mo_optical_props, only: ty_optical_props_2str - use rrtmgp_sampling, only: sampled_mask, draw_samples - use mersenne_twister, only: random_setseed, random_number, random_stat - use radiation_tools, only: check_error_msg - use rrtmgp_sw_gas_optics, only: sw_gas_props - use netcdf - - implicit none - -contains - -!>\defgroup rrtmgp_sw_cloud_sampling_mod GFS RRTMGP-SW Cloud Sampling Module -!> @{ -!> \section arg_table_rrtmgp_sw_cloud_sampling_run -!! \htmlinclude rrtmgp_sw_cloud_sampling.html -!! -!> \ingroup rrtmgp_sw_cloud_sampling -!! -!! \brief This routine performs the McICA cloud-sampling and maps the shortwave cloud- -!! optical properties, defined for each spectral band, to each spectral point (g-point). -!! -!! \section rrtmgp_sw_cloud_sampling_run - subroutine rrtmgp_sw_cloud_sampling_run(doSWrad, nCol, nDay, nLev, idxday, iovr, & - iovr_convcld, iovr_max, iovr_maxrand, iovr_rand, iovr_dcorr, iovr_exp, iovr_exprand, & - isubc_sw,icseed_sw, cld_frac, precip_frac, cloud_overlap_param, precip_overlap_param,& - imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_samf, cnv_cloud_overlap_param, cld_cnv_frac, & - sw_optical_props_cnvcloudsByBand, sw_optical_props_cloudsByBand, & - sw_optical_props_precipByBand, sw_optical_props_clouds, sw_optical_props_cnvclouds, & - sw_optical_props_precip, errmsg, errflg) - - ! Inputs - logical, intent(in) :: & - doSWrad ! Logical flag for shortwave radiation call - integer, intent(in) :: & - nCol, & ! Number of horizontal gridpoints - nDay, & ! Number of daylit points. - nLev, & ! Number of vertical layers - imfdeepcnv, & ! - imfdeepcnv_gf, & ! - imfdeepcnv_samf, & ! - iovr, & ! Choice of cloud-overlap method - iovr_convcld, & ! Choice of convective cloud-overlap method - iovr_max, & ! Flag for maximum cloud overlap method - iovr_maxrand, & ! Flag for maximum-random cloud overlap method - iovr_rand, & ! Flag for random cloud overlap method - iovr_dcorr, & ! Flag for decorrelation-length cloud overlap method - iovr_exp, & ! Flag for exponential cloud overlap method - iovr_exprand, & ! Flag for exponential-random cloud overlap method - isubc_sw - integer,intent(in),dimension(:) :: & - idxday ! Indices for daylit points. - integer,intent(in),dimension(:) :: & - icseed_sw ! auxiliary special cloud related array when module - ! variable isubc_sw=2, it provides permutation seed - ! for each column profile that are used for generating - ! random numbers. when isubc_sw /=2, it will not be used. - real(kind_phys), dimension(:,:),intent(in) :: & - cld_frac, & ! Total cloud fraction by layer - cld_cnv_frac, & ! Convective cloud fraction by layer - precip_frac ! Precipitation fraction by layer - real(kind_phys), dimension(:,:), intent(in) :: & - cloud_overlap_param, & ! Cloud overlap parameter - cnv_cloud_overlap_param, & ! Convective cloud overlap parameter - precip_overlap_param ! Precipitation overlap parameter - type(ty_optical_props_2str),intent(in) :: & - sw_optical_props_cloudsByBand, & ! RRTMGP DDT: Shortwave optical properties in each band (clouds) - sw_optical_props_cnvcloudsByBand,& ! RRTMGP DDT: Shortwave optical properties in each band (convectivecloud) - sw_optical_props_precipByBand ! RRTMGP DDT: Shortwave optical properties in each band (precipitation) - - ! Outputs - character(len=*), intent(out) :: & - errmsg ! Error message - integer, intent(out) :: & - errflg ! Error flag - type(ty_optical_props_2str),intent(out) :: & - sw_optical_props_clouds, & ! RRTMGP DDT: Shortwave optical properties at each spectral point (clouds) - sw_optical_props_cnvclouds, & ! RRTMGP DDT: Shortwave optical properties at each spectral point (convectivecloud) - sw_optical_props_precip ! RRTMGP DDT: Shortwave optical properties at each spectral point (precipitation) - - ! Local variables - integer :: iday,iLay,iGpt - integer,dimension(nday) :: ipseed_sw - type(random_stat) :: rng_stat - real(kind_phys) :: tauloc,asyloc,ssaloc - real(kind_dbl_prec), dimension(sw_gas_props%get_ngpt(),nLev,nday) :: rng3D,rng3D2 - real(kind_dbl_prec), dimension(sw_gas_props%get_ngpt()*nLev) :: rng2D - real(kind_dbl_prec), dimension(sw_gas_props%get_ngpt()) :: rng1D - logical, dimension(nday,nLev,sw_gas_props%get_ngpt()) :: maskMCICA - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (.not. doSWrad) return - if (nDay .gt. 0) then - ! ################################################################################# - ! First sample the clouds... - ! ################################################################################# - - ! Allocate space RRTMGP DDTs [nday,nLev,nGpt] - call check_error_msg('rrtmgp_sw_cloud_sampling_run', & - sw_optical_props_clouds%alloc_2str(nday, nLev, sw_gas_props)) - - ! Change random number seed value for each radiation invocation (isubc_sw =1 or 2). - if(isubc_sw == 1) then ! advance prescribed permutation seed - do iday = 1, nday - ipseed_sw(iday) = sw_gas_props%get_ngpt() + iday - enddo - elseif (isubc_sw == 2) then ! use input array of permutaion seeds - do iday = 1, nday - ipseed_sw(iday) = icseed_sw(idxday(iday)) - enddo - endif - - ! Call RNG. Mersennse Twister accepts 1D array, so loop over columns and collapse along G-points - ! and layers. ([nGpts,nLev,nDayumn]-> [nGpts*nLev]*nDayumn) - do iday=1,nday - call random_setseed(ipseed_sw(iday),rng_stat) - ! Use same rng for each layer - if (iovr == iovr_max) then - call random_number(rng1D,rng_stat) - do iLay=1,nLev - rng3D(:,iLay,iday) = rng1D - enddo - else - do iLay=1,nLev - call random_number(rng1D,rng_stat) - rng3D(:,iLay,iday) = rng1D - enddo - endif - enddo - - ! Cloud overlap. - ! Maximum-random, random, or maximum cloud overlap - if (iovr == iovr_maxrand .or. iovr == iovr_max .or. iovr == iovr_rand) then - call sampled_mask(real(rng3D, kind=kind_phys), cld_frac(idxday(1:nDay),:), maskMCICA) - endif - ! Decorrelation-length overlap - if (iovr == iovr_dcorr) then - do iday=1,nday - call random_setseed(ipseed_sw(iday),rng_stat) - call random_number(rng2D,rng_stat) - rng3D2(:,:,iday) = reshape(source = rng2D,shape=[sw_gas_props%get_ngpt(),nLev]) - enddo - call sampled_mask(real(rng3D, kind=kind_phys), cld_frac(idxday(1:nDay),:), maskMCICA, & - overlap_param = cloud_overlap_param(idxday(1:nDay),1:nLev-1), & - randoms2 = real(rng3D2, kind=kind_phys)) - endif - ! Exponential or exponential-random cloud overlap - if (iovr == iovr_exp .or. iovr == iovr_exprand) then - call sampled_mask(real(rng3D, kind=kind_phys), cld_frac(idxday(1:nDay),:), maskMCICA, & - overlap_param = cloud_overlap_param(idxday(1:nDay),1:nLev-1)) - endif - - ! - ! Sampling. Map band optical depth to each g-point using McICA - ! - call check_error_msg('rrtmgp_sw_cloud_sampling_run_draw_samples', & - draw_samples(maskMCICA, .true., & - sw_optical_props_cloudsByBand, & - sw_optical_props_clouds)) - endif - - end subroutine rrtmgp_sw_cloud_sampling_run - -!> @} -end module rrtmgp_sw_cloud_sampling diff --git a/physics/rrtmgp_sw_cloud_sampling.meta b/physics/rrtmgp_sw_cloud_sampling.meta deleted file mode 100644 index 1415108f8..000000000 --- a/physics/rrtmgp_sw_cloud_sampling.meta +++ /dev/null @@ -1,240 +0,0 @@ -[ccpp-table-properties] - name = rrtmgp_sw_cloud_sampling - type = scheme - dependencies = machine.F,mersenne_twister.f,rrtmgp_sampling.F90,radiation_tools.F90 - -###################################################### -[ccpp-arg-table] - name = rrtmgp_sw_cloud_sampling_run - type = scheme -[doSWrad] - standard_name = flag_for_calling_shortwave_radiation - long_name = logical flags for sw radiation calls - units = flag - dimensions = () - type = logical - intent = in -[imfdeepcnv] - standard_name = control_for_deep_convection_scheme - long_name = flag for mass-flux deep convection scheme - units = flag - dimensions = () - type = integer - intent = in -[imfdeepcnv_gf] - standard_name = identifier_for_grell_freitas_deep_convection - long_name = flag for Grell-Freitas deep convection scheme - units = flag - dimensions = () - type = integer - intent = in -[imfdeepcnv_samf] - standard_name = identifer_for_scale_aware_mass_flux_deep_convection - long_name = flag for SAMF deep convection scheme - units = flag - dimensions = () - type = integer - intent = in -[iovr_convcld] - standard_name = flag_for_convective_cloud_overlap_method_for_radiation - long_name = flag for convective cloud overlap method - units = flag - dimensions = () - type = integer - intent = in -[ncol] - standard_name = horizontal_loop_extent - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in -[nday] - standard_name = daytime_points_dimension - long_name = daytime points dimension - units = count - dimensions = () - type = integer - intent = in -[nLev] - standard_name = vertical_layer_dimension - long_name = number of vertical levels - units = count - dimensions = () - type = integer - intent = in -[isubc_sw] - standard_name = flag_for_sw_clouds_grid_approximation - long_name = flag for sw clouds sub-grid approximation - units = flag - dimensions = () - type = integer - intent = in -[idxday] - standard_name = daytime_points - long_name = daytime points - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = in -[iovr] - standard_name = flag_for_cloud_overlap_method_for_radiation - long_name = max-random overlap clouds - units = flag - dimensions = () - type = integer - intent = in -[iovr_maxrand] - standard_name = flag_for_maximum_random_cloud_overlap_method - long_name = choice of maximum-random cloud overlap method - units = flag - dimensions = () - type = integer - intent = in -[iovr_dcorr] - standard_name = flag_for_decorrelation_length_cloud_overlap_method - long_name = choice of decorrelation-length cloud overlap method - units = flag - dimensions = () - type = integer - intent = in -[iovr_exp] - standard_name = flag_for_exponential_cloud_overlap_method - long_name = choice of exponential cloud overlap method - units = flag - dimensions = () - type = integer - intent = in -[iovr_exprand] - standard_name = flag_for_exponential_random_cloud_overlap_method - long_name = choice of exponential-random cloud overlap method - units = flag - dimensions = () - type = integer - intent = in -[iovr_rand] - standard_name = flag_for_random_cloud_overlap_method - long_name = choice of random cloud overlap method - units = flag - dimensions = () - type = integer - intent = in -[iovr_max] - standard_name = flag_for_maximum_cloud_overlap_method - long_name = choice of maximum cloud overlap method - units = flag - dimensions = () - type = integer - intent = in -[icseed_sw] - standard_name = random_number_seed_for_mcica_shortwave - long_name = seed for random number generation for shortwave radiation - units = none - dimensions = (horizontal_loop_extent) - type = integer - intent = in -[cld_frac] - standard_name = total_cloud_fraction - long_name = layer total cloud fraction - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[precip_frac] - standard_name = precipitation_fraction_by_layer - long_name = precipitation fraction in each layer - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cld_cnv_frac] - standard_name = convective_cloud_fraction_for_RRTMGP - long_name = layer convective cloud fraction - units = frac - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cnv_cloud_overlap_param] - standard_name = convective_cloud_overlap_param - long_name = convective cloud overlap parameter - units = km - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[cloud_overlap_param] - standard_name = cloud_overlap_param - long_name = cloud overlap parameter - units = km - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[precip_overlap_param] - standard_name = precip_overlap_param - long_name = precipitation overlap parameter - units = km - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[sw_optical_props_cloudsByBand] - standard_name = shortwave_optical_properties_for_cloudy_atmosphere_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = in -[sw_optical_props_cnvcloudsByBand] - standard_name = shortwave_optical_properties_for_convective_cloudy_atmosphere_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = in -[sw_optical_props_precipByBand] - standard_name = shortwave_optical_properties_for_precipitation_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = in -[sw_optical_props_clouds] - standard_name = shortwave_optical_properties_for_cloudy_atmosphere - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = out -[sw_optical_props_cnvclouds] - standard_name = shortwave_optical_properties_for_convective_cloudy_atmosphere - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = out -[sw_optical_props_precip] - standard_name = shortwave_optical_properties_for_precipitation - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = out -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out diff --git a/physics/rrtmgp_sw_gas_optics.F90 b/physics/rrtmgp_sw_gas_optics.F90 index 4bafa56a4..f62a75e4b 100644 --- a/physics/rrtmgp_sw_gas_optics.F90 +++ b/physics/rrtmgp_sw_gas_optics.F90 @@ -2,11 +2,8 @@ !! !> \defgroup rrtmgp_sw_gas_optics rrtmgp_sw_gas_optics.F90 !! -!! \brief This module contains two routines: One to initialize the k-distribution data -!! and functions needed to compute the shortwave gaseous optical properties in RRTMGP. -!! The second routine is a ccpp scheme within the "radiation loop", where the shortwave -!! optical prperties (optical-depth, single-scattering albedo, asymmetry parameter) are -!! computed for clear-sky conditions (no aerosols) +!! \brief This module contains a routine to initialize the k-distribution data used +!! by the RRTMGP shortwave radiation scheme. !! module rrtmgp_sw_gas_optics use machine, only: kind_phys @@ -14,7 +11,6 @@ module rrtmgp_sw_gas_optics use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp use mo_gas_concentrations, only: ty_gas_concs use radiation_tools, only: check_error_msg - use mo_optical_props, only: ty_optical_props_2str use netcdf #ifdef MPI use mpi @@ -83,7 +79,7 @@ module rrtmgp_sw_gas_optics scale_by_complement_upperSW ! Absorption is scaled by concentration of scaling_gas (F) or its complement (T) contains - + ! ###################################################################################### !>\defgroup rrtmgp_sw_gas_optics_mod GFS RRTMGP-SW Gas Optics Module !> @{ !! \section arg_table_rrtmgp_sw_gas_optics_init @@ -100,19 +96,19 @@ module rrtmgp_sw_gas_optics !! \section rrtmgp_sw_gas_optics_init !> @{ ! ###################################################################################### - subroutine rrtmgp_sw_gas_optics_init(rrtmgp_root_dir, rrtmgp_sw_file_gas, & + subroutine rrtmgp_sw_gas_optics_init(rrtmgp_root_dir, rrtmgp_sw_file_gas, & active_gases_array, mpicomm, mpirank, mpiroot, errmsg, errflg) ! Inputs character(len=128),intent(in) :: & rrtmgp_root_dir, & ! RTE-RRTMGP root directory - rrtmgp_sw_file_gas ! RRTMGP file containing coefficients used to compute gaseous optical properties + rrtmgp_sw_file_gas ! RRTMGP file containing K-distribution data + character(len=*), dimension(:), intent(in) :: & + active_gases_array ! List of active gases from namelist as array integer,intent(in) :: & mpicomm, & ! MPI communicator mpirank, & ! Current MPI rank mpiroot ! Master MPI rank - character(len=*), dimension(:), intent(in) :: & - active_gases_array ! List of active gases from namelist as array ! Outputs character(len=*), intent(out) :: & @@ -121,11 +117,10 @@ subroutine rrtmgp_sw_gas_optics_init(rrtmgp_root_dir, rrtmgp_sw_file_gas, errflg ! CCPP error code ! Local variables - integer :: status, ncid, dimid, varID, iGas, mpierr, iChar + integer :: status, ncid, dimid, varID, mpierr, iChar integer,dimension(:),allocatable :: temp1, temp2, temp3, temp4 character(len=264) :: sw_gas_props_file - type(ty_gas_concs) :: gas_concentrations ! RRTMGP DDT containing active trace gases - + type(ty_gas_concs) :: gas_concs ! RRTMGP DDT containing active trace gases ! Initialize errmsg = '' @@ -488,129 +483,19 @@ subroutine rrtmgp_sw_gas_optics_init(rrtmgp_root_dir, rrtmgp_sw_file_gas, ! Initialize RRTMGP DDT's... ! ! ####################################################################################### - allocate(gas_concentrations%gas_name(1:size(active_gases_array))) - gas_concentrations%gas_name(:) = active_gases_array(:) - call check_error_msg('sw_gas_optics_init',sw_gas_props%load(gas_concentrations, & + call check_error_msg('rrtmgp_sw_gas_optics_init_gas_concs',gas_concs%init(active_gases_array)) + call check_error_msg('rrtmgp_sw_gas_optics_init_load',sw_gas_props%load(gas_concs, & gas_namesSW, key_speciesSW, band2gptSW, band_limsSW, press_refSW, press_ref_tropSW,& temp_refSW, temp_ref_pSW, temp_ref_tSW, vmr_refSW, kmajorSW, kminor_lowerSW, & kminor_upperSW, gas_minorSW, identifier_minorSW, minor_gases_lowerSW, & minor_gases_upperSW, minor_limits_gpt_lowerSW, minor_limits_gpt_upperSW, & minor_scales_with_density_lowerSW, minor_scales_with_density_upperSW, & scaling_gas_lowerSW, scaling_gas_upperSW, scale_by_complement_lowerSW, & - - scale_by_complement_upperSW, kminor_start_lowerSW, kminor_start_upperSW, & solar_quietSW, solar_facularSW, solar_sunspotSW, tsi_defaultSW, mg_defaultSW, & sb_defaultSW, rayl_lowerSW, rayl_upperSW)) end subroutine rrtmgp_sw_gas_optics_init - -!> @} - ! ###################################################################################### -!> \section arg_table_rrtmgp_sw_gas_optics_run -!! \htmlinclude rrtmgp_sw_gas_optics.html -!! -!> \ingroup rrtmgp_sw_gas_optics -!! -!! Compute shortwave optical prperties (optical-depth, single-scattering albedo, -!! asymmetry parameter) for clear-sky conditions. -!! -!! \section rrtmgp_sw_gas_optics_run -!> @{ - ! ###################################################################################### - subroutine rrtmgp_sw_gas_optics_run(doSWrad, nCol, nLev, ngptsGPsw, nday, idxday, p_lay, & - p_lev, toa_src_sw, t_lay, t_lev, active_gases_array, gas_concentrations, solcon, & - sw_optical_props_clrsky, errmsg, errflg) - - ! Inputs - logical, intent(in) :: & - doSWrad ! Flag to calculate SW irradiances - integer,intent(in) :: & - ngptsGPsw, & ! Number of spectral (g) points. - nDay, & ! Number of daylit points. - nCol, & ! Number of horizontal points - nLev ! Number of vertical levels - integer,intent(in),dimension(ncol) :: & - idxday ! Indices for daylit points. - real(kind_phys), dimension(ncol,nLev), intent(in) :: & - p_lay, & ! Pressure @ model layer-centers (Pa) - t_lay ! Temperature (K) - real(kind_phys), dimension(ncol,nLev+1), intent(in) :: & - p_lev, & ! Pressure @ model layer-interfaces (Pa) - t_lev ! Temperature @ model levels - type(ty_gas_concs),intent(inout) :: & - gas_concentrations ! RRTMGP DDT: trace gas concentrations (vmr) - real(kind_phys), intent(in) :: & - solcon ! Solar constant - - ! Output - character(len=*), intent(out) :: & - errmsg ! CCPP error message - integer, intent(out) :: & - errflg ! CCPP error code - type(ty_optical_props_2str),intent(out) :: & - sw_optical_props_clrsky ! RRTMGP DDT: clear-sky shortwave optical properties, spectral (tau,ssa,g) - real(kind_phys), dimension(nCol,ngptsGPsw), intent(out) :: & - toa_src_sw ! TOA incident spectral flux (W/m2) - character(len=*), dimension(:), intent(in) :: & - active_gases_array ! List of active gases from namelist as array - - ! Local variables - integer :: ij,iGas - real(kind_phys), dimension(ncol,nLev) :: vmrTemp - real(kind_phys), dimension(nday,ngptsGPsw) :: toa_src_sw_temp - type(ty_gas_concs) :: gas_concentrations_daylit - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (.not. doSWrad) return - - gas_concentrations%gas_name(:) = active_gases_array(:) - - toa_src_sw(:,:) = 0._kind_phys - if (nDay .gt. 0) then - ! Allocate space - call check_error_msg('rrtmgp_sw_gas_optics_run_alloc_2str',& - sw_optical_props_clrsky%alloc_2str(nday, nLev, sw_gas_props)) - - gas_concentrations_daylit%ncol = nDay - gas_concentrations_daylit%nlay = nLev - allocate(gas_concentrations_daylit%gas_name(gas_concentrations%get_num_gases())) - allocate(gas_concentrations_daylit%concs(gas_concentrations%get_num_gases())) - do iGas=1,gas_concentrations%get_num_gases() - allocate(gas_concentrations_daylit%concs(iGas)%conc(nDay, nLev)) - enddo - gas_concentrations_daylit%gas_name(:) = active_gases_array(:) - - ! Subset the gas concentrations. - do iGas=1,gas_concentrations%get_num_gases() - call check_error_msg('rrtmgp_sw_gas_optics_run_get_vmr',& - gas_concentrations%get_vmr(trim(gas_concentrations_daylit%gas_name(iGas)),vmrTemp)) - call check_error_msg('rrtmgp_sw_gas_optics_run_set_vmr',& - gas_concentrations_daylit%set_vmr(trim(gas_concentrations_daylit%gas_name(iGas)),vmrTemp(idxday(1:nday),:))) - enddo - - ! Call SW gas-optics - call check_error_msg('rrtmgp_sw_gas_optics_run',sw_gas_props%gas_optics(& - p_lay(idxday(1:nday),:), & ! IN - Pressure @ layer-centers (Pa) - p_lev(idxday(1:nday),:), & ! IN - Pressure @ layer-interfaces (Pa) - t_lay(idxday(1:nday),:), & ! IN - Temperature @ layer-centers (K) - gas_concentrations_daylit, & ! IN - RRTMGP DDT: trace gas volumne mixing-ratios - sw_optical_props_clrsky, & ! OUT - RRTMGP DDT: Shortwave optical properties, by - ! spectral point (tau,ssa,g) - toa_src_sw_temp)) ! OUT - TOA incident shortwave radiation (spectral) - toa_src_sw(idxday(1:nday),:) = toa_src_sw_temp - - ! Scale incident flux - do ij=1,nday - toa_src_sw(idxday(ij),:) = toa_src_sw(idxday(ij),:)*solcon/ & - sum(toa_src_sw(idxday(ij),:)) - enddo - endif - - end subroutine rrtmgp_sw_gas_optics_run !> @} end module rrtmgp_sw_gas_optics diff --git a/physics/rrtmgp_sw_gas_optics.meta b/physics/rrtmgp_sw_gas_optics.meta deleted file mode 100644 index 1fdbc946b..000000000 --- a/physics/rrtmgp_sw_gas_optics.meta +++ /dev/null @@ -1,201 +0,0 @@ -[ccpp-table-properties] - name = rrtmgp_sw_gas_optics - type = scheme - dependencies = machine.F,radiation_tools.F90,GFS_rrtmgp_pre.F90,rte-rrtmgp/rrtmgp/mo_gas_optics_rrtmgp.F90,rte-rrtmgp/rte/mo_rte_kind.F90,rte-rrtmgp/rrtmgp/mo_gas_concentrations.F90,rte-rrtmgp/rte/mo_optical_props.F90 - -######################################################################## -[ccpp-arg-table] - name = rrtmgp_sw_gas_optics_init - type = scheme -[rrtmgp_root_dir] - standard_name = directory_for_rte_rrtmgp_source_code - long_name = directory for rte+rrtmgp source code - units = none - dimensions = () - type = character - intent = in - kind = len=128 -[rrtmgp_sw_file_gas] - standard_name = filename_of_rrtmgp_shortwave_k_distribution - long_name = file containing RRTMGP SW k-distribution - units = none - dimensions = () - type = character - intent = in - kind = len=128 -[active_gases_array] - standard_name = list_of_active_gases_used_by_RRTMGP - long_name = list of active gases used by RRTMGP - units = none - dimensions = (number_of_active_gases_used_by_RRTMGP) - type = character - kind = len=* - intent = in -[mpirank] - standard_name = mpi_rank - long_name = current MPI rank - units = index - dimensions = () - type = integer - intent = in -[mpiroot] - standard_name = mpi_root - long_name = master MPI rank - units = index - dimensions = () - type = integer - intent = in -[mpicomm] - standard_name = mpi_communicator - long_name = MPI communicator - units = index - dimensions = () - type = integer - intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - -######################################################################## -[ccpp-arg-table] - name = rrtmgp_sw_gas_optics_run - type = scheme -[doSWrad] - standard_name = flag_for_calling_shortwave_radiation - long_name = flag to calculate SW irradiances - units = flag - dimensions = () - type = logical - intent = in -[ncol] - standard_name = horizontal_loop_extent - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in -[nLev] - standard_name = vertical_layer_dimension - long_name = number of vertical levels - units = count - dimensions = () - type = integer - intent = in -[nday] - standard_name = daytime_points_dimension - long_name = daytime points dimension - units = count - dimensions = () - type = integer - intent = in -[idxday] - standard_name = daytime_points - long_name = daytime points - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = in -[ngptsGPsw] - standard_name = number_of_shortwave_spectral_points - long_name = number of spectral points in RRTMGP SW calculation - units = count - dimensions = () - type = integer - intent = in -[p_lay] - standard_name = air_pressure_at_layer_for_RRTMGP - long_name = air pressure layer - units = Pa - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[p_lev] - standard_name = air_pressure_at_interface_for_RRTMGP - long_name = air pressure level - units = Pa - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = in -[t_lay] - standard_name = air_temperature_at_layer_for_RRTMGP - long_name = air temperature layer - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[t_lev] - standard_name = air_temperature_at_interface_for_RRTMGP - long_name = air temperature level - units = K - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = in -[toa_src_sw] - standard_name = toa_incident_sw_flux_by_spectral_point - long_name = TOA shortwave incident flux at each spectral points - units = W m-2 - dimensions = (horizontal_loop_extent,number_of_shortwave_spectral_points) - type = real - kind = kind_phys - intent = out -[active_gases_array] - standard_name = list_of_active_gases_used_by_RRTMGP - long_name = list of active gases used by RRTMGP - units = none - dimensions = (number_of_active_gases_used_by_RRTMGP) - type = character - kind = len=* - intent = in -[gas_concentrations] - standard_name = Gas_concentrations_for_RRTMGP_suite - long_name = DDT containing gas concentrations for RRTMGP radiation scheme - units = DDT - dimensions = () - type = ty_gas_concs - intent = inout -[solcon] - standard_name = solar_constant - long_name = solar constant - units = W m-2 - dimensions = () - type = real - kind = kind_phys - intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out -[sw_optical_props_clrsky] - standard_name = shortwave_optical_properties_for_clear_sky - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = out diff --git a/physics/rrtmgp_sw_main.F90 b/physics/rrtmgp_sw_main.F90 new file mode 100644 index 000000000..b25e093e7 --- /dev/null +++ b/physics/rrtmgp_sw_main.F90 @@ -0,0 +1,683 @@ +! ########################################################################################### +! ########################################################################################### +module rrtmgp_sw_main + use machine, only: kind_phys, kind_dbl_prec + use mo_optical_props, only: ty_optical_props_2str + use mo_cloud_optics, only: ty_cloud_optics + use module_radsw_parameters, only: cmpfsw_type + use mo_rte_sw, only: rte_sw + use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp + use mo_gas_concentrations, only: ty_gas_concs + use mo_fluxes_byband, only: ty_fluxes_byband + use radiation_tools, only: check_error_msg + use rrtmgp_sw_gas_optics, only: sw_gas_props,rrtmgp_sw_gas_optics_init + use rrtmgp_sw_cloud_optics, only: sw_cloud_props, rrtmgp_sw_cloud_optics_init, a0r, a0s, & + a1s, b0r, b0s, b1s, c0r, c0s + use GFS_rrtmgp_pre, only: iStr_h2o, iStr_co2, iStr_o3, iStr_n2o, iStr_ch4, & + iStr_o2, iStr_ccl4, iStr_cfc11, iStr_cfc12, iStr_cfc22, & + eps, oneminus, ftiny + use mersenne_twister, only: random_setseed, random_number, random_stat + use rrtmgp_sampling, only: sampled_mask, draw_samples + implicit none + + type(ty_gas_concs) :: gas_concs + type(ty_optical_props_2str) :: sw_optical_props_accum, sw_optical_props_aerosol_local, & + sw_optical_props_cloudsByBand, sw_optical_props_cnvcloudsByBand, & + sw_optical_props_pblcloudsByBand, sw_optical_props_precipByBand, & + sw_optical_props_clouds + + public rrtmgp_sw_main_init, rrtmgp_sw_main_run + +contains + + ! ######################################################################################### + ! SUBROUTINE rrtmgp_sw_main_init + ! ######################################################################################### +!! \section arg_table_rrtmgp_sw_main_init +!! \htmlinclude rrtmgp_sw_main_init.html +!! + subroutine rrtmgp_sw_main_init(rrtmgp_root_dir, rrtmgp_sw_file_gas, rrtmgp_sw_file_clouds,& + active_gases_array, doGP_cldoptics_PADE, doGP_cldoptics_LUT, doGP_sgs_pbl, & + doGP_sgs_cnv, nrghice, mpicomm, mpirank, mpiroot, nLay, rrtmgp_phys_blksz, & + errmsg, errflg) + + ! Inputs + character(len=128),intent(in) :: & + rrtmgp_root_dir, & ! RTE-RRTMGP root directory + rrtmgp_sw_file_clouds, & ! RRTMGP file containing K-distribution data + rrtmgp_sw_file_gas ! RRTMGP file containing cloud-optics data + character(len=*), dimension(:), intent(in) :: & + active_gases_array ! List of active gases from namelist as array) + logical, intent(in) :: & + doGP_cldoptics_PADE, & ! Use RRTMGP cloud-optics: PADE approximation? + doGP_cldoptics_LUT, & ! Use RRTMGP cloud-optics: LUTs? + doGP_sgs_pbl, & ! Flag to include sgs PBL clouds + doGP_sgs_cnv ! Flag to include sgs convective clouds + integer, intent(inout) :: & + nrghice ! Number of ice-roughness categories + integer,intent(in) :: & + mpicomm, & ! MPI communicator + mpirank, & ! Current MPI rank + mpiroot, & ! Master MPI rank + rrtmgp_phys_blksz, & ! Number of horizontal points to process at once. + nLay + ! Outputs + character(len=*), intent(out) :: & + errmsg ! CCPP error message + integer, intent(out) :: & + errflg ! CCPP error code + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! RRTMGP shortwave gas-optics (k-distribution) initialization + call rrtmgp_sw_gas_optics_init(rrtmgp_root_dir, rrtmgp_sw_file_gas, active_gases_array,& + mpicomm, mpirank, mpiroot, errmsg, errflg) + + ! RRTMGP shortwave cloud-optics initialization + call rrtmgp_sw_cloud_optics_init(rrtmgp_root_dir, rrtmgp_sw_file_clouds, & + doGP_cldoptics_PADE, doGP_cldoptics_LUT, nrghice, mpicomm, mpirank, mpiroot, & + errmsg, errflg) + + ! DDTs + + ! ty_gas_concs + call check_error_msg('rrtmgp_sw_main_gas_concs_init',gas_concs%init(active_gases_array)) + + ! ty_optical_props + call check_error_msg('rrtmgp_sw_main_accumulated_optics_init',& + sw_optical_props_accum%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props)) + call check_error_msg('rrtmgp_sw_main_cloud_optics_init',& + sw_optical_props_cloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) + call check_error_msg('rrtmgp_sw_main_precip_optics_init',& + sw_optical_props_precipByBand%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) + call check_error_msg('rrtmgp_sw_mian_cloud_sampling_init', & + sw_optical_props_clouds%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props)) + call check_error_msg('rrtmgp_sw_main_aerosol_optics_init',& + sw_optical_props_aerosol_local%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) + if (doGP_sgs_cnv) then + call check_error_msg('rrtmgp_sw_main_cnv_cloud_optics_init',& + sw_optical_props_cnvcloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) + endif + if (doGP_sgs_pbl) then + call check_error_msg('rrtmgp_sw_main_pbl_cloud_optics_init',& + sw_optical_props_pblcloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) + endif + end subroutine rrtmgp_sw_main_init + + ! ######################################################################################### + ! SUBROUTINE rrtmgp_sw_main_run + ! ######################################################################################### +!! \section arg_table_rrtmgp_sw_main_run +!! \htmlinclude rrtmgp_sw_main_run.html +!! + subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_sgs_pbl, & + nCol, nDay, nLay, nGases, rrtmgp_phys_blksz, idx, icseed_sw, iovr, iovr_convcld, & + iovr_max, iovr_maxrand, iovr_rand, iovr_dcorr, iovr_exp, iovr_exprand, isubc_sw, & + iSFC, sfc_alb_nir_dir, sfc_alb_nir_dif, sfc_alb_uvvis_dir, sfc_alb_uvvis_dif, coszen,& + p_lay, p_lev, t_lay, t_lev, vmr_o2, vmr_h2o, vmr_o3, vmr_ch4, vmr_n2o, vmr_co2, & + cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, & + cld_rerain, precip_frac, cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, cld_cnv_reice, & + cld_pbl_lwp, cld_pbl_reliq, cld_pbl_iwp, cld_pbl_reice, cloud_overlap_param, & + active_gases_array, aersw_tau, aersw_ssa, aersw_g, solcon, scmpsw, & + fluxswUP_allsky, fluxswDOWN_allsky, fluxswUP_clrsky, fluxswDOWN_clrsky, cldtausw, & + errmsg, errflg) + + ! Inputs + logical, intent(in) :: & + doSWrad, & ! Flag to perform shortwave calculation + doSWclrsky, & ! Flag to compute clear-sky fluxes + top_at_1, & ! Flag for vertical ordering convention + doGP_sgs_pbl, & ! Flag to include sgs PBL clouds + doGP_sgs_cnv ! Flag to include sgs convective clouds + integer,intent(in) :: & + nCol, & ! Number of horizontal points + nDay, & ! Number of daytime points + nLay, & ! Number of vertical grid points. + nGases, & ! Number of active gases + rrtmgp_phys_blksz, & ! Number of horizontal points to process at once. + iovr, & ! Choice of cloud-overlap method + iovr_convcld, & ! Choice of convective cloud-overlap + iovr_max, & ! Flag for maximum cloud overlap method + iovr_maxrand, & ! Flag for maximum-random cloud overlap method + iovr_rand, & ! Flag for random cloud overlap method + iovr_dcorr, & ! Flag for decorrelation-length cloud overlap method + iovr_exp, & ! Flag for exponential cloud overlap method + iovr_exprand, & ! Flag for exponential-random cloud overlap method + isubc_sw, & ! + iSFC + integer,intent(in),dimension(:) :: & + idx, & ! Index array for daytime points + icseed_sw ! Seed for random number generation for shortwave radiation + real(kind_phys), dimension(:), intent(in) :: & + sfc_alb_nir_dir, & ! Surface albedo (direct) + sfc_alb_nir_dif, & ! Surface albedo (diffuse) + sfc_alb_uvvis_dir, & ! Surface albedo (direct) + sfc_alb_uvvis_dif, & ! Surface albedo (diffuse) + coszen ! Cosize of SZA + real(kind_phys), dimension(:,:), intent(in) :: & + p_lay, & ! Pressure @ model layer-centers (Pa) + t_lay, & ! Temperature (K) + p_lev, & ! Pressure @ model layer-interfaces (Pa) + t_lev, & ! Temperature @ model levels (K) + vmr_o2, & ! Molar-mixing ratio oxygen + vmr_h2o, & ! Molar-mixing ratio water vapor + vmr_o3, & ! Molar-mixing ratio ozone + vmr_ch4, & ! Molar-mixing ratio methane + vmr_n2o, & ! Molar-mixing ratio nitrous oxide + vmr_co2, & ! Molar-mixing ratio carbon dioxide + cld_frac, & ! Cloud-fraction for stratiform clouds + cld_lwp, & ! Water path for stratiform liquid cloud-particles + cld_reliq, & ! Effective radius for stratiform liquid cloud-particles + cld_iwp, & ! Water path for stratiform ice cloud-particles + cld_reice, & ! Effective radius for stratiform ice cloud-particles + cld_swp, & ! Water path for snow hydrometeors + cld_resnow, & ! Effective radius for snow hydrometeors + cld_rwp, & ! Water path for rain hydrometeors + cld_rerain, & ! Effective radius for rain hydrometeors + precip_frac, & ! Precipitation fraction + cld_cnv_lwp, & ! Water path for convective liquid cloud-particles + cld_cnv_reliq, & ! Effective radius for convective liquid cloud-particles + cld_cnv_iwp, & ! Water path for convective ice cloud-particles + cld_cnv_reice, & ! Effective radius for convective ice cloud-particles + cld_pbl_lwp, & ! Water path for PBL liquid cloud-particles + cld_pbl_reliq, & ! Effective radius for PBL liquid cloud-particles + cld_pbl_iwp, & ! Water path for PBL ice cloud-particles + cld_pbl_reice, & ! Effective radius for PBL ice cloud-particles + cloud_overlap_param ! + real(kind_phys), dimension(:,:,:), intent(in) :: & + aersw_tau, & ! Aerosol optical depth + aersw_ssa, & ! Aerosol single scattering albedo + aersw_g ! Aerosol asymmetry paramter + character(len=*), dimension(:), intent(in) :: & + active_gases_array ! List of active gases from namelist as array + real(kind_phys), intent(in) :: & + solcon ! Solar constant + + ! Outputs + character(len=*), intent(out) :: & + errmsg ! CCPP error message + integer, intent(out) :: & + errflg ! CCPP error flag + real(kind_phys), dimension(:,:), intent(inout) :: & + cldtausw ! Approx 10.mu band layer cloud optical depth + real(kind_phys), dimension(:,:), intent(inout) :: & + fluxswUP_allsky, & ! RRTMGP upward all-sky flux profiles (W/m2) + fluxswDOWN_allsky, & ! RRTMGP downward all-sky flux profiles (W/m2) + fluxswUP_clrsky, & ! RRTMGP upward clear-sky flux profiles (W/m2) + fluxswDOWN_clrsky ! RRTMGP downward clear-sky flux profiles (W/m2) + type(cmpfsw_type), dimension(:), intent(inout) :: & + scmpsw ! 2D surface fluxes, components: + ! uvbfc - total sky downward uv-b flux (W/m2) + ! uvbf0 - clear sky downward uv-b flux (W/m2) + ! nirbm - downward nir direct beam flux (W/m2) + ! nirdf - downward nir diffused flux (W/m2) + ! visbm - downward uv+vis direct beam flux (W/m2) + ! visdf - downward uv+vis diffused flux (W/m2) + + ! Local variables + type(cmpfsw_type), dimension(rrtmgp_phys_blksz) :: scmpsw_clrsky, scmpsw_allsky + type(ty_fluxes_byband) :: flux_allsky, flux_clrsky + real(kind_phys) :: tau_rain, tau_snow, ssa_rain, ssa_snow, asy_rain, asy_snow, & + tau_prec, asy_prec, ssa_prec, asyw, ssaw, za1, za2, flux_dir, flux_dif + real(kind_phys), dimension(rrtmgp_phys_blksz) :: zcf0, zcf1 + real(kind_dbl_prec), dimension(sw_gas_props%get_ngpt()) :: rng1D + real(kind_dbl_prec), dimension(sw_gas_props%get_ngpt(),nLay,rrtmgp_phys_blksz) :: rng3D,rng3D2 + real(kind_dbl_prec), dimension(sw_gas_props%get_ngpt()*nLay) :: rng2D + logical, dimension(rrtmgp_phys_blksz,nLay,sw_gas_props%get_ngpt()) :: maskMCICA + logical :: cloudy_column, clear_column + real(kind_phys), dimension(sw_gas_props%get_nband(),rrtmgp_phys_blksz) :: & + sfc_alb_dir, sfc_alb_dif + real(kind_phys), dimension(rrtmgp_phys_blksz,nLay+1,sw_gas_props%get_nband()),target :: & + fluxSW_up_allsky, fluxSW_up_clrsky, fluxSW_dn_dir_clrsky, fluxSW_dn_allsky, & + fluxSW_dn_clrsky, fluxSW_dn_dir_allsky + integer :: iBand, ibd, ibd_uv, iCol, iGas, iLay, ix, ix2, iblck + integer, dimension(rrtmgp_phys_blksz) :: ipseed_sw, iCols + type(random_stat) :: rng_stat + real(kind_phys), dimension(2,sw_gas_props%get_nband()) :: bandlimits + real(kind_phys), dimension(2), parameter :: & + nIR_uvvis_bnd = (/12850,16000/), & + uvb_bnd = (/29000,38000/) + real(kind_phys), dimension(rrtmgp_phys_blksz,sw_gas_props%get_ngpt()) :: toa_src_sw + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (.not. doSWrad) return + + if (nDay .gt. 0) then + + bandlimits = sw_gas_props%get_band_lims_wavenumber() + ! ###################################################################################### + ! + ! Loop over all (daylit) columns... + ! + ! ###################################################################################### + do iCol=1,nDay,rrtmgp_phys_blksz + !ix = idx(iCol) + !ix2 = idx(iCol + rrtmgp_phys_blksz - 1) + iCols = idx(iCol:iCol + rrtmgp_phys_blksz - 1) + + ! Create clear/cloudy indicator + zcf0(:) = 1._kind_phys + zcf1(:) = 1._kind_phys + do iblck = 1, rrtmgp_phys_blksz + do iLay=1,nLay + zcf0(iblck) = min(zcf0(iblck), 1._kind_phys - cld_frac(iCols(iblck),iLay)) + enddo + if (zcf0(iblck) <= ftiny) zcf0(iblck) = 0._kind_phys + if (zcf0(iblck) > oneminus) zcf0(iblck) = 1._kind_phys + zcf1(iblck) = 1._kind_phys - zcf0(iblck) + enddo + cloudy_column = any(zcf1 .gt. eps) + clear_column = .true. + if (cloudy_column) clear_column = .false. + + ! ################################################################################### + ! + ! Initialize/reset + ! + ! ################################################################################### + sw_optical_props_clouds%tau = 0._kind_phys + sw_optical_props_clouds%ssa = 0._kind_phys + sw_optical_props_clouds%g = 0._kind_phys + sw_optical_props_accum%tau = 0._kind_phys + sw_optical_props_accum%ssa = 0._kind_phys + sw_optical_props_accum%g = 0._kind_phys + sw_optical_props_cloudsByBand%tau = 0._kind_phys + sw_optical_props_cloudsByBand%ssa = 0._kind_phys + sw_optical_props_cloudsByBand%g = 0._kind_phys + sw_optical_props_precipByBand%tau = 0._kind_phys + sw_optical_props_precipByBand%ssa = 0._kind_phys + sw_optical_props_precipByBand%g = 0._kind_phys + if (doGP_sgs_cnv) then + sw_optical_props_cnvcloudsByBand%tau = 0._kind_phys + sw_optical_props_cnvcloudsByBand%ssa = 0._kind_phys + sw_optical_props_cnvcloudsByBand%g = 0._kind_phys + endif + if (doGP_sgs_pbl) then + sw_optical_props_pblcloudsByBand%tau = 0._kind_phys + sw_optical_props_pblcloudsByBand%ssa = 0._kind_phys + sw_optical_props_pblcloudsByBand%g = 0._kind_phys + endif + scmpsw_clrsky= cmpfsw_type( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 ) + scmpsw_allsky= cmpfsw_type( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 ) + cldtausw = 0._kind_phys + + ! ty_fluxes_byband + fluxSW_up_allsky = 0._kind_phys + fluxSW_dn_allsky = 0._kind_phys + fluxSW_dn_dir_allsky = 0._kind_phys + fluxSW_up_clrsky = 0._kind_phys + fluxSW_dn_clrsky = 0._kind_phys + flux_allsky%bnd_flux_up => fluxSW_up_allsky + flux_allsky%bnd_flux_dn => fluxSW_dn_allsky + flux_allsky%bnd_flux_dn_dir => fluxSW_dn_dir_allsky + flux_clrsky%bnd_flux_up => fluxSW_up_clrsky + flux_clrsky%bnd_flux_dn => fluxSW_dn_clrsky + + ! ################################################################################### + ! + ! Set gas-concentrations + ! + ! ################################################################################### + call check_error_msg('rrtmgp_sw_main_set_vmr_o2', & + gas_concs%set_vmr(trim(active_gases_array(istr_o2)), vmr_o2(iCols,:))) + call check_error_msg('rrtmgp_sw_main_set_vmr_co2', & + gas_concs%set_vmr(trim(active_gases_array(istr_co2)),vmr_co2(iCols,:))) + call check_error_msg('rrtmgp_sw_main_set_vmr_ch4', & + gas_concs%set_vmr(trim(active_gases_array(istr_ch4)),vmr_ch4(iCols,:))) + call check_error_msg('rrtmgp_sw_main_set_vmr_n2o', & + gas_concs%set_vmr(trim(active_gases_array(istr_n2o)),vmr_n2o(iCols,:))) + call check_error_msg('rrtmgp_sw_main_set_vmr_h2o', & + gas_concs%set_vmr(trim(active_gases_array(istr_h2o)),vmr_h2o(iCols,:))) + call check_error_msg('rrtmgp_sw_main_set_vmr_o3', & + gas_concs%set_vmr(trim(active_gases_array(istr_o3)), vmr_o3(iCols,:))) + + ! ################################################################################### + ! + ! Compute gas-optics + ! + ! ################################################################################### + + call check_error_msg('rrtmgp_sw_main_gas_optics',sw_gas_props%gas_optics(& + p_lay(iCols,:), & ! IN - Pressure @ layer-centers (Pa) + p_lev(iCols,:), & ! IN - Pressure @ layer-interfaces (Pa) + t_lay(iCols,:), & ! IN - Temperature @ layer-centers (K) + gas_concs, & ! IN - RRTMGP DDT: trace gas volumne mixing-ratios + sw_optical_props_accum, & ! OUT - RRTMGP DDT: Shortwave optical properties, by + ! spectral point (tau,ssa,g) + toa_src_sw)) ! OUT - TOA incident shortwave radiation (spectral) + ! Scale incident flux + do iblck = 1, rrtmgp_phys_blksz + toa_src_sw(iblck,:) = toa_src_sw(iblck,:)*solcon / sum(toa_src_sw(iblck,:)) + enddo + + ! ################################################################################### + ! + ! Set surface albedo + ! + ! Use near-IR albedo for bands with wavenumbers extending to 12850cm-1 + ! Use uv-vis albedo for bands with wavenumbers greater than 16000cm-1 + ! For overlapping band, average near-IR and us-vis albedos. + ! + ! ################################################################################### + do iblck = 1, rrtmgp_phys_blksz + do iBand=1,sw_gas_props%get_nband() + if (bandlimits(1,iBand) .lt. nIR_uvvis_bnd(1)) then + sfc_alb_dir(iBand,iblck) = sfc_alb_nir_dir(iCols(iblck)) + sfc_alb_dif(iBand,iblck) = sfc_alb_nir_dif(iCols(iblck)) + endif + if (bandlimits(1,iBand) .eq. nIR_uvvis_bnd(1)) then + sfc_alb_dir(iBand,iblck) = 0.5_kind_phys*(sfc_alb_nir_dir(iCols(iblck)) + & + sfc_alb_uvvis_dir(iCols(iblck))) + sfc_alb_dif(iBand,iblck) = 0.5_kind_phys*(sfc_alb_nir_dif(iCols(iblck)) + & + sfc_alb_uvvis_dif(iCols(iblck))) + ibd = iBand + endif + if (bandlimits(1,iBand) .ge. nIR_uvvis_bnd(2)) then + sfc_alb_dir(iBand,iblck) = sfc_alb_uvvis_dir(iCols(iblck)) + sfc_alb_dif(iBand,iblck) = sfc_alb_uvvis_dif(iCols(iblck)) + endif + if (bandlimits(1,iBand) .eq. uvb_bnd(1)) ibd_uv = iBand + enddo + enddo + + ! ################################################################################### + ! + ! Compute optics for cloud(s) and precipitation, sample clouds... + ! + ! ################################################################################### + if (cloudy_column) then + ! Gridmean/mp-clouds + call check_error_msg('rrtmgp_sw_main_cloud_optics',sw_cloud_props%cloud_optics(& + cld_lwp(iCols,:), & ! IN - Cloud liquid water path + cld_iwp(iCols,:), & ! IN - Cloud ice water path + cld_reliq(iCols,:), & ! IN - Cloud liquid effective radius + cld_reice(iCols,:), & ! IN - Cloud ice effective radius + sw_optical_props_cloudsByBand)) ! OUT - RRTMGP DDT: Shortwave optical properties, + ! in each band (tau,ssa,g) + cldtausw(iCols,:) = sw_optical_props_cloudsByBand%tau(:,:,11) + + ! Include convective clouds? + if (doGP_sgs_cnv) then + ! Compute + call check_error_msg('rrtmgp_sw_main_cnv_cloud_optics',sw_cloud_props%cloud_optics(& + cld_cnv_lwp(iCols,:), & ! IN - Convective cloud liquid water path (g/m2) + cld_cnv_iwp(iCols,:), & ! IN - Convective cloud ice water path (g/m2) + cld_cnv_reliq(iCols,:), & ! IN - Convective cloud liquid effective radius (microns) + cld_cnv_reice(iCols,:), & ! IN - Convective cloud ice effective radius (microns) + sw_optical_props_cnvcloudsByBand)) ! OUT - RRTMGP DDT containing convective cloud radiative properties + ! in each band + ! Increment + call check_error_msg('rrtmgp_sw_main_increment_cnvclouds_to_clouds',& + sw_optical_props_cnvcloudsByBand%increment(sw_optical_props_cloudsByBand)) + endif + + ! Include PBL clouds? + if (doGP_sgs_pbl) then + ! Compute + call check_error_msg('rrtmgp_sw_main_pbl_cloud_optics',sw_cloud_props%cloud_optics(& + cld_pbl_lwp(iCols,:), & ! IN - PBL cloud liquid water path (g/m2) + cld_pbl_iwp(iCols,:), & ! IN - PBL cloud ice water path (g/m2) + cld_pbl_reliq(iCols,:), & ! IN - PBL cloud liquid effective radius (microns) + cld_pbl_reice(iCols,:), & ! IN - PBL cloud ice effective radius (microns) + sw_optical_props_pblcloudsByBand)) ! OUT - RRTMGP DDT containing PBL cloud radiative properties + ! in each band + ! Increment + call check_error_msg('rrtmgp_sw_main_increment_pblclouds_to_clouds',& + sw_optical_props_pblcloudsByBand%increment(sw_optical_props_cloudsByBand)) + endif + + ! Cloud precipitation optics: rain and snow(+groupel) + do iblck = 1, rrtmgp_phys_blksz + do iLay=1,nLay + if (cld_frac(iCols(iblck),iLay) .gt. ftiny) then + ! Rain/Snow optical depth (No band dependence) + tau_rain = cld_rwp(iCols(iblck),iLay)*a0r + if (cld_swp(iCols(iblck),iLay) .gt. 0. .and. cld_resnow(iCols(iblck),iLay) .gt. 10._kind_phys) then + tau_snow = cld_swp(iCols(iblck),iLay)*1.09087*(a0s + a1s/(1.0315*cld_resnow(iCols(iblck),iLay))) ! fu's formula + else + tau_snow = 0._kind_phys + endif + + ! Rain/Snow single-scattering albedo and asymmetry (Band dependent) + do iBand=1,sw_gas_props%get_nband() + ! By species + ssa_rain = tau_rain*(1.-b0r(iBand)) + asy_rain = ssa_rain*c0r(iBand) + ssa_snow = tau_snow*(1.-(b0s(iBand)+b1s(iBand)*1.0315*cld_resnow(iCols(iblck),iLay))) + asy_snow = ssa_snow*c0s(iBand) + ! Combine + tau_prec = max(1.e-12_kind_phys, tau_rain + tau_snow) + ssa_prec = max(1.e-12_kind_phys, ssa_rain + ssa_snow) + asy_prec = max(1.e-12_kind_phys, asy_rain + asy_snow) + asyw = asy_prec/max(1.e-12_kind_phys, ssa_prec) + ssaw = min(1._kind_phys-0.000001, ssa_prec/tau_prec) + za1 = asyw * asyw + za2 = ssaw * za1 + sw_optical_props_precipByBand%tau(iblck,iLay,iBand) = (1._kind_phys - za2) * tau_prec + sw_optical_props_precipByBand%ssa(iblck,iLay,iBand) = (ssaw - za2) / (1._kind_phys - za2) + sw_optical_props_precipByBand%g(iblck,iLay,iBand) = asyw/(1+asyw) + enddo + endif + enddo + enddo + ! Increment + call check_error_msg('rrtmgp_sw_main_increment_precip_to_clouds',& + sw_optical_props_precipByBand%increment(sw_optical_props_cloudsByBand)) + + ! ################################################################################### + ! + ! Cloud-sampling + ! + ! ################################################################################### + ! Change random number seed value for each radiation invocation (isubc_sw =1 or 2). + if(isubc_sw == 1) then ! advance prescribed permutation seed + do iblck = 1, rrtmgp_phys_blksz + ipseed_sw(iblck) = sw_gas_props%get_ngpt() + iCols(iblck) + enddo + elseif (isubc_sw == 2) then ! use input array of permutaion seeds + do iblck = 1, rrtmgp_phys_blksz + ipseed_sw(iblck) = icseed_sw(iCols(iblck)) + enddo + endif + + ! Call RNG + do iblck = 1, rrtmgp_phys_blksz + call random_setseed(ipseed_sw(iblck),rng_stat) + ! Use same rng for each layer + if (iovr == iovr_max) then + call random_number(rng1D,rng_stat) + do iLay=1,nLay + rng3D(:,iLay,iblck) = rng1D + enddo + else + do iLay=1,nLay + call random_number(rng1D,rng_stat) + rng3D(:,iLay,iblck) = rng1D + enddo + endif + enddo + + ! Cloud-overlap. + ! Maximum-random, random or maximum. + if (iovr == iovr_maxrand .or. iovr == iovr_rand .or. iovr == iovr_max) then + call sampled_mask(real(rng3D, kind=kind_phys), cld_frac(iCols,:), maskMCICA) + endif + ! Exponential decorrelation length overlap + if (iovr == iovr_dcorr) then + do iblck = 1, rrtmgp_phys_blksz + ! Generate second RNG + call random_setseed(ipseed_sw(iblck),rng_stat) + call random_number(rng2D,rng_stat) + rng3D2(:,:,iblck) = reshape(source = rng2D,shape=[sw_gas_props%get_ngpt(),nLay]) + enddo + ! + call sampled_mask(real(rng3D, kind=kind_phys), cld_frac(iCols,:), maskMCICA, & + overlap_param = cloud_overlap_param(iCols,1:nLay-1), randoms2 = real(rng3D2, kind=kind_phys)) + endif + ! Exponential or Exponential-random + if (iovr == iovr_exp .or. iovr == iovr_exprand) then + call sampled_mask(real(rng3D, kind=kind_phys), cld_frac(iCols,:), maskMCICA, & + overlap_param = cloud_overlap_param(iCols,1:nLay-1)) + endif + ! Sampling. Map band optical depth to each g-point using McICA + call check_error_msg('rrtmgp_sw_main_cloud_sampling',& + draw_samples(maskMCICA, .true., & + sw_optical_props_cloudsByBand, sw_optical_props_clouds)) + endif ! cloudy_column + + ! ################################################################################### + ! + ! Compute clear-sky fluxes (gaseous+aerosol) + ! + ! ################################################################################### + ! Increment optics (always) + sw_optical_props_aerosol_local%tau = aersw_tau(iCols,:,:) + sw_optical_props_aerosol_local%ssa = aersw_ssa(iCols,:,:) + sw_optical_props_aerosol_local%g = aersw_g(iCols,:,:) + call check_error_msg('rrtmgp_sw_main_increment_aerosol_to_clrsky', & + sw_optical_props_aerosol_local%increment(sw_optical_props_accum)) + + ! Compute clear-sky fluxes (Yes for no-clouds. Optional for cloudy scenes) + if (clear_column .or. doSWclrsky) then + call check_error_msg('rrtmgp_sw_main_rte_sw_clrsky',rte_sw( & + sw_optical_props_accum, & ! IN - optical-properties + top_at_1, & ! IN - veritcal ordering flag + coszen(iCols), & ! IN - Cosine of solar zenith angle + toa_src_sw, & ! IN - incident solar flux at TOA + sfc_alb_dir, & ! IN - Shortwave surface albedo (direct) + sfc_alb_dif, & ! IN - Shortwave surface albedo (diffuse) + flux_clrsky)) ! OUT - Fluxes, clear-sky, 3D (1,nLay,nBand) + + ! Store fluxes + fluxswUP_clrsky(iCols,:) = sum(flux_clrsky%bnd_flux_up, dim=3) + fluxswDOWN_clrsky(iCols,:) = sum(flux_clrsky%bnd_flux_dn, dim=3) + + ! Compute surface downward beam/diffused flux components + do iblck = 1, rrtmgp_phys_blksz + do iBand=1,sw_gas_props%get_nband() + flux_dir = flux_clrsky%bnd_flux_dn(iblck,iSFC,iBand) + flux_dif = 0._kind_phys + ! Near-IR bands + if (iBand < ibd) then + scmpsw_clrsky(iblck)%nirbm = scmpsw_clrsky(iblck)%nirbm + flux_dir + scmpsw_clrsky(iblck)%nirdf = scmpsw_clrsky(iblck)%nirdf + flux_dif + endif + ! Transition band + if (iBand == ibd) then + scmpsw_clrsky(iblck)%nirbm = scmpsw_clrsky(iblck)%nirbm + flux_dir*0.5_kind_phys + scmpsw_clrsky(iblck)%nirdf = scmpsw_clrsky(iblck)%nirdf + flux_dif*0.5_kind_phys + scmpsw_clrsky(iblck)%visbm = scmpsw_clrsky(iblck)%visbm + flux_dir*0.5_kind_phys + scmpsw_clrsky(iblck)%visdf = scmpsw_clrsky(iblck)%visdf + flux_dif*0.5_kind_phys + endif + ! UV-VIS bands + if (iBand > ibd) then + scmpsw_clrsky(iblck)%visbm = scmpsw_clrsky(iblck)%visbm + flux_dir + scmpsw_clrsky(iblck)%visdf = scmpsw_clrsky(iblck)%visdf + flux_dif + endif + ! uv-b surface downward flux + scmpsw_clrsky(iblck)%uvbfc = flux_clrsky%bnd_flux_dn(iblck,iSFC,ibd_uv) + enddo + enddo + else + fluxswUP_clrsky(iCols,:) = 0._kind_phys + fluxswDOWN_clrsky(iCols,:) = 0._kind_phys + scmpsw = cmpfsw_type( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 ) + endif + + ! ################################################################################### + ! + ! All-sky fluxes (clear-sky + clouds + precipitation) + ! + ! ################################################################################### + if (cloudy_column) then + ! Delta scale + !call check_error_msg('rrtmgp_sw_main_delta_scale',sw_optical_props_clouds%delta_scale()) + + ! Increment + call check_error_msg('rrtmgp_sw_main_increment_clouds_to_clrsky', & + sw_optical_props_clouds%increment(sw_optical_props_accum)) + + ! Compute fluxes + call check_error_msg('rrtmgp_sw_main_rte_sw_allsky',rte_sw( & + sw_optical_props_accum, & ! IN - optical-properties + top_at_1, & ! IN - veritcal ordering flag + coszen(iCols), & ! IN - Cosine of solar zenith angle + toa_src_sw, & ! IN - incident solar flux at TOA + sfc_alb_dir, & ! IN - Shortwave surface albedo (direct) + sfc_alb_dif, & ! IN - Shortwave surface albedo (diffuse) + flux_allsky)) ! OUT - Fluxes, clear-sky, 3D (1,nLay,nBand) + + ! Store fluxes + fluxswUP_allsky(iCols,:) = sum(flux_allsky%bnd_flux_up, dim=3) + fluxswDOWN_allsky(iCols,:) = sum(flux_allsky%bnd_flux_dn, dim=3) + + ! Compute and store downward beam/diffused flux components + do iblck = 1, rrtmgp_phys_blksz + ! Loop over bands, sum fluxes... + do iBand=1,sw_gas_props%get_nband() + flux_dir = flux_allsky%bnd_flux_dn_dir(iblck,iSFC,iBand) + flux_dif = flux_allsky%bnd_flux_dn(iblck,iSFC,iBand) - flux_allsky%bnd_flux_dn_dir(iblck,iSFC,iBand) + ! Near-IR bands + if (iBand < ibd) then + scmpsw_allsky(iblck)%nirbm = scmpsw_allsky(iblck)%nirbm + flux_dir + scmpsw_allsky(iblck)%nirdf = scmpsw_allsky(iblck)%nirdf + flux_dif + endif + ! Transition band + if (iBand == ibd) then + scmpsw_allsky(iblck)%nirbm = scmpsw_allsky(iblck)%nirbm + flux_dir*0.5_kind_phys + scmpsw_allsky(iblck)%nirdf = scmpsw_allsky(iblck)%nirdf + flux_dif*0.5_kind_phys + scmpsw_allsky(iblck)%visbm = scmpsw_allsky(iblck)%visbm + flux_dir*0.5_kind_phys + scmpsw_allsky(iblck)%visdf = scmpsw_allsky(iblck)%visdf + flux_dif*0.5_kind_phys + endif + ! UV-VIS bands + if (iBand > ibd) then + scmpsw_allsky(iblck)%visbm = scmpsw_allsky(iblck)%visbm + flux_dir + scmpsw_allsky(iblck)%visdf = scmpsw_allsky(iblck)%visdf + flux_dif + endif + ! uv-b surface downward flux + scmpsw_allsky(iblck)%uvbfc = flux_allsky%bnd_flux_dn(iblck,iSFC,ibd_uv) + enddo + ! Store surface downward beam/diffused flux components + if (zcf1(iblck) .gt. eps) then + scmpsw(iCols(iblck))%nirbm = scmpsw_allsky(iblck)%nirbm + scmpsw(iCols(iblck))%nirdf = scmpsw_allsky(iblck)%nirdf + scmpsw(iCols(iblck))%visbm = scmpsw_allsky(iblck)%visbm + scmpsw(iCols(iblck))%visdf = scmpsw_allsky(iblck)%visdf + scmpsw(iCols(iblck))%uvbfc = flux_allsky%bnd_flux_dn(iblck,iSFC,ibd_uv) + else + scmpsw(iCols(iblck))%nirbm = scmpsw_clrsky(iblck)%nirbm + scmpsw(iCols(iblck))%nirdf = scmpsw_clrsky(iblck)%nirdf + scmpsw(iCols(iblck))%visbm = scmpsw_clrsky(iblck)%visbm + scmpsw(iCols(iblck))%visdf = scmpsw_clrsky(iblck)%visdf + scmpsw(iCols(iblck))%uvbfc = flux_clrsky%bnd_flux_dn(iblck,iSFC,ibd_uv) + endif + scmpsw(iCols(iblck))%uvbf0 = flux_clrsky%bnd_flux_dn(iblck,iSFC,ibd_uv) + enddo + else ! No clouds + fluxswUP_allsky(iCols,:) = sum(flux_clrsky%bnd_flux_up, dim=3) + fluxswDOWN_allsky(iCols,:) = sum(flux_clrsky%bnd_flux_dn, dim=3) + do iblck = 1, rrtmgp_phys_blksz + scmpsw(iCols(iblck))%nirbm = scmpsw_clrsky(iblck)%nirbm + scmpsw(iCols(iblck))%nirdf = scmpsw_clrsky(iblck)%nirdf + scmpsw(iCols(iblck))%visbm = scmpsw_clrsky(iblck)%visbm + scmpsw(iCols(iblck))%visdf = scmpsw_clrsky(iblck)%visdf + scmpsw(iCols(iblck))%uvbfc = flux_clrsky%bnd_flux_dn(iblck,iSFC,ibd_uv) + scmpsw(iCols(iblck))%uvbf0 = flux_clrsky%bnd_flux_dn(iblck,iSFC,ibd_uv) + enddo + endif + ! + enddo ! nday + else + fluxswUP_allsky(:,:) = 0._kind_phys + fluxswDOWN_allsky(:,:) = 0._kind_phys + fluxswUP_clrsky(:,:) = 0._kind_phys + fluxswDOWN_clrsky(:,:) = 0._kind_phys + scmpsw = cmpfsw_type( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 ) + endif + end subroutine rrtmgp_sw_main_run +end module rrtmgp_sw_main diff --git a/physics/rrtmgp_sw_main.meta b/physics/rrtmgp_sw_main.meta new file mode 100644 index 000000000..4ca6cc716 --- /dev/null +++ b/physics/rrtmgp_sw_main.meta @@ -0,0 +1,664 @@ +[ccpp-table-properties] + name = rrtmgp_sw_main + type = scheme + dependencies = machine.F,radiation_tools.F90,GFS_rrtmgp_pre.F90,rte-rrtmgp/rrtmgp/mo_gas_optics_rrtmgp.F90 + dependencies = rte-rrtmgp/rte/mo_rte_kind.F90,rte-rrtmgp/rrtmgp/mo_gas_concentrations.F90,rte-rrtmgp/rte/mo_optical_props.F90 + dependencies = rte-rrtmgp/rte/mo_rte_sw.F90,rte-rrtmgp/rte/mo_fluxes.F90 + dependencies = rte-rrtmgp/rte/kernels/mo_fluxes_broadband_kernels.F90, rte-rrtmgp/rte/kernels/mo_rte_solver_kernels.F90 + dependencies = mersenne_twister.f,rrtmgp_sampling.F90,rte-rrtmgp/extensions/mo_fluxes_byband.F90 + dependencies = rrtmgp_sw_gas_optics.F90, rrtmgp_sw_cloud_optics.F90 + +######################################################################## +[ccpp-arg-table] + name = rrtmgp_sw_main_init + type = scheme +[rrtmgp_root_dir] + standard_name = directory_for_rte_rrtmgp_source_code + long_name = directory for rte+rrtmgp source code + units = none + dimensions = () + type = character + intent = in + kind = len=128 +[rrtmgp_sw_file_gas] + standard_name = filename_of_rrtmgp_shortwave_k_distribution + long_name = file containing RRTMGP SW k-distribution + units = none + dimensions = () + type = character + intent = in + kind = len=128 +[rrtmgp_sw_file_clouds] + standard_name = filename_of_rrtmgp_shortwave_cloud_optics_coefficients + long_name = file containing coefficients for RRTMGP SW cloud optics + units = none + dimensions = () + type = character + intent = in + kind = len=128 +[doGP_cldoptics_PADE] + standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_PADE + long_name = logical flag to control cloud optics scheme. + units = flag + dimensions = () + type = logical + intent = in +[doGP_cldoptics_LUT] + standard_name = flag_to_calc_lw_cld_optics_using_RRTMGP_LUT + long_name = logical flag to control cloud optics scheme. + units = flag + dimensions = () + type = logical + intent = in +[nrghice] + standard_name = number_of_ice_roughness_categories + long_name = number of ice-roughness categories in RRTMGP calculation + units = count + dimensions = () + type = integer + intent = inout +[doGP_sgs_cnv] + standard_name = flag_to_include_sgs_convective_cloud_in_RRTMGP + long_name = logical flag to control sgs convective cloud in RRTMGP + units = flag + dimensions = () + type = logical + intent = in +[doGP_sgs_pbl] + standard_name = flag_to_include_sgs_MYNN_EDMF_cloud_in_RRTMGP + long_name = logical flag to control MYNN-EDMF PBL cloud in RRTMGP + units = flag + dimensions = () + type = logical + intent = in +[rrtmgp_phys_blksz] + standard_name = number_of_columns_per_RRTMGP_SW_block + long_name = number of columns to process at a time by RRTMGP SW scheme + units = count + dimensions = () + type = integer + intent = in +[nLay] + standard_name = vertical_layer_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in +[mpirank] + standard_name = mpi_rank + long_name = current MPI rank + units = index + dimensions = () + type = integer + intent = in +[mpiroot] + standard_name = mpi_root + long_name = master MPI rank + units = index + dimensions = () + type = integer + intent = in +[mpicomm] + standard_name = mpi_communicator + long_name = MPI communicator + units = index + dimensions = () + type = integer + intent = in +[active_gases_array] + standard_name = list_of_active_gases_used_by_RRTMGP + long_name = list of active gases used by RRTMGP + units = none + dimensions = (number_of_active_gases_used_by_RRTMGP) + type = character + kind = len=* + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out + +######################################################################## +[ccpp-arg-table] + name = rrtmgp_sw_main_run + type = scheme +[doSWrad] + standard_name = flag_for_calling_shortwave_radiation + long_name = logical flags for sw radiation calls + units = flag + dimensions = () + type = logical + intent = in +[doSWclrsky] + standard_name = flag_for_output_of_tendency_of_air_temperature_due_to_shortwave_heating_on_radiation_timestep_assuming_clear_sky + long_name = flag to output sw heating rate (Radtend%swhc) + units = flag + dimensions = () + type = logical + intent = in +[top_at_1] + standard_name = flag_for_vertical_ordering_in_RRTMGP + long_name = flag for vertical ordering in RRTMGP + units = flag + dimensions = () + type = logical + intent = in +[iSFC] + standard_name = vertical_index_for_surface_in_RRTMGP + long_name = index for surface layer in RRTMGP + units = flag + dimensions = () + type = integer + intent = in +[doGP_sgs_cnv] + standard_name = flag_to_include_sgs_convective_cloud_in_RRTMGP + long_name = logical flag to control sgs convective cloud in RRTMGP + units = flag + dimensions = () + type = logical + intent = in +[doGP_sgs_pbl] + standard_name = flag_to_include_sgs_MYNN_EDMF_cloud_in_RRTMGP + long_name = logical flag to control MYNN-EDMF PBL cloud in RRTMGP + units = flag + dimensions = () + type = logical + intent = in +[ncol] + standard_name = horizontal_loop_extent + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in +[nLay] + standard_name = vertical_layer_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in +[rrtmgp_phys_blksz] + standard_name = number_of_columns_per_RRTMGP_SW_block + long_name = number of columns to process at a time by RRTMGP SW scheme + units = count + dimensions = () + type = integer + intent = in +[nGases] + standard_name = number_of_active_gases_used_by_RRTMGP + long_name = number of gases available used by RRTMGP (Model%nGases) + units = count + dimensions = () + type = integer + intent = in +[nday] + standard_name = daytime_points_dimension + long_name = daytime points dimension + units = count + dimensions = () + type = integer + intent = in +[idx] + standard_name = daytime_points + long_name = daytime points + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[coszen] + standard_name = cosine_of_solar_zenith_angle_for_daytime_points_on_radiation_timestep + long_name = mean cos of zenith angle over rad call period + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[isubc_sw] + standard_name = flag_for_sw_clouds_grid_approximation + long_name = flag for sw clouds sub-grid approximation + units = flag + dimensions = () + type = integer + intent = in +[iovr] + standard_name = flag_for_cloud_overlap_method_for_radiation + long_name = max-random overlap clouds + units = flag + dimensions = () + type = integer + intent = in +[iovr_maxrand] + standard_name = flag_for_maximum_random_cloud_overlap_method + long_name = choice of maximum-random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_dcorr] + standard_name = flag_for_decorrelation_length_cloud_overlap_method + long_name = choice of decorrelation-length cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_exp] + standard_name = flag_for_exponential_cloud_overlap_method + long_name = choice of exponential cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_exprand] + standard_name = flag_for_exponential_random_cloud_overlap_method + long_name = choice of exponential-random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_rand] + standard_name = flag_for_random_cloud_overlap_method + long_name = choice of random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_max] + standard_name = flag_for_maximum_cloud_overlap_method + long_name = choice of maximum cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_convcld] + standard_name = flag_for_convective_cloud_overlap_method_for_radiation + long_name = flag for convective cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[icseed_sw] + standard_name = random_number_seed_for_mcica_shortwave + long_name = seed for random number generation for shortwave radiation + units = none + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[p_lay] + standard_name = air_pressure_at_layer_for_RRTMGP + long_name = air pressure at vertical layer for radiation calculation + units = Pa + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[p_lev] + standard_name = air_pressure_at_interface_for_RRTMGP + long_name = air pressure at vertical interface for radiation calculation + units = Pa + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in +[t_lay] + standard_name = air_temperature_at_layer_for_RRTMGP + long_name = air temperature at vertical layer for radiation calculation + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[t_lev] + standard_name = air_temperature_at_interface_for_RRTMGP + long_name = air temperature at vertical interface for radiation calculation + units = K + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in +[vmr_o2] + standard_name = volume_mixing_ratio_for_o2 + long_name = molar mixing ratio of o2 in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[vmr_h2o] + standard_name = volume_mixing_ratio_for_h2o + long_name = molar mixing ratio of h2o in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[vmr_o3] + standard_name = volume_mixing_ratio_for_o3 + long_name = molar mixing ratio of o3 in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[vmr_ch4] + standard_name = volume_mixing_ratio_for_ch4 + long_name = molar mixing ratio of ch4 in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[vmr_n2o] + standard_name = volume_mixing_ratio_for_n2o + long_name = molar mixing ratio of n2o in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[vmr_co2] + standard_name = volume_mixing_ratio_for_co2 + long_name = molar mixing ratio of co2 in with respect to dry air + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_frac] + standard_name = total_cloud_fraction + long_name = layer total cloud fraction + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_lwp] + standard_name = cloud_liquid_water_path + long_name = layer cloud liquid water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_reliq] + standard_name = mean_effective_radius_for_liquid_cloud + long_name = mean effective radius for liquid cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_iwp] + standard_name = cloud_ice_water_path + long_name = layer cloud ice water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_reice] + standard_name = mean_effective_radius_for_ice_cloud + long_name = mean effective radius for ice cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_swp] + standard_name = cloud_snow_water_path + long_name = layer cloud snow water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_resnow] + standard_name = mean_effective_radius_for_snow_flake + long_name = mean effective radius for snow cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_rwp] + standard_name = cloud_rain_water_path + long_name = layer cloud rain water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_rerain] + standard_name = mean_effective_radius_for_rain_drop + long_name = mean effective radius for rain cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[precip_frac] + standard_name = precipitation_fraction_by_layer + long_name = precipitation fraction in each layer + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_cnv_lwp] + standard_name = convective_cloud_liquid_water_path + long_name = layer convective cloud liquid water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_cnv_iwp] + standard_name = convective_cloud_ice_water_path + long_name = layer convective cloud ice water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_cnv_reliq] + standard_name = mean_effective_radius_for_liquid_convective_cloud + long_name = mean effective radius for liquid convective cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_cnv_reice] + standard_name = mean_effective_radius_for_ice_convective_cloud + long_name = mean effective radius for ice convective cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_pbl_lwp] + standard_name = MYNN_SGS_cloud_liquid_water_path + long_name = layer convective cloud liquid water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_pbl_iwp] + standard_name = MYNN_SGS_cloud_ice_water_path + long_name = layer convective cloud ice water path + units = g m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_pbl_reliq] + standard_name = mean_effective_radius_for_liquid_MYNN_SGS_cloud + long_name = mean effective radius for liquid MYNN_SGS cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cld_pbl_reice] + standard_name = mean_effective_radius_for_ice_MYNN_SGS_cloud + long_name = mean effective radius for ice MYNN_SGS cloud + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cloud_overlap_param] + standard_name = cloud_overlap_param + long_name = cloud overlap parameter + units = km + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[sfc_alb_nir_dir] + standard_name = surface_albedo_due_to_near_IR_direct + long_name = surface albedo due to near IR direct beam + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[sfc_alb_nir_dif] + standard_name = surface_albedo_due_to_near_IR_diffused + long_name = surface albedo due to near IR diffused beam + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[sfc_alb_uvvis_dir] + standard_name = surface_albedo_due_to_UV_and_VIS_direct + long_name = surface albedo due to UV+VIS direct beam + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[sfc_alb_uvvis_dif] + standard_name = surface_albedo_due_to_UV_and_VIS_diffused + long_name = surface albedo due to UV+VIS diffused beam + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[active_gases_array] + standard_name = list_of_active_gases_used_by_RRTMGP + long_name = list of active gases used by RRTMGP + units = none + dimensions = (number_of_active_gases_used_by_RRTMGP) + type = character + kind = len=* + intent = in +[aersw_tau] + standard_name = aerosol_optical_depth_for_shortwave_bands_01_16 + long_name = aerosol optical depth for shortwave bands 01-16 + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_aerosol_bands_for_shortwave_radiation) + type = real + kind = kind_phys + intent = in +[aersw_ssa] + standard_name = aerosol_single_scattering_albedo_for_shortwave_bands_01_16 + long_name = aerosol single scattering albedo for shortwave bands 01-16 + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_aerosol_bands_for_shortwave_radiation) + type = real + kind = kind_phys + intent = in +[aersw_g] + standard_name = aerosol_asymmetry_parameter_for_shortwave_bands_01_16 + long_name = aerosol asymmetry parameter for shortwave bands 01-16 + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_aerosol_bands_for_shortwave_radiation) + type = real + kind = kind_phys + intent = in +[solcon] + standard_name = solar_constant + long_name = solar constant + units = W m-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[scmpsw] + standard_name = components_of_surface_downward_shortwave_fluxes + long_name = derived type for special components of surface downward shortwave fluxes + units = W m-2 + dimensions = (horizontal_loop_extent) + type = cmpfsw_type + intent = inout +[fluxswUP_allsky] + standard_name = RRTMGP_sw_flux_profile_upward_allsky + long_name = RRTMGP upward shortwave all-sky flux profile + units = W m-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = inout +[fluxswDOWN_allsky] + standard_name = RRTMGP_sw_flux_profile_downward_allsky + long_name = RRTMGP downward shortwave all-sky flux profile + units = W m-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = inout +[fluxswUP_clrsky] + standard_name = RRTMGP_sw_flux_profile_upward_clrsky + long_name = RRTMGP upward shortwave clr-sky flux profile + units = W m-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = inout +[fluxswDOWN_clrsky] + standard_name = RRTMGP_sw_flux_profile_downward_clrsky + long_name = RRTMGP downward shortwave clr-sky flux profile + units = W m-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = inout +[cldtausw] + standard_name = cloud_optical_depth_layers_at_0p55mu_band + long_name = approx .55mu band layer cloud optical depth + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out diff --git a/physics/rrtmgp_sw_rte.F90 b/physics/rrtmgp_sw_rte.F90 deleted file mode 100644 index 521aae2c1..000000000 --- a/physics/rrtmgp_sw_rte.F90 +++ /dev/null @@ -1,219 +0,0 @@ -!> \file rrtmgp_sw_rte.F90 -!! -!> \defgroup rrtmgp_sw_rte rrtmgp_sw_rte.F90 -!! -!! \brief This module contains the main rte shortwave driver. -module rrtmgp_sw_rte - use machine, only: kind_phys - use mo_optical_props, only: ty_optical_props_2str - use mo_rte_sw, only: rte_sw - use mo_fluxes_byband, only: ty_fluxes_byband - use module_radsw_parameters, only: cmpfsw_type - use radiation_tools, only: check_error_msg - use rrtmgp_sw_gas_optics, only: sw_gas_props - implicit none - - public rrtmgp_sw_rte_run - -contains -!>\defgroup rrtmgp_sw_rte_mod GFS RRTMGP-SW RTE Module -!> \section arg_table_rrtmgp_sw_rte_run -!! \htmlinclude rrtmgp_sw_rte.html -!! -!> \ingroup rrtmgp_sw_rte -!! -!! \brief This routine takes all of the shortwave optical properties ,ty_optical_props_2str, -!! and computes the shortwave radiative fluxes for cloudy and clear-sky conditions. -!! -!! \section rrtmgp_sw_rte_run Main Driver -!> @{ - ! ###################################################################################### - subroutine rrtmgp_sw_rte_run(doSWrad, doSWclrsky, nCol, nLev, nDay, idxday, coszen, p_lay,& - t_lay, top_at_1, doGP_sgs_cnv, doGP_sgs_mynn, iSFC, sfc_alb_nir_dir, sfc_alb_nir_dif,& - sfc_alb_uvvis_dir, sfc_alb_uvvis_dif, toa_src_sw, sw_optical_props_clrsky, & - sw_optical_props_clouds, sw_optical_props_precipByBand, & - sw_optical_props_cnvcloudsByBand, sw_optical_props_MYNNcloudsByBand, & - sw_optical_props_aerosol, scmpsw, fluxswUP_allsky, fluxswDOWN_allsky, & - fluxswUP_clrsky, fluxswDOWN_clrsky, errmsg, errflg) - - ! Inputs - logical, intent(in) :: & - top_at_1, & ! Vertical ordering flag - doGP_sgs_mynn, & ! Flag for MYNN-EDMF PBL cloud scheme - doGP_sgs_cnv, & ! Flag for sgs convective clouds scheme - doSWrad, & ! Flag to calculate SW irradiances - doSWclrsky ! Compute clear-sky fluxes? - integer, intent(in) :: & - nCol, & ! Number of horizontal gridpoints - nday, & ! Number of daytime points - nLev, & ! Number of vertical levels - iSFC ! Vertical index for surface-level - integer, intent(in), dimension(:) :: & - idxday ! Index array for daytime points - real(kind_phys),intent(in), dimension(:) :: & - sfc_alb_nir_dir, & ! Surface albedo (direct) - sfc_alb_nir_dif, & ! Surface albedo (diffuse) - sfc_alb_uvvis_dir, & ! Surface albedo (direct) - sfc_alb_uvvis_dif, & ! Surface albedo (diffuse) - coszen ! Cosize of SZA - real(kind_phys), dimension(:,:), intent(in) :: & - p_lay, & ! Pressure @ model layer-centers (Pa) - t_lay, & ! Temperature (K) - toa_src_sw ! TOA incident spectral flux (W/m2) - type(ty_optical_props_2str),intent(inout) :: & - sw_optical_props_clrsky ! RRTMGP DDT: shortwave clear-sky radiative properties - type(ty_optical_props_2str),intent(in) :: & - sw_optical_props_clouds, & ! RRTMGP DDT: shortwave cloud optical properties - sw_optical_props_cnvcloudsByBand, & ! RRTMGP DDT: shortwave convecive cloud optical properties - sw_optical_props_MYNNcloudsByBand, & ! RRTMGP DDT: shortwave MYNN-EDMF PBL cloud optical properties - sw_optical_props_precipByBand, & ! RRTMGP DDT: shortwave precipitation optical properties - sw_optical_props_aerosol ! RRTMGP DDT: shortwave aerosol optical properties - - ! Outputs - character(len=*), intent(out) :: & - errmsg ! CCPP error message - integer, intent(out) :: & - errflg ! CCPP error flag - real(kind_phys), dimension(:,:), intent(inout) :: & - fluxswUP_allsky, & ! RRTMGP upward all-sky flux profiles (W/m2) - fluxswDOWN_allsky, & ! RRTMGP downward all-sky flux profiles (W/m2) - fluxswUP_clrsky, & ! RRTMGP upward clear-sky flux profiles (W/m2) - fluxswDOWN_clrsky ! RRTMGP downward clear-sky flux profiles (W/m2) - type(cmpfsw_type), dimension(:), intent(inout) :: & - scmpsw ! 2D surface fluxes, components: - ! uvbfc - total sky downward uv-b flux (W/m2) - ! uvbf0 - clear sky downward uv-b flux (W/m2) - ! nirbm - downward nir direct beam flux (W/m2) - ! nirdf - downward nir diffused flux (W/m2) - ! visbm - downward uv+vis direct beam flux (W/m2) - ! visdf - downward uv+vis diffused flux (W/m2) - - ! Local variables - real(kind_phys), dimension(sw_gas_props%get_nband(),nday) :: & - sfc_alb_dir,sfc_alb_dif - type(ty_fluxes_byband) :: & - flux_allsky, & ! All-sky flux (W/m2) - flux_clrsky ! Clear-sky flux (W/m2) - real(kind_phys), dimension(nday,NLev+1,sw_gas_props%get_nband()),target :: & - fluxSW_up_allsky, fluxSW_up_clrsky, fluxSW_dn_allsky, fluxSW_dn_clrsky, fluxSW_dn_dir_allsky - real(kind_phys), dimension(ncol,NLev) :: vmrTemp - integer :: iBand, iDay,ibd - real(kind_phys), dimension(2,sw_gas_props%get_nband()) :: bandlimits - real(kind_phys), dimension(2), parameter :: nIR_uvvis_bnd = (/12850,16000/) - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (.not. doSWrad) return - - if (nDay .gt. 0) then - - ! Initialize RRTMGP DDT containing 2D(3D) fluxes - flux_allsky%bnd_flux_up => fluxSW_up_allsky - flux_allsky%bnd_flux_dn => fluxSW_dn_allsky - flux_allsky%bnd_flux_dn_dir => fluxSW_dn_dir_allsky - flux_clrsky%bnd_flux_up => fluxSW_up_clrsky - flux_clrsky%bnd_flux_dn => fluxSW_dn_clrsky - - ! Use near-IR albedo for bands with wavenumbers extending to 12850cm-1 - ! Use uv-vis albedo for bands with wavenumbers greater than 16000cm-1 - ! For overlapping band, average near-IR and us-vis albedos. - bandlimits = sw_gas_props%get_band_lims_wavenumber() - do iBand=1,sw_gas_props%get_nband() - if (bandlimits(1,iBand) .lt. nIR_uvvis_bnd(1)) then - sfc_alb_dir(iBand,:) = sfc_alb_nir_dir(idxday(1:nday)) - sfc_alb_dif(iBand,:) = sfc_alb_nir_dif(idxday(1:nday)) - endif - if (bandlimits(1,iBand) .eq. nIR_uvvis_bnd(1)) then - sfc_alb_dir(iBand,:) = 0.5_kind_phys*(sfc_alb_nir_dir(idxday(1:nday)) + sfc_alb_uvvis_dir(idxday(1:nday))) - sfc_alb_dif(iBand,:) = 0.5_kind_phys*(sfc_alb_nir_dif(idxday(1:nday)) + sfc_alb_uvvis_dif(idxday(1:nday))) - ibd = iBand - endif - if (bandlimits(1,iBand) .ge. nIR_uvvis_bnd(2)) then - sfc_alb_dir(iBand,:) = sfc_alb_uvvis_dir(idxday(1:nday)) - sfc_alb_dif(iBand,:) = sfc_alb_uvvis_dif(idxday(1:nday)) - endif - enddo - - ! - ! Compute clear-sky fluxes (if requested) - ! - - ! Clear-sky fluxes (gas+aerosol) - call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_aerosol%increment(sw_optical_props_clrsky)) - ! Delta-scale optical properties - call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_clrsky%delta_scale()) - if (doSWclrsky) then - call check_error_msg('rrtmgp_sw_rte_run',rte_sw( & - sw_optical_props_clrsky, & ! IN - optical-properties - top_at_1, & ! IN - veritcal ordering flag - coszen(idxday(1:nday)), & ! IN - Cosine of solar zenith angle - toa_src_sw(idxday(1:nday),:), & ! IN - incident solar flux at TOA - sfc_alb_dir, & ! IN - Shortwave surface albedo (direct) - sfc_alb_dif, & ! IN - Shortwave surface albedo (diffuse) - flux_clrsky)) ! OUT - Fluxes, clear-sky, 3D (nCol,NLev,nBand) - ! Store fluxes - fluxswUP_clrsky(idxday(1:nday),:) = sum(flux_clrsky%bnd_flux_up,dim=3) - fluxswDOWN_clrsky(idxday(1:nday),:) = sum(flux_clrsky%bnd_flux_dn,dim=3) - endif - - ! - ! Compute all-sky fluxes - ! - - ! Include convective cloud? - if (doGP_sgs_cnv) then - call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_cnvcloudsByBand%increment(sw_optical_props_clrsky)) - endif - - ! Include MYNN-EDMF PBL cloud? - if (doGP_sgs_mynn) then - call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_MYNNcloudsByBand%increment(sw_optical_props_clrsky)) - endif - - ! All-sky fluxes (clear-sky + clouds + precipitation) - call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_precipByBand%increment(sw_optical_props_clrsky)) - call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_clouds%increment(sw_optical_props_clrsky)) - - ! Delta-scale optical properties - call check_error_msg('rrtmgp_sw_rte_run',sw_optical_props_clrsky%delta_scale()) - call check_error_msg('rrtmgp_sw_rte_run',rte_sw( & - sw_optical_props_clrsky, & ! IN - optical-properties - top_at_1, & ! IN - veritcal ordering flag - coszen(idxday(1:nday)), & ! IN - Cosine of solar zenith angle - toa_src_sw(idxday(1:nday),:), & ! IN - incident solar flux at TOA - sfc_alb_dir, & ! IN - Shortwave surface albedo (direct) - sfc_alb_dif, & ! IN - Shortwave surface albedo (diffuse) - flux_allsky)) ! OUT - Fluxes, clear-sky, 3D (nCol,NLev,nBand) - - ! Store fluxes - fluxswUP_allsky(idxday(1:nday),:) = sum(flux_allsky%bnd_flux_up,dim=3) - fluxswDOWN_allsky(idxday(1:nday),:) = sum(flux_allsky%bnd_flux_dn,dim=3) - do iDay=1,nDay - ! Near IR - scmpsw(idxday(iDay))%nirbm = sum(flux_allsky%bnd_flux_dn_dir(iDay,iSFC,1:ibd-1)) + & - flux_allsky%bnd_flux_dn_dir(iDay,iSFC,ibd)/2. - scmpsw(idxday(iDay))%nirdf = (sum(flux_allsky%bnd_flux_dn(iDay,iSFC,1:ibd-1)) + & - flux_allsky%bnd_flux_dn(iDay,iSFC,ibd)/2.) - & - (sum(flux_allsky%bnd_flux_dn_dir(iDay,iSFC,1:ibd-1)) + & - flux_allsky%bnd_flux_dn_dir(iDay,iSFC,ibd)/2.) - ! UV-VIS - scmpsw(idxday(iDay))%visbm = sum(flux_allsky%bnd_flux_dn_dir(iDay,iSFC,ibd+1:sw_gas_props%get_nband())) + & - flux_allsky%bnd_flux_dn_dir(iDay,iSFC,ibd)/2. - scmpsw(idxday(iDay))%visdf = (sum(flux_allsky%bnd_flux_dn(iDay,iSFC,ibd+1:sw_gas_props%get_nband())) + & - flux_allsky%bnd_flux_dn(iDay,iSFC,ibd)/2. ) - & - (sum(flux_allsky%bnd_flux_dn_dir(iDay,iSFC,ibd+1:sw_gas_props%get_nband())) + & - flux_allsky%bnd_flux_dn_dir(iDay,iSFC,ibd)/2.) - enddo - else - fluxswUP_allsky(:,:) = 0._kind_phys - fluxswDOWN_allsky(:,:) = 0._kind_phys - fluxswUP_clrsky(:,:) = 0._kind_phys - fluxswDOWN_clrsky(:,:) = 0._kind_phys - scmpsw = cmpfsw_type( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 ) - endif - - end subroutine rrtmgp_sw_rte_run -!> @} -end module rrtmgp_sw_rte diff --git a/physics/rrtmgp_sw_rte.meta b/physics/rrtmgp_sw_rte.meta deleted file mode 100644 index 9ab24c8b3..000000000 --- a/physics/rrtmgp_sw_rte.meta +++ /dev/null @@ -1,240 +0,0 @@ -[ccpp-table-properties] - name = rrtmgp_sw_rte - type = scheme - dependencies = machine.F,radsw_param.f,rte-rrtmgp/rte/mo_rte_sw.F90,rte-rrtmgp/rte/mo_fluxes.F90,rte-rrtmgp/rte/kernels/mo_fluxes_broadband_kernels.F90,radiation_tools.F90 - dependencies = rte-rrtmgp/rte/kernels/mo_rte_solver_kernels.F90,rte-rrtmgp/extensions/mo_fluxes_byband.F90 - -######################################################################## -[ccpp-arg-table] - name = rrtmgp_sw_rte_run - type = scheme -[doSWrad] - standard_name = flag_for_calling_shortwave_radiation - long_name = flag to calculate SW irradiances - units = flag - dimensions = () - type = logical - intent = in -[doSWclrsky] - standard_name = flag_for_output_of_tendency_of_air_temperature_due_to_shortwave_heating_on_radiation_timestep_assuming_clear_sky - long_name = flag to output sw heating rate (Radtend%swhc) - units = flag - dimensions = () - type = logical - intent = in -[ncol] - standard_name = horizontal_loop_extent - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in -[nLev] - standard_name = vertical_layer_dimension - long_name = number of vertical levels - units = count - dimensions = () - type = integer - intent = in -[nday] - standard_name = daytime_points_dimension - long_name = daytime points dimension - units = count - dimensions = () - type = integer - intent = in -[idxday] - standard_name = daytime_points - long_name = daytime points - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = in -[coszen] - standard_name = cosine_of_solar_zenith_angle_for_daytime_points_on_radiation_timestep - long_name = mean cos of zenith angle over rad call period - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[p_lay] - standard_name = air_pressure_at_layer_for_RRTMGP - long_name = air pressure layer - units = Pa - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[top_at_1] - standard_name = flag_for_vertical_ordering_in_RRTMGP - long_name = flag for vertical ordering in RRTMGP - units = flag - dimensions = () - type = logical - intent = in -[doGP_sgs_cnv] - standard_name = flag_to_include_sgs_convective_cloud_in_RRTMGP - long_name = logical flag to control sgs convective cloud in RRTMGP - units = flag - dimensions = () - type = logical - intent = in -[doGP_sgs_mynn] - standard_name = flag_to_include_sgs_MYNN_EDMF_cloud_in_RRTMGP - long_name = logical flag to control MYNN-EDMF PBL cloud in RRTMGP - units = flag - dimensions = () - type = logical - intent = in -[iSFC] - standard_name = vertical_index_for_surface_in_RRTMGP - long_name = index for surface layer in RRTMGP - units = flag - dimensions = () - type = integer - intent = in -[t_lay] - standard_name = air_temperature_at_layer_for_RRTMGP - long_name = air temperature layer - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[sw_optical_props_clrsky] - standard_name = shortwave_optical_properties_for_clear_sky - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = inout -[sw_optical_props_clouds] - standard_name = shortwave_optical_properties_for_cloudy_atmosphere - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = in -[sw_optical_props_precipByBand] - standard_name = shortwave_optical_properties_for_precipitation_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = in -[sw_optical_props_cnvcloudsByBand] - standard_name = shortwave_optical_properties_for_convective_cloudy_atmosphere_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = in -[sw_optical_props_MYNNcloudsByBand] - standard_name = shortwave_optical_properties_for_MYNN_EDMF_PBL_cloudy_atmosphere_by_band - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = in -[sw_optical_props_aerosol] - standard_name = shortwave_optical_properties_for_aerosols - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_2str - intent = in -[sfc_alb_nir_dir] - standard_name = surface_albedo_due_to_near_IR_direct - long_name = surface albedo due to near IR direct beam - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[sfc_alb_nir_dif] - standard_name = surface_albedo_due_to_near_IR_diffused - long_name = surface albedo due to near IR diffused beam - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[sfc_alb_uvvis_dir] - standard_name = surface_albedo_due_to_UV_and_VIS_direct - long_name = surface albedo due to UV+VIS direct beam - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[sfc_alb_uvvis_dif] - standard_name = surface_albedo_due_to_UV_and_VIS_diffused - long_name = surface albedo due to UV+VIS diffused beam - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[toa_src_sw] - standard_name = toa_incident_sw_flux_by_spectral_point - long_name = TOA shortwave incident flux at each spectral points - units = W m-2 - dimensions = (horizontal_loop_extent,number_of_shortwave_spectral_points) - type = real - kind = kind_phys - intent = in -[scmpsw] - standard_name = components_of_surface_downward_shortwave_fluxes - long_name = derived type for special components of surface downward shortwave fluxes - units = W m-2 - dimensions = (horizontal_loop_extent) - type = cmpfsw_type - intent = inout -[fluxswUP_allsky] - standard_name = RRTMGP_sw_flux_profile_upward_allsky - long_name = RRTMGP upward shortwave all-sky flux profile - units = W m-2 - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = inout -[fluxswDOWN_allsky] - standard_name = RRTMGP_sw_flux_profile_downward_allsky - long_name = RRTMGP downward shortwave all-sky flux profile - units = W m-2 - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = inout -[fluxswUP_clrsky] - standard_name = RRTMGP_sw_flux_profile_upward_clrsky - long_name = RRTMGP upward shortwave clr-sky flux profile - units = W m-2 - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = inout -[fluxswDOWN_clrsky] - standard_name = RRTMGP_sw_flux_profile_downward_clrsky - long_name = RRTMGP downward shortwave clr-sky flux profile - units = W m-2 - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = inout -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out diff --git a/physics/rte-rrtmgp b/physics/rte-rrtmgp index 7f01618c9..0dc54f5ec 160000 --- a/physics/rte-rrtmgp +++ b/physics/rte-rrtmgp @@ -1 +1 @@ -Subproject commit 7f01618c92409658bddd3afa9acb004c608f6a0d +Subproject commit 0dc54f5ecaeb1e1e342efd1e02d0bcd41737bde2 From 936a28e2d746b486dc28ce79f7bf14647bd99952 Mon Sep 17 00:00:00 2001 From: drnimbusrain Date: Tue, 7 Feb 2023 14:01:19 -0500 Subject: [PATCH 101/380] Updated Meta data --- physics/satmedmfvdifq.meta | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/physics/satmedmfvdifq.meta b/physics/satmedmfvdifq.meta index 8538c6aa7..8a41e39e3 100644 --- a/physics/satmedmfvdifq.meta +++ b/physics/satmedmfvdifq.meta @@ -581,6 +581,14 @@ type = real kind = kind_phys intent = in +[canheight] + standard_name = forest_canopy_height + long_name = forest canopy height above ground + units = m + dimensions = () + type = real + kind = kind_phys + intent = in [sfc_rlm] standard_name = choice_of_near_surface_mixing_length_in_boundary_layer_mass_flux_scheme long_name = choice of near surface mixing length in boundary layer mass flux scheme From f3499e3c2bba057c36975d4ff5faa8772ab85c16 Mon Sep 17 00:00:00 2001 From: dustinswales Date: Wed, 8 Feb 2023 10:45:58 -0700 Subject: [PATCH 102/380] Merge pull request #956 from dustinswales/accumulated_cleanup Accumulated cleanup --- CODEOWNERS | 301 ++++++----- physics/GFS_cloud_diagnostics.F90 | 80 ++- physics/GFS_cloud_diagnostics.meta | 23 + physics/GFS_phys_time_vary.fv3.F90 | 14 +- physics/GFS_phys_time_vary.fv3.meta | 15 + physics/GFS_phys_time_vary.scm.F90 | 2 +- physics/GFS_rad_time_vary.fv3.F90 | 8 +- physics/GFS_rad_time_vary.fv3.meta | 16 +- physics/GFS_rad_time_vary.scm.F90 | 8 +- physics/GFS_rad_time_vary.scm.meta | 16 +- physics/GFS_radiation_surface.F90 | 23 +- physics/GFS_radiation_surface.meta | 33 +- physics/GFS_rrtmg_pre.F90 | 89 ++-- physics/GFS_rrtmg_pre.meta | 121 ++++- physics/GFS_rrtmg_setup.F90 | 442 ++++------------ physics/GFS_rrtmg_setup.meta | 290 ++++++++++- physics/GFS_rrtmgp_cloud_overlap.F90 | 3 +- physics/GFS_rrtmgp_cloud_overlap.meta | 4 +- physics/GFS_rrtmgp_pre.F90 | 34 +- physics/GFS_rrtmgp_pre.meta | 21 +- physics/GFS_rrtmgp_setup.F90 | 95 ++-- physics/GFS_rrtmgp_setup.meta | 223 ++++++-- physics/GFS_surface_composites_pre.F90 | 1 - physics/GFS_surface_composites_pre.meta | 2 +- physics/cires_ugwpv1_oro.F90 | 4 +- physics/drag_suite.F90 | 6 + physics/gcycle.F90 | 27 +- physics/gfdl_cloud_microphys.F90 | 2 +- physics/gfdl_sfc_layer.F90 | 6 +- physics/lsm_noah.f | 5 +- physics/lsm_ruc.F90 | 8 +- physics/m_micro.F90 | 4 +- physics/module_SF_JSFC.F90 | 23 +- physics/module_gfdl_cloud_microphys.F90 | 13 +- physics/module_sf_exchcoef.f90 | 13 +- physics/module_sf_mynn.F90 | 21 +- ...acier.f90 => module_sf_noahmp_glacier.F90} | 2 +- ..._noahmplsm.f90 => module_sf_noahmplsm.F90} | 2 +- physics/module_sf_ruclsm.F90 | 29 +- physics/myjsfc_wrapper.F90 | 2 +- physics/noahmpdrv.F90 | 2 +- physics/noahmpdrv.meta | 2 +- physics/physcons.F90 | 4 +- physics/physparam.f | 300 ----------- physics/radiation_aerosols.f | 477 +++++++++++------ physics/radiation_astronomy.f | 74 +-- physics/radiation_cloud_overlap.F90 | 2 +- physics/radiation_clouds.f | 488 ++++++++---------- physics/radiation_gases.f | 310 ++++++----- physics/radiation_surface.f | 44 +- physics/radlw_datatb.f | 38 +- physics/radlw_main.F90 | 212 ++++---- physics/radlw_main.meta | 86 ++- physics/radlw_param.f | 2 +- physics/radsw_datatb.f | 34 +- physics/radsw_main.F90 | 275 +++++----- physics/radsw_main.meta | 93 +++- physics/radsw_param.f | 2 +- physics/rrtmgp_aerosol_optics.F90 | 25 +- physics/rrtmgp_aerosol_optics.meta | 45 ++ physics/set_soilveg.f | 22 +- physics/set_soilveg_ruc.F90 | 20 +- physics/sfc_diff.f | 4 +- physics/sflx.f | 36 +- 64 files changed, 2605 insertions(+), 2023 deletions(-) rename physics/{module_sf_noahmp_glacier.f90 => module_sf_noahmp_glacier.F90} (99%) rename physics/{module_sf_noahmplsm.f90 => module_sf_noahmplsm.F90} (99%) delete mode 100644 physics/physparam.f diff --git a/CODEOWNERS b/CODEOWNERS index cf7a886aa..15821a791 100644 --- a/CODEOWNERS +++ b/CODEOWNERS @@ -4,127 +4,198 @@ # Default codeowners for files that don't have specific owners: -* @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +* @grantfirl @ChunxiZhang-NOAA @dustinswales @mzhangw # The following lines are from the CCPP Primary Schemes Points of Contact # https://docs.google.com/spreadsheets/d/14y0Th_sSpCqlssEMNfSZ_Ni9wrpPqfpPY0kRG7jCZB8/edit#gid=0 # (Internal NOAA document.) -smoke/* @haiqinli @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/cs_conv_aw_adj.* @AnningCheng-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/cs_conv.* @AnningCheng-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/cu_gf* @hannahcbarnes @haiqinli @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/sascnvn.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/cu_ntiedtke* @ChunxiZhang-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/rascnv.* @SMoorthi-emc @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/samfdeepcnv.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/samfshalcnv.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/samfaerosols.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/shalcnv.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/unified_ugwp* @mdtoyNOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/ugwp_driver_v0.F @mdtoyNOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/cires_ugwp* @mdtoyNOAA @ValeryYudin-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/drag_suite.* @mdtoyNOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/gwdc.* @Songyou184 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/gwdps.* @Songyou184 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/gfdl_fv_sat_adj.* @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/gfdl_cloud_microphys.* @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/module_gfdl_cloud_microphys.* @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/multi_gases.F90 @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/mp_fer_hires.* @ericaligo-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/module_MP_FER_HIRES.* @ericaligo-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/module_mp_thompson* @gthompsnWRF @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/module_mp_radar.* @gthompsnWRF @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/mp_thompson* @gthompsnWRF @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/precpd.* @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/gscond.* @RuiyuSun @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/m_micro* @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/aer_cloud.F @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/aerclm_def.F @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/cldmacro.F @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/cldwat2m_micro.F @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/wv_saturation.F @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/micro_mg* @AnningCheng-NOAA @andrewgettelman @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/ozphys* @AlexBelochitski-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/satmedmfvdif.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/satmedmfvdifq.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/mfpbl.f @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/mfscu.f @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/mfpbltq.f @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/mfscuq.f @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/shinhongvdif.* @ChunxiZhang-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich -physics/ysuvdif.* @ChunxiZhang-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich - -physics/tridi.f @JongilHan66 @ChunxiZhang-NOAA @JongilHan66 @WeiguoWang-NOAA @AlexBelochitski-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich - -physics/moninedmf.* @JongilHan66 @WeiguoWang-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/module_BL_MYJPBL.* @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/module_MYJPBL_wrapper.* @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/module_bl_mynn.* @joeolson42 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/module_MYNNPBL_wrapper.* @joeolson42 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/gcm_shoc.* @AlexBelochitski-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/moninshoc.* @AlexBelochitski-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/rte-rrtmgp @dustinswales @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/radiation_tools.* @dustinswales @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/rrtmgp_lw_rte.met* @dustinswales @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/rrtmgp_sw_rte.met* @dustinswales @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/radlw_main.* @mjiacono @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/HWRF_mcica_random_numbers.F90 @mjiacono @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/HWRF_mersenne_twister.F90 @mjiacono @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/radlw_datatb.f @mjiacono @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/radsw_datatb.* @mjiacono @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/radsw_main.* @mjiacono @Qingfu-Liu @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/radsw_param.f @dustinswales @Qingfu-Liu @mjiacono @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/rayleigh_damp.* @yangfanglin @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/GFS_stochastics.* @pjpegion @lisa-bengtsson @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/flake* @YihuaWu-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/sfc_drv.* @HelinWei-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/sflx.f @HelinWei-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/surface_perturbation.* @HelinWei-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/*noahmp* @barlage @cenlinhe @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/set_soilveg.* @HelinWei-NOAA @barlage @cenlinhe @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/namelist_soilveg.* @HelinWei-NOAA @barlage @cenlinhe @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/namelist_soilveg_ruc.* @tanyasmirnova @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/set_soilveg_ruc.* @tanyasmirnova @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/module_sf_ruclsm.* @tanyasmirnova @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/module_soil_pre.* @tanyasmirnova @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/sfc_drv_ruc.* @tanyasmirnova @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/date_def.f @XuLi-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/*nst* @XuLi-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/sfc_ocean.* @HelinWei-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/sfc_diff.* @JongilHan66 @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/h2ophys.* @AlexBelochitski-NOAA @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA - -physics/sfc_sice.* @wd20xw @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA -physics/sfc_cice.* @wd20xw @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +smoke/* @haiqinli @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/aerclm_def.F @AnningCheng-NOAA @andrewgettelman @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/aer_cloud.F @AnningCheng-NOAA @andrewgettelman @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/aerinterp.F90 @AnningCheng-NOAA @andrewgettelman @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/bl_mynn_common.f90 @joeolson42 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/calpreciptype.f90 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/cires_orowam2017.f @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/cires_tauamf_data.F90 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/cires_ugwp* @ValeryYudin-NOAA @mdtoyNOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/cldmacro.F @AnningCheng-NOAA @andrewgettelman @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/cldwat2m_micro.F @AnningCheng-NOAA @andrewgettelman @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/cnvc90.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/cs_conv_aw_adj.* @AnningCheng-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/cs_conv.* @AnningCheng-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/cu_gf* @hannahcbarnes @haiqinli @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/cu_ntiedtke* @ChunxiZhang-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/date_def.f @XuLi-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/dcyc2t3.* @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/drag_suite.* @mdtoyNOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/flake* @YihuaWu-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/funcphys.f90 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/fv_sat_adj.* @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/gcycle.F90 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/get_phi_fv3.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/get_prs_fv3.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/gfdl_cloud_microphys.* @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFDL_parse_tracers.F90 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/gfdl_sfc_layer.* @ZhanZhang-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_cloud_diagnostics.* @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_DCNV_generic_post.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_DCNV_generic_pre.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_debug.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_GWD_generic_post.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_GWD_generic_pre.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_MP_generic_post.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_MP_generic_pre.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_PBL_generic_common.F90 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_PBL_generic_post.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_PBL_generic_pre.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_phys_time_vary.fv3.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_phys_time_vary.scm.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/gfs_phy_tracer_config.F @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_radiation_surface.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_rad_time_vary.fv3.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_rad_time_vary.scm.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_rrtmgp_cloud_mp.* @dustinswales @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_rrtmgp_cloud_overlap.* @dustinswales @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_rrtmgp_lw_post.* @dustinswales @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_rrtmg_post.* @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_rrtmgp_pre.* @dustinswales @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_rrtmg_pre.* @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_rrtmgp_setup.* @dustinswales @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_rrtmgp_sw_post.* @dustinswales @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_rrtmgp_sw_pre.* @dustinswales @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_rrtmg_setup.* @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_SCNV_generic_post.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_SCNV_generic_pre.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_stochastics.* @pjpegion @lisa-bengtsson @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_suite_interstitial_1.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_suite_interstitial_2.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_suite_interstitial_3.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_suite_interstitial_4.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_suite_interstitial_5.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_suite_interstitial_phys_reset.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_suite_interstitial_rad_reset.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_suite_stateout_reset.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_suite_stateout_update.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_surface_composites_inter.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_surface_composites_post.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_surface_composites_pre.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_surface_generic_post.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_surface_generic_pre.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_surface_loop_control_part1.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_surface_loop_control_part2.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_time_vary_pre.fv3.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/GFS_time_vary_pre.scm.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/gocart_tracer_config_stub.f @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/gwdc.* @Songyou184 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/gwdps.* @Songyou184 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/h2o_def.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/h2ointerp.f90 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/h2ophys.* @SMoorthi-emc @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/hedmf.* @JongilHan66 @WeiguoWang-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/iccn_def.F @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/iccninterp.F90 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/iounitdef.f @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/lsm_noah.* @HelinWei-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/lsm_ruc.* @tanyasmirnova @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/machine.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/maximum_hourly_diagnostics.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/mersenne_twister.f @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/mfpbl.f @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/mfpblt.f @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/mfpbltq.f @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/mfscu.f @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/mfscuq.f @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/micro_mg* @AnningCheng-NOAA @andrewgettelman @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/m_micro* @AnningCheng-NOAA @andrewgettelman @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/module_bfmicrophysics.f @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/module_BL_MYJPBL.* @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/module_bl_mynn.* @joeolson42 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/module_gfdl_cloud_microphys.* @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/module_MP_FER_HIRES.* @ericaligo-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/module_mp_nssl_2mom.F90 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/module_mp_radar.* @gthompsnWRF @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/module_mp_thompson* @gthompsnWRF @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/module_nst* @XuLi-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/module_sf_exchcoef.f90 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/module_SF_JSFC.F90 @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/module_sf_mynn.F90 @joeolson42 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/module_sf_ruclsm.* @tanyasmirnova @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/module_soil_pre.* @tanyasmirnova @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/moninshoc.* @SMoorthi-emc @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/mp_fer_hires.* @ericaligo-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/mp_nssl.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/mp_thompson* @gthompsnWRF @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/multi_gases.F90 @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/myjpbl_wrapper.* @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/myjsfc_wrapper.* @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/mynnedmf_wrapper.* @joeolson42 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/mynnsfc_wrapper.* @joeolson42 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/namelist_soilveg.* @HelinWei-NOAA @barlage @cenlinhe @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/namelist_soilveg_ruc.* @tanyasmirnova @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/*noahmp* @barlage @cenlinhe @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/ozinterp.f90 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/ozne_def.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/ozphys* @SMoorthi-emc @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/physcons.F90 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/phys_tend.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/progsigma_calc.f90 @lisa-bengtsson @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/radcons.f90 @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/radiation_aerosols.f @Qingfu-Liu @dustinswales @AnningCheng-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/radiation_astronomy.f @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/radiation_cloud_overlap.F90 @dustinswales @mjiacono @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/radiation_clouds.f @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/radiation_gases.f @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/radiation_surface.* @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/radiation_tools.F90 @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/radlw_* @mjiacono @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/radsw_* @mjiacono @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/rad_sw_pre.* @dustinswales @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/rascnv.* @SMoorthi-emc @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/rayleigh_damp.* @yangfanglin @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/rrtmg_lw_cloud_optics.F90 @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/rrtmg_lw_post.* @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/rrtmg_lw_pre.* @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/rrtmgp_aerosol_optics.* @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/rrtmgp_lw_* @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/rrtmgp_sw_* @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/rrtmg_sw_cloud_optics.F90 @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/rrtmg_sw_post.* @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/rte-rrtmgp @RobertPincus @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/samfdeepcnv.* @JongilHan66 @lisa-bengtsson @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/samfshalcnv.* @JongilHan66 @lisa-bengtsson @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/samfaerosols.* @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/sascnvn.* @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/satmedmfvdif.* @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/satmedmfvdifq.* @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/scm_sfc_flux_spec.* @grantfirl @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/set_soilveg.* @HelinWei-NOAA @barlage @cenlinhe @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/set_soilveg_ruc.* @tanyasmirnova @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/sfc_cice.* @wd20xw @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/sfc_diag.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/sfc_diag_post.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/sfc_diff.* @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/sfc_nst* @XuLi-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/sfc_ocean.* @HelinWei-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/sfc_sice.* @wd20xw @grantfirl @ChunxiZhang-NOAA @dustinswales +#physics/sfcsub.F @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/sflx.f @HelinWei-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/sgscloud_radpost.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/sgscloud_radpre.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/shalcnv.* @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/shinhongvdif.* @ChunxiZhang-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/shoc.* @SMoorthi-emc @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/surface_perturbation.* @HelinWei-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/tridi.f @JongilHan66 @ChunxiZhang-NOAA @WeiguoWang-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/ugwp_driver_v0.F @mdtoyNOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/ugwpv1_gsldrag.* @mdtoyNOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/ugwpv1_gsldrag_post.* @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/unified_ugwp* @mdtoyNOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/wv_saturation.F @AnningCheng-NOAA @andrewgettelman @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/ysuvdif.* @ChunxiZhang-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/zhaocarr_gscond.* @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales +physics/zhaocarr_precpd.* @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales ######################################################################## diff --git a/physics/GFS_cloud_diagnostics.F90 b/physics/GFS_cloud_diagnostics.F90 index 0e3f730e5..86dc2b518 100644 --- a/physics/GFS_cloud_diagnostics.F90 +++ b/physics/GFS_cloud_diagnostics.F90 @@ -3,7 +3,6 @@ module GFS_cloud_diagnostics use machine, only: kind_phys - use physparam, only: icldflg use module_radiation_clouds, only: gethml ! Module parameters (imported directly from radiation_cloud.f) @@ -19,10 +18,6 @@ module GFS_cloud_diagnostics ! Version tag and last revision date character(40), parameter :: VTAGCLD='UFS-cloud-diagnostics vX.x May 2020 ' - - ! Module variables - integer :: & - llyr = 2 ! Upper limit of boundary layer clouds public GFS_cloud_diagnostics_run @@ -36,51 +31,54 @@ module GFS_cloud_diagnostics !> \section arg_table_GFS_cloud_diagnostics_run !! \htmlinclude GFS_cloud_diagnostics_run.html !! - subroutine GFS_cloud_diagnostics_run(nCol, nLev, iovr_rand, iovr_maxrand, iovr_max, & - iovr_dcorr, iovr_exp, iovr_exprand, lsswr, lslwr, lat, de_lgth, p_lay, & + subroutine GFS_cloud_diagnostics_run(nCol, nLev, iovr, iovr_rand, iovr_maxrand, & + iovr_max, iovr_dcorr, iovr_exp, iovr_exprand, lsswr, lslwr, lat, de_lgth, p_lay, & cld_frac, p_lev, deltaZ, cloud_overlap_param, precip_overlap_param, con_pi, & - mtopa, mbota, cldsa, errmsg, errflg) + top_at_1, si, mtopa, mbota, cldsa, errmsg, errflg) implicit none ! Inputs - integer, intent(in) :: & - nCol, & ! Number of horizontal grid-points - nLev ! Number of vertical-layers - integer, intent(in) :: & - iovr_rand, & ! Flag for random cloud overlap method - iovr_maxrand, & ! Flag for maximum-random cloud overlap method - iovr_max, & ! Flag for maximum cloud overlap method - iovr_dcorr, & ! Flag for decorrelation-length cloud overlap method - iovr_exp, & ! Flag for exponential cloud overlap method - iovr_exprand ! Flag for exponential-random cloud overlap method - logical, intent(in) :: & - lsswr, & ! Call SW radiation? - lslwr ! Call LW radiation - real(kind_phys), intent(in) :: & - con_pi ! Physical constant: pi + integer, intent(in) :: & + nCol, & ! Number of horizontal grid-points + nLev ! Number of vertical-layers + integer, intent(in) :: & + iovr, & ! Choice of cloud-overlap method + iovr_rand, & ! Flag for random cloud overlap method + iovr_maxrand, & ! Flag for maximum-random cloud overlap method + iovr_max, & ! Flag for maximum cloud overlap method + iovr_dcorr, & ! Flag for decorrelation-length cloud overlap method + iovr_exp, & ! Flag for exponential cloud overlap method + iovr_exprand ! Flag for exponential-random cloud overlap method + logical, intent(in) :: & + lsswr, & ! Call SW radiation? + lslwr, & ! Call LW radiation? + top_at_1 ! Vertical ordering flag + real(kind_phys), intent(in) :: & + con_pi ! Physical constant: pi real(kind_phys), dimension(:), intent(in) :: & - lat, & ! Latitude - de_lgth ! Decorrelation length + lat, & ! Latitude + de_lgth, & ! Decorrelation length + si ! Vertical sigma coordinate real(kind_phys), dimension(:,:), intent(in) :: & - p_lay, & ! Pressure at model-layer - cld_frac ! Total cloud fraction + p_lay, & ! Pressure at model-layer + cld_frac ! Total cloud fraction real(kind_phys), dimension(:,:), intent(in) :: & - p_lev ! Pressure at model interfaces + p_lev ! Pressure at model interfaces real(kind_phys), dimension(:,:), intent(in) :: & - deltaZ, & ! Layer thickness (m) - cloud_overlap_param, & ! Cloud-overlap parameter - precip_overlap_param ! Precipitation overlap parameter + deltaZ, & ! Layer thickness (m) + cloud_overlap_param, & ! Cloud-overlap parameter + precip_overlap_param ! Precipitation overlap parameter ! Outputs - character(len=*), intent(out) :: & - errmsg ! Error message - integer, intent(out) :: & - errflg ! Error flag - integer,dimension(:,:),intent(out) :: & - mbota, & ! Vertical indices for cloud tops - mtopa ! Vertical indices for cloud bases + character(len=*), intent(out) :: & + errmsg ! Error message + integer, intent(out) :: & + errflg ! Error flag + integer,dimension(:,:),intent(out) :: & + mbota, & ! Vertical indices for cloud tops + mtopa ! Vertical indices for cloud bases real(kind_phys),dimension(:,:), intent(out) :: & - cldsa ! Fraction of clouds for low, middle, high, total and BL + cldsa ! Fraction of clouds for low, middle, high, total and BL ! Local variables integer i,id,iCol,iLay,icld @@ -111,8 +109,8 @@ subroutine GFS_cloud_diagnostics_run(nCol, nLev, iovr_rand, iovr_maxrand, iovr_m ! defined by ptopc. The cloud overlapping method is defined by control flag 'iovr', which may ! be different for lw and sw radiation programs. call gethml(p_lay*0.01, ptop1, cld_frac, cldcnv, deltaZ, de_lgth, cloud_overlap_param,& - nCol, nLev, iovr_rand, iovr_maxrand, iovr_max, iovr_dcorr, iovr_exp, & - iovr_exprand, cldsa, mtopa, mbota) + nCol, nLev, iovr, iovr_rand, iovr_maxrand, iovr_max, iovr_dcorr, iovr_exp, & + iovr_exprand, top_at_1, si, cldsa, mtopa, mbota) end subroutine GFS_cloud_diagnostics_run !> @} diff --git a/physics/GFS_cloud_diagnostics.meta b/physics/GFS_cloud_diagnostics.meta index dd88bbc46..53d1552e6 100644 --- a/physics/GFS_cloud_diagnostics.meta +++ b/physics/GFS_cloud_diagnostics.meta @@ -1,6 +1,7 @@ [ccpp-table-properties] name = GFS_cloud_diagnostics type = scheme + dependencies = machine.F,radiation_clouds.f ######################################################################## [ccpp-arg-table] @@ -20,6 +21,13 @@ dimensions = () type = integer intent = in +[iovr] + standard_name = flag_for_cloud_overlap_method_for_radiation + long_name = max-random overlap clouds + units = flag + dimensions = () + type = integer + intent = in [iovr_rand] standard_name = flag_for_random_cloud_overlap_method long_name = choice of random cloud overlap method @@ -148,6 +156,21 @@ type = real kind = kind_phys intent = in +[top_at_1] + standard_name = flag_for_vertical_ordering_in_radiation + long_name = flag for vertical ordering in radiation + units = flag + dimensions = () + type = logical + intent = in +[si] + standard_name = sigma_pressure_hybrid_vertical_coordinate + long_name = vertical sigma coordinate for radiation initialization + units = none + dimensions = (vertical_interface_dimension) + type = real + kind = kind_phys + intent = in [mtopa] standard_name = model_layer_number_at_cloud_top long_name = vertical indices for low, middle and high cloud tops diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index 796856ad3..42f2bbc15 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -34,7 +34,6 @@ module GFS_phys_time_vary !--- variables needed for calculating 'sncovr' use namelist_soilveg, only: salp_data, snupx use set_soilveg_mod, only: set_soilveg - use physparam, only : iaermdl ! --- needed for Noah MP init use noahmp_tables, only: laim_table,saim_table,sla_table, & @@ -67,7 +66,7 @@ module GFS_phys_time_vary !>\section gen_GFS_phys_time_vary_init GFS_phys_time_vary_init General Algorithm !> @{ subroutine GFS_phys_time_vary_init ( & - me, master, ntoz, h2o_phys, iaerclm, iccn, iflip, im, levs, & + me, master, ntoz, h2o_phys, iaerclm, iccn, iaermdl, iflip, im, levs, & nx, ny, idate, xlat_d, xlon_d, & jindx1_o3, jindx2_o3, ddy_o3, ozpl, jindx1_h, jindx2_h, ddy_h, h2opl,fhour, & jindx1_aer, jindx2_aer, ddy_aer, iindx1_aer, iindx2_aer, ddx_aer, aer_nm, & @@ -86,7 +85,7 @@ subroutine GFS_phys_time_vary_init ( implicit none ! Interface variables - integer, intent(in) :: me, master, ntoz, iccn, iflip, im, nx, ny, levs + integer, intent(in) :: me, master, ntoz, iccn, iflip, im, nx, ny, levs, iaermdl logical, intent(in) :: h2o_phys, iaerclm, lsm_cold_start integer, intent(in) :: idate(:) real(kind_phys), intent(in) :: fhour @@ -288,7 +287,7 @@ subroutine GFS_phys_time_vary_init ( !$OMP section !> - Initialize soil vegetation (needed for sncovr calculation further down) - call set_soilveg(me, isot, ivegsrc, nlunit) + call set_soilveg(me, isot, ivegsrc, nlunit, errmsg, errflg) !$OMP end sections @@ -712,7 +711,7 @@ subroutine GFS_phys_time_vary_timestep_init ( imfdeepcnv, cal_pre, random_clds, nscyc, ntoz, h2o_phys, iaerclm, iccn, clstp, & jindx1_o3, jindx2_o3, ddy_o3, ozpl, jindx1_h, jindx2_h, ddy_h, h2opl, iflip, & jindx1_aer, jindx2_aer, ddy_aer, iindx1_aer, iindx2_aer, ddx_aer, aer_nm, & - jindx1_ci, jindx2_ci, ddy_ci, iindx1_ci, iindx2_ci, ddx_ci, in_nm, ccn_nm, & + jindx1_ci, jindx2_ci, ddy_ci, iindx1_ci, iindx2_ci, ddx_ci, in_nm, ccn_nm, fn_nml, & imap, jmap, prsl, seed0, rann, nthrds, nx, ny, nsst, tile_num, nlunit, lsoil, lsoil_lsm,& kice, ialb, isot, ivegsrc, input_nml_file, use_ufo, nst_anl, frac_grid, fhcyc, phour, & lakefrac, min_seaice, min_lakeice, smc, slc, stc, smois, sh2o, tslb, tiice, tg3, tref, & @@ -753,6 +752,7 @@ subroutine GFS_phys_time_vary_timestep_init ( integer, intent(in) :: nthrds, nx, ny, nsst, tile_num, nlunit, lsoil integer, intent(in) :: lsoil_lsm, kice, ialb, isot, ivegsrc character(len=*), intent(in) :: input_nml_file(:) + character(len=*), intent(in) :: fn_nml logical, intent(in) :: use_ufo, nst_anl, frac_grid real(kind_phys), intent(in) :: fhcyc, phour, lakefrac(:), min_seaice, min_lakeice, & xlat_d(:), xlon_d(:), landfrac(:) @@ -893,14 +893,14 @@ subroutine GFS_phys_time_vary_timestep_init ( !> - Call gcycle() to repopulate specific time-varying surface properties for AMIP/forecast runs if (nscyc > 0) then if (mod(kdt,nscyc) == 1) THEN - call gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & + call gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, fn_nml, & input_nml_file, lsoil, lsoil_lsm, kice, idate, ialb, isot, ivegsrc, & use_ufo, nst_anl, fhcyc, phour, landfrac, lakefrac, min_seaice, min_lakeice,& frac_grid, smc, slc, stc, smois, sh2o, tslb, tiice, tg3, tref, tsfc, & tsfco, tisfc, hice, fice, facsf, facwf, alvsf, alvwf, alnsf, alnwf, & zorli, zorll, zorlo, weasd, slope, snoalb, canopy, vfrac, vtype, & stype, shdmin, shdmax, snowd, cv, cvb, cvt, oro, oro_uf, & - xlat_d, xlon_d, slmsk, imap, jmap) + xlat_d, xlon_d, slmsk, imap, jmap, errmsg, errflg) endif endif diff --git a/physics/GFS_phys_time_vary.fv3.meta b/physics/GFS_phys_time_vary.fv3.meta index f37235975..ce8c6c54b 100644 --- a/physics/GFS_phys_time_vary.fv3.meta +++ b/physics/GFS_phys_time_vary.fv3.meta @@ -44,6 +44,13 @@ dimensions = () type = logical intent = in +[iaermdl] + standard_name = control_for_aerosol_radiation_scheme + long_name = control of aerosol scheme in radiation + units = 1 + dimensions = () + type = integer + intent = in [iccn] standard_name = control_for_ice_cloud_condensation_nuclei_forcing long_name = flag for IN and CCN forcing for morrison gettelman microphysics @@ -1285,6 +1292,14 @@ type = real kind = kind_phys intent = inout +[fn_nml] + standard_name = filename_of_namelist + long_name = namelist filename + units = none + dimensions = () + type = character + kind = len=* + intent = in [imap] standard_name = map_of_block_column_number_to_global_i_index long_name = map of local index ix to global index i for this block diff --git a/physics/GFS_phys_time_vary.scm.F90 b/physics/GFS_phys_time_vary.scm.F90 index c70e3232a..74b34e974 100644 --- a/physics/GFS_phys_time_vary.scm.F90 +++ b/physics/GFS_phys_time_vary.scm.F90 @@ -264,7 +264,7 @@ subroutine GFS_phys_time_vary_init ( endif !> - Initialize soil vegetation (needed for sncovr calculation further down) - call set_soilveg(me, isot, ivegsrc, nlunit) + call set_soilveg(me, isot, ivegsrc, nlunit, errmsg, errflg) !> - Call setindxoz() to initialize ozone data if (ntoz > 0) then diff --git a/physics/GFS_rad_time_vary.fv3.F90 b/physics/GFS_rad_time_vary.fv3.F90 index cef530b55..978dc177f 100644 --- a/physics/GFS_rad_time_vary.fv3.F90 +++ b/physics/GFS_rad_time_vary.fv3.F90 @@ -18,10 +18,10 @@ module GFS_rad_time_vary !! subroutine GFS_rad_time_vary_timestep_init (lrseeds, rseeds, & lslwr, lsswr, isubc_lw, isubc_sw, icsdsw, icsdlw, cnx, cny, isc, jsc, & - imap, jmap, sec, kdt, imp_physics, imp_physics_zhao_carr, ps_2delt, & - ps_1delt, t_2delt, t_1delt, qv_2delt, qv_1delt, t, qv, ps, errmsg, errflg) + imap, jmap, sec, kdt, imp_physics, imp_physics_zhao_carr, ipsd0, ipsdlim,& + ps_2delt, ps_1delt, t_2delt, t_1delt, qv_2delt, qv_1delt, t, qv, ps, & + errmsg, errflg) - use physparam, only: ipsd0, ipsdlim, iaerflg use mersenne_twister, only: random_setseed, random_index, random_stat use machine, only: kind_phys use radcons, only: qmin, con_100 @@ -32,7 +32,7 @@ subroutine GFS_rad_time_vary_timestep_init (lrseeds, rseeds, logical, intent(in) :: lrseeds integer, intent(in) :: rseeds(:,:) integer, intent(in) :: isubc_lw, isubc_sw, cnx, cny, isc, jsc, kdt - integer, intent(in) :: imp_physics, imp_physics_zhao_carr + integer, intent(in) :: imp_physics, imp_physics_zhao_carr, ipsd0, ipsdlim logical, intent(in) :: lslwr, lsswr integer, intent(inout) :: icsdsw(:), icsdlw(:) integer, intent(in) :: imap(:), jmap(:) diff --git a/physics/GFS_rad_time_vary.fv3.meta b/physics/GFS_rad_time_vary.fv3.meta index f7a154eea..19eb41dc2 100644 --- a/physics/GFS_rad_time_vary.fv3.meta +++ b/physics/GFS_rad_time_vary.fv3.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_rad_time_vary type = scheme - dependencies = machine.F,mersenne_twister.f,physparam.f,radcons.f90 + dependencies = machine.F,mersenne_twister.f,radcons.f90 ######################################################################## [ccpp-arg-table] @@ -134,6 +134,20 @@ dimensions = () type = integer intent = in +[ipsd0] + standard_name = initial_seed_for_mcica + long_name = initial permutaion seed for mcica radiation + units = 1 + dimensions = () + type = integer + intent = in +[ipsdlim] + standard_name = limit_for_initial_seed_for_mcica + long_name = limit for initial permutaion seed for mcica radiation + units = 1 + dimensions = () + type = integer + intent = in [ps_2delt] standard_name = surface_air_pressure_two_timesteps_back long_name = surface air pressure two timesteps back diff --git a/physics/GFS_rad_time_vary.scm.F90 b/physics/GFS_rad_time_vary.scm.F90 index 924312a2a..3f730eaf5 100644 --- a/physics/GFS_rad_time_vary.scm.F90 +++ b/physics/GFS_rad_time_vary.scm.F90 @@ -18,10 +18,10 @@ module GFS_rad_time_vary !! subroutine GFS_rad_time_vary_timestep_init (lrseeds, rseeds, & lslwr, lsswr, isubc_lw, isubc_sw, icsdsw, icsdlw, cnx, cny, isc, jsc, & - imap, jmap, sec, kdt, imp_physics, imp_physics_zhao_carr, ps_2delt, & - ps_1delt, t_2delt, t_1delt, qv_2delt, qv_1delt, t, qv, ps, errmsg, errflg) + imap, jmap, sec, kdt, imp_physics, imp_physics_zhao_carr, ipsd0, ipsdlim,& + ps_2delt, ps_1delt, t_2delt, t_1delt, qv_2delt, qv_1delt, t, qv, ps, & + errmsg, errflg) - use physparam, only: ipsd0, ipsdlim, iaerflg use mersenne_twister, only: random_setseed, random_index, random_stat use machine, only: kind_phys use radcons, only: qmin, con_100 @@ -32,7 +32,7 @@ subroutine GFS_rad_time_vary_timestep_init (lrseeds, rseeds, logical, intent(in) :: lrseeds integer, intent(in) :: rseeds(:,:) integer, intent(in) :: isubc_lw, isubc_sw, cnx, cny, isc, jsc, kdt - integer, intent(in) :: imp_physics, imp_physics_zhao_carr + integer, intent(in) :: imp_physics, imp_physics_zhao_carr, ipsd0, ipsdlim logical, intent(in) :: lslwr, lsswr integer, intent(inout) :: icsdsw(:), icsdlw(:) integer, intent(in) :: imap(:), jmap(:) diff --git a/physics/GFS_rad_time_vary.scm.meta b/physics/GFS_rad_time_vary.scm.meta index f7a154eea..19eb41dc2 100644 --- a/physics/GFS_rad_time_vary.scm.meta +++ b/physics/GFS_rad_time_vary.scm.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_rad_time_vary type = scheme - dependencies = machine.F,mersenne_twister.f,physparam.f,radcons.f90 + dependencies = machine.F,mersenne_twister.f,radcons.f90 ######################################################################## [ccpp-arg-table] @@ -134,6 +134,20 @@ dimensions = () type = integer intent = in +[ipsd0] + standard_name = initial_seed_for_mcica + long_name = initial permutaion seed for mcica radiation + units = 1 + dimensions = () + type = integer + intent = in +[ipsdlim] + standard_name = limit_for_initial_seed_for_mcica + long_name = limit for initial permutaion seed for mcica radiation + units = 1 + dimensions = () + type = integer + intent = in [ps_2delt] standard_name = surface_air_pressure_two_timesteps_back long_name = surface air pressure two timesteps back diff --git a/physics/GFS_radiation_surface.F90 b/physics/GFS_radiation_surface.F90 index 6a23cb264..feae36fbe 100644 --- a/physics/GFS_radiation_surface.F90 +++ b/physics/GFS_radiation_surface.F90 @@ -17,14 +17,15 @@ module GFS_radiation_surface !> \section arg_table_GFS_radiation_surface_init Argument Table !! \htmlinclude GFS_radiation_surface_init.html !! - subroutine GFS_radiation_surface_init (me, ialb, iems, errmsg, errflg) + subroutine GFS_radiation_surface_init (me, ialb, iems, semis_file, con_pi, errmsg, errflg) - use physparam, only: ialbflg, iemsflg use module_radiation_surface, only: sfc_init implicit none integer, intent(in) :: me, ialb, iems + character(len=26), intent(in) :: semis_file + real(kind_phys), intent(in) :: con_pi character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -32,16 +33,13 @@ subroutine GFS_radiation_surface_init (me, ialb, iems, errmsg, errflg) errmsg = '' errflg = 0 - ialbflg= ialb ! surface albedo control flag - iemsflg= iems ! surface emissivity control flag - if ( me == 0 ) then print *,'In GFS_radiation_surface_init, before calling sfc_init' print *,'ialb=',ialb,' iems=',iems end if ! Call surface initialization routine - call sfc_init ( me, errmsg, errflg ) + call sfc_init ( me, ialb, iems, semis_file, con_pi, errmsg, errflg ) end subroutine GFS_radiation_surface_init @@ -50,13 +48,13 @@ end subroutine GFS_radiation_surface_init !! \htmlinclude GFS_radiation_surface_run.html !! subroutine GFS_radiation_surface_run ( & - im, nf_albd, frac_grid, lslwr, lsswr, lsm, lsm_noahmp, lsm_ruc, & - xlat, xlon, slmsk, lndp_type, n_var_lndp, sfc_alb_pert, & + ialb, im, nf_albd, frac_grid, lslwr, lsswr, lsm, lsm_noahmp, & + lsm_ruc, xlat, xlon, slmsk, lndp_type, n_var_lndp, sfc_alb_pert,& lndp_var_list, lndp_prt_list, landfrac, snodl, snodi, sncovr, & sncovr_ice, fice, zorl, hprime, tsfg, tsfa, tisfc, coszen, & cplice, min_seaice, min_lakeice, lakefrac, use_flake, & alvsf, alnsf, alvwf, alnwf, facsf, facwf, & - semis_lnd, semis_ice, semis_wat, snoalb, use_cice_alb, & + semis_lnd, semis_ice, semis_wat, snoalb, use_cice_alb, con_ttp, & albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, & albdvis_ice, albdnir_ice, albivis_ice, albinir_ice, & semisbase, semis, sfcalb, sfc_alb_dif, errmsg, errflg) @@ -67,10 +65,10 @@ subroutine GFS_radiation_surface_run ( & implicit none - integer, intent(in) :: im, nf_albd + integer, intent(in) :: im, nf_albd, ialb logical, intent(in) :: frac_grid, lslwr, lsswr, use_cice_alb, cplice integer, intent(in) :: lsm, lsm_noahmp, lsm_ruc, lndp_type, n_var_lndp - real(kind=kind_phys), intent(in) :: min_seaice, min_lakeice + real(kind=kind_phys), intent(in) :: min_seaice, min_lakeice, con_ttp logical, dimension(:), intent(in) :: use_flake real(kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, slmsk, & @@ -184,7 +182,8 @@ subroutine GFS_radiation_surface_run ( & alvsf, alnsf, alvwf, alnwf, facsf, facwf, fice, tisfc, & albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, & albdvis_ice, albdnir_ice, albivis_ice, albinir_ice, & - im, nf_albd, sfc_alb_pert, lndp_alb, fracl, fraco, fraci, icy, & ! --- inputs + im, nf_albd, sfc_alb_pert, lndp_alb, fracl, fraco, fraci, icy, ialb, & + con_ttp, & ! --- inputs sfcalb ) ! --- outputs !> -# Approximate mean surface albedo from vis- and nir- diffuse values. diff --git a/physics/GFS_radiation_surface.meta b/physics/GFS_radiation_surface.meta index 771cd5f4d..22f2d4f0b 100644 --- a/physics/GFS_radiation_surface.meta +++ b/physics/GFS_radiation_surface.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_radiation_surface type = scheme - dependencies = iounitdef.f,machine.F,physparam.f,radiation_surface.f,set_soilveg_ruc.F90,namelist_soilveg_ruc.F90 + dependencies = iounitdef.f,machine.F,radiation_surface.f,set_soilveg_ruc.F90,namelist_soilveg_ruc.F90 ######################################################################## [ccpp-arg-table] @@ -28,6 +28,22 @@ dimensions = () type = integer intent = in +[semis_file] + standard_name = surface_emissivity_data_file + long_name = surface emissivity data file for radiation + units = none + dimensions = () + type = character + kind = len=26 + intent = in +[con_pi] + standard_name = pi + long_name = ratio of a circle's circumference to its diameter + units = none + dimensions = () + type = real + kind = kind_phys + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -55,6 +71,13 @@ dimensions = () type = integer intent = in +[ialb] + standard_name = control_for_surface_albedo + long_name = flag for using climatology alb, based on sfc type + units = flag + dimensions = () + type = integer + intent = in [nf_albd] standard_name = number_of_components_for_surface_albedo long_name = number of IR/VIS/UV compinents for surface albedo @@ -387,6 +410,14 @@ dimensions = () type = logical intent = in +[con_ttp] + standard_name = triple_point_temperature_of_water + long_name = triple point temperature of water + units = K + dimensions = () + type = real + kind = kind_phys + intent = in [albdvis_lnd] standard_name = surface_albedo_direct_visible_over_land long_name = direct surface albedo visible band over land diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index d05f02dae..c8ed0339e 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -17,9 +17,9 @@ module GFS_rrtmg_pre !! \htmlinclude GFS_rrtmg_pre_run.html !! !>\section rrtmg_pre_gen General Algorithm - subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, lextop, ltp, & - n_var_lndp, imfdeepcnv, imfdeepcnv_gf, me, ncnd, ntrac, num_p3d, & - npdf3d, ncnvcld3d, ntqv, ntcw,ntiw, ntlnc, ntinc, ntrnc, ntsnc, ntccn, & + subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& + ltp, imfdeepcnv, imfdeepcnv_gf, me, ncnd, ntrac, num_p3d, npdf3d, & + ncnvcld3d,ntqv, ntcw,ntiw, ntlnc, ntinc, ntrnc, ntsnc, ntccn, top_at_1,& ntrw, ntsw, ntgl, nthl, ntwa, ntoz, & ntclamt, nleffr, nieffr, nseffr, lndp_type, kdt, & ntdu1, ntdu2, ntdu3, ntdu4, ntdu5, ntss1, ntss2, & @@ -27,14 +27,15 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, lextop, ltp, & imp_physics,imp_physics_nssl, nssl_ccn_on, nssl_invertccn, & imp_physics_thompson, imp_physics_gfdl, imp_physics_zhao_carr, & imp_physics_zhao_carr_pdf, imp_physics_mg, imp_physics_wsm6, & - imp_physics_fer_hires, iovr_rand, iovr_maxrand, iovr_max, iovr_dcorr, & - iovr_exp, iovr_exprand, idcor_con, idcor_hogan, idcor_oreopoulos, & - julian, yearlen, lndp_var_list, lsswr, lslwr, & - ltaerosol, mraerosol, lgfdlmprad, uni_cld, effr_in, do_mynnedmf, lmfshal, & - lmfdeep2, fhswr, fhlwr, solhr, sup, con_eps, epsm1, fvirt, & - rog, rocp, con_rd, xlat_d, xlat, xlon, coslat, sinlat, tsfc, slmsk, & - prsi, prsl, prslk, tgrs, sfc_wts, mg_cld, effrr_in, pert_clds, & - sppt_wts, sppt_amp, cnvw_in, cnvc_in, qgrs, aer_nm, dx, icloud, & !inputs from here and above + imp_physics_fer_hires, iovr, iovr_rand, iovr_maxrand, iovr_max, & + iovr_dcorr, iovr_exp, iovr_exprand, idcor, idcor_con, idcor_hogan, & + idcor_oreopoulos, dcorr_con, julian, yearlen, lndp_var_list, lsswr, & + lslwr, ltaerosol, mraerosol, lgfdlmprad, uni_cld, effr_in, do_mynnedmf,& + lmfshal, lcnorm, lmfdeep2, lcrick, fhswr, fhlwr, solhr, sup, con_eps, & + epsm1, fvirt, rog, rocp, con_rd, xlat_d, xlat, xlon, coslat, sinlat, & + tsfc, slmsk, prsi, prsl, prslk, tgrs, sfc_wts, mg_cld, effrr_in, & + pert_clds, sppt_wts, sppt_amp, cnvw_in, cnvc_in, qgrs, aer_nm, dx, & + icloud, iaermdl, iaerflg, con_pi, con_g, con_ttp, con_thgni, si, & !inputs from here and above coszen, coszdg, effrl_inout, effri_inout, effrs_inout, & clouds1, clouds2, clouds3, clouds4, clouds5, qci_conv, & !in/out from here and above kd, kt, kb, mtopa, mbota, raddt, tsfg, tsfa, de_lgth, alb1d, delp, dz, & !output from here and below @@ -44,14 +45,11 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, lextop, ltp, & clouds9, cldsa, cldfra, cldfra2d, lwp_ex,iwp_ex, lwp_fc,iwp_fc, & faersw1, faersw2, faersw3, faerlw1, faerlw2, faerlw3, alpha, & aero_dir_fdb, smoke_ext, dust_ext, & - spp_wts_rad, spp_rad, rrfs_smoke_band, errmsg, errflg) + spp_wts_rad, spp_rad, rrfs_smoke_band, ico2, errmsg, errflg) use machine, only: kind_phys - use physparam - - use radcons, only: itsfc, qmin, & - qme5, qme6, epsq, prsmin + use radcons, only: itsfc, qmin, qme5, qme6, epsq, prsmin use funcphys, only: fpvs use module_radiation_astronomy,only: coszmn ! sol_init, sol_update @@ -82,7 +80,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, lextop, ltp, & make_IceNumber, & make_DropletNumber, & make_RainNumber - use physparam, only : iaermdl implicit none integer, intent(in) :: im, levs, lm, lmk, lmp, ltp, & @@ -102,9 +99,10 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, lextop, ltp, & imp_physics_mg, imp_physics_wsm6, & imp_physics_nssl, & imp_physics_fer_hires, & - yearlen, icloud + yearlen, icloud, iaermdl, iaerflg integer, intent(in) :: & + iovr, & ! choice of cloud-overlap method iovr_rand, & ! Flag for random cloud overlap method iovr_maxrand, & ! Flag for maximum-random cloud overlap method iovr_max, & ! Flag for maximum cloud overlap method @@ -112,18 +110,21 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, lextop, ltp, & iovr_exp, & ! Flag for exponential cloud overlap method iovr_exprand, & ! Flag for exponential-random cloud overlap method idcor_con, & + idcor, & idcor_hogan, & idcor_oreopoulos, & - rrfs_smoke_band ! Band number for rrfs-smoke dust and smoke + rrfs_smoke_band, & ! Band number for rrfs-smoke dust and smoke + ico2 ! Flag for co2 source used in radiation integer, intent(in) :: ntdu1, ntdu2, ntdu3, ntdu4, ntdu5, ntss1, ntss2, ntss3, & ntss4, ntss5, ntsu, ntbcb, ntbcl, ntocb, ntocl, ntchm character(len=3), dimension(:), intent(in) :: lndp_var_list - logical, intent(in) :: lextop, lsswr, lslwr, ltaerosol, lgfdlmprad, & + logical, intent(in) :: lsswr, lslwr, ltaerosol, lgfdlmprad, & uni_cld, effr_in, do_mynnedmf, & - lmfshal, lmfdeep2, pert_clds, mraerosol + lmfshal, lmfdeep2, pert_clds, lcrick,& + lcnorm, top_at_1, lextop, mraerosol logical, intent(in) :: aero_dir_fdb real(kind=kind_phys), dimension(:,:), intent(in) :: smoke_ext, dust_ext @@ -131,12 +132,12 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, lextop, ltp, & integer, intent(in) :: spp_rad real(kind_phys), intent(in) :: spp_wts_rad(:,:) - real(kind=kind_phys), intent(in) :: fhswr, fhlwr, solhr, sup, julian, sppt_amp - real(kind=kind_phys), intent(in) :: con_eps, epsm1, fvirt, rog, rocp, con_rd + real(kind=kind_phys), intent(in) :: fhswr, fhlwr, solhr, sup, julian, sppt_amp, dcorr_con + real(kind=kind_phys), intent(in) :: con_eps, epsm1, fvirt, rog, rocp, con_rd, con_pi, con_g, con_ttp, con_thgni real(kind=kind_phys), dimension(:), intent(in) :: xlat_d, xlat, xlon, & coslat, sinlat, tsfc, & - slmsk, dx + slmsk, dx, si real(kind=kind_phys), dimension(:,:), intent(in) :: prsi, prsl, prslk, & tgrs, sfc_wts, & @@ -202,7 +203,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, lextop, ltp, & faerlw2,& faerlw3 real(kind=kind_phys), dimension(:,:), intent(out) :: alpha - character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -285,7 +285,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, lextop, ltp, & ! variables if ( lextop ) then - if ( ivflip == 1 ) then ! vertical from sfc upward + if (.not. top_at_1) then ! vertical from sfc upward kd = 0 ! index diff between in/out and local kt = 1 ! index diff between lyr and upper bound kb = 0 ! index diff between lyr and lower bound @@ -301,16 +301,16 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, lextop, ltp, & llb = 1 ! local index at toa level lya = 2 ! local index for the 2nd layer from top lyb = 1 ! local index for the top layer - endif ! end if_ivflip_block + endif ! end if_top_at_1_block else kd = 0 - if ( ivflip == 1 ) then ! vertical from sfc upward + if (.not. top_at_1) then ! vertical from sfc upward kt = 1 ! index diff between lyr and upper bound kb = 0 ! index diff between lyr and lower bound else ! vertical from toa downward kt = 0 ! index diff between lyr and upper bound kb = 1 ! index diff between lyr and lower bound - endif ! end if_ivflip_block + endif ! end if_top_at_1_block endif ! end if_lextop_block raddt = min(fhswr, fhlwr) @@ -337,7 +337,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, lextop, ltp, & ! lsk = 0 - if (ivflip == 0 .and. lm < levs) lsk = levs - lm + if (top_at_1 .and. lm < levs) lsk = levs - lm ! convert pressure unit from pa to mb do k = 1, LM @@ -368,7 +368,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, lextop, ltp, & enddo enddo ! - if (ivflip == 0) then ! input data from toa to sfc + if (top_at_1) then ! input data from toa to sfc if (lsk > 0) then k1 = 1 + kd k2 = k1 + kb @@ -427,8 +427,8 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, lextop, ltp, & enddo enddo else ! climatological ozone - call getozn (prslk1, xlat, im, lmk, & ! --- inputs - olyr) ! --- outputs + call getozn (prslk1, xlat, im, lmk, top_at_1, & ! --- inputs + olyr) ! --- outputs endif ! end_if_ntoz !> - Call coszmn(), to compute cosine of zenith angle (only when SW is called) @@ -452,8 +452,8 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, lextop, ltp, & ! --- ... set up non-prognostic gas volume mixing ratioes - call getgases (plvl, xlon, xlat, IM, LMK, & ! --- inputs - gasvmr) ! --- outputs + call getgases (plvl, xlon, xlat, IM, LMK, ico2, top_at_1,& ! --- inputs + con_pi, gasvmr) ! --- outputs !CCPP: re-assign gasvmr(:,:,NF_VGAS) to gasvmr_X(:,:) do k = 1, LMK @@ -479,7 +479,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, lextop, ltp, & enddo enddo - if (ivflip == 0) then ! input data from toa to sfc + if (top_at_1) then ! input data from toa to sfc do i = 1, IM tem1d (i) = QME6 tem2da(i,1) = log( plyr(i,1) ) @@ -609,7 +609,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, lextop, ltp, & dzb(i,1) = hzb(i,1) - hz(i,1) enddo - endif ! end_if_ivflip + endif ! end_if_top_at_1 !check print *,' in grrad : calling setaer ' @@ -642,8 +642,8 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, lextop, ltp, & !! property profile for radiation. call setaer (plvl, plyr, prslk1, tvly, rhly, slmsk, & ! --- inputs tracer1, aer_nm, xlon, xlat, IM, LMK, LMP,& - lsswr,lslwr, & - faersw,faerlw,aerodp) ! --- outputs + lsswr, lslwr, iaermdl, iaerflg, top_at_1, con_pi, & + con_rd, con_g, faersw, faerlw, aerodp, errflg, errmsg) ! --- outputs ! CCPP do j = 1,NBDSW @@ -961,20 +961,21 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, lextop, ltp, & & ( plyr, plvl, tlyr, tvly, qlyr, qstl, rhly, & ! --- inputs: & ccnd, ncndl, cnvw, cnvc, tracer1, & & xlat, xlon, slmsk, dz, delp, IM, LM, LMK, LMP, & - & deltaq, sup, me, icloud, kdt, & + & deltaq, sup, dcorr_con, me, icloud, kdt, & & ntrac, ntcw, ntiw, ntrw, ntsw, ntgl, ntclamt, & & imp_physics, imp_physics_nssl, imp_physics_fer_hires, & & imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, & & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & - & imp_physics_mg, iovr_rand, iovr_maxrand, iovr_max, & - & iovr_dcorr, iovr_exp, iovr_exprand, idcor_con, & - & idcor_hogan, idcor_oreopoulos, & + & imp_physics_mg, iovr, iovr_rand, iovr_maxrand, iovr_max, & + & iovr_dcorr, iovr_exp, iovr_exprand, idcor, idcor_con, & + & idcor_hogan, idcor_oreopoulos, lcrick, lcnorm, & & imfdeepcnv, imfdeepcnv_gf, do_mynnedmf, lgfdlmprad, & & uni_cld, lmfshal, lmfdeep2, cldcov, clouds1, & & effrl, effri, effrr, effrs, effr_in, & & effrl_inout, effri_inout, effrs_inout, & & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & - & dzb, xlat_d, julian, yearlen, gridkm, & + & dzb, xlat_d, julian, yearlen, gridkm, top_at_1, si, & + & con_ttp, con_pi, con_g, con_rd, con_thgni, & & cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, & ! --- outputs: & cld_rwp, cld_rerain, cld_swp, cld_resnow, & ! --- outputs: & cldsa, mtopa, mbota, de_lgth, alpha & ! --- outputs: diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 63ab11d3e..53f05225b 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -2,7 +2,7 @@ name = GFS_rrtmg_pre type = scheme dependencies = funcphys.f90,iounitdef.f,machine.F,module_bfmicrophysics.f,module_mp_radar.F90,module_mp_thompson.F90 - dependencies = module_mp_thompson_make_number_concentrations.F90,physcons.F90,physparam.f,radcons.f90,radiation_aerosols.f + dependencies = module_mp_thompson_make_number_concentrations.F90,radcons.f90,radiation_aerosols.f dependencies = radiation_astronomy.f,radiation_clouds.f,radiation_gases.f,radlw_param.f,radsw_param.f,surface_perturbation.F90,radiation_cloud_overlap.F90 ######################################################################## @@ -219,6 +219,20 @@ dimensions = () type = integer intent = in +[iaermdl] + standard_name = control_for_aerosol_radiation_scheme + long_name = control of aerosol scheme in radiation + units = 1 + dimensions = () + type = integer + intent = in +[iaerflg] + standard_name = control_for_aerosol_effects_in_radiation + long_name = control of aerosol effects in radiation + units = 1 + dimensions = () + type = integer + intent = in [nssl_ccn_on] standard_name = nssl_ccn_on long_name = CCN activation flag in NSSL micro @@ -450,6 +464,13 @@ dimensions = () type = integer intent = in +[iovr] + standard_name = flag_for_cloud_overlap_method_for_radiation + long_name = max-random overlap clouds + units = flag + dimensions = () + type = integer + intent = in [iovr_rand] standard_name = flag_for_random_cloud_overlap_method long_name = choice of random cloud overlap method @@ -492,6 +513,20 @@ dimensions = () type = integer intent = in +[dcorr_con] + standard_name = decorrelation_length_used_by_overlap_method + long_name = decorrelation length (default) used by cloud overlap method (iovr) + units = km + dimensions = () + type = real + intent = in +[idcor] + standard_name = flag_for_decorrelation_length_method + long_name = flag for decorrelation length method used in cloud overlap method (iovr) + units = flag + dimensions = () + type = integer + intent = in [idcor_con] standard_name = flag_for_constant_decorrelation_length_method long_name = choice of decorrelation length computation (costant) @@ -606,6 +641,20 @@ dimensions = () type = logical intent = in +[lcrick] + standard_name = flag_for_CRICK_proof_cloud_water + long_name = flag for CRICK-Proof cloud water + units = flag + dimensions = () + type = logical + intent = in +[lcnorm] + standard_name = flag_for_in_cloud_condensate + long_name = flag for cloud condensate normalized by cloud cover + units = flag + dimensions = () + type = logical + intent = in [fhswr] standard_name = period_of_shortwave_radiation_calls long_name = frequency for shortwave radiation @@ -646,6 +695,46 @@ type = real kind = kind_phys intent = in +[con_pi] + standard_name = pi + long_name = ratio of a circle's circumference to its diameter + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rd] + standard_name = gas_constant_of_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_ttp] + standard_name = triple_point_temperature_of_water + long_name = triple point temperature of water + units = K + dimensions = () + type = real + kind = kind_phys + intent = in +[con_thgni] + standard_name = temperature_ice_nucleation_starts + long_name = temperature the H.G.Nuc. ice starts + units = K + dimensions = () + type = real + kind = kind_phys + intent = in [epsm1] standard_name = ratio_of_dry_air_to_water_vapor_gas_constants_minus_one long_name = (rd/rv) - 1 @@ -678,14 +767,6 @@ type = real kind = kind_phys intent = in -[con_rd] - standard_name = gas_constant_of_dry_air - long_name = ideal gas constant for dry air - units = J kg-1 K-1 - dimensions = () - type = real - kind = kind_phys - intent = in [xlat_d] standard_name = latitude_in_degree long_name = latitude in degree north @@ -1327,6 +1408,28 @@ type = real kind = kind_phys intent = out +[top_at_1] + standard_name = flag_for_vertical_ordering_in_radiation + long_name = flag for vertical ordering in radiation + units = flag + dimensions = () + type = logical + intent = in +[si] + standard_name = sigma_pressure_hybrid_vertical_coordinate + long_name = vertical sigma coordinate for radiation initialization + units = none + dimensions = (vertical_interface_dimension) + type = real + kind = kind_phys + intent = in +[ico2] + standard_name = control_for_co2 + long_name = prescribed global mean value (old opernl) + units = flag + dimensions = () + type = integer + intent = in [aero_dir_fdb] standard_name = do_smoke_aerosol_direct_feedback long_name = flag for smoke and dust radiation feedback diff --git a/physics/GFS_rrtmg_setup.F90 b/physics/GFS_rrtmg_setup.F90 index 86d8fab7b..384d5252d 100644 --- a/physics/GFS_rrtmg_setup.F90 +++ b/physics/GFS_rrtmg_setup.F90 @@ -6,12 +6,7 @@ !> @{ module GFS_rrtmg_setup - use physparam, only : isolar , ictmflg, ico2flg, ioznflg, iaerflg, & - & iaermdl, icldflg, & - & iovrRad=>iovr, lcrick , lcnorm , lnoprec, & - & isubcsw, isubclw, ivflip , ipsd0, & - & iswcliq, & - & kind_phys + use machine, only: kind_phys implicit none @@ -27,14 +22,14 @@ module GFS_rrtmg_setup ! & VTAGRAD='NCEP-Radiation_driver v5.1 Nov 2012 ' ! & VTAGRAD='NCEP-Radiation_driver v5.0 Aug 2012 ' - !> new data input control variables (set/reset in subroutines radinit/radupdate): + !> new data input control variables (set/reset in subroutine radupdate): integer :: month0 = 0 integer :: iyear0 = 0 integer :: monthd = 0 !> control flag for the first time of reading climatological ozone data !! (set/reset in subroutines radinit/radupdate, it is used only if the - !! control parameter ioznflg=0) + !! control parameter ntoz=0) logical :: loz1st = .true. contains @@ -42,13 +37,14 @@ module GFS_rrtmg_setup !> \section arg_table_GFS_rrtmg_setup_init Argument Table !! \htmlinclude GFS_rrtmg_setup_init.html !! - subroutine GFS_rrtmg_setup_init ( & - si, levr, ictm, isol, ico2, iaer, ntcw, & - num_p3d, npdf3d, ntoz, iovr, isubc_sw, isubc_lw, & - icliq_sw, crick_proof, ccnorm, & - imp_physics, & - norad_precip, idate, iflip, & - do_RRTMGP, me, ltp, lextop, errmsg, errflg) + subroutine GFS_rrtmg_setup_init ( si, levr, ictm, isol, solar_file, ico2, & + iaer, ntcw, num_p3d, npdf3d, ntoz, iovr, iovr_rand, iovr_maxrand, & + iovr_max, iovr_dcorr, iovr_exp, iovr_exprand, icliq_sw, lcrick, & + lcnorm, imp_physics, lnoprec, idate, iflip, do_RRTMGP, me, lalw1bd, & + iaermdl, iaerflg, aeros_file, con_pi, con_t0c, con_c, con_boltz, & + con_plnk, con_solr_2008, con_solr_2002, con_g, con_rd, co2usr_file, & + co2cyc_file, rad_hr_units, inc_minor_gas, icliq_lw, isubcsw, isubclw,& + iswmode, ipsd0, ltp, lextop, errmsg, errflg) ! ================= subprogram documentation block ================ ! ! ! ! subprogram: GFS_rrtmg_setup_init - a subprogram to initialize radiation ! @@ -125,14 +121,14 @@ subroutine GFS_rrtmg_setup_init ( & ! =1: max/ran overlapping clouds ! ! =2: maximum overlap clouds (mcica only) ! ! =3: decorrelation-length overlap (mcica only) ! -! =4: exponential overlap clouds -! isubc_sw/isubc_lw: sub-column cloud approx control flag (sw/lw rad) ! +! =4: exponential overlap clouds ! +! isubcsw/isubclw: sub-column cloud approx control flag (sw/lw rad) ! ! =0: with out sub-column cloud approximation ! ! =1: mcica sub-col approx. prescribed random seed ! ! =2: mcica sub-col approx. provided random seed ! -! crick_proof : control flag for eliminating CRICK ! -! ccnorm : control flag for in-cloud condensate mixing ratio! -! norad_precip : control flag for not using precip in radiation ! +! lcrick : control flag for eliminating CRICK ! +! lcnorm : control flag for in-cloud condensate mixing ratio! +! lnoprec : control flag for not using precip in radiation ! ! idate(4) : ncep absolute date and time of initial condition ! ! (hour, month, day, year) ! ! iflip : control flag for direction of vertical index ! @@ -146,35 +142,31 @@ subroutine GFS_rrtmg_setup_init ( & ! ! ! =================================================================== ! ! + use module_radiation_astronomy, only : sol_init + use module_radiation_aerosols, only : aer_init + use module_radiation_gases, only : gas_init + use module_radiation_clouds, only : cld_init + use rrtmg_lw, only : rlwinit + use rrtmg_sw, only : rswinit implicit none ! interface variables real (kind=kind_phys), intent(in) :: si(:) - integer, intent(in) :: levr - integer, intent(in) :: ictm - integer, intent(in) :: isol - integer, intent(in) :: ico2 - integer, intent(in) :: iaer - integer, intent(in) :: ntcw - integer, intent(in) :: num_p3d - integer, intent(in) :: npdf3d - integer, intent(in) :: ntoz - integer, intent(in) :: iovr - integer, intent(in) :: isubc_sw - integer, intent(in) :: isubc_lw - integer, intent(in) :: icliq_sw - logical, intent(in) :: crick_proof - logical, intent(in) :: ccnorm - integer, intent(in) :: imp_physics - logical, intent(in) :: norad_precip + integer, intent(in) :: levr, ictm, isol, ico2, iaer, ntcw, num_p3d, & + ltp, npdf3d, ntoz, iovr, iovr_rand, iovr_maxrand, iovr_max, & + iovr_dcorr, iovr_exp, iovr_exprand, icliq_sw, imp_physics, & + iflip, me, rad_hr_units, icliq_lw, isubcsw, isubclw, iswmode integer, intent(in) :: idate(:) - integer, intent(in) :: iflip - logical, intent(in) :: do_RRTMGP - integer, intent(in) :: me - integer, intent(in) :: ltp - logical, intent(in) :: lextop + logical, intent(in) :: lcrick, lcnorm, lnoprec, do_RRTMGP, lalw1bd, & + inc_minor_gas, lextop + character(len=26),intent(in) :: aeros_file, solar_file, co2usr_file,& + co2cyc_file + real(kind_phys), intent(in) :: con_pi, con_t0c, con_c, con_boltz, & + con_plnk, con_solr_2008, con_solr_2002, con_g, con_rd + integer, intent(inout) :: ipsd0 character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg + integer, intent(out) :: iaermdl, iaerflg ! Initialize the CCPP error handling variables errmsg = '' @@ -188,11 +180,6 @@ subroutine GFS_rrtmg_setup_init ( & return end if - isolar = isol ! solar constant control flag - ictmflg= ictm ! data ic time/date control flag - ico2flg= ico2 ! co2 data source control flag - ioznflg= ntoz ! ozone data source control flag - if ( ictm==0 .or. ictm==-2 ) then iaerflg = mod(iaer, 100) ! no volcanic aerosols for clim hindcast else @@ -201,58 +188,50 @@ subroutine GFS_rrtmg_setup_init ( & iaermdl = iaer/1000 ! control flag for aerosol scheme selection if ( iaermdl < 0 .or. (iaermdl>2 .and. iaermdl/=5) ) then print *, ' Error -- IAER flag is incorrect, Abort' - stop 7777 + errflg = 1 + errmsg = 'ERROR(GFS_rrtmg_setup): IAER flag is incorrect' + return endif -! if ( ntcw > 0 ) then - icldflg = 1 ! prognostic cloud optical prop scheme -! else -! icldflg = 0 ! no support for diag cloud opt prop scheme -! endif - - iswcliq = icliq_sw ! optical property for liquid clouds for sw - - ! iovr comes from the model. In the RRTMG implementation this is stored in phyrparam.f, - ! it comes in from the host-model and is set here. - ! In GP, iovr is passed directly into the routines. - iovrRAD = iovr - lcrick = crick_proof ! control flag for eliminating CRICK - lcnorm = ccnorm ! control flag for in-cld condensate - lnoprec = norad_precip ! precip effect on radiation flag (ferrier microphysics) - isubcsw = isubc_sw ! sub-column cloud approx flag in sw radiation - isubclw = isubc_lw ! sub-column cloud approx flag in lw radiation - - ivflip = iflip ! vertical index direction control flag - ! --- assign initial permutation seed for mcica cloud-radiation - if ( isubc_sw>0 .or. isubc_lw>0 ) then + if ( isubcsw>0 .or. isubclw>0 ) then ! ipsd0 = 17*idate(1)+43*idate(2)+37*idate(3)+23*idate(4) + ipsd0 ipsd0 = 17*idate(1)+43*idate(2)+37*idate(3)+23*idate(4) endif if ( me == 0 ) then - print *,' In rad_initialize (GFS_rrtmg_setup_init), before calling radinit' - print *,' si =',si - print *,' levr=',levr,' ictm=',ictm,' isol=',isol,' ico2=',ico2,& - & ' iaermdl=',iaermdl,' iaerflg=',iaerflg - print *,' np3d=',num_p3d,' ntoz=',ntoz, & - & ' iovr=',iovr,' isubc_sw=',isubc_sw, & - & ' isubc_lw=',isubc_lw,' icliq_sw=',icliq_sw, & - & ' iflip=',iflip,' me=',me - print *,' crick_proof=',crick_proof, & - & ' ccnorm=',ccnorm,' norad_precip=',norad_precip + print *,' In rad_initialize (GFS_rrtmg_setup_init), before calling RRTMG initialization' + print *,' si =',si + print *,' levr=',levr,' ictm=',ictm,' isol=',isol,' ico2=',ico2,& + ' iaermdl=',iaermdl,' iaerflg=',iaerflg + print *,' np3d=',num_p3d,' ntoz=',ntoz, & + ' iovr=',iovr,' isubcsw=',isubcsw, & + ' isubclw=',isubclw,' icliq_sw=',icliq_sw, & + ' iflip=',iflip,' me=',me + print *,' lcrick=',lcrick, & + ' lcnorm=',lcnorm,' lnoprec=',lnoprec + print *, 'lextop=',lextop, ' ltp=',ltp endif - call radinit & -! --- inputs: - & ( si, levr, imp_physics, me, ltp, lextop ) -! --- outputs: -! ( none ) + ! Call initialization routines + call sol_init ( me, isol, solar_file, con_solr_2008,con_solr_2002,& + con_pi ) + call aer_init ( levr, me, iaermdl, iaerflg, lalw1bd, aeros_file, & + con_pi, con_t0c, con_c, con_boltz, con_plnk, errflg, errmsg) + call gas_init ( me, co2usr_file, co2cyc_file, ico2, ictm, ntoz, & + con_pi, errflg, errmsg) + call cld_init ( si, levr, imp_physics, me, con_g, con_rd, errflg, errmsg) + call rlwinit ( me, rad_hr_units, inc_minor_gas, icliq_lw, isubcsw, & + iovr, iovr_rand, iovr_maxrand, iovr_max, iovr_dcorr, & + iovr_exp, iovr_exprand, errflg, errmsg ) + call rswinit ( me, rad_hr_units, inc_minor_gas, icliq_sw, isubclw, & + iovr, iovr_rand, iovr_maxrand, iovr_max, iovr_dcorr, & + iovr_exp, iovr_exprand,iswmode, errflg, errmsg ) if ( me == 0 ) then print *,' Radiation sub-cloud initial seed =',ipsd0, & & ' IC-idate =',idate - print *,' return from rad_initialize (GFS_rrtmg_setup_init) - after calling radinit' + print *,' return from rad_initialize (GFS_rrtmg_setup_init) - after calling RRTMG initialization' endif ! is_initialized = .true. @@ -264,9 +243,9 @@ end subroutine GFS_rrtmg_setup_init !> \section arg_table_GFS_rrtmg_setup_timestep_init Argument Table !! \htmlinclude GFS_rrtmg_setup_timestep_init.html !! - subroutine GFS_rrtmg_setup_timestep_init ( & - idate, jdate, deltsw, deltim, lsswr, me, & - slag, sdec, cdec, solcon, errmsg, errflg) + subroutine GFS_rrtmg_setup_timestep_init (idate, jdate, deltsw, deltim, & + lsswr, me, iaermdl, iaerflg, isol, aeros_file, slag, sdec, cdec, & + solcon, con_pi, co2dat_file, co2gbl_file, ictm, ico2, ntoz, errmsg, errflg) implicit none @@ -275,8 +254,11 @@ subroutine GFS_rrtmg_setup_timestep_init ( & integer, intent(in) :: jdate(:) real(kind=kind_phys), intent(in) :: deltsw real(kind=kind_phys), intent(in) :: deltim + real(kind=kind_phys), intent(in) :: con_pi logical, intent(in) :: lsswr integer, intent(in) :: me + integer, intent(in) :: iaermdl, iaerflg, isol, ictm, ico2, ntoz + character(len=26), intent(in) :: aeros_file, co2dat_file, co2gbl_file real(kind=kind_phys), intent(out) :: slag real(kind=kind_phys), intent(out) :: sdec real(kind=kind_phys), intent(out) :: cdec @@ -295,8 +277,8 @@ subroutine GFS_rrtmg_setup_timestep_init ( & errmsg = '' errflg = 0 - call radupdate(idate,jdate,deltsw,deltim,lsswr,me, & - slag,sdec,cdec,solcon) + call radupdate(idate,jdate,deltsw,deltim,lsswr,me,iaermdl, iaerflg,isol,aeros_file,& + slag,sdec,cdec,solcon,con_pi,co2dat_file,co2gbl_file,ictm,ico2,ntoz,errflg,errmsg) end subroutine GFS_rrtmg_setup_timestep_init @@ -322,229 +304,6 @@ subroutine GFS_rrtmg_setup_finalize (errmsg, errflg) end subroutine GFS_rrtmg_setup_finalize - -! Private functions - -!>Initialization of radiation calculations. - subroutine radinit( si, NLAY, imp_physics, me, ltp, lextop ) -!................................... - -! --- inputs: -! & ( si, NLAY, imp_physics, me ) -! --- outputs: -! ( none ) - -! ================= subprogram documentation block ================ ! -! ! -! subprogram: radinit initialization of radiation calculations ! -! ! -! usage: call radinit ! -! ! -! attributes: ! -! language: fortran 90 ! -! machine: wcoss ! -! ! -! ==================== definition of variables ==================== ! -! ! -! input parameters: ! -! si : model vertical sigma interface ! -! NLAY : number of model vertical layers ! -! imp_physics : MP identifier ! -! me : print control flag ! -! ! -! outputs: (none) ! -! ! -! external module variables: (in module physparam) ! -! isolar : solar constant cntrol flag ! -! = 0: use the old fixed solar constant in "physcon" ! -! =10: use the new fixed solar constant in "physcon" ! -! = 1: use noaa ann-mean tsi tbl abs-scale with cycle apprx! -! = 2: use noaa ann-mean tsi tbl tim-scale with cycle apprx! -! = 3: use cmip5 ann-mean tsi tbl tim-scale with cycl apprx! -! = 4: use cmip5 mon-mean tsi tbl tim-scale with cycl apprx! -! iaerflg : 3-digit aerosol flag (abc for volc, lw, sw) ! -! a:=0 use background stratospheric aerosol ! -! =1 include stratospheric vocanic aeros ! -! b:=0 no topospheric aerosol in lw radiation ! -! =1 compute tropspheric aero in 1 broad band for lw ! -! =2 compute tropspheric aero in multi bands for lw ! -! c:=0 no topospheric aerosol in sw radiation ! -! =1 include tropspheric aerosols for sw ! -! ico2flg : co2 data source control flag ! -! =0: use prescribed global mean co2 (old oper) ! -! =1: use observed co2 annual mean value only ! -! =2: use obs co2 monthly data with 2-d variation ! -! ictmflg : =yyyy#, external data ic time/date control flag ! -! = -2: same as 0, but superimpose seasonal cycle ! -! from climatology data set. ! -! = -1: use user provided external data for the ! -! forecast time, no extrapolation. ! -! = 0: use data at initial cond time, if not ! -! available, use latest, no extrapolation. ! -! = 1: use data at the forecast time, if not ! -! available, use latest and extrapolation. ! -! =yyyy0: use yyyy data for the forecast time, ! -! no further data extrapolation. ! -! =yyyy1: use yyyy data for the fcst. if needed, do ! -! extrapolation to match the fcst time. ! -! ioznflg : ozone data source control flag ! -! =0: use climatological ozone profile ! -! =1: use interactive ozone profile ! -! icldflg : cloud optical property scheme control flag ! -! =0: use diagnostic cloud scheme ! -! =1: use prognostic cloud scheme (default) ! -! imp_physics : cloud microphysics scheme control flag ! -! =99 zhao/carr/sundqvist microphysics scheme ! -! =98 zhao/carr/sundqvist microphysics+pdf cloud&cnvc,cnvw ! -! =11 GFDL cloud microphysics ! -! =8 Thompson microphysics scheme ! -! =6 WSM6 microphysics scheme ! -! =10 MG microphysics scheme ! -! iovr : control flag for cloud overlap in radiation ! -! =0: random overlapping clouds ! -! =1: max/ran overlapping clouds ! -! isubcsw : sub-column cloud approx control flag in sw radiation ! -! isubclw : sub-column cloud approx control flag in lw radiation ! -! =0: with out sub-column cloud approximation ! -! =1: mcica sub-col approx. prescribed random seed ! -! =2: mcica sub-col approx. provided random seed ! -! lcrick : control flag for eliminating CRICK ! -! =t: apply layer smoothing to eliminate CRICK ! -! =f: do not apply layer smoothing ! -! lcnorm : control flag for in-cld condensate ! -! =t: normalize cloud condensate ! -! =f: not normalize cloud condensate ! -! lnoprec : precip effect in radiation flag (ferrier microphysics) ! -! =t: snow/rain has no impact on radiation ! -! =f: snow/rain has impact on radiation ! -! ivflip : vertical index direction control flag ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! ! -! subroutines called: sol_init, aer_init, gas_init, cld_init, ! -! rlwinit, rswinit ! -! ! -! usage: call radinit ! -! ! -! =================================================================== ! -! - - use module_radiation_astronomy, only : sol_init - use module_radiation_aerosols, only : aer_init - use module_radiation_gases, only : gas_init - use module_radiation_clouds, only : cld_init - use rrtmg_lw, only : rlwinit - use rrtmg_sw, only : rswinit - - implicit none - -! --- inputs: - integer, intent(in) :: NLAY, me, imp_physics, ltp - logical, intent(in) :: lextop - - real (kind=kind_phys), intent(in) :: si(:) - -! --- outputs: (none, to module variables) - -! --- locals: - -! -!===> ... begin here -! -!> -# Set up control variables and external module variables in -!! module physparam - loz1st = (ioznflg == 0) ! first-time clim ozone data read flag - month0 = 0 - iyear0 = 0 - monthd = 0 - - if (me == 0) then -! print *,' NEW RADIATION PROGRAM STRUCTURES -- SEP 01 2004' - print *,' NEW RADIATION PROGRAM STRUCTURES BECAME OPER. ', & - & ' May 01 2007' - print *, VTAGRAD !print out version tag - print *,' - Selected Control Flag settings: ICTMflg=',ictmflg, & - & ' ISOLar =',isolar, ' ICO2flg=',ico2flg,' IAERflg=',iaerflg, & - & ' ICLDflg=',icldflg, & - & ' IMP_PHYSICS=',imp_physics,' IOZNflg=',ioznflg - print *,' IVFLIP=',ivflip,' IOVR=',iovrRad, & - & ' ISUBCSW=',isubcsw,' ISUBCLW=',isubclw - print *,' LCRICK=',lcrick,' LCNORM=',lcnorm,' LNOPREC=',lnoprec - print *,' LTP =',ltp,', add extra top layer =',lextop - - if ( ictmflg==0 .or. ictmflg==-2 ) then - print *,' Data usage is limited by initial condition!' - print *,' No volcanic aerosols' - endif - - if ( isubclw == 0 ) then - print *,' - ISUBCLW=',isubclw,' No McICA, use grid ', & - & 'averaged cloud in LW radiation' - elseif ( isubclw == 1 ) then - print *,' - ISUBCLW=',isubclw,' Use McICA with fixed ', & - & 'permutation seeds for LW random number generator' - elseif ( isubclw == 2 ) then - print *,' - ISUBCLW=',isubclw,' Use McICA with random ', & - & 'permutation seeds for LW random number generator' - else - print *,' - ERROR!!! ISUBCLW=',isubclw,' is not a ', & - & 'valid option ' - stop - endif - - if ( isubcsw == 0 ) then - print *,' - ISUBCSW=',isubcsw,' No McICA, use grid ', & - & 'averaged cloud in SW radiation' - elseif ( isubcsw == 1 ) then - print *,' - ISUBCSW=',isubcsw,' Use McICA with fixed ', & - & 'permutation seeds for SW random number generator' - elseif ( isubcsw == 2 ) then - print *,' - ISUBCSW=',isubcsw,' Use McICA with random ', & - & 'permutation seeds for SW random number generator' - else - print *,' - ERROR!!! ISUBCSW=',isubcsw,' is not a ', & - & 'valid option ' - stop - endif - - if ( isubcsw /= isubclw ) then - print *,' - *** Notice *** ISUBCSW /= ISUBCLW !!!', & - & isubcsw, isubclw - endif - endif - -!> -# Initialization -!! - astronomy initialization routine: -!! call module_radiation_astronomy::sol_init() -!! - aerosols initialization routine: -!! call module_radiation_aerosols::aer_init() -!! - CO2 and other gases intialization routine: -!! call module_radiation_gases::gas_init() -!! - cloud initialization routine: -!! call module_radiation_clouds::cld_init() -!! - LW radiation initialization routine: -!! call module_radlw_main::rlwinit() -!! - SW radiation initialization routine: -!! call module_radsw_main::rswinit() -! Initialization - - call sol_init ( me ) ! --- ... astronomy initialization routine - - call aer_init ( NLAY, me ) ! --- ... aerosols initialization routine - - call gas_init ( me ) ! --- ... co2 and other gases initialization routine - - call cld_init ( si, NLAY, imp_physics, me) ! --- ... cloud initialization routine - - call rlwinit ( me ) ! --- ... lw radiation initialization routine - - call rswinit ( me ) ! --- ... sw radiation initialization routine -! - return -! - end subroutine radinit - !----------------------------------- - !> This subroutine checks and updates time sensitive data used by !! radiation computations. This subroutine needs to be placed inside !! the time advancement loop but outside of the horizontal grid loop. @@ -565,8 +324,9 @@ end subroutine radinit !! \param solcon solar constant adjusted by sun-earth distance \f$(W/m^2)\f$ !> \section gen_radupdate General Algorithm !----------------------------------- - subroutine radupdate( idate,jdate,deltsw,deltim,lsswr, me, & - & slag,sdec,cdec,solcon) + subroutine radupdate( idate,jdate,deltsw,deltim,lsswr,me, iaermdl,& + iaerflg, isol, aeros_file, slag,sdec,cdec,solcon, con_pi, & + co2dat_file,co2gbl_file, ictm, ico2, ntoz, errflg, errmsg) !................................... ! ================= subprogram documentation block ================ ! @@ -598,31 +358,6 @@ subroutine radupdate( idate,jdate,deltsw,deltim,lsswr, me, & ! sdec, cdec : sin and cos of the solar declination angle ! ! solcon : sun-earth distance adjusted solar constant (w/m2) ! ! ! -! external module variables: ! -! isolar : solar constant cntrl (in module physparam) ! -! = 0: use the old fixed solar constant in "physcon" ! -! =10: use the new fixed solar constant in "physcon" ! -! = 1: use noaa ann-mean tsi tbl abs-scale with cycle apprx! -! = 2: use noaa ann-mean tsi tbl tim-scale with cycle apprx! -! = 3: use cmip5 ann-mean tsi tbl tim-scale with cycl apprx! -! = 4: use cmip5 mon-mean tsi tbl tim-scale with cycl apprx! -! ictmflg : =yyyy#, external data ic time/date control flag ! -! = -2: same as 0, but superimpose seasonal cycle ! -! from climatology data set. ! -! = -1: use user provided external data for the ! -! forecast time, no extrapolation. ! -! = 0: use data at initial cond time, if not ! -! available, use latest, no extrapolation. ! -! = 1: use data at the forecast time, if not ! -! available, use latest and extrapolation. ! -! =yyyy0: use yyyy data for the forecast time, ! -! no further data extrapolation. ! -! =yyyy1: use yyyy data for the fcst. if needed, do ! -! extrapolation to match the fcst time. ! -! ! -! module variables: ! -! loz1st : first-time clim ozone data read flag ! -! ! ! subroutines called: sol_update, aer_update, gas_update ! ! ! ! =================================================================== ! @@ -634,13 +369,16 @@ subroutine radupdate( idate,jdate,deltsw,deltim,lsswr, me, & implicit none ! --- inputs: - integer, intent(in) :: idate(:), jdate(:), me + integer, intent(in) :: idate(:), jdate(:), me, iaermdl, iaerflg, isol, ictm, ntoz, ico2 logical, intent(in) :: lsswr + character(len=26),intent(in) :: aeros_file,co2dat_file,co2gbl_file - real (kind=kind_phys), intent(in) :: deltsw, deltim + real (kind=kind_phys), intent(in) :: deltsw, deltim, con_pi ! --- outputs: real (kind=kind_phys), intent(out) :: slag, sdec, cdec, solcon + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg ! --- locals: integer :: iyear, imon, iday, ihour @@ -652,6 +390,11 @@ subroutine radupdate( idate,jdate,deltsw,deltim,lsswr, me, & ! !===> ... begin here ! + + ! Initialize the CCPP error handling variables + errmsg = '' + errflg = 0 + !> -# Set up time stamp at fcst time and that for green house gases !! (currently co2 only) ! --- ... time stamp at fcst time @@ -663,7 +406,7 @@ subroutine radupdate( idate,jdate,deltsw,deltim,lsswr, me, & ! --- ... set up time stamp used for green house gases (** currently co2 only) - if ( ictmflg==0 .or. ictmflg==-2 ) then ! get external data at initial condition time + if ( ictm==0 .or. ictm==-2 ) then ! get external data at initial condition time kyear = idate(1) kmon = idate(2) kday = idate(3) @@ -673,7 +416,7 @@ subroutine radupdate( idate,jdate,deltsw,deltim,lsswr, me, & kmon = imon kday = iday khour = ihour - endif ! end if_ictmflg_block + endif ! end if_ictm_block if ( month0 /= imon ) then lmon_chg = .true. @@ -686,12 +429,12 @@ subroutine radupdate( idate,jdate,deltsw,deltim,lsswr, me, & !! time interpolation. if (lsswr) then - if ( isolar == 0 .or. isolar == 10 ) then + if ( isol == 0 .or. isol == 10 ) then lsol_chg = .false. elseif ( iyear0 /= iyear ) then lsol_chg = .true. else - lsol_chg = ( isolar==4 .and. lmon_chg ) + lsol_chg = ( isol==4 .and. lmon_chg ) endif iyear0 = iyear @@ -699,7 +442,7 @@ subroutine radupdate( idate,jdate,deltsw,deltim,lsswr, me, & ! --- inputs: & ( jdate,kyear,deltsw,deltim,lsol_chg, me, & ! --- outputs: - & slag,sdec,cdec,solcon & + & slag,sdec,cdec,solcon,con_pi,errmsg,errflg & & ) endif ! end_if_lsswr_block @@ -707,7 +450,7 @@ subroutine radupdate( idate,jdate,deltsw,deltim,lsswr, me, & !> -# Call module_radiation_aerosols::aer_update(), monthly update, no !! time interpolation if ( lmon_chg ) then - call aer_update ( iyear, imon, me ) + call aer_update ( iyear, imon, me, iaermdl, aeros_file, errflg, errmsg ) endif !> -# Call co2 and other gases update routine: @@ -719,7 +462,8 @@ subroutine radupdate( idate,jdate,deltsw,deltim,lsswr, me, & lco2_chg = .false. endif - call gas_update ( kyear,kmon,kday,khour,loz1st,lco2_chg, me ) + call gas_update ( kyear,kmon,kday,khour,loz1st,lco2_chg, me, co2dat_file, & + co2gbl_file, ictm, ico2, ntoz, errflg, errmsg ) if ( loz1st ) loz1st = .false. diff --git a/physics/GFS_rrtmg_setup.meta b/physics/GFS_rrtmg_setup.meta index 599f974f4..adf6d8750 100644 --- a/physics/GFS_rrtmg_setup.meta +++ b/physics/GFS_rrtmg_setup.meta @@ -1,8 +1,8 @@ [ccpp-table-properties] name = GFS_rrtmg_setup type = scheme - dependencies = iounitdef.f,module_bfmicrophysics.f,physparam.f,radcons.f90,radiation_aerosols.f,radiation_astronomy.f,radiation_clouds.f - dependencies = module_mp_thompson.F90,radiation_gases.f,radlw_main.F90,radlw_param.f,radsw_main.F90,radsw_param.f + dependencies = iounitdef.f,module_bfmicrophysics.f,radcons.f90,radiation_aerosols.f,radiation_astronomy.f,radiation_clouds.f + dependencies = module_mp_thompson.F90,radiation_gases.f,radlw_main.F90,radlw_param.f,radsw_main.F90,radsw_param.f,machine.F ######################################################################## [ccpp-arg-table] @@ -37,6 +37,30 @@ dimensions = () type = integer intent = in +[solar_file] + standard_name = solar_constant_file + long_name = external solar constant data table file + units = none + dimensions = () + type = character + kind = len=26 + intent = in +[con_solr_2008] + standard_name = solar_constant_2008 + long_name = solar constant Tim 2008 + units = W m-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_solr_2002] + standard_name = solar_constant_2002 + long_name= solar constant Liu 2002 + units = W m-2 + dimensions = () + type = real + kind = kind_phys + intent = in [ico2] standard_name = control_for_co2 long_name = prescribed global mean value (old opernl) @@ -86,20 +110,69 @@ dimensions = () type = integer intent = in -[isubc_sw] +[iovr_exp] + standard_name = flag_for_exponential_cloud_overlap_method + long_name = choice of exponential cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_exprand] + standard_name = flag_for_exponential_random_cloud_overlap_method + long_name = choice of exponential-random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_max] + standard_name = flag_for_maximum_cloud_overlap_method + long_name = choice of maximum cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_rand] + standard_name = flag_for_random_cloud_overlap_method + long_name = choice of random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_maxrand] + standard_name = flag_for_maximum_random_cloud_overlap_method + long_name = choice of maximum-random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_dcorr] + standard_name = flag_for_decorrelation_length_cloud_overlap_method + long_name = choice of decorrelation-length cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[isubcsw] standard_name = flag_for_sw_clouds_grid_approximation long_name = flag for sw clouds sub-grid approximation units = flag dimensions = () type = integer intent = in -[isubc_lw] +[isubclw] standard_name = flag_for_lw_clouds_sub_grid_approximation long_name = flag for lw clouds sub-grid approximation units = flag dimensions = () type = integer intent = in +[iswmode] + standard_name = control_for_sw_scattering_choice + long_name = control of rrtmg shortwave scattering choice + units = 1 + dimensions = () + type = integer + intent = in [icliq_sw] standard_name = control_for_shortwave_radiation_liquid_clouds long_name = sw optical property for liquid clouds @@ -107,14 +180,14 @@ dimensions = () type = integer intent = in -[crick_proof] +[lcrick] standard_name = flag_for_CRICK_proof_cloud_water long_name = flag for CRICK-Proof cloud water units = flag dimensions = () type = logical intent = in -[ccnorm] +[lcnorm] standard_name = flag_for_in_cloud_condensate long_name = flag for cloud condensate normalized by cloud cover units = flag @@ -128,7 +201,7 @@ dimensions = () type = integer intent = in -[norad_precip] +[lnoprec] standard_name = flag_for_turning_off_precipitation_radiative_effect long_name = radiation precip flag for Ferrier/Moorthi units = flag @@ -163,6 +236,114 @@ dimensions = () type = integer intent = in +[aeros_file] + standard_name = aerosol_data_file + long_name = aerosol data file + units = none + dimensions = () + type = character + kind = len=26 + intent = in +[co2usr_file] + standard_name = co2_user_data_table_file + long_name = co2 user defined data table file + units = none + dimensions = () + type = character + kind = len=26 + intent = in +[co2cyc_file] + standard_name = co2_clim_monthly_cycle_data_table_file + long_name = co2 climotological monthly cycle data table file + units = none + dimensions = () + type = character + kind = len=26 + intent = in +[rad_hr_units] + standard_name = control_for_radiation_heating_rate_units + long_name = control of heating rate units + units = 1 + dimensions = () + type = integer + intent = in +[inc_minor_gas] + standard_name = flag_to_include_minor_gases_in_rrtmg + long_name = flag to include minor trace gases in rrtmg + units = flag + dimensions = () + type = logical + intent = in +[icliq_lw] + standard_name = flag_for_optical_property_for_liquid_clouds_for_longwave_radiation + long_name = lw optical property for liquid clouds + units = flag + dimensions = () + type = integer + intent = in +[con_pi] + standard_name = pi + long_name = ratio of a circle's circumference to its diameter + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[con_c] + standard_name = speed_of_light_in_vacuum + long_name = speed of light in vacuum + units = m s-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_plnk] + standard_name = planck_constant + long_name = Planck constant + units = J s-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_boltz] + standard_name = boltzmann_constant + long_name = Boltzmann constant + units = J K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_t0c] + standard_name = temperature_at_zero_celsius + long_name = temperature at 0 degree Celsius + units = K + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rd] + standard_name = gas_constant_of_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[lalw1bd] + standard_name = do_longwave_aerosol_band_properties + long_name = control of band or multiband longwave aerosol properties + units = 1 + dimensions = () + type = logical + intent = in [ltp] standard_name = extra_top_layer long_name = extra top layer for radiation @@ -177,6 +358,27 @@ dimensions = () type = logical intent = in +[ipsd0] + standard_name = initial_seed_for_mcica + long_name = initial permutaion seed for mcica radiation + units = 1 + dimensions = () + type = integer + intent = inout +[iaermdl] + standard_name = control_for_aerosol_radiation_scheme + long_name = control of aerosol scheme in radiation + units = 1 + dimensions = () + type = integer + intent = out +[iaerflg] + standard_name = control_for_aerosol_effects_in_radiation + long_name = control of aerosol effects in radiation + units = 1 + dimensions = () + type = integer + intent = out [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -241,6 +443,80 @@ dimensions = () type = integer intent = in +[iaermdl] + standard_name = control_for_aerosol_radiation_scheme + long_name = control of aerosol scheme in radiation + units = 1 + dimensions = () + type = integer + intent = in +[iaerflg] + standard_name = control_for_aerosol_effects_in_radiation + long_name = control of aerosol effects in radiation + units = 1 + dimensions = () + type = integer + intent = in +[isol] + standard_name = control_for_solar_constant + long_name = use prescribed solar constant + units = flag + dimensions = () + type = integer + intent = in +[aeros_file] + standard_name = aerosol_data_file + long_name = aerosol data file + units = none + dimensions = () + type = character + kind = len=26 + intent = in +[co2dat_file] + standard_name = co2_monthly_obs_data_table_file + long_name = co2 monthly observation data table + units = none + dimensions = () + type = character + kind = len=26 + intent = in +[co2gbl_file] + standard_name = co2_global_annual_mean_data_table_file + long_name = co2 global annual mean data file + units = none + dimensions = () + type = character + kind = len=26 + intent = in +[ictm] + standard_name = flag_for_initial_time_date_control + long_name = flag for initial conditions and forcing + units = flag + dimensions = () + type = integer + intent = in +[ico2] + standard_name = control_for_co2 + long_name = prescribed global mean value (old opernl) + units = flag + dimensions = () + type = integer + intent = in +[ntoz] + standard_name = index_of_ozone_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for ozone mixing ratio + units = index + dimensions = () + type = integer + intent = in +[con_pi] + standard_name = pi + long_name = ratio of a circle's circumference to its diameter + units = none + dimensions = () + type = real + kind = kind_phys + intent = in [slag] standard_name = equation_of_time long_name = equation of time (radian) diff --git a/physics/GFS_rrtmgp_cloud_overlap.F90 b/physics/GFS_rrtmgp_cloud_overlap.F90 index b294b4a99..0094f8165 100644 --- a/physics/GFS_rrtmgp_cloud_overlap.F90 +++ b/physics/GFS_rrtmgp_cloud_overlap.F90 @@ -100,6 +100,7 @@ subroutine GFS_rrtmgp_cloud_overlap_run(nCol, nLev, yearlen, doSWrad, doLWrad, ! ! Cloud decorrelation length ! + de_lgth(:) = 0. if (idcor == idcor_hogan) then call cmp_dcorr_lgth(nCol, lat, con_pi, de_lgth) endif @@ -116,7 +117,6 @@ subroutine GFS_rrtmgp_cloud_overlap_run(nCol, nLev, yearlen, doSWrad, doLWrad, if (iovr == iovr_dcorr .or. iovr == iovr_exp .or. iovr == iovr_exprand) then call get_alpha_exper(nCol, nLev, iovr, iovr_exprand, deltaZc*0.001, de_lgth, cld_frac, cloud_overlap_param) else - de_lgth(:) = 0. cloud_overlap_param(:,:) = 0. endif @@ -127,7 +127,6 @@ subroutine GFS_rrtmgp_cloud_overlap_run(nCol, nLev, yearlen, doSWrad, doLWrad, if (iovr_convcld == iovr_dcorr .or. iovr_convcld == iovr_exp .or. iovr_convcld == iovr_exprand) then call get_alpha_exper(nCol, nLev, iovr_convcld, iovr_exprand, deltaZc*0.001, de_lgth, cld_cnv_frac, cnv_cloud_overlap_param) else - de_lgth(:) = 0. cnv_cloud_overlap_param(:,:) = 0. endif endif diff --git a/physics/GFS_rrtmgp_cloud_overlap.meta b/physics/GFS_rrtmgp_cloud_overlap.meta index f7d12bed5..cf6a05217 100644 --- a/physics/GFS_rrtmgp_cloud_overlap.meta +++ b/physics/GFS_rrtmgp_cloud_overlap.meta @@ -210,8 +210,8 @@ kind = kind_phys intent = in [top_at_1] - standard_name = flag_for_vertical_ordering_in_RRTMGP - long_name = flag for vertical ordering in RRTMGP + standard_name = flag_for_vertical_ordering_in_radiation + long_name = flag for vertical ordering in radiation units = flag dimensions = () type = logical diff --git a/physics/GFS_rrtmgp_pre.F90 b/physics/GFS_rrtmgp_pre.F90 index 8e115b774..02cc506fd 100644 --- a/physics/GFS_rrtmgp_pre.F90 +++ b/physics/GFS_rrtmgp_pre.F90 @@ -5,18 +5,14 @@ !! \brief This module contains code to prepare model fields for use by the RRTMGP !! radiation scheme. module GFS_rrtmgp_pre - use machine, only: & - kind_phys !< Working type - use funcphys, only: & - fpvs !< Function ot compute sat. vapor pressure over liq. - use module_radiation_astronomy, only: & - coszmn - use module_radiation_gases, only: & - NF_VGAS, & !< Number of active gas species - getgases, & !< Routine to setup trace gases - getozn !< Routine to setup ozone - use radiation_tools, only: check_error_msg,cmp_tlev - use rrtmgp_lw_gas_optics, only: lw_gas_props + use machine, only: kind_phys + use funcphys, only: fpvs + use module_radiation_astronomy, only: coszmn + use module_radiation_gases, only: NF_VGAS, getgases, getozn + use mo_gas_concentrations, only: ty_gas_concs + use radiation_tools, only: check_error_msg,cmp_tlev + use rrtmgp_lw_gas_optics, only: lw_gas_props + implicit none real(kind_phys), parameter :: & @@ -121,13 +117,15 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, doSWrad, doLWrad, fhswr, fhl vmr_n2o, vmr_co2, tsfg, tsfa, qs_lay, q_lay, tv_lay, & relhum, deltaZ, deltaZc, deltaP, active_gases_array, & tsfc_radtime, coszen, coszdg, top_at_1, iSFC, iTOA, nDay, idxday, semis, & - sfc_emiss_byband, errmsg, errflg) + sfc_emiss_byband, ico2, con_pi, errmsg, errflg) ! Inputs integer, intent(in) :: & me, & ! MPI rank nCol, & ! Number of horizontal grid points nLev, & ! Number of vertical layers + nTracers, & ! Number of tracers from model. + ico2, & ! Flag for co2 radiation scheme i_o3 ! Index into tracer array for ozone logical, intent(in) :: & doSWrad, & ! Call SW radiation? @@ -142,6 +140,7 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, doSWrad, doLWrad, fhswr, fhl con_epsm1, & ! Physical constant: Epsilon (Rd/Rv) minus one con_fvirt, & ! Physical constant: Inverse of epsilon minus one con_epsqs, & ! Physical constant: Minimum saturation mixing-ratio (kg/kg) + con_pi, & ! Physical constant: Pi solhr ! Time in hours after 00z at the current timestep real(kind_phys), dimension(:), intent(in) :: & xlon, & ! Longitude @@ -208,7 +207,7 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, doSWrad, doLWrad, fhswr, fhl ! Initialize CCPP error handling variables errmsg = '' errflg = 0 - + nday = 0 idxday = 0 if (.not. (doSWrad .or. doLWrad)) return @@ -352,14 +351,14 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, doSWrad, doLWrad, fhswr, fhl enddo ! OR Use climatological ozone data else - call getozn (prslk(1:NCOL,:), xlat, nCol, nLev, o3_lay) + call getozn (prslk(1:NCOL,:), xlat, nCol, nLev, top_at_1, o3_lay) endif ! ####################################################################################### ! Set gas concentrations for RRTMGP ! ####################################################################################### ! Call getgases(), to set up non-prognostic gas volume mixing ratios (gas_vmr). - call getgases (p_lev/100., xlon, xlat, nCol, nLev, gas_vmr) + call getgases (p_lev/100., xlon, xlat, nCol, nLev, ico2, top_at_1, con_pi, gas_vmr) vmr_o2 = gas_vmr(:,:,4) vmr_ch4 = gas_vmr(:,:,3) vmr_n2o = gas_vmr(:,:,2) @@ -377,6 +376,9 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, doSWrad, doLWrad, fhswr, fhl ! ####################################################################################### ! Setup surface ground temperature and ground/air skin temperature if required. ! ####################################################################################### + iSFC_ilev = 1 + if (top_at_1) iSFC_ilev = iSFC + 1 + tsfg(1:NCOL) = t_lev(1:NCOL,iSFC_ilev) tsfa(1:NCOL) = t_lay(1:NCOL,iSFC) diff --git a/physics/GFS_rrtmgp_pre.meta b/physics/GFS_rrtmgp_pre.meta index 455010e58..abb07b825 100644 --- a/physics/GFS_rrtmgp_pre.meta +++ b/physics/GFS_rrtmgp_pre.meta @@ -2,7 +2,7 @@ name = GFS_rrtmgp_pre type = scheme dependencies = funcphys.f90,iounitdef.f,machine.F,module_bfmicrophysics.f,physcons.F90,radcons.f90,radiation_aerosols.f - dependencies = radiation_astronomy.f,radiation_clouds.f,radiation_gases.f,radiation_tools.F90,rrtmg_lw_cloud_optics.F90 + dependencies = radiation_astronomy.f,radiation_gases.f,radiation_tools.F90,rrtmg_lw_cloud_optics.F90 ######################################################################## [ccpp-arg-table] @@ -245,6 +245,21 @@ type = real kind = kind_phys intent = in +[con_pi] + standard_name = pi + long_name = ratio of a circle's circumference to its diameter + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[ico2] + standard_name = control_for_co2 + long_name = prescribed global mean value (old opernl) + units = flag + dimensions = () + type = integer + intent = in [raddt] standard_name = time_step_for_radiation long_name = radiation time step @@ -310,8 +325,8 @@ kind = kind_phys intent = inout [top_at_1] - standard_name = flag_for_vertical_ordering_in_RRTMGP - long_name = flag for vertical ordering in RRTMGP + standard_name = flag_for_vertical_ordering_in_radiation + long_name = flag for vertical ordering in radiation units = flag dimensions = () type = logical diff --git a/physics/GFS_rrtmgp_setup.F90 b/physics/GFS_rrtmgp_setup.F90 index f028acca2..76db14279 100644 --- a/physics/GFS_rrtmgp_setup.F90 +++ b/physics/GFS_rrtmgp_setup.F90 @@ -6,15 +6,12 @@ module GFS_rrtmgp_setup use module_radiation_astronomy, only : sol_init, sol_update use module_radiation_aerosols, only : aer_init, aer_update use module_radiation_gases, only : gas_init, gas_update - ! use GFS_cloud_diagnostics, only : hml_cloud_diagnostics_initialize - ! *NOTE* These parameters below are required radiation_****** modules. They are not - ! directly used by the RRTMGP routines. - use physparam, only : isolar, ictmflg, ico2flg, ioznflg, iaerflg, & - iaermdl, ivflip implicit none public GFS_rrtmgp_setup_init, GFS_rrtmgp_setup_timestep_init, GFS_rrtmgp_setup_finalize - + + private + ! Version tag and last revision date character(40), parameter :: & VTAGRAD='NCEP-RRTMGP_driver v1.0 Sep 2019 ' @@ -28,7 +25,7 @@ module GFS_rrtmgp_setup is_initialized = .false. ! Control flag for the first time of reading climatological ozone data ! (set/reset in subroutines GFS_rrtmgp_setup_init/GFS_rrtmgp_setup_timestep_init, it is used only if - ! the control parameter ioznflg=0) + ! the control parameter ntoz=0) logical :: loz1st = .true. contains @@ -40,8 +37,9 @@ module GFS_rrtmgp_setup subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires, & imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, imp_physics_zhao_carr, & imp_physics_zhao_carr_pdf, imp_physics_mg, si, levr, ictm, isol, ico2, iaer, & - ntcw, num_p3d, ntoz, iovr, isubc_sw, isubc_lw, icliq_sw, crick_proof, ccnorm, & - norad_precip, idate, iflip, me, errmsg, errflg) + ntcw, ntoz, iovr, isubc_sw, isubc_lw, lalw1bd, idate, me, aeros_file, & + iaermdl, iaerflg, con_pi, con_t0c, con_c, con_boltz, con_plnk, solar_file, & + con_solr_2008, con_solr_2002, co2usr_file, co2cyc_file, ipsd0, errmsg, errflg) ! Inputs logical, intent(in) :: do_RRTMGP @@ -54,19 +52,24 @@ subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires, imp_physics_zhao_carr, & ! Flag for zhao-carr scheme imp_physics_zhao_carr_pdf, & ! Flag for zhao-carr+PDF scheme imp_physics_mg ! Flag for MG scheme + real(kind_phys), intent(in) :: & + con_pi, con_t0c, con_c, con_boltz, con_plnk, con_solr_2008, con_solr_2002 real(kind_phys), dimension(:), intent(in) :: & si integer, intent(in) :: levr, ictm, isol, ico2, iaer, & - ntcw, num_p3d, ntoz, iovr, isubc_sw, isubc_lw, & - icliq_sw, iflip, me + ntcw, ntoz, iovr, isubc_sw, isubc_lw, & + me logical, intent(in) :: & - crick_proof, ccnorm, norad_precip + lalw1bd integer, intent(in), dimension(:) :: & idate + character(len=26),intent(in) :: aeros_file, solar_file, co2usr_file, co2cyc_file ! Outputs - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(inout) :: ipsd0 + integer, intent(out) :: iaermdl, iaerflg ! Initialize the CCPP error handling variables errmsg = '' @@ -82,12 +85,6 @@ subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires, end if ! Set radiation parameters - isolar = isol ! solar constant control flag - ictmflg = ictm ! data ic time/date control flag - ico2flg = ico2 ! co2 data source control flag - ioznflg = ntoz ! ozone data source control flag - ivflip = iflip ! vertical index direction control flag - if ( ictm==0 .or. ictm==-2 ) then iaerflg = mod(iaer, 100) ! no volcanic aerosols for clim hindcast else @@ -99,6 +96,11 @@ subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires, errflg = 1 return endif + + ! Assign initial permutation seed for mcica cloud-radiation + if ( isubc_sw>0 .or. isubc_lw>0 ) then + ipsd0 = 17*idate(1)+43*idate(2)+37*idate(3)+23*idate(4) + endif if ( me == 0 ) then print *,' In rad_initialize (GFS_rrtmgp_setup_init), before calling radinit' @@ -107,39 +109,27 @@ subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires, ' ictm = ',ictm, & ' isol = ',isol, & ' ico2 = ',ico2, & - ' iaer = ',iaer, & - ' ntcw = ',ntcw - print *,' np3d = ',num_p3d, & + ' iaermdl = ',iaermdl, & + ' iaerflg = ',iaerflg, & + ' ntcw = ',ntcw, & ' ntoz = ',ntoz, & ' iovr = ',iovr, & ' isubc_sw = ',isubc_sw, & ' isubc_lw = ',isubc_lw, & - ' icliq_sw = ',icliq_sw, & - ' iflip = ',iflip, & + ' ipsd0 = ',ipsd0, & ' me = ',me endif - - loz1st = (ioznflg == 0) ! first-time clim ozone data read flag + + loz1st = (ntoz == 0) ! first-time clim ozone data read flag month0 = 0 iyear0 = 0 monthd = 0 -!> -# Initialization -!! - astronomy initialization routine: -!! call module_radiation_astronomy::sol_init() -!! - aerosols initialization routine: -!! call module_radiation_aerosols::aer_init() -!! - CO2 and other gases intialization routine: -!! call module_radiation_gases::gas_init() - ! Call initialization routines.. - call sol_init ( me ) - call aer_init ( levr, me ) - call gas_init ( me ) - !call hml_cloud_diagnostics_initialize(imp_physics, imp_physics_fer_hires, & - ! imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, & - ! imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, imp_physics_mg, levr, me, si,& - ! errflg) + call sol_init ( me, isol, solar_file, con_solr_2008, con_solr_2002, con_pi ) + call aer_init ( levr, me, iaermdl, iaerflg, lalw1bd, aeros_file, con_pi, con_t0c, & + con_c, con_boltz, con_plnk, errflg, errmsg) + call gas_init ( me, co2usr_file, co2cyc_file, ico2, ictm, ntoz, con_pi, errflg, errmsg ) if ( me == 0 ) then print *,' return from rad_initialize (GFS_rrtmgp_setup_init) - after calling radinit' @@ -156,8 +146,9 @@ end subroutine GFS_rrtmgp_setup_init !> \section arg_table_GFS_rrtmgp_setup_timestep_init !! \htmlinclude GFS_rrtmgp_setup_timestep_init.html !! - subroutine GFS_rrtmgp_setup_timestep_init (idate, jdate, deltsw, deltim, doSWrad, me, & - slag, sdec, cdec, solcon, errmsg, errflg) + subroutine GFS_rrtmgp_setup_timestep_init (idate, jdate, deltsw, deltim, doSWrad, me, & + iaermdl, aeros_file, isol, slag, sdec, cdec, solcon, con_pi, co2dat_file, & + co2gbl_file, ictm, ico2, ntoz, errmsg, errflg) ! Inputs integer, intent(in) :: idate(:) @@ -165,7 +156,10 @@ subroutine GFS_rrtmgp_setup_timestep_init (idate, jdate, deltsw, deltim, doSWrad real(kind_phys), intent(in) :: deltsw real(kind_phys), intent(in) :: deltim logical, intent(in) :: doSWrad + real(kind_phys), intent(in) :: con_pi integer, intent(in) :: me + integer, intent(in) :: iaermdl,isol,ictm,ico2,ntoz + character(len=26), intent(in) :: aeros_file,co2dat_file,co2gbl_file ! Outputs real(kind_phys), intent(out) :: slag @@ -201,7 +195,7 @@ subroutine GFS_rrtmgp_setup_timestep_init (idate, jdate, deltsw, deltim, doSWrad ! Set up time stamp used for green house gases (** currently co2 only) ! get external data at initial condition time - if ( ictmflg==0 .or. ictmflg==-2 ) then + if ( ictm==0 .or. ictm==-2 ) then kyear = idate(1) kmon = idate(2) kday = idate(3) @@ -223,20 +217,20 @@ subroutine GFS_rrtmgp_setup_timestep_init (idate, jdate, deltsw, deltim, doSWrad ! Update solar forcing... if (doSWrad) then - if ( isolar == 0 .or. isolar == 10 ) then + if ( isol == 0 .or. isol == 10 ) then lsol_chg = .false. elseif ( iyear0 /= iyear ) then lsol_chg = .true. else - lsol_chg = ( isolar==4 .and. lmon_chg ) + lsol_chg = ( isol==4 .and. lmon_chg ) endif iyear0 = iyear - call sol_update(jdate, kyear, deltsw, deltim, lsol_chg, me, slag, sdec, cdec, solcon) + call sol_update(jdate, kyear, deltsw, deltim, lsol_chg, me, slag, sdec, cdec, solcon, con_pi, errmsg, errflg) endif ! Update aerosols... if ( lmon_chg ) then - call aer_update ( iyear, imon, me ) + call aer_update ( iyear, imon, me, iaermdl, aeros_file, errflg, errmsg) endif ! Update trace gases (co2 only)... @@ -246,7 +240,8 @@ subroutine GFS_rrtmgp_setup_timestep_init (idate, jdate, deltsw, deltim, doSWrad else lco2_chg = .false. endif - call gas_update (kyear, kmon, kday, khour, loz1st, lco2_chg, me ) + call gas_update (kyear, kmon, kday, khour, loz1st, lco2_chg, me, co2dat_file, & + co2gbl_file, ictm, ico2, ntoz, errflg, errmsg ) if ( loz1st ) loz1st = .false. diff --git a/physics/GFS_rrtmgp_setup.meta b/physics/GFS_rrtmgp_setup.meta index 160430765..c4f7cfaa5 100644 --- a/physics/GFS_rrtmgp_setup.meta +++ b/physics/GFS_rrtmgp_setup.meta @@ -1,8 +1,8 @@ [ccpp-table-properties] name = GFS_rrtmgp_setup type = scheme - dependencies = iounitdef.f,machine.F,module_bfmicrophysics.f,physparam.f,radiation_aerosols.f,radiation_astronomy.f - dependencies = module_mp_thompson.F90,radiation_clouds.f,radiation_gases.f + dependencies = iounitdef.f,machine.F,module_bfmicrophysics.f,radiation_aerosols.f,radiation_astronomy.f + dependencies = module_mp_thompson.F90,radiation_gases.f ######################################################################## [ccpp-arg-table] @@ -101,6 +101,30 @@ dimensions = () type = integer intent = in +[solar_file] + standard_name = solar_constant_file + long_name = external solar constant data table file + units = none + dimensions = () + type = character + kind = len=26 + intent = in +[con_solr_2008] + standard_name = solar_constant_2008 + long_name = solar constant Tim 2008 + units = W m-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_solr_2002] + standard_name = solar_constant_2002 + long_name= solar constant Liu 2002 + units = W m-2 + dimensions = () + type = real + kind = kind_phys + intent = in [ico2] standard_name = control_for_co2 long_name = prescribed global mean value (old opernl) @@ -122,13 +146,6 @@ dimensions = () type = integer intent = in -[num_p3d] - standard_name = number_of_microphysics_variables_in_xyz_dimensioned_restart_array - long_name = number of 3D arrays needed for microphysics - units = count - dimensions = () - type = integer - intent = in [ntoz] standard_name = index_of_ozone_mixing_ratio_in_tracer_concentration_array long_name = tracer index for ozone mixing ratio @@ -157,31 +174,10 @@ dimensions = () type = integer intent = in -[icliq_sw] - standard_name = control_for_shortwave_radiation_liquid_clouds - long_name = sw optical property for liquid clouds - units = flag - dimensions = () - type = integer - intent = in -[crick_proof] - standard_name = flag_for_CRICK_proof_cloud_water - long_name = flag for CRICK-Proof cloud water - units = flag - dimensions = () - type = logical - intent = in -[ccnorm] - standard_name = flag_for_in_cloud_condensate - long_name = flag for cloud condensate normalized by cloud cover - units = flag - dimensions = () - type = logical - intent = in -[norad_precip] - standard_name = flag_for_turning_off_precipitation_radiative_effect - long_name = radiation precip flag for Ferrier/Moorthi - units = flag +[lalw1bd] + standard_name = do_longwave_aerosol_band_properties + long_name = control of band or multiband longwave aerosol properties + units = 1 dimensions = () type = logical intent = in @@ -192,13 +188,6 @@ dimensions = (4) type = integer intent = in -[iflip] - standard_name = control_for_vertical_index_direction - long_name = flag for vertical index direction control - units = flag - dimensions = () - type = integer - intent = in [me] standard_name = mpi_rank long_name = current MPI-rank @@ -206,6 +195,91 @@ dimensions = () type = integer intent = in +[aeros_file] + standard_name = aerosol_data_file + long_name = aerosol data file + units = none + dimensions = () + type = character + kind = len=26 + intent = in +[con_pi] + standard_name = pi + long_name = ratio of a circle's circumference to its diameter + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[con_c] + standard_name = speed_of_light_in_vacuum + long_name = speed of light in vacuum + units = m s-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_plnk] + standard_name = planck_constant + long_name = Planck constant + units = J s-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_boltz] + standard_name = boltzmann_constant + long_name = Boltzmann constant + units = J K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_t0c] + standard_name = temperature_at_zero_celsius + long_name = temperature at 0 degree Celsius + units = K + dimensions = () + type = real + kind = kind_phys + intent = in +[co2usr_file] + standard_name = co2_user_data_table_file + long_name = co2 user defined data table file + units = none + dimensions = () + type = character + kind = len=26 + intent = in +[co2cyc_file] + standard_name = co2_clim_monthly_cycle_data_table_file + long_name = co2 climotological monthly cycle data table file + units = none + dimensions = () + type = character + kind = len=26 + intent = in +[ipsd0] + standard_name = initial_seed_for_mcica + long_name = initial permutaion seed for mcica radiation + units = 1 + dimensions = () + type = integer + intent = inout +[iaermdl] + standard_name = control_for_aerosol_radiation_scheme + long_name = control of aerosol scheme in radiation + units = 1 + dimensions = () + type = integer + intent = out +[iaerflg] + standard_name = control_for_aerosol_effects_in_radiation + long_name = control of aerosol effects in radiation + units = 1 + dimensions = () + type = integer + intent = out [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -270,6 +344,73 @@ dimensions = () type = integer intent = in +[aeros_file] + standard_name = aerosol_data_file + long_name = aerosol data file + units = none + dimensions = () + type = character + kind = len=26 + intent = in +[co2dat_file] + standard_name = co2_monthly_obs_data_table_file + long_name = co2 monthly observation data table + units = none + dimensions = () + type = character + kind = len=26 + intent = in +[co2gbl_file] + standard_name = co2_global_annual_mean_data_table_file + long_name = co2 global annual mean data file + units = none + dimensions = () + type = character + kind = len=26 + intent = in +[ictm] + standard_name = flag_for_initial_time_date_control + long_name = flag for initial conditions and forcing + units = flag + dimensions = () + type = integer + intent = in +[ico2] + standard_name = control_for_co2 + long_name = prescribed global mean value (old opernl) + units = flag + dimensions = () + type = integer + intent = in +[ntoz] + standard_name = index_of_ozone_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for ozone mixing ratio + units = index + dimensions = () + type = integer + intent = in +[iaermdl] + standard_name = control_for_aerosol_radiation_scheme + long_name = control of aerosol scheme in radiation + units = 1 + dimensions = () + type = integer + intent = in +[isol] + standard_name = control_for_solar_constant + long_name = use prescribed solar constant + units = flag + dimensions = () + type = integer + intent = in +[con_pi] + standard_name = pi + long_name = ratio of a circle's circumference to its diameter + units = none + dimensions = () + type = real + kind = kind_phys + intent = in [slag] standard_name = equation_of_time long_name = equation of time (radian) diff --git a/physics/GFS_surface_composites_pre.F90 b/physics/GFS_surface_composites_pre.F90 index 734f1965b..a8b0a3112 100644 --- a/physics/GFS_surface_composites_pre.F90 +++ b/physics/GFS_surface_composites_pre.F90 @@ -4,7 +4,6 @@ module GFS_surface_composites_pre use machine, only: kind_phys - use physparam, only : iemsflg implicit none diff --git a/physics/GFS_surface_composites_pre.meta b/physics/GFS_surface_composites_pre.meta index e87af3e28..a0e30055f 100644 --- a/physics/GFS_surface_composites_pre.meta +++ b/physics/GFS_surface_composites_pre.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = GFS_surface_composites_pre type = scheme - dependencies = machine.F,physparam.f + dependencies = machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/cires_ugwpv1_oro.F90 b/physics/cires_ugwpv1_oro.F90 index b0af0f2a1..423a21348 100644 --- a/physics/cires_ugwpv1_oro.F90 +++ b/physics/cires_ugwpv1_oro.F90 @@ -1002,7 +1002,9 @@ subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & ! enddo print * - stop + errflg = 1 + errmsg = 'ERROR(orogw_v1): ' + return endif endif diff --git a/physics/drag_suite.F90 b/physics/drag_suite.F90 index ed1571622..4c65a91ce 100644 --- a/physics/drag_suite.F90 +++ b/physics/drag_suite.F90 @@ -9,6 +9,12 @@ module drag_suite !> \defgroup gfs_drag_suite_mod GSL drag_suite Module !> This module contains the CCPP-compliant GSL orographic gravity wave drag scheme. !> @{ +!! +!> \brief This subroutine initializes the orographic gravity wave drag scheme. +!! +!> \section arg_table_drag_suite_init Argument Table +!! \htmlinclude drag_suite_init.html +!! subroutine drag_suite_init(gwd_opt, errmsg, errflg) integer, intent(in) :: gwd_opt diff --git a/physics/gcycle.F90 b/physics/gcycle.F90 index 5f4f959c6..16e446b27 100644 --- a/physics/gcycle.F90 +++ b/physics/gcycle.F90 @@ -15,14 +15,14 @@ module gcycle_mod !>\ingroup mod_GFS_phys_time_vary !! This subroutine repopulates specific time-varying surface properties for !! atmospheric forecast runs. - subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & + subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, fn_nml, & input_nml_file, lsoil, lsoil_lsm, kice, idate, ialb, isot, ivegsrc, & use_ufo, nst_anl, fhcyc, phour, landfrac, lakefrac, min_seaice, min_lakeice, & frac_grid, smc, slc, stc, smois, sh2o, tslb, tiice, tg3, tref, tsfc, & tsfco, tisfc, hice, fice, facsf, facwf, alvsf, alvwf, alnsf, alnwf, & zorli, zorll, zorlo, weasd, slope, snoalb, canopy, vfrac, vtype, & stype, shdmin, shdmax, snowd, cv, cvb, cvt, oro, oro_uf, & - xlat_d, xlon_d, slmsk, imap, jmap) + xlat_d, xlon_d, slmsk, imap, jmap, errmsg, errflg) ! ! use machine, only: kind_phys, kind_io8 @@ -31,6 +31,7 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, integer, intent(in) :: me, nthrds, nx, ny, isc, jsc, nsst, & tile_num, nlunit, lsoil, lsoil_lsm, kice integer, intent(in) :: idate(:), ialb, isot, ivegsrc + character(len = 64), intent(in) :: fn_nml character(len=*), intent(in) :: input_nml_file(:) logical, intent(in) :: use_ufo, nst_anl, frac_grid real(kind=kind_phys), intent(in) :: fhcyc, phour, landfrac(:), lakefrac(:), & @@ -77,6 +78,9 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, slope(:) integer, intent(in) :: imap(:), jmap(:) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + ! ! Local variables ! --------------- @@ -103,6 +107,11 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, real(kind=kind_phys) :: sig1t integer :: npts, nb, ix, jx, ls, ios, ll logical :: exists + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! !@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ ! @@ -210,13 +219,15 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, enddo ! #ifndef INTERNAL_FILE_NML - inquire (file=trim(Model%fn_nml),exist=exists) + inquire (file=trim(fn_nml),exist=exists) if (.not. exists) then - write(6,*) 'gcycle:: namelist file: ',trim(Model%fn_nml),' does not exist' - stop + write(6,*) 'gcycle:: namelist file: ',trim(fn_nml),' does not exist' + errflg = 1 + errmsg = 'ERROR(gcycle): namelist file: ',trim(fn_nml),' does not exist.' + return else - open (unit=Model%nlunit, file=trim(Model%fn_nml), action='READ', status='OLD', iostat=ios) - rewind (Model%nlunit) + open (unit=nlunit, file=trim(fn_nml), action='READ', status='OLD', iostat=ios) + rewind (nlunit) endif #endif CALL SFCCYCLE (9998, npts, max(lsoil,lsoil_lsm), sig1t, fhcyc, & @@ -233,7 +244,7 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, min_ice, ialb, isot, ivegsrc, & trim(tile_num_ch), i_indx, j_indx) #ifndef INTERNAL_FILE_NML - close (Model%nlunit) + close (nlunit) #endif ! if ( nsst > 0 ) then diff --git a/physics/gfdl_cloud_microphys.F90 b/physics/gfdl_cloud_microphys.F90 index 4e8b3d586..0fd84c7ea 100644 --- a/physics/gfdl_cloud_microphys.F90 +++ b/physics/gfdl_cloud_microphys.F90 @@ -63,7 +63,7 @@ subroutine gfdl_cloud_microphys_init (me, master, nlunit, input_nml_file, loguni return endif - call gfdl_cloud_microphys_mod_init(me, master, nlunit, input_nml_file, logunit, fn_nml) + call gfdl_cloud_microphys_mod_init(me, master, nlunit, input_nml_file, logunit, fn_nml, errmsg, errflg) is_initialized = .true. diff --git a/physics/gfdl_sfc_layer.F90 b/physics/gfdl_sfc_layer.F90 index cf97fc1b6..e235acc52 100644 --- a/physics/gfdl_sfc_layer.F90 +++ b/physics/gfdl_sfc_layer.F90 @@ -1137,7 +1137,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m land(i) = 0.0 windmks=wind10p(i)*.01 if ( iwavecpl .eq. 1 ) then - call znot_wind10m(windmks,znott,znotm,icoef_sf) + call znot_wind10m(windmks,znott,znotm,icoef_sf,errmsg,errflg) !Check if Charnock parameter ratio is received in a proper range. if ( alpha(i) .ge. 0.2 .and. alpha(i) .le. 5. ) then znotm = znotm*alpha(i) @@ -1145,7 +1145,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m zoc(i) = -100.*znotm zot(i) = -100* znott else - call znot_wind10m(windmks,znott,znotm,icoef_sf) + call znot_wind10m(windmks,znott,znotm,icoef_sf,errmsg,errflg) zoc(i) = -100.*znotm zot(i) = -100* znott endif @@ -1782,7 +1782,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !m !!! if ( iwavecpl .eq. 1 .and. zoc(i) .le. 0.0 ) then windmks = wind10(i) * 0.01 - call znot_wind10m(windmks,znott,znotm,icoef_sf) + call znot_wind10m(windmks,znott,znotm,icoef_sf,errmsg,errflg) !Check if Charnock parameter ratio is received in a proper range. if ( alpha(i) .ge. 0.2 .and. alpha(i) .le. 5. ) then znotm = znotm*alpha(i) diff --git a/physics/lsm_noah.f b/physics/lsm_noah.f index 246f81654..e13f7facc 100644 --- a/physics/lsm_noah.f +++ b/physics/lsm_noah.f @@ -61,7 +61,7 @@ subroutine lsm_noah_init(lsm, lsm_noah, me, isot, ivegsrc, nlunit, end if !--- initialize soil vegetation - call set_soilveg(me, isot, ivegsrc, nlunit) + call set_soilveg(me, isot, ivegsrc, nlunit, errmsg, errflg) pores (:) = maxsmc (:) resid (:) = drysmc (:) @@ -543,7 +543,8 @@ subroutine lsm_noah_run & & edir, et, ett, esnow, drip, dew, beta, etp, ssoil, & & flx1, flx2, flx3, runoff1, runoff2, runoff3, & & snomlt, sncovr, rc, pc, rsmin, xlai, rcs, rct, rcq, & - & rcsoil, soilw, soilm, smcwlt, smcdry, smcref, smcmax) + & rcsoil, soilw, soilm, smcwlt, smcdry, smcref, smcmax, & + & errmsg, errflg ) !> - Noah LSM: prepare variables for return to parent model and unit conversion. ! - 6. output (o): diff --git a/physics/lsm_ruc.F90 b/physics/lsm_ruc.F90 index 99b6c2b41..e6dc66579 100644 --- a/physics/lsm_ruc.F90 +++ b/physics/lsm_ruc.F90 @@ -159,7 +159,7 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & endif !--- initialize soil vegetation - call set_soilveg_ruc(me, isot, ivegsrc, nlunit) + call set_soilveg_ruc(me, isot, ivegsrc, nlunit, errmsg, errflg) pores (:) = maxsmc (:) resid (:) = drysmc (:) @@ -1149,7 +1149,8 @@ subroutine lsm_ruc_run & ! inputs & smfrsoil(i,:,j),keepfrsoil(i,:,j), .false., & & shdmin1d(i,j), shdmax1d(i,j), rdlai2d, & & ims,ime, jms,jme, kms,kme, & - & its,ite, jts,jte, kts,kte ) + & its,ite, jts,jte, kts,kte, & + & errmsg, errflg) if(debug_print) then write (0,*)'after LSMRUC for land' write (0,*)'after sneqv(i,j) =',i,j,sneqv_lnd(i,j) @@ -1423,7 +1424,8 @@ subroutine lsm_ruc_run & ! inputs & smfrice(i,:,j),keepfrice(i,:,j), .false., & & shdmin1d(i,j), shdmax1d(i,j), rdlai2d, & & ims,ime, jms,jme, kms,kme, & - & its,ite, jts,jte, kts,kte ) + & its,ite, jts,jte, kts,kte, & + & errmsg, errflg) ! Interstitial evap_ice(i) = qfx_ice(i,j) / rho(i) ! kinematic diff --git a/physics/m_micro.F90 b/physics/m_micro.F90 index 091ed2020..714372d53 100644 --- a/physics/m_micro.F90 +++ b/physics/m_micro.F90 @@ -123,7 +123,9 @@ subroutine m_micro_init(imp_physics, imp_physics_mg, fprcp, gravit, rair, rh2o, mg_ngcons, mg_ngnst) else write(0,*)' fprcp = ',fprcp,' is not a valid option - aborting' - stop + errflg = 1 + errmsg = 'ERROR(m_micro_init): fprcp is not a valid option' + return endif call aer_cloud_init () diff --git a/physics/module_SF_JSFC.F90 b/physics/module_SF_JSFC.F90 index 8d67a81cd..fdf188b96 100644 --- a/physics/module_SF_JSFC.F90 +++ b/physics/module_SF_JSFC.F90 @@ -122,7 +122,7 @@ SUBROUTINE JSFC(FLAG_ITER,ITER,ME & & ,A1U,A1T,A1Q & & ,IDS,IDE,JDS,JDE,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & - & ,ITS,ITE,JTS,JTE,KTS,LM) + & ,ITS,ITE,JTS,JTE,KTS,LM,errmsg,errflg) ! !----------------------------------------------------------------------- ! SUBROUTINE JSFC(NTSD,EPSQ2,HT,DZ & @@ -182,6 +182,8 @@ SUBROUTINE JSFC(FLAG_ITER,ITER,ME & REAL(kind=kfpt),DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: CM,CH,STRESS,FFM & & ,FFH,WIND,FM10,FH2 & & ,A1U,A1T,A1Q + character(len=*),intent(out) :: errmsg + integer, intent(out) :: errflg ! ! REAL(kind=kfpt),DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: CHS,CHS2,CQS2 & ! & ,CPM,CT,FLHC,FLQC & @@ -215,6 +217,9 @@ SUBROUTINE JSFC(FLAG_ITER,ITER,ME & ! !---------------------------------------------------------------------- !********************************************************************** + ! Initialize error-handling + errflg = 0 + errmsg = '' !---------------------------------------------------------------------- ! !*** MAKE PREPARATIONS @@ -390,7 +395,8 @@ SUBROUTINE JSFC(FLAG_ITER,ITER,ME & & ,A1U(I,J),A1T(I,J),A1Q(I,J) & & ,IDS,IDE,JDS,JDE,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & - & ,ITS,ITE,JTS,JTE,KTS,LM,I,J,ZHK(LMH+1),RIB(I,J)) ! Added Bulk Richardson No. + & ,ITS,ITE,JTS,JTE,KTS,LM,I,J,ZHK(LMH+1),RIB(I,J) & ! Added Bulk Richardson No. + & ,errmsg, errflg) ! !*** REMOVE SUPERATURATION AT 2M AND 10M ! @@ -454,7 +460,8 @@ SUBROUTINE SFCDIF(NTSD,SEAMASK,THS,QS,PSFC & & ,FFM,FFH,FM10,FH2,A1U,A1T,A1Q & & ,IDS,IDE,JDS,JDE,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & - & ,ITS,ITE,JTS,JTE,KTS,LM,I,J,ZSFC,RIB) ! Added Bulk Richardson No. + & ,ITS,ITE,JTS,JTE,KTS,LM,I,J,ZSFC,RIB & ! Added Bulk Richardson No. + & ,errmsg, errflg) ! **************************************************************** ! * * ! * SURFACE LAYER * @@ -481,6 +488,8 @@ SUBROUTINE SFCDIF(NTSD,SEAMASK,THS,QS,PSFC & REAL(kind=kfpt),INTENT(OUT) :: FFM,FFH,FM10,FH2,A1U,A1T,A1Q ! REAL(kind=kfpt),INTENT(INOUT) :: AKHS,AKMS,QZ0,THZ0,USTAR,UZ0,VZ0,Z0,QS + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg !---------------------------------------------------------------------- !*** !*** LOCAL VARIABLES @@ -507,6 +516,10 @@ SUBROUTINE SFCDIF(NTSD,SEAMASK,THS,QS,PSFC & !---------------------------------------------------------------------- !********************************************************************** !---------------------------------------------------------------------- + ! Initialize error-handling + errflg = 0 + errmsg = '' + RDZ=1./ZSL CXCHL=EXCML*RDZ CXCHS=EXCMS*RDZ @@ -701,7 +714,9 @@ SUBROUTINE SFCDIF(NTSD,SEAMASK,THS,QS,PSFC & print*,'PSIH1(1,2),RDZT=',PSIH1(K+1),PSIH1(K+2),RDZT print*,'ZSLU,ZSLT,RLMO,ZU,ZT=',ZSLU,ZSLT,RLMO,ZU,ZT print*,'A,B,DTHV,DU2,RIB=',A,B,DTHV,DU2,RIB - stop + errflg = 1 + errmsg = 'ERROR(SFCDIF): ' + return end if diff --git a/physics/module_gfdl_cloud_microphys.F90 b/physics/module_gfdl_cloud_microphys.F90 index 3ebcfc587..5cab1abbc 100644 --- a/physics/module_gfdl_cloud_microphys.F90 +++ b/physics/module_gfdl_cloud_microphys.F90 @@ -3563,7 +3563,8 @@ end subroutine setupm !>\ingroup mod_gfdl_cloud_mp !! The subroutine 'gfdl_cloud_microphys_init' initializes the GFDL !! cloud microphysics. -subroutine gfdl_cloud_microphys_mod_init (me, master, nlunit, input_nml_file, logunit, fn_nml) +subroutine gfdl_cloud_microphys_mod_init (me, master, nlunit, input_nml_file, logunit, & + fn_nml, errmsg, errflg) implicit none @@ -3574,6 +3575,8 @@ subroutine gfdl_cloud_microphys_mod_init (me, master, nlunit, input_nml_file, lo character (len = 64), intent (in) :: fn_nml character (len = *), intent (in) :: input_nml_file(:) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg integer :: ios logical :: exists @@ -3588,13 +3591,19 @@ subroutine gfdl_cloud_microphys_mod_init (me, master, nlunit, input_nml_file, lo ! master = (mpp_pe () .eq.mpp_root_pe ()) + ! Initialize CCPP error-handling + errflg = 0 + errmsg = '' + #ifdef INTERNAL_FILE_NML read (input_nml_file, nml = gfdl_cloud_microphysics_nml) #else inquire (file = trim (fn_nml), exist = exists) if (.not. exists) then write (6, *) 'gfdl - mp :: namelist file: ', trim (fn_nml), ' does not exist' - stop + errflg = 1 + errmsg = 'ERROR(gfdl_cloud_microphys_mod_init): namelist file '//trim (fn_nml)//' does not exist' + return else open (unit = nlunit, file = fn_nml, action = 'read' , status = 'old', iostat = ios) endif diff --git a/physics/module_sf_exchcoef.f90 b/physics/module_sf_exchcoef.f90 index 0e3dae80c..6ec9ed835 100644 --- a/physics/module_sf_exchcoef.f90 +++ b/physics/module_sf_exchcoef.f90 @@ -636,7 +636,7 @@ SUBROUTINE znot_t_v8(uref,znott) END SUBROUTINE znot_t_v8 - SUBROUTINE znot_wind10m(w10m,znott,znotm,icoef_sf) + SUBROUTINE znot_wind10m(w10m,znott,znotm,icoef_sf,errmsg,errflg) IMPLICIT NONE ! w10m(m/s) : 10-m wind speed @@ -647,8 +647,15 @@ SUBROUTINE znot_wind10m(w10m,znott,znotm,icoef_sf) REAL, INTENT(IN) :: w10m INTEGER, INTENT(IN) :: icoef_sf REAL, INTENT(OUT):: znott, znotm + character(len=*),intent(out) :: errmsg + integer, intent(out) :: errflg real :: zm,zt,windmks, zlev,z10, tmp, zlevt, aaa, zm1,zt1 + + ! Initialize error-handling + errflg = 0 + errmsg = '' + zlev=20.0 zlevt=10.0 z10=10.0 @@ -722,7 +729,9 @@ SUBROUTINE znot_wind10m(w10m,znott,znotm,icoef_sf) call znot_t_v8(windmks,zt1) else write(0,*)'stop, icoef_sf must be one of 0,1,2,3,4,5,6,7,8' - stop + errflg = 1 + errmsg = 'ERROR(znot_wind10m): icoef_sf must be one of 0,1,2,3,4,5,6,7,8' + return endif znott=zt1 znotm=zm1 diff --git a/physics/module_sf_mynn.F90 b/physics/module_sf_mynn.F90 index c0457c20a..33678fa3a 100644 --- a/physics/module_sf_mynn.F90 +++ b/physics/module_sf_mynn.F90 @@ -382,6 +382,10 @@ SUBROUTINE SFCLAY_mynn( & INTEGER :: I,J,K,itf,ktf !----------------------------------------------------------- + ! Initialize error-handling + errflg = 0 + errmsg = '' + IF (debug_code >= 1) THEN write(*,*)"======= printing of constants:" write(*,*)"cp=", cp," g=", g @@ -684,6 +688,9 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & REAL(kind=kind_phys) :: FLUXC,VSGD REAL(kind=kind_phys) :: restar,VISC,DQG,OLDUST,OLDTST + ! Initialize error-handling + errflg = 0 + errmsg = '' !------------------------------------------------------------------- DO I=its,ite @@ -1192,7 +1199,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ENDIF ELSEIF ( ISFTCFLX .EQ. 4 ) THEN !GFS zt formulation - CALL GFS_zt_wat(ZT_wat(i),ZNTstoch_wat(i),restar,WSPD(i),ZA(i),sfc_z0_type) + CALL GFS_zt_wat(ZT_wat(i),ZNTstoch_wat(i),restar,WSPD(i),ZA(i),sfc_z0_type,errmsg,errflg) ZQ_wat(i)=ZT_wat(i) ENDIF ELSE @@ -2763,14 +2770,20 @@ SUBROUTINE GFS_z0_wat(z0rl_wat,ustar_wat,WSPD,z1,sfc_z0_type,redrag) END SUBROUTINE GFS_z0_wat !-------------------------------------------------------------------- !>\ingroup mynn_sfc - SUBROUTINE GFS_zt_wat(ztmax,z0rl_wat,restar,WSPD,z1,sfc_z0_type) + SUBROUTINE GFS_zt_wat(ztmax,z0rl_wat,restar,WSPD,z1,sfc_z0_type,errmsg,errflg) REAL(kind=kind_phys), INTENT(OUT) :: ztmax REAL(kind=kind_phys), INTENT(IN) :: wspd,z1,z0rl_wat,restar INTEGER, INTENT(IN):: sfc_z0_type + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg REAL(kind=kind_phys) :: z0,z0max,wind10m,rat,ustar_wat REAL(kind=kind_phys), PARAMETER :: charnock = 0.014, z0s_max=.317e-2 + ! Initialize error-handling + errflg = 0 + errmsg = '' + ! z0 = 0.01 * z0rl_wat !Already converted to meters in the wrapper z0 = z0rl_wat @@ -2800,7 +2813,9 @@ SUBROUTINE GFS_zt_wat(ztmax,z0rl_wat,restar,WSPD,z1,sfc_z0_type) call znot_t_v7(wind10m, ztmax) ! 10-m wind,m/s, ztmax(m) else if (sfc_z0_type > 0) then write(0,*)'no option for sfc_z0_type=',sfc_z0_type - stop + errflg = 1 + errmsg = 'ERROR(GFS_zt_wat): sfc_z0_type not valid.' + return endif END SUBROUTINE GFS_zt_wat diff --git a/physics/module_sf_noahmp_glacier.f90 b/physics/module_sf_noahmp_glacier.F90 similarity index 99% rename from physics/module_sf_noahmp_glacier.f90 rename to physics/module_sf_noahmp_glacier.F90 index 738a40b5c..bd6b016f1 100644 --- a/physics/module_sf_noahmp_glacier.f90 +++ b/physics/module_sf_noahmp_glacier.F90 @@ -1,5 +1,5 @@ #define CCPP -!> \file module_sf_noahmp_glacier.f90 +!> \file module_sf_noahmp_glacier.F90 !! This file contains the NoahMP Glacier scheme. !>\ingroup NoahMP_LSM diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.F90 similarity index 99% rename from physics/module_sf_noahmplsm.f90 rename to physics/module_sf_noahmplsm.F90 index 1da30f156..53373073f 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.F90 @@ -1,5 +1,5 @@ #define CCPP -!> \file module_sf_noahmplsm.f90 +!> \file module_sf_noahmplsm.F90 !! This file contains the NoahMP land surface model. !>\ingroup NoahMP_LSM diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 9a6363c08..5cf04d297 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -72,7 +72,8 @@ SUBROUTINE LSMRUC( & SMFR3D,KEEPFR3DFLAG, & myj,shdmin,shdmax,rdlai2d, & ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) + its,ite, jts,jte, kts,kte, & + errmsg, errflg) !----------------------------------------------------------------- IMPLICIT NONE !----------------------------------------------------------------- @@ -325,7 +326,6 @@ SUBROUTINE LSMRUC( & KICE, & KWT - REAL, DIMENSION(1:NSL) :: ZSMAIN, & ZSHALF, & DTDZS2 @@ -381,9 +381,14 @@ SUBROUTINE LSMRUC( & INTEGER :: I,J,K,NZS,NZS1,NDDZS INTEGER :: k1,k2 logical :: debug_print - + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg !----------------------------------------------------------------- ! + ! Initialize error-handling + errflg = 0 + errmsg = '' + debug_print = .false. ! rovcp = rd/cp @@ -704,7 +709,7 @@ SUBROUTINE LSMRUC( & soilfrac,nscat,shdmin(i,j),shdmax(i,j),mosaic_lu, mosaic_soil,& NLCAT,ILAND,ISOIL,iswater,MYJ,IFOREST,lufrac,VEGFRA(I,J), & EMISSL(I,J),PC(I,J),ZNT(I,J),LAI(I,J),RDLAI2D, & - QWRTZ,RHOCS,BCLH,DQM,KSAT,PSIS,QMIN,REF,WILT,i,j ) + QWRTZ,RHOCS,BCLH,DQM,KSAT,PSIS,QMIN,REF,WILT,i,j,errmsg, errflg) !-- update background emissivity for land points, can have vegetation mosaic effect EMISBCK(I,J) = EMISSL(I,J) @@ -6547,7 +6552,8 @@ SUBROUTINE SOILVEGIN ( debug_print, & mosaic_lu, mosaic_soil, & NLCAT,IVGTYP,ISLTYP,iswater,MYJ, & IFOREST,lufrac,vegfrac,EMISS,PC,ZNT,LAI,RDLAI2D,& - QWRTZ,RHOCS,BCLH,DQM,KSAT,PSIS,QMIN,REF,WILT,I,J) + QWRTZ,RHOCS,BCLH,DQM,KSAT,PSIS,QMIN,REF,WILT,I,J,& + errmsg, errflg) !************************************************************************ ! Set-up soil and vegetation Parameters in the case when @@ -6809,7 +6815,8 @@ SUBROUTINE SOILVEGIN ( debug_print, & REF, & WILT INTEGER, INTENT ( OUT) :: iforest - + character(len=*),intent(out) :: errmsg + integer, intent(out) :: errflg ! INTEGER, DIMENSION( 1:(lucats) ) , & ! INTENT ( OUT) :: iforest @@ -6830,7 +6837,11 @@ SUBROUTINE SOILVEGIN ( debug_print, & ! iforest(k)=if1(k) ! enddo - iforest = IFORTBL(IVGTYP) + ! Initialize error-handling + errflg = 0 + errmsg = '' + + iforest = IFORTBL(IVGTYP) IF (debug_print ) THEN print *,'ifortbl(ivgtyp),ivgtyp,laitbl(ivgtyp),z0tbl(ivgtyp)', & @@ -6904,7 +6915,9 @@ SUBROUTINE SOILVEGIN ( debug_print, & if (area.gt.1.) area=1. if (area <= 0.) then print *,'Bad area of grid box', area - stop + errflg = 1 + errmsg = 'ERROR(SOILVEGIN): Bad area of grid box' + return endif IF (debug_print ) THEN diff --git a/physics/myjsfc_wrapper.F90 b/physics/myjsfc_wrapper.F90 index 81cb36765..cebd2a9f1 100644 --- a/physics/myjsfc_wrapper.F90 +++ b/physics/myjsfc_wrapper.F90 @@ -334,7 +334,7 @@ SUBROUTINE myjsfc_wrapper_run( & & ,phy_f2d_myj(1:im,13) & & ,1,im,1,1,1,levs & & ,1,im,1,1,1,levs & - & ,1,im,1,1,1,levs) + & ,1,im,1,1,1,levs, errmsg, errflg) do i = 1, im if(flag_iter(i))then diff --git a/physics/noahmpdrv.F90 b/physics/noahmpdrv.F90 index fed823ead..615b7cbc7 100644 --- a/physics/noahmpdrv.F90 +++ b/physics/noahmpdrv.F90 @@ -93,7 +93,7 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, me, isot, ivegsrc, & !--- initialize soil vegetation - call set_soilveg(me, isot, ivegsrc, nlunit) + call set_soilveg(me, isot, ivegsrc, nlunit, errmsg, errflg) ! initialize psih and psim diff --git a/physics/noahmpdrv.meta b/physics/noahmpdrv.meta index 3235b7c90..29ce6f2f7 100644 --- a/physics/noahmpdrv.meta +++ b/physics/noahmpdrv.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = noahmpdrv type = scheme - dependencies = funcphys.f90,machine.F,sfc_diff.f,module_sf_noahmp_glacier.f90,module_sf_noahmplsm.f90,noahmp_tables.f90,set_soilveg.f + dependencies = funcphys.f90,machine.F,sfc_diff.f,module_sf_noahmp_glacier.F90,module_sf_noahmplsm.F90,noahmp_tables.f90,set_soilveg.f ######################################################################## [ccpp-arg-table] diff --git a/physics/physcons.F90 b/physics/physcons.F90 index 41d37491a..7b7a71c98 100644 --- a/physics/physcons.F90 +++ b/physics/physcons.F90 @@ -53,8 +53,8 @@ module physcons real(kind=kind_phys),parameter:: con_omega =7.2921e-5_kind_phys !< ang vel of earth (\f$s^{-1}\f$) real(kind=kind_phys),parameter:: con_p0 =1.01325e5_kind_phys !< standard atmospheric pressure (\f$Pa\f$) ! real(kind=kind_phys),parameter:: con_solr =1.36822e+3_kind_phys ! solar constant (W/m2)-aer(2001) - real(kind=kind_phys),parameter:: con_solr_old =1.3660e+3_kind_phys !< solar constant (\f$W/m^{2}\f$)-Liu(2002) - real(kind=kind_phys),parameter:: con_solr =1.3608e+3_kind_phys !< solar constant (\f$W/m^{2}\f$)-nasa-sorce Tim(2008) + real(kind=kind_phys),parameter:: con_solr_2002 =1.3660e+3_kind_phys !< solar constant (\f$W/m^{2}\f$)-Liu(2002) + real(kind=kind_phys),parameter:: con_solr_2008 =1.3608e+3_kind_phys !< solar constant (\f$W/m^{2}\f$)-nasa-sorce Tim(2008) ! real(kind=kind_phys),parameter:: con_solr =1.36742732e+3_kind_phys ! solar constant (W/m2)-gfdl(1989) - OPR as of Jan 2006 ! Selected geophysics/astronomy constants with kind=kind_dyn real(kind=kind_dyn), parameter:: con_g_dyn =9.80665e+0_kind_dyn !< gravity (\f$m/s^{2}\f$) diff --git a/physics/physparam.f b/physics/physparam.f deleted file mode 100644 index 5518c6163..000000000 --- a/physics/physparam.f +++ /dev/null @@ -1,300 +0,0 @@ -!> \file physparam.f -!! This file contains module physparam. - -! ========================================================== !!!!! -! module physparam description !!!!! -! ========================================================== !!!!! -! ! -! This module defines commonly used control variables/parameters ! -! in physics related programs. ! -! ! -! Section 1 contains control variables defined in the form of ! -! parameter. They are pre-determined choices and not adjustable ! -! during model's run-time. ! -! ! -! Section 2 contains control variables defined as module variables.! -! They are more flexible to be changed during run-time by either ! -! through input namelist, or through model environment condition. ! -! They are preassigned here as the default values. ! -! ! -!!!!! ========================================================== !!!!! - -!> \defgroup phy_sparam GFS Physics Parameter Module -!! Those variables are grouped together in accordance with functionaity -!! and are given brief descriptions and value specifications. There are -!! two types of attributes (parameters vs. save) designated for the -!! control variables. Those with a "parameter" attribute are prescribed -!! with a preferred option value, while the ones with a "save" attribute -!! are given a default value but could be changed at the model's -!! execution-time (usually through an input of name-list file or through -!! run scripts). - -!> This module defines commonly used control variables and parameters -!! in physics related programs. - module physparam -! -! implicit none - -! --- ... define kind parameters here - -! ** if already exist, use the module containing kind definitions - use machine - -! ** otherwise, define kind parameter here -! implicit none -! integer, public, parameter :: kind_io4 = 4 -! integer, public, parameter :: kind_io8 = 8 -! integer, public, parameter :: kind_phys= selected_real_kind(13,60) ! the '60' maps to 64-bit real -! ..... - -! implicit none -! - public - -!================================================================================== -! Section - 1 - -! control flags are pre-set as run-time non-adjuztable parameters. -!================================================================================== - -! ............................................. ! -!> \name 1.1 Control flags for SW radiation -! ............................................. ! - -!> SW heating rate unit control flag: =1:k/day; =2:k/second. - integer,parameter :: iswrate = 2 - -!> SW minor gases effect control flag (CH4 and O2): =0:no; =1:yes. -!!\n =0: minor gases' effects are not included in calculations -!!\n =1: minor gases' effects are included in calculations - integer,parameter :: iswrgas = 1 - -!> SW optical property for liquid clouds -!!\n =0:input cld opt depth, ignoring iswcice setting -!!\n =1:cloud optical property scheme based on Hu and Stamnes(1993) \cite hu_and_stamnes_1993 method -!!\n =2:cloud optical property scheme based on Hu and Stamnes(1993) -updated - integer,save :: iswcliq = 1 - -!> SW optical property for ice clouds (only iswcliq>0) -!!\n =1:optical property scheme based on Ebert and Curry (1992) -!! \cite ebert_and_curry_1992 method -!!\n =2:optical property scheme based on Streamer v3.0 -!! \cite key_2002 method -!!\n =3:optical property scheme based on Fu's method (1996) -!! \cite fu_1996 method - integer,save :: iswcice = 3 - -!> SW control flag for scattering process approximation -!!\n =1:two-stream delta-eddington (Joseph et al. 1976 -!! \cite joseph_et_al_1976) -!!\n =2:two-stream PIFM (Zdunkowski et al. 1980 -!! \cite zdunkowski_et_al_1980) -!!\n =3:discrete ordinates (Liou, 1973 -!! \cite liou_1973) - integer,parameter :: iswmode = 2 - -! ............................................. ! -!> \name 1.2 Control flags for LW radiation -! ............................................. ! - -!> LW heating rate unit: =1:k/day; =2:k/second. - integer,parameter :: ilwrate = 2 - -!> LW minor gases effect control flag (CH4,N2O,O2,and some CFCs): -!!\n =0: minor gases' effects are not included in calculations -!!\n =1: minor gases' effects are included in calculations - integer,parameter :: ilwrgas = 1 - -!> LW optical property scheme for liquid clouds -!!\n =0:input cloud optical properties directly, not computed within -!!\n =1:input cwp,rew, use Hu and Stamnes(1993) -!! \cite hu_and_stamnes_1993 method - integer,save :: ilwcliq = 1 - -!> LW optical property scheme for ice clouds (only ilwcliq>0) -!!\n =1:optical property scheme based on Ebert and Curry (1992) -!! \cite ebert_and_curry_1992 method -!!\n =2:optical property scheme based on Streamer v3 -!! \cite key_2002 method -!!\n =3:optical property scheme use Fu's method (1998) -!! \cite fu_et_al_1998 method - integer,save :: ilwcice = 3 - -! ............................................. ! -!>\name 1.3 Control flag for LW aerosol property - -!> selects 1 band or multi bands for LW aerosol properties -!!\n =.true.:aerosol properties calculated in 1 broad LW band -!!\n =.false.:aerosol properties calculated in all LW bands -!!\n variable names diff in Opr CFS - logical,parameter :: lalw1bd =.false. - -!================================================================================== -! Section - 2 - -! values of control flags might be re-set in initialization subroutines -! (may be adjusted at run time based on namelist input or run condition) -!================================================================================== - -! ............................................. ! -!>\name 2.1 For module radiation_astronomy -! ............................................. ! - -!> solar constant scheme control flag -!!\n =0:fixed value=1366.0\f$W/m^2\f$(old standard) -!!\n =10:fixed value=1360.8\f$W/m^2\f$(new standard) -!!\n =1:NOAA ABS-scale TSI table (yearly) w 11-yr cycle approx -!!\n =2:NOAA TIM-scale TSI table (yearly) w 11-yr cycle approx -!!\n =3:CMIP5 TIM-scale TSI table (yearly) w 11-yr cycle approx -!!\n =4:CMIP5 TIM-scale TSI table (monthly) w 11-yr cycle approx -!!\n see ISOL in run scripts: Opr GFS=2; Opr CFS=1 - integer, save :: isolar = 0 - -!> external solar constant data table,solarconstant_noaa_a0.txt - character, save :: solar_file*26 -! data solar_file / 'solarconstantdata.txt ' / - data solar_file / 'solarconstant_noaa_a0.txt ' / - -! ............................................. ! -!> \name 2.2 For module radiation_aerosols -! ............................................. ! - -!> aerosol model scheme control flag -!!\n =0:seasonal global distributed OPAC aerosol climatology -!!\n =1:monthly global distributed GOCART aerosol climatology -!!\n =2: GOCART prognostic aerosol model -!!\n =5: OPAC climatoloy with new band mapping -!!\n Opr GFS=0; Opr CFS=n/a - integer, save :: iaermdl = 0 - -!> aerosol effect control flag -!!\n 3-digit flag 'abc': -!!\n a-stratospheric volcanic aerols -!!\n b-tropospheric aerosols for LW -!!\n c-tropospheric aerosols for SW -!!\n =0:aerosol effect is not included; =1:aerosol effect is included -!!\n Opr GFS/CFS =111; see IAER in run scripts - integer, save :: iaerflg = 0 - -!> external aerosols data file: aerosol.dat - character, save :: aeros_file*26 -! data aeros_file / 'climaeropac_global.txt ' / - data aeros_file / 'aerosol.dat ' / - -! ............................................. ! -!> \name 2.3 For module radiation_gases -! ............................................. ! - -!> co2 data source control flag -!!\n =0:prescribed value(380 ppmv) -!!\n =1:yearly global averaged annual mean from observations -!!\n =2:monthly 15 degree horizontal resolution from observations -!!\n Opr GFS/CFS=2; see ICO2 in run scripts - integer, save :: ico2flg = 0 - -!> controls external data at initial time and data usage during -!! forecast time -!!\n =-2:as in 0,but superimpose with seasonal climatology cycle -!!\n =-1:use user data,no extrapolation in overtime -!!\n =0:use IC time to select data,no extrapolation in overtime -!!\n =1:use forecast time to select data,extrapolate when necessary -!!\n =yyyy0:use yyyy year of data, no extrapolation -!!\n =yyyy1:use yyyy year of data, extrapolate when necessary -!!\n Opr GFS/CFS=1; see ICTM in run scripts - integer, save :: ictmflg = 0 - -!> ozone data source control flag -!!\n =0:use seasonal climatology ozone data -!!\n >0:use prognostic ozone scheme (also depend on other model control -!! variable at initial time) - integer, save :: ioznflg = 1 - -!> external co2 2d monthly obsv data table: co2historicaldata_2004.txt - character, save :: co2dat_file*26 -!> external co2 global annual mean data tb: co2historicaldata_glob.txt - character, save :: co2gbl_file*26 -!> external co2 user defined data table: co2userdata.txt - character, save :: co2usr_file*26 -!> external co2 clim monthly cycle data tb: co2monthlycyc.txt - character, save :: co2cyc_file*26 - data co2dat_file / 'co2historicaldata_2004.txt' / !year is run-time selected - data co2gbl_file / 'co2historicaldata_glob.txt' / - data co2usr_file / 'co2userdata.txt ' / - data co2cyc_file / 'co2monthlycyc.txt ' / - -! ............................................. ! -!>\name 2.4 For module radiation_clouds -! ............................................. ! - -!> cloud optical property scheme control flag -!!\n =0:use diagnostic cloud scheme for cloud cover and mean optical properties -!!\n =1:use prognostic cloud scheme for cloud cover and cloud properties - integer, save :: icldflg = 1 - -!> cloud overlapping control flag for Radiation -!!\n =0:use random cloud overlapping method -!!\n =1:use maximum-random cloud overlapping method -!!\n =2:use maximum cloud overlapping method -!!\n =3:use decorrelation length overlapping method -!!\n =4:use exponential overlapping method -!!\n =5:use exponential-random overlapping method -!!\n Opr GFS/CFS=1; see IOVR in run scripts - integer, save :: iovr = 1 -!!\n Decorrelation length type for iovr = 4 or 5 -!!\n =0:use constant decorrelation length defined by decorr_con (in module physcons) -!!\n =1:use day-of-year and latitude-varying decorrelation length - integer, save :: idcor = 1 - -!> sub-column cloud approx flag in SW radiation -!!\n =0:no McICA approximation in SW radiation -!!\n =1:use McICA with precribed permutation seeds (test mode) -!!\n =2:use McICA with randomly generated permutation seeds -!!\n Opr GFS/CFS=2; see ISUBC_SW in run scripts - integer, save :: isubcsw = 0 -!> sub-column cloud approx flag in LW radiation -!!\n =0:no McICA approximation in LW radiation -!!\n =1:use McICA with prescribed permutation seeds (test mode) -!!\n =2:use McICA with randomly generatedo -!!\n Opr GFS/CFS=2; see ISUBC_LW in run scripts - integer, save :: isubclw = 0 - -!> eliminating CRICK control flag - logical, save :: lcrick =.false. -!> in-cld condensate control flag - logical, save :: lcnorm =.false. -!> precip effect on radiation flag (Ferrier microphysics) - logical, save :: lnoprec =.false. -!> shallow convetion flag - logical, save :: lsashal =.false. - -! ............................................. ! -!>\name 2.5 For module radiation_surface -! ............................................. ! - -!> surface albedo scheme control flag -!!\n =0:vegetation type based climatological albedo scheme -!!\n =1:seasonal albedo derived from MODIS measurements - integer, save :: ialbflg = 0 - -!> surface emissivity scheme control flag -!!\n =0:black-body surface emissivity(=1.0) -!!\n =1:vegetation type based climatology emissivity(<1.0) -!!\n Opr GFS/CFS=1; see IEMS in run scripts - integer, save :: iemsflg = 0 - -!> external sfc emissivity data table: sfc_emissivity_idx.txt - character, save :: semis_file*26 - data semis_file / 'sfc_emissivity_idx.txt ' / - -! ............................................. ! -!> \name 2.6 general purpose -! ............................................. ! - -!> vertical profile indexing flag - integer, save :: ivflip = 1 - -!> initial permutaion seed for mcica radiation - integer, save :: ipsd0 = 0 - integer, save :: ipsdlim = 1e8 -! -!...................................! - end module physparam ! -!===================================! diff --git a/physics/radiation_aerosols.f b/physics/radiation_aerosols.f index 8f4562847..3cd5c64e1 100644 --- a/physics/radiation_aerosols.f +++ b/physics/radiation_aerosols.f @@ -15,25 +15,23 @@ ! inputs: ! ! ( NLAY, me ) ! ! outputs: ! -! ( none ) ! +! ( errflg, errmsg ) ! ! ! ! 'aer_update' -- updating aerosol data ! ! inputs: ! ! ( iyear, imon, me ) ! ! outputs: ! -! ( none ) ! +! ( errflg, errmsg ) ! ! ! ! 'setaer' -- mapping aeros profile, compute aeros opticals ! ! inputs: ! ! (prsi,prsl,prslk,tvly,rhlay,slmsk,tracer,aerfld,xlon,xlat, ! ! IMAX,NLAY,NLP1, lsswr,lslwr, ! ! outputs: ! -! (aerosw,aerolw,aerodp) ! +! (aerosw,aerolw,aerodp,errmsg,errflg) ! ! ! ! ! ! external modules referenced: ! -! 'module physparam' in 'physparam.f' ! -! 'module physcons' in 'physcons.f' ! ! 'module module_radsw_parameters' in 'radsw_xxxx#_param.f' ! ! 'module module_radlw_parameters' in 'radlw_xxxx#_param.f' ! ! 'module module_radlw_cntr_para' in 'radsw_xxxx#_param.f' ! @@ -128,11 +126,7 @@ module module_radiation_aerosols ! !........................................! ! - use physparam,only : iaermdl, iaerflg, lalw1bd, aeros_file, & - & ivflip, kind_phys, kind_io4, kind_io8 - use physcons, only : con_pi, con_rd, con_g, con_t0c, con_c, & - & con_boltz, con_plnk, con_amd - + use machine, only : kind_phys, kind_io4, kind_io8 use module_iounitdef, only : NIAERCM use module_radsw_parameters, only : NBDSW, wvnsw1=>wvnum1, & & NSWSTR, wvnsw2=>wvnum2 @@ -499,8 +493,8 @@ module module_radiation_aerosols ! !>\section gen_al General Algorithm !----------------------------------- subroutine aer_init & - & ( NLAY, me ) ! --- inputs -! --- outputs: ( to module variables ) + & ( NLAY, me, iaermdl, iaerflg, lalw1bd, aeros_file, con_pi, & + & con_t0c, con_c, con_boltz, con_plnk, errflg, errmsg) ! ================================================================== ! ! ! @@ -510,24 +504,26 @@ subroutine aer_init & ! inputs: ! ! NLAY - number of model vertical layers (not used) ! ! me - print message control flag ! -! ! -! outputs: (to module variables) ! -! ! -! external module variables: (in physparam) ! ! iaermdl - tropospheric aerosol model scheme flag ! ! =0 opac-clim; =1 gocart-clim, =2 gocart-prognostic ! ! =5 opac-clim new spectral mapping ! +! lalw1bd = logical lw aeros propty 1 band vs multi-band cntl flag ! +! =t use 1 broad band optical property ! +! =f use multi bands optical property ! +! ! +! outputs: (CCPP error handling) ! +! errmsg - CCPP error message ! +! errflg - CCPP error flag ! +! ! +! internal module variables: ! ! lalwflg - logical lw aerosols effect control flag ! ! =t compute lw aerosol optical prop ! ! laswflg - logical sw aerosols effect control flag ! ! =t compute sw aerosol optical prop ! ! lavoflg - logical stratosphere volcanic aerosol control flag ! ! =t include volcanic aerosol effect ! -! lalw1bd = logical lw aeros propty 1 band vs multi-band cntl flag ! -! =t use 1 broad band optical property ! -! =f use multi bands optical property ! ! ! -! module constants: ! +! internal module constants: ! ! NWVSOL - num of wvnum regions where solar flux is constant ! ! NWVTOT - total num of wave numbers used in sw spectrum ! ! NWVTIR - total num of wave numbers used in the ir region ! @@ -542,9 +538,14 @@ subroutine aer_init & ! ================================================================== ! ! --- inputs: - integer, intent(in) :: NLAY, me - -! --- output: ( none ) + integer, intent(in) :: NLAY, me, iaermdl, iaerflg + logical, intent(in) :: lalw1bd + character(len=26),intent(in) :: aeros_file + real(kind_phys), intent(in) :: con_pi,con_t0c, con_c, con_boltz, & + & con_plnk +! --- output: + integer, intent(out) :: errflg + character(len=*), intent(out) :: errmsg ! --- locals: real (kind=kind_phys), dimension(NWVTOT) :: solfwv ! one wvn sol flux @@ -552,6 +553,11 @@ subroutine aer_init & ! !===> ... begin here ! + +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + kyrstr = 1 kyrend = 1 kyrsav = 1 @@ -565,9 +571,9 @@ subroutine aer_init & if ( me == 0 ) then - call wrt_aerlog ! write aerosol param info to log file + call wrt_aerlog(iaermdl, iaerflg, lalw1bd, errflg, errmsg) ! write aerosol param info to log file ! --- inputs: (in scope variables) -! --- outputs: ( none ) +! --- outputs: (CCPP error handling) endif @@ -617,33 +623,36 @@ subroutine aer_init & !> -# Call set_spectrum to set up spectral one wavenumber solar/IR !! fluxes. - call set_spectrum + call set_spectrum(con_pi, con_t0c, con_c, con_boltz, con_plnk, & + & errflg, errmsg) ! --- inputs: (module constants) -! --- outputs: (in-scope variables) +! --- outputs: (ccpp error handling) !> -# Call clim_aerinit() to invoke tropospheric aerosol initialization. if ( iaermdl==0 .or. iaermdl==5 ) then ! opac-climatology scheme - call clim_aerinit & ! --- inputs: - & ( solfwv, eirfwv, me & + & ( solfwv, eirfwv, me, aeros_file, & ! --- outputs: - & ) + & errflg, errmsg) elseif ( iaermdl==1 .or. iaermdl==2 ) then ! gocart clim/prog scheme call gocart_aerinit & ! --- inputs: - & ( solfwv, eirfwv, me & + & ( solfwv, eirfwv, me, & ! --- outputs: - & ) + & errflg, errmsg) else if ( me == 0 ) then print *,' !!! ERROR in aerosol model scheme selection', & & ' iaermdl =',iaermdl - stop + errflg = 1 + errmsg = 'ERROR(aer_init): aerosol model scheme selected'// & + & 'is invalid' + return endif endif @@ -654,9 +663,9 @@ subroutine aer_init & if ( lavoflg ) then - call set_volcaer + call set_volcaer(errflg, errmsg) ! --- inputs: (module variables) -! --- outputs: (module variables) +! --- outputs: (module variables: ccpp error handling) endif ! end if_lavoflg_block @@ -667,11 +676,7 @@ subroutine aer_init & !> This subroutine writes aerosol parameter configuration to run log file. !-------------------------------- - subroutine wrt_aerlog -!................................ -! --- inputs: (in scope variables) -! --- outputs: ( none ) - + subroutine wrt_aerlog(iaermdl, iaerflg, lalw1bd, errflg, errmsg) ! ================================================================== ! ! ! ! subprogram : wrt_aerlog ! @@ -680,15 +685,18 @@ subroutine wrt_aerlog ! ! ! ==================== defination of variables =================== ! ! ! -! external module variables: (in physparam) ! -! iaermdl - aerosol scheme flag: 0:opac-clm; 1:gocart-clim; ! -! 2:gocart-prog; 5:opac-clim+new mapping ! -! iaerflg - aerosol effect control flag: 3-digits (volc,lw,sw) ! +! internal module variables: ! ! lalwflg - toposphere lw aerosol effect: =f:no; =t:yes ! ! laswflg - toposphere sw aerosol effect: =f:no; =t:yes ! -! lavoflg - stratospherer volcanic aeros effect: =f:no; =t:yes ! +! lavoflg - stratosphere volcanic aeros effect: =f:no; =t:yes ! +! ! +! inputs: ! +! iaerflg - aerosol effect control flag: 3-digits (volc,lw,sw) ! +! iaermdl - tropospheric aerosol model scheme flag ! ! ! -! outputs: ( none ) ! +! outputs: ! +! errmsg - CCPP error message ! +! errflg - CCPP error flag ! ! ! ! subroutines called: none ! ! ! @@ -696,13 +704,22 @@ subroutine wrt_aerlog ! ! ! ================================================================== ! -! --- inputs: ( none ) -! --- output: ( none ) +! --- inputs: () + integer, intent(in) :: iaermdl, iaerflg + logical, intent(in) :: lalw1bd +! --- output: (CCPP error handling) + integer, intent(out) :: errflg + character(len=*), intent(out) :: errmsg ! --- locals: ! !===> ... begin here ! + +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + print *, VTAGAER ! print out version tag if ( iaermdl==0 .or. iaermdl==5 ) then @@ -717,7 +734,10 @@ subroutine wrt_aerlog else print *,' !!! ERROR in selection of aerosol model scheme', & & ' IAER_MDL =',iaermdl - stop + errflg = 1 + errmsg = 'ERROR(wrt_aerlog): Selected aerosol model scheme is'//& + & 'is invalid' + return endif ! end_if_iaermdl_block print *,' IAER=',iaerflg,' LW-trop-aer=',lalwflg, & @@ -764,10 +784,8 @@ end subroutine wrt_aerlog !> This subroutine defines the one wavenumber solar fluxes based on toa !! solar spectral distribution, and define the one wavenumber IR fluxes !! based on black-body emission distribution at a predefined temperature. - subroutine set_spectrum -!................................ -! --- inputs: (module constants) -! --- outputs: (in-scope variables) + subroutine set_spectrum(con_pi, con_t0c, con_c, con_boltz, & + & con_plnk, errflg, errmsg) ! ================================================================== ! ! ! @@ -779,7 +797,14 @@ subroutine set_spectrum ! ! ! ==================== defination of variables =================== ! ! ! -!> - inputs: (module constants) +!> - inputs: (CCPP Interstitials) +!! - con_pi: Physical constant (pi) +!! - con_t0c: Physical constant (temperature kelvin at zero celcius) +!! - con_c: Physical constant (speed of light) +!! - con_boltz: Physical constant (Boltzmann constant) +!! - con_plnk: Physical constant (Planck constant) +!! +!> - inputs: (in-scope variables) !! - NWVTOT: total num of wave numbers used in sw spectrum !! - NWVTIR: total num of wave numbers used in the ir region !! @@ -788,6 +813,10 @@ subroutine set_spectrum !! (\f$W/m^2\f$) !! - eirfwv(NWVTIR): ir flux(273k) for each individual wavenumber !! (\f$W/m^2\f$) +!! +!> - outputs: (CCPP error-handling) +!! - errflg: CCPP error flag +!! - errmsg: CCPP error message ! ! ! subroutines called: none ! ! ! @@ -797,15 +826,24 @@ subroutine set_spectrum ! --- inputs: (module constants) ! integer :: NWVTOT, NWVTIR +! --- inputs: (CCPP Interstitials) + real(kind_phys),intent(in) :: con_pi, con_t0c, con_c, con_boltz, & + & con_plnk ! --- output: (in-scope variables) ! real (kind=kind_phys), dimension(NWVTOT) :: solfwv ! one wvn sol flux ! real (kind=kind_phys), dimension(NWVTIR) :: eirfwv ! one wvn ir flux - +! --- output: (CCPP error-handling) + integer, intent(out) :: errflg + character(len=*), intent(out) :: errmsg ! --- locals: real (kind=kind_phys) :: soltot, tmp1, tmp2, tmp3 integer :: nb, nw, nw1, nw2, nmax, nmin + +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 ! !===> ... begin here ! @@ -857,11 +895,12 @@ end subroutine set_spectrum !> The initialization program for stratospheric volcanic aerosols. !----------------------------- - subroutine set_volcaer + subroutine set_volcaer(errflg, errmsg) !............................. -! --- inputs: ( none ) -! --- outputs: (module variables) - +! --- inputs: ( none ) ! +! outputs: (CCPP error handling) ! +! errflg - CCPP error flag ! +! errmsg - CCPP error message ! ! ================================================================== ! ! ! ! subprogram : set_volcaer ! @@ -877,13 +916,19 @@ subroutine set_volcaer ! --- inputs: (none) -! --- output: (module variables) +! --- output: (CCPP error handling) ! integer :: ivolae(:,:,:) - + integer, intent(out) :: errflg + character(len=*), intent(out) :: errmsg ! --- locals: ! !===> ... begin here ! + +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! --- allocate data space if ( .not. allocated(ivolae) ) then @@ -910,8 +955,8 @@ end subroutine aer_init !! !!\section gen_clim_aerinit General Algorithm subroutine clim_aerinit & - & ( solfwv, eirfwv, me & ! --- inputs - & ) ! --- outputs + & ( solfwv, eirfwv, me, aeros_file, & ! --- inputs + & errflg, errmsg) ! --- outputs ! ================================================================== ! ! ! @@ -922,24 +967,17 @@ subroutine clim_aerinit & ! solfwv(NWVTOT) - solar flux for each individual wavenumber (w/m2)! ! eirfwv(NWVTIR) - ir flux(273k) for each individual wavenum (w/m2)! ! me - print message control flag ! +! aeros_file - external aerosol data file name ! ! ! -! outputs: (to module variables) ! +! outputs: (CCPP error handling) ! +! errflg - CCPP error flag ! +! errmsg - CCPP error message ! ! ! -! external module variables: (in physparam) ! -! iaerflg - abc 3-digit integer aerosol flag (abc:volc,lw,sw) ! -! a: =0 use background stratospheric aerosol ! -! =1 incl stratospheric vocanic aeros (MINVYR-MAXVYR) ! -! b: =0 no topospheric aerosol in lw radiation ! -! =1 include tropspheric aerosols for lw radiation ! -! c: =0 no topospheric aerosol in sw radiation ! -! =1 include tropspheric aerosols for sw radiation ! +! internal module variables: ! ! lalwflg - logical lw aerosols effect control flag ! ! =t compute lw aerosol optical prop ! ! laswflg - logical sw aerosols effect control flag ! ! =t compute sw aerosol optical prop ! -! lalw1bd = logical lw aeros propty 1 band vs multi-band cntl flag ! -! =t use 1 broad band optical property ! -! =f use multi bands optical property ! ! ! ! module constants: ! ! NWVSOL - num of wvnum regions where solar flux is constant ! @@ -960,10 +998,11 @@ subroutine clim_aerinit & ! --- inputs: real (kind=kind_phys), dimension(:) :: solfwv ! one wvn sol flux real (kind=kind_phys), dimension(:) :: eirfwv ! one wvn ir flux - integer, intent(in) :: me - -! --- output: ( none ) + character(len=26), intent(in) :: aeros_file +! --- output: (CCPP error handling) + integer, intent(out) :: errflg + character(len=*), intent(out) :: errmsg ! --- locals: real (kind=kind_phys), dimension(NAERBND,NCM1) :: & @@ -982,10 +1021,14 @@ subroutine clim_aerinit & ! !===> ... begin here ! +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! --- ... invoke tropospheric aerosol initialization !> - call set_aercoef() to invoke tropospheric aerosol initialization. - call set_aercoef + call set_aercoef(aeros_file, errflg, errmsg) ! --- inputs: (in-scope variables, module constants) ! --- outputs: (module variables) @@ -999,10 +1042,10 @@ subroutine clim_aerinit & !! corresponding SW radiation spectral bands. !!\section det_set_aercoef General Algorithm !-------------------------------- - subroutine set_aercoef + subroutine set_aercoef(aeros_file,errflg, errmsg) !................................ ! --- inputs: (in-scope variables, module constants) -! --- outputs: (module variables) +! --- outputs: (CCPP error handling) ! ================================================================== ! ! ! @@ -1021,8 +1064,11 @@ subroutine set_aercoef ! me - integer, select cpu number as print control flag ! ! ! ! outputs: (to the module variables) ! +! outputs: (CCPP error handling) ! +! errflg - CCPP error flag ! +! errmsg - CCPP error message ! ! ! -! external module variables: (in physparam) ! +! external module variables: ! ! lalwflg - module control flag for lw trop-aer: =f:no; =t:yes ! ! laswflg - module control flag for sw trop-aer: =f:no; =t:yes ! ! aeros_file- external aerosol data file name ! @@ -1076,7 +1122,10 @@ subroutine set_aercoef ! ================================================================== ! ! ! --- inputs: ( none ) -! --- output: ( none ) + character(len=26),intent(in) :: aeros_file +! --- output: (CCPP error handling) + integer, intent(out) :: errflg + character(len=*), intent(out) :: errmsg ! --- locals: integer, dimension(NAERBND) :: iendwv @@ -1090,6 +1139,11 @@ subroutine set_aercoef ! !===> ... begin here ! + +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + !> -# Reading climatological aerosols optical data from aeros_file, !! including: @@ -1104,7 +1158,10 @@ subroutine set_aercoef print *,' Requested aerosol data file "',aeros_file, & & '" not found!' print *,' *** Stopped in subroutine aero_init !!' - stop + errflg = 1 + errmsg = 'ERROR(set_aercoef): Requested aerosol data file '// & + & aeros_file//' not found' + return endif ! end if_file_exist_block ! --- ... skip monthly global distribution @@ -1470,7 +1527,7 @@ subroutine optavg ! NSWBND - total number of sw spectral bands ! ! NLWBND - total number of lw spectral bands ! ! ! -! external module variables: (in physparam) ! +! external module variables: ! ! laswflg - control flag for sw spectral region ! ! lalwflg - control flag for lw spectral region ! ! ! @@ -1705,22 +1762,25 @@ end subroutine clim_aerinit !>\section gen_aer_upd General Algorithm !----------------------------------- subroutine aer_update & - & ( iyear, imon, me ) ! --- inputs: -! --- outputs: ( to module variables ) + & ( iyear, imon, me, iaermdl, aeros_file, errflg, errmsg ) ! ================================================================== ! ! ! ! aer_update checks and update time varying climatology aerosol ! ! data sets. ! ! ! -! inputs: size ! -! iyear - 4-digit calender year 1 ! -! imon - month of the year 1 ! -! me - print message control flag 1 ! +! inputs: size ! +! iyear - 4-digit calender year 1 ! +! imon - month of the year 1 ! +! me - print message control flag 1 ! +! iaermdl - tropospheric aerosol model scheme flag 1 ! +! aeros_file - external aerosol data file name len=26 ! ! ! -! outputs: ( none ) ! +! outputs: (CCPP error handling) len=* ! +! errmsg - CCPP error message 1 ! +! errflg - CCPP error flag ! ! ! -! external module variables: (in physparam) ! +! internal module variables: ! ! lalwflg - control flag for tropospheric lw aerosol ! ! laswflg - control flag for tropospheric sw aerosol ! ! lavoflg - control flag for stratospheric volcanic aerosol ! @@ -1732,33 +1792,41 @@ subroutine aer_update & ! ================================================================== ! ! --- inputs: - integer, intent(in) :: iyear, imon, me - -! --- output: ( none ) - + integer, intent(in) :: iyear, imon, me, iaermdl + character(len=26),intent(in) :: aeros_file +! --- output: (CCPP error-handling) + integer, intent(out) :: errflg + character(len=*), intent(out) :: errmsg ! --- locals: ( none ) ! !===> ... begin here ! + +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + if ( imon < 1 .or. imon > 12 ) then print *,' ***** ERROR in specifying requested month !!! ', & & 'imon=', imon print *,' ***** STOPPED in subroutinte aer_update !!!' - stop + errflg = 1 + errmsg = 'ERROR(aer_update): Requested month not valid' + return endif !> -# Call trop_update() to update monthly tropospheric aerosol data. if ( lalwflg .or. laswflg ) then if ( iaermdl == 0 .or. iaermdl==5 ) then ! opac-climatology scheme - call trop_update + call trop_update(aeros_file, errflg, errmsg) endif endif !> -# Call volc_update() to update yearly stratospheric volcanic aerosol data. if ( lavoflg ) then - call volc_update + call volc_update(errflg, errmsg) endif @@ -1769,10 +1837,7 @@ subroutine aer_update & !> This subroutine updates the monthly global distribution of aerosol !! profiles in five degree horizontal resolution. !-------------------------------- - subroutine trop_update -!................................ -! --- inputs: (in scope variables, module variables) -! --- outputs: (module variables) + subroutine trop_update(aeros_file, errflg, errmsg) ! ================================================================== ! ! ! @@ -1786,11 +1851,14 @@ subroutine trop_update ! inputs: (in-scope variables, module constants) ! ! imon - integer, month of the year ! ! me - integer, print message control flag ! +! inputs: (CCPP Interstitials) ! +! aeros_file - external aerosol data file name ! ! ! ! outputs: (module variables) ! -! ! -! external module variables: (in physparam) ! -! aeros_file - external aerosol data file name ! +! +! outputs: (CCPP error-handling) ! +! errmsg - Error message ! +! errflg - Error flag ! ! ! ! internal module variables: ! ! kprfg ( IMXAE*JMXAE) - aeros profile index ! @@ -1806,8 +1874,11 @@ subroutine trop_update ! ! ! ================================================================== ! -! --- inputs: ( none ) -! --- output: ( none ) +! --- inputs: (CCPP Interstitials) + character(len=26),intent(in) :: aeros_file +! --- output: (CCPP error handling) + integer, intent(out) :: errflg + character(len=*), intent(out) :: errmsg ! --- locals: ! real (kind=kind_io8) :: cmix(NXC), denn, tem @@ -1821,6 +1892,11 @@ subroutine trop_update ! !===> ... begin here ! + +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! --- ... reading climatological aerosols data inquire (file=aeros_file, exist=file_exist) @@ -1838,7 +1914,10 @@ subroutine trop_update print *,' Requested aerosol data file "',aeros_file, & & '" not found!' print *,' *** Stopped in subroutine trop_update !!' - stop + errflg = 1 + errmsg = 'ERROR(trop_update):Requested aerosol data file '// & + & aeros_file // ' not found.' + return endif ! end if_file_exist_block !$omp parallel do private(i,j,m) @@ -1930,10 +2009,10 @@ end subroutine trop_update !> This subroutine searches historical volcanic data sets to find and !! read in monthly 45-degree lat-zone band of optical depth. !-------------------------------- - subroutine volc_update + subroutine volc_update(errflg, errmsg) !................................ ! --- inputs: (in scope variables, module variables) -! --- outputs: (module variables) +! --- outputs: (CCPP error handling) ! ================================================================== ! ! ! @@ -1957,6 +2036,10 @@ subroutine volc_update ! kyrsav - integer, the year of data in use in the input file ! ! kmonsav - integer, the month of data in use in the input file ! ! ! +! outputs: (CCPP error-handling) ! +! errmsg - Error message ! +! errflg - Error flag ! +! ! ! subroutines called: none ! ! ! ! usage: call volc_aerinit ! @@ -1968,6 +2051,9 @@ subroutine volc_update ! --- output: (module variables) ! integer :: ivolae(:,:,:), kyrstr, kyrend, kyrsav, kmonsav +! --- output: (CCPP error-handling) + integer, intent(out) :: errflg + character(len=*), intent(out) :: errmsg ! --- locals: integer :: i, j, k @@ -1978,6 +2064,11 @@ subroutine volc_update ! !===> ... begin here ! + +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + kmonsav = imon if ( kyrstr<=iyear .and. iyear<=kyrend ) then ! use previously input data @@ -2032,7 +2123,10 @@ subroutine volc_update print *,' Requested volcanic data file "', & & volcano_file,'" not found!' print *,' *** Stopped in subroutine VOLC_AERINIT !!' - stop + errflg = 1 + errmsg = 'ERROR(volc_update): Requested volcanic data '// & + & 'file '//volcano_file//' not found!' + return endif ! end if_file_exist_block endif ! end if_iyear_block @@ -2083,9 +2177,9 @@ end subroutine aer_update !----------------------------------- subroutine setaer & & ( prsi,prsl,prslk,tvly,rhlay,slmsk,tracer,aerfld,xlon,xlat, & ! --- inputs - & IMAX,NLAY,NLP1, lsswr,lslwr, & - & aerosw,aerolw & ! --- outputs - &, aerodp & + & IMAX,NLAY,NLP1, lsswr,lslwr,iaermdl,iaerflg,top_at_1, & + & con_pi,con_rd,con_g,aerosw,aerolw, & ! --- outputs + & aerodp, errflg, errmsg & & ) ! ================================================================== ! @@ -2109,6 +2203,12 @@ subroutine setaer & ! NLAY,NLP1-vertical dimensions of arrays 1 ! ! lsswr,lslwr ! ! - logical flags for sw/lw radiation calls 1 ! +! con_pi - Physical constant (pi) ! +! con_t0c - Physical constant (temperature kelvin at zero celcius) ! +! con_c - Physical constant (speed of light) ! +! iaermdl - tropospheric aerosol model scheme flag ! +! iaerflg - aerosol effect control flag ! +! top_at_1 - Vertical ordering convection flag ! ! ! ! outputs: ! ! aerosw - aeros opt properties for sw IMAX*NLAY*NBDSW*NF_AESW! @@ -2122,18 +2222,16 @@ subroutine setaer & ! tau_gocart - 550nm aeros opt depth IMAX*NLAY*MAX_NUM_GRIDCOMP! !! aerodp - vertically integrated optical depth IMAX*NSPC1 ! ! ! -! external module variable: (in physparam) ! -! iaerflg - aerosol effect control flag (volc,lw,sw, 3-dig) ! +! errflg - CCPP error flag ! +! errmsg - CCPP error message ! +! ! +! internal module variable: ! ! laswflg - tropospheric aerosol control flag for sw radiation ! ! =f: no sw aeros calc. =t: do sw aeros calc. ! ! lalwflg - tropospheric aerosol control flag for lw radiation ! ! =f: no lw aeros calc. =t: do lw aeros calc. ! ! lavoflg - control flag for stratospheric vocanic aerosols ! ! =t: add volcanic aerosols to the background aerosols ! -! ivflip - control flag for direction of vertical index ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! ! ! internal module variable: (set by subroutine aer_init) ! ! ivolae - stratosphere volcanic aerosol optical depth (fac 1.e4) ! ! 12*4*10 ! @@ -2144,8 +2242,8 @@ subroutine setaer & ! ================================================================== ! ! --- inputs: - integer, intent(in) :: IMAX, NLAY, NLP1 - + integer, intent(in) :: IMAX, NLAY, NLP1, iaermdl, iaerflg + real (kind=kind_phys), intent(in) :: con_pi, con_rd, con_g real (kind=kind_phys), dimension(:,:), intent(in) :: prsi, prsl, & & prslk, tvly, rhlay real (kind=kind_phys), dimension(:), intent(in) :: xlon, xlat, & @@ -2153,7 +2251,7 @@ subroutine setaer & real (kind=kind_phys), dimension(:,:,:),intent(in):: tracer real (kind=kind_phys), dimension(:,:,:),intent(in):: aerfld - logical, intent(in) :: lsswr, lslwr + logical, intent(in) :: lsswr, lslwr, top_at_1 ! --- outputs: @@ -2161,6 +2259,8 @@ subroutine setaer & & aerosw, aerolw real (kind=kind_phys), dimension(:,:) , intent(out) :: aerodp + integer, intent(out) :: errflg + character(len=*), intent(out) :: errmsg ! --- locals: real (kind=kind_phys), parameter :: psrfh = 5.0 ! ref press (mb) for upper bound @@ -2177,10 +2277,16 @@ subroutine setaer & logical :: laddlw=.false., laerlw=.false. ! --- conversion constants - real (kind=kind_phys), parameter :: rdg = 180.0 / con_pi - real (kind=kind_phys), parameter :: rovg = 0.001 * con_rd / con_g + real (kind=kind_phys) :: rdg + real (kind=kind_phys) :: rovg !===> ... begin here + rdg = 180._kind_phys / con_pi + rovg = 0.001_kind_phys * con_rd / con_g + +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 do m = 1, NF_AESW do j = 1, NBDSW @@ -2235,7 +2341,7 @@ subroutine setaer & lab_do_IMAX : do i = 1, IMAX - lab_if_flip : if (ivflip == 1) then ! input from sfc to toa + lab_if_flip : if (.not. top_at_1) then ! input from sfc to toa do k = 1, NLAY prsln(k) = log(prsi(i,k)) @@ -2290,10 +2396,10 @@ subroutine setaer & ! --- inputs: & ( prsi,prsl,prslk,tvly,rhlay,dz,hz,tracer, & & alon,alat,slmsk, laersw,laerlw, & - & IMAX,NLAY,NLP1, & + & IMAX,NLAY,NLP1,top_at_1, & ! & IMAX,NLAY,NLP1,NSPC1, & ! --- outputs: - & aerosw,aerolw,aerodp & + & aerosw,aerolw,aerodp,errflg,errmsg & & ) ! @@ -2302,10 +2408,10 @@ subroutine setaer & call aer_property_gocart & ! --- inputs: & ( prsi,prsl,prslk,tvly,rhlay,dz,hz,tracer,aerfld, & - & alon,alat,slmsk,laersw,laerlw, & + & alon,alat,slmsk,laersw,laerlw,con_rd, & & IMAX,NLAY,NLP1, & ! --- outputs: - & aerosw,aerolw,aerodp & + & aerosw,aerolw,aerodp,errflg,errmsg & & ) endif ! end if_iaerflg_block @@ -2392,7 +2498,7 @@ subroutine setaer & endif enddo - if ( ivflip == 0 ) then ! input data from toa to sfc + if (top_at_1) then ! input data from toa to sfc ! --- find lower boundary of stratosphere @@ -2627,7 +2733,7 @@ subroutine setaer & endif ! end if_NLWBND_block endif ! end if_laddlw_block - endif ! end if_ivflip_block + endif ! end if_top_at_1_block endif ! end if_lavoflg_block ! @@ -2667,8 +2773,8 @@ end subroutine setaer subroutine aer_property & & ( prsi,prsl,prslk,tvly,rhlay,dz,hz,tracer, & ! --- inputs: & alon,alat,slmsk, laersw,laerlw, & - & IMAX,NLAY,NLP1, & - & aerosw,aerolw,aerodp & ! --- outputs: + & IMAX,NLAY,NLP1,top_at_1, & + & aerosw,aerolw,aerodp,errflg,errmsg & ! --- outputs: & ) ! ================================================================== ! @@ -2694,6 +2800,7 @@ subroutine aer_property & ! IMAX - horizontal dimension of arrays 1 ! ! NLAY,NLP1-vertical dimensions of arrays 1 ! !! NSPC - num of species for optional aod output fields 1 ! +! top_at_1 - vertical ordering flag ! ! ! ! outputs: ! ! aerosw - aeros opt properties for sw IMAX*NLAY*NBDSW*NF_AESW! @@ -2706,16 +2813,14 @@ subroutine aer_property & ! (:,:,:,3): asymmetry parameter ! !! aerodp - vertically integrated aer-opt-depth IMAX*NSPC+1 ! ! ! +! errflg - CCPP error flag ! +! errmsg - CCPP error message ! +! ! ! module parameters and constants: ! ! NSWBND - total number of actual sw spectral bands computed ! ! NLWBND - total number of actual lw spectral bands computed ! ! NSWLWBD - total number of sw+lw bands computed ! ! ! -! external module variables: (in physparam) ! -! ivflip - control flag for direction of vertical index ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! ! ! module variable: (set by subroutine aer_init) ! ! kprfg - aerosols profile index IMXAE*JMXAE ! ! 1:ant 2:arc 3:cnt 4:mar 5:des 6:marme 7:cntme ! @@ -2735,7 +2840,7 @@ subroutine aer_property & ! --- inputs: integer, intent(in) :: IMAX, NLAY, NLP1 ! integer, intent(in) :: IMAX, NLAY, NLP1, NSPC - logical, intent(in) :: laersw, laerlw + logical, intent(in) :: laersw, laerlw, top_at_1 real (kind=kind_phys), dimension(:,:), intent(in) :: prsi, prsl, & & prslk, tvly, rhlay, dz, hz @@ -2747,6 +2852,8 @@ subroutine aer_property & real (kind=kind_phys), dimension(:,:,:,:), intent(out) :: & & aerosw, aerolw real (kind=kind_phys), dimension(:,:) , intent(out) :: aerodp + integer, intent(out) :: errflg + character(len=*), intent(out) :: errmsg ! --- locals: real (kind=kind_phys), dimension(NCM) :: cmix @@ -2773,6 +2880,11 @@ subroutine aer_property & ! !===> ... begin here ! + +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + !> -# Map aerosol data to model grids !! - Map grid in longitude direction, lon from 0 to 355 deg resolution !! - Map grid in latitude direction, lat from 90n to 90s in 5 deg resolution @@ -2798,7 +2910,9 @@ subroutine aer_property & if ( i3 > IMXAE ) then print *,' ERROR! In setclimaer alon>360. ipt =',i, & & ', dltg,alon,tlon,dlon =',dltg,alon(i),tmp1,dtmp - stop + errflg = 1 + errmsg = 'ERROR(aer_property)' + return endif elseif ( dtmp >= f_zero ) then i1 = i3 @@ -2816,7 +2930,9 @@ subroutine aer_property & if ( i3 < 1 ) then print *,' ERROR! In setclimaer alon< 0. ipt =',i, & & ', dltg,alon,tlon,dlon =',dltg,alon(i),tmp1,dtmp - stop + errflg = 1 + errmsg = 'ERROR(aer_property)' + return endif endif enddo lab_do_IMXAE @@ -2835,7 +2951,9 @@ subroutine aer_property & if ( j3 >= JMXAE ) then print *,' ERROR! In setclimaer alat<-90. ipt =',i, & & ', dltg,alat,tlat,dlat =',dltg,alat(i),tmp2,dtmp - stop + errflg = 1 + errmsg = 'ERROR(aer_property)' + return endif elseif ( dtmp >= f_zero ) then j1 = j3 @@ -2853,7 +2971,9 @@ subroutine aer_property & if ( j3 < 1 ) then print *,' ERROR! In setclimaer alat>90. ipt =',i, & & ', dltg,alat,tlat,dlat =',dltg,alat(i),tmp2,dtmp - stop + errflg = 1 + errmsg = 'ERROR(aer_property)' + return endif endif enddo lab_do_JMXAE @@ -2950,14 +3070,16 @@ subroutine aer_property & dz1(k) = dz (i,k) enddo - lab_if_flip : if (ivflip == 1) then ! input from sfc to toa + lab_if_flip : if (.not. top_at_1) then ! input from sfc to toa if ( prsi(i,1) > 100.0 ) then rps = f_one / prsi(i,1) else print *,' !!! (1) Error in subr radiation_aerosols:', & & ' unrealistic surface pressure =', i,prsi(i,1) - stop + errflg = 1 + errmsg = 'ERROR(aer_property): Unrealistic surface pressure' + return endif ii = 1 @@ -3030,7 +3152,7 @@ subroutine aer_property & !> -# Call radclimaer() to calculate SW/LW aerosol optical properties !! for the corresponding frequency bands. - call radclimaer + call radclimaer(top_at_1) ! --- inputs: (in-scope variables) ! --- outputs: (in-scope variables) @@ -3091,7 +3213,7 @@ subroutine aer_property & !! troposphere, aerosol distribution at each grid point is composed !! from up to six components out of ten different substances. !-------------------------------- - subroutine radclimaer + subroutine radclimaer(top_at_1) !................................ ! --- inputs: (in scope variables) @@ -3127,6 +3249,7 @@ subroutine radclimaer parameter (crt1=30.0, crt2=0.03333) ! --- inputs: + logical, intent(in) :: top_at_1 ! --- outputs: ! --- locals: @@ -3329,7 +3452,7 @@ subroutine radclimaer ! !===> ... smooth profile at domain boundaries ! - if ( ivflip == 0 ) then ! input from toa to sfc + if (top_at_1) then ! input from toa to sfc do ib = 1, NSWLWBD do kk = 2, NLAY @@ -3404,8 +3527,8 @@ end subroutine aer_property !>\section gel_go_ini General Algorithm !----------------------------------- subroutine gocart_aerinit & - & ( solfwv, eirfwv, me & - & ) + & ( solfwv, eirfwv, me, & + & errflg, errmsg) ! ================================================================== ! ! ! @@ -3419,7 +3542,9 @@ subroutine gocart_aerinit & ! eirfwv(NWVTIR) - ir flux(273k) for each individual wavenum (w/m2)! ! me - print message control flag ! ! ! -! outputs: (to module variables) ! +! outputs: (CCPP error handling) ! +! errflg - CCPP error flag ! +! errmsg - CCPP error message ! ! ! ! module variables: ! ! NWVSOL - num of wvnum regions where solar flux is constant ! @@ -3445,7 +3570,9 @@ subroutine gocart_aerinit & integer, intent(in) :: me -! --- output: ( none ) +! --- output: (CCPP error handling) + integer, intent(out) :: errflg + character(len=*), intent(out) :: errmsg ! --- locals: real (kind=kind_phys), dimension(kaerbndi,kcm1) :: & @@ -3476,13 +3603,20 @@ subroutine gocart_aerinit & ! !===> ... begin here + +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! ! --- ... invoke gocart aerosol initialization if (KCM /= ntrcaerm ) then print *, 'ERROR in # of gocart aer species',KCM - stop 3000 + errflg = 1 + errmsg = 'ERROR(gocart_init): Incorrect # of species' + return endif ! --- ... aloocate and input aerosol optical data @@ -3801,7 +3935,9 @@ subroutine rd_gocart_luts else print *,' Requested luts file ',trim(fin),' not found' print *,' ** Stopped in rd_gocart_luts ** ' - stop 1220 + errflg = 1 + errmsg = 'Requested luts file '//trim(fin)//' not found' + return endif ! end if_file_exist_block iradius = 5 @@ -3866,7 +4002,9 @@ subroutine rd_gocart_luts else print *,' Requested luts file ',trim(fin),' not found' print *,' ** Stopped in rd_gocart_luts ** ' - stop 1222 + errflg = 1 + errmsg = 'Requested luts file '//trim(fin)//' not found' + return endif ! end if_file_exist_block ibeg = radius_lower(ib) - kcm1 @@ -3977,7 +4115,7 @@ subroutine optavg_gocart ! nswbnd - total number of sw spectral bands ! ! nlwbnd - total number of lw spectral bands ! ! ! -! external module variables: (in physparam) ! +! external module variables: ! ! laswflg - control flag for sw spectral region ! ! lalwflg - control flag for lw spectral region ! ! ! @@ -4193,10 +4331,10 @@ subroutine aer_property_gocart & ! --- inputs: & ( prsi,prsl,prslk,tvly,rhlay,dz,hz,tracer,aerfld, & - & alon,alat,slmsk, laersw,laerlw, & + & alon,alat,slmsk, laersw,laerlw,con_rd, & & imax,nlay,nlp1, & ! --- outputs: - & aerosw,aerolw,aerodp & + & aerosw,aerolw,aerodp,errflg,errmsg & & ) ! ================================================================== ! @@ -4222,6 +4360,7 @@ subroutine aer_property_gocart & ! - logical flag for sw/lw aerosol calculations ! ! IMAX - horizontal dimension of arrays 1 ! ! NLAY,NLP1-vertical dimensions of arrays 1 ! +! con_rd - Physical constant (gas constant for dry air) ! ! ! ! outputs: ! ! aerosw - aeros opt properties for sw IMAX*NLAY*NBDSW*NF_AESW! @@ -4233,17 +4372,14 @@ subroutine aer_property_gocart & ! (:,:,:,2): single scattering albedo ! ! (:,:,:,3): asymmetry parameter ! ! aerodp - vertically integrated aer-opt-depth IMAX*NSPC+1 ! +! errflg - CCPP error flag ! +! errmsg - CCPP error message ! ! ! ! module parameters and constants: ! ! NSWBND - total number of actual sw spectral bands computed ! ! NLWBND - total number of actual lw spectral bands computed ! ! NSWLWBD - total number of sw+lw bands computed ! ! ! -! external module variables: (in physparam) ! -! ivflip - control flag for direction of vertical index ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! ! ! module variable: (set by subroutine aer_init) ! ! ! ! usage: call aer_property_gocart ! @@ -4253,7 +4389,7 @@ subroutine aer_property_gocart & ! --- inputs: integer, intent(in) :: IMAX, NLAY, NLP1 logical, intent(in) :: laersw, laerlw - + real (kind=kind_phys), intent(in) :: con_rd real (kind=kind_phys), dimension(:,:), intent(in) :: prsi, prsl, & & prslk, tvly, rhlay, dz, hz real (kind=kind_phys), dimension(:), intent(in) :: alon, alat, & @@ -4265,6 +4401,8 @@ subroutine aer_property_gocart & real (kind=kind_phys), dimension(:,:,:,:), intent(out) :: & & aerosw, aerolw real (kind=kind_phys), dimension(:,:) , intent(out) :: aerodp + integer, intent(out) :: errflg + character(len=*), intent(out) :: errmsg ! --- locals: real (kind=kind_phys), dimension(nlay,nswlwbd):: tauae,ssaae,asyae @@ -4279,6 +4417,11 @@ subroutine aer_property_gocart & ! !===> ... begin here ! + +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + lab_do_IMAXg : do i = 1, IMAX ! --- initialize tauae, ssaae, asyae diff --git a/physics/radiation_astronomy.f b/physics/radiation_astronomy.f index 1d60c74ef..b25c89a8c 100644 --- a/physics/radiation_astronomy.f +++ b/physics/radiation_astronomy.f @@ -21,7 +21,7 @@ ! input: ! ! ( jdate,kyear,deltsw,deltim,lsol_chg, me ) ! ! output: ! -! ( slag,sdec,cdec,solcon ) ! +! ( slag,sdec,cdec,solcon,errmsg,errflg) ! ! ! ! 'coszmn' -- compute cosin of zenith angles ! ! input: ! @@ -29,11 +29,6 @@ ! output: ! ! ( coszen,coszdg ) ! ! ! -! ! -! external modules referenced: ! -! 'module physparam' in 'physparam.f' ! -! 'module physcons' in 'physcons.f' ! -! ! ! program history log: ! ! - a collection of programs to track solar-earth position ! ! may 1977 --- ray orzol (gfdl) created program compjd to ! @@ -93,8 +88,7 @@ !> This module sets up astronomy quantities for solar radiation calculations. module module_radiation_astronomy ! - use physparam, only : isolar, solar_file, kind_phys - use physcons, only : con_solr, con_solr_old, con_pi + use machine, only : kind_phys use module_iounitdef, only : NIRADSF ! implicit none @@ -107,17 +101,17 @@ module module_radiation_astronomy ! & VTAGAST='NCEP-Radiation_astronomy v5.1 Nov 2012 ' ! Parameter constants - real (kind=kind_phys), parameter :: degrad = 180.0/con_pi - real (kind=kind_phys), parameter :: tpi = 2.0 * con_pi - real (kind=kind_phys), parameter :: hpi = 0.5 * con_pi + real (kind=kind_phys) :: degrad + real (kind=kind_phys) :: tpi + real (kind=kind_phys) :: hpi + real (kind=kind_phys) :: pid12 real (kind=kind_phys), parameter :: f12 = 12.0 real (kind=kind_phys), parameter :: f3600 = 3600.0 real (kind=kind_phys), parameter :: czlimt = 0.0001 ! ~ cos(89.99427) - real (kind=kind_phys), parameter :: pid12 = con_pi/f12 ! angle per hour ! real (kind=kind_phys), parameter :: pid12 = (2.0*asin(1.0))/f12 ! Module variable (to be set in module_radiation_astronomy::sol_init): - real (kind=kind_phys), public :: solc0 = con_solr + real (kind=kind_phys), public :: solc0 integer :: isolflg = 10 character(26) :: solar_fname = ' ' @@ -133,7 +127,6 @@ module module_radiation_astronomy real (kind=kind_phys) :: anginc=0.0 ! saved monthly solar constants (isolflg=4 only) real (kind=kind_phys) :: smon_sav(12) - data smon_sav(1:12) / 12*con_solr / ! saved year of data used integer :: iyr_sav =0 @@ -152,7 +145,7 @@ module module_radiation_astronomy !!\param me print message control flag !>\section sol_init_gen sol_init General Algorithm subroutine sol_init & - & ( me ) ! --- inputs + & ( me, isolar, solar_file, con_solr, con_solr_old, con_pi ) ! --- inputs ! --- outputs: ( none ) ! =================================================================== ! @@ -161,18 +154,16 @@ subroutine sol_init & ! ! ! inputs: ! ! me - print message control flag ! -! ! -! outputs: (to module variable) ! -! ( none ) ! -! ! -! external module variable: (in physparam) ! -! isolar - = 0: use the old fixed solar constant in "physcon" ! -! =10: use the new fixed solar constant in "physcon" ! +! isolar - = 0: use the old fixed solar constant in "GFS_typedefs" ! +! =10: use the new fixed solar constant in "GFS_typedefs" ! ! = 1: use noaa ann-mean tsi tbl abs-scale with cyc apprx ! ! = 2: use noaa ann-mean tsi tbl tim-scale with cyc apprx ! ! = 3: use cmip5 ann-mean tsi tbl tim-scale with cyc apprx! ! = 4: use cmip5 mon-mean tsi tbl tim-scale with cyc apprx! -! solar_file- external solar constant data table ! +! solar_file - external solar constant data table ! +! ! +! outputs: (to module variable) ! +! ( none ) ! ! ! ! internal module variable: ! ! isolflg - internal solar constant scheme control flag ! @@ -189,23 +180,33 @@ subroutine sol_init & implicit none ! --- input: - integer, intent(in) :: me - + integer, intent(in) :: me, isolar + character(len=26), intent(in) :: solar_file + real(kind=kind_phys), intent(in) :: con_solr, con_solr_old, con_pi ! --- output: ( none ) ! --- local: logical :: file_exist + integer :: imonth ! !===> ... begin here ! if ( me == 0 ) print *, VTAGAST !print out version tag + degrad = 180.0/con_pi + tpi = 2.0 * con_pi + hpi = 0.5 * con_pi + pid12 = con_pi/f12 + ! --- initialization isolflg = isolar solc0 = con_solr solar_fname = solar_file iyr_sav = 0 nstp = 6 + do imonth = 1,12 + smon_sav(imonth) = con_solr + enddo if ( isolar == 0 ) then solc0 = con_solr_old @@ -326,7 +327,7 @@ end subroutine sol_init !----------------------------------- subroutine sol_update & & ( jdate,kyear,deltsw,deltim,lsol_chg, me, & ! --- inputs - & slag, sdec, cdec, solcon & ! --- outputs + & slag, sdec, cdec, solcon, con_pi, errmsg, errflg & ! --- outputs & ) ! =================================================================== ! @@ -348,6 +349,8 @@ subroutine sol_update & ! slag - equation of time in radians ! ! sdec, cdec - sin and cos of the solar declination angle ! ! solcon - sun-earth distance adjusted solar constant (w/m2) ! +! errmsg - CCPP error message ! +! errflg - CCPP error flag ! ! ! ! ! ! module variable: ! @@ -381,10 +384,12 @@ subroutine sol_update & integer, intent(in) :: jdate(:), kyear, me logical, intent(in) :: lsol_chg - real (kind=kind_phys), intent(in) :: deltsw, deltim + real (kind=kind_phys), intent(in) :: deltsw, deltim, con_pi ! --- output: real (kind=kind_phys), intent(out) :: slag, sdec, cdec, solcon + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg ! --- locals: real (kind=kind_phys), parameter :: hrday = 1.0/24.0 ! frc day/hour @@ -403,6 +408,10 @@ subroutine sol_update & ! !===> ... begin here ! +! Initialize the CCPP error handling variables + errmsg = '' + errflg = 0 + ! --- ... forecast time iyear = jdate(1) imon = jdate(2) @@ -425,7 +434,10 @@ subroutine sol_update & inquire (file=solar_fname, exist=file_exist) if ( .not. file_exist ) then print *,' !!! ERROR! Can not find solar constant file!!!' - stop + errflg = 1 + errmsg = "ERROR(radiation_astronomy): solar constant file"//& + & " not found" + return else iyr = iyear @@ -580,7 +592,7 @@ subroutine sol_update & !> -# Call solar() call solar & ! --- inputs: - & ( jd, fjd, & + & ( jd, fjd, con_pi, & ! --- outputs: & r1, dlt, alp & & ) @@ -644,7 +656,7 @@ end subroutine sol_update !>\section solar_gen solar General Algorithm !----------------------------------- subroutine solar & - & ( jd, fjd, & ! --- inputs + & ( jd, fjd, con_pi, & ! --- inputs & r1, dlt, alp & ! --- outputs & ) @@ -676,7 +688,7 @@ subroutine solar & implicit none ! --- inputs: - real (kind=kind_phys), intent(in) :: fjd + real (kind=kind_phys), intent(in) :: fjd, con_pi integer, intent(in) :: jd ! --- outputs: diff --git a/physics/radiation_cloud_overlap.F90 b/physics/radiation_cloud_overlap.F90 index d6169b3e5..737b9be61 100644 --- a/physics/radiation_cloud_overlap.F90 +++ b/physics/radiation_cloud_overlap.F90 @@ -4,7 +4,7 @@ !>\defgroup rad_cld_ovr_mod Radiation Cloud Overlap Module !! This module contains the calculation of cloud overlap parameters for both RRTMG and RRTMGP. module module_radiation_cloud_overlap - use physparam, only : kind_phys + use machine, only : kind_phys implicit none public :: cmp_dcorr_lgth diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index 7255f1578..ca9ea6e81 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -16,7 +16,7 @@ ! inputs: ! ! ( si, NLAY, imp_physics, me ) ! ! outputs: ! -! ( none ) ! +! ( errflg, errmsg ) ! ! ! ! 'radiation_clouds_prop' --- radiation cloud properties ! ! obtained from various cloud schemes ! @@ -29,8 +29,8 @@ ! imp_physics, imp_physics_nssl, imp_physics_fer_hires, ! ! imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, ! ! imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, ! -! imp_physics_mg, iovr_rand, iovr_maxrand, iovr_max, ! -! iovr_dcorr, iovr_exp, iovr_exprand, idcor_con, ! +! imp_physics_mg, iovr, iovr_rand, iovr_maxrand, iovr_max, ! +! iovr_dcorr, iovr_exp, iovr_exprand, idcor, idcor_con, ! ! idcor_hogan, idcor_oreopoulos, ! ! imfdeepcnv, imfdeepcnv_gf, do_mynnedmf, lgfdlmprad, ! ! uni_cld, lmfshal, lmfdeep2, cldcov, clouds1, ! @@ -68,12 +68,8 @@ ! ** fu's scheme need to be normalized by snow density (g/m**3/1.0e6)! ! ! ! external modules referenced: ! -! ! -! 'module physparam' in 'physparam.f' ! -! 'module physcons' in 'physcons.f' ! ! 'module module_microphysics' in 'module_bfmicrophysics.f' ! ! ! -! ! ! program history log: ! ! nov 1992, y.h., k.a.c, a.k. - cloud parameterization ! ! 'cldjms' patterned after slingo and slingo's work (jgr, ! @@ -169,13 +165,6 @@ !> This module computes cloud related quantities for radiation computations. module module_radiation_clouds ! - use physparam, only : icldflg, iovr, idcor, & - & lcrick, lcnorm, lnoprec, & - & ivflip - use physcons, only : con_fvirt, con_ttp, con_rocp, & - & con_t0c, con_pi, con_g, con_rd, & - & con_thgni, decorr_con - use module_microphysics, only : rsipath2 use module_iounitdef, only : NICLTUN use module_radiation_cloud_overlap, only: cmp_dcorr_lgth, & & get_alpha_exper @@ -191,9 +180,7 @@ module module_radiation_clouds ! & VTAGCLD='NCEP-Radiation_clouds v5.0 Aug 2012 ' ! --- set constant parameters - real (kind=kind_phys), parameter :: gfac=1.0e5/con_g & - &, gord=con_g/con_rd - + real (kind=kind_phys) :: gfac,gord integer, parameter, public :: NF_CLDS = 9 !< number of fields in cloud array integer, parameter, public :: NK_CLDS = 3 !< number of cloud vertical domains @@ -265,10 +252,7 @@ module module_radiation_clouds !!\param me print control flag !>\section cld_init General Algorithm subroutine cld_init & - & ( si, NLAY, imp_physics, me ) ! --- inputs -! --- outputs: -! ( none ) - + & ( si, NLAY, imp_physics, me, con_g, con_rd, errflg, errmsg ) ! =================================================================== ! ! ! ! abstract: cld_init is an initialization program for cloud-radiation ! @@ -280,31 +264,12 @@ subroutine cld_init & ! NLAY : vertical layer number ! ! imp_physics : MP identifier ! ! me : print control flag ! +! imp_physics : cloud microphysics scheme control flag ! ! ! -! outputs: (none) ! -! to module variables ! +! outputs: ! +! errflg : CCPP error flag ! +! errmsg : CCPP error message ! ! ! -! external module variables: (in physparam) ! -! icldflg : cloud optical property scheme control flag ! -! =0: abort! diagnostic cloud method discontinued ! -! =1: model use prognostic cloud method ! -! imp_physics : cloud microphysics scheme control flag ! -! =99: zhao/carr/sundqvist microphysics cloud ! -! =98: zhao/carr/sundqvist microphysics cloud+pdfcld! -! =11: GFDL microphysics cloud ! -! =8: Thompson microphysics ! -! =6: WSM6 microphysics ! -! =10: MG microphysics ! -! iovr : control flag for cloud overlapping scheme ! -! =0: random overlapping clouds ! -! =1: max/ran overlapping clouds ! -! =2: maximum overlap clouds (mcica only) ! -! =3: decorrelation-length overlap (mcica only) ! -! =4: exponential cloud overlap (AER; mcica only) ! -! =5: exponential-random overlap (AER; mcica only) ! -! ivflip : control flag for direction of vertical index ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! ! usage: call cld_init ! ! ! ! subroutines called: rhtable ! @@ -316,71 +281,51 @@ subroutine cld_init & ! --- inputs: integer, intent(in) :: NLAY, me, imp_physics - real (kind=kind_phys), intent(in) :: si(:) + real (kind=kind_phys), intent(in) :: si(:), con_g, con_rd -! --- outputs: (none) - -! --- locals: - integer :: k, kl, ier +! --- outputs: + integer, intent(out) :: errflg + character(len=*), intent(out) :: errmsg ! !===> ... begin here ! -! --- set up module variables - - if (me == 0) print *, VTAGCLD !print out version tag - - if ( icldflg == 0 ) then - print *,' - Diagnostic Cloud Method has been discontinued' - stop - - else - if (me == 0) then - print *,' - Using Prognostic Cloud Method' - if (imp_physics == 99) then +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! Initialze module parameters + gfac = 1.0e5/con_g + gord = con_g/con_rd + + if (me == 0) then + print *, VTAGCLD !print out version tag + print *,' - Using Prognostic Cloud Method' + if (imp_physics == 99) then print *,' --- Zhao/Carr/Sundqvist microphysics' - elseif (imp_physics == 98) then + elseif (imp_physics == 98) then print *,' --- zhao/carr/sundqvist + pdf cloud' - elseif (imp_physics == 11) then + elseif (imp_physics == 11) then print *,' --- GFDL Lin cloud microphysics' - elseif (imp_physics == 8) then + elseif (imp_physics == 8) then print *,' --- Thompson cloud microphysics' - elseif (imp_physics == 6) then + elseif (imp_physics == 6) then print *,' --- WSM6 cloud microphysics' - elseif (imp_physics == 10) then + elseif (imp_physics == 10) then print *,' --- MG cloud microphysics' - elseif (imp_physics == 15) then + elseif (imp_physics == 15) then print *,' --- Ferrier-Aligo cloud microphysics' - elseif (imp_physics == 17) then + elseif (imp_physics == 17) then print *,' --- NSSL cloud microphysics' - else + else print *,' !!! ERROR in cloud microphysc specification!!!', & & ' imp_physics (NP3D) =',imp_physics - stop - endif - endif + errflg = 1 + errmsg = 'ERROR(cld_init): cloud mp specification is not'// & + & ' valid' + return + endif endif - -!> - Compute the top of BL cld (llyr), which is the topmost non -!! cld(low) layer for stratiform (at or above lowest 0.1 of the -!! atmosphere). - - if ( ivflip == 0 ) then ! data from toa to sfc - lab_do_k0 : do k = NLAY, 2, -1 - kl = k - if (si(k) < 0.9e0) exit lab_do_k0 - enddo lab_do_k0 - - llyr = kl - else ! data from sfc to top - lab_do_k1 : do k = 2, NLAY - kl = k - if (si(k) < 0.9e0) exit lab_do_k1 - enddo lab_do_k1 - - llyr = kl - 1 - endif ! end_if_ivflip - ! return !................................... @@ -394,20 +339,21 @@ subroutine radiation_clouds_prop & & ( plyr, plvl, tlyr, tvly, qlyr, qstl, rhly, & ! --- inputs: & ccnd, ncndl, cnvw, cnvc, tracer1, & & xlat, xlon, slmsk, dz, delp, IX, LM, NLAY, NLP1, & - & deltaq, sup, me, icloud, kdt, & + & deltaq, sup, dcorr_con, me, icloud, kdt, & & ntrac, ntcw, ntiw, ntrw, ntsw, ntgl, ntclamt, & & imp_physics, imp_physics_nssl, imp_physics_fer_hires, & & imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, & & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & - & imp_physics_mg, iovr_rand, iovr_maxrand, iovr_max, & - & iovr_dcorr, iovr_exp, iovr_exprand, idcor_con, & - & idcor_hogan, idcor_oreopoulos, & + & imp_physics_mg, iovr, iovr_rand, iovr_maxrand, iovr_max, & + & iovr_dcorr, iovr_exp, iovr_exprand, idcor, idcor_con, & + & idcor_hogan, idcor_oreopoulos, lcrick, lcnorm, & & imfdeepcnv, imfdeepcnv_gf, do_mynnedmf, lgfdlmprad, & & uni_cld, lmfshal, lmfdeep2, cldcov, clouds1, & & effrl, effri, effrr, effrs, effr_in, & & effrl_inout, effri_inout, effrs_inout, & & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & - & dzlay, latdeg, julian, yearlen, gridkm, & + & dzlay, latdeg, julian, yearlen, gridkm, top_at_1, si, & + & con_ttp, con_pi, con_g, con_rd, con_thgni, & & cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, & ! --- outputs: & cld_rwp, cld_rerain, cld_swp, cld_resnow, & & clds, mtop, mbot, de_lgth, alpha & @@ -490,15 +436,17 @@ subroutine radiation_clouds_prop & ! imp_physics_zhao_carr : Zhao-Carr microphysics scheme ! ! imp_physics_zhao_carr_pdf : Zhao-Carr microphysics scheme with PDF clouds ! imp_physics_mg : Morrison-Gettelman microphysics scheme ! -! iovr_rand : choice of cloud-overlap: random (=0) -! iovr_maxrand : choice of cloud-overlap: maximum random (=1) -! iovr_max : choice of cloud-overlap: maximum (=2) -! iovr_dcorr : choice of cloud-overlap: decorrelation length (=3) -! iovr_exp : choice of cloud-overlap: exponential (=4) -! iovr_exprand : choice of cloud-overlap: exponential random (=5) -! idcor_con : choice for decorrelation-length: Use constant value (=0) -! idcor_hogan : choice for decorrelation-length: (=1) -! idcor_oreopoulos: choice for decorrelation-length: (=2) +! iovr : choice of cloud-overlap ! +! iovr_rand : flag of cloud-overlap: random (=0) ! +! iovr_maxrand : flag of cloud-overlap: maximum random (=1) ! +! iovr_max : flag of cloud-overlap: maximum (=2) ! +! iovr_dcorr : flag of cloud-overlap: decorrelation length(=3) ! +! iovr_exp : flag of cloud-overlap: exponential (=4) ! +! iovr_exprand : flag of cloud-overlap: exponential random (=5) ! +! idcor : choice for decorrelation-length ! +! idcor_con : flag for decorrelation-length: Use constant value (=0) +! idcor_hogan : flag for decorrelation-length: (=1) ! +! idcor_oreopoulos: flag for decorrelation-length: (=2) ! ! imfdeepcnv : flag for mass-flux deep convection scheme ! ! imfdeepcnv_gf : flag for scale- & aerosol-aware Grell-Freitas scheme (GSD) ! do_mynnedmf : flag for MYNN-EDMF ! @@ -506,6 +454,7 @@ subroutine radiation_clouds_prop & ! uni_cld : logical - true for cloud fraction from shoc ! ! lmfshal : logical - true for mass flux shallow convection ! ! lmfdeep2 : logical - true for mass flux deep convection ! +! top_at_1 : logical - true if ordered from toa-2-sfc ! ! cldcov : layer cloud fraction (used when uni_cld=.true. ! ! clouds1 : layer total cloud fraction ! effrl, : effective radius for liquid water @@ -524,7 +473,15 @@ subroutine radiation_clouds_prop & ! latdeg(ix) : latitude (in degrees 90 -> -90) ! ! julian : day of the year (fractional julian day) ! ! yearlen : current length of the year (365/366 days) ! -! gridkm : grid length in km +! gridkm : grid length in km ! +! lmfshal : mass-flux shallow conv scheme flag ! +! lmfdeep2 : scale-aware mass-flux deep conv scheme flag ! +! lcrick : control flag for eliminating CRICK ! +! =t: apply layer smoothing to eliminate CRICK ! +! =f: do not apply layer smoothing ! +! lcnorm : control flag for in-cld condensate ! +! =t: normalize cloud condensate ! +! =f: not normalize cloud condensate ! ! ! ! output variables: ! ! cloud profiles: ! @@ -542,20 +499,7 @@ subroutine radiation_clouds_prop & ! mtop (IX,3) : vertical indices for low, mid, hi cloud tops ! ! mbot (IX,3) : vertical indices for low, mid, hi cloud bases ! ! de_lgth(ix) : clouds decorrelation length (km) ! -! alpha(ix,nlay) : alpha decorrelation parameter -! ! -! module variables: ! -! ivflip : control flag of vertical index direction ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! lmfshal : mass-flux shallow conv scheme flag ! -! lmfdeep2 : scale-aware mass-flux deep conv scheme flag ! -! lcrick : control flag for eliminating CRICK ! -! =t: apply layer smoothing to eliminate CRICK ! -! =f: do not apply layer smoothing ! -! lcnorm : control flag for in-cld condensate ! -! =t: normalize cloud condensate ! -! =f: not normalize cloud condensate ! +! alpha(ix,nlay) : alpha decorrelation parameter ! ! ! ! ==================== end of description ===================== ! implicit none @@ -577,19 +521,21 @@ subroutine radiation_clouds_prop & & imp_physics_mg ! Flag for MG scheme integer, intent(in) :: & + & iovr, ! & iovr_rand, ! Flag for random cloud overlap method & iovr_maxrand, ! Flag for maximum-random cloud overlap method & iovr_max, ! Flag for maximum cloud overlap method & iovr_dcorr, ! Flag for decorrelation-length cloud overlap method & iovr_exp, ! Flag for exponential cloud overlap method & iovr_exprand, ! Flag for exponential-random cloud overlap method + & idcor, & idcor_con, & idcor_hogan, & idcor_oreopoulos - logical, intent(in) :: uni_cld, lmfshal, lmfdeep2, effr_in - logical, intent(in) :: do_mynnedmf, lgfdlmprad + logical, intent(in) :: uni_cld, lmfshal, lmfdeep2, effr_in, & + & do_mynnedmf, lgfdlmprad, top_at_1, lcrick, lcnorm real (kind=kind_phys), dimension(:,:,:), intent(in) :: ccnd, & & tracer1 @@ -597,9 +543,10 @@ subroutine radiation_clouds_prop & & tlyr, tvly, qlyr, qstl, rhly, cnvw, cnvc, cldcov, & & delp, dz, effrl, effri, effrr, effrs, dzlay, clouds1 - real (kind=kind_phys), intent(in) :: sup + real (kind=kind_phys), intent(in) :: sup, dcorr_con, con_ttp, & + & con_pi, con_g, con_rd, con_thgni real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & - & slmsk + & slmsk, si real(kind=kind_phys), dimension(:), intent(in) :: latdeg, gridkm real(kind=kind_phys), intent(in) :: julian @@ -677,7 +624,7 @@ subroutine radiation_clouds_prop & & IX, NLAY, NLP1, cldcov, & & effrl, effri, effrr, effrs, effr_in, & & dzlay, & - & cldtot, cldcnv, & ! inout + & cldtot, cldcnv, lcrick, lcnorm, con_ttp, & ! inout & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs & cld_reice,cld_rwp, cld_rerain,cld_swp, & & cld_resnow) @@ -688,7 +635,7 @@ subroutine radiation_clouds_prop & & lmfshal, lmfdeep2, & & cldcov, effrl, effri, effrr, effrs, effr_in, & & dzlay, & - & cldtot, cldcnv, & ! inout + & cldtot, cldcnv, lcrick, lcnorm, con_ttp, & ! inout & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs & cld_reice,cld_rwp, cld_rerain,cld_swp, & & cld_resnow) @@ -700,8 +647,8 @@ subroutine radiation_clouds_prop & & qstl, rhly, ccnd(1:IX,1:NLAY,1), cnvw, cnvc, & & xlat, xlon, slmsk, dz, delp, IX, NLAY, NLP1, & & deltaq, sup, kdt, me, dzlay, & - & cldtot, cldcnv, & ! inout - & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs + & cldtot, cldcnv, lcrick, lcnorm, con_thgni, & ! inout + & con_ttp, cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs & cld_reice,cld_rwp, cld_rerain,cld_swp, & & cld_resnow) @@ -712,7 +659,7 @@ subroutine radiation_clouds_prop & & qstl, rhly, ccnd(1:IX,1:NLAY,1), cnvw, cnvc, & & xlat, xlon, slmsk, cldcov, dz, delp, & & IX, NLAY, NLP1, dzlay, & - & cldtot, cldcnv, & ! inout + & cldtot, cldcnv, lcrick, lcnorm, con_ttp, & ! inout & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs & cld_reice,cld_rwp, cld_rerain,cld_swp, & & cld_resnow) @@ -722,7 +669,7 @@ subroutine radiation_clouds_prop & & xlon, slmsk, dz,delp, IX, NLAY, NLP1, cldcov, & & effrl, effri, effrr, effrs, effr_in, & & dzlay, & - & cldtot, cldcnv, & ! inout + & cldtot, cldcnv, lcrick, lcnorm, con_ttp, & ! inout & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs & cld_reice,cld_rwp, cld_rerain,cld_swp, & & cld_resnow) @@ -744,7 +691,7 @@ subroutine radiation_clouds_prop & & cldcov(:,1:NLAY),effrl_inout(:,:), & & effri_inout(:,:), effrs_inout(:,:), & & dzlay, & - & cldtot, cldcnv, & ! inout + & cldtot, cldcnv, lcnorm, & ! inout & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs & cld_reice,cld_rwp, cld_rerain,cld_swp, & & cld_resnow) @@ -767,7 +714,7 @@ subroutine radiation_clouds_prop & & cld_frac, & & effrl, effri, effrr, effrs, effr_in , & & dzlay, & - & cldtot, cldcnv, & ! inout + & cldtot, cldcnv, lcrick, lcnorm, con_ttp, & ! inout & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs & cld_reice,cld_rwp, cld_rerain,cld_swp, & & cld_resnow) @@ -776,13 +723,13 @@ subroutine radiation_clouds_prop & call progcld_thompson_wsm6 (plyr,plvl,tlyr,qlyr,qstl, & ! --- inputs & rhly,tracer1,xlat,xlon,slmsk,dz,delp, & & ntrac-1, ntcw-1,ntiw-1,ntrw-1, & - & ntsw-1,ntgl-1, & + & ntsw-1,ntgl-1,con_ttp, & & IX, NLAY, NLP1, uni_cld, lmfshal, lmfdeep2, & & cldcov(:,1:NLAY), cnvw, effrl_inout, & & effri_inout, effrs_inout, & & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & & dzlay, & - & cldtot, cldcnv, & ! inout + & cldtot, cldcnv, lcnorm, & ! inout & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs & cld_reice,cld_rwp, cld_rerain,cld_swp, & & cld_resnow) @@ -800,7 +747,7 @@ subroutine radiation_clouds_prop & & IX, LM, NLP1, uni_cld, lmfshal, lmfdeep2, & & cldcov(:,1:LM), effrl, effri, effrs, & & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & - & dzlay, gridkm, & + & dzlay, gridkm, top_at_1, & & cldtot, cldcnv, & ! inout & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs & cld_reice,cld_rwp, cld_rerain,cld_swp, & @@ -822,7 +769,7 @@ subroutine radiation_clouds_prop & & cld_frac, & & effrl, effri, effrr, effrs, effr_in , & & dzlay, & - & cldtot, cldcnv, & ! inout + & cldtot, cldcnv, lcrick, lcnorm, con_ttp, & ! inout & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs & cld_reice,cld_rwp, cld_rerain,cld_swp, & & cld_resnow) @@ -839,7 +786,7 @@ subroutine radiation_clouds_prop & & IX, LM, NLP1, uni_cld, lmfshal, lmfdeep2, & & cldcov(:,1:LM), effrl, effri, effrs, & & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & - & dzlay, gridkm, & + & dzlay, gridkm, top_at_1, & & cldtot, cldcnv, & ! inout & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs & cld_reice,cld_rwp, cld_rerain,cld_swp, & @@ -849,12 +796,12 @@ subroutine radiation_clouds_prop & call progcld_thompson_wsm6 (plyr,plvl,tlyr,qlyr,qstl, & ! --- inputs & rhly,tracer1,xlat,xlon,slmsk,dz,delp, & & ntrac-1, ntcw-1,ntiw-1,ntrw-1, & - & ntsw-1,ntgl-1, & + & ntsw-1,ntgl-1,con_ttp, & & IX, NLAY, NLP1, uni_cld, lmfshal, lmfdeep2, & & cldcov(:,1:NLAY), cnvw, effrl, effri, effrs, & & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & & dzlay, & - & cldtot, cldcnv, & ! inout + & cldtot, cldcnv, lcnorm, & ! inout & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs & cld_reice,cld_rwp, cld_rerain,cld_swp, & & cld_resnow) @@ -889,7 +836,7 @@ subroutine radiation_clouds_prop & call cmp_dcorr_lgth(ix, latdeg, julian, yearlen, de_lgth) endif if (idcor == idcor_con) then - de_lgth(:) = decorr_con + de_lgth(:) = dcorr_con endif ! Call subroutine get_alpha_exper to define alpha parameter for exponential cloud overlap options @@ -914,8 +861,8 @@ subroutine radiation_clouds_prop & call gethml & ! --- inputs: & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, alpha, & - & IX, NLAY, iovr_rand, iovr_maxrand, iovr_max, & - & iovr_dcorr, iovr_exp, iovr_exprand, & + & IX, NLAY, iovr, iovr_rand, iovr_maxrand, iovr_max, & + & iovr_dcorr, iovr_exp, iovr_exprand, top_at_1, si, & ! --- outputs: & clds, mtop, mbot & & ) @@ -932,7 +879,7 @@ subroutine progcld_zhao_carr & & xlat,xlon,slmsk,dz,delp, IX, NLAY, NLP1, & & uni_cld, lmfshal, lmfdeep2, cldcov, & & effrl,effri,effrr,effrs,effr_in, & - & dzlay, cldtot, cldcnv, & + & dzlay, cldtot, cldcnv, lcrick, lcnorm, con_ttp, & & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs & cld_reice,cld_rwp, cld_rerain,cld_swp, cld_resnow & & ) @@ -949,9 +896,7 @@ subroutine progcld_zhao_carr & ! top and base. the three vertical cloud domains are set up in the ! ! initial subroutine "cld_init". ! ! ! -! usage: call progcld_zhao_carr ! -! ! -! subprograms called: gethml ! +! usage: call progcld_zhao_carr ! ! ! ! attributes: ! ! language: fortran 90 ! @@ -987,6 +932,14 @@ subroutine progcld_zhao_carr & ! effrs : effective radius for snow water ! effr_in : logical, if .true. use input effective radii ! dzlay(ix,nlay) : thickness between model layer centers (km) ! +! lmfshal : mass-flux shallow conv scheme flag ! +! lmfdeep2 : scale-aware mass-flux deep conv scheme flag ! +! lcrick : control flag for eliminating CRICK ! +! =t: apply layer smoothing to eliminate CRICK ! +! =f: do not apply layer smoothing ! +! lcnorm : control flag for in-cld condensate ! +! =t: normalize cloud condensate ! +! =f: not normalize cloud condensate ! ! ! ! output variables: ! ! cloud profiles: ! @@ -1000,19 +953,6 @@ subroutine progcld_zhao_carr & ! *** cld_swp (:,:) - layer snow flake water path not assigned ! ! cld_resnow(:,:) - mean eff radius for snow flake (micron) ! ! ! -! module variables: ! -! ivflip : control flag of vertical index direction ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! lmfshal : mass-flux shallow conv scheme flag ! -! lmfdeep2 : scale-aware mass-flux deep conv scheme flag ! -! lcrick : control flag for eliminating CRICK ! -! =t: apply layer smoothing to eliminate CRICK ! -! =f: do not apply layer smoothing ! -! lcnorm : control flag for in-cld condensate ! -! =t: normalize cloud condensate ! -! =f: not normalize cloud condensate ! -! ! ! ==================== end of description ===================== ! ! implicit none @@ -1020,7 +960,8 @@ subroutine progcld_zhao_carr & ! --- inputs integer, intent(in) :: IX, NLAY, NLP1 - logical, intent(in) :: uni_cld, lmfshal, lmfdeep2, effr_in + logical, intent(in) :: uni_cld, lmfshal, lmfdeep2, effr_in, & + & lcrick, lcnorm real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & & tlyr, tvly, qlyr, qstl, rhly, clw, cldcov, delp, dz, & @@ -1028,6 +969,7 @@ subroutine progcld_zhao_carr & real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & & slmsk + real (kind=kind_phys), intent(in) :: con_ttp ! --- inputs/outputs @@ -1236,7 +1178,7 @@ subroutine progcld_zhao_carr_pdf & & xlat,xlon,slmsk, dz, delp, & & ix, nlay, nlp1, & & deltaq,sup,kdt,me, & - & dzlay, cldtot, cldcnv, & + & dzlay, cldtot, cldcnv, lcrick, lcnorm, con_thgni, con_ttp, & & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs & cld_reice,cld_rwp, cld_rerain,cld_swp, cld_resnow & & ) @@ -1253,9 +1195,7 @@ subroutine progcld_zhao_carr_pdf & ! top and base. the three vertical cloud domains are set up in the ! ! initial subroutine "cld_init". ! ! ! -! usage: call progcld_zhao_carr_pdf ! -! ! -! subprograms called: gethml ! +! usage: call progcld_zhao_carr_pdf ! ! ! ! attributes: ! ! language: fortran 90 ! @@ -1286,6 +1226,12 @@ subroutine progcld_zhao_carr_pdf & ! deltaq(ix,nlay) : half total water distribution width ! ! sup : supersaturation ! ! dzlay(ix,nlay) : thickness between model layer centers (km) ! +! lcrick : control flag for eliminating crick ! +! =t: apply layer smoothing to eliminate crick ! +! =f: do not apply layer smoothing ! +! lcnorm : control flag for in-cld condensate ! +! =t: normalize cloud condensate ! +! =f: not normalize cloud condensate ! ! ! ! output variables: ! ! cloud profiles: ! @@ -1299,28 +1245,18 @@ subroutine progcld_zhao_carr_pdf & ! *** cld_swp (:,:) - layer snow flake water path not assigned ! ! cld_resnow(:,:) - mean eff radius for snow flake (micron) ! ! ! -! module variables: ! -! ivflip : control flag of vertical index direction ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! lcrick : control flag for eliminating crick ! -! =t: apply layer smoothing to eliminate crick ! -! =f: do not apply layer smoothing ! -! lcnorm : control flag for in-cld condensate ! -! =t: normalize cloud condensate ! -! =f: not normalize cloud condensate ! -! ! ! ==================== end of description ===================== ! ! implicit none ! --- inputs integer, intent(in) :: ix, nlay, nlp1,kdt - + logical, intent(in) :: lcrick, lcnorm real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & & tlyr, tvly, qlyr, qstl, rhly, clw, dz, delp, dzlay ! & tlyr, tvly, qlyr, qstl, rhly, clw, cnvw, cnvc ! real (kind=kind_phys), dimension(:,:), intent(in) :: deltaq + real (kind=kind_phys), intent(in) :: con_thgni, con_ttp real (kind=kind_phys), dimension(:,:) :: deltaq, cnvw, cnvc real (kind=kind_phys) qtmp,qsc,rhs real (kind=kind_phys), intent(in) :: sup @@ -1416,7 +1352,7 @@ subroutine progcld_zhao_carr_pdf & do k = 1, nlay do i = 1, ix tem1 = tlyr(i,k) - 273.16 - if(tem1 < con_thgni) then ! for pure ice, has to be consistent with gscond + if(tem1 < (con_thgni - 273.16)) then ! for pure ice, has to be consistent with gscond qsc = sup * qstl(i,k) rhs = sup else @@ -1536,7 +1472,7 @@ subroutine progcld_gfdl_lin & & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw,cnvw,cnvc, & ! --- inputs: & xlat,xlon,slmsk,cldtot, dz, delp, & & IX, NLAY, NLP1, & - & dzlay, cldtot1, cldcnv, & + & dzlay, cldtot1, cldcnv, lcrick, lcnorm, con_ttp, & & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs & cld_reice,cld_rwp, cld_rerain,cld_swp, cld_resnow & & ) @@ -1553,9 +1489,7 @@ subroutine progcld_gfdl_lin & ! top and base. the three vertical cloud domains are set up in the ! ! initial subroutine "cld_init". ! ! ! -! usage: call progcld_gfdl_lin ! -! ! -! subprograms called: gethml ! +! usage: call progcld_gfdl_lin ! ! ! ! attributes: ! ! language: fortran 90 ! @@ -1584,6 +1518,12 @@ subroutine progcld_gfdl_lin & ! IX : horizontal dimention ! ! NLAY,NLP1 : vertical layer/level dimensions ! ! dzlay(ix,nlay) : thickness between model layer centers (km) ! +! lcrick : control flag for eliminating CRICK ! +! =t: apply layer smoothing to eliminate CRICK ! +! =f: do not apply layer smoothing ! +! lcnorm : control flag for in-cld condensate ! +! =t: normalize cloud condensate ! +! =f: not normalize cloud condensate ! ! ! ! output variables: ! ! cloud profiles: ! @@ -1597,28 +1537,17 @@ subroutine progcld_gfdl_lin & ! *** cld_swp (:,:) - layer snow flake water path not assigned ! ! cld_resnow(:,:) - mean eff radius for snow flake (micron) ! ! ! -! module variables: ! -! ivflip : control flag of vertical index direction ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! lsashal : control flag for shallow convection ! -! lcrick : control flag for eliminating CRICK ! -! =t: apply layer smoothing to eliminate CRICK ! -! =f: do not apply layer smoothing ! -! lcnorm : control flag for in-cld condensate ! -! =t: normalize cloud condensate ! -! =f: not normalize cloud condensate ! -! ! ! ==================== end of description ===================== ! ! implicit none ! --- inputs integer, intent(in) :: IX, NLAY, NLP1 - + logical, intent(in) :: lcrick, lcnorm real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & & tlyr, tvly, qlyr, qstl, rhly, clw, cldtot, cnvw, cnvc, & & delp, dz, dzlay + real (kind=kind_phys) :: con_ttp real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & & slmsk @@ -1786,7 +1715,7 @@ subroutine progcld_fer_hires & & IX, NLAY, NLP1, icloud, & & uni_cld, lmfshal, lmfdeep2, cldcov, & & re_cloud,re_ice,re_snow, & - & dzlay, cldtot, cldcnv, & + & dzlay, cldtot, cldcnv, lcnorm, & & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs & cld_reice,cld_rwp, cld_rerain,cld_swp, cld_resnow & & ) @@ -1803,9 +1732,7 @@ subroutine progcld_fer_hires & ! top and base. the three vertical cloud domains are set up in the ! ! initial subroutine "cld_init". ! ! ! -! usage: call progcld_fer_hires ! -! ! -! subprograms called: gethml ! +! usage: call progcld_fer_hires ! ! ! ! attributes: ! ! language: fortran 90 ! @@ -1837,6 +1764,14 @@ subroutine progcld_fer_hires & ! lmfdeep2 : logical - true for mass flux deep convection ! ! cldcov : layer cloud fraction (used when uni_cld=.true. ! ! dzlay(ix,nlay) : thickness between model layer centers (km) ! +! lmfshal : mass-flux shallow conv scheme flag ! +! lmfdeep2 : scale-aware mass-flux deep conv scheme flag ! +! lcrick : control flag for eliminating CRICK ! +! =t: apply layer smoothing to eliminate CRICK ! +! =f: do not apply layer smoothing ! +! lcnorm : control flag for in-cld condensate ! +! =t: normalize cloud condensate ! +! =f: not normalize cloud condensate ! ! ! ! output variables: ! ! cloud profiles: ! @@ -1850,19 +1785,6 @@ subroutine progcld_fer_hires & ! *** cld_swp (:,:) - layer snow flake water path not assigned ! ! cld_resnow(:,:) - mean eff radius for snow flake (micron) ! ! ! -! module variables: ! -! ivflip : control flag of vertical index direction ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! lmfshal : mass-flux shallow conv scheme flag ! -! lmfdeep2 : scale-aware mass-flux deep conv scheme flag ! -! lcrick : control flag for eliminating CRICK ! -! =t: apply layer smoothing to eliminate CRICK ! -! =f: do not apply layer smoothing ! -! lcnorm : control flag for in-cld condensate ! -! =t: normalize cloud condensate ! -! =f: not normalize cloud condensate ! -! ! ! ==================== end of description ===================== ! ! implicit none @@ -1871,7 +1793,7 @@ subroutine progcld_fer_hires & integer, intent(in) :: IX, NLAY, NLP1, ICLOUD integer, intent(in) :: ntrac, ntcw, ntiw, ntrw - logical, intent(in) :: uni_cld, lmfshal, lmfdeep2 + logical, intent(in) :: uni_cld, lmfshal, lmfdeep2, lcnorm real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & & tlyr, tvly, qlyr, qstl, rhly, cldcov, delp, dz, dzlay @@ -2036,12 +1958,12 @@ end subroutine progcld_fer_hires subroutine progcld_thompson_wsm6 & & ( plyr,plvl,tlyr,qlyr,qstl,rhly,clw, & ! --- inputs: & xlat,xlon,slmsk,dz,delp, & - & ntrac,ntcw,ntiw,ntrw,ntsw,ntgl, & + & ntrac,ntcw,ntiw,ntrw,ntsw,ntgl,con_ttp, & & IX, NLAY, NLP1, & & uni_cld, lmfshal, lmfdeep2, cldcov, cnvw, & & re_cloud,re_ice,re_snow, & & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & - & dzlay, cldtot, cldcnv, & + & dzlay, cldtot, cldcnv, lcnorm, & & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs & cld_reice,cld_rwp, cld_rerain,cld_swp, cld_resnow & & ) @@ -2059,9 +1981,7 @@ subroutine progcld_thompson_wsm6 & ! top and base. the three vertical cloud domains are set up in the ! ! initial subroutine "cld_init". ! ! ! -! usage: call progcld_thompson_wsm6 ! -! ! -! subprograms called: gethml ! +! usage: call progcld_thompson_wsm6 ! ! ! ! attributes: ! ! language: fortran 90 ! @@ -2092,6 +2012,14 @@ subroutine progcld_thompson_wsm6 & ! lmfshal : logical - true for mass flux shallow convection ! ! lmfdeep2 : logical - true for mass flux deep convection ! ! cldcov : layer cloud fraction (used when uni_cld=.true. ! +! lmfshal : mass-flux shallow conv scheme flag ! +! lmfdeep2 : scale-aware mass-flux deep conv scheme flag ! +! lcrick : control flag for eliminating CRICK ! +! =t: apply layer smoothing to eliminate CRICK ! +! =f: do not apply layer smoothing ! +! lcnorm : control flag for in-cld condensate ! +! =t: normalize cloud condensate ! +! =f: not normalize cloud condensate ! ! ! ! output variables: ! ! cloud profiles: ! @@ -2110,19 +2038,6 @@ subroutine progcld_thompson_wsm6 & ! mbot (IX,3) : vertical indices for low, mid, hi cloud bases ! ! de_lgth(ix) : clouds decorrelation length (km) ! ! ! -! module variables: ! -! ivflip : control flag of vertical index direction ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! lmfshal : mass-flux shallow conv scheme flag ! -! lmfdeep2 : scale-aware mass-flux deep conv scheme flag ! -! lcrick : control flag for eliminating CRICK ! -! =t: apply layer smoothing to eliminate CRICK ! -! =f: do not apply layer smoothing ! -! lcnorm : control flag for in-cld condensate ! -! =t: normalize cloud condensate ! -! =f: not normalize cloud condensate ! -! ! ! ==================== end of description ===================== ! ! implicit none @@ -2131,7 +2046,7 @@ subroutine progcld_thompson_wsm6 & integer, intent(in) :: IX, NLAY, NLP1 integer, intent(in) :: ntrac, ntcw, ntiw, ntrw, ntsw, ntgl - logical, intent(in) :: uni_cld, lmfshal, lmfdeep2 + logical, intent(in) :: uni_cld, lmfshal, lmfdeep2, lcnorm real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & & tlyr, qlyr, qstl, rhly, cldcov, delp, dz, dzlay, & @@ -2143,7 +2058,7 @@ subroutine progcld_thompson_wsm6 & real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & & slmsk - + real (kind=kind_phys), intent(in) :: con_ttp ! --- inputs/outputs real (kind=kind_phys), dimension(:,:), intent(inout) :: & @@ -2342,7 +2257,7 @@ subroutine progcld_thompson & & uni_cld, lmfshal, lmfdeep2, cldcov, & & re_cloud,re_ice,re_snow, & & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & - & dzlay, gridkm, cldtot, cldcnv, & + & dzlay, gridkm, top_at_1, cldtot, cldcnv, & & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs & cld_reice,cld_rwp, cld_rerain,cld_swp, cld_resnow & & ) @@ -2361,8 +2276,6 @@ subroutine progcld_thompson & ! ! ! usage: call progcld_thompson ! ! ! -! subprograms called: gethml ! -! ! ! attributes: ! ! language: fortran 90 ! ! machine: ibm-sp, sgi ! @@ -2392,7 +2305,16 @@ subroutine progcld_thompson & ! uni_cld : logical - true for cloud fraction from shoc ! ! lmfshal : logical - true for mass flux shallow convection ! ! lmfdeep2 : logical - true for mass flux deep convection ! +! top_at_1 : logical - true if vertical ordereing is toa-2-sfc ! ! cldcov : layer cloud fraction (used when uni_cld=.true. ! +! lmfshal : mass-flux shallow conv scheme flag ! +! lmfdeep2 : scale-aware mass-flux deep conv scheme flag ! +! lcrick : control flag for eliminating CRICK ! +! =t: apply layer smoothing to eliminate CRICK ! +! =f: do not apply layer smoothing ! +! lcnorm : control flag for in-cld condensate ! +! =t: normalize cloud condensate ! +! =f: not normalize cloud condensate ! ! ! ! output variables: ! ! cloud profiles: ! @@ -2406,19 +2328,6 @@ subroutine progcld_thompson & ! *** cld_swp (:,:) - layer snow flake water path not assigned ! ! cld_resnow(:,:) - mean eff radius for snow flake (micron) ! ! ! -! module variables: ! -! ivflip : control flag of vertical index direction ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! lmfshal : mass-flux shallow conv scheme flag ! -! lmfdeep2 : scale-aware mass-flux deep conv scheme flag ! -! lcrick : control flag for eliminating CRICK ! -! =t: apply layer smoothing to eliminate CRICK ! -! =f: do not apply layer smoothing ! -! lcnorm : control flag for in-cld condensate ! -! =t: normalize cloud condensate ! -! =f: not normalize cloud condensate ! -! ! ! ==================== end of description ===================== ! ! implicit none @@ -2427,7 +2336,7 @@ subroutine progcld_thompson & integer, intent(in) :: IX, NLAY, NLP1 integer, intent(in) :: ntrac, ntcw, ntiw, ntrw, ntsw, ntgl - logical, intent(in) :: uni_cld, lmfshal, lmfdeep2 + logical, intent(in) :: uni_cld, lmfshal, lmfdeep2, top_at_1 real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & & tlyr, qlyr, qstl, rhly, cldcov, delp, dz, dzlay, & @@ -2531,7 +2440,7 @@ subroutine progcld_thompson & cldfra1d(:) = 0.0 - if (ivflip .eq. 1) then + if (.not. top_at_1) then do k = 1, NLAY qv1d(k) = qlyr(i,k) qc1d(k) = max(0.0, clw(i,k,ntcw)) @@ -2625,7 +2534,7 @@ subroutine progclduni & & ( plyr,plvl,tlyr,tvly,ccnd,ncnd, & ! --- inputs: & xlat,xlon,slmsk,dz,delp, IX, NLAY, NLP1, cldtot, & & effrl,effri,effrr,effrs,effr_in, & - & dzlay, cldtot1, cldcnv, & + & dzlay, cldtot1, cldcnv, lcrick, lcnorm, con_ttp, & & cld_frac, cld_lwp, cld_reliq, cld_iwp, & ! --- outputs & cld_reice,cld_rwp, cld_rerain,cld_swp, cld_resnow & & ) @@ -2647,8 +2556,6 @@ subroutine progclduni & ! ! ! usage: call progclduni ! ! ! -! subprograms called: gethml ! -! ! ! attributes: ! ! language: fortran 90 ! ! machine: ibm-sp, sgi ! @@ -2679,6 +2586,14 @@ subroutine progclduni & ! dz (ix,nlay) : layer thickness (km) ! ! delp (ix,nlay) : model layer pressure thickness in mb (100Pa) ! ! dzlay(ix,nlay) : thickness between model layer centers (km) ! +! lmfshal : mass-flux shallow conv scheme flag ! +! lmfdeep2 : scale-aware mass-flux deep conv scheme flag ! +! lcrick : control flag for eliminating CRICK ! +! =t: apply layer smoothing to eliminate CRICK ! +! =f: do not apply layer smoothing ! +! lcnorm : control flag for in-cld condensate ! +! =t: normalize cloud condensate ! +! =f: not normalize cloud condensate ! ! ! ! output variables: ! ! cloud profiles: ! @@ -2696,20 +2611,7 @@ subroutine progclduni & ! mtop (IX,3) : vertical indices for low, mid, hi cloud tops ! ! mbot (IX,3) : vertical indices for low, mid, hi cloud bases ! ! de_lgth(ix) : clouds decorrelation length (km) ! -! alpha(ix,nlay) : alpha decorrelation parameter -! ! -! module variables: ! -! ivflip : control flag of vertical index direction ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! lmfshal : mass-flux shallow conv scheme flag ! -! lmfdeep2 : scale-aware mass-flux deep conv scheme flag ! -! lcrick : control flag for eliminating CRICK ! -! =t: apply layer smoothing to eliminate CRICK ! -! =f: do not apply layer smoothing ! -! lcnorm : control flag for in-cld condensate ! -! =t: normalize cloud condensate ! -! =f: not normalize cloud condensate ! +! alpha(ix,nlay) : alpha decorrelation parameter ! ! ! ! ==================== end of description ===================== ! ! @@ -2717,8 +2619,9 @@ subroutine progclduni & ! --- inputs integer, intent(in) :: IX, NLAY, NLP1, ncnd - logical, intent(in) :: effr_in + logical, intent(in) :: effr_in, lcrick, lcnorm + real (kind=kind_phys), intent(in) :: con_ttp real (kind=kind_phys), dimension(:,:,:), intent(in) :: ccnd real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr,& & tlyr, tvly, cldtot, effrl, effri, effrr, effrs, dz, delp, & @@ -2936,8 +2839,8 @@ end subroutine progclduni !>\section detail Detailed Algorithm subroutine gethml & & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, alpha, & ! --- inputs: - & IX, NLAY, iovr_rand, iovr_maxrand, iovr_max, & - & iovr_dcorr, iovr_exp, iovr_exprand, & + & IX, NLAY, iovr, iovr_rand, iovr_maxrand, iovr_max, & + & iovr_dcorr, iovr_exp, iovr_exprand, top_at_1, si, & & clds, mtop, mbot & ! --- outputs: & ) @@ -2975,13 +2878,7 @@ subroutine gethml & ! output variables: ! ! clds (IX,5) : fraction of clouds for low, mid, hi, tot, bl ! ! mtop (IX,3) : vertical indices for low, mid, hi cloud tops ! -! mbot (IX,3) : vertical indices for low, mid, hi cloud bases ! -! ! -! external module variables: (in physparam) ! -! ivflip : control flag of vertical index direction ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! ! +! mbot (IX,3) : vertical indices for low, mid, hi cloud bases ! ! ! internal module variables: ! ! iovr : control flag for cloud overlap ! ! =0 random overlapping clouds ! @@ -2996,8 +2893,10 @@ subroutine gethml & implicit none! ! --- inputs: + logical, intent(in) :: top_at_1 integer, intent(in) :: IX, NLAY integer, intent(in) :: & + & iovr, ! & iovr_rand, ! Flag for random cloud overlap method & iovr_maxrand, ! Flag for maximum-random cloud overlap method & iovr_max, ! Flag for maximum cloud overlap method @@ -3007,7 +2906,7 @@ subroutine gethml & real (kind=kind_phys), dimension(:,:), intent(in) :: plyr, ptop1, & & cldtot, cldcnv, dz - real (kind=kind_phys), dimension(:), intent(in) :: de_lgth + real (kind=kind_phys), dimension(:), intent(in) :: de_lgth, si real (kind=kind_phys), dimension(:,:), intent(in) :: alpha ! --- outputs @@ -3020,11 +2919,30 @@ subroutine gethml & real (kind=kind_phys) :: pcur, pnxt, ccur, cnxt, alfa integer, dimension(IX):: idom, kbt1, kth1, kbt2, kth2 - integer :: i, k, id, id1, kstr, kend, kinc + integer :: i, k, id, id1, kstr, kend, kinc,kl ! !===> ... begin here ! +!> - Compute the top of BL cld (llyr), which is the topmost non +!! cld(low) layer for stratiform (at or above lowest 0.1 of the +!! atmosphere). + + if (top_at_1) then ! data from toa to sfc + lab_do_k0 : do k = NLAY, 2, -1 + kl = k + if (si(k) < 0.9e0) exit lab_do_k0 + enddo lab_do_k0 + llyr = kl + else ! data from sfc to top + lab_do_k1 : do k = 2, NLAY + kl = k + if (si(k) < 0.9e0) exit lab_do_k1 + enddo lab_do_k1 + + llyr = kl - 1 + endif ! end_if_top_at_1 + clds(:,:) = 0.0 do i = 1, IX @@ -3038,7 +2956,7 @@ subroutine gethml & !> - Calculate total and BL cloud fractions (maximum-random cloud !! overlapping is operational). - if ( ivflip == 0 ) then ! input data from toa to sfc + if (top_at_1) then ! input data from toa to sfc kstr = NLAY kend = 1 kinc = -1 @@ -3046,7 +2964,7 @@ subroutine gethml & kstr = 1 kend = NLAY kinc = 1 - endif ! end_if_ivflip + endif ! end_if_top_at_1 if ( iovr == iovr_rand ) then ! random overlap @@ -3180,7 +3098,7 @@ subroutine gethml & !> - Calculte high, mid, low cloud fractions and vertical indices of !! cloud tops/bases. - if ( ivflip == 0 ) then ! input data from toa to sfc + if (top_at_1) then ! input data from toa to sfc do i = 1, IX cl1 (i) = 0.0 @@ -3344,7 +3262,7 @@ subroutine gethml & enddo ! end_do_i_loop enddo ! end_do_k_loop - endif ! end_if_ivflip + endif ! end_if_top_at_1 ! return diff --git a/physics/radiation_gases.f b/physics/radiation_gases.f index c958fc243..ccc3b598a 100644 --- a/physics/radiation_gases.f +++ b/physics/radiation_gases.f @@ -19,13 +19,13 @@ ! input: ! ! ( me ) ! ! output: ! -! ( none ) ! +! ( errflg, errmsg ) ! ! ! ! 'gas_update' -- read in data and update with time ! ! input: ! ! ( iyear, imon, iday, ihour, loz1st, ldoco2, me ) ! ! output: ! -! ( none ) ! +! ( errflg, errmsg ) ! ! ! ! 'getozn' -- setup climatological ozone profile ! ! input: ! @@ -44,7 +44,6 @@ ! external modules referenced: ! ! 'module machine' in 'machine.f' ! ! 'module funcphys' in 'funcphys.f' ! -! 'module physcons' in 'physcons.f ! ! 'module module_iounitdef' in 'iounitdef.f' ! ! ! ! unit used for radiative active gases: ! @@ -81,7 +80,7 @@ ! nov 2008 - y-t hou fix bugs in superimposing climatology ! ! seasonal cycle calculations ! ! aug 2011 - y-t hou fix a bug in subr getgases doing vertical ! -! co2 mapping. (for iflip=0 case, not affact opr). ! +! co2 mapping. (for top_at_1 case, not affact opr). ! ! aug 2012 - y-t hou modified subr getozn. moved the if-first ! ! block to subr gas_init to ensure threading safe in ! ! climatology ozone applications. (not affect gfs) ! @@ -141,13 +140,8 @@ !> This module sets up ozone climatological profiles and other constant gas !! profiles, such as co2, ch4, n2o, o2, and those of cfc gases. module module_radiation_gases -! - use physparam, only : ico2flg, ictmflg, ioznflg, ivflip, & - & co2dat_file, co2gbl_file, & - & co2usr_file, co2cyc_file, & - & kind_phys, kind_io4 + use machine, only : kind_phys, kind_io4 use funcphys, only : fpkapx - use physcons, only : con_pi use ozne_def, only : JMR => latsozc, LOZ => levozc, & & blte => blatc, dlte=> dphiozc, & & timeozc => timeozc @@ -168,9 +162,9 @@ module module_radiation_gases integer, parameter :: MINYEAR = 1957 ! earlist year 2D CO2 data available real (kind=kind_phys), parameter :: resco2=15.0 ! horizontal resolution in degree - real (kind=kind_phys), parameter :: raddeg=180.0/con_pi ! rad->deg conversion real (kind=kind_phys), parameter :: prsco2=788.0 ! pressure limitation for 2D CO2 (mb) - real (kind=kind_phys), parameter :: hfpi =0.5*con_pi ! half of pi + real (kind=kind_phys) :: raddeg ! rad->deg conversion + real (kind=kind_phys) :: hfpi ! half of pi real (kind=kind_phys), parameter :: co2vmr_def = 350.0e-6 ! parameter constant for CO2 volume mixing ratio real (kind=kind_phys), parameter :: n2ovmr_def = 0.31e-6 ! parameter constant for N2O volume mixing ratio @@ -227,48 +221,54 @@ module module_radiation_gases !> This subroutine sets up ozone, co2, etc. parameters. If climatology !! ozone then read in monthly ozone data. -!!\param me print message control flag +!!\param me print message control flag +!!\param co2usr_file co2 user defined data table +!!\param co2cyc_file co2 climotology monthly cycle data table +!!\param ictmflg data ic time/date control flag +!!\param ico2flg co2 data source control flag +!!\param ioznflg ozone data control flag +!!\param con_pi physical constant Pi +!!\param errflg error flag +!!\param errmsg error message !>\section gas_init_gen gas_init General Algorithm !----------------------------------- - subroutine gas_init & - & ( me )! --- inputs: -! --- outputs: ( none ) + subroutine gas_init( me, co2usr_file, co2cyc_file, ico2flg, & + & ictmflg, ioznflg, con_pi, errflg, errmsg) ! =================================================================== ! ! ! ! gas_init sets up ozone, co2, etc. parameters. if climatology ozone ! ! then read in monthly ozone data. ! ! ! -! inputs: dimemsion ! -! me - print message control flag 1 ! -! ! -! outputs: (to the module variables) ! -! ( none ) ! -! ! -! external module variables: (in physparam) ! -! ico2flg - co2 data source control flag ! +! inputs: ! +! me - print message control flag ! +! ico2flg - co2 data source control flag ! ! =0: use prescribed co2 global mean value ! ! =1: use input global mean co2 value (co2_glb) ! ! =2: use input 2-d monthly co2 value (co2vmr_sav) ! -! ictmflg - =yyyy#, data ic time/date control flag ! -! = -2: same as 0, but superimpose seasonal cycle ! -! from climatology data set. ! -! = -1: use user provided external data for the fcst ! -! time, no extrapolation. ! -! = 0: use data at initial cond time, if not existed! -! then use latest, without extrapolation. ! -! = 1: use data at the forecast time, if not existed! -! then use latest and extrapolate to fcst time.! -! =yyyy0: use yyyy data for the forecast time, no ! -! further data extrapolation. ! -! =yyyy1: use yyyy data for the fcst. if needed, do ! -! extrapolation to match the fcst time. ! -! ioznflg - ozone data control flag ! +! ictmflg - =yyyy#, data ic time/date control flag ! +! =-2: same as 0, but superimpose seasonal cycle ! +! from climatology data set. ! +! =-1: use user provided external data for the fcst ! +! time, no extrapolation. ! +! =0: use data at initial cond time, if not existed ! +! then use latest, without extrapolation. ! +! =1: use data at the forecast time, if not existed ! +! then use latest and extrapolate to fcst time. ! +! =yyyy0: use yyyy data for the forecast time, no ! +! further data extrapolation. ! +! =yyyy1: use yyyy data for the fcst. if needed, do ! +! extrapolation to match the fcst time. ! +! ioznflg - ozone data control flag ! ! =0: use climatological ozone profile ! -! >0: use interactive ozone profile ! -! ivflip - vertical profile indexing flag ! -! co2usr_file- external co2 user defined data table ! -! co2cyc_file- external co2 climotology monthly cycle data table ! +! >0: use interactive ozone profile ! +! co2usr_file - external co2 user defined data table ! +! co2cyc_file - external co2 climotology monthly cycle data table ! +! con_pi - physical constant Pi ! +! ! +! outputs: (CCPP error handling) ! +! errflg - error flag ! +! errmsg - error message ! ! ! ! internal module variables: ! ! pkstr, o3r - arrays for climatology ozone data ! @@ -282,9 +282,12 @@ subroutine gas_init & implicit none ! --- inputs: - integer, intent(in) :: me - -! --- output: ( none ) + integer, intent(in) :: me, ictmflg, ioznflg, ico2flg + character(len=26),intent(in) :: co2usr_file,co2cyc_file + real(kind=kind_phys), intent(in) :: con_pi +! --- output: + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg ! --- locals: real (kind=kind_phys), dimension(IMXCO2,JMXCO2) :: co2dat @@ -300,6 +303,15 @@ subroutine gas_init & ! !===> ... begin here ! + +! Initialize the CCPP error handling variables + errmsg = '' + errflg = 0 + +! Initiailize module parameters + raddeg = 180.0/con_pi + hfpi = 0.5*con_pi + if ( me == 0 ) print *, VTAGGAS ! print out version tag kyrsav = 0 @@ -316,7 +328,10 @@ subroutine gas_init & print *,' - Using climatology ozone distribution' print *,' timeozc=',timeozc, ' is not monthly mean', & & ' - job aborting in subroutin gas_init!!!' - stop + errflg = 1 + errmsg = 'ERROR(gas_init): Climatological o3 distribution '// & + & 'is not monthly mean' + return endif allocate (pkstr(LOZ), o3r(JMR,LOZ,12)) @@ -391,9 +406,10 @@ subroutine gas_init & inquire (file=co2usr_file, exist=file_exist) if ( .not. file_exist ) then - print *,' Can not find user CO2 data file: ',co2usr_file, & - & ' - Stopped in subroutine gas_init !!' - stop + print *,' Can not find user CO2 data file: ',co2usr_file + errflg = 1 + errmsg = 'ERROR(gas_init): Can not find user CO2 data file' + return else close (NICO2CN) open(NICO2CN,file=co2usr_file,form='formatted',status='old') @@ -434,9 +450,10 @@ subroutine gas_init & enddo endif else - print *,' ICO2=',ico2flg,' is not a valid selection', & - & ' - Stoped in subroutine gas_init!!!' - stop + print *,' ICO2=',ico2flg,' is not a valid selection' + errflg = 1 + errmsg = 'ERROR(gas_init): ICO2 is not valid' + return endif ! endif_ico2flg_block close (NICO2CN) @@ -455,9 +472,10 @@ subroutine gas_init & print *,' - Using observed co2 monthly 2-d data' endif else - print *,' ICO2=',ico2flg,' is not a valid selection', & - & ' - Stoped in subroutine gas_init!!!' - stop + print *,' ICO2=',ico2flg,' is not a valid selection' + errflg = 1 + errmsg = 'ERROR(gas_init): ICO2 is not valid' + return endif if ( ictmflg == -2 ) then @@ -465,9 +483,12 @@ subroutine gas_init & if ( .not. file_exist ) then if ( me == 0 ) then print *,' Can not find seasonal cycle CO2 data: ', & - & co2cyc_file,' - Stopped in subroutine gas_init !!' + & co2cyc_file endif - stop + errflg = 1 + errmsg = 'ERROR(gas_init): Can not find seasonal cycle '//& + & 'CO2 data' + return else allocate( co2cyc_sav(IMXCO2,JMXCO2,12) ) @@ -517,18 +538,25 @@ end subroutine gas_init !> This subroutine reads in 2-d monthly co2 data set for a specified !! year. Data are in a 15 degree lat/lon horizontal resolution. -!!\param iyear year of the requested data for fcst -!!\param imon month of the year -!!\param iday day of the month -!!\param ihour hour of the day -!!\param loz1st clim ozone 1st time update control flag -!!\param ldoco2 co2 update control flag -!!\param me print message control flag +!!\param iyear year of the requested data for fcst +!!\param imon month of the year +!!\param iday day of the month +!!\param ihour hour of the day +!!\param loz1st clim ozone 1st time update control flag +!!\param ldoco2 co2 update control flag +!!\param me print message control flag +!!\param co2dat_file co2 2d monthly obsv data table +!!\param co2gbl_file co2 global annual mean data table +!!\param ictmflg data ic time/date control flag +!!\param ico2flg co2 data source control flag +!!\param ioznflg ozone data control flag +!!\param errflg error flag +!!\param errmsg error message !>\section gen_gas_update gas_update General Algorithm !----------------------------------- - subroutine gas_update & - & ( iyear, imon, iday, ihour, loz1st, ldoco2, me )! --- inputs -! --- outputs: ( none ) + subroutine gas_update(iyear, imon, iday, ihour, loz1st, ldoco2, & + & me, co2dat_file, co2gbl_file, ictmflg, ico2flg, ioznflg, & + & errflg, errmsg ) ! =================================================================== ! ! ! @@ -536,41 +564,40 @@ subroutine gas_update & ! data are in a 15 degree lat/lon horizontal resolution. ! ! ! ! inputs: dimemsion ! -! iyear - year of the requested data for fcst 1 ! -! imon - month of the year 1 ! -! iday - day of the month 1 ! -! ihour - hour of the day 1 ! -! loz1st - clim ozone 1st time update control flag 1 ! -! ldoco2 - co2 update control flag 1 ! -! me - print message control flag 1 ! -! ! -! outputs: (to the module variables) ! -! ( none ) ! -! ! -! external module variables: (in physparam) ! -! ico2flg - co2 data source control flag ! +! iyear - year of the requested data for fcst 1 ! +! imon - month of the year 1 ! +! iday - day of the month 1 ! +! ihour - hour of the day 1 ! +! loz1st - clim ozone 1st time update control flag 1 ! +! ldoco2 - co2 update control flag 1 ! +! me - print message control flag 1 ! +! ico2flg - co2 data source control flag ! ! =0: use prescribed co2 global mean value ! ! =1: use input global mean co2 value (co2_glb) ! ! =2: use input 2-d monthly co2 value (co2vmr_sav) ! -! ictmflg - =yyyy#, data ic time/date control flag ! -! = -2: same as 0, but superimpose seasonal cycle ! -! from climatology data set. ! -! = -1: use user provided external data for the fcst ! -! time, no extrapolation. ! -! = 0: use data at initial cond time, if not existed! -! then use latest, without extrapolation. ! -! = 1: use data at the forecast time, if not existed! -! then use latest and extrapolate to fcst time.! -! =yyyy0: use yyyy data for the forecast time, no ! -! further data extrapolation. ! -! =yyyy1: use yyyy data for the fcst. if needed, do ! -! extrapolation to match the fcst time. ! -! ioznflg - ozone data control flag ! +! ictmflg - =yyyy#, data ic time/date control flag ! +! =-2: same as 0, but superimpose seasonal cycle ! +! from climatology data set. ! +! =-1: use user provided external data for the fcst ! +! time, no extrapolation. ! +! =0: use data at initial cond time, if not existed ! +! then use latest, without extrapolation. ! +! =1: use data at the forecast time, if not existed ! +! then use latest and extrapolate to fcst time. ! +! =yyyy0: use yyyy data for the forecast time, no ! +! further data extrapolation. ! +! =yyyy1: use yyyy data for the fcst. if needed, do ! +! extrapolation to match the fcst time. ! +! ioznflg - ozone data control flag ! ! =0: use climatological ozone profile ! ! >0: use interactive ozone profile ! -! ivflip - vertical profile indexing flag ! -! co2dat_file- external co2 2d monthly obsv data table ! -! co2gbl_file- external co2 global annual mean data table ! +! ivflip - vertical profile indexing flag ! +! co2dat_file - external co2 2d monthly obsv data table ! +! co2gbl_file - external co2 global annual mean data table ! +! ! +! outputs: (CCPP error handling) ! +! errflg - error flag ! +! errmsg - error message ! ! ! ! internal module variables: ! ! co2vmr_sav - monthly co2 volume mixing ratio IMXCO2*JMXCO2*12 ! @@ -589,11 +616,14 @@ subroutine gas_update & implicit none ! --- inputs: - integer, intent(in) :: iyear, imon, iday, ihour, me - + integer, intent(in) :: iyear,imon,iday,ihour,me,ictmflg,ico2flg + integer, intent(in) :: ioznflg + character(len=26),intent(in) :: co2dat_file, co2gbl_file logical, intent(in) :: loz1st, ldoco2 -! --- output: ( none ) +! --- output: + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg ! --- locals: real (kind=kind_phys), dimension(IMXCO2,JMXCO2) :: co2dat, co2ann @@ -610,6 +640,10 @@ subroutine gas_update & ! !===> ... begin here ! +! Initialize the CCPP error handling variables + errmsg = '' + errflg = 0 + !> - Ozone data section if ( ioznflg == 0 ) then @@ -680,8 +714,11 @@ subroutine gas_update & inquire (file=co2gbl_file, exist=file_exist) if ( .not. file_exist ) then print *,' Requested co2 data file "',co2gbl_file, & - & '" not found - Stopped in subroutine gas_update!!' - stop + & '" not found' + errflg = 1 + errmsg = 'ERROR(gas_update): Requested co2 data file not '// & + & 'found' + return else close(NICO2CN) open (NICO2CN,file=co2gbl_file,form='formatted',status='old') @@ -748,9 +785,11 @@ subroutine gas_update & if ( me == 0 ) then print *,' Specified co2 data for year',idyr, & & ' not found !! Need to change namelist ICTM !!' - print *,' *** Stopped in subroutine gas_update !!' endif - stop + errflg = 1 + errmsg = 'ERROR(gas_update): Specified co2 data for year '//& + & 'not found' + return else Lab_if_ictm ! looking for latest available data if ( me == 0 ) then print *,' Requested co2 data for year',idyr, & @@ -774,9 +813,11 @@ subroutine gas_update & if ( .not. file_exist ) then if ( me == 0 ) then print *,' Can not find co2 data source file' - print *,' *** Stopped in subroutine gas_update !!' endif - stop + errflg = 1 + errmsg = 'ERROR(gas_update): Can not find co2 data '// & + & 'source file' + return endif endif Lab_if_ictm endif ! end if_file_exist_block @@ -907,6 +948,9 @@ end subroutine gas_update !! pi/2 -> -pi/2, otherwise see in-line comment !!\param IMAX horizontal dimension for output data !!\param LMAX vertical dimension for output data +!!\param ico2flg (1), co2 data source control flag +!!\param top_at_1 (1), vertical ordering flag +!!\param con_pi (1), physical constant Pi !!\param gasdat (IMAX,LMAX,NF_VGAS) - gases volume mixing ratioes !!\n (:,:,1) - co2 !!\n (:,:,2) - n2o @@ -918,13 +962,16 @@ end subroutine gas_update !!\n (:,:,8) - cfc22 !!\n (:,:,9) - ccl4 !!\n (:,:,10) - cfc113 +!!\n +!> - Internal module variables : +!!\n co2vmr_sav - saved monthly co2 concentration from sub gas_update +!!\n co2_glb - saved global annual mean co2 value from gas_update +!!\n gco2cyc - saved global seasonal variation of co2 climatology +!! in 12-month form !>\section gen_getgases getgases General Algorithm !----------------------------------- - subroutine getgases & - & ( plvl, xlon, xlat, & ! --- inputs - & IMAX, LMAX, & - & gasdat & ! --- outputs - & ) + subroutine getgases( plvl, xlon, xlat, IMAX, LMAX, ico2flg, & + & top_at_1, con_pi, gasdat) ! =================================================================== ! ! ! ! getgases set up global distribution of radiation absorbing gases ! @@ -939,6 +986,12 @@ subroutine getgases & ! xlat(IMAX) - grid latitude in radians, default range to ! ! pi/2 -> -pi/2, otherwise see in-line comment ! ! IMAX, LMAX - horiz, vert dimensions for output data ! +! ico2flg - co2 data source control flag ! +! =0: use prescribed co2 global mean value ! +! =1: use input global mean co2 value (co2_glb) ! +! =2: use input 2-d monthly co2 value (co2vmr_sav)! +! top_at_1 - vertical profile indexing flag ! +! con_pi - physical constant Pi ! ! ! ! outputs: ! ! gasdat(IMAX,LMAX,NF_VGAS) - gases volume mixing ratioes ! @@ -953,19 +1006,7 @@ subroutine getgases & ! (:,:,9) - ccl4 ! ! (:,:,10) - cfc113 ! ! ! -!> - External module variables: (in physparam) -!!\n ico2flg - co2 data source control flag -!!\n =0: use prescribed co2 global mean value -!!\n =1: use input global mean co2 value (co2_glb) -!!\n =2: use input 2-d monthly co2 value (co2vmr_sav) -!!\n ivflip - vertical profile indexing flag -!! -!> - Internal module variables : -!!\n co2vmr_sav - saved monthly co2 concentration from sub gas_update -!!\n co2_glb - saved global annual mean co2 value from gas_update -!!\n gco2cyc - saved global seasonal variation of co2 climatology -!! in 12-month form -!note: for lower atmos co2vmr_sav may have clim monthly deviations ! +! note: for lower atmos co2vmr_sav may have clim monthly deviations ! ! superimposed on init-cond co2 value, while co2_glb only ! ! contains the global mean value, thus needs to add the ! ! monthly dglobal mean deviation gco2cyc at upper atmos. for ! @@ -980,8 +1021,10 @@ subroutine getgases & implicit none ! --- input: - integer, intent(in) :: IMAX, LMAX + integer, intent(in) :: IMAX, LMAX, ico2flg real (kind=kind_phys), intent(in) :: plvl(:,:), xlon(:), xlat(:) + logical, intent(in) :: top_at_1 + real(kind=kind_phys), intent(in) :: con_pi ! --- output: real (kind=kind_phys), intent(out) :: gasdat(:,:,:) @@ -1035,7 +1078,7 @@ subroutine getgases & ilon = min( IMXCO2, int( xlon1*tmp + 1 )) ilat = min( JMXCO2, int( xlat1*tmp + 1 )) - if ( ivflip == 0 ) then ! index from toa to sfc + if (top_at_1) then ! index from toa to sfc do k = 1, LMAX if ( plvl(i,k) >= prsco2 ) then gasdat(i,k,1) = co2vmr_sav(ilon,ilat,kmonsav) @@ -1066,16 +1109,13 @@ end subroutine getgases !!\param prslk (IMAX,LM), exner function = \f$(p/p0)^{rocp}\f$ !!\param xlat (IMAX), latitude in radians, default to pi/2 -> !! -pi/2 range, otherwise see in-line comment -!!\param IMAX, LM horizontal and vertical dimensions +!!\param IMAX, LM (1), horizontal and vertical dimensions +!!\param top_at_1 (1), vertical profile indexing flag !!\param o3mmr (IMAX,LM), output ozone profile in mass mixing !! ratio (g/g) !>\section getozn_gen getozn General Algorithm !----------------------------------- - subroutine getozn & - & ( prslk,xlat, & ! --- inputs - & IMAX, LM, & - & o3mmr & ! --- outputs - & ) + subroutine getozn( prslk,xlat, IMAX, LM, top_at_1, o3mmr) ! =================================================================== ! ! ! @@ -1088,6 +1128,7 @@ subroutine getozn & ! xlat (IMAX) - latitude in radians, default to pi/2 -> -pi/2 ! ! range, otherwise see in-line comment ! ! IMAX, LM - horizontal and vertical dimensions ! +! top_at_1 - vertical profile indexing flag ! ! ! ! outputs: ! ! o3mmr (IMAX,LM) - output ozone profile in mass mixing ratio (g/g)! @@ -1095,7 +1136,6 @@ subroutine getozn & ! module variables: ! ! k1oz, k2oz - ozone data interpolation indices ! ! facoz - ozone data interpolation factor ! -! ivflip - control flag for direction of vertical index ! ! ! ! usage: call getozn ! ! ! @@ -1105,7 +1145,7 @@ subroutine getozn & ! --- inputs: integer, intent(in) :: IMAX, LM - + logical, intent(in) :: top_at_1 real (kind=kind_phys), intent(in) :: prslk(:,:), xlat(:) ! --- outputs: @@ -1149,7 +1189,7 @@ subroutine getozn & do l = 1, LM ll = l - if (ivflip == 1) ll = LM -l + 1 + if (.not. top_at_1) ll = LM -l + 1 do i = 1, IMAX wk1(i) = prslk(i,ll) diff --git a/physics/radiation_surface.f b/physics/radiation_surface.f index 2fea84b5f..299f2e92c 100644 --- a/physics/radiation_surface.f +++ b/physics/radiation_surface.f @@ -104,9 +104,7 @@ !! emissivity for LW radiation. module module_radiation_surface ! - use physparam, only : ialbflg, iemsflg, semis_file, & - & kind_phys - use physcons, only : con_t0c, con_ttp, con_pi, con_tice + use machine, only : kind_phys use module_iounitdef, only : NIRADSF use surface_perturbation, only : ppfbet ! @@ -125,7 +123,7 @@ module module_radiation_surface real (kind=kind_phys), parameter :: f_zero = 0.0 real (kind=kind_phys), parameter :: f_one = 1.0 real (kind=kind_phys), parameter :: epsln = 1.0e-6 - real (kind=kind_phys), parameter :: rad2dg = 180.0 / con_pi + real (kind=kind_phys) :: rad2dg integer, allocatable :: idxems(:,:) ! global surface emissivity index array integer :: iemslw = 1 ! global surface emissivity control flag set up in 'sfc_init' ! @@ -141,7 +139,7 @@ module module_radiation_surface !>\section gen_sfc_init sfc_init General Algorithm !----------------------------------- subroutine sfc_init & - & ( me, errmsg, errflg )! --- inputs/outputs: + & ( me, ialbflg, iemsflg, semis_file, con_pi, errmsg, errflg )! --- inputs/outputs: ! ! =================================================================== ! ! ! @@ -155,11 +153,7 @@ subroutine sfc_init & ! ==================== defination of variables ==================== ! ! ! ! inputs: ! -! me - print control flag ! -! ! -! outputs: (none) to module variables only ! -! ! -! external module variables: ! +! me - print control flag ! ! ialbflg - control flag for surface albedo schemes ! ! =1: use modis based surface albedo ! ! =2: use surface albedo from land model ! @@ -169,13 +163,18 @@ subroutine sfc_init & ! b:=1 use varying climtology sfc emiss (veg based) ! ! =2 use surface emissivity from land model ! ! ! +! outputs: (CCPP error handling) ! +! errmsg - CCPP error message ! +! errflg - CCPP error flag ! +! ! ! ==================== end of description ===================== ! ! implicit none ! --- inputs: - integer, intent(in) :: me - + integer, intent(in) :: me, ialbflg, iemsflg + real(kind=kind_phys), intent(in) :: con_pi + character(len=26), intent(in) :: semis_file ! --- outputs: ( none ) character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -191,10 +190,13 @@ subroutine sfc_init & errmsg = '' errflg = 0 ! + ! Module + rad2dg = 180.0 / con_pi + if ( me == 0 ) print *, VTAGSFC ! print out version tag !> - Initialization of surface albedo section -!! \n physparam::ialbflg +!! \n GFS_typedefs::ialbflg !! - = 1: using MODIS based land surface albedo for SW !! - = 2: using albedo from land model @@ -219,6 +221,9 @@ subroutine sfc_init & endif ! end if_ialbflg_block !> - Initialization of surface emissivity section +!! \n GFS_typedefs::iemsflg +!! - = 1: input SFC emissivity type map from "semis_file" +!! - = 2: input SFC emissivity from land model iemslw = mod(iemsflg, 10) ! emissivity control @@ -344,6 +349,7 @@ subroutine setalb & & lsmalbdvis, lsmalbdnir, lsmalbivis, lsmalbinir, & & icealbdvis, icealbdnir, icealbivis, icealbinir, & & IMAX, NF_ALBD, albPpert, pertalb, fracl, fraco, fraci, icy,& + & ialbflg, con_ttp, & & sfcalb & ! --- outputs: & ) @@ -391,6 +397,9 @@ subroutine setalb & ! fice (IMAX) - sea-ice fraction ! ! tisfc (IMAX) - sea-ice surface temperature ! ! IMAX - array horizontal dimension ! +! ialbflg - control flag for surface albedo schemes ! +! =1: use modis based surface albedo ! +! =2: use surface albedo from land model ! ! ! ! outputs: ! ! sfcalb(IMAX,NF_ALBD) ! @@ -399,17 +408,12 @@ subroutine setalb & ! ( :, 3) - uv+vis direct beam albedo ! ! ( :, 4) - uv+vis diffused albedo ! ! ! -! module internal control variables: ! -! ialbflg - =0 use the default climatology surface albedo ! -! =1 use modis retrieved albedo and input snow cover! -! for land areas ! -! ! ! ==================== end of description ===================== ! ! implicit none ! --- inputs - integer, intent(in) :: IMAX, NF_ALBD + integer, intent(in) :: IMAX, NF_ALBD, ialbflg integer, intent(in) :: lsm, lsm_noahmp, lsm_ruc logical, intent(in) :: use_cice_alb, frac_grid @@ -419,7 +423,7 @@ subroutine setalb & & alvsf, alnsf, alvwf, alnwf, facsf, facwf, fice, tisfc, & & icealbdvis, icealbdnir, icealbivis, icealbinir, & & sncovr, sncovr_ice, snoalb, albPpert ! sfc-perts, mgehne - real (kind=kind_phys), intent(in) :: pertalb ! sfc-perts, mgehne + real (kind=kind_phys), intent(in) :: pertalb, con_ttp! sfc-perts, mgehne real (kind=kind_phys), dimension(:), intent(in) :: & & fracl, fraco, fraci real (kind=kind_phys), dimension(:),intent(inout) :: & diff --git a/physics/radlw_datatb.f b/physics/radlw_datatb.f index f297c8e4c..da0f5eaa3 100644 --- a/physics/radlw_datatb.f +++ b/physics/radlw_datatb.f @@ -66,7 +66,7 @@ module module_radlw_avplank ! !........................................! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radlw_parameters, only : NPLNK, NBANDS ! implicit none @@ -747,7 +747,7 @@ end module module_radlw_avplank ! module module_radlw_ref ! !........................................! ! - use physparam, only : kind_phys + use machine, only : kind_phys ! implicit none ! @@ -924,7 +924,7 @@ end module module_radlw_ref ! module module_radlw_cldprlw ! !........................................! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radlw_parameters, only : NBANDS ! implicit none @@ -1607,7 +1607,7 @@ end module module_radlw_cldprlw ! module module_radlw_kgb01 ! !........................................! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radlw_parameters, only : NG01 ! implicit none @@ -2421,7 +2421,7 @@ end module module_radlw_kgb01 ! module module_radlw_kgb02 ! !........................................! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radlw_parameters, only : NG02 ! implicit none @@ -3278,7 +3278,7 @@ end module module_radlw_kgb02 ! module module_radlw_kgb03 ! !........................................! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radlw_parameters, only : NG03 ! implicit none @@ -10152,7 +10152,7 @@ end module module_radlw_kgb03 ! module module_radlw_kgb04 ! !........................................! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radlw_parameters, only : NG04 ! implicit none @@ -15352,7 +15352,7 @@ end module module_radlw_kgb04 ! module module_radlw_kgb05 ! !........................................! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radlw_parameters, only : NG05 ! implicit none @@ -21849,7 +21849,7 @@ end module module_radlw_kgb05 ! module module_radlw_kgb06 ! !........................................! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radlw_parameters, only : NG06 ! implicit none @@ -22109,7 +22109,7 @@ end module module_radlw_kgb06 ! module module_radlw_kgb07 ! !........................................! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radlw_parameters, only : NG07 ! implicit none @@ -24756,7 +24756,7 @@ end module module_radlw_kgb07 ! module module_radlw_kgb08 ! !........................................! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radlw_parameters, only : NG08 ! implicit none @@ -25553,7 +25553,7 @@ end module module_radlw_kgb08 ! module module_radlw_kgb09 ! !........................................! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radlw_parameters, only : NG09 ! implicit none @@ -28231,7 +28231,7 @@ end module module_radlw_kgb09 ! module module_radlw_kgb10 ! !........................................! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radlw_parameters, only : NG10 ! implicit none @@ -28705,7 +28705,7 @@ end module module_radlw_kgb10 ! module module_radlw_kgb11 ! !........................................! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radlw_parameters, only : NG11 ! implicit none @@ -29404,7 +29404,7 @@ end module module_radlw_kgb11 ! module module_radlw_kgb12 ! !........................................! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radlw_parameters, only : NG12 ! implicit none @@ -30475,7 +30475,7 @@ end module module_radlw_kgb12 ! module module_radlw_kgb13 ! !........................................! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radlw_parameters, only : NG13 ! implicit none @@ -31381,7 +31381,7 @@ end module module_radlw_kgb13 ! module module_radlw_kgb14 ! !........................................! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radlw_parameters, only : NG14 ! implicit none @@ -31605,7 +31605,7 @@ end module module_radlw_kgb14 ! module module_radlw_kgb15 ! !........................................! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radlw_parameters, only : NG15 ! implicit none @@ -32010,7 +32010,7 @@ end module module_radlw_kgb15 ! module module_radlw_kgb16 ! !........................................! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radlw_parameters, only : NG16 ! implicit none diff --git a/physics/radlw_main.F90 b/physics/radlw_main.F90 index 04609382d..7bc1ea80c 100644 --- a/physics/radlw_main.F90 +++ b/physics/radlw_main.F90 @@ -79,7 +79,6 @@ ! ! ! external modules referenced: ! ! ! -! 'module physparam' ! ! 'module physcons' ! ! 'mersenne_twister' ! ! ! @@ -278,8 +277,6 @@ !! rrtmg-lw radiation code from aer inc. module rrtmg_lw ! - use physparam, only : ilwrate, ilwrgas, ilwcliq, ilwcice, & - & isubclw, icldflg, iovr, ivflip use physcons, only : con_g, con_cp, con_avgd, con_amd, & & con_amw, con_amo3 use mersenne_twister, only : random_setseed, random_number, & @@ -425,7 +422,10 @@ subroutine rrtmg_lw_run & & gasvmr_cfc12, gasvmr_cfc22, gasvmr_ccl4, & & icseed,aeraod,aerssa,sfemis,sfgtmp, & & dzlyr,delpin,de_lgth,alpha, & - & npts, nlay, nlp1, lprnt, cld_cf, lslwr, & + & npts, nlay, nlp1, lprnt, cld_cf, lslwr, top_at_1, iovr, & + & iovr_rand, iovr_maxrand, iovr_max, iovr_dcorr, iovr_exp, & + & iovr_exprand, & + & inc_minor_gas, ilwcliq, ilwcice, isubclw, & & hlwc,topflx,sfcflx,cldtau, & ! --- outputs & HLW0,HLWB,FLXPRF, & ! --- optional & cld_lwp, cld_ref_liq, cld_iwp, cld_ref_ice, & @@ -483,6 +483,33 @@ subroutine rrtmg_lw_run & ! npts : total number of horizontal points ! ! nlay, nlp1 : total number of vertical layers, levels ! ! lprnt : cntl flag for diagnostic print out ! +! inc_minor_gas - control flag for rare gases (ch4,n2o,o2,cfcs, etc.) ! +! =0: do not include rare gases ! +! >0: include all rare gases ! +! ilwcliq - control flag for liq-cloud optical properties ! +! =1: input cld liqp & reliq, hu & stamnes (1993) ! +! =2: not used ! +! ilwcice - control flag for ice-cloud optical properties ! +! =1: input cld icep & reice, ebert & curry (1997) ! +! =2: input cld icep & reice, streamer (1996) ! +! =3: input cld icep & reice, fu (1998) ! +! isubclw - sub-column cloud approximation control flag ! +! =0: no sub-col cld treatment, use grid-mean cld quantities ! +! =1: mcica sub-col, prescribed seeds to get random numbers ! +! =2: mcica sub-col, providing array icseed for random numbers! +! iovr - clouds vertical overlapping control flag ! +! =iovr_rand ! +! =iovr_maxrand ! +! =iovr_max ! +! =iovr_dcorr ! +! =iovr_exp ! +! =iovr_exprand ! +! iovr_rand - choice of cloud-overlap: random ! +! iovr_maxrand - choice of cloud-overlap: maximum random ! +! iovr_max - choice of cloud-overlap: maximum ! +! iovr_dcorr - choice of cloud-overlap: decorrelation length ! +! iovr_exp - choice of cloud-overlap: exponential ! +! iovr_exprand - choice of cloud-overlap: exponential random ! ! ! ! output variables: ! ! hlwc (npts,nlay): total sky heating rate (k/day or k/sec) ! @@ -508,32 +535,6 @@ subroutine rrtmg_lw_run & ! upfx0 - clear sky upward flux ! ! dnfx0 - clear sky dnward flux ! ! ! -! external module variables: (in physparam) ! -! ilwrgas - control flag for rare gases (ch4,n2o,o2,cfcs, etc.) ! -! =0: do not include rare gases ! -! >0: include all rare gases ! -! ilwcliq - control flag for liq-cloud optical properties ! -! =1: input cld liqp & reliq, hu & stamnes (1993) ! -! =2: not used ! -! ilwcice - control flag for ice-cloud optical properties ! -! =1: input cld icep & reice, ebert & curry (1997) ! -! =2: input cld icep & reice, streamer (1996) ! -! =3: input cld icep & reice, fu (1998) ! -! isubclw - sub-column cloud approximation control flag ! -! =0: no sub-col cld treatment, use grid-mean cld quantities ! -! =1: mcica sub-col, prescribed seeds to get random numbers ! -! =2: mcica sub-col, providing array icseed for random numbers! -! iovr - cloud overlapping control flag ! -! =0: random overlapping clouds ! -! =1: maximum/random overlapping clouds ! -! =2: maximum overlap cloud (used for isubclw>0 only) ! -! =3: decorrelation-length overlap (for isubclw>0 only) ! -! =4: exponential cloud overlap (AER) ! -! =5: exponential-random cloud overlap (AER) ! -! ivflip - control flag for vertical index direction ! -! =0: vertical index from toa to surface ! -! =1: vertical index from surface to toa ! -! ! ! module parameters, control variables: ! ! nbands - number of longwave spectral bands ! ! maxgas - maximum number of absorbing gaseous ! @@ -605,10 +606,12 @@ subroutine rrtmg_lw_run & ! ====================== end of definitions =================== ! ! --- inputs: - integer, intent(in) :: npts, nlay, nlp1 + integer, intent(in) :: npts, nlay, nlp1, ilwcliq, ilwcice, & + isubclw, iovr, iovr_dcorr, iovr_exp, iovr_exprand, iovr_rand,& + iovr_maxrand, iovr_max integer, intent(in) :: icseed(npts) - logical, intent(in) :: lprnt + logical, intent(in) :: lprnt, inc_minor_gas real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, & & tlvl @@ -631,6 +634,7 @@ subroutine rrtmg_lw_run & real (kind=kind_phys), dimension(:,:,:),intent(in):: & & aeraod, aerssa + logical, intent(in) :: lslwr, top_at_1 ! --- outputs: real (kind=kind_phys), dimension(:,:), intent(inout) :: hlwc @@ -650,7 +654,6 @@ subroutine rrtmg_lw_run & & intent(inout) :: hlw0 type (proflw_type), dimension(:,:), optional, & & intent(inout) :: flxprf - logical, intent(in) :: lslwr ! --- locals: real (kind=kind_phys), dimension(0:nlp1) :: cldfrc @@ -790,7 +793,7 @@ subroutine rrtmg_lw_run & endif stemp = sfgtmp(iplon) ! surface ground temp - if (iovr == 3) delgth= de_lgth(iplon) ! clouds decorr-length + if (iovr == iovr_dcorr) delgth= de_lgth(iplon) ! clouds decorr-length !> -# Prepare atmospheric profile for use in rrtm. ! the vertical index of internal array is from surface to top @@ -801,7 +804,7 @@ subroutine rrtmg_lw_run & ! layer pressure thickness (in mb), based on the hydrostatic equation ! --- ... and includes a correction to account for h2o in the layer. - if (ivflip == 0) then ! input from toa to sfc + if (top_at_1) then ! input from toa to sfc tem1 = 100.0 * con_g tem2 = 1.0e-20 * 1.0e3 * con_avgd @@ -814,7 +817,7 @@ subroutine rrtmg_lw_run & tavel(k)= tlyr(iplon,k1) tz(k) = tlvl(iplon,k1) dz(k) = dzlyr(iplon,k1) - if (iovr == 4 .or. iovr == 5) alph(k) = alpha(iplon,k) ! alpha decorrelation + if (iovr == iovr_exp .or. iovr == iovr_exprand) alph(k) = alpha(iplon,k) ! alpha decorrelation !> -# Set absorber amount for h2o, co2, and o3. @@ -841,7 +844,7 @@ subroutine rrtmg_lw_run & !! cf22, convert from volume mixing ratio to molec/cm2 based on !! coldry (scaled to 1.0e-20). - if (ilwrgas > 0) then + if (inc_minor_gas) then do k = 1, nlay k1 = nlp1 - k colamt(k,4)=max(temcol(k), coldry(k)*gasvmr_n2o(iplon,k1)) ! n2o @@ -927,7 +930,7 @@ subroutine rrtmg_lw_run & tavel(k)= tlyr(iplon,k) tz(k) = tlvl(iplon,k+1) dz(k) = dzlyr(iplon,k) - if (iovr == 4 .or. iovr == 5) alph(k) = alpha(iplon,k) ! alpha decorrelation + if (iovr == iovr_exp .or. iovr == iovr_exprand) alph(k) = alpha(iplon,k) ! alpha decorrelation ! --- ... set absorber amount !test use @@ -952,7 +955,7 @@ subroutine rrtmg_lw_run & ! --- ... set up col amount for rare gases, convert from volume mixing ratio ! to molec/cm2 based on coldry (scaled to 1.0e-20) - if (ilwrgas > 0) then + if (inc_minor_gas) then do k = 1, nlay colamt(k,4)=max(temcol(k), coldry(k)*gasvmr_n2o(iplon,k)) ! n2o colamt(k,5)=max(temcol(k), coldry(k)*gasvmr_ch4(iplon,k)) ! ch4 @@ -1021,7 +1024,7 @@ subroutine rrtmg_lw_run & tem0 = 10.0 * tem2 / (amdw * tem1 * con_g) pwvcm = tem0 * plvl(iplon,1) - endif ! if_ivflip + endif ! top_at_1 !> -# Compute column amount for broadening gases. @@ -1078,6 +1081,7 @@ subroutine rrtmg_lw_run & ! --- inputs: & ( cldfrc,clwp,relw,ciwp,reiw,cda1,cda2,cda3,cda4, & & nlay, nlp1, ipseed(iplon), dz, delgth, iovr, alph, & + & ilwcliq, ilwcice, isubclw, & ! --- outputs: & cldfmc, taucld & & ) @@ -1085,7 +1089,7 @@ subroutine rrtmg_lw_run & ! --- ... save computed layer cloud optical depth for output ! rrtm band-7 is apprx 10mu channel (or use spectral mean of bands 6-8) - if (ivflip == 0) then ! input from toa to sfc + if (top_at_1) then ! input from toa to sfc do k = 1, nlay k1 = nlp1 - k cldtau(iplon,k1) = taucld( 7,k) @@ -1094,7 +1098,7 @@ subroutine rrtmg_lw_run & do k = 1, nlay cldtau(iplon,k) = taucld( 7,k) enddo - endif ! end if_ivflip_block + endif ! end if_top_at_1_block else cldfmc = f_zero @@ -1229,7 +1233,7 @@ subroutine rrtmg_lw_run & sfcflx(iplon)%dnfxc = totdflux(0) sfcflx(iplon)%dnfx0 = totdclfl(0) - if (ivflip == 0) then ! output from toa to sfc + if (top_at_1) then ! output from toa to sfc !! --- ... optional fluxes if ( lflxprf ) then @@ -1297,7 +1301,7 @@ subroutine rrtmg_lw_run & enddo endif - endif ! if_ivflip + endif ! if_top_at_1 enddo lab_do_iplon @@ -1315,9 +1319,9 @@ end subroutine rrtmg_lw_run !! spectral band are reduced from 256 g-point intervals to 140. !!\param me print control for parallel process !!\section rlwinit_gen rlwinit General Algorithm - subroutine rlwinit & - & ( me ) ! --- inputs -! --- outputs: (none) + subroutine rlwinit( me, rad_hr_units, inc_minor_gas, ilwcliq, & + isubclw, iovr, iovr_rand, iovr_maxrand, iovr_max, iovr_dcorr,& + iovr_exp, iovr_exprand, errflg, errmsg ) ! =================== program usage description =================== ! ! ! @@ -1329,17 +1333,9 @@ subroutine rlwinit & ! ==================== defination of variables ==================== ! ! ! ! inputs: ! -! me - print control for parallel process ! -! ! -! outputs: (none) ! -! ! -! external module variables: (in physparam) ! -! ilwrate - heating rate unit selections ! -! =1: output in k/day ! -! =2: output in k/second ! -! ilwrgas - control flag for rare gases (ch4,n2o,o2,cfcs, etc.) ! -! =0: do not include rare gases ! -! >0: include all rare gases ! +! me - print control for parallel process ! +! rad_hr_units - 1 for heating rates in units K/day. 2 for K/s ! +! inc_minor_gas - flag to turn on/off minor gases in rrtmg ! ! ilwcliq - liquid cloud optical properties contrl flag ! ! =0: input cloud opt depth from diagnostic scheme ! ! >0: input cwp,rew, and other cloud content parameters ! @@ -1347,16 +1343,23 @@ subroutine rlwinit & ! =0: no sub-col cld treatment, use grid-mean cld quantities ! ! =1: mcica sub-col, prescribed seeds to get random numbers ! ! =2: mcica sub-col, providing array icseed for random numbers! -! icldflg - cloud scheme control flag ! -! =0: diagnostic scheme gives cloud tau, omiga, and g. ! -! =1: prognostic scheme gives cloud liq/ice path, etc. ! ! iovr - clouds vertical overlapping control flag ! -! =0: random overlapping clouds ! -! =1: maximum/random overlapping clouds ! -! =2: maximum overlap cloud (isubcol>0 only) ! -! =3: decorrelation-length overlap (for isubclw>0 only) ! -! =4: exponential cloud overlap (AER) ! -! =5: exponential-random cloud overlap (AER) ! +! =iovr_rand ! +! =iovr_maxrand ! +! =iovr_max ! +! =iovr_dcorr ! +! =iovr_exp ! +! =iovr_exprand ! +! iovr_rand - choice of cloud-overlap: random ! +! iovr_maxrand - choice of cloud-overlap: maximum random ! +! iovr_max - choice of cloud-overlap: maximum ! +! iovr_dcorr - choice of cloud-overlap: decorrelation length ! +! iovr_exp - choice of cloud-overlap: exponential ! +! iovr_exprand - choice of cloud-overlap: exponential random ! +! ! +! outputs: ! +! errflg - error flag ! +! errmsg - error message ! ! ! ! ******************************************************************* ! ! original code description ! @@ -1386,9 +1389,14 @@ subroutine rlwinit & ! ====================== end of description block ================= ! ! --- inputs: - integer, intent(in) :: me + integer, intent(in) :: me, rad_hr_units, ilwcliq, isubclw, iovr, & + iovr_rand, iovr_maxrand, iovr_max, iovr_dcorr, iovr_exp, & + iovr_exprand + logical, intent(in) :: inc_minor_gas -! --- outputs: none +! --- outputs: + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg ! --- locals: real (kind=kind_phys), parameter :: expeps = 1.e-20 @@ -1400,25 +1408,21 @@ subroutine rlwinit & ! !===> ... begin here ! - if ( iovr<0 .or. iovr>5 ) then - print *,' *** Error in specification of cloud overlap flag', & - & ' IOVR=',iovr,' in RLWINIT !!' - stop - elseif ( (iovr==2 .or. iovr==3) .and. isubclw==0 ) then - if (me == 0) then - print *,' *** IOVR=',iovr,' is not available for', & - & ' ISUBCLW=0 setting!!' - print *,' The program uses maximum/random overlap', & - & ' instead.' - endif + ! Initialize error-handling + errflg = 0 + errmsg = '' - iovr = 1 + if ((iovr .ne. iovr_rand) .and. (iovr .ne. iovr_maxrand) .and. & + (iovr .ne. iovr_max) .and. (iovr .ne. iovr_dcorr) .and. & + (iovr .ne. iovr_exp) .and. (iovr .ne. iovr_exprand)) then + errflg = 1 + errmsg = 'ERROR(rlwinit): Error in specification of cloud overlap flag' endif if (me == 0) then print *,' - Using AER Longwave Radiation, Version: ', VTAGLW - if (ilwrgas > 0) then + if (inc_minor_gas) then print *,' --- Include rare gases N2O, CH4, O2, CFCs ', & & 'absorptions in LW' else @@ -1434,22 +1438,9 @@ subroutine rlwinit & elseif ( isubclw == 2 ) then print *,' --- Using MCICA sub-colum clouds approximation ', & & 'with provided input array of permutation seeds' - else - print *,' *** Error in specification of sub-column cloud ', & - & ' control flag isubclw =',isubclw,' !!' - stop endif endif -!> -# Check cloud flags for consistency. - - if ((icldflg == 0 .and. ilwcliq /= 0) .or. & - & (icldflg == 1 .and. ilwcliq == 0)) then - print *,' *** Model cloud scheme inconsistent with LW', & - & ' radiation cloud radiative property setup !!' - stop - endif - !> -# Setup default surface emissivity for each band. semiss0(:) = f_one @@ -1461,7 +1452,7 @@ subroutine rlwinit & fluxfac = pival * 2.0d4 ! fluxfac = 62831.85307179586 ! = 2 * pi * 1.0e4 - if (ilwrate == 1) then + if (rad_hr_units == 1) then ! heatfac = 8.4391 ! heatfac = con_g * 86400. * 1.0e-2 / con_cp ! (in k/day) heatfac = con_g * 864.0 / con_cp ! (in k/day) @@ -1538,8 +1529,8 @@ end subroutine rlwinit !!\section gen_cldprop cldprop General Algorithm subroutine cldprop & & ( cfrac,cliqp,reliq,cicep,reice,cdat1,cdat2,cdat3,cdat4, & ! --- inputs - & nlay, nlp1, ipseed, dz, de_lgth, iovr, alpha, & - & cldfmc, taucld & ! --- outputs + & nlay, nlp1, ipseed, dz, de_lgth, iovr, alpha, ilwcliq, & + & ilwcice, isubclw, cldfmc, taucld & ! --- outputs & ) ! =================== program usage description =================== ! @@ -1639,7 +1630,8 @@ subroutine cldprop & use module_radlw_cldprlw ! --- inputs: - integer, intent(in) :: nlay, nlp1, ipseed, iovr + integer, intent(in) :: nlay, nlp1, ipseed, iovr, ilwcliq, ilwcice,& + isubclw real (kind=kind_phys), dimension(0:nlp1), intent(in) :: cfrac real (kind=kind_phys), dimension(nlay), intent(in) :: cliqp, & @@ -1804,7 +1796,7 @@ subroutine cldprop & endif lab_if_ilwcliq -!> -# if physparam::isubclw > 0, call mcica_subcol() to distribute +!> -# if GFS_typedefs::isubclw > 0, call mcica_subcol() to distribute !! cloud properties to each g-point. if ( isubclw > 0 ) then ! mcica sub-col clouds approx @@ -1820,7 +1812,7 @@ subroutine cldprop & call mcica_subcol & ! --- inputs: - & ( cldf, nlay, ipseed, dz, de_lgth, alpha, & + & ( cldf, nlay, ipseed, dz, de_lgth, alpha, iovr, & ! --- output: & lcloudy & & ) @@ -1853,7 +1845,7 @@ end subroutine cldprop !!\param lcloudy sub-colum cloud profile flag array !!\section mcica_subcol_gen mcica_subcol General Algorithm subroutine mcica_subcol & - & ( cldf, nlay, ipseed, dz, de_lgth, alpha, & ! --- inputs + & ( cldf, nlay, ipseed, dz, de_lgth, alpha, iovr, & ! --- inputs & lcloudy & ! --- outputs & ) @@ -1868,22 +1860,20 @@ subroutine mcica_subcol & ! for lw and sw, use values differ by the number of g-pts. ! ! dz - real, layer thickness (km) nlay ! ! de_lgth - real, layer cloud decorrelation length (km) 1 ! -! alpha - real, EXP/ER decorrelation parameter nlay ! +! alpha - real, EXP/ER decorrelation parameter nlay ! +! iovr - control flag for cloud overlapping method 1 ! +! =0:random; =1:maximum/random: =2:maximum; =3:decorr ! +! =4:exponential; =5:exponential-random ! ! ! ! output variables: ! ! lcloudy - logical, sub-colum cloud profile flag array ngptlw*nlay! ! ! -! other control flags from module variables: ! -! iovr : control flag for cloud overlapping method ! -! =0:random; =1:maximum/random: =2:maximum; =3:decorr ! -! =4:exponential; =5:exponential-random ! -! ! ! ===================== end of definitions ==================== ! implicit none ! --- inputs: - integer, intent(in) :: nlay, ipseed + integer, intent(in) :: nlay, ipseed, iovr real (kind=kind_phys), dimension(nlay), intent(in) :: cldf, dz real (kind=kind_phys), intent(in) :: de_lgth @@ -7635,7 +7625,9 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & return elseif(inflag .eq. 1) then - stop 'INFLAG = 1 OPTION NOT AVAILABLE WITH MCICA' + errflg = 1 + errmsg = 'ERROR(rlwinit): INFLAG = 1 OPTION NOT AVAILABLE WITH MCICA' + return ! cwp = ciwpmc(ig,lay) + clwpmc(ig,lay) ! taucmc(ig,lay) = abscld1 * cwp diff --git a/physics/radlw_main.meta b/physics/radlw_main.meta index 9286c45cb..3dccc97b3 100644 --- a/physics/radlw_main.meta +++ b/physics/radlw_main.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = rrtmg_lw type = scheme - dependencies = machine.F,mersenne_twister.f,physcons.F90,physparam.f,radlw_datatb.f,radlw_param.f + dependencies = machine.F,mersenne_twister.f,physcons.F90,radlw_datatb.f,radlw_param.f ######################################################################## [ccpp-arg-table] @@ -241,6 +241,90 @@ dimensions = () type = logical intent = in +[top_at_1] + standard_name = flag_for_vertical_ordering_in_radiation + long_name = flag for vertical ordering in radiation + units = flag + dimensions = () + type = logical + intent = in +[iovr] + standard_name = flag_for_cloud_overlap_method_for_radiation + long_name = flag for cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_exp] + standard_name = flag_for_exponential_cloud_overlap_method + long_name = choice of exponential cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_exprand] + standard_name = flag_for_exponential_random_cloud_overlap_method + long_name = choice of exponential-random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_max] + standard_name = flag_for_maximum_cloud_overlap_method + long_name = choice of maximum cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_rand] + standard_name = flag_for_random_cloud_overlap_method + long_name = choice of random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_maxrand] + standard_name = flag_for_maximum_random_cloud_overlap_method + long_name = choice of maximum-random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_dcorr] + standard_name = flag_for_decorrelation_length_cloud_overlap_method + long_name = choice of decorrelation-length cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[inc_minor_gas] + standard_name = flag_to_include_minor_gases_in_rrtmg + long_name = flag to include minor trace gases in rrtmg + units = flag + dimensions = () + type = logical + intent = in +[ilwcliq] + standard_name = flag_for_optical_property_for_liquid_clouds_for_longwave_radiation + long_name = lw optical property for liquid clouds + units = flag + dimensions = () + type = integer + intent = in +[ilwcice] + standard_name = flag_for_optical_property_for_ice_clouds_for_longwave_radiation + long_name = lw optical property for ice clouds + units = flag + dimensions = () + type = integer + intent = in +[isubclw] + standard_name = flag_for_lw_clouds_sub_grid_approximation + long_name = flag for lw clouds sub-grid approximation + units = flag + dimensions = () + type = integer + intent = in [hlwc] standard_name = tendency_of_air_temperature_due_to_longwave_heating_on_radiation_time_step_and_radiation_levels long_name = longwave total sky heating rate diff --git a/physics/radlw_param.f b/physics/radlw_param.f index fa7ceecb0..bc2aae224 100644 --- a/physics/radlw_param.f +++ b/physics/radlw_param.f @@ -65,7 +65,7 @@ module module_radlw_parameters ! !! \htmlinclude module_radlw_parameters.html !! - use physparam, only : kind_phys + use machine, only : kind_phys implicit none ! diff --git a/physics/radsw_datatb.f b/physics/radsw_datatb.f index 6d88f1989..e0bb651e9 100644 --- a/physics/radsw_datatb.f +++ b/physics/radsw_datatb.f @@ -73,7 +73,7 @@ module module_radsw_ref ! !........................................! ! - use physparam, only : kind_phys + use machine, only : kind_phys ! implicit none ! @@ -217,7 +217,7 @@ module module_radsw_cldprtb ! ! ! ! ************************* end description ************************ ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radsw_parameters, only : nblow, nbhgh ! implicit none @@ -2503,7 +2503,7 @@ module module_radsw_sflux ! ! ! ! ************************* end description ************************ ! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radsw_parameters, only : NGMAX, NG16, NG17, NG18, NG19,& & NG20, NG21, NG22, NG23, NG24, & & NG25, NG26, NG27, NG28, NG29, & @@ -2838,7 +2838,7 @@ module module_radsw_kgb16 ! ! ! ! ************************ end description ************************ ! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radsw_parameters, only : NG16 ! @@ -4031,7 +4031,7 @@ module module_radsw_kgb17 ! ! ! ! ********* ********* end description ********* ********* ! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radsw_parameters, only : NG17 ! @@ -8640,7 +8640,7 @@ module module_radsw_kgb18 ! ! ! ! ********* ********* end description ********* ********* ! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radsw_parameters, only : NG18 ! @@ -10158,7 +10158,7 @@ module module_radsw_kgb19 ! ! ! ! ********* ********* end description ********* ********* ! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radsw_parameters, only : NG19 ! @@ -11677,7 +11677,7 @@ module module_radsw_kgb20 ! ! ! ! ********* ********* end description ********* ********* ! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radsw_parameters, only : NG20 ! @@ -12461,7 +12461,7 @@ module module_radsw_kgb21 ! ! ! ! ********* ********* end description ********* ********* ! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radsw_parameters, only : NG21 ! @@ -16319,7 +16319,7 @@ module module_radsw_kgb22 ! ! ! ! ********* ********* end description ********* ********* ! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radsw_parameters, only : NG22 ! @@ -16766,7 +16766,7 @@ module module_radsw_kgb23 ! ! ! ! ********* ********* end description ********* ********* ! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radsw_parameters, only : NG23 ! @@ -17023,7 +17023,7 @@ module module_radsw_kgb24 ! ! ! ! ********* ********* end description ********* ********* ! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radsw_parameters, only : NG24 ! @@ -18588,7 +18588,7 @@ module module_radsw_kgb25 ! ! ! ! ********* ********* end description ********* ********* ! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radsw_parameters, only : NG25 ! @@ -18748,7 +18748,7 @@ module module_radsw_kgb26 ! ! ! ! ********* ********* end description ********* ********* ! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radsw_parameters, only : NG26 ! @@ -18784,7 +18784,7 @@ module module_radsw_kgb27 ! ! ! ! ********* ********* end description ********* ********* ! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radsw_parameters, only : NG27 ! @@ -19387,7 +19387,7 @@ module module_radsw_kgb28 ! ! ! ! ********* ********* end description ********* ********* ! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radsw_parameters, only : NG28 ! @@ -21701,7 +21701,7 @@ module module_radsw_kgb29 ! ! ! ! ********* ********* end description ********* ********* ! ! - use physparam, only : kind_phys + use machine, only : kind_phys use module_radsw_parameters, only : NG29 ! diff --git a/physics/radsw_main.F90 b/physics/radsw_main.F90 index ae2f21e18..fe63963f5 100644 --- a/physics/radsw_main.F90 +++ b/physics/radsw_main.F90 @@ -90,7 +90,6 @@ ! ! ! external modules referenced: ! ! ! -! 'module physparam' ! ! 'module physcons' ! ! 'mersenne_twister' ! ! ! @@ -304,9 +303,6 @@ !! rrtmg-sw radiation code from aer inc. module rrtmg_sw ! - use physparam, only : iswrate, iswrgas, iswcliq, iswcice, & - & isubcsw, icldflg, iovr, ivflip, & - & iswmode use physcons, only : con_g, con_cp, con_avgd, con_amd, & & con_amw, con_amo3 use machine, only : rb => kind_phys, im => kind_io4, & @@ -503,8 +499,9 @@ subroutine rrtmg_sw_run & & sfcalb_uvis_dir, sfcalb_uvis_dif, & & dzlyr,delpin,de_lgth,alpha, & & cosz,solcon,NDAY,idxday, & - & npts, nlay, nlp1, lprnt, & - & cld_cf, lsswr, & + & npts, nlay, nlp1, lprnt, inc_minor_gas, iswcliq, iswcice, & + & isubcsw, iovr, top_at_1, iswmode, cld_cf, lsswr, iovr_rand,& + & iovr_maxrand, iovr_max, iovr_dcorr, iovr_exp, iovr_exprand,& & hswc,topflx,sfcflx,cldtau, & ! --- outputs & HSW0,HSWB,FLXPRF,FDNCMP, & ! --- optional & cld_lwp, cld_ref_liq, cld_iwp, cld_ref_ice, & @@ -570,6 +567,36 @@ subroutine rrtmg_sw_run & ! npts : number of horizontal points ! ! nlay,nlp1 : vertical layer/lavel numbers ! ! lprnt : logical check print flag ! +! iswcliq - control flag for liq-cloud optical properties ! +! =0: input cloud optical depth, fixed ssa, asy ! +! =1: use hu and stamnes(1993) method for liq cld ! +! =2: use updated coeffs for hu and stamnes scheme ! +! iswcice - control flag for ice-cloud optical properties ! +! *** if iswcliq==0, iswcice is ignored ! +! =1: use ebert and curry (1992) scheme for ice clouds ! +! =2: use streamer v3.0 (2001) method for ice clouds ! +! =3: use fu's method (1996) for ice clouds ! +! iswmode - control flag for 2-stream transfer scheme ! +! =1; delta-eddington (joseph et al., 1976) ! +! =2: pifm (zdunkowski et al., 1980) ! +! =3: discrete ordinates (liou, 1973) ! +! isubcsw - sub-column cloud approximation control flag ! +! =0: no sub-col cld treatment, use grid-mean cld quantities ! +! =1: mcica sub-col, prescribed seeds to get random numbers ! +! =2: mcica sub-col, providing array icseed for random numbers! +! iovr - clouds vertical overlapping control flag ! +! =iovr_rand ! +! =iovr_maxrand ! +! =iovr_max ! +! =iovr_dcorr ! +! =iovr_exp ! +! =iovr_exprand ! +! iovr_rand - choice of cloud-overlap: random ! +! iovr_maxrand - choice of cloud-overlap: maximum random ! +! iovr_max - choice of cloud-overlap: maximum ! +! iovr_dcorr - choice of cloud-overlap: decorrelation length ! +! iovr_exp - choice of cloud-overlap: exponential ! +! iovr_exprand - choice of cloud-overlap: exponential random ! ! ! ! output variables: ! ! hswc (npts,nlay): total sky heating rates (k/sec or k/day) ! @@ -604,38 +631,6 @@ subroutine rrtmg_sw_run & ! visbm - downward surface uv+vis direct beam flux ! ! visdf - downward surface uv+vis diffused flux ! ! ! -! external module variables: (in physparam) ! -! iswrgas - control flag for rare gases (ch4,n2o,o2, etc.) ! -! =0: do not include rare gases ! -! >0: include all rare gases ! -! iswcliq - control flag for liq-cloud optical properties ! -! =0: input cloud optical depth, fixed ssa, asy ! -! =1: use hu and stamnes(1993) method for liq cld ! -! =2: use updated coeffs for hu and stamnes scheme ! -! iswcice - control flag for ice-cloud optical properties ! -! *** if iswcliq==0, iswcice is ignored ! -! =1: use ebert and curry (1992) scheme for ice clouds ! -! =2: use streamer v3.0 (2001) method for ice clouds ! -! =3: use fu's method (1996) for ice clouds ! -! iswmode - control flag for 2-stream transfer scheme ! -! =1; delta-eddington (joseph et al., 1976) ! -! =2: pifm (zdunkowski et al., 1980) ! -! =3: discrete ordinates (liou, 1973) ! -! isubcsw - sub-column cloud approximation control flag ! -! =0: no sub-col cld treatment, use grid-mean cld quantities ! -! =1: mcica sub-col, prescribed seeds to get random numbers ! -! =2: mcica sub-col, providing array icseed for random numbers! -! iovr - cloud overlapping control flag ! -! =0: random overlapping clouds ! -! =1: maximum/random overlapping clouds ! -! =2: maximum overlap cloud ! -! =3: decorrelation-length overlap clouds ! -! =4: exponential cloud overlap (AER) ! -! =5: exponential-random cloud overlap (AER) ! -! ivflip - control flg for direction of vertical index ! -! =0: index from toa to surface ! -! =1: index from surface to toa ! -! ! ! module parameters, control variables: ! ! nblow,nbhgh - lower and upper limits of spectral bands ! ! maxgas - maximum number of absorbing gaseous ! @@ -690,11 +685,13 @@ subroutine rrtmg_sw_run & ! ===================== end of definitions ==================== ! ! --- inputs: - integer, intent(in) :: npts, nlay, nlp1, NDAY + integer, intent(in) :: npts, nlay, nlp1, NDAY, iswcliq, iswcice, & + isubcsw, iovr, iswmode, iovr_dcorr, iovr_exp, iovr_exprand, & + iovr_rand, iovr_maxrand, iovr_max integer, dimension(:), intent(in) :: idxday, icseed - logical, intent(in) :: lprnt, lsswr + logical, intent(in) :: lprnt, lsswr, inc_minor_gas, top_at_1 real (kind=kind_phys), dimension(:,:), intent(in) :: & & plvl, tlvl @@ -899,7 +896,7 @@ subroutine rrtmg_sw_run & cosz1 = cosz(j1) sntz1 = f_one / cosz(j1) ssolar = s0fac * cosz(j1) - if (iovr == 3) delgth = de_lgth(j1) ! clouds decorr-length + if (iovr == iovr_dcorr) delgth = de_lgth(j1) ! clouds decorr-length !> - Prepare surface albedo: bm,df - dir,dif; 1,2 - nir,uvv. albbm(1) = sfcalb_nir_dir(j1) @@ -910,7 +907,7 @@ subroutine rrtmg_sw_run & !> - Prepare atmospheric profile for use in rrtm. ! the vertical index of internal array is from surface to top - if (ivflip == 0) then ! input from toa to sfc + if (top_at_1) then ! input from toa to sfc tem1 = 100.0 * con_g tem2 = 1.0e-20 * 1.0e3 * con_avgd @@ -921,7 +918,7 @@ subroutine rrtmg_sw_run & tavel(k) = tlyr(j1,kk) delp (k) = delpin(j1,kk) dz (k) = dzlyr (j1,kk) - if (iovr == 4 .or. iovr == 5) alph(k) = alpha(j1,k) ! alpha decorrelation + if (iovr == iovr_exp .or. iovr == iovr_exprand) alph(k) = alpha(j1,k) ! alpha decorrelation !> - Set absorber and gas column amount, convert from volume mixing !! ratio to molec/cm2 based on coldry (scaled to 1.0e-20) @@ -950,7 +947,7 @@ subroutine rrtmg_sw_run & ! --- ... set up gas column amount, convert from volume mixing ratio ! to molec/cm2 based on coldry (scaled to 1.0e-20) - if (iswrgas > 0) then + if (inc_minor_gas) then do k = 1, nlay kk = nlp1 - k colamt(k,4) = max(temcol(k), coldry(k)*gasvmr_n2o(j1,kk)) ! n2o @@ -1012,7 +1009,7 @@ subroutine rrtmg_sw_run & tavel(k) = tlyr(j1,k) delp (k) = delpin(j1,k) dz (k) = dzlyr (j1,k) - if (iovr == 4 .or. iovr == 5) alph(k) = alpha(j1,k) ! alpha decorrelation + if (iovr == iovr_exp .or. iovr == iovr_exprand) alph(k) = alpha(j1,k) ! alpha decorrelation ! --- ... set absorber amount !test use @@ -1047,7 +1044,7 @@ subroutine rrtmg_sw_run & ! --- ... set up gas column amount, convert from volume mixing ratio ! to molec/cm2 based on coldry (scaled to 1.0e-20) - if (iswrgas > 0) then + if (inc_minor_gas) then do k = 1, nlay colamt(k,4) = max(temcol(k), coldry(k)*gasvmr_n2o(j1,k)) ! n2o colamt(k,5) = max(temcol(k), coldry(k)*gasvmr_ch4(j1,k)) ! ch4 @@ -1094,7 +1091,7 @@ subroutine rrtmg_sw_run & enddo endif ! end if_iswcliq - endif ! if_ivflip + endif ! if_top_at_1 !> - Compute fractions of clear sky view: !! - random overlapping @@ -1103,11 +1100,11 @@ subroutine rrtmg_sw_run & zcf0 = f_one zcf1 = f_one - if (iovr == 0) then ! random overlapping + if (iovr == iovr_rand) then ! random overlapping do k = 1, nlay zcf0 = zcf0 * (f_one - cfrac(k)) enddo - else if (iovr == 1) then ! max/ran/exp overlapping + else if (iovr == iovr_maxrand) then ! max/ran/exp overlapping do k = 1, nlay if (cfrac(k) > ftiny) then ! cloudy layer zcf1 = min ( zcf1, f_one-cfrac(k) ) @@ -1135,7 +1132,8 @@ subroutine rrtmg_sw_run & call cldprop & ! --- inputs: & ( cfrac,cliqp,reliq,cicep,reice,cdat1,cdat2,cdat3,cdat4, & - & zcf1, nlay, ipseed(j1), dz, delgth, alph, & + & zcf1, nlay, ipseed(j1), dz, delgth, alph, iswcliq, iswcice,& + & isubcsw, iovr, & ! --- outputs: & taucw, ssacw, asycw, cldfrc, cldfmc & & ) @@ -1143,7 +1141,7 @@ subroutine rrtmg_sw_run & ! --- ... save computed layer cloud optical depth for output ! rrtm band 10 is approx to the 0.55 mu spectrum - if (ivflip == 0) then ! input from toa to sfc + if (top_at_1) then ! input from toa to sfc do k = 1, nlay kk = nlp1 - k cldtau(j1,kk) = taucw(k,10) @@ -1152,7 +1150,7 @@ subroutine rrtmg_sw_run & do k = 1, nlay cldtau(j1,k) = taucw(k,10) enddo - endif ! end if_ivflip_block + endif ! end if_top_at_1_block else ! clear sky column cldfrc(:) = f_zero @@ -1187,9 +1185,9 @@ subroutine rrtmg_sw_run & & ) !> - Call the 2-stream radiation transfer model: -!! - if physparam::isubcsw .le.0, using standard cloud scheme, +!! - if GFS_typedefs::isubcsw .le.0, using standard cloud scheme, !! call spcvrtc(). -!! - if physparam::isubcsw .gt.0, using mcica cloud scheme, +!! - if GFS_typedefs::isubcsw .gt.0, using mcica cloud scheme, !! call spcvrtm(). if ( isubcsw <= 0 ) then ! use standard cloud scheme @@ -1198,7 +1196,7 @@ subroutine rrtmg_sw_run & ! --- inputs: & ( ssolar,cosz1,sntz1,albbm,albdf,sfluxzen,cldfrc, & & zcf1,zcf0,taug,taur,tauae,ssaae,asyae,taucw,ssacw,asycw, & - & nlay, nlp1, & + & nlay, nlp1, iswmode, & ! --- outputs: & fxupc,fxdnc,fxup0,fxdn0, & & ftoauc,ftoau0,ftoadc,fsfcuc,fsfcu0,fsfcdc,fsfcd0, & @@ -1211,7 +1209,7 @@ subroutine rrtmg_sw_run & ! --- inputs: & ( ssolar,cosz1,sntz1,albbm,albdf,sfluxzen,cldfmc, & & zcf1,zcf0,taug,taur,tauae,ssaae,asyae,taucw,ssacw,asycw, & - & nlay, nlp1, & + & nlay, nlp1, iswmode, & ! --- outputs: & fxupc,fxdnc,fxup0,fxdn0, & & ftoauc,ftoau0,ftoadc,fsfcuc,fsfcu0,fsfcdc,fsfcd0, & @@ -1276,7 +1274,7 @@ subroutine rrtmg_sw_run & sfcflx(j1)%upfx0 = fsfcu0 sfcflx(j1)%dnfx0 = fsfcd0 - if (ivflip == 0) then ! output from toa to sfc + if (top_at_1) then ! output from toa to sfc ! --- ... compute heating rates @@ -1372,7 +1370,7 @@ subroutine rrtmg_sw_run & enddo endif - endif ! if_ivflip + endif ! if_top_at_1 enddo lab_do_ipt @@ -1387,9 +1385,9 @@ end subroutine rrtmg_sw_run !!\param me print control for parallel process !>\section rswinit_gen rswinit General Algorithm !----------------------------------- - subroutine rswinit & - & ( me ) ! --- inputs: -! --- outputs: (none) + subroutine rswinit( me, rad_hr_units, inc_minor_gas, iswcliq, & + isubcsw, iovr, iovr_rand, iovr_maxrand, iovr_max, iovr_dcorr,& + iovr_exp, iovr_exprand, iswmode, errflg, errmsg ) ! =================== program usage description =================== ! ! ! @@ -1401,17 +1399,8 @@ subroutine rswinit & ! ==================== defination of variables ==================== ! ! ! ! inputs: ! -! me - print control for parallel process ! -! ! -! outputs: (none) ! -! ! -! external module variables: (in physparam) ! -! iswrate - heating rate unit selections ! -! =1: output in k/day ! -! =2: output in k/second ! -! iswrgas - control flag for rare gases (ch4,n2o,o2, etc.) ! -! =0: do not include rare gases ! -! >0: include all rare gases ! +! me - print control for parallel process ! +! rad_hr_units - ! ! iswcliq - liquid cloud optical properties contrl flag ! ! =0: input cloud opt depth from diagnostic scheme ! ! >0: input cwp,rew, and other cloud content parameters ! @@ -1419,21 +1408,27 @@ subroutine rswinit & ! =0: no sub-col cld treatment, use grid-mean cld quantities ! ! =1: mcica sub-col, prescribed seeds to get random numbers ! ! =2: mcica sub-col, providing array icseed for random numbers! -! icldflg - cloud scheme control flag ! -! =0: diagnostic scheme gives cloud tau, omiga, and g. ! -! =1: prognostic scheme gives cloud liq/ice path, etc. ! -! iovr - clouds vertical overlapping control flag ! -! =0: random overlapping clouds ! -! =1: maximum/random overlapping clouds ! -! =2: maximum overlap cloud ! -! =3: decorrelation-length overlap clouds ! -! =4: exponential cloud overlap (AER) ! -! =5: exponential-random cloud overlap (AER) ! +! iovr - clouds vertical overlapping control flag ! +! =iovr_rand ! +! =iovr_maxrand ! +! =iovr_max ! +! =iovr_dcorr ! +! =iovr_exp ! +! =iovr_exprand ! +! iovr_rand - choice of cloud-overlap: random ! +! iovr_maxrand - choice of cloud-overlap: maximum random ! +! iovr_max - choice of cloud-overlap: maximum ! +! iovr_dcorr - choice of cloud-overlap: decorrelation length ! +! iovr_exp - choice of cloud-overlap: exponential ! +! iovr_exprand - choice of cloud-overlap: exponential random ! ! iswmode - control flag for 2-stream transfer scheme ! ! =1; delta-eddington (joseph et al., 1976) ! ! =2: pifm (zdunkowski et al., 1980) ! ! =3: discrete ordinates (liou, 1973) ! ! ! +! outputs: ! +! errflg - error flag ! +! errmsg - error message ! ! ******************************************************************* ! ! ! ! definitions: ! @@ -1446,9 +1441,13 @@ subroutine rswinit & ! ====================== end of description block ================= ! ! --- inputs: - integer, intent(in) :: me - -! --- outputs: none + integer, intent(in) :: me, rad_hr_units, iswcliq, isubcsw, iovr, & + iswmode, iovr_rand, iovr_maxrand, iovr_max, iovr_dcorr, & + iovr_exp, iovr_exprand + logical, intent(in) :: inc_minor_gas +! --- outputs: + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg ! --- locals: real (kind=kind_phys), parameter :: expeps = 1.e-20 @@ -1460,10 +1459,15 @@ subroutine rswinit & ! !===> ... begin here ! - if ( iovr<0 .or. iovr>5 ) then - print *,' *** Error in specification of cloud overlap flag', & - & ' IOVR=',iovr,' in RSWINIT !!' - stop + ! Initialize error-handling + errflg = 0 + errmsg = '' + + if ((iovr .ne. iovr_rand) .and. (iovr .ne. iovr_maxrand) .and. & + (iovr .ne. iovr_max) .and. (iovr .ne. iovr_dcorr) .and. & + (iovr .ne. iovr_exp) .and. (iovr .ne. iovr_exprand)) then + errflg = 1 + errmsg = 'ERROR(rswinit): Error in specification of cloud overlap flag' endif if (me == 0) then @@ -1477,7 +1481,7 @@ subroutine rswinit & print *,' --- Discrete ordinates 2-stream transfer scheme' endif - if (iswrgas <= 0) then + if (.not. inc_minor_gas) then print *,' --- Rare gases absorption is NOT included in SW' else print *,' --- Include rare gases N2O, CH4, O2, absorptions',& @@ -1493,37 +1497,13 @@ subroutine rswinit & elseif ( isubcsw == 2 ) then print *,' --- Using MCICA sub-colum clouds approximation ', & & 'with provided input array of permutation seeds' - else - print *,' *** Error in specification of sub-column cloud ', & - & ' control flag isubcsw =',isubcsw,' !!' - stop endif endif -!> - Check cloud flags for consistency. - - if ((icldflg == 0 .and. iswcliq /= 0) .or. & - & (icldflg == 1 .and. iswcliq == 0)) then - print *,' *** Model cloud scheme inconsistent with SW', & - & ' radiation cloud radiative property setup !!' - stop - endif - - if ( isubcsw==0 .and. iovr>2 ) then - if (me == 0) then - print *,' *** IOVR=',iovr,' is not available for', & - & ' ISUBCSW=0 setting!!' - print *,' The program will use maximum/random overlap', & - & ' instead.' - endif - - iovr = 1 - endif - !> - Setup constant factors for heating rate !! the 1.0e-2 is to convert pressure from mb to \f$N/m^2\f$ . - if (iswrate == 1) then + if (rad_hr_units == 1) then ! heatfac = 8.4391 ! heatfac = con_g * 86400. * 1.0e-2 / con_cp ! (in k/day) heatfac = con_g * 864.0 / con_cp ! (in k/day) @@ -1585,8 +1565,8 @@ end subroutine rswinit !!\section General_cldprop cldprop General Algorithm subroutine cldprop & & ( cfrac,cliqp,reliq,cicep,reice,cdat1,cdat2,cdat3,cdat4, & ! --- inputs - & cf1, nlay, ipseed, dz, delgth, alpha, & - & taucw, ssacw, asycw, cldfrc, cldfmc & ! --- output + & cf1, nlay, ipseed, dz, delgth, alpha, iswcliq, iswcice, & + & isubcsw, iovr, taucw, ssacw, asycw, cldfrc, cldfmc & ! --- output & ) ! =================== program usage description =================== ! @@ -1637,7 +1617,7 @@ subroutine cldprop & ! ! ! ! ! explanation of the method for each value of iswcliq, and iswcice. ! -! set up in module "physparam" ! +! provided by host-model ! ! ! ! iswcliq=0 : input cloud optical property (tau, ssa, asy). ! ! (used for diagnostic cloud method) ! @@ -1672,7 +1652,8 @@ subroutine cldprop & use module_radsw_cldprtb ! --- inputs: - integer, intent(in) :: nlay, ipseed + integer, intent(in) :: nlay, ipseed, iswcliq, iswcice, isubcsw, & + iovr real (kind=kind_phys), intent(in) :: cf1, delgth real (kind=kind_phys), dimension(nlay), intent(in) :: cliqp, & @@ -1930,7 +1911,7 @@ subroutine cldprop & call mcica_subcol & ! --- inputs: - & ( cldf, nlay, ipseed, dz, delgth, alpha, & + & ( cldf, nlay, ipseed, dz, delgth, alpha, iovr, & ! --- outputs: & lcloudy & & ) @@ -1969,7 +1950,7 @@ end subroutine cldprop !!\section mcica_sw_gen mcica_subcol General Algorithm ! ---------------------------------- subroutine mcica_subcol & - & ( cldf, nlay, ipseed, dz, de_lgth, alpha, & ! --- inputs + & ( cldf, nlay, ipseed, dz, de_lgth, alpha, iovr, & ! --- inputs & lcloudy & ! --- outputs & ) @@ -1982,15 +1963,10 @@ subroutine mcica_subcol & ! ** note : if the cloud generator is called multiple times, need ! ! to permute the seed between each call; if between calls ! ! for lw and sw, use values differ by the number of g-pts. ! -! dz - real, layer thickness (km) nlay ! -! de_lgth-real, layer cloud decorrelation length (km) 1 ! -! alpha - real, EXP/ER decorrelation parameter nlay ! -! ! -! output variables: ! -! lcloudy - logical, sub-colum cloud profile flag array nlay*ngptsw! -! ! -! other control flags from module variables: ! -! iovr : control flag for cloud overlapping method ! +! dz - real, layer thickness (km) nlay ! +! de_lgth - real, layer cloud decorrelation length (km) 1 ! +! alpha - real, EXP/ER decorrelation parameter nlay ! +! iovr - control flag for cloud overlapping method 1 ! ! =0: random ! ! =1: maximum/random overlapping clouds ! ! =2: maximum overlap cloud ! @@ -1998,12 +1974,15 @@ subroutine mcica_subcol & ! =4: exponential cloud overlap method (AER) ! ! =5: exponential-random cloud overlap method (AER) ! ! ! +! output variables: ! +! lcloudy - logical, sub-colum cloud profile flag array nlay*ngptsw! +! ! ! ===================== end of definitions ==================== ! implicit none ! --- inputs: - integer, intent(in) :: nlay, ipseed + integer, intent(in) :: nlay, ipseed, iovr real (kind=kind_phys), dimension(nlay), intent(in) :: cldf, dz real (kind=kind_phys), intent(in) :: de_lgth @@ -2453,7 +2432,7 @@ end subroutine setcoef subroutine spcvrtc & & ( ssolar,cosz,sntz,albbm,albdf,sfluxzen,cldfrc, & ! --- inputs & cf1,cf0,taug,taur,tauae,ssaae,asyae,taucw,ssacw,asycw, & - & nlay, nlp1, & + & nlay, nlp1, iswmode, & & fxupc,fxdnc,fxup0,fxdn0, & ! --- outputs & ftoauc,ftoau0,ftoadc,fsfcuc,fsfcu0,fsfcdc,fsfcd0, & & sfbmc,sfdfc,sfbm0,sfdf0,suvbfc,suvbf0 & @@ -2515,7 +2494,7 @@ subroutine spcvrtc & ! zldbt - real, layer beam transmittance for clear/cloudy nlp1 ! ! ztdbt - real, lev total beam transmittance for clr/cld nlp1 ! ! ! -! control parameters in module "physparam" ! +! control parameters in module "GFS_typedefs" ! ! iswmode - control flag for 2-stream transfer schemes ! ! = 1 delta-eddington (joseph et al., 1976) ! ! = 2 pifm (zdunkowski et al., 1980) ! @@ -2556,7 +2535,7 @@ subroutine spcvrtc & real (kind=kind_phys), parameter :: eps1 = 1.0e-8 ! --- inputs: - integer, intent(in) :: nlay, nlp1 + integer, intent(in) :: nlay, nlp1, iswmode real (kind=kind_phys), dimension(nlay,ngptsw), intent(in) :: & & taug, taur @@ -2661,7 +2640,7 @@ subroutine spcvrtc & !! transmittance. ! - Set up toa direct beam and surface values (beam and diff). ! - Delta scaling for clear-sky condition. -! - General two-stream expressions for physparam::iswmode . +! - General two-stream expressions. ! - Compute homogeneous reflectance and transmittance for both ! conservative and non-conservative scattering. ! - Pre-delta-scaling clear and cloudy direct beam transmittance. @@ -2693,7 +2672,7 @@ subroutine spcvrtc & zasy3 = 0.75 * zasy1 !> - Perform general two-stream expressions: -!!\n control parameters in module "physparam" +!!\n control parameters provided by host-model !!\n iswmode - control flag for 2-stream transfer schemes !!\n = 1 delta-eddington (joseph et al., 1976) !!\n = 2 pifm (zdunkowski et al., 1980) @@ -2887,7 +2866,7 @@ subroutine spcvrtc & !! transmittance. ! - Set up toa direct beam and surface values (beam and diff) ! - Delta scaling for total-sky condition -! - General two-stream expressions for physparam::iswmode +! - General two-stream expressions ! - Compute homogeneous reflectance and transmittance for ! conservative scattering and non-conservative scattering ! - Pre-delta-scaling clear and cloudy direct beam transmittance @@ -2922,7 +2901,7 @@ subroutine spcvrtc & zasy3 = 0.75 * zasy1 !> - Perform general two-stream expressions: -!!\n control parameters in module "physparam" +!!\n control parameters provided by host-model !!\n iswmode - control flag for 2-stream transfer schemes !!\n = 1 delta-eddington (joseph et al., 1976) !!\n = 2 pifm (zdunkowski et al., 1980) @@ -3249,7 +3228,7 @@ end subroutine spcvrtc subroutine spcvrtm & & ( ssolar,cosz,sntz,albbm,albdf,sfluxzen,cldfmc, & ! --- inputs & cf1,cf0,taug,taur,tauae,ssaae,asyae,taucw,ssacw,asycw, & - & nlay, nlp1, & + & nlay, nlp1, iswmode, & & fxupc,fxdnc,fxup0,fxdn0, & ! --- outputs & ftoauc,ftoau0,ftoadc,fsfcuc,fsfcu0,fsfcdc,fsfcd0, & & sfbmc,sfdfc,sfbm0,sfdf0,suvbfc,suvbf0 & @@ -3285,6 +3264,10 @@ subroutine spcvrtm & ! ssacw - real, weighted cloud single scat albedo nlay*nbdsw ! ! asycw - real, weighted cloud asymmetry factor nlay*nbdsw ! ! nlay,nlp1 - integer, number of layers/levels 1 ! +! iswmode - control flag for 2-stream transfer schemes ! +! = 1 delta-eddington (joseph et al., 1976) ! +! = 2 pifm (zdunkowski et al., 1980) ! +! = 3 discrete ordinates (liou, 1973) ! ! ! ! output variables: ! ! fxupc - real, tot sky upward flux nlp1*nbdsw ! @@ -3313,12 +3296,6 @@ subroutine spcvrtm & ! zldbt - real, layer beam transmittance for clear/cloudy nlp1 ! ! ztdbt - real, lev total beam transmittance for clr/cld nlp1 ! ! ! -! control parameters in module "physparam" ! -! iswmode - control flag for 2-stream transfer schemes ! -! = 1 delta-eddington (joseph et al., 1976) ! -! = 2 pifm (zdunkowski et al., 1980) ! -! = 3 discrete ordinates (liou, 1973) ! -! ! ! ******************************************************************* ! ! original code description ! ! ! @@ -3354,7 +3331,7 @@ subroutine spcvrtm & real (kind=kind_phys), parameter :: eps1 = 1.0e-8 ! --- inputs: - integer, intent(in) :: nlay, nlp1 + integer, intent(in) :: nlay, nlp1, iswmode real (kind=kind_phys), dimension(nlay,ngptsw), intent(in) :: & & taug, taur, cldfmc @@ -3458,7 +3435,7 @@ subroutine spcvrtm & !! transmittance. ! - Set up toa direct beam and surface values (beam and diff) ! - Delta scaling for clear-sky condition -! - General two-stream expressions for physparam::iswmode +! - General two-stream expressions ! - Compute homogeneous reflectance and transmittance for both ! conservative and non-conservative scattering ! - Pre-delta-scaling clear and cloudy direct beam transmittance @@ -3489,7 +3466,7 @@ subroutine spcvrtm & zasy3 = 0.75 * zasy1 !> - Perform general two-stream expressions: -!!\n control parameters in module "physparam" +!!\n control parameters provided by host-model !!\n iswmode - control flag for 2-stream transfer schemes !!\n = 1 delta-eddington (joseph et al., 1976) !!\n = 2 pifm (zdunkowski et al., 1980) @@ -3682,7 +3659,7 @@ subroutine spcvrtm & !! transmittance. ! - Set up toa direct beam and surface values (beam and diff) ! - Delta scaling for total-sky condition -! - General two-stream expressions for physparam::iswmode +! - General two-stream expressions ! - Compute homogeneous reflectance and transmittance for ! conservative scattering and non-conservative scattering ! - Pre-delta-scaling clear and cloudy direct beam transmittance diff --git a/physics/radsw_main.meta b/physics/radsw_main.meta index 506e2edf0..1edb6fcac 100644 --- a/physics/radsw_main.meta +++ b/physics/radsw_main.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = rrtmg_sw type = scheme - dependencies = machine.F,mersenne_twister.f,physcons.F90,physparam.f,radsw_datatb.f,radsw_param.f + dependencies = machine.F,mersenne_twister.f,physcons.F90,radsw_datatb.f,radsw_param.f ######################################################################## [ccpp-arg-table] @@ -280,6 +280,97 @@ dimensions = () type = logical intent = in +[inc_minor_gas] + standard_name = flag_to_include_minor_gases_in_rrtmg + long_name = flag to include minor trace gases in rrtmg + units = flag + dimensions = () + type = logical + intent = in +[top_at_1] + standard_name = flag_for_vertical_ordering_in_radiation + long_name = flag for vertical ordering in radiation + units = flag + dimensions = () + type = logical + intent = in +[iswcice] + standard_name = flag_for_optical_property_for_ice_clouds_for_shortwave_radiation + long_name = sw optical property for ice clouds + units = flag + dimensions = () + type = integer + intent = in +[iswcliq] + standard_name = control_for_shortwave_radiation_liquid_clouds + long_name = sw optical property for liquid clouds + units = flag + dimensions = () + type = integer + intent = in +[isubcsw] + standard_name = flag_for_sw_clouds_grid_approximation + long_name = flag for sw clouds sub-grid approximation + units = flag + dimensions = () + type = integer + intent = in +[iovr] + standard_name = flag_for_cloud_overlap_method_for_radiation + long_name = max-random overlap clouds + units = flag + dimensions = () + type = integer + intent = in +[iovr_exp] + standard_name = flag_for_exponential_cloud_overlap_method + long_name = choice of exponential cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_exprand] + standard_name = flag_for_exponential_random_cloud_overlap_method + long_name = choice of exponential-random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_max] + standard_name = flag_for_maximum_cloud_overlap_method + long_name = choice of maximum cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_rand] + standard_name = flag_for_random_cloud_overlap_method + long_name = choice of random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_maxrand] + standard_name = flag_for_maximum_random_cloud_overlap_method + long_name = choice of maximum-random cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iovr_dcorr] + standard_name = flag_for_decorrelation_length_cloud_overlap_method + long_name = choice of decorrelation-length cloud overlap method + units = flag + dimensions = () + type = integer + intent = in +[iswmode] + standard_name = control_for_sw_scattering_choice + long_name = control of rrtmg shortwave scattering choice + units = 1 + dimensions = () + type = integer + intent = in [cld_cf] standard_name = total_cloud_fraction long_name = total cloud fraction diff --git a/physics/radsw_param.f b/physics/radsw_param.f index 69c8c2446..2086f5df8 100644 --- a/physics/radsw_param.f +++ b/physics/radsw_param.f @@ -66,7 +66,7 @@ module module_radsw_parameters ! !! \htmlinclude module_radsw_parameters.html !! - use physparam, only : kind_phys + use machine, only : kind_phys implicit none ! diff --git a/physics/rrtmgp_aerosol_optics.F90 b/physics/rrtmgp_aerosol_optics.F90 index cf3f7deea..e23a19a15 100644 --- a/physics/rrtmgp_aerosol_optics.F90 +++ b/physics/rrtmgp_aerosol_optics.F90 @@ -24,20 +24,29 @@ module rrtmgp_aerosol_optics !! \section arg_table_rrtmgp_aerosol_optics_run !! \htmlinclude rrtmgp_aerosol_optics_run.html !! - subroutine rrtmgp_aerosol_optics_run(doSWrad, doLWrad, nCol, nLev, nDay, idxday, p_lev, & - p_lay, p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, & - aerodp, aerlw_tau, aerlw_ssa, aerlw_g, aersw_tau, aersw_ssa, aersw_g, errmsg, errflg ) + subroutine rrtmgp_aerosol_optics_run(doSWrad, doLWrad, nCol, nLev, nTracer, nTracerAer, & + nDay, idxday, p_lev, p_lay, p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, & + iaermdl, iaerflg, top_at_1, con_pi, con_rd, con_g, aerodp, errmsg, errflg ) ! Inputs logical, intent(in) :: & doSWrad, & ! Logical flag for shortwave radiation call - doLWrad ! Logical flag for longwave radiation call + doLWrad, & ! Logical flag for longwave radiation call + top_at_1 ! Logical flag for vertical grid direcetion integer, intent(in) :: & nCol, & ! Number of horizontal grid points nDay, & ! Number of daylit points - nLev ! Number of vertical layers - integer,dimension(:), intent(in) :: & - idxday ! Indices for daylit points. + nLev, & ! Number of vertical layers + nTracer, & ! Number of tracers + nTracerAer, & ! Number of aerosol tracers + iaermdl, & ! Aerosol model scheme flag + iaerflg ! Aerosol effects to include + integer,intent(in),dimension(:) :: & + idxday ! Indices for daylit points. + real(kind_phys),intent(in) :: & + con_pi, & ! Physical constant (pi) + con_rd, & ! Physical constant (gas constant for dry-air) + con_g ! Physical constant (gravitational constant) real(kind_phys), dimension(:), intent(in) :: & lon, & ! Longitude lat, & ! Latitude @@ -84,7 +93,7 @@ subroutine rrtmgp_aerosol_optics_run(doSWrad, doLWrad, nCol, nLev, nDay, idxday, ! Call module_radiation_aerosols::setaer(),to setup aerosols property profile call setaer(p_lev*0.01, p_lay*0.01, p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, nCol, nLev, & - nLev+1, .true., .true., aerosolssw2, aerosolslw, aerodp) + nLev+1, .true., .true., iaermdl, iaerflg, top_at_1, con_pi, con_rd, con_g, aerosolssw2, aerosolslw, aerodp, errflg, errmsg) ! Shortwave if (doSWrad .and. (nDay .gt. 0)) then diff --git a/physics/rrtmgp_aerosol_optics.meta b/physics/rrtmgp_aerosol_optics.meta index 6dbf9c73c..e2b81b192 100644 --- a/physics/rrtmgp_aerosol_optics.meta +++ b/physics/rrtmgp_aerosol_optics.meta @@ -21,6 +21,37 @@ dimensions = () type = logical intent = in +[top_at_1] + standard_name = flag_for_vertical_ordering_in_radiation + long_name = flag for vertical ordering in radiation + units = flag + dimensions = () + type = logical + intent = in +[con_pi] + standard_name = pi + long_name = ratio of a circle's circumference to its diameter + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rd] + standard_name = gas_constant_of_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in [ncol] standard_name = horizontal_loop_extent long_name = horizontal dimension @@ -129,6 +160,20 @@ type = real kind = kind_phys intent = in +[iaermdl] + standard_name = control_for_aerosol_radiation_scheme + long_name = control of aerosol scheme in radiation + units = 1 + dimensions = () + type = integer + intent = in +[iaerflg] + standard_name = control_for_aerosol_effects_in_radiation + long_name = control of aerosol effects in radiation + units = 1 + dimensions = () + type = integer + intent = in [aerodp] standard_name = atmosphere_optical_thickness_due_to_ambient_aerosol_particles long_name = vertical integrated optical depth for various aerosol species diff --git a/physics/set_soilveg.f b/physics/set_soilveg.f index efef0f24b..37f2c2a73 100644 --- a/physics/set_soilveg.f +++ b/physics/set_soilveg.f @@ -13,11 +13,13 @@ module set_soilveg_mod !> \ingroup Noah_LSM !! This subroutine initializes soil and vegetation. - subroutine set_soilveg(me,isot,ivet,nlunit) + subroutine set_soilveg(me,isot,ivet,nlunit,errmsg,errflg) use namelist_soilveg implicit none integer, intent(in) :: me,isot,ivet,nlunit + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg !my begin locals !for 20 igbp veg type and 19 stasgo soil type integer i @@ -385,16 +387,22 @@ subroutine set_soilveg(me,isot,ivet,nlunit) ! CLOSE(59) IF (DEFINED_SOIL .GT. MAX_SOILTYP) THEN - WRITE(0,*) 'Warning: DEFINED_SOIL too large in namelist' - STOP 222 + errflg = 222 + errmsg = 'ERROR(set_soilveg): DEFINED_SOIL too large in '// & + & 'namelist' + return ENDIF IF (DEFINED_VEG .GT. MAX_VEGTYP) THEN - WRITE(0,*) 'Warning: DEFINED_VEG too large in namelist' - STOP 222 + errflg = 222 + errmsg = 'ERROR(set_soilveg): DEFINED_VEG too large in '// & + & 'namelist' + return ENDIF IF (DEFINED_SLOPE .GT. MAX_SLOPETYP) THEN - WRITE(0,*) 'Warning: DEFINED_SLOPE too large in namelist' - STOP 222 + errflg = 222 + errmsg = 'ERROR(set_soilveg): DEFINED_SLOPE too large in '//& + & 'namelist' + return ENDIF SMLOW = SMLOW_DATA diff --git a/physics/set_soilveg_ruc.F90 b/physics/set_soilveg_ruc.F90 index cac4fd1e7..c03e6fc5f 100644 --- a/physics/set_soilveg_ruc.F90 +++ b/physics/set_soilveg_ruc.F90 @@ -17,9 +17,11 @@ module set_soilveg_ruc_mod !>\ingroup lsm_ruc_group !! This subroutine specifies vegetation and soil parameters for a given !! soil and land-use classification. - subroutine set_soilveg_ruc(me,isot,ivet,nlunit) + subroutine set_soilveg_ruc(me,isot,ivet,nlunit,errmsg,errflg) integer, intent(in) :: isot,ivet,nlunit + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg integer me integer i @@ -35,6 +37,10 @@ subroutine set_soilveg_ruc(me,isot,ivet,nlunit) & WLTSMC, QTZ, mosaic_soil, mosaic_lu, & & REFSMCnoah, WLTSMCnoah, MAXSMCnoah + ! Initialize error-handling + errflg = 0 + errmsg = '' + if(ivet.eq.2) then ! Using umd veg classification slope_data =(/0.1, 0.6, 1.0, 0.35, 0.55, 0.8, & @@ -415,15 +421,21 @@ subroutine set_soilveg_ruc(me,isot,ivet,nlunit) IF (DEFINED_SOIL .GT. MAX_SOILTYP) THEN WRITE(0,*) 'Warning: DEFINED_SOIL too large in namelist' - STOP 222 + errflg = 1 + errmsg = 'ERROR(set_soilveg_ruc): DEFINED_SOIL too large in namelist' + return ENDIF IF (DEFINED_VEG .GT. MAX_VEGTYP) THEN WRITE(0,*) 'Warning: DEFINED_VEG too large in namelist' - STOP 222 + errflg = 1 + errmsg = 'ERROR(set_soilveg_ruc): DEFINED_VEG too large in namelist' + return ENDIF IF (DEFINED_SLOPE .GT. MAX_SLOPETYP) THEN WRITE(0,*) 'Warning: DEFINED_SLOPE too large in namelist' - STOP 222 + errflg = 1 + errmsg = 'ERROR(set_soilveg_ruc): DEFINED_SLOPE too large in namelist' + return ENDIF ! if (me == 0) write(6,soil_veg_ruc) diff --git a/physics/sfc_diff.f b/physics/sfc_diff.f index 9bc7e6d0a..01294bb31 100644 --- a/physics/sfc_diff.f +++ b/physics/sfc_diff.f @@ -376,7 +376,9 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) call znot_t_v7(wind10m, ztmax_wat(i)) ! 10-m wind,m/s, ztmax(m) else if (sfc_z0_type > 0) then write(0,*)'no option for sfc_z0_type=',sfc_z0_type - stop + errflg = 1 + errmsg = 'ERROR(sfc_diff_run): no option for sfc_z0_type' + return endif ! call stability diff --git a/physics/sflx.f b/physics/sflx.f index a020e217a..92205dd61 100644 --- a/physics/sflx.f +++ b/physics/sflx.f @@ -123,7 +123,8 @@ subroutine gfssflx &! --- input & edir, et, ett, esnow, drip, dew, beta, etp, ssoil, & & flx1, flx2, flx3, runoff1, runoff2, runoff3, & & snomlt, sncovr, rc, pc, rsmin, xlai, rcs, rct, rcq, & - & rcsoil, soilw, soilm, smcwlt, smcdry, smcref, smcmax) + & rcsoil, soilw, soilm, smcwlt, smcdry, smcref, smcmax, & + & errmsg, errflg ) ! ===================================================================== ! ! description: ! @@ -327,6 +328,8 @@ subroutine gfssflx &! --- input & runoff1, runoff2, runoff3, rc, pc, rsmin, xlai, rcs, & & rct, rcq, rcsoil, soilw, soilm, smcwlt, smcdry, smcref, & & smcmax + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg ! --- locals: ! real (kind=kind_phys) :: df1h, @@ -346,6 +349,10 @@ subroutine gfssflx &! --- input ! !===> ... begin here ! +! Initialize CCPP error-handling + errflg = 0 + errmsg = '' + ! --- ... initialization runoff1 = 0.0 @@ -411,7 +418,7 @@ subroutine gfssflx &! --- input !> - Call redprm() to set the land-surface paramters, !! including soil-type and veg-type dependent parameters. - call redprm + call redprm(errmsg, errflg) if(ivegsrc == 1) then !only igbp type has urban !urban @@ -1668,7 +1675,7 @@ end subroutine penman !> This subroutine internally sets default values or optionally read-in !! via namelist i/o, all soil and vegetation parateters requied for the execusion !! of the Noah LSM. - subroutine redprm + subroutine redprm(errmsg, errflg) !................................... ! --- inputs: ! & ( nsoil, vegtyp, soiltyp, slopetyp, sldpth, zsoil, & @@ -1855,7 +1862,8 @@ subroutine redprm ! & frzx, psisat, slope, snup, salp, bexp, dksat, dwsat, & ! & smcmax, smcwlt, smcref, smcdry, f1, quartz, fxexp, z0, & ! & czil, xlai, csoil, rtdis(nsoil) - + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg ! integer, intent(out) :: nroot ! --- locals: @@ -1866,20 +1874,30 @@ subroutine redprm ! !===> ... begin here ! +! Initialize CCPP error-handling + errflg = 0 + errmsg = '' + if (soiltyp > defined_soil) then write(*,*) 'warning: too many soil types,soiltyp=',soiltyp, & & 'defined_soil=',defined_soil - stop 333 + errflg = 1 + errmsg = 'ERROR(sflx.f): too many soil types' + return endif if (vegtyp > defined_veg) then write(*,*) 'warning: too many veg types' - stop 333 + errflg = 1 + errmsg = 'ERROR(sflx.f): too many veg types' + return endif if (slopetyp > defined_slope) then write(*,*) 'warning: too many slope types' - stop 333 + errflg = 1 + errmsg = 'ERROR(sflx.f): too many slope types' + return endif ! --- ... set-up universal parameters (not dependent on soiltyp, vegtyp @@ -1936,7 +1954,9 @@ subroutine redprm if (nroot > nsoil) then write(*,*) 'warning: too many root layers' - stop 333 + errflg = 1 + errmsg = 'ERROR(sflx.f): too many root layers' + return endif ! --- ... calculate root distribution. present version assumes uniform From 944aae4476ead37d12fb5ab8e2dd488572a803b4 Mon Sep 17 00:00:00 2001 From: dustinswales Date: Wed, 8 Feb 2023 14:33:20 -0700 Subject: [PATCH 103/380] Cleanup from previous merge. --- physics/GFS_rrtmgp_pre.F90 | 1 - physics/rrtmgp_aerosol_optics.F90 | 9 ++++----- physics/rrtmgp_lw_main.meta | 4 ++-- physics/rrtmgp_sw_main.meta | 4 ++-- 4 files changed, 8 insertions(+), 10 deletions(-) diff --git a/physics/GFS_rrtmgp_pre.F90 b/physics/GFS_rrtmgp_pre.F90 index 02cc506fd..009eb8c38 100644 --- a/physics/GFS_rrtmgp_pre.F90 +++ b/physics/GFS_rrtmgp_pre.F90 @@ -124,7 +124,6 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, doSWrad, doLWrad, fhswr, fhl me, & ! MPI rank nCol, & ! Number of horizontal grid points nLev, & ! Number of vertical layers - nTracers, & ! Number of tracers from model. ico2, & ! Flag for co2 radiation scheme i_o3 ! Index into tracer array for ozone logical, intent(in) :: & diff --git a/physics/rrtmgp_aerosol_optics.F90 b/physics/rrtmgp_aerosol_optics.F90 index e23a19a15..ce0fa8ea9 100644 --- a/physics/rrtmgp_aerosol_optics.F90 +++ b/physics/rrtmgp_aerosol_optics.F90 @@ -24,9 +24,10 @@ module rrtmgp_aerosol_optics !! \section arg_table_rrtmgp_aerosol_optics_run !! \htmlinclude rrtmgp_aerosol_optics_run.html !! - subroutine rrtmgp_aerosol_optics_run(doSWrad, doLWrad, nCol, nLev, nTracer, nTracerAer, & - nDay, idxday, p_lev, p_lay, p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, & - iaermdl, iaerflg, top_at_1, con_pi, con_rd, con_g, aerodp, errmsg, errflg ) + subroutine rrtmgp_aerosol_optics_run(doSWrad, doLWrad, nCol, nLev, nDay, idxday, p_lev, & + p_lay, p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, iaermdl, iaerflg, & + top_at_1, con_pi, con_rd, con_g, aerodp, aerlw_tau, aerlw_ssa, aerlw_g, aersw_tau, & + aersw_ssa, aersw_g, errmsg, errflg ) ! Inputs logical, intent(in) :: & @@ -37,8 +38,6 @@ subroutine rrtmgp_aerosol_optics_run(doSWrad, doLWrad, nCol, nLev, nTracer, nTra nCol, & ! Number of horizontal grid points nDay, & ! Number of daylit points nLev, & ! Number of vertical layers - nTracer, & ! Number of tracers - nTracerAer, & ! Number of aerosol tracers iaermdl, & ! Aerosol model scheme flag iaerflg ! Aerosol effects to include integer,intent(in),dimension(:) :: & diff --git a/physics/rrtmgp_lw_main.meta b/physics/rrtmgp_lw_main.meta index a1a384b25..fd96eb14b 100644 --- a/physics/rrtmgp_lw_main.meta +++ b/physics/rrtmgp_lw_main.meta @@ -149,8 +149,8 @@ type = logical intent = in [top_at_1] - standard_name = flag_for_vertical_ordering_in_RRTMGP - long_name = flag for vertical ordering in RRTMGP + standard_name = flag_for_vertical_ordering_in_radiation + long_name = flag for vertical ordering in radiaiton units = flag dimensions = () type = logical diff --git a/physics/rrtmgp_sw_main.meta b/physics/rrtmgp_sw_main.meta index 4ca6cc716..dbb93a5df 100644 --- a/physics/rrtmgp_sw_main.meta +++ b/physics/rrtmgp_sw_main.meta @@ -149,8 +149,8 @@ type = logical intent = in [top_at_1] - standard_name = flag_for_vertical_ordering_in_RRTMGP - long_name = flag for vertical ordering in RRTMGP + standard_name = flag_for_vertical_ordering_in_radiation + long_name = flag for vertical ordering in radiation units = flag dimensions = () type = logical From 6760693df8390074a8d6c64c2a0ae330e7bb0dbf Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Mon, 30 Jan 2023 09:24:50 -0500 Subject: [PATCH 104/380] Merge pull request #35 from ChunxiZhang-NOAA/bugfix/cloud_rad Bug fix for cloud effective radius for convective clouds (HR1) --- physics/radiation_clouds.f | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index 81a845fd2..ca9ea6e81 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -2127,10 +2127,16 @@ subroutine progcld_thompson_wsm6 & !> The total condensate includes convective condensate. do k = 1, NLAY-1 do i = 1, IX - cwp(i,k) = max(0.0, (clw(i,k,ntcw)+cnvw(i,k)* - & (1.-tem2d(i,k))) * gfac * delp(i,k)) - cip(i,k) = max(0.0, (clw(i,k,ntiw) + cnvw(i,k)* - & tem2d(i,k)) *gfac * delp(i,k)) + tem1 = cnvw(i,k)*(1.-tem2d(i,k)) + cwp(i,k) = max(0.0, (clw(i,k,ntcw)+tem1) * + & gfac * delp(i,k)) + if(tem1 > 1.e-12 .and. clw(i,k,ntcw) < 1.e-12) + & rew(i,k)=reliq_def + tem2 = cnvw(i,k)*tem2d(i,k) + cip(i,k) = max(0.0, (clw(i,k,ntiw) + tem2 ) + & *gfac * delp(i,k)) + if(tem2 > 1.e-12 .and. clw(i,k,ntiw) < 1.e-12) + & rei(i,k)=reice_def crp(i,k) = max(0.0, clw(i,k,ntrw) * gfac * delp(i,k)) csp(i,k) = max(0.0, clw(i,k,ntsw) * gfac * delp(i,k)) enddo From 989ed53a0af5352afc97803acfbf71b727cb9c91 Mon Sep 17 00:00:00 2001 From: drnimbusrain Date: Thu, 9 Feb 2023 15:45:45 -0500 Subject: [PATCH 105/380] Added lai and vegtype to the meta --- physics/satmedmfvdifq.F | 13 ++++++------- physics/satmedmfvdifq.meta | 17 ++++++++++++----- 2 files changed, 18 insertions(+), 12 deletions(-) diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index edf66d094..0c1b0bc74 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -9,6 +9,7 @@ module satmedmfvdifq use mfscuq_mod !PCC_CANOPY use canopy_utils_mod + use noahmp_tables, only : hvt_table contains @@ -80,7 +81,7 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & & kinver,xkzm_m,xkzm_h,xkzm_s,dspfac,bl_upfr,bl_dnfr, & & rlmx,elmx,sfc_rlm, & !PCC_CANOPY------------------------------------ - & canheight, & + & vegtype, lai & !---------------------------------------------- & ntqv,dtend,dtidx,index_of_temperature,index_of_x_wind, & & index_of_y_wind,index_of_process_pbl,gen_tend,ldiag3d, & @@ -105,7 +106,7 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & real(kind=kind_phys), intent(in) :: dspfac, bl_upfr, bl_dnfr real(kind=kind_phys), intent(in) :: rlmx, elmx !PCC_CANOPY------------------------------------ - real(kind=kind_phys), intent(in) :: canheight(:) + real(kind=kind_phys), intent(in) :: vegtype(:), lai(:) !---------------------------------------------- real(kind=kind_phys), intent(inout) :: dv(:,:), du(:,:), & & tdt(:,:), rtg(:,:,:), tmf(:,:) @@ -1215,13 +1216,11 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & !PCC_CANOPY------------------------------------ do k = 1, 1km1 do i=1,im - FCH = canheight(i) !Input canopy height for grid cell i + FCH = hvt_table(vegtype) !top of canopy (m) IF (k .EQ. 1) THEN !first model layer ! Check for Contiguous Canopy Grid Cells - IF ( FCH .LT. 0.5 -! IF ( LAI .LT. 0.1 -! & .OR. FCH .LT. 0.5 -! & .OR. FCH .LT. 10.0 + IF ( lai(i) .LT. 0.1 + & .OR. FCH .LT. 0.5 ) ! & .OR. MAX(0.0, 1.0 - FRT) .GT. 0.5 ! & .OR. POPU .GT. 10000.0 ! & .OR. EXP(-0.5*LAI*CLU).GT. 0.45 diff --git a/physics/satmedmfvdifq.meta b/physics/satmedmfvdifq.meta index 8a41e39e3..95491d1f7 100644 --- a/physics/satmedmfvdifq.meta +++ b/physics/satmedmfvdifq.meta @@ -581,11 +581,18 @@ type = real kind = kind_phys intent = in -[canheight] - standard_name = forest_canopy_height - long_name = forest canopy height above ground - units = m - dimensions = () +[vegtype] + standard_name = vegetation_type_classification + long_name = vegetation type at each grid cell + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[lai] + standard_name = leaf_area_index + long_name = leaf area index + units = none + dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in From 99ba7571aab79ea927ac42b13ac3dc3c1645efaf Mon Sep 17 00:00:00 2001 From: drnimbusrain Date: Thu, 9 Feb 2023 15:51:17 -0500 Subject: [PATCH 106/380] Fixed bugs. --- physics/satmedmfvdifq.F | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index 0c1b0bc74..6001650d1 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -1216,7 +1216,7 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & !PCC_CANOPY------------------------------------ do k = 1, 1km1 do i=1,im - FCH = hvt_table(vegtype) !top of canopy (m) + FCH = hvt_table(vegtype(i)) !top of canopy (m) IF (k .EQ. 1) THEN !first model layer ! Check for Contiguous Canopy Grid Cells IF ( lai(i) .LT. 0.1 @@ -1297,7 +1297,7 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & EDDYVEST_INT = IntegrateTrapezoid((ZCANX(COUNTCAN:1:-1)/FCH),EDDYVESTX(COUNTCAN:1:-1)) dkt(i,k)= (dkt(i,k)/EDDYVEST1) * EDDYVEST_INT !Scale dkt to resolved eddy diffusivity dkq(i,k)= (dkq(i,k)/EDDYVEST1) * EDDYVEST_INT !Scale dkq to resolved eddy diffusivity - dku(i,k)= (dkq(i,k)/EDDYVEST1) * EDDYVEST_INT !Scale dku to resolved eddy diffusivity + dku(i,k)= (dku(i,k)/EDDYVEST1) * EDDYVEST_INT !Scale dku to resolved eddy diffusivity END IF !contigous canopy conditions END IF ! first model layer scaled canopy enddo !i From 59cc88e9177e872639acc0397941f32c334faa73 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Fri, 10 Feb 2023 00:59:10 +0000 Subject: [PATCH 107/380] wrong vars & units --- physics/maximum_hourly_diagnostics.F90 | 26 +++++++++++--------- physics/maximum_hourly_diagnostics.meta | 32 +++++++++++++++++++++---- 2 files changed, 43 insertions(+), 15 deletions(-) diff --git a/physics/maximum_hourly_diagnostics.F90 b/physics/maximum_hourly_diagnostics.F90 index 08f793aad..19f110767 100644 --- a/physics/maximum_hourly_diagnostics.F90 +++ b/physics/maximum_hourly_diagnostics.F90 @@ -30,8 +30,8 @@ subroutine maximum_hourly_diagnostics_run(im, levs, reset, lradar, imp_physics, u10max, v10max, spd10max, pgr, t2m, q2m, t02max, & t02min, rh02max, rh02min, dtp, rain, pratemax, & lightning_threat, ltg1_max,ltg2_max,ltg3_max, & - wgrs, phii, qgraupel, qsnowwat, qicewat, & - kdt, errmsg, errflg) + wgrs, prsi, qgraupel, qsnowwat, qicewat, tgrs, con_rd,& + prsl, kdt, errmsg, errflg) ! Interface variables integer, intent(in) :: im, levs, kdt @@ -39,6 +39,7 @@ subroutine maximum_hourly_diagnostics_run(im, levs, reset, lradar, imp_physics, integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_fer_hires, & imp_physics_nssl real(kind_phys), intent(in ) :: con_g + real(kind_phys), intent(in ) :: con_rd real(kind_phys), intent(in ) :: phil(:,:) real(kind_phys), intent(in ) :: gt0(:,:) real(kind_phys), intent(in ) :: refl_10cm(:,:) @@ -58,9 +59,11 @@ subroutine maximum_hourly_diagnostics_run(im, levs, reset, lradar, imp_physics, real(kind_phys), intent(inout) :: rh02min(:) real(kind_phys), intent(in ) :: dtp real(kind_phys), intent(in ) :: rain(:) + real(kind_phys), intent(in ) :: tgrs(:,:) + real(kind_phys), intent(in ) :: prsl(:,:) real(kind_phys), intent(inout) :: pratemax(:) - real(kind_phys), intent(in), dimension(:,:) :: phii, qgraupel, qsnowwat, qicewat, wgrs + real(kind_phys), intent(in), dimension(:,:) :: prsi, qgraupel, qsnowwat, qicewat, wgrs real(kind_phys), intent(inout), dimension(:) :: ltg1_max, ltg2_max, ltg3_max character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -161,7 +164,7 @@ subroutine lightning_threat_indices REAL(kind_phys), PARAMETER :: coef1=0.042*1000.*1.22 REAL(kind_phys), PARAMETER :: coef2=0.20*1.22 - REAL(kind_phys) :: totice_colint(im), msft(im), ltg1, ltg2, high_ltg1, high_wgrs, high_graupel + REAL(kind_phys) :: totice_colint(im), msft(im), ltg1, ltg2, high_ltg1, high_wgrs, high_graupel, rho LOGICAL :: ltg1_calc(im) integer :: k, i, count @@ -175,19 +178,20 @@ subroutine lightning_threat_indices msft = 1. ! get area (m^2) in units of km^2 ! msft = 1.E-6*area - do k=2,levs + do k=1,levs-1 do i=1,im - dP = phii(i,k+1) - phii(i,k) + dP = prsi(i,k) - prsi(i,k+1) Q = qgraupel(i,k) + qsnowwat(i,k) + qicewat(i,k) - totice_colint(i) = totice_colint(i) + Q * dP / con_g + rho = prsl(i,k) / (con_rd * tgrs(i,k)) + totice_colint(i) = totice_colint(i) + Q * rho * dP / con_g IF ( .not.ltg1_calc(i) ) THEN - IF ( 0.5*(phii(i,k-1) - phii(i,k+1)) < 258.15 ) THEN + IF ( 0.5*(tgrs(i,k+1) + tgrs(i,k)) < 258.15 ) THEN count = count + 1 ltg1_calc(i) = .true. ltg1 = coef1*wgrs(i,k)* & - (( qgraupel(i,k-1) + qgraupel(i,k) )*0.5 )/msft(i) + (( qgraupel(i,k+1) + qgraupel(i,k) )*0.5 )/msft(i) high_ltg1 = max(high_ltg1, ltg1) high_graupel = max(high_graupel, qgraupel(i,k)) if(abs(wgrs(i,k)) > high_wgrs) then @@ -205,8 +209,8 @@ subroutine lightning_threat_indices enddo if(count > 0) then - if(abs(high_wgrs) < 0.1 .or. high_graupel < 1e-4) then - !print *, 'low wgrs or graupel' + if(high_ltg1 < .01 .and. (abs(high_wgrs) < 0.1 .or. high_graupel < 1e-4)) then + ! Nothing to look at else 183 format('high_ltg1 = ',F30.23,' high_wgrs = ',F30.23,' high_graupel = ',F30.23) print 183, high_ltg1, high_wgrs, high_graupel diff --git a/physics/maximum_hourly_diagnostics.meta b/physics/maximum_hourly_diagnostics.meta index 107281a48..98d30dc19 100644 --- a/physics/maximum_hourly_diagnostics.meta +++ b/physics/maximum_hourly_diagnostics.meta @@ -270,6 +270,22 @@ type = real kind = kind_phys intent = in +[con_rd] + standard_name = gas_constant_of_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[tgrs] + standard_name = air_temperature + long_name = model layer mean temperature + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in [lightning_threat] standard_name = lightning_threat_indices_enabled long_name = lightning threat indices enabled @@ -301,14 +317,22 @@ type = real kind = kind_phys intent = inout -[phii] - standard_name = geopotential_at_interface - long_name = geopotential at model layer interfaces - units = m2 s-2 +[prsi] + standard_name = air_pressure_at_interface + long_name = air pressure at model layer interfaces + units = Pa dimensions = (horizontal_loop_extent,vertical_interface_dimension) type = real kind = kind_phys intent = in +[prsl] + standard_name = air_pressure + long_name = mean layer pressure + units = Pa + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in [kdt] standard_name = index_of_timestep long_name = current forecast iteration From de1c0b44a0eeed9ab153ad93b980c8e0ff0593fc Mon Sep 17 00:00:00 2001 From: drnimbusrain Date: Fri, 10 Feb 2023 12:08:39 -0500 Subject: [PATCH 108/380] Added canopy_utils_mod and noahmp_tables to satmedmfvdifq meta dependencies. --- physics/satmedmfvdifq.meta | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/satmedmfvdifq.meta b/physics/satmedmfvdifq.meta index 95491d1f7..6f2178c18 100644 --- a/physics/satmedmfvdifq.meta +++ b/physics/satmedmfvdifq.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = satmedmfvdifq type = scheme - dependencies = funcphys.f90,machine.F,mfpbltq.f,mfscuq.f,tridi.f + dependencies = funcphys.f90,machine.F,mfpbltq.f,mfscuq.f,tridi.f,canopy_utils_mod.f,noahmp_tables.f90 ######################################################################## [ccpp-arg-table] From 90762fb7cca794c3dae6893f6002b3687e739c6d Mon Sep 17 00:00:00 2001 From: drnimbusrain Date: Fri, 10 Feb 2023 12:40:59 -0500 Subject: [PATCH 109/380] Changed some comments. --- physics/satmedmfvdifq.F | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index 6001650d1..77ba03c20 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -1216,10 +1216,12 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & !PCC_CANOPY------------------------------------ do k = 1, 1km1 do i=1,im - FCH = hvt_table(vegtype(i)) !top of canopy (m) + FCH = hvt_table(vegtype(i)) !top of canopy + !(m) from + !Noah-MP LSM tables IF (k .EQ. 1) THEN !first model layer ! Check for Contiguous Canopy Grid Cells - IF ( lai(i) .LT. 0.1 + IF ( lai(i) .LT. 0.1 !from LSM & .OR. FCH .LT. 0.5 ) ! & .OR. MAX(0.0, 1.0 - FRT) .GT. 0.5 ! & .OR. POPU .GT. 10000.0 From 07bafc08512f9226f0f43d27ddb9ca5f0e9942b4 Mon Sep 17 00:00:00 2001 From: drnimbusrain Date: Fri, 10 Feb 2023 13:00:11 -0500 Subject: [PATCH 110/380] Fixed IF statement bug in canopy conditions. --- physics/satmedmfvdifq.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index 77ba03c20..d3d3699f2 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -1222,7 +1222,7 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & IF (k .EQ. 1) THEN !first model layer ! Check for Contiguous Canopy Grid Cells IF ( lai(i) .LT. 0.1 !from LSM - & .OR. FCH .LT. 0.5 ) + & .OR. FCH .LT. 0.5 ) THEN ! & .OR. MAX(0.0, 1.0 - FRT) .GT. 0.5 ! & .OR. POPU .GT. 10000.0 ! & .OR. EXP(-0.5*LAI*CLU).GT. 0.45 From 1a9d3d2e2522ef6d6b3697be6d1aeee3521a2cd7 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Fri, 10 Feb 2023 18:43:06 +0000 Subject: [PATCH 111/380] remove msft and tweak print statements --- physics/maximum_hourly_diagnostics.F90 | 23 ++++++++++++----------- 1 file changed, 12 insertions(+), 11 deletions(-) diff --git a/physics/maximum_hourly_diagnostics.F90 b/physics/maximum_hourly_diagnostics.F90 index 19f110767..969af8dcd 100644 --- a/physics/maximum_hourly_diagnostics.F90 +++ b/physics/maximum_hourly_diagnostics.F90 @@ -164,7 +164,7 @@ subroutine lightning_threat_indices REAL(kind_phys), PARAMETER :: coef1=0.042*1000.*1.22 REAL(kind_phys), PARAMETER :: coef2=0.20*1.22 - REAL(kind_phys) :: totice_colint(im), msft(im), ltg1, ltg2, high_ltg1, high_wgrs, high_graupel, rho + REAL(kind_phys) :: totice_colint(im), ltg1, ltg2, high_ltg1, high_wgrs, high_graupel, rho LOGICAL :: ltg1_calc(im) integer :: k, i, count @@ -175,9 +175,6 @@ subroutine lightning_threat_indices totice_colint = 0 ltg1_calc = .false. - msft = 1. - ! get area (m^2) in units of km^2 - ! msft = 1.E-6*area do k=1,levs-1 do i=1,im dP = prsi(i,k) - prsi(i,k+1) @@ -191,11 +188,15 @@ subroutine lightning_threat_indices ltg1_calc(i) = .true. ltg1 = coef1*wgrs(i,k)* & - (( qgraupel(i,k+1) + qgraupel(i,k) )*0.5 )/msft(i) - high_ltg1 = max(high_ltg1, ltg1) - high_graupel = max(high_graupel, qgraupel(i,k)) - if(abs(wgrs(i,k)) > high_wgrs) then - high_wgrs = wgrs(i,k) + (( qgraupel(i,k+1) + qgraupel(i,k) )*0.5 ) + if(ltg1 > 0.01) then +184 format('Found ltg1=',F20.13,' with w=',F20.13,' Qg=',F20.13) + print 184, ltg1, wgrs(i,k), ( qgraupel(i,k+1) + qgraupel(i,k) )*0.5 + endif + if(ltg1 > high_ltg1) then + high_ltg1 = ltg1 + high_graupel = qgraupel(i,k) + high_wgrs = wgrs(i,k) endif IF ( ltg1 .LT. clim1 ) ltg1 = 0. @@ -212,13 +213,13 @@ subroutine lightning_threat_indices if(high_ltg1 < .01 .and. (abs(high_wgrs) < 0.1 .or. high_graupel < 1e-4)) then ! Nothing to look at else -183 format('high_ltg1 = ',F30.23,' high_wgrs = ',F30.23,' high_graupel = ',F30.23) +183 format('Max ltg1=',F20.13,' has w=',F20.13,' Qg=',F20.13) print 183, high_ltg1, high_wgrs, high_graupel endif endif do i=1,im - ltg2 = coef2 * totice_colint(i) / msft(i) + ltg2 = coef2 * totice_colint(i) IF ( ltg2 .LT. clim2 ) ltg2 = 0. From 6b686e537a37575e72e2b62334dbbe8d3728fba6 Mon Sep 17 00:00:00 2001 From: drnimbusrain Date: Fri, 10 Feb 2023 14:04:24 -0500 Subject: [PATCH 112/380] Fixed bug in canopy variable inputs. --- physics/satmedmfvdifq.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index d3d3699f2..8b2a5ce56 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -81,7 +81,7 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & & kinver,xkzm_m,xkzm_h,xkzm_s,dspfac,bl_upfr,bl_dnfr, & & rlmx,elmx,sfc_rlm, & !PCC_CANOPY------------------------------------ - & vegtype, lai & + & vegtype, lai, & !---------------------------------------------- & ntqv,dtend,dtidx,index_of_temperature,index_of_x_wind, & & index_of_y_wind,index_of_process_pbl,gen_tend,ldiag3d, & From 8122173328edaeb32bd9a7ccbdf9dcbbee5ab525 Mon Sep 17 00:00:00 2001 From: drnimbusrain Date: Sat, 11 Feb 2023 23:09:56 -0500 Subject: [PATCH 113/380] Updated bugs. --- physics/satmedmfvdifq.F | 48 ++++++++++++++++++++++------------------- 1 file changed, 26 insertions(+), 22 deletions(-) diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index 38d5dd6ea..352784393 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -86,9 +86,7 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & & dspheat,dusfc,dvsfc,dtsfc,dqsfc,hpbl,dkt,dku, & & kinver,xkzm_m,xkzm_h,xkzm_s,dspfac,bl_upfr,bl_dnfr, & & rlmx,elmx,sfc_rlm,tc_pbl, & - !PCC_CANOPY------------------------------------ & vegtype, lai, & - !---------------------------------------------- & ntqv,dtend,dtidx,index_of_temperature,index_of_x_wind, & & index_of_y_wind,index_of_process_pbl,gen_tend,ldiag3d, & & errmsg,errflg) @@ -262,14 +260,14 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & real(kind=kind_phys) bfac, mffac - !PCC_CANOPY------------------------------------ +!PCC_CANOPY------------------------------------ integer COUNTCAN real(kind=kind_phys) FCH, MOL, HOL, & SIGMACAN, RRCAN, BBCAN & AACAN, ZCAN, EDDYVEST1, & ZCANX, EDDVESTX, & EDDYVEST_INT - !---------------------------------------------- +!---------------------------------------------- !! parameter(bfac=100.) parameter(wfac=7.0,cfac=4.5) @@ -291,9 +289,9 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & parameter(ck1=0.15,ch1=0.15) parameter(cs0=0.2) parameter(rchck=1.5,ndt=20) - !PCC_CANOPY------------------------------------ +!PCC_CANOPY------------------------------------ parameter (PICAN = 3.1415927) - !---------------------------------------------- +!---------------------------------------------- if (tc_pbl == 0) then ck0 = 0.4 @@ -304,7 +302,6 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & ch0 = 0.55 ce0 = 0.12 endif ->>>>>>> origin/develop gravi = 1.0 / grav g = grav gocp = g / cp @@ -1296,10 +1293,9 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & enddo !PCC_CANOPY------------------------------------ do k = 1, 1km1 - do i=1,im - FCH = hvt_table(vegtype(i)) !top of canopy - !(m) from - !Noah-MP LSM tables + do i = 1, im + FCH = hvt_table(vegtype(i)) !top of canopy + IF (k .EQ. 1) THEN !first model layer ! Check for Contiguous Canopy Grid Cells IF ( lai(i) .LT. 0.1 !from LSM @@ -1307,7 +1303,8 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & ! & .OR. MAX(0.0, 1.0 - FRT) .GT. 0.5 ! & .OR. POPU .GT. 10000.0 ! & .OR. EXP(-0.5*LAI*CLU).GT. 0.45 -! & .AND. FCH .LT. 18.0 ) THEN !not a contigous canopy cell +! & .AND. FCH .LT. 18.0 ) THEN +! not a contigous canopy cell dkt(i,k)= dkt(i,k) dkq(i,k)= dkq(i,k) dku(i,k)= dku(i,k) @@ -1330,9 +1327,11 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & IF ( ZCAN/FCH .GT. 1.25 ) THEN !SIGMACAN = Eulerian vertical velocity variance SIGMACAN = 1.25*ustar(i) END IF - IF ( ZCAN/FCH .GE. 0.175 .AND. ZCAN/FCH .LE. 1.25 ) THEN - SIGMACAN = ustar(i) * ( 0.75 + (0.5 * COS((PICAN/1.06818) * - & (1.25 - (ZCAN/FCH)))) ) + IF ( ZCAN/FCH .GE. 0.175 + & .AND. ZCAN/FCH .LE. 1.25 ) THEN + SIGMACAN = ustar(i) * ( 0.75 + + & (0.5 * COS((PICAN/1.06818) * + & (1.25 - (ZCAN/FCH)))) ) END IF IF ( ZCAN/FCH .LT. 0.175 ) THEN SIGMACAN = 0.25*ustar(i) @@ -1342,9 +1341,11 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & IF ( ZCAN/FCH .GT. 1.25 ) THEN SIGMACAN = 1.0*ustar(i) END IF - IF ( ZCAN/FCH .GE. 0.175 .AND. ZCAN/FCH .LE. 1.25 ) THEN - SIGMACAN = ustar(i) * ( 0.625 + (0.375* COS((PICAN/1.06818) * - & (1.25 - (ZCAN/FCH)))) ) + IF ( ZCAN/FCH .GE. 0.175 + & .AND. ZCAN/FCH .LE. 1.25 ) THEN + SIGMACAN = ustar(i) * ( 0.625 + + & (0.375* COS((PICAN/1.06818) * + & (1.25 - (ZCAN/FCH)))) ) END IF IF ( ZCAN/FCH .LT. 0.175 ) THEN SIGMACAN = 0.25*ustar(i) @@ -1354,12 +1355,14 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & IF ( ZCAN/FCH .GT. 1.25 ) THEN SIGMACAN = 0.25*(4.375 - (3.75*HOL))*ustar(i) END IF - IF ( ZCAN/FCH .GE. 0.175 .AND. ZCAN/FCH .LE. 1.25 ) THEN + IF ( ZCAN/FCH .GE. 0.175 i + & .AND. ZCAN/FCH .LE. 1.25 ) THEN RRCAN=4.375-(3.75*HOL) AACAN=(0.125*RRCAN) + 0.125 BBCAN=(0.125*RRCAN) - 0.125 - SIGMACAN = ustar(i) * ( AACAN + (BBCAN * COS((PICAN/1.06818) * - & (1.25 - (ZCAN/FCH)))) ) + SIGMACAN = ustar(i) * ( AACAN + + & (BBCAN * COS((PICAN/1.06818) * + & (1.25 - (ZCAN/FCH)))) ) END IF IF ( ZCAN/FCH .LT. 0.175 ) THEN SIGMACAN = 0.25*ustar(i) @@ -1377,7 +1380,8 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & END IF ZCAN = ZCAN-0.5 !step down in-canopy resolution of 0.5m END DO !end loop on canopy layers - EDDYVEST_INT = IntegrateTrapezoid((ZCANX(COUNTCAN:1:-1)/FCH),EDDYVESTX(COUNTCAN:1:-1)) + EDDYVEST_INT = IntegrateTrapezoid((ZCANX(COUNTCAN:1:-1) + & /FCH),EDDYVESTX(COUNTCAN:1:-1)) dkt(i,k)= (dkt(i,k)/EDDYVEST1) * EDDYVEST_INT !Scale dkt to resolved eddy diffusivity dkq(i,k)= (dkq(i,k)/EDDYVEST1) * EDDYVEST_INT !Scale dkq to resolved eddy diffusivity dku(i,k)= (dku(i,k)/EDDYVEST1) * EDDYVEST_INT !Scale dku to resolved eddy diffusivity From f99c2bb720b83205461812c346bd39e31c43c2bd Mon Sep 17 00:00:00 2001 From: drnimbusrain Date: Sun, 12 Feb 2023 10:41:39 -0500 Subject: [PATCH 114/380] Fixed bugs (again...). --- physics/satmedmfvdifq.F | 37 +++++++++++++++++++++++++++++-------- 1 file changed, 29 insertions(+), 8 deletions(-) diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index 352784393..61f040cff 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -111,7 +111,8 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & real(kind=kind_phys), intent(in) :: dspfac, bl_upfr, bl_dnfr real(kind=kind_phys), intent(in) :: rlmx, elmx !PCC_CANOPY------------------------------------ - real(kind=kind_phys), intent(in) :: vegtype(:), lai(:) + integer, intent(in) :: vegtype(:) + real(kind=kind_phys), intent(in) :: lai(:) !---------------------------------------------- real(kind=kind_phys), intent(inout) :: dv(:,:), du(:,:), & & tdt(:,:), rtg(:,:,:), tmf(:,:) @@ -254,6 +255,10 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & ! real(kind=kind_phys) ck0, ck1, ch0, ch1, ce0, rchck ! +!PCC_CANOPY------------------------------------ + real(kind=kind_phys) PICAN +!---------------------------------------------- + real(kind=kind_phys) qlcr, zstblmax, hcrinv ! real(kind=kind_phys) h1 @@ -262,12 +267,20 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & !PCC_CANOPY------------------------------------ integer COUNTCAN - real(kind=kind_phys) FCH, MOL, HOL, - & SIGMACAN, RRCAN, BBCAN - & AACAN, ZCAN, EDDYVEST1, - & ZCANX, EDDVESTX, - & EDDYVEST_INT + real(kind=kind_phys) FCH, MOL, HOL, TLCAN, + & SIGMACAN, RRCAN, BBCAN, + & AACAN, ZCAN, ZFL, + & EDDYVEST1, EDDYVEST_INT + + ! in canopy eddy diffusivity [ m**2/s ] + real(kind=kind_phys), allocatable :: EDDYVESTX ( : ) + ! in canopy layer [m] + real(kind=kind_phys), allocatable :: ZCANX ( : ) + ! Declare local maximum canopy layers + integer, parameter :: MAXCAN = 1000 + !---------------------------------------------- + !! parameter(bfac=100.) parameter(wfac=7.0,cfac=4.5) @@ -293,6 +306,13 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & parameter (PICAN = 3.1415927) !---------------------------------------------- +!PCC_CANOPY------------------------------------ + if(.not.allocated(EDDYVESTX)) + & allocate( EDDYVESTX ( MAXCAN ) ) + if(.not.allocated(ZCANX)) + & allocate( ZCANX ( MAXCAN ) ) +!---------------------------------------------- + if (tc_pbl == 0) then ck0 = 0.4 ch0 = 0.4 @@ -1292,7 +1312,7 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & enddo enddo !PCC_CANOPY------------------------------------ - do k = 1, 1km1 + do k = 1, km1 do i = 1, im FCH = hvt_table(vegtype(i)) !top of canopy @@ -1317,6 +1337,7 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & MOL = zol(i)/zl(i,k) !Monin-Obukhov Length HOL = FCH/MOL !local canopy stability parameter (hc/MOL) ZCAN = zl(i,k) ! Initialize canopy top (m) = First model layer height above canopy + ZFL = ZCAN ! Set ZFL = ZCAN COUNTCAN = 0 ! Initialize canopy layers DO WHILE (ZCAN.GE.0.5) !canopy threshold >= 0.5 m ! TLCAN = Lagrangian timescale @@ -1355,7 +1376,7 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & IF ( ZCAN/FCH .GT. 1.25 ) THEN SIGMACAN = 0.25*(4.375 - (3.75*HOL))*ustar(i) END IF - IF ( ZCAN/FCH .GE. 0.175 i + IF ( ZCAN/FCH .GE. 0.175 & .AND. ZCAN/FCH .LE. 1.25 ) THEN RRCAN=4.375-(3.75*HOL) AACAN=(0.125*RRCAN) + 0.125 From bc083e716c2b00d894bc197dfb0cb4b85262de31 Mon Sep 17 00:00:00 2001 From: Michael Toy Date: Mon, 13 Feb 2023 18:43:22 +0000 Subject: [PATCH 115/380] Changed UGWP diagnostic variable declaration intents from 'out' to 'inout' --- physics/drag_suite.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/drag_suite.F90 b/physics/drag_suite.F90 index ed1571622..e082379e0 100644 --- a/physics/drag_suite.F90 +++ b/physics/drag_suite.F90 @@ -377,12 +377,12 @@ subroutine drag_suite_run( & real(kind=kind_phys), intent(inout) :: & & dusfc(:), dvsfc(:) !Output (optional): - real(kind=kind_phys), intent(out) :: & + real(kind=kind_phys), intent(inout) :: & & dusfc_ms(:),dvsfc_ms(:), & & dusfc_bl(:),dvsfc_bl(:), & & dusfc_ss(:),dvsfc_ss(:), & & dusfc_fd(:),dvsfc_fd(:) - real(kind=kind_phys), intent(out) :: & + real(kind=kind_phys), intent(inout) :: & & dtaux2d_ms(:,:),dtauy2d_ms(:,:), & & dtaux2d_bl(:,:),dtauy2d_bl(:,:), & & dtaux2d_ss(:,:),dtauy2d_ss(:,:), & From 3a386379e6ea99426f30203098dafa4bcbe5a5ae Mon Sep 17 00:00:00 2001 From: Michael Toy Date: Tue, 14 Feb 2023 15:42:24 +0000 Subject: [PATCH 116/380] Updated UGWP diagnostic variable declaration intents in drag_suite.meta --- physics/drag_suite.meta | 32 ++++++++++++++++---------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/physics/drag_suite.meta b/physics/drag_suite.meta index 8f33fcc60..ff60290ae 100644 --- a/physics/drag_suite.meta +++ b/physics/drag_suite.meta @@ -277,7 +277,7 @@ dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys - intent = out + intent = inout [dtauy2d_ms] standard_name = tendency_of_y_wind_due_to_mesoscale_orographic_gravity_wave_drag long_name = y wind tendency from mesoscale gwd @@ -285,7 +285,7 @@ dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys - intent = out + intent = inout [dtaux2d_bl] standard_name = tendency_of_x_wind_due_to_blocking_drag long_name = x wind tendency from blocking drag @@ -293,7 +293,7 @@ dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys - intent = out + intent = inout [dtauy2d_bl] standard_name = tendency_of_y_wind_due_to_blocking_drag long_name = y wind tendency from blocking drag @@ -301,7 +301,7 @@ dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys - intent = out + intent = inout [dtaux2d_ss] standard_name = tendency_of_x_wind_due_to_small_scale_gravity_wave_drag long_name = x wind tendency from small scale gwd @@ -309,7 +309,7 @@ dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys - intent = out + intent = inout [dtauy2d_ss] standard_name = tendency_of_y_wind_due_to_small_scale_gravity_wave_drag long_name = y wind tendency from small scale gwd @@ -317,7 +317,7 @@ dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys - intent = out + intent = inout [dtaux2d_fd] standard_name = tendency_of_x_wind_due_to_form_drag long_name = x wind tendency from form drag @@ -325,7 +325,7 @@ dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys - intent = out + intent = inout [dtauy2d_fd] standard_name = tendency_of_y_wind_due_to_form_drag long_name = y wind tendency from form drag @@ -333,7 +333,7 @@ dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys - intent = out + intent = inout [dusfc] standard_name = instantaneous_x_stress_due_to_gravity_wave_drag long_name = zonal surface stress due to orographic gravity wave drag @@ -357,7 +357,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout [dvsfc_ms] standard_name = vertically_integrated_y_momentum_flux_due_to_mesoscale_orographic_gravity_wave_drag long_name = integrated y momentum flux from mesoscale gwd @@ -365,7 +365,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout [dusfc_bl] standard_name = vertically_integrated_x_momentum_flux_due_to_blocking_drag long_name = integrated x momentum flux from blocking drag @@ -373,7 +373,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout [dvsfc_bl] standard_name = vertically_integrated_y_momentum_flux_due_to_blocking_drag long_name = integrated y momentum flux from blocking drag @@ -381,7 +381,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout [dusfc_ss] standard_name = vertically_integrated_x_momentum_flux_due_to_small_scale_gravity_wave_drag long_name = integrated x momentum flux from small scale gwd @@ -389,7 +389,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout [dvsfc_ss] standard_name = vertically_integrated_y_momentum_flux_due_to_small_scale_gravity_wave_drag long_name = integrated y momentum flux from small scale gwd @@ -397,7 +397,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout [dusfc_fd] standard_name = vertically_integrated_x_momentum_flux_due_to_form_drag long_name = integrated x momentum flux from form drag @@ -405,7 +405,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout [dvsfc_fd] standard_name = vertically_integrated_y_momentum_flux_due_to_form_drag long_name = integrated y momentum flux from form drag @@ -413,7 +413,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout [slmsk] standard_name = area_type long_name = landmask: sea/land/ice=0/1/2 From 5d6055ae89e4dbe6f17ed096005e5daf8eafa322 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 16 Feb 2023 23:13:41 +0000 Subject: [PATCH 117/380] remove prints and climate limits --- physics/maximum_hourly_diagnostics.F90 | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/physics/maximum_hourly_diagnostics.F90 b/physics/maximum_hourly_diagnostics.F90 index 969af8dcd..267dd0d94 100644 --- a/physics/maximum_hourly_diagnostics.F90 +++ b/physics/maximum_hourly_diagnostics.F90 @@ -79,7 +79,6 @@ subroutine maximum_hourly_diagnostics_run(im, levs, reset, lradar, imp_physics, !Lightning threat indices if (lightning_threat) then - print *,'call lightning_threat_indices' call lightning_threat_indices endif @@ -189,7 +188,7 @@ subroutine lightning_threat_indices ltg1 = coef1*wgrs(i,k)* & (( qgraupel(i,k+1) + qgraupel(i,k) )*0.5 ) - if(ltg1 > 0.01) then + if(.false.) then ! ltg1 > 0.01) then 184 format('Found ltg1=',F20.13,' with w=',F20.13,' Qg=',F20.13) print 184, ltg1, wgrs(i,k), ( qgraupel(i,k+1) + qgraupel(i,k) )*0.5 endif @@ -199,7 +198,7 @@ subroutine lightning_threat_indices high_wgrs = wgrs(i,k) endif - IF ( ltg1 .LT. clim1 ) ltg1 = 0. + !IF ( ltg1 .LT. clim1 ) ltg1 = 0. IF ( ltg1 .GT. ltg1_max(i) ) THEN ltg1_max(i) = ltg1 @@ -209,7 +208,7 @@ subroutine lightning_threat_indices enddo enddo - if(count > 0) then + if(.false.) then ! count > 0) then if(high_ltg1 < .01 .and. (abs(high_wgrs) < 0.1 .or. high_graupel < 1e-4)) then ! Nothing to look at else @@ -221,7 +220,7 @@ subroutine lightning_threat_indices do i=1,im ltg2 = coef2 * totice_colint(i) - IF ( ltg2 .LT. clim2 ) ltg2 = 0. + !IF ( ltg2 .LT. clim2 ) ltg2 = 0. IF ( ltg2 .GT. ltg2_max(i) ) THEN ltg2_max(i) = ltg2 @@ -229,7 +228,7 @@ subroutine lightning_threat_indices ltg3_max(i) = 0.95 * ltg1_max(i) + 0.05 * ltg2_max(i) - IF ( ltg3_max(i) .LT. clim3 ) ltg3_max(i) = 0. + !IF ( ltg3_max(i) .LT. clim3 ) ltg3_max(i) = 0. enddo end subroutine lightning_threat_indices From 58402e8fa2d0370c46f4a58b45ca450171c36863 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Fri, 17 Feb 2023 05:35:04 -0700 Subject: [PATCH 118/380] Add missing dependency on libsp to CMakeLists.txt --- CMakeLists.txt | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index d14778b06..00269140b 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -195,7 +195,9 @@ set_target_properties(ccpp_physics PROPERTIES VERSION ${PROJECT_VERSION} target_include_directories(ccpp_physics PUBLIC $) -target_link_libraries(ccpp_physics PUBLIC w3emc::w3emc_d NetCDF::NetCDF_Fortran) +target_link_libraries(ccpp_physics PUBLIC w3emc::w3emc_d + sp::sp_d + NetCDF::NetCDF_Fortran) # Define where to install the library install(TARGETS ccpp_physics From 88a7ebb5f1ab56166212ce10ecf0912092329f3b Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Mon, 27 Feb 2023 22:30:09 +0000 Subject: [PATCH 119/380] put clim limits back in --- physics/maximum_hourly_diagnostics.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/maximum_hourly_diagnostics.F90 b/physics/maximum_hourly_diagnostics.F90 index 267dd0d94..17679d3c6 100644 --- a/physics/maximum_hourly_diagnostics.F90 +++ b/physics/maximum_hourly_diagnostics.F90 @@ -220,7 +220,7 @@ subroutine lightning_threat_indices do i=1,im ltg2 = coef2 * totice_colint(i) - !IF ( ltg2 .LT. clim2 ) ltg2 = 0. + IF ( ltg2 .LT. clim2 ) ltg2 = 0. IF ( ltg2 .GT. ltg2_max(i) ) THEN ltg2_max(i) = ltg2 @@ -228,7 +228,7 @@ subroutine lightning_threat_indices ltg3_max(i) = 0.95 * ltg1_max(i) + 0.05 * ltg2_max(i) - !IF ( ltg3_max(i) .LT. clim3 ) ltg3_max(i) = 0. + IF ( ltg3_max(i) .LT. clim3 ) ltg3_max(i) = 0. enddo end subroutine lightning_threat_indices From 2942b9f6eec9b96bd504022bb4fce1d83045061d Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Mon, 27 Feb 2023 22:40:54 +0000 Subject: [PATCH 120/380] remove unintended changes --- physics/maximum_hourly_diagnostics.F90 | 15 +-------------- 1 file changed, 1 insertion(+), 14 deletions(-) diff --git a/physics/maximum_hourly_diagnostics.F90 b/physics/maximum_hourly_diagnostics.F90 index 17679d3c6..fbbcc86b3 100644 --- a/physics/maximum_hourly_diagnostics.F90 +++ b/physics/maximum_hourly_diagnostics.F90 @@ -188,17 +188,13 @@ subroutine lightning_threat_indices ltg1 = coef1*wgrs(i,k)* & (( qgraupel(i,k+1) + qgraupel(i,k) )*0.5 ) - if(.false.) then ! ltg1 > 0.01) then -184 format('Found ltg1=',F20.13,' with w=',F20.13,' Qg=',F20.13) - print 184, ltg1, wgrs(i,k), ( qgraupel(i,k+1) + qgraupel(i,k) )*0.5 - endif if(ltg1 > high_ltg1) then high_ltg1 = ltg1 high_graupel = qgraupel(i,k) high_wgrs = wgrs(i,k) endif - !IF ( ltg1 .LT. clim1 ) ltg1 = 0. + IF ( ltg1 .LT. clim1 ) ltg1 = 0. IF ( ltg1 .GT. ltg1_max(i) ) THEN ltg1_max(i) = ltg1 @@ -208,15 +204,6 @@ subroutine lightning_threat_indices enddo enddo - if(.false.) then ! count > 0) then - if(high_ltg1 < .01 .and. (abs(high_wgrs) < 0.1 .or. high_graupel < 1e-4)) then - ! Nothing to look at - else -183 format('Max ltg1=',F20.13,' has w=',F20.13,' Qg=',F20.13) - print 183, high_ltg1, high_wgrs, high_graupel - endif - endif - do i=1,im ltg2 = coef2 * totice_colint(i) From 1e5bfd90d1ebf323bd65e80516ef8e41c092fac9 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Tue, 28 Feb 2023 19:11:05 +0000 Subject: [PATCH 121/380] fill ltg*_max with 0 when model is hydrostatic --- physics/maximum_hourly_diagnostics.F90 | 12 +++++++++--- physics/maximum_hourly_diagnostics.meta | 7 +++++++ 2 files changed, 16 insertions(+), 3 deletions(-) diff --git a/physics/maximum_hourly_diagnostics.F90 b/physics/maximum_hourly_diagnostics.F90 index fbbcc86b3..df8d9202f 100644 --- a/physics/maximum_hourly_diagnostics.F90 +++ b/physics/maximum_hourly_diagnostics.F90 @@ -31,11 +31,11 @@ subroutine maximum_hourly_diagnostics_run(im, levs, reset, lradar, imp_physics, t02min, rh02max, rh02min, dtp, rain, pratemax, & lightning_threat, ltg1_max,ltg2_max,ltg3_max, & wgrs, prsi, qgraupel, qsnowwat, qicewat, tgrs, con_rd,& - prsl, kdt, errmsg, errflg) + prsl, kdt, hydrostatic, errmsg, errflg) ! Interface variables integer, intent(in) :: im, levs, kdt - logical, intent(in) :: reset, lradar, lightning_threat + logical, intent(in) :: reset, lradar, lightning_threat, hydrostatic integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_fer_hires, & imp_physics_nssl real(kind_phys), intent(in ) :: con_g @@ -79,7 +79,13 @@ subroutine maximum_hourly_diagnostics_run(im, levs, reset, lradar, imp_physics, !Lightning threat indices if (lightning_threat) then - call lightning_threat_indices + if(hydrostatic) then + ltg1_max = 0 + ltg2_max = 0 + ltg3_max = 0 + else + call lightning_threat_indices + endif endif !Calculate hourly max 1-km agl and -10C reflectivity diff --git a/physics/maximum_hourly_diagnostics.meta b/physics/maximum_hourly_diagnostics.meta index 98d30dc19..afe533375 100644 --- a/physics/maximum_hourly_diagnostics.meta +++ b/physics/maximum_hourly_diagnostics.meta @@ -340,6 +340,13 @@ dimensions = () type = integer intent = in +[hydrostatic] + standard_name = flag_for_hydrostatic_solver + long_name = flag for hydrostatic solver from dynamics + units = flag + dimensions = () + type = logical + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From b558a091b6b5a05a69c9e804ab162cace03d7744 Mon Sep 17 00:00:00 2001 From: joeolson42 Date: Tue, 28 Feb 2023 22:10:37 +0000 Subject: [PATCH 122/380] MYNN updates --- physics/module_bl_mynn.F90 | 2956 ++++++++++++++++----------------- physics/mynnedmf_wrapper.F90 | 279 ++-- physics/mynnedmf_wrapper.meta | 46 +- physics/sgscloud_radpre.F90 | 135 +- physics/sgscloud_radpre.meta | 38 + 5 files changed, 1793 insertions(+), 1661 deletions(-) diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index ffb4b5696..b95f401c4 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -121,7 +121,7 @@ ! Hybrid PBL height diagnostic, which blends a theta-v-based ! definition in neutral/convective BL and a TKE-based definition ! in stable conditions. -! TKE budget output option (bl_mynn_tkebudget) +! TKE budget output option ! v3.5.0: TKE advection option (bl_mynn_tkeadvect) ! v3.5.1: Fog deposition related changes. ! v3.6.0: Removed fog deposition from the calculation of tendencies @@ -216,14 +216,14 @@ ! Misc small-impact bugfixes: ! 1) dz was incorrectly indexed in mym_condensation ! 2) configurations with icloud_bl = 0 were using uninitialized arrays -! v4.4 / CCPP +! v4.5 / CCPP ! This version includes many modifications that proved valuable in the global ! framework and removes some key lingering bugs in the mixing of chemical species. ! TKE Budget output fixed (Puhales, 2020-12) ! New option for stability function: (Puhales, 2020-12) ! bl_mynn_stfunc = 0 (original, Kansas-type function, Paulson, 1970 ) ! bl_mynn_stfunc = 1 (expanded range, same as used for Jimenez et al (MWR) -! see the Technical Note for this implementation. +! see the Technical Note for this implementation (small impact). ! Improved conservation of momentum and higher-order moments. ! Important bug fixes for mixing of chemical species. ! Addition of pressure-gradient effects on updraft momentum transport. @@ -248,21 +248,11 @@ MODULE module_bl_mynn xlvcp , tv0 , tv1 , tref , & zero , half , one , two , & onethird , twothirds , tkmin , t0c , & - tice + tice , kind_phys IMPLICIT NONE -!get rid - INTEGER , PARAMETER :: param_first_scalar = 1, & - & p_qc = 2, & - & p_qr = 0, & - & p_qi = 2, & - & p_qs = 0, & - & p_qg = 0, & - & p_qnc= 0, & - & p_qni= 0 - !=================================================================== ! From here on, these are MYNN-specific parameters: ! The parameters below depend on stability functions of module_sf_mynn. @@ -301,6 +291,7 @@ MODULE module_bl_mynn ! &cns=3.5, alp1=0.23, alp2=0.3, alp3=3.0, alp4=10.0, alp5=0.2 REAL, PARAMETER :: gpw=5./3., qcgmin=1.e-8, qkemin=1.e-12 + REAL, PARAMETER :: tliq = 269. !all hydrometeors are liquid when T > tliq ! Constants for cloud PDF (mym_condensation) REAL, PARAMETER :: rr2=0.7071068, rrp=0.3989423 @@ -340,32 +331,6 @@ MODULE module_bl_mynn LOGICAL, PARAMETER :: debug_code = .false. INTEGER, PARAMETER :: idbg = 23 !specific i-point to write out -! JAYMES- -!> Constants used for empirical calculations of saturation -!! vapor pressures (in function "esat") and saturation mixing ratios -!! (in function "qsat"), reproduced from module_mp_thompson.F, -!! v3.6 - REAL, PARAMETER:: J0= .611583699E03 - REAL, PARAMETER:: J1= .444606896E02 - REAL, PARAMETER:: J2= .143177157E01 - REAL, PARAMETER:: J3= .264224321E-1 - REAL, PARAMETER:: J4= .299291081E-3 - REAL, PARAMETER:: J5= .203154182E-5 - REAL, PARAMETER:: J6= .702620698E-8 - REAL, PARAMETER:: J7= .379534310E-11 - REAL, PARAMETER:: J8=-.321582393E-13 - - REAL, PARAMETER:: K0= .609868993E03 - REAL, PARAMETER:: K1= .499320233E02 - REAL, PARAMETER:: K2= .184672631E01 - REAL, PARAMETER:: K3= .402737184E-1 - REAL, PARAMETER:: K4= .565392987E-3 - REAL, PARAMETER:: K5= .521693933E-5 - REAL, PARAMETER:: K6= .307839583E-7 - REAL, PARAMETER:: K7= .105785160E-9 - REAL, PARAMETER:: K8= .161444444E-12 -! end- - ! Used in WRF-ARW module_physics_init.F INTEGER :: mynn_level @@ -373,7 +338,7 @@ MODULE module_bl_mynn CONTAINS ! ================================================================== -!>\ingroup gp_mynnedmf +!>\ingroup gsd_mynn_edmf !! This subroutine is the GSD MYNN-EDNF PBL driver routine,which !! encompassed the majority of the subroutines that comprise the !! procedures that ultimately solve for tendencies of @@ -383,35 +348,32 @@ MODULE module_bl_mynn SUBROUTINE mynn_bl_driver( & &initflag,restart,cycling, & &delt,dz,dx,znt, & - &u,v,w,th,sqv3D,sqc3D,sqi3D, & - &qnc,qni, & - &qnwfa,qnifa,ozone, & - &p,exner,rho,T3D, & + &u,v,w,th,sqv3d,sqc3d,sqi3d, & + &sqs3d,qnc,qni, & + &qnwfa,qnifa,qnbca,ozone, & + &p,exner,rho,t3d, & &xland,ts,qsfc,ps, & &ust,ch,hfx,qfx,rmol,wspd, & &uoce,voce, & !ocean current - &vdfg, & !Katata-added for fog dep - &Qke,qke_adv, & + &qke,qke_adv, & &sh3d,sm3d, & - &nchem,kdvel,ndvel, & !Smoke/Chem variables - &chem3d, vdep, & - &frp,EMIS_ANT_NO, & ! JLS/RAR to adjust exchange coeffs - &mix_chem,fire_turb,rrfs_smoke, & ! end smoke/chem variables - - &Tsq,Qsq,Cov, & - &RUBLTEN,RVBLTEN,RTHBLTEN, & - &RQVBLTEN,RQCBLTEN,RQIBLTEN, & - &RQNCBLTEN,RQNIBLTEN, & - &RQNWFABLTEN,RQNIFABLTEN, & - &DOZONE, & + &chem3d,vdep,smoke_dbg, & + &frp,emis_ant_no, & ! JLS/RAR to adjust exchange coeffs + &mix_chem,enh_mix,rrfs_sd, & ! end smoke/chem variables + &tsq,qsq,cov, & + &rublten,rvblten,rthblten, & + &rqvblten,rqcblten,rqiblten, & + &rqncblten,rqniblten,rqsblten, & + &rqnwfablten,rqnifablten, & + &rqnbcablten,dozone, & &exch_h,exch_m, & - &Pblh,kpbl, & + &pblh,kpbl, & &el_pbl, & - &dqke,qWT,qSHEAR,qBUOY,qDISS, & + &dqke,qwt,qshear,qbuoy,qdiss, & &qc_bl,qi_bl,cldfra_bl, & &bl_mynn_tkeadvect, & - &bl_mynn_tkebudget, & + &tke_budget, & &bl_mynn_cloudpdf, & &bl_mynn_mixlength, & &icloud_bl, & @@ -428,20 +390,21 @@ SUBROUTINE mynn_bl_driver( & &det_thl3D,det_sqv3D, & &nupdraft,maxMF,ktop_plume, & &spp_pbl,pattern_spp_pbl, & - &RTHRATEN, & + &rthraten, & &FLAG_QC,FLAG_QI,FLAG_QNC, & - &FLAG_QNI,FLAG_QNWFA,FLAG_QNIFA, & - &FLAG_OZONE & - &,IDS,IDE,JDS,JDE,KDS,KDE & - &,IMS,IME,JMS,JME,KMS,KME & - &,ITS,ITE,JTS,JTE,KTS,KTE) + &FLAG_QNI,FLAG_QS, & + &FLAG_QNWFA,FLAG_QNIFA, & + &FLAG_QNBCA,FLAG_OZONE, & + &IDS,IDE,JDS,JDE,KDS,KDE, & + &IMS,IME,JMS,JME,KMS,KME, & + &ITS,ITE,JTS,JTE,KTS,KTE ) !------------------------------------------------------------------- INTEGER, INTENT(in) :: initflag !INPUT NAMELIST OPTIONS: - LOGICAL, INTENT(IN) :: restart,cycling - LOGICAL, INTENT(in) :: bl_mynn_tkebudget + LOGICAL, INTENT(in) :: restart,cycling + INTEGER, INTENT(in) :: tke_budget INTEGER, INTENT(in) :: bl_mynn_cloudpdf INTEGER, INTENT(in) :: bl_mynn_mixlength INTEGER, INTENT(in) :: bl_mynn_edmf @@ -453,17 +416,18 @@ SUBROUTINE mynn_bl_driver( & INTEGER, INTENT(in) :: bl_mynn_cloudmix INTEGER, INTENT(in) :: bl_mynn_mixqt INTEGER, INTENT(in) :: icloud_bl - REAL, INTENT(in) :: closure + REAL(kind=kind_phys), INTENT(in) :: closure LOGICAL, INTENT(in) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC,& - FLAG_QNWFA,FLAG_QNIFA,FLAG_OZONE + FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA, & + FLAG_OZONE,FLAG_QS - LOGICAL, INTENT(IN) :: mix_chem,fire_turb,rrfs_smoke + LOGICAL, INTENT(IN) :: mix_chem,enh_mix,rrfs_sd,smoke_dbg - INTEGER, INTENT(in) :: & - & IDS,IDE,JDS,JDE,KDS,KDE & - &,IMS,IME,JMS,JME,KMS,KME & - &,ITS,ITE,JTS,JTE,KTS,KTE + INTEGER, INTENT(in) :: & + & IDS,IDE,JDS,JDE,KDS,KDE & + &,IMS,IME,JMS,JME,KMS,KME & + &,ITS,ITE,JTS,JTE,KTS,KTE #ifdef HARDCODE_VERTICAL # define kts 1 @@ -480,71 +444,67 @@ SUBROUTINE mynn_bl_driver( & ! to prevent a crash on Cheyenne. Do not change it back without testing if the code runs ! on Cheyenne with the GNU compiler. - REAL, INTENT(in) :: delt - REAL, DIMENSION(:), INTENT(in) :: dx - REAL, DIMENSION(:,:), INTENT(in) :: dz, & + REAL(kind=kind_phys), INTENT(in) :: delt + REAL(kind=kind_phys), DIMENSION(:), INTENT(in) :: dx + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(in) :: dz, & &u,v,w,th,sqv3D,p,exner,rho,T3D - REAL, DIMENSION(:,:), INTENT(in):: & - &sqc3D,sqi3D,qni,qnc,qnwfa,qnifa - REAL, DIMENSION(:,:), INTENT(in):: ozone - REAL, DIMENSION(:), INTENT(in) :: xland,ust, & - &ch,ts,qsfc,ps,hfx,qfx,wspd,uoce,voce,vdfg,znt - - REAL, DIMENSION(:,:), INTENT(inout) :: & + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(in) :: & + &sqc3D,sqi3D,sqs3D,qni,qnc,qnwfa,qnifa,qnbca + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(in):: ozone + REAL(kind=kind_phys), DIMENSION(:), INTENT(in):: ust, & + &ch,qsfc,ps,wspd + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(inout) :: & &Qke,Tsq,Qsq,Cov,qke_adv + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(inout) :: & + &rublten,rvblten,rthblten,rqvblten,rqcblten, & + &rqiblten,rqsblten,rqniblten,rqncblten, & + &rqnwfablten,rqnifablten,rqnbcablten + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(inout) :: dozone + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(in) :: rthraten - REAL, DIMENSION(:,:), INTENT(inout) :: & - &RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN,RQCBLTEN, & - &RQIBLTEN,RQNIBLTEN,RQNCBLTEN, & - &RQNWFABLTEN,RQNIFABLTEN - REAL, DIMENSION(:,:), INTENT(inout) :: DOZONE - - REAL, DIMENSION(:,:), INTENT(in) :: RTHRATEN - - REAL, DIMENSION(:,:), INTENT(out) :: & - &exch_h,exch_m + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(out) :: exch_h,exch_m + REAL, DIMENSION(:), INTENT(in) :: xland,ts,znt,hfx,qfx, & + &uoce,voce !These 10 arrays are only allocated when bl_mynn_output > 0 - REAL, DIMENSION(:,:), INTENT(inout) :: & - & edmf_a,edmf_w,edmf_qt,edmf_thl,edmf_ent,edmf_qc, & + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(inout) :: & + & edmf_a,edmf_w,edmf_qt,edmf_thl,edmf_ent,edmf_qc, & & sub_thl3D,sub_sqv3D,det_thl3D,det_sqv3D ! REAL, DIMENSION(IMS:IME,KMS:KME) :: & ! & edmf_a_dd,edmf_w_dd,edmf_qt_dd,edmf_thl_dd,edmf_ent_dd,edmf_qc_dd - REAL, DIMENSION(:), INTENT(inout) :: Pblh,rmol + REAL(kind=kind_phys), DIMENSION(:), INTENT(inout) :: Pblh + REAL, DIMENSION(:), INTENT(inout) :: rmol - REAL, DIMENSION(IMS:IME) :: Psig_bl,Psig_shcu + REAL, DIMENSION(IMS:IME) :: psig_bl,psig_shcu - INTEGER,DIMENSION(:),INTENT(INOUT) :: & + INTEGER,DIMENSION(:),INTENT(INOUT) :: & &KPBL,nupdraft,ktop_plume - REAL, DIMENSION(:), INTENT(OUT) :: & - &maxmf + REAL(kind=kind_phys), DIMENSION(:), INTENT(out) :: maxmf - REAL, DIMENSION(:,:), INTENT(inout) :: & - &el_pbl + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(inout) :: el_pbl - REAL, DIMENSION(:,:), INTENT(out) :: & + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(out) :: & &qWT,qSHEAR,qBUOY,qDISS,dqke - ! 3D budget arrays are not allocated when bl_mynn_tkebudget == .false. + ! 3D budget arrays are not allocated when tke_budget == 0 ! 1D (local) budget arrays are used for passing between subroutines. - REAL, DIMENSION(kts:kte) :: qWT1,qSHEAR1,qBUOY1,qDISS1,dqke1,diss_heat + REAL, DIMENSION(kts:kte) :: qwt1,qshear1,qbuoy1,qdiss1, & + &dqke1,diss_heat - REAL, DIMENSION(:,:), intent(out) :: Sh3D,Sm3D + REAL(kind=kind_phys), DIMENSION(:,:), intent(out) :: Sh3D,Sm3D - REAL, DIMENSION(:,:), INTENT(inout) :: & + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(inout) :: & &qc_bl,qi_bl,cldfra_bl - REAL, DIMENSION(KTS:KTE) :: qc_bl1D,qi_bl1D,cldfra_bl1D,& + REAL, DIMENSION(KTS:KTE) :: qc_bl1D,qi_bl1D,cldfra_bl1D, & qc_bl1D_old,qi_bl1D_old,cldfra_bl1D_old ! smoke/chemical arrays INTEGER, INTENT(IN ) :: nchem, kdvel, ndvel -! REAL, DIMENSION( ims:ime, kms:kme, nchem ), INTENT(INOUT), optional :: chem3d -! REAL, DIMENSION( ims:ime, kdvel, ndvel ), INTENT(IN), optional :: vdep - REAL, DIMENSION(:, :, :), INTENT(INOUT) :: chem3d - REAL, DIMENSION(:, :), INTENT(IN) :: vdep - REAL, DIMENSION(:), INTENT(IN) :: frp,EMIS_ANT_NO + REAL(kind=kind_phys), DIMENSION(:,:,:), INTENT(INOUT) :: chem3d + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(IN) :: vdep + REAL(kind=kind_phys), DIMENSION(:), INTENT(IN) :: frp,EMIS_ANT_NO !local REAL, DIMENSION(kts:kte ,nchem) :: chem1 REAL, DIMENSION(kts:kte+1,nchem) :: s_awchem1 @@ -553,15 +513,16 @@ SUBROUTINE mynn_bl_driver( & !local vars INTEGER :: ITF,JTF,KTF, IMD,JMD - INTEGER :: i,j,k - REAL, DIMENSION(KTS:KTE) :: thl,thvl,tl,qv1,qc1,qi1,sqw,& - &El, Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc, & - &Vt, Vq, sgm, thlsg, sqwsg + INTEGER :: i,j,k,kproblem + REAL, DIMENSION(KTS:KTE) :: thl,tl,qv1,qc1,qi1,qs1,sqw, & + &el, dfm, dfh, dfq, tcd, qcd, pdk, pdt, pdq, pdc, & + &vt, vq, sgm REAL, DIMENSION(KTS:KTE) :: thetav,sh,sm,u1,v1,w1,p1, & &ex1,dz1,th1,tk1,rho1,qke1,tsq1,qsq1,cov1, & - &sqv,sqi,sqc,du1,dv1,dth1,dqv1,dqc1,dqi1,ozone1, & + &sqv,sqi,sqc,sqs, & + &du1,dv1,dth1,dqv1,dqc1,dqi1,dqs1,ozone1, & &k_m1,k_h1,qni1,dqni1,qnc1,dqnc1,qnwfa1,qnifa1, & - &dqnwfa1,dqnifa1,dozone1 + &qnbca1,dqnwfa1,dqnifa1,dqnbca1,dozone1 !mass-flux variables REAL, DIMENSION(KTS:KTE) :: dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf @@ -574,52 +535,67 @@ SUBROUTINE mynn_bl_driver( & det_thl,det_sqv,det_sqc,det_u,det_v REAL,DIMENSION(KTS:KTE+1) :: s_aw1,s_awthl1,s_awqt1, & s_awqv1,s_awqc1,s_awu1,s_awv1,s_awqke1, & - s_awqnc1,s_awqni1,s_awqnwfa1,s_awqnifa1 + s_awqnc1,s_awqni1,s_awqnwfa1,s_awqnifa1, & + s_awqnbca1 REAL,DIMENSION(KTS:KTE+1) :: sd_aw1,sd_awthl1,sd_awqt1, & sd_awqv1,sd_awqc1,sd_awu1,sd_awv1,sd_awqke1 REAL, DIMENSION(KTS:KTE+1) :: zw REAL :: cpm,sqcg,flt,fltv,flq,flqv,flqc,pmz,phh,exnerg,zet,phi_m,& & afk,abk,ts_decay, qc_bl2, qi_bl2, & - & th_sfc,ztop_plume,sqc9,sqi9 + & th_sfc,ztop_plume,wsp !top-down diffusion REAL, DIMENSION(ITS:ITE) :: maxKHtopdown - REAL,DIMENSION(KTS:KTE) :: KHtopdown,TKEprodTD + REAL, DIMENSION(KTS:KTE) :: KHtopdown,TKEprodTD - LOGICAL :: INITIALIZE_QKE + LOGICAL :: INITIALIZE_QKE,problem ! Stochastic fields - INTEGER, INTENT(IN) ::spp_pbl - REAL, DIMENSION( :, :), INTENT(IN) ::pattern_spp_pbl - REAL, DIMENSION(KTS:KTE) ::rstoch_col + INTEGER, INTENT(IN) :: spp_pbl + REAL(kind=kind_phys), DIMENSION( :, :), INTENT(IN) :: pattern_spp_pbl + REAL, DIMENSION(KTS:KTE) :: rstoch_col ! Substepping TKE INTEGER :: nsub - real :: delt2 - - IF ( debug_code ) THEN - if (idbg .lt. ime) then - print*,'in MYNN driver; at beginning' - print*," th(1:5)=",th(idbg,1:5) - print*," u(1:5)=",u(idbg,1:5) - print*," v(1:5)=",v(idbg,1:5) - print*," w(1:5)=",w(idbg,1:5) - print*," sqv(1:5)=",sqv3D(idbg,1:5) - print*," p(1:5)=",p(idbg,1:5) - print*," rho(1:5)=",rho(idbg,1:5) - print*," xland=",xland(idbg)," u*=",ust(idbg), & - &" ts=",ts(idbg)," qsfc=",qsfc(idbg), & - &" z/L=",0.5*dz(idbg,1)*rmol(idbg)," ps=",ps(idbg),& - &" hfx=",hfx(idbg)," qfx=",qfx(idbg), & - &" wspd=",wspd(idbg)," znt=",znt(idbg) - endif - ENDIF + real(kind=kind_phys) :: delt2 + + + if (debug_code) then !check incoming values + do i=its,ite + problem = .false. + do k=kts,kte + wsp = sqrt(u(i,k)**2 + v(i,k)**2) + if (abs(hfx(i)) > 1200. .or. abs(qfx(i)) > 0.001 .or. & + wsp > 200. .or. t3d(i,k) > 360. .or. t3d(i,k) < 160. .or. & + sqv3d(i,k)< 0.0 .or. sqc3d(i,k)< 0.0 ) then + kproblem = k + problem = .true. + print*,"Incoming problem at: i=",i," k=1" + print*," QFX=",qfx(i)," HFX=",hfx(i) + print*," wsp=",wsp," T=",t3d(i,k) + print*," qv=",sqv3d(i,k)," qc=",sqc3d(i,k) + print*," u*=",ust(i)," wspd=",wspd(i) + print*," xland=",xland(i)," ts=",ts(i) + print*," z/L=",0.5*dz(i,1)*rmol(i)," ps=",ps(i) + print*," znt=",znt(i)," dx=",dx(i) + endif + enddo + if (problem) then + print*,"===tk:",t3d(i,max(kproblem-3,1):min(kproblem+3,kte)) + print*,"===qv:",sqv3d(i,max(kproblem-3,1):min(kproblem+3,kte)) + print*,"===qc:",sqc3d(i,max(kproblem-3,1):min(kproblem+3,kte)) + print*,"===qi:",sqi3d(i,max(kproblem-3,1):min(kproblem+3,kte)) + print*,"====u:",u(i,max(kproblem-3,1):min(kproblem+3,kte)) + print*,"====v:",v(i,max(kproblem-3,1):min(kproblem+3,kte)) + endif + enddo + endif !*** Begin debugging IMD=(IMS+IME)/2 JMD=(JMS+JME)/2 -!*** End debugging +!*** End debugging JTF=JTE ITF=ITE @@ -691,6 +667,7 @@ SUBROUTINE mynn_bl_driver( & dqnc1(kts:kte)=0.0 dqnwfa1(kts:kte)=0.0 dqnifa1(kts:kte)=0.0 + dqnbca1(kts:kte)=0.0 dozone1(kts:kte)=0.0 qc_bl1D_old(kts:kte)=0.0 cldfra_bl1D_old(kts:kte)=0.0 @@ -711,7 +688,7 @@ SUBROUTINE mynn_bl_driver( & ENDDO ENDDO - IF ( bl_mynn_tkebudget ) THEN + IF (tke_budget .eq. 1) THEN DO k=KTS,KTE DO i=ITS,ITF qWT(i,k)=0. @@ -724,7 +701,23 @@ SUBROUTINE mynn_bl_driver( & ENDIF DO i=ITS,ITF - DO k=KTS,KTE !KTF + if (FLAG_QI ) then + sqi(:)=sqi3D(i,:) + else + sqi = 0.0 + endif + if (FLAG_QS ) then + sqs(:)=sqs3D(i,:) + else + sqs = 0.0 + endif + if (icloud_bl > 0) then + cldfra_bl1d(:)=cldfra_bl(i,:) + qc_bl1d(:)=qc_bl(i,:) + qi_bl1d(:)=qi_bl(i,:) + endif + + do k=KTS,KTE !KTF dz1(k)=dz(i,k) u1(k) = u(i,k) v1(k) = v(i,k) @@ -736,51 +729,14 @@ SUBROUTINE mynn_bl_driver( & sqc(k)=sqc3D(i,k) !/(1.+qv(i,k)) sqv(k)=sqv3D(i,k) !/(1.+qv(i,k)) thetav(k)=th(i,k)*(1.+0.608*sqv(k)) - IF (icloud_bl > 0) THEN - CLDFRA_BL1D(k)=CLDFRA_BL(i,k) - QC_BL1D(k)=QC_BL(i,k) - QI_BL1D(k)=QI_BL(i,k) - ENDIF - IF (FLAG_QI ) THEN - sqi(k)=sqi3D(i,k) !/(1.+qv(i,k)) - sqw(k)=sqv(k)+sqc(k)+sqi(k) - thl(k)=th1(k) - xlvcp/ex1(k)*sqc(k) & - & - xlscp/ex1(k)*sqi(k) - !Use form from Tripoli and Cotton (1981) with their - !suggested min temperature to improve accuracy. - !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) & - ! & - xlscp/MAX(tk1(k),TKmin)*sqi(k)) - !COMPUTE THL USING SGS CLOUDS FOR PBLH DIAG - IF(sqc(k)<1e-6 .and. sqi(k)<1e-8 .and. CLDFRA_BL1D(k)>0.001)THEN - sqc9=QC_BL1D(k)*CLDFRA_BL1D(k) - sqi9=QI_BL1D(k)*CLDFRA_BL1D(k) - ELSE - sqc9=sqc(k) - sqi9=sqi(k) - ENDIF - thlsg(k)=th1(k) - xlvcp/ex1(k)*sqc9 & - & - xlscp/ex1(k)*sqi9 - sqwsg(k)=sqv(k)+sqc9+sqi9 - ELSE - sqi(k)=0.0 - sqw(k)=sqv(k)+sqc(k) - thl(k)=th1(k)-xlvcp/ex1(k)*sqc(k) - !Use form from Tripoli and Cotton (1981) with their - !suggested min temperature to improve accuracy. - !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k)) - !COMPUTE THL USING SGS CLOUDS FOR PBLH DIAG - IF(sqc(k)<1e-6 .and. CLDFRA_BL1D(k)>0.001)THEN - sqc9=QC_BL1D(k)*CLDFRA_BL1D(k) - sqi9=0.0 - ELSE - sqc9=sqc(k) - sqi9=0.0 - ENDIF - thlsg(k)=th1(k) - xlvcp/ex1(k)*sqc9 & - & - xlscp/ex1(k)*sqi9 - sqwsg(k)=sqv(k)+sqc9+sqi9 - ENDIF - thvl(k)=thlsg(k)*(1.+0.61*sqv(k)) + !keep snow out for now - increases ceiling bias + sqw(k)=sqv(k)+sqc(k)+sqi(k)!+sqs(k) + thl(k)=th1(k) - xlvcp/ex1(k)*sqc(k) & + & - xlscp/ex1(k)*(sqi(k)+sqs(k)) + !Use form from Tripoli and Cotton (1981) with their + !suggested min temperature to improve accuracy. + !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) & + ! & - xlscp/MAX(tk1(k),TKmin)*sqi(k)) IF (k==kts) THEN zw(k)=0. @@ -811,9 +767,8 @@ SUBROUTINE mynn_bl_driver( & zw(kte+1)=zw(kte)+dz(i,kte) -!> - Call get_pblh() to calculate hybrid (\f$\theta_{vli}-TKE\f$) PBL height. -! CALL GET_PBLH(KTS,KTE,PBLH(i),thetav,& - CALL GET_PBLH(KTS,KTE,PBLH(i),thvl, & +!> - Call get_pblh() to calculate hybrid (\f$\theta_{v}-TKE\f$) PBL height. + CALL GET_PBLH(KTS,KTE,PBLH(i),thetav,& & Qke1,zw,dz1,xland(i),KPBL(i)) !> - Call scale_aware() to calculate similarity functions for scale-adaptive control @@ -831,18 +786,17 @@ SUBROUTINE mynn_bl_driver( & !! obtaining prerequisite variables by calling the following subroutines from !! within mym_initialize(): mym_level2() and mym_length(). CALL mym_initialize ( & - &kts,kte, & + &kts,kte,xland(i), & &dz1, dx(i), zw, & &u1, v1, thl, sqv, & - &thlsg, sqwsg, & &PBLH(i), th1, thetav, sh, sm, & &ust(i), rmol(i), & &el, Qke1, Tsq1, Qsq1, Cov1, & &Psig_bl(i), cldfra_bl1D, & &bl_mynn_mixlength, & - &edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf,& + &edmf_w1,edmf_a1, & &INITIALIZE_QKE, & - &spp_pbl,rstoch_col ) + &spp_pbl,rstoch_col ) IF (.not.restart) THEN !UPDATE 3D VARIABLES @@ -885,654 +839,582 @@ SUBROUTINE mynn_bl_driver( & ENDIF DO i=ITS,ITF - DO k=KTS,KTE !KTF - !JOE-TKE BUDGET - IF ( bl_mynn_tkebudget ) THEN - dqke(i,k)=qke(i,k) - END IF - IF (icloud_bl > 0) THEN - CLDFRA_BL1D(k)=CLDFRA_BL(i,k) - QC_BL1D(k)=QC_BL(i,k) - QI_BL1D(k)=QI_BL(i,k) - cldfra_bl1D_old(k)=cldfra_bl(i,k) - qc_bl1D_old(k)=qc_bl(i,k) - qi_bl1D_old(k)=qi_bl(i,k) - else - CLDFRA_BL1D(k)=0.0 - QC_BL1D(k)=0.0 - QI_BL1D(k)=0.0 - cldfra_bl1D_old(k)=0.0 - qc_bl1D_old(k)=0.0 - qi_bl1D_old(k)=0.0 - ENDIF - dz1(k)= dz(i,k) - u1(k) = u(i,k) - v1(k) = v(i,k) - w1(k) = w(i,k) - th1(k)= th(i,k) - tk1(k)=T3D(i,k) - p1(k) = p(i,k) - ex1(k)= exner(i,k) - rho1(k)=rho(i,k) - sqv(k)= sqv3D(i,k) !/(1.+qv(i,k)) - sqc(k)= sqc3D(i,k) !/(1.+qv(i,k)) - qv1(k)= sqv(k)/(1.-sqv(k)) - qc1(k)= sqc(k)/(1.-sqv(k)) - dqc1(k)=0.0 - dqi1(k)=0.0 - dqni1(k)=0.0 - dqnc1(k)=0.0 - dqnwfa1(k)=0.0 - dqnifa1(k)=0.0 - dozone1(k)=0.0 - IF(FLAG_QI)THEN - sqi(k)= sqi3D(i,k) !/(1.+qv(i,k)) - qi1(k)= sqi(k)/(1.-sqv(k)) - sqw(k)= sqv(k)+sqc(k)+sqi(k) - thl(k)= th1(k) - xlvcp/ex1(k)*sqc(k) & - & - xlscp/ex1(k)*sqi(k) - !Use form from Tripoli and Cotton (1981) with their - !suggested min temperature to improve accuracy. - !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) & - ! & - xlscp/MAX(tk1(k),TKmin)*sqi(k)) - !COMPUTE THL USING SGS CLOUDS FOR PBLH DIAG - IF(sqc(k)<1e-6 .and. sqi(k)<1e-8 .and. CLDFRA_BL1D(k)>0.001)THEN - sqc9=QC_BL1D(k)*CLDFRA_BL1D(k) - sqi9=QI_BL1D(k)*CLDFRA_BL1D(k) - ELSE - sqc9=sqc(k) - sqi9=sqi(k) - ENDIF - thlsg(k)=th1(k) - xlvcp/ex1(k)*sqc9 & - & - xlscp/ex1(k)*sqi9 - sqwsg(k)=sqv(k)+sqc9+sqi9 - ELSE - qi1(k)=0.0 - sqi(k)=0.0 - sqw(k)= sqv(k)+sqc(k) - thl(k)= th1(k)-xlvcp/ex1(k)*sqc(k) - !Use form from Tripoli and Cotton (1981) with their - !suggested min temperature to improve accuracy. - !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k)) - !COMPUTE THL USING SGS CLOUDS FOR PBLH DIAG - IF(sqc(k)<1e-6 .and. CLDFRA_BL1D(k)>0.001)THEN - sqc9=QC_BL1D(k)*CLDFRA_BL1D(k) - sqi9=QI_BL1D(k)*CLDFRA_BL1D(k) - ELSE - sqc9=sqc(k) - sqi9=0.0 - ENDIF - thlsg(k)=th1(k) - xlvcp/ex1(k)*sqc9 & - & - xlscp/ex1(k)*sqi9 - ENDIF - thetav(k)=th1(k)*(1.+0.608*sqv(k)) - thvl(k) =thlsg(k) *(1.+0.608*sqv(k)) - - IF (FLAG_QNI ) THEN - qni1(k)=qni(i,k) - ELSE - qni1(k)=0.0 - ENDIF - IF (FLAG_QNC ) THEN - qnc1(k)=qnc(i,k) - ELSE - qnc1(k)=0.0 - ENDIF - IF (FLAG_QNWFA ) THEN - qnwfa1(k)=qnwfa(i,k) - ELSE - qnwfa1(k)=0.0 - ENDIF - IF (FLAG_QNIFA ) THEN - qnifa1(k)=qnifa(i,k) - ELSE - qnifa1(k)=0.0 - ENDIF - IF (FLAG_OZONE) THEN - ozone1(k)=ozone(i,k) - ELSE - ozone1(k)=0.0 - ENDIF - el(k) = el_pbl(i,k) - qke1(k)=qke(i,k) - sh(k) =sh3d(i,k) - sm(k) =sm3d(i,k) - tsq1(k)=tsq(i,k) - qsq1(k)=qsq(i,k) - cov1(k)=cov(i,k) - if (spp_pbl==1) then - rstoch_col(k)=pattern_spp_pbl(i,k) - else - rstoch_col(k)=0.0 - endif - - !edmf - edmf_a1(k)=0.0 - edmf_w1(k)=0.0 - edmf_qc1(k)=0.0 - s_aw1(k)=0. - s_awthl1(k)=0. - s_awqt1(k)=0. - s_awqv1(k)=0. - s_awqc1(k)=0. - s_awu1(k)=0. - s_awv1(k)=0. - s_awqke1(k)=0. - s_awqnc1(k)=0. - s_awqni1(k)=0. - s_awqnwfa1(k)=0. - s_awqnifa1(k)=0. - ![EWDD] - edmf_a_dd1(k)=0.0 - edmf_w_dd1(k)=0.0 - edmf_qc_dd1(k)=0.0 - sd_aw1(k)=0. - sd_awthl1(k)=0. - sd_awqt1(k)=0. - sd_awqv1(k)=0. - sd_awqc1(k)=0. - sd_awu1(k)=0. - sd_awv1(k)=0. - sd_awqke1(k)=0. - sub_thl(k)=0. - sub_sqv(k)=0. - sub_u(k)=0. - sub_v(k)=0. - det_thl(k)=0. - det_sqv(k)=0. - det_sqc(k)=0. - det_u(k)=0. - det_v(k)=0. - - IF (k==kts) THEN - zw(k)=0. - ELSE - zw(k)=zw(k-1)+dz(i,k-1) - ENDIF - ENDDO ! end k - - !initialize smoke/chem arrays (if used): - IF ( rrfs_smoke .and. mix_chem ) then - do ic = 1,ndvel - vd1(ic) = vdep(i,ic) !is this correct???? - chem1(kts,ic) = chem3d(i,kts,ic) - s_awchem1(kts,ic)=0. - enddo - do k = kts+1,kte - DO ic = 1,nchem - chem1(k,ic) = chem3d(i,k,ic) - s_awchem1(k,ic)=0. - ENDDO - enddo - ELSE - do ic = 1,ndvel - vd1(ic) = 0. !is this correct??? (ite) or (ndvel) - chem1(kts,ic) = 0. - s_awchem1(kts,ic)=0. - enddo - do k = kts+1,kte - do ic = 1,nchem - chem1(k,ic) = 0. - s_awchem1(k,ic)=0. - enddo - enddo - ENDIF - - zw(kte+1)=zw(kte)+dz(i,kte) - !EDMF - s_aw1(kte+1)=0. - s_awthl1(kte+1)=0. - s_awqt1(kte+1)=0. - s_awqv1(kte+1)=0. - s_awqc1(kte+1)=0. - s_awu1(kte+1)=0. - s_awv1(kte+1)=0. - s_awqke1(kte+1)=0. - s_awqnc1(kte+1)=0. - s_awqni1(kte+1)=0. - s_awqnwfa1(kte+1)=0. - s_awqnifa1(kte+1)=0. - sd_aw1(kte+1)=0. - sd_awthl1(kte+1)=0. - sd_awqt1(kte+1)=0. - sd_awqv1(kte+1)=0. - sd_awqc1(kte+1)=0. - sd_awu1(kte+1)=0. - sd_awv1(kte+1)=0. - sd_awqke1(kte+1)=0. - IF ( mix_chem ) THEN - DO ic = 1,nchem - s_awchem1(kte+1,ic)=0. - ENDDO - ENDIF + !Initialize some arrays + if (tke_budget .eq. 1) then + dqke(i,:)=qke(i,:) + endif + if (FLAG_QI ) then + sqi(:)=sqi3D(i,:) + else + sqi = 0.0 + endif + if (FLAG_QS ) then + sqs(:)=sqs3D(i,:) + else + sqs = 0.0 + endif + if (icloud_bl > 0) then + CLDFRA_BL1D(:)=CLDFRA_BL(i,:) + QC_BL1D(:) =QC_BL(i,:) + QI_BL1D(:) =QI_BL(i,:) + cldfra_bl1D_old(:)=cldfra_bl(i,:) + qc_bl1D_old(:)=qc_bl(i,:) + qi_bl1D_old(:)=qi_bl(i,:) + else + CLDFRA_BL1D =0.0 + QC_BL1D =0.0 + QI_BL1D =0.0 + cldfra_bl1D_old=0.0 + qc_bl1D_old =0.0 + qi_bl1D_old =0.0 + endif + dz1(kts:kte) =dz(i,kts:kte) + u1(kts:kte) =u(i,kts:kte) + v1(kts:kte) =v(i,kts:kte) + w1(kts:kte) =w(i,kts:kte) + th1(kts:kte) =th(i,kts:kte) + tk1(kts:kte) =T3D(i,kts:kte) + p1(kts:kte) =p(i,kts:kte) + ex1(kts:kte) =exner(i,kts:kte) + rho1(kts:kte) =rho(i,kts:kte) + sqv(kts:kte) =sqv3D(i,kts:kte) !/(1.+qv(i,kts:kte)) + sqc(kts:kte) =sqc3D(i,kts:kte) !/(1.+qv(i,kts:kte)) + qv1(kts:kte) =sqv(kts:kte)/(1.-sqv(kts:kte)) + qc1(kts:kte) =sqc(kts:kte)/(1.-sqv(kts:kte)) + qi1(kts:kte) =sqi(kts:kte)/(1.-sqv(kts:kte)) + qs1(kts:kte) =sqs(kts:kte)/(1.-sqv(kts:kte)) + dqc1(kts:kte) =0.0 + dqi1(kts:kte) =0.0 + dqs1(kts:kte) =0.0 + dqni1(kts:kte) =0.0 + dqnc1(kts:kte) =0.0 + dqnwfa1(kts:kte)=0.0 + dqnifa1(kts:kte)=0.0 + dqnbca1(kts:kte)=0.0 + dozone1(kts:kte)=0.0 + IF (FLAG_QNI ) THEN + qni1(kts:kte)=qni(i,kts:kte) + ELSE + qni1(kts:kte)=0.0 + ENDIF + IF (FLAG_QNC ) THEN + qnc1(kts:kte)=qnc(i,kts:kte) + ELSE + qnc1(kts:kte)=0.0 + ENDIF + IF (FLAG_QNWFA ) THEN + qnwfa1(kts:kte)=qnwfa(i,kts:kte) + ELSE + qnwfa1(kts:kte)=0.0 + ENDIF + IF (FLAG_QNIFA ) THEN + qnifa1(kts:kte)=qnifa(i,kts:kte) + ELSE + qnifa1(kts:kte)=0.0 + ENDIF + IF (FLAG_QNBCA ) THEN + qnbca1(kts:kte)=qnbca(i,kts:kte) + ELSE + qnbca1(kts:kte)=0.0 + ENDIF + IF (FLAG_OZONE ) THEN + ozone1(kts:kte)=ozone(i,kts:kte) + ELSE + ozone1(kts:kte)=0.0 + ENDIF + el(kts:kte) =el_pbl(i,kts:kte) + qke1(kts:kte)=qke(i,kts:kte) + sh(kts:kte) =sh3d(i,kts:kte) + sm(kts:kte) =sm3d(i,kts:kte) + tsq1(kts:kte)=tsq(i,kts:kte) + qsq1(kts:kte)=qsq(i,kts:kte) + cov1(kts:kte)=cov(i,kts:kte) + if (spp_pbl==1) then + rstoch_col(kts:kte)=pattern_spp_pbl(i,kts:kte) + else + rstoch_col(kts:kte)=0.0 + endif + !edmf + edmf_a1 =0.0 + edmf_w1 =0.0 + edmf_qc1 =0.0 + s_aw1 =0.0 + s_awthl1 =0.0 + s_awqt1 =0.0 + s_awqv1 =0.0 + s_awqc1 =0.0 + s_awu1 =0.0 + s_awv1 =0.0 + s_awqke1 =0.0 + s_awqnc1 =0.0 + s_awqni1 =0.0 + s_awqnwfa1 =0.0 + s_awqnifa1 =0.0 + s_awqnbca1 =0.0 + ![EWDD] + edmf_a_dd1 =0.0 + edmf_w_dd1 =0.0 + edmf_qc_dd1=0.0 + sd_aw1 =0.0 + sd_awthl1 =0.0 + sd_awqt1 =0.0 + sd_awqv1 =0.0 + sd_awqc1 =0.0 + sd_awu1 =0.0 + sd_awv1 =0.0 + sd_awqke1 =0.0 + sub_thl =0.0 + sub_sqv =0.0 + sub_u =0.0 + sub_v =0.0 + det_thl =0.0 + det_sqv =0.0 + det_sqc =0.0 + det_u =0.0 + det_v =0.0 + + do k = kts,kte + if (k==kts) then + zw(k)=0. + else + zw(k)=zw(k-1)+dz(i,k-1) + endif + !keep snow out for now - increases ceiling bias + sqw(k)= sqv(k)+sqc(k)+sqi(k)!+sqs(k) + thl(k)= th1(k) - xlvcp/ex1(k)*sqc(k) & + & - xlscp/ex1(k)*(sqi(k)+sqs(k)) + !Use form from Tripoli and Cotton (1981) with their + !suggested min temperature to improve accuracy. + !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) & + ! & - xlscp/MAX(tk1(k),TKmin)*sqi(k)) + thetav(k)=th1(k)*(1.+0.608*sqv(k)) + enddo ! end k + zw(kte+1)=zw(kte)+dz(i,kte) + + !initialize smoke/chem arrays (if used): + if ( mix_chem ) then + do ic = 1,ndvel + vd1(ic) = vdep(i,ic) ! dry deposition velocity + chem1(kts,ic) = chem3d(i,kts,ic) + enddo + do k = kts+1,kte + do ic = 1,nchem + chem1(k,ic) = chem3d(i,k,ic) + enddo + enddo + else + do ic = 1,ndvel + vd1(ic) = 0. ! dry deposition velocity + chem1(kts,ic) = 0. + enddo + do k = kts+1,kte + do ic = 1,nchem + chem1(k,ic) = 0. + enddo + enddo + endif + s_awchem1 = 0.0 !> - Call get_pblh() to calculate the hybrid \f$\theta_{vli}-TKE\f$ !! PBL height diagnostic. -! CALL GET_PBLH(KTS,KTE,PBLH(i),thetav,& - CALL GET_PBLH(KTS,KTE,PBLH(i),thvl,& - & Qke1,zw,dz1,xland(i),KPBL(i)) + CALL GET_PBLH(KTS,KTE,PBLH(i),thetav,& + & Qke1,zw,dz1,xland(i),KPBL(i)) !> - Call scale_aware() to calculate the similarity functions, !! \f$P_{\sigma-PBL}\f$ and \f$P_{\sigma-shcu}\f$, to control !! the scale-adaptive behaviour for the local and nonlocal !! components, respectively. - IF (scaleaware > 0.) THEN - CALL SCALE_AWARE(dx(i),PBLH(i),Psig_bl(i),Psig_shcu(i)) - ELSE - Psig_bl(i)=1.0 - Psig_shcu(i)=1.0 - ENDIF + if (scaleaware > 0.) then + call SCALE_AWARE(dx(i),PBLH(i),Psig_bl(i),Psig_shcu(i)) + else + Psig_bl(i)=1.0 + Psig_shcu(i)=1.0 + endif - sqcg= 0.0 !ill-defined variable; qcg has been removed - cpm=cp*(1.+0.84*qv1(kts)) - exnerg=(ps(i)/p1000mb)**rcp - - !----------------------------------------------------- - !ORIGINAL CODE - !flt = hfx(i)/( rho(i,kts)*cpm ) & - ! +xlvcp*ch(i)*(sqc(kts)/exner(i,kts) -sqcg/exnerg) - !flq = qfx(i)/ rho(i,kts) & - ! -ch(i)*(sqc(kts) -sqcg ) - !----------------------------------------------------- - ! Katata-added - The deposition velocity of cloud (fog) - ! water is used instead of CH. - !flt = hfx(i)/( rho(i,kts)*cpm ) & - ! & +xlvcp*vdfg(i)*(sqc(kts)/exner(i,kts)- sqcg/exnerg) - !flq = qfx(i)/ rho(i,kts) & - ! & -vdfg(i)*(sqc(kts) - sqcg ) - !----------------------------------------------------- - flqv = qfx(i)/rho1(kts) - flqc = -vdfg(i)*(sqc(kts) - sqcg ) - th_sfc = ts(i)/ex1(kts) - - ! TURBULENT FLUX FOR TKE BOUNDARY CONDITIONS - flq =flqv+flqc !! LATENT - flt =hfx(i)/(rho1(kts)*cpm )-xlvcp*flqc/ex1(kts) !! Temperature flux - fltv=flt + flqv*p608*th_sfc !! Virtual temperature flux - - ! Update 1/L using updated sfc heat flux and friction velocity - rmol(i) = -karman*gtr*fltv/max(ust(i)**3,1.0e-6) - zet = 0.5*dz(i,kts)*rmol(i) - zet = MAX(zet, -20.) - zet = MIN(zet, 20.) - !if(i.eq.idbg)print*,"updated z/L=",zet - if (bl_mynn_stfunc == 0) then - !Original Kansas-type stability functions - if ( zet >= 0.0 ) then - pmz = 1.0 + (cphm_st-1.0) * zet - phh = 1.0 + cphh_st * zet - else - pmz = 1.0/ (1.0-cphm_unst*zet)**0.25 - zet - phh = 1.0/SQRT(1.0-cphh_unst*zet) - end if + sqcg= 0.0 !ill-defined variable; qcg has been removed + cpm=cp*(1.+0.84*qv1(kts)) + exnerg=(ps(i)/p1000mb)**rcp + + !----------------------------------------------------- + !ORIGINAL CODE + !flt = hfx(i)/( rho(i,kts)*cpm ) & + ! +xlvcp*ch(i)*(sqc(kts)/exner(i,kts) -sqcg/exnerg) + !flq = qfx(i)/ rho(i,kts) & + ! -ch(i)*(sqc(kts) -sqcg ) + !----------------------------------------------------- + flqv = qfx(i)/rho1(kts) + flqc = 0.0 !currently no sea-spray fluxes, fog settling handled elsewhere + th_sfc = ts(i)/ex1(kts) + + ! TURBULENT FLUX FOR TKE BOUNDARY CONDITIONS + flq =flqv+flqc !! LATENT + flt =hfx(i)/(rho1(kts)*cpm )-xlvcp*flqc/ex1(kts) !! Temperature flux + fltv=flt + flqv*p608*th_sfc !! Virtual temperature flux + + ! Update 1/L using updated sfc heat flux and friction velocity + rmol(i) = -karman*gtr*fltv/max(ust(i)**3,1.0e-6) + zet = 0.5*dz(i,kts)*rmol(i) + zet = MAX(zet, -20.) + zet = MIN(zet, 20.) + !if(i.eq.idbg)print*,"updated z/L=",zet + if (bl_mynn_stfunc == 0) then + !Original Kansas-type stability functions + if ( zet >= 0.0 ) then + pmz = 1.0 + (cphm_st-1.0) * zet + phh = 1.0 + cphh_st * zet else - !Updated stability functions (Puhales, 2020) - phi_m = phim(zet) - pmz = phi_m - zet - phh = phih(zet) + pmz = 1.0/ (1.0-cphm_unst*zet)**0.25 - zet + phh = 1.0/SQRT(1.0-cphh_unst*zet) end if + else + !Updated stability functions (Puhales, 2020) + phi_m = phim(zet) + pmz = phi_m - zet + phh = phih(zet) + end if !> - Call mym_condensation() to calculate the nonconvective component !! of the subgrid cloud fraction and mixing ratio as well as the functions !! used to calculate the buoyancy flux. Different cloud PDFs can be !! selected by use of the namelist parameter \p bl_mynn_cloudpdf. - CALL mym_condensation ( kts,kte, & - &dx(i),dz1,zw,thl,sqw,sqv,sqc,sqi,& - &p1,ex1,tsq1,qsq1,cov1, & - &Sh,el,bl_mynn_cloudpdf, & - &qc_bl1D,qi_bl1D,cldfra_bl1D, & - &PBLH(i),HFX(i), & - &Vt, Vq, th1, sgm, rmol(i), & - &spp_pbl, rstoch_col ) + call mym_condensation (kts,kte, & + &dx(i),dz1,zw,xland(i), & + &thl,sqw,sqv,sqc,sqi,sqs, & + &p1,ex1,tsq1,qsq1,cov1, & + &Sh,el,bl_mynn_cloudpdf, & + &qc_bl1D,qi_bl1D,cldfra_bl1D, & + &PBLH(i),HFX(i), & + &Vt, Vq, th1, sgm, rmol(i), & + &spp_pbl, rstoch_col ) !> - Add TKE source driven by cloud top cooling !! Calculate the buoyancy production of TKE from cloud-top cooling when !! \p bl_mynn_topdown =1. - IF (bl_mynn_topdown.eq.1)then - CALL topdown_cloudrad(kts,kte,dz1,zw, & - &xland(i),kpbl(i),PBLH(i), & - &sqc,sqi,sqw,thl,th1,ex1,p1,rho1,thetav, & - &cldfra_bl1D,rthraten, & - &maxKHtopdown(i),KHtopdown,TKEprodTD ) - ELSE - maxKHtopdown(i) = 0.0 - KHtopdown(kts:kte) = 0.0 - TKEprodTD(kts:kte) = 0.0 - ENDIF + if (bl_mynn_topdown.eq.1) then + call topdown_cloudrad(kts,kte,dz1,zw, & + &xland(i),kpbl(i),PBLH(i), & + &sqc,sqi,sqw,thl,th1,ex1,p1,rho1,thetav, & + &cldfra_bl1D,rthraten(i,:), & + &maxKHtopdown(i),KHtopdown,TKEprodTD ) + else + maxKHtopdown(i) = 0.0 + KHtopdown(kts:kte) = 0.0 + TKEprodTD(kts:kte) = 0.0 + endif - IF (bl_mynn_edmf > 0) THEN - !PRINT*,"Calling DMP Mass-Flux: i= ",i - CALL DMP_mf( & - &kts,kte,delt,zw,dz1,p1,rho1, & - &bl_mynn_edmf_mom, & - &bl_mynn_edmf_tke, & - &bl_mynn_mixscalars, & - &u1,v1,w1,th1,thl,thetav,tk1, & - &sqw,sqv,sqc,qke1, & - &qnc1,qni1,qnwfa1,qnifa1, & - &ex1,Vt,Vq,sgm, & - &ust(i),flt,fltv,flq,flqv, & - &PBLH(i),KPBL(i),DX(i), & - &xland(i),th_sfc, & + if (bl_mynn_edmf > 0) then + !PRINT*,"Calling DMP Mass-Flux: i= ",i + call DMP_mf( & + &kts,kte,delt,zw,dz1,p1,rho1, & + &bl_mynn_edmf_mom, & + &bl_mynn_edmf_tke, & + &bl_mynn_mixscalars, & + &u1,v1,w1,th1,thl,thetav,tk1, & + &sqw,sqv,sqc,qke1, & + &qnc1,qni1,qnwfa1,qnifa1,qnbca1, & + &ex1,Vt,Vq,sgm, & + &ust(i),flt,fltv,flq,flqv, & + &PBLH(i),KPBL(i),DX(i), & + &xland(i),th_sfc, & ! now outputs - tendencies - ! &,dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf & + ! &,dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf & ! outputs - updraft properties - & edmf_a1,edmf_w1,edmf_qt1, & - & edmf_thl1,edmf_ent1,edmf_qc1, & + &edmf_a1,edmf_w1,edmf_qt1, & + &edmf_thl1,edmf_ent1,edmf_qc1, & ! for the solver - & s_aw1,s_awthl1,s_awqt1, & - & s_awqv1,s_awqc1, & - & s_awu1,s_awv1,s_awqke1, & - & s_awqnc1,s_awqni1, & - & s_awqnwfa1,s_awqnifa1, & - & sub_thl,sub_sqv, & - & sub_u,sub_v, & - & det_thl,det_sqv,det_sqc, & - & det_u,det_v, & + &s_aw1,s_awthl1,s_awqt1, & + &s_awqv1,s_awqc1, & + &s_awu1,s_awv1,s_awqke1, & + &s_awqnc1,s_awqni1, & + &s_awqnwfa1,s_awqnifa1,s_awqnbca1, & + &sub_thl,sub_sqv, & + &sub_u,sub_v, & + &det_thl,det_sqv,det_sqc, & + &det_u,det_v, & ! chem/smoke mixing - & nchem,chem1,s_awchem1, & - & mix_chem, & - & qc_bl1D,cldfra_bl1D, & - & qc_bl1D_old,cldfra_bl1D_old, & - & FLAG_QC,FLAG_QI, & - & FLAG_QNC,FLAG_QNI, & - & FLAG_QNWFA,FLAG_QNIFA, & - & Psig_shcu(i), & - & nupdraft(i),ktop_plume(i), & - & maxmf(i),ztop_plume, & - & spp_pbl,rstoch_col ) - ENDIF + &nchem,chem1,s_awchem1, & + &mix_chem, & + &qc_bl1D,cldfra_bl1D, & + &qc_bl1D_old,cldfra_bl1D_old, & + &FLAG_QC,FLAG_QI, & + &FLAG_QNC,FLAG_QNI, & + &FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA, & + &Psig_shcu(i), & + &nupdraft(i),ktop_plume(i), & + &maxmf(i),ztop_plume, & + &spp_pbl,rstoch_col ) + endif - IF (bl_mynn_edmf_dd == 1) THEN - CALL DDMF_JPL(kts,kte,delt,zw,dz1,p1, & - &u1,v1,th1,thl,thetav,tk1, & - sqw,sqv,sqc,rho1,ex1, & - &ust(i),flt,flq, & - &PBLH(i),KPBL(i), & - &edmf_a_dd1,edmf_w_dd1,edmf_qt_dd1, & - &edmf_thl_dd1,edmf_ent_dd1, & - &edmf_qc_dd1, & - &sd_aw1,sd_awthl1,sd_awqt1, & - &sd_awqv1,sd_awqc1,sd_awu1,sd_awv1, & - &sd_awqke1, & - &qc_bl1d,cldfra_bl1d, & - &rthraten(i,:) ) - ENDIF + if (bl_mynn_edmf_dd == 1) then + call DDMF_JPL(kts,kte,delt,zw,dz1,p1, & + &u1,v1,th1,thl,thetav,tk1, & + &sqw,sqv,sqc,rho1,ex1, & + &ust(i),flt,flq, & + &PBLH(i),KPBL(i), & + &edmf_a_dd1,edmf_w_dd1,edmf_qt_dd1, & + &edmf_thl_dd1,edmf_ent_dd1, & + &edmf_qc_dd1, & + &sd_aw1,sd_awthl1,sd_awqt1, & + &sd_awqv1,sd_awqc1,sd_awu1,sd_awv1, & + &sd_awqke1, & + &qc_bl1d,cldfra_bl1d, & + &rthraten(i,:) ) + endif - !Capability to substep the eddy-diffusivity portion - !do nsub = 1,2 - delt2 = delt !*0.5 !only works if topdown=0 - - CALL mym_turbulence ( & - &kts,kte,closure, & - &dz1, DX(i), zw, & - &u1, v1, thl, thetav, sqc, sqw, & - &thlsg, sqwsg, & - &qke1, tsq1, qsq1, cov1, & - &vt, vq, & - &rmol(i), flt, flq, & - &PBLH(i),th1, & - &Sh,Sm,el, & - &Dfm,Dfh,Dfq, & - &Tcd,Qcd,Pdk, & - &Pdt,Pdq,Pdc, & - &qWT1,qSHEAR1,qBUOY1,qDISS1, & - &bl_mynn_tkebudget, & - &Psig_bl(i),Psig_shcu(i), & - &cldfra_bl1D,bl_mynn_mixlength, & - &edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf, & - &TKEprodTD, & - &spp_pbl,rstoch_col) + !Capability to substep the eddy-diffusivity portion + !do nsub = 1,2 + delt2 = delt !*0.5 !only works if topdown=0 + + call mym_turbulence( & + &kts,kte,xland(i),closure, & + &dz1, DX(i), zw, & + &u1, v1, thl, thetav, sqc, sqw, & + &qke1, tsq1, qsq1, cov1, & + &vt, vq, & + &rmol(i), flt, fltv, flq, & + &PBLH(i),th1, & + &Sh,Sm,el, & + &Dfm,Dfh,Dfq, & + &Tcd,Qcd,Pdk, & + &Pdt,Pdq,Pdc, & + &qWT1,qSHEAR1,qBUOY1,qDISS1, & + &tke_budget, & + &Psig_bl(i),Psig_shcu(i), & + &cldfra_bl1D,bl_mynn_mixlength, & + &edmf_w1,edmf_a1, & + &TKEprodTD, & + &spp_pbl,rstoch_col ) !> - Call mym_predict() to solve TKE and !! \f$\theta^{'2}, q^{'2}, and \theta^{'}q^{'}\f$ !! for the following time step. - CALL mym_predict (kts,kte,closure, & - &delt2, dz1, & - &ust(i), flt, flq, pmz, phh, & - &el, dfq, rho1, pdk, pdt, pdq, pdc,& - &Qke1, Tsq1, Qsq1, Cov1, & - &s_aw1, s_awqke1, bl_mynn_edmf_tke,& - &qWT1, qDISS1,bl_mynn_tkebudget) !! TKE budget (Puhales, 2020) - - if (dheat_opt > 0) then - DO k=kts,kte-1 - ! Set max dissipative heating rate to 7.2 K per hour - diss_heat(k) = MIN(MAX(1.0*(qke1(k)**1.5)/(b1*MAX(0.5*(el(k)+el(k+1)),1.))/cp, 0.0),0.002) - ! Limit heating above 100 mb: - diss_heat(k) = diss_heat(k) * exp(-10000./MAX(p1(k),1.)) - ENDDO - diss_heat(kte) = 0. - else - diss_heat(1:kte) = 0. - endif + call mym_predict(kts,kte,closure, & + &delt2, dz1, & + &ust(i), flt, flq, pmz, phh, & + &el, dfq, rho1, pdk, pdt, pdq, pdc, & + &Qke1, Tsq1, Qsq1, Cov1, & + &s_aw1, s_awqke1, bl_mynn_edmf_tke, & + &qWT1, qDISS1, tke_budget ) + + if (dheat_opt > 0) then + do k=kts,kte-1 + ! Set max dissipative heating rate to 7.2 K per hour + diss_heat(k) = MIN(MAX(1.0*(qke1(k)**1.5)/(b1*MAX(0.5*(el(k)+el(k+1)),1.))/cp, 0.0),0.002) + ! Limit heating above 100 mb: + diss_heat(k) = diss_heat(k) * exp(-10000./MAX(p1(k),1.)) + enddo + diss_heat(kte) = 0. + else + diss_heat(1:kte) = 0. + endif !> - Call mynn_tendencies() to solve for tendencies of !! \f$U, V, \theta, q_{v}, q_{c}, and q_{i}\f$. - CALL mynn_tendencies(kts,kte,i, & - &closure, & - &delt, dz1, rho1, & - &u1, v1, th1, tk1, qv1, & - &qc1, qi1, qnc1, qni1, & - &ps(i), p1, ex1, thl, & - &sqv, sqc, sqi, sqw, & - &qnwfa1, qnifa1, ozone1, & - &ust(i),flt,flq,flqv,flqc, & - &wspd(i),uoce(i),voce(i), & - &tsq1, qsq1, cov1, & - &tcd, qcd, & - &dfm, dfh, dfq, & - &Du1, Dv1, Dth1, Dqv1, & - &Dqc1, Dqi1, Dqnc1, Dqni1, & - &Dqnwfa1, Dqnifa1, Dozone1, & - &vdfg(i), diss_heat, & + call mynn_tendencies(kts,kte,i, & + &delt, dz1, rho1, & + &u1, v1, th1, tk1, qv1, & + &qc1, qi1, qs1, qnc1, qni1, & + &ps(i), p1, ex1, thl, & + &sqv, sqc, sqi, sqs, sqw, & + &qnwfa1, qnifa1, qnbca1, ozone1, & + &ust(i),flt,flq,flqv,flqc, & + &wspd(i),uoce(i),voce(i), & + &tsq1, qsq1, cov1, & + &tcd, qcd, & + &dfm, dfh, dfq, & + &Du1, Dv1, Dth1, Dqv1, & + &Dqc1, Dqi1, Dqs1, Dqnc1, Dqni1, & + &Dqnwfa1, Dqnifa1, Dqnbca1, & + &Dozone1, & + &diss_heat, & ! mass flux components - &s_aw1,s_awthl1,s_awqt1, & - &s_awqv1,s_awqc1,s_awu1,s_awv1, & - &s_awqnc1,s_awqni1, & - &s_awqnwfa1,s_awqnifa1, & - &sd_aw1,sd_awthl1,sd_awqt1, & - &sd_awqv1,sd_awqc1, & - sd_awu1,sd_awv1, & - &sub_thl,sub_sqv, & - &sub_u,sub_v, & - &det_thl,det_sqv,det_sqc, & - &det_u,det_v, & - &FLAG_QC,FLAG_QI,FLAG_QNC, & - &FLAG_QNI,FLAG_QNWFA,FLAG_QNIFA, & - &cldfra_bl1d, & - &bl_mynn_cloudmix, & - &bl_mynn_mixqt, & - &bl_mynn_edmf, & - &bl_mynn_edmf_mom, & - &bl_mynn_mixscalars ) - - - IF ( rrfs_smoke .and. mix_chem ) THEN - CALL mynn_mix_chem(kts,kte,i, & - &delt, dz1, pblh(i), & - &nchem, kdvel, ndvel, & - &chem1, vd1, & - &rho1,flt, & - &tcd, qcd, & - &dfh, & - &s_aw1,s_awchem1, & - &emis_ant_no(i), & - &frp(i), & - &fire_turb ) - - DO ic = 1,nchem - DO k = kts,kte - chem3d(i,k,ic) = chem1(k,ic) - ENDDO - ENDDO - ENDIF + &s_aw1,s_awthl1,s_awqt1, & + &s_awqv1,s_awqc1,s_awu1,s_awv1, & + &s_awqnc1,s_awqni1, & + &s_awqnwfa1,s_awqnifa1,s_awqnbca1, & + &sd_aw1,sd_awthl1,sd_awqt1, & + &sd_awqv1,sd_awqc1, & + &sd_awu1,sd_awv1, & + &sub_thl,sub_sqv, & + &sub_u,sub_v, & + &det_thl,det_sqv,det_sqc, & + &det_u,det_v, & + &FLAG_QC,FLAG_QI,FLAG_QNC, & + &FLAG_QNI,FLAG_QS, & + &FLAG_QNWFA,FLAG_QNIFA, & + &FLAG_QNBCA, & + &cldfra_bl1d, & + &bl_mynn_cloudmix, & + &bl_mynn_mixqt, & + &bl_mynn_edmf, & + &bl_mynn_edmf_mom, & + &bl_mynn_mixscalars ) + + + if ( mix_chem ) then + if ( rrfs_sd ) then + call mynn_mix_chem(kts,kte,i, & + &delt, dz1, pblh(i), & + &nchem, kdvel, ndvel, & + &chem1, vd1, & + &rho1,flt, & + &tcd, qcd, & + &dfh, & + &s_aw1,s_awchem1, & + &emis_ant_no(i), & + &frp(i), rrfs_sd, & + &enh_mix, smoke_dbg ) + else + call mynn_mix_chem(kts,kte,i, & + &delt, dz1, pblh(i), & + &nchem, kdvel, ndvel, & + &chem1, vd1, & + &rho1,flt, & + &tcd, qcd, & + &dfh, & + &s_aw1,s_awchem1, & + &zero, & + &zero, rrfs_sd, & + &enh_mix, smoke_dbg ) + endif + do ic = 1,nchem + do k = kts,kte + chem3d(i,k,ic) = max(1.e-12, chem1(k,ic)) + enddo + enddo + endif - CALL retrieve_exchange_coeffs(kts,kte,& - &dfm, dfh, dz1, K_m1, K_h1) - - !UPDATE 3D ARRAYS - DO k=KTS,KTE !KTF - exch_m(i,k)=K_m1(k) - exch_h(i,k)=K_h1(k) - RUBLTEN(i,k)=du1(k) - RVBLTEN(i,k)=dv1(k) - RTHBLTEN(i,k)=dth1(k) - RQVBLTEN(i,k)=dqv1(k) - IF(bl_mynn_cloudmix > 0)THEN - IF (FLAG_QC) RQCBLTEN(i,k)=dqc1(k) - IF (FLAG_QI) RQIBLTEN(i,k)=dqi1(k) - ELSE - IF (FLAG_QC) RQCBLTEN(i,k)=0. - IF (FLAG_QI) RQIBLTEN(i,k)=0. - ENDIF - IF(bl_mynn_cloudmix > 0 .AND. bl_mynn_mixscalars > 0)THEN - IF (FLAG_QNC) RQNCBLTEN(i,k)=dqnc1(k) - IF (FLAG_QNI) RQNIBLTEN(i,k)=dqni1(k) - IF (FLAG_QNWFA) RQNWFABLTEN(i,k)=dqnwfa1(k) - IF (FLAG_QNIFA) RQNIFABLTEN(i,k)=dqnifa1(k) - ELSE - IF (FLAG_QNC) RQNCBLTEN(i,k)=0. - IF (FLAG_QNI) RQNIBLTEN(i,k)=0. - IF (FLAG_QNWFA) RQNWFABLTEN(i,k)=0. - IF (FLAG_QNIFA) RQNIFABLTEN(i,k)=0. - ENDIF - DOZONE(i,k)=DOZONE1(k) - - IF(icloud_bl > 0)THEN - !DIAGNOSTIC-DECAY FOR SUBGRID-SCALE CLOUDS - IF (CLDFRA_BL1D(k) < cldfra_bl1D_old(k)) THEN - !DECAY TIMESCALE FOR CALM CONDITION IS THE EDDY TURNOVER - !TIMESCALE, BUT FOR WINDY CONDITIONS, IT IS THE ADVECTIVE - !TIMESCALE. USE THE MINIMUM OF THE TWO. - ts_decay = MIN( 1800., 2.*dx(i)/MAX(SQRT(u1(k)**2 + v1(k)**2),1.0) ) - cldfra_bl(i,k)= MAX(cldfra_bl1D(k),cldfra_bl1D_old(k)-(0.25*delt/ts_decay)) - ! qc_bl2 and qi_bl2 are linked to decay rates - qc_bl2 = MAX(qc_bl1D(k),qc_bl1D_old(k)) - qi_bl2 = MAX(qi_bl1D(k),qi_bl1D_old(k)) - qc_bl(i,k) = MAX(qc_bl1D(k),qc_bl1D_old(k)-(MIN(qc_bl2,1.0E-5) * delt/ts_decay)) - qi_bl(i,k) = MAX(qi_bl1D(k),qi_bl1D_old(k)-(MIN(qi_bl2,1.0E-6) * delt/ts_decay)) - IF (cldfra_bl(i,k) < 0.005 .OR. & - (qc_bl(i,k) + qi_bl(i,k)) < 1E-9) THEN - CLDFRA_BL(i,k)= 0. - QC_BL(i,k) = 0. - QI_BL(i,k) = 0. - ENDIF - ELSE - qc_bl(i,k)=qc_bl1D(k) - qi_bl(i,k)=qi_bl1D(k) - cldfra_bl(i,k)=cldfra_bl1D(k) - ENDIF - ENDIF - - el_pbl(i,k)=el(k) - qke(i,k)=qke1(k) - tsq(i,k)=tsq1(k) - qsq(i,k)=qsq1(k) - cov(i,k)=cov1(k) - sh3d(i,k)=sh(k) - sm3d(i,k)=sm(k) - ENDDO !end-k - - IF ( bl_mynn_tkebudget ) THEN - !! TKE budget is now given in m**2/s**-3 (Puhales, 2020) - !! Lower boundary condtions (using similarity relationships such as the prognostic equation for Qke) - k=kts - qSHEAR1(k)=4.*(ust(i)**3*phi_m/(karman*dz(i,k)))-qSHEAR1(k+1) !! staggered - qBUOY1(k)=4.*(-ust(i)**3*zet/(karman*dz(i,k)))-qBUOY1(k+1) !! staggered - !! unstaggering SHEAR and BUOY and trasfering all TKE budget to 3D array - DO k = kts,kte-1 - qSHEAR(i,k)=0.5*(qSHEAR1(k)+qSHEAR1(k+1)) !!! unstaggering in z - qBUOY(i,k)=0.5*(qBUOY1(k)+qBUOY1(k+1)) !!! unstaggering in z - qWT(i,k)=qWT1(k) - qDISS(i,k)=qDISS1(k) - dqke(i,k)=(qke1(k)-dqke(i,k))*0.5/delt - ENDDO - !! Upper boundary conditions - k=kte - qSHEAR(i,k)=0. - qBUOY(i,k)=0. - qWT(i,k)=0. - qDISS(i,k)=0. - dqke(i,k)=0. - ENDIF + call retrieve_exchange_coeffs(kts,kte, & + &dfm, dfh, dz1, K_m1, K_h1 ) + + !UPDATE 3D ARRAYS + exch_m(i,:) =k_m1(:) + exch_h(i,:) =k_h1(:) + rublten(i,:) =du1(:) + rvblten(i,:) =dv1(:) + rthblten(i,:)=dth1(:) + rqvblten(i,:)=dqv1(:) + if (bl_mynn_cloudmix > 0) then + if (flag_qc) rqcblten(i,:)=dqc1(:) + if (flag_qi) rqiblten(i,:)=dqi1(:) + if (flag_qs) rqsblten(i,:)=dqs1(:) + else + if (flag_qc) rqcblten(i,:)=0. + if (flag_qi) rqiblten(i,:)=0. + if (flag_qs) rqsblten(i,:)=0. + endif + if (bl_mynn_cloudmix > 0 .and. bl_mynn_mixscalars > 0) then + if (flag_qnc) rqncblten(i,:) =dqnc1(:) + if (flag_qni) rqniblten(i,:) =dqni1(:) + if (flag_qnwfa) rqnwfablten(i,:)=dqnwfa1(:) + if (flag_qnifa) rqnifablten(i,:)=dqnifa1(:) + if (flag_qnbca) rqnbcablten(i,:)=dqnbca1(:) + else + if (flag_qnc) rqncblten(i,:) =0. + if (flag_qni) rqniblten(i,:) =0. + if (flag_qnwfa) rqnwfablten(i,:)=0. + if (flag_qnifa) rqnifablten(i,:)=0. + if (flag_qnbca) rqnbcablten(i,:)=0. + endif + dozone(i,:)=dozone1(:) + if (icloud_bl > 0) then + qc_bl(i,:) =qc_bl1D(:) + qi_bl(i,:) =qi_bl1D(:) + cldfra_bl(i,:)=cldfra_bl1D(:) + endif + el_pbl(i,:)=el(:) + qke(i,:) =qke1(:) + tsq(i,:) =tsq1(:) + qsq(i,:) =qsq1(:) + cov(i,:) =cov1(:) + sh3d(i,:) =sh(:) + sm3d(i,:) =sm(:) + + if (tke_budget .eq. 1) then + !! TKE budget is now given in m**2/s**-3 (Puhales, 2020) + !! Lower boundary condtions (using similarity relationships such as the prognostic equation for Qke) + k=kts + qSHEAR1(k) =4.*(ust(i)**3*phi_m/(karman*dz(i,k)))-qSHEAR1(k+1) !! staggered + qBUOY1(k) =4.*(-ust(i)**3*zet/(karman*dz(i,k)))-qBUOY1(k+1) !! staggered + !! unstaggering SHEAR and BUOY and trasfering all TKE budget to 3D array + do k = kts,kte-1 + qSHEAR(i,k)=0.5*(qSHEAR1(k)+qSHEAR1(k+1)) !!! unstaggering in z + qBUOY(i,k) =0.5*(qBUOY1(k)+qBUOY1(k+1)) !!! unstaggering in z + qWT(i,k) =qWT1(k) + qDISS(i,k) =qDISS1(k) + dqke(i,k) =(qke1(k)-dqke(i,k))*0.5/delt + enddo + !! Upper boundary conditions + k=kte + qSHEAR(i,k) =0. + qBUOY(i,k) =0. + qWT(i,k) =0. + qDISS(i,k) =0. + dqke(i,k) =0. + endif - !update updraft/downdraft properties - if (bl_mynn_output > 0) THEN !research mode == 1 - if (bl_mynn_edmf > 0) THEN - DO k = kts,kte - edmf_a(i,k)=edmf_a1(k) - edmf_w(i,k)=edmf_w1(k) - edmf_qt(i,k)=edmf_qt1(k) - edmf_thl(i,k)=edmf_thl1(k) - edmf_ent(i,k)=edmf_ent1(k) - edmf_qc(i,k)=edmf_qc1(k) - sub_thl3D(i,k)=sub_thl(k) - sub_sqv3D(i,k)=sub_sqv(k) - det_thl3D(i,k)=det_thl(k) - det_sqv3D(i,k)=det_sqv(k) - ENDDO - endif -! if (bl_mynn_edmf_dd > 0) THEN -! DO k = kts,kte -! edmf_a_dd(i,k)=edmf_a_dd1(k) -! edmf_w_dd(i,k)=edmf_w_dd1(k) -! edmf_qt_dd(i,k)=edmf_qt_dd1(k) -! edmf_thl_dd(i,k)=edmf_thl_dd1(k) -! edmf_ent_dd(i,k)=edmf_ent_dd1(k) -! edmf_qc_dd(i,k)=edmf_qc_dd1(k) -! ENDDO -! ENDIF - ENDIF + !update updraft/downdraft properties + if (bl_mynn_output > 0) then !research mode == 1 + if (bl_mynn_edmf > 0) then + edmf_a(i,:) =edmf_a1(:) + edmf_w(i,:) =edmf_w1(:) + edmf_qt(i,:) =edmf_qt1(:) + edmf_thl(i,:) =edmf_thl1(:) + edmf_ent(i,:) =edmf_ent1(:) + edmf_qc(i,:) =edmf_qc1(:) + sub_thl3D(i,:)=sub_thl(:) + sub_sqv3D(i,:)=sub_sqv(:) + det_thl3D(i,:)=det_thl(:) + det_sqv3D(i,:)=det_sqv(:) + endif + !if (bl_mynn_edmf_dd > 0) THEN + ! edmf_a_dd(i,:) =edmf_a_dd1(:) + ! edmf_w_dd(i,:) =edmf_w_dd1(:) + ! edmf_qt_dd(i,:) =edmf_qt_dd1(:) + ! edmf_thl_dd(i,:)=edmf_thl_dd1(:) + ! edmf_ent_dd(i,:)=edmf_ent_dd1(:) + ! edmf_qc_dd(i,:) =edmf_qc_dd1(:) + !endif + endif - !*** Begin debug prints - IF ( debug_code .and. (i .eq. idbg)) THEN - IF ( ABS(QFX(i))>.001)print*,& - "SUSPICIOUS VALUES AT: i=",i," QFX=",QFX(i) - IF ( ABS(HFX(i))>1100.)print*,& - "SUSPICIOUS VALUES AT: i=",i," HFX=",HFX(i) - DO k = kts,kte - IF ( sh(k) < 0. .OR. sh(k)> 200.)print*,& - "SUSPICIOUS VALUES AT: i,k=",i,k," sh=",sh(k) - IF ( ABS(vt(k)) > 0.9 )print*,& - "SUSPICIOUS VALUES AT: i,k=",i,k," vt=",vt(k) - IF ( ABS(vq(k)) > 6000.)print*,& - "SUSPICIOUS VALUES AT: i,k=",i,k," vq=",vq(k) - IF ( qke(i,k) < -1. .OR. qke(i,k)> 200.)print*,& - "SUSPICIOUS VALUES AT: i,k=",i,k," qke=",qke(i,k) - IF ( el_pbl(i,k) < 0. .OR. el_pbl(i,k)> 1500.)print*,& - "SUSPICIOUS VALUES AT: i,k=",i,k," el_pbl=",el_pbl(i,k) - IF ( exch_m(i,k) < 0. .OR. exch_m(i,k)> 2000.)print*,& - "SUSPICIOUS VALUES AT: i,k=",i,k," exxch_m=",exch_m(i,k) - IF (icloud_bl > 0) then - IF( cldfra_bl(i,k) < 0.0 .OR. cldfra_bl(i,k)> 1.)THEN - PRINT*,"SUSPICIOUS VALUES: CLDFRA_BL=",cldfra_bl(i,k)," qc_bl=",QC_BL(i,k) - ENDIF - ENDIF - - !IF (I==IMD .AND. J==JMD) THEN - ! PRINT*,"MYNN DRIVER END: k=",k," sh=",sh(k) - ! PRINT*," sqw=",sqw(k)," thl=",thl(k)," exch_m=",exch_m(i,k) - ! PRINT*," xland=",xland(i)," rmol=",rmol(i)," ust=",ust(i) - ! PRINT*," qke=",qke(i,k)," el=",el_pbl(i,k)," tsq=",tsq(i,k) - ! PRINT*," PBLH=",PBLH(i)," u=",u(i,k)," v=",v(i,k) - ! PRINT*," vq=",vq(k)," vt=",vt(k)," vdfg=",vdfg(i) - !ENDIF - ENDDO !end-k - ENDIF - !*** End debug prints + !*** Begin debug prints + if ( debug_code .and. (i .eq. idbg)) THEN + if ( ABS(QFX(i))>.001)print*,& + "SUSPICIOUS VALUES AT: i=",i," QFX=",QFX(i) + if ( ABS(HFX(i))>1100.)print*,& + "SUSPICIOUS VALUES AT: i=",i," HFX=",HFX(i) + do k = kts,kte + IF ( sh(k) < 0. .OR. sh(k)> 200.)print*,& + "SUSPICIOUS VALUES AT: i,k=",i,k," sh=",sh(k) + IF ( ABS(vt(k)) > 2.0 )print*,& + "SUSPICIOUS VALUES AT: i,k=",i,k," vt=",vt(k) + IF ( ABS(vq(k)) > 7000.)print*,& + "SUSPICIOUS VALUES AT: i,k=",i,k," vq=",vq(k) + IF ( qke(i,k) < -1. .OR. qke(i,k)> 200.)print*,& + "SUSPICIOUS VALUES AT: i,k=",i,k," qke=",qke(i,k) + IF ( el_pbl(i,k) < 0. .OR. el_pbl(i,k)> 1500.)print*,& + "SUSPICIOUS VALUES AT: i,k=",i,k," el_pbl=",el_pbl(i,k) + IF ( exch_m(i,k) < 0. .OR. exch_m(i,k)> 2000.)print*,& + "SUSPICIOUS VALUES AT: i,k=",i,k," exxch_m=",exch_m(i,k) + IF (icloud_bl > 0) then + IF ( cldfra_bl(i,k) < 0.0 .OR. cldfra_bl(i,k)> 1.)THEN + PRINT*,"SUSPICIOUS VALUES: CLDFRA_BL=",cldfra_bl(i,k)," qc_bl=",QC_BL(i,k) + ENDIF + ENDIF - !JOE-add tke_pbl for coupling w/shallow-cu schemes (TKE_PBL = QKE/2.) - ! TKE_PBL is defined on interfaces, while QKE is at middle of layer. - !tke_pbl(i,kts) = 0.5*MAX(qke(i,kts),1.0e-10) - !DO k = kts+1,kte - ! afk = dz1(k)/( dz1(k)+dz1(k-1) ) - ! abk = 1.0 -afk - ! tke_pbl(i,k) = 0.5*MAX(qke(i,k)*abk+qke(i,k-1)*afk,1.0e-3) - !ENDDO + !IF (I==IMD .AND. J==JMD) THEN + ! PRINT*,"MYNN DRIVER END: k=",k," sh=",sh(k) + ! PRINT*," sqw=",sqw(k)," thl=",thl(k)," exch_m=",exch_m(i,k) + ! PRINT*," xland=",xland(i)," rmol=",rmol(i)," ust=",ust(i) + ! PRINT*," qke=",qke(i,k)," el=",el_pbl(i,k)," tsq=",tsq(i,k) + ! PRINT*," PBLH=",PBLH(i)," u=",u(i,k)," v=",v(i,k) + ! PRINT*," vq=",vq(k)," vt=",vt(k) + !ENDIF + enddo !end-k + endif - ENDDO !end i-loop + enddo !end i-loop !ACF copy qke into qke_adv if using advection IF (bl_mynn_tkeadvect) THEN @@ -1549,13 +1431,7 @@ END SUBROUTINE mynn_bl_driver !> @} !======================================================================= -!> This subroutine gives the closure constants and initializes the -!! turbulent qantities. ! SUBROUTINE mym_initialize: -! ================================================================== -! This subroutine computes the length scales up and down -! and then computes the min, average of the up/down length scales, and also -! considers the distance to the surface. ! ! Input variables: ! iniflag : <>0; turbulent quantities will be initialized @@ -1607,47 +1483,44 @@ END SUBROUTINE mynn_bl_driver ! !------------------------------------------------------------------- -!>\ingroup gp_mynnedmf +!>\ingroup gsd_mynn_edmf !! This subroutine initializes the mixing length, TKE, \f$\theta^{'2}\f$, !! \f$q^{'2}\f$, and \f$\theta^{'}q^{'}\f$. !!\section gen_mym_ini GSD MYNN-EDMF mym_initialize General Algorithm !> @{ SUBROUTINE mym_initialize ( & - & kts,kte, & + & kts,kte,xland, & & dz, dx, zw, & & u, v, thl, qw, & - & thlsg, qwsg, & ! & ust, rmo, pmz, phh, flt, flq, & & zi, theta, thetav, sh, sm, & & ust, rmo, el, & & Qke, Tsq, Qsq, Cov, Psig_bl, cldfra_bl1D, & & bl_mynn_mixlength, & - & edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf, & + & edmf_w1,edmf_a1, & & INITIALIZE_QKE, & & spp_pbl,rstoch_col) ! !------------------------------------------------------------------- INTEGER, INTENT(IN) :: kts,kte - INTEGER, INTENT(IN) :: bl_mynn_mixlength,bl_mynn_edmf + INTEGER, INTENT(IN) :: bl_mynn_mixlength LOGICAL, INTENT(IN) :: INITIALIZE_QKE ! REAL, INTENT(IN) :: ust, rmo, pmz, phh, flt, flq - REAL, INTENT(IN) :: ust, rmo, Psig_bl, dx + REAL, INTENT(IN) :: rmo, Psig_bl, xland + REAL(kind=kind_phys), INTENT(IN) :: dx, ust, zi REAL, DIMENSION(kts:kte), INTENT(in) :: dz REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,qw,cldfra_bl1D,& - edmf_w1,edmf_a1,edmf_qc1 + edmf_w1,edmf_a1 REAL, DIMENSION(kts:kte), INTENT(out) :: tsq,qsq,cov REAL, DIMENSION(kts:kte), INTENT(inout) :: el,qke - REAL, DIMENSION(kts:kte) :: & &ql,pdk,pdt,pdq,pdc,dtl,dqw,dtv,& &gm,gh,sm,sh,qkw,vt,vq INTEGER :: k,l,lmax - REAL :: phm,vkz,elq,elv,b1l,b2l,pmz=1.,phh=1.,flt=0.,flq=0.,tmpq - REAL :: zi - REAL, DIMENSION(kts:kte) :: theta,thetav,thlsg,qwsg - + REAL :: phm,vkz,elq,elv,b1l,b2l,pmz=1.,phh=1.,flt=0.,fltv=0.,flq=0.,tmpq + REAL, DIMENSION(kts:kte) :: theta,thetav REAL, DIMENSION(kts:kte) :: rstoch_col INTEGER ::spp_pbl @@ -1662,7 +1535,6 @@ SUBROUTINE mym_initialize ( & CALL mym_level2 ( kts,kte, & & dz, & & u, v, thl, thetav, qw, & - & thlsg, qwsg, & & ql, vt, vq, & & dtl, dqw, dtv, gm, gh, sm, sh ) ! @@ -1701,17 +1573,18 @@ SUBROUTINE mym_initialize ( & DO l = 1,lmax ! !> - call mym_length() to calculate the master length scale. - CALL mym_length ( & - & kts,kte, & - & dz, dx, zw, & - & rmo, flt, flq, & - & vt, vq, & - & u, v, qke, & - & dtv, & - & el, & - & zi,theta, & - & qkw,Psig_bl,cldfra_bl1D,bl_mynn_mixlength,& - & edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf) + CALL mym_length ( & + & kts,kte,xland, & + & dz, dx, zw, & + & rmo, flt, fltv, flq, & + & vt, vq, & + & u, v, qke, & + & dtv, & + & el, & + & zi,theta, & + & qkw,Psig_bl,cldfra_bl1D, & + & bl_mynn_mixlength, & + & edmf_w1,edmf_a1 ) ! DO k = kts+1,kte elq = el(k)*qkw(k) @@ -1795,7 +1668,7 @@ END SUBROUTINE mym_initialize ! These are defined on the walls of the grid boxes. ! -!>\ingroup gp_mynnedmf +!>\ingroup gsd_mynn_edmf !! This subroutine calculates the level 2, non-dimensional wind shear !! \f$G_M\f$ and vertical temperature gradient \f$G_H\f$ as well as !! the level 2 stability funcitons \f$S_h\f$ and \f$S_m\f$. @@ -1821,7 +1694,6 @@ END SUBROUTINE mym_initialize SUBROUTINE mym_level2 (kts,kte, & & dz, & & u, v, thl, thetav, qw, & - & thlsg, qwsg, & & ql, vt, vq, & & dtl, dqw, dtv, gm, gh, sm, sh ) ! @@ -1836,7 +1708,7 @@ SUBROUTINE mym_level2 (kts,kte, & REAL, DIMENSION(kts:kte), INTENT(in) :: dz REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,qw,ql,vt,vq,& - thetav,thlsg,qwsg + thetav REAL, DIMENSION(kts:kte), INTENT(out) :: & &dtl,dqw,dtv,gm,gh,sm,sh @@ -1873,11 +1745,7 @@ SUBROUTINE mym_level2 (kts,kte, & duz = ( u(k)-u(k-1) )**2 +( v(k)-v(k-1) )**2 duz = duz /dzk**2 dtz = ( thl(k)-thl(k-1) )/( dzk ) - !Alternatively, use SGS clouds for thl - !dtz = ( thlsg(k)-thlsg(k-1) )/( dzk ) dqz = ( qw(k)-qw(k-1) )/( dzk ) - !Alternatively, use SGS clouds for qw - !dqz = ( qwsg(k)-qwsg(k-1) )/( dzk ) ! vtt = 1.0 +vt(k)*abk +vt(k-1)*afk ! Beta-theta in NN09, Eq. 39 vqq = tv0 +vq(k)*abk +vq(k-1)*afk ! Beta-q @@ -1951,19 +1819,21 @@ END SUBROUTINE mym_level2 ! NOTE: the mixing lengths are meant to be calculated at the full- ! sigmal levels (or interfaces beween the model layers). ! -!>\ingroup gp_mynnedmf +!>\ingroup gsd_mynn_edmf !! This subroutine calculates the mixing lengths. SUBROUTINE mym_length ( & - & kts,kte, & + & kts,kte,xland, & & dz, dx, zw, & - & rmo, flt, flq, & + & rmo, flt, fltv, flq, & & vt, vq, & & u1, v1, qke, & & dtv, & & el, & - & zi,theta, & - & qkw,Psig_bl,cldfra_bl1D,bl_mynn_mixlength,& - & edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf) + & zi, theta, qkw, & + & Psig_bl, cldfra_bl1D, & + & bl_mynn_mixlength, & + & edmf_w1,edmf_a1 ) + !------------------------------------------------------------------- INTEGER, INTENT(IN) :: kts,kte @@ -1973,12 +1843,13 @@ SUBROUTINE mym_length ( & # define kte HARDCODE_VERTICAL #endif - INTEGER, INTENT(IN) :: bl_mynn_mixlength,bl_mynn_edmf + INTEGER, INTENT(IN) :: bl_mynn_mixlength REAL, DIMENSION(kts:kte), INTENT(in) :: dz REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw - REAL, INTENT(in) :: rmo,flt,flq,Psig_bl,dx + REAL, INTENT(in) :: rmo,flt,fltv,flq,Psig_bl,xland + REAL(kind=kind_phys), INTENT(IN) :: dx,zi REAL, DIMENSION(kts:kte), INTENT(IN) :: u1,v1,qke,vt,vq,cldfra_bl1D,& - edmf_w1,edmf_a1,edmf_qc1 + edmf_w1,edmf_a1 REAL, DIMENSION(kts:kte), INTENT(out) :: qkw, el REAL, DIMENSION(kts:kte), INTENT(in) :: dtv @@ -1986,7 +1857,7 @@ SUBROUTINE mym_length ( & REAL, DIMENSION(kts:kte), INTENT(IN) :: theta REAL, DIMENSION(kts:kte) :: qtke,elBLmin,elBLavg,thetaw - REAL :: wt,wt2,zi,zi2,h1,h2,hs,elBLmin0,elBLavg0,cldavg + REAL :: wt,wt2,zi2,h1,h2,hs,elBLmin0,elBLavg0,cldavg ! THE FOLLOWING CONSTANTS ARE IMPORTANT FOR REGULATING THE ! MIXING LENGTHS: @@ -2011,13 +1882,12 @@ SUBROUTINE mym_length ( & !SURFACE LAYER LENGTH SCALE MODS TO REDUCE IMPACT IN UPPER BOUNDARY LAYER REAL, PARAMETER :: ZSLH = 100. !< Max height correlated to surface conditions (m) REAL, PARAMETER :: CSL = 2. !< CSL = constant of proportionality to L O(1) - REAL :: z_m INTEGER :: i,j,k REAL :: afk,abk,zwk,zwk1,dzk,qdz,vflx,bv,tau_cloud,wstar,elb,els, & - & els1,elf,el_stab,el_unstab,el_mf,el_stab_mf,elb_mf, & - & PBLH_PLUS_ENT,Uonset,Ugrid,el_les + & elf,el_stab,el_mf,el_stab_mf,elb_mf, & + & PBLH_PLUS_ENT,Uonset,Ugrid,wt_u,el_les REAL, PARAMETER :: ctau = 1000. !constant for tau_cloud ! tv0 = 0.61*tref @@ -2028,7 +1898,7 @@ SUBROUTINE mym_length ( & CASE (0) ! ORIGINAL MYNN MIXING LENGTH + BouLac cns = 2.7 - alp1 = 0.21 + alp1 = 0.23 alp2 = 1.0 alp3 = 5.0 alp4 = 100. @@ -2086,15 +1956,11 @@ SUBROUTINE mym_length ( & elf = elb ENDIF - z_m = MAX(0.,zwk - 4.) - ! ** Length scale in the surface layer ** IF ( rmo .GT. 0.0 ) THEN els = karman*zwk/(1.0+cns*MIN( zwk*rmo, zmax )) - els1 = karman*z_m/(1.0+cns*MIN( zwk*rmo, zmax )) ELSE els = karman*zwk*( 1.0 - alp4* zwk*rmo )**0.2 - els1 = karman*z_m*( 1.0 - alp4* zwk*rmo )**0.2 END IF ! ** HARMONC AVERGING OF MIXING LENGTH SCALES: @@ -2109,18 +1975,21 @@ SUBROUTINE mym_length ( & CASE (1) !NONLOCAL (using BouLac) FORM OF MIXING LENGTH - cns = 3.5 - alp1 = 0.21 + ugrid = sqrt(u1(kts)**2 + v1(kts)**2) + uonset= 15. + wt_u = (1.0 - min(max(ugrid - uonset, 0.0)/30.0, 0.5)) + cns = 2.7 !was 3.5 + alp1 = 0.22 alp2 = 0.3 - alp3 = 1.5 + alp3 = 2.0 * wt_u !taper off bouyancy enhancement in shear-driven pbls alp4 = 5.0 alp5 = 0.3 alp6 = 50. ! Impose limits on the height integration for elt and the transition layer depth - zi2=MAX(zi,200.) !minzi) - h1=MAX(0.3*zi2,200.) - h1=MIN(h1,500.) ! 1/2 transition layer depth + zi2=MAX(zi,300.) !minzi) + h1=MAX(0.3*zi2,300.) + h1=MIN(h1,600.) ! 1/2 transition layer depth h2=h1/2.0 ! 1/4 transition layer depth qtke(kts)=MAX(0.5*qke(kts), 0.01) !tke at full sigma levels @@ -2143,7 +2012,7 @@ SUBROUTINE mym_length ( & zwk = zw(k) DO WHILE (zwk .LE. zi2+h1) dzk = 0.5*( dz(k)+dz(k-1) ) - qdz = MAX( qkw(k)-qmin, 0.03 )*dzk + qdz = min(max( qkw(k)-qmin, 0.03 ), 30.0)*dzk elt = elt +qdz*zwk vsc = vsc +qdz k = k+1 @@ -2151,7 +2020,9 @@ SUBROUTINE mym_length ( & END DO elt = MIN( MAX( alp1*elt/vsc, 10.), 400.) - vflx = ( vt(kts)+1.0 )*flt +( vq(kts)+tv0 )*flq + !avoid use of buoyancy flux functions which are ill-defined at the surface + !vflx = ( vt(kts)+1.0 )*flt + ( vq(kts)+tv0 )*flq + vflx = fltv vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**onethird ! ** Strictly, el(i,j,1) is not zero. ** @@ -2166,31 +2037,23 @@ SUBROUTINE mym_length ( & ! ** Length scale limited by the buoyancy effect ** IF ( dtv(k) .GT. 0.0 ) THEN - alp2 = 0.3 + 0.15*0.5*(cldfra_bl1D(k)+cldfra_bl1D(k-1)) - bv = SQRT( gtr*dtv(k) ) - !elb = alp2*qkw(k) / bv & ! formulation, - ! & *( 1.0 + alp3/alp2*& ! except keep - ! &SQRT( vsc/( bv*elt ) ) ) ! elb bounded by zwk - elb = MAX(alp2*qkw(k), & - & alp6*edmf_a1(k)*edmf_w1(k)) / bv & + bv = max( sqrt( gtr*dtv(k) ), 0.001) + elb = MAX(alp2*qkw(k), & + & alp6*edmf_a1(k-1)*edmf_w1(k-1)) / bv & & *( 1.0 + alp3*SQRT( vsc/(bv*elt) ) ) elb = MIN(elb, zwk) - elf = 0.65 * qkw(k)/bv - !elBLavg(k) = MAX(elBLavg(k), alp6*edmf_a1(k)*edmf_w1(k)/bv) + elf = 0.80 * qkw(k)/bv + elBLavg(k) = MAX(elBLavg(k), alp6*edmf_a1(k-1)*edmf_w1(k-1)/bv) ELSE elb = 1.0e10 elf = elb ENDIF - z_m = MAX(0.,zwk - 4.) - ! ** Length scale in the surface layer ** IF ( rmo .GT. 0.0 ) THEN els = karman*zwk/(1.0+cns*MIN( zwk*rmo, zmax )) - els1 = karman*z_m/(1.0+cns*MIN( zwk*rmo, zmax )) ELSE els = karman*zwk*( 1.0 - alp4* zwk*rmo )**0.2 - els1 = karman*z_m*( 1.0 - alp4* zwk*rmo )**0.2 END IF ! ** NOW BLEND THE MIXING LENGTH SCALES: @@ -2200,8 +2063,7 @@ SUBROUTINE mym_length ( & !defined relative to the PBLH (zi) + transition layer (h1) !el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf) !try squared-blending - !el_unstab = SQRT( els**2/(1. + (els1**2/elt**2) )) - el(k) = SQRT( els**2/(1. + (els1**2/elt**2) +(els1**2/elb**2))) + el(k) = SQRT( els**2/(1. + (els**2/elt**2) +(els**2/elb**2))) el(k) = MIN (el(k), elf) el(k) = el(k)*(1.-wt) + alp5*elBLavg(k)*wt @@ -2215,20 +2077,20 @@ SUBROUTINE mym_length ( & Uonset = 3.5 + dz(kts)*0.1 Ugrid = sqrt(u1(kts)**2 + v1(kts)**2) cns = 3.5 !JOE-test * (1.0 - MIN(MAX(Ugrid - Uonset, 0.0)/10.0, 1.0)) - alp1 = 0.21 + alp1 = 0.22 alp2 = 0.30 - alp3 = 1.5 + alp3 = 2.0 alp4 = 5.0 alp5 = alp2 !like alp2, but for free atmosphere alp6 = 50.0 !used for MF mixing length ! Impose limits on the height integration for elt and the transition layer depth !zi2=MAX(zi,minzi) - zi2=MAX(zi, 200.) + zi2=MAX(zi, 300.) !h1=MAX(0.3*zi2,mindz) !h1=MIN(h1,maxdz) ! 1/2 transition layer depth - h1=MAX(0.3*zi2,200.) - h1=MIN(h1,500.) + h1=MAX(0.3*zi2,300.) + h1=MIN(h1,600.) h2=h1*0.5 ! 1/4 transition layer depth qtke(kts)=MAX(0.5*qke(kts),0.01) !tke at full sigma levels @@ -2250,7 +2112,7 @@ SUBROUTINE mym_length ( & zwk = zw(k) DO WHILE (zwk .LE. PBLH_PLUS_ENT) dzk = 0.5*( dz(k)+dz(k-1) ) - qdz = MAX( qkw(k)-qmin, 0.03 )*dzk + qdz = min(max( qkw(k)-qmin, 0.03 ), 30.0)*dzk elt = elt +qdz*zwk vsc = vsc +qdz k = k+1 @@ -2258,7 +2120,9 @@ SUBROUTINE mym_length ( & END DO elt = MIN( MAX(alp1*elt/vsc, 10.), 400.) - vflx = ( vt(kts)+1.0 )*flt +( vq(kts)+tv0 )*flq + !avoid use of buoyancy flux functions which are ill-defined at the surface + !vflx = ( vt(kts)+1.0 )*flt +( vq(kts)+tv0 )*flq + vflx = fltv vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**onethird ! ** Strictly, el(i,j,1) is not zero. ** @@ -2276,7 +2140,7 @@ SUBROUTINE mym_length ( & bv = MAX( SQRT( gtr*dtv(k) ), 0.001) !elb_mf = alp2*qkw(k) / bv & elb_mf = MAX(alp2*qkw(k), & - & alp6*edmf_a1(k)*edmf_w1(k)) / bv & + & alp6*edmf_a1(k-1)*edmf_w1(k-1)) / bv & & *( 1.0 + alp3*SQRT( vsc/( bv*elt ) ) ) elb = MIN(MAX(alp5*qkw(k), alp6*edmf_a1(k)*edmf_w1(k))/bv, zwk) @@ -2321,33 +2185,24 @@ SUBROUTINE mym_length ( & elb_mf = elb END IF elf = elf/(1. + (elf/800.)) !bound free-atmos mixing length to < 800 m. -! elb_mf = elb_mf/(1. + (elb_mf/800.)) !bound buoyancy mixing length to < 800 m. elb_mf = MAX(elb_mf, 0.01) !to avoid divide-by-zero below - z_m = MAX(0.,zwk - 4.) - ! ** Length scale in the surface layer ** IF ( rmo .GT. 0.0 ) THEN els = karman*zwk/(1.0+cns*MIN( zwk*rmo, zmax )) - els1 = karman*z_m/(1.0+cns*MIN( zwk*rmo, zmax )) ELSE els = karman*zwk*( 1.0 - alp4* zwk*rmo )**0.2 - els1 = karman*z_m*( 1.0 - alp4* zwk*rmo )**0.2 END IF ! ** NOW BLEND THE MIXING LENGTH SCALES: wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 - ! "el_unstab" = blended els-elt - !el_unstab = els/(1. + (els1/elt)) !try squared-blending - !el(k) = SQRT( els**2/(1. + (els1**2/elt**2) )) - el(k) = SQRT( els**2/(1. + (els1**2/elt**2) +(els1**2/elb_mf**2))) - !el(k) = MIN(el_unstab, elb_mf) + el(k) = SQRT( els**2/(1. + (els**2/elt**2) +(els**2/elb_mf**2))) el(k) = el(k)*(1.-wt) + elf*wt - ! include scale-awareness. For now, use simple asymptotic kz -> 12 m. - el_les= MIN(els/(1. + (els1/12.)), elb_mf) + ! include scale-awareness. For now, use simple asymptotic kz -> 12 m (should be ~dz). + el_les= MIN(els/(1. + (els/12.)), elb_mf) el(k) = el(k)*Psig_bl + (1.-Psig_bl)*el_les END DO @@ -2363,7 +2218,7 @@ SUBROUTINE mym_length ( & END SUBROUTINE mym_length ! ================================================================== -!>\ingroup gp_mynnedmf +!>\ingroup gsd_mynn_edmf !! This subroutine was taken from the BouLac scheme in WRF-ARW and modified for !! integration into the MYNN PBL scheme. WHILE loops were added to reduce the !! computational expense. This subroutine computes the length scales up and down @@ -2526,7 +2381,7 @@ SUBROUTINE boulac_length0(k,kts,kte,zw,dz,qtke,theta,lb1,lb2) END SUBROUTINE boulac_length0 ! ================================================================== -!>\ingroup gp_mynnedmf +!>\ingroup gsd_mynn_edmf !! This subroutine was taken from the BouLac scheme in WRF-ARW !! and modified for integration into the MYNN PBL scheme. !! WHILE loops were added to reduce the computational expense. @@ -2717,7 +2572,7 @@ END SUBROUTINE boulac_length ! # dtl, dqw, dtv, gm and gh are allowed to share storage units with ! dfm, dfh, dfq, tcd and qcd, respectively, for saving memory. ! -!>\ingroup gp_mynnedmf +!>\ingroup gsd_mynn_edmf !! This subroutine calculates the vertical diffusivity coefficients and the !! production terms for the turbulent quantities. !>\section gen_mym_turbulence GSD mym_turbulence General Algorithm @@ -2733,29 +2588,30 @@ END SUBROUTINE boulac_length !! - Production terms of TKE,\f$\theta^{'2}\f$,\f$q^{'2}\f$, and \f$\theta^{'}q^{'}\f$ !! are calculated. !! - Eddy diffusivity \f$K_h\f$ and eddy viscosity \f$K_m\f$ are calculated. -!! - TKE budget terms are calculated (if the namelist parameter \p bl_mynn_tkebudget +!! - TKE budget terms are calculated (if the namelist parameter \p tke_budget !! is set to True) SUBROUTINE mym_turbulence ( & & kts,kte, & - & closure, & + & xland,closure, & & dz, dx, zw, & & u, v, thl, thetav, ql, qw, & - & thlsg, qwsg, & & qke, tsq, qsq, cov, & & vt, vq, & - & rmo, flt, flq, & + & rmo, flt, fltv, flq, & & zi,theta, & & sh, sm, & & El, & & Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc, & & qWT1D,qSHEAR1D,qBUOY1D,qDISS1D, & - & bl_mynn_tkebudget, & - & Psig_bl,Psig_shcu,cldfra_bl1D,bl_mynn_mixlength,& - & edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf, & + & tke_budget, & + & Psig_bl,Psig_shcu,cldfra_bl1D, & + & bl_mynn_mixlength, & + & edmf_w1,edmf_a1, & & TKEprodTD, & - & spp_pbl,rstoch_col) + & spp_pbl,rstoch_col ) + !------------------------------------------------------------------- -! + INTEGER, INTENT(IN) :: kts,kte #ifdef HARDCODE_VERTICAL @@ -2763,39 +2619,39 @@ SUBROUTINE mym_turbulence ( & # define kte HARDCODE_VERTICAL #endif - INTEGER, INTENT(IN) :: bl_mynn_mixlength,bl_mynn_edmf - REAL, INTENT(IN) :: closure - REAL, DIMENSION(kts:kte), INTENT(in) :: dz + INTEGER, INTENT(IN) :: bl_mynn_mixlength,tke_budget + REAL(kind=kind_phys), INTENT(IN) :: closure + REAL, DIMENSION(kts:kte), INTENT(in) :: dz REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw - REAL, INTENT(in) :: rmo,flt,flq,Psig_bl,Psig_shcu,dx - REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,thetav,qw,& - &ql,vt,vq,qke,tsq,qsq,cov,cldfra_bl1D,edmf_w1,edmf_a1,edmf_qc1,& - &TKEprodTD,thlsg,qwsg + REAL, INTENT(in) :: rmo,flt,fltv,flq,Psig_bl,Psig_shcu,xland + REAL(kind=kind_phys), INTENT(IN) :: dx,zi + REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,thetav,qw, & + &ql,vt,vq,qke,tsq,qsq,cov,cldfra_bl1D,edmf_w1,edmf_a1, & + &TKEprodTD - REAL, DIMENSION(kts:kte), INTENT(out) :: dfm,dfh,dfq,& + REAL, DIMENSION(kts:kte), INTENT(out) :: dfm,dfh,dfq, & &pdk,pdt,pdq,pdc,tcd,qcd,el - REAL, DIMENSION(kts:kte), INTENT(inout) :: & + REAL, DIMENSION(kts:kte), INTENT(inout) :: & qWT1D,qSHEAR1D,qBUOY1D,qDISS1D REAL :: q3sq_old,dlsq1,qWTP_old,qWTP_new - REAL :: dudz,dvdz,dTdz,& + REAL :: dudz,dvdz,dTdz, & upwp,vpwp,Tpwp - LOGICAL, INTENT(in) :: bl_mynn_tkebudget REAL, DIMENSION(kts:kte) :: qkw,dtl,dqw,dtv,gm,gh,sm,sh INTEGER :: k ! REAL :: cc2,cc3,e1c,e2c,e3c,e4c,e5c - REAL :: e6c,dzk,afk,abk,vtt,vqq,& + REAL :: e6c,dzk,afk,abk,vtt,vqq, & &cw25,clow,cupp,gamt,gamq,smd,gamv,elq,elh - REAL :: zi, cldavg + REAL :: cldavg REAL, DIMENSION(kts:kte), INTENT(in) :: theta REAL :: a2fac, duz, ri !JOE-Canuto/Kitamura mod - REAL:: auh,aum,adh,adm,aeh,aem,Req,Rsl,Rsl2,& - gmelq,sm20,sh20,sm25max,sh25max,sm25min,sh25min,& + REAL:: auh,aum,adh,adm,aeh,aem,Req,Rsl,Rsl2, & + gmelq,sm20,sh20,sm25max,sh25max,sm25min,sh25min, & sm_pbl,sh_pbl,zi2,wt,slht,wtpr DOUBLE PRECISION q2sq, t2sq, r2sq, c2sq, elsq, gmel, ghel @@ -2805,7 +2661,7 @@ SUBROUTINE mym_turbulence ( & ! Stochastic INTEGER, INTENT(IN) :: spp_pbl REAL, DIMENSION(KTS:KTE) :: rstoch_col - REAL :: Prnum, Prlim + REAL :: Prnum, shb REAL, PARAMETER :: Prlimit = 5.0 @@ -2825,21 +2681,21 @@ SUBROUTINE mym_turbulence ( & CALL mym_level2 (kts,kte, & & dz, & & u, v, thl, thetav, qw, & - & thlsg, qwsg, & & ql, vt, vq, & & dtl, dqw, dtv, gm, gh, sm, sh ) ! CALL mym_length ( & - & kts,kte, & + & kts,kte,xland, & & dz, dx, zw, & - & rmo, flt, flq, & + & rmo, flt, fltv, flq, & & vt, vq, & & u, v, qke, & & dtv, & & el, & & zi,theta, & - & qkw,Psig_bl,cldfra_bl1D,bl_mynn_mixlength, & - & edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf ) + & qkw,Psig_bl,cldfra_bl1D, & + & bl_mynn_mixlength, & + & edmf_w1,edmf_a1 ) ! DO k = kts+1,kte @@ -3003,10 +2859,16 @@ SUBROUTINE mym_turbulence ( & !IF ( sm(k) > sm25max ) sm(k) = sm25max !IF ( sm(k) < sm25min ) sm(k) = sm25min !sm(k) = Prnum*sh(k) - slht = zi*0.1 - wtpr = min( max( (slht - zw(k))/slht, 0.0), 1.0) ! 1 at z=0, 0 above sfc layer - Prlim = 1.0*wtpr + (1.0 - wtpr)*Prlimit - sm(k) = MIN(sm(k), Prlimit*Sh(k)) + + !surface layer PR + !slht = zi*0.1 + !wtpr = min( max( (slht - zw(k))/slht, 0.0), 1.0) ! 1 at z=0, 0 above sfc layer + !Prlim = 1.0*wtpr + (1.0 - wtpr)*Prlimit + !Prlim = 2.0*wtpr + (1.0 - wtpr)*Prlimit + !sm(k) = MIN(sm(k), Prlim*Sh(k)) + !Pending more testing, keep same Pr limit in sfc layer + shb = max(sh(k), 0.002) + sm(k) = MIN(sm(k), Prlimit*shb) ! ** Level 3 : start ** IF ( closure .GE. 3.0 ) THEN @@ -3161,11 +3023,6 @@ SUBROUTINE mym_turbulence ( & ! with active plumes and clouds. cldavg = 0.5*(cldfra_bl1D(k-1) + cldfra_bl1D(k)) IF (edmf_a1(k) > 0.001 .OR. cldavg > 0.02) THEN - !sm(k) = MAX(sm(k), MAX(1.0 - 2.0*cldavg, 0.0)**0.33 * 0.03 * & - ! & MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) - !sh(k) = MAX(sh(k), MAX(1.0 - 2.0*cldavg, 0.0)**0.33 * 0.03 * & - ! & MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) - ! for mass-flux columns sm(k) = MAX(sm(k), 0.03*MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) sh(k) = MAX(sh(k), 0.03*MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) @@ -3179,14 +3036,14 @@ SUBROUTINE mym_turbulence ( & ! Production of TKE (pdk), T-variance (pdt), ! q-variance (pdq), and covariance (pdc) - pdk(k) = elq*( sm(k)*gm(k) & - & +sh(k)*gh(k)+gamv ) + & + pdk(k) = elq*( sm(k)*gm(k) & + & +sh(k)*gh(k)+gamv ) + & & TKEprodTD(k) pdt(k) = elh*( sh(k)*dtl(k)+gamt )*dtl(k) pdq(k) = elh*( sh(k)*dqw(k)+gamq )*dqw(k) - pdc(k) = elh*( sh(k)*dtl(k)+gamt )& - &*dqw(k)*0.5 & - &+elh*( sh(k)*dqw(k)+gamq )*dtl(k)*0.5 + pdc(k) = elh*( sh(k)*dtl(k)+gamt ) & + & *dqw(k)*0.5 & + & + elh*( sh(k)*dqw(k)+gamq )*dtl(k)*0.5 ! Contergradient terms tcd(k) = elq*gamt @@ -3201,7 +3058,7 @@ SUBROUTINE mym_turbulence ( & dfq(k) = dfm(k) ! Modified: Dec/22/2005, up to here - IF ( bl_mynn_tkebudget ) THEN + IF (tke_budget .eq. 1) THEN !TKE BUDGET ! dudz = ( u(k)-u(k-1) )/dzk ! dvdz = ( v(k)-v(k-1) )/dzk @@ -3230,7 +3087,7 @@ SUBROUTINE mym_turbulence ( & !!!Dissipation Term (now it evaluated on mym_predict) !qDISS1D(k) = (q3sq**(3./2.))/(b1*MAX(el(k),1.)) !! ORIGINAL CODE - !! >> EOB + !! >> EOB ENDIF END DO @@ -3313,7 +3170,7 @@ END SUBROUTINE mym_turbulence ! scheme (program). ! !------------------------------------------------------------------- -!>\ingroup gp_mynnedmf +!>\ingroup gsd_mynn_edmf !! This subroutine predicts the turbulent quantities at the next step. SUBROUTINE mym_predict (kts,kte, & & closure, & @@ -3324,7 +3181,8 @@ SUBROUTINE mym_predict (kts,kte, & & pdk, pdt, pdq, pdc, & & qke, tsq, qsq, cov, & & s_aw,s_awqke,bl_mynn_edmf_tke, & - & qWT1D, qDISS1D,bl_mynn_tkebudget) !! TKE budget (Puhales, 2020) + & qWT1D, qDISS1D,tke_budget) !! TKE budget (Puhales, 2020) + !------------------------------------------------------------------- INTEGER, INTENT(IN) :: kts,kte @@ -3333,19 +3191,18 @@ SUBROUTINE mym_predict (kts,kte, & # define kte HARDCODE_VERTICAL #endif - REAL, INTENT(IN) :: closure - INTEGER, INTENT(IN) :: bl_mynn_edmf_tke - REAL, INTENT(IN) :: delt + REAL(kind=kind_phys), INTENT(IN) :: closure + INTEGER, INTENT(IN) :: bl_mynn_edmf_tke,tke_budget REAL, DIMENSION(kts:kte), INTENT(IN) :: dz, dfq, el, rho REAL, DIMENSION(kts:kte), INTENT(INOUT) :: pdk, pdt, pdq, pdc - REAL, INTENT(IN) :: flt, flq, ust, pmz, phh + REAL, INTENT(IN) :: flt, flq, pmz, phh + REAL(kind=kind_phys), INTENT(IN) :: ust, delt REAL, DIMENSION(kts:kte), INTENT(INOUT) :: qke,tsq, qsq, cov ! WA 8/3/15 REAL, DIMENSION(kts:kte+1), INTENT(INOUT) :: s_awqke,s_aw !! TKE budget (Puhales, 2020, WRF 4.2.1) << EOB REAL, DIMENSION(kts:kte), INTENT(OUT) :: qWT1D, qDISS1D - LOGICAL, INTENT(IN) :: bl_mynn_tkebudget REAL, DIMENSION(kts:kte) :: tke_up,dzinv !! >> EOB @@ -3486,7 +3343,7 @@ SUBROUTINE mym_predict (kts,kte, & !! TKE budget (Puhales, 2020, WRF 4.2.1) << EOB - IF (bl_mynn_tkebudget) THEN + IF (tke_budget .eq. 1) THEN !! TKE Vertical transport << EOBvt tke_up=0.5*qke dzinv=1./dz @@ -3716,22 +3573,22 @@ END SUBROUTINE mym_predict ! Set these values to those adopted by you. ! !------------------------------------------------------------------- -!>\ingroup gp_mynnedmf +!>\ingroup gsd_mynn_edmf !! This subroutine calculates the nonconvective component of the !! subgrid cloud fraction and mixing ratio as well as the functions used to !! calculate the buoyancy flux. Different cloud PDFs can be selected by !! use of the namelist parameter \p bl_mynn_cloudpdf . - SUBROUTINE mym_condensation (kts,kte, & - & dx, dz, zw, & - & thl, qw, qv, qc, qi, & - & p,exner, & - & tsq, qsq, cov, & - & Sh, el, bl_mynn_cloudpdf,& - & qc_bl1D, qi_bl1D, & - & cldfra_bl1D, & - & PBLH1,HFX1, & - & Vt, Vq, th, sgm, rmo, & - & spp_pbl,rstoch_col ) + SUBROUTINE mym_condensation (kts,kte, & + & dx, dz, zw, xland, & + & thl, qw, qv, qc, qi, qs, & + & p,exner, & + & tsq, qsq, cov, & + & Sh, el, bl_mynn_cloudpdf, & + & qc_bl1D, qi_bl1D, & + & cldfra_bl1D, & + & PBLH1,HFX1, & + & Vt, Vq, th, sgm, rmo, & + & spp_pbl,rstoch_col ) !------------------------------------------------------------------- @@ -3742,10 +3599,11 @@ SUBROUTINE mym_condensation (kts,kte, & # define kte HARDCODE_VERTICAL #endif - REAL, INTENT(IN) :: dx,PBLH1,HFX1,rmo + REAL, INTENT(IN) :: HFX1,rmo,xland + REAL(kind=kind_phys), INTENT(IN) :: dx,pblh1 REAL, DIMENSION(kts:kte), INTENT(IN) :: dz REAL, DIMENSION(kts:kte+1), INTENT(IN) :: zw - REAL, DIMENSION(kts:kte), INTENT(IN) :: p,exner,thl,qw,qv,qc,qi, & + REAL, DIMENSION(kts:kte), INTENT(IN) :: p,exner,thl,qw,qv,qc,qi,qs, & &tsq, qsq, cov, th REAL, DIMENSION(kts:kte), INTENT(INOUT) :: vt,vq,sgm @@ -3758,7 +3616,8 @@ SUBROUTINE mym_condensation (kts,kte, & REAL :: qsl,esat,qsat,dqsl,cld0,q1k,qlk,eq1,qll,& &q2p,pt,rac,qt,t,xl,rsl,cpm,Fng,qww,alpha,beta,bb,& &ls,wt,cld_factor,fac_damp,liq_frac,ql_ice,ql_water,& - &qmq,qsat_tk + &qmq,qsat_tk,q1_rh,rh_hack + REAL, PARAMETER :: rhcrit=0.83 !for hom pdf min sigma INTEGER :: i,j,k REAL :: erf @@ -3769,7 +3628,7 @@ SUBROUTINE mym_condensation (kts,kte, & !variables for SGS BL clouds REAL :: zagl,damp,PBLH2 - REAL :: lfac + REAL :: cfmax !JAYMES: variables for tropopause-height estimation REAL :: theta1, theta2, ht1, ht2 @@ -3854,9 +3713,6 @@ SUBROUTINE mym_condensation (kts,kte, & qc_bl1D(k) = liq_frac*ql(k) qi_bl1D(k) = (1.0 - liq_frac)*ql(k) - if(cldfra_bl1D(k)>0.01 .and. qc_bl1D(k)<1.E-6)qc_bl1D(k)=1.E-6 - if(cldfra_bl1D(k)>0.01 .and. qi_bl1D(k)<1.E-8)qi_bl1D(k)=1.E-8 - !Now estimate the buoyancy flux functions q2p = xlvcp/exner(k) pt = thl(k) +q2p*ql(k) ! potential temp @@ -3914,9 +3770,6 @@ SUBROUTINE mym_condensation (kts,kte, & qc_bl1D(k) = liq_frac*ql(k) qi_bl1D(k) = (1.0 - liq_frac)*ql(k) - if(cldfra_bl1D(k)>0.01 .and. qc_bl1D(k)<1.E-6)qc_bl1D(k)=1.E-6 - if(cldfra_bl1D(k)>0.01 .and. qi_bl1D(k)<1.E-8)qi_bl1D(k)=1.E-8 - !Now estimate the buoyancy flux functions q2p = xlvcp/exner(k) pt = thl(k) +q2p*ql(k) ! potential temp @@ -3945,7 +3798,7 @@ SUBROUTINE mym_condensation (kts,kte, & xl = xl_blend(t) ! obtain latent heat qsat_tk = qsat_blend(t, p(k)) ! saturation water vapor mixing ratio at tk and p - rh(k)=MAX(MIN(1.0,qw(k)/MAX(1.E-8,qsat_tk)),0.001) + rh(k)=MAX(MIN(1.00,qw(k)/MAX(1.E-10,qsat_tk)),0.001) !dqw/dT: Clausius-Clapeyron dqsl = qsat_tk*ep_2*xlv/( r_d*t**2 ) @@ -3966,101 +3819,89 @@ SUBROUTINE mym_condensation (kts,kte, & !Use the form of Eq. (6) in Chaboureau and Bechtold (2002) !except neglect all but the first term for sig_r - r3sq = MAX( qsq(k), 0.0 ) + r3sq = max( qsq(k), 0.0 ) !Calculate sigma using higher-order moments: sgm(k) = SQRT( r3sq ) !Set limits on sigma relative to saturation water vapor - sgm(k) = MIN( sgm(k), qsat_tk*0.666 ) !500 ) - sgm(k) = MAX( sgm(k), qsat_tk*0.040 ) !Note: 0.02 results in SWDOWN similar - !to the first-order version of sigma - q1(k) = qmq / sgm(k) ! Q1, the normalized saturation - - !Original C-B cloud fraction, allows cloud fractions out to q1 = -3.5 - cldfra_bl1D(K) = MAX(0., MIN(1., 0.5+0.36*ATAN(1.55*q1(k)))) ! Eq. 7 in CB02 - !This form only allows cloud fractions out to q1 = -1.8 - !cldfra_bl1D(K) = MAX(0., MIN(1., 0.5+0.41*ATAN(1.55*q1(k)))) - !This form only allows cloud fractions out to q1 = -1 - !cldfra_bl1D(K) = MAX(0., MIN(1., 0.5+0.50*ATAN(1.55*q1(k)))) + sgm(k) = min( sgm(k), qsat_tk*0.666 ) + sgm(k) = max( sgm(k), qsat_tk*0.035 ) + q1(k) = qmq / sgm(k) ! Q1, the normalized saturation + + !Add condition for falling/settling into low-RH layers, so at least + !some cloud fraction is applied for all qc and qi. + rh_hack = rh(k) + !ensure adequate RH & q1 when qi is at least 1e-9 + if (qi(k)>1.e-9) then + rh_hack =min(1.0, rhcrit + 0.06*(9.0 + log10(qi(k)))) + rh(k) =max(rh(k), rh_hack) + !add rh-based q1 + q1_rh =-3. + 3.*(rh_hack-rhcrit)/(1.-rhcrit) + q1(k) =max(q1_rh, q1(k) ) + endif + !ensure adequate RH & q1 when qc is at least 1e-6 + if (qc(k)>1.e-6) then + rh_hack =min(1.0, rhcrit + 0.09*(6.0 + log10(qc(k)))) + rh(k) =max(rh(k), rh_hack) + !add rh-based q1 + q1_rh =-3. + 3.*(rh_hack-rhcrit)/(1.-rhcrit) + q1(k) =max(q1_rh, q1(k) ) + endif - END DO + q1k = q1(k) ! backup Q1 for later modification - ! Specify hydrometeors - ! JAYMES- this option added 8 May 2015 - ! The cloud water formulations are taken from CB02, Eq. 8. - ! "fng" represents the non-Gaussian contribution to the liquid - ! water flux; these formulations are from Cuijpers and Bechtold - ! (1995), Eq. 7. CB95 also draws from Bechtold et al. 1995, - ! hereafter BCMT95 - zagl = 0. - DO k = kts,kte-1 - t = th(k)*exner(k) - q1k = q1(k) - zagl = zagl + dz(k) + ! Specify cloud fraction + !Original C-B cloud fraction, allows cloud fractions out to q1 = -3.5 + !cldfra_bl1D(K) = max(0., min(1., 0.5+0.36*atan(1.55*q1(k)))) ! Eq. 7 in CB02 + !Waynes LES fit - over-diffuse, when limits removed from vt & vq & fng + !cldfra_bl1D(K) = max(0., min(1., 0.5+0.36*atan(1.2*(q1(k)+0.4)))) + !Best compromise: Improves marine stratus without adding much cold bias. + cldfra_bl1D(k) = max(0., min(1., 0.5+0.36*atan(1.8*(q1(k)+0.2)))) - !CLOUD WATER AND ICE + ! Specify hydrometeors + ! JAYMES- this option added 8 May 2015 + ! The cloud water formulations are taken from CB02, Eq. 8. IF (q1k < 0.) THEN !unsaturated -#ifdef SINGLE_PREC ql_water = sgm(k)*EXP(1.2*q1k-1.) -#else - ql_water = sgm(k)*EXP(1.2*q1k-1) -#endif ql_ice = sgm(k)*EXP(1.2*q1k-1.) ELSE IF (q1k > 2.) THEN !supersaturated ql_water = sgm(k)*q1k ql_ice = sgm(k)*q1k - !ql_ice = MIN(80.*qv(k),0.1)*sgm(k)*q1k ELSE !slightly saturated (0 > q1 < 2) ql_water = sgm(k)*(EXP(-1.) + 0.66*q1k + 0.086*q1k**2) ql_ice = sgm(k)*(EXP(-1.) + 0.66*q1k + 0.086*q1k**2) - !ql_ice = MIN(80.*qv(k),0.1)*sgm(k)*(EXP(-1.) + 0.66*q1k + 0.086*q1k**2) ENDIF - !In saturated grid cells, use average of current estimate and prev time step - IF ( qc(k) > 1.e-7 ) ql_water = 0.5 * ( ql_water + qc(k) ) - IF ( qi(k) > 1.e-9 ) ql_ice = 0.5 * ( ql_ice + qi(k) ) + !In saturated grid cells, use average of SGS and resolved values + !if ( qc(k) > 1.e-6 ) ql_water = 0.5 * ( ql_water + qc(k) ) + !ql_ice is actually the total frozen condensate (snow+ice), + !if ( (qi(k)+qs(k)) > 1.e-9 ) ql_ice = 0.5 * ( ql_ice + (qi(k)+qs(k)) ) - IF (cldfra_bl1D(k) < 0.01) THEN + if (cldfra_bl1D(k) < 0.001) then ql_ice = 0.0 ql_water = 0.0 cldfra_bl1D(k) = 0.0 - ENDIF - - !PHASE PARTITIONING: Make some inferences about the relative amounts of - !subgrid cloud water vs. ice based on collocated explicit clouds. Otherise, - !use a simple temperature-dependent partitioning. -! IF ( qc(k) + qi(k) > 0.0 ) THEN ! explicit condensate exists, retain its phase partitioning -! IF ( qi(k) == 0.0 ) THEN ! explicit contains no ice; assume subgrid liquid -! liq_frac = 1.0 -! ELSE IF ( qc(k) == 0.0 ) THEN ! explicit contains no liquid; assume subgrid ice -! liq_frac = 0.0 -! ELSE IF ( (qc(k) >= 1.E-10) .AND. (qi(k) >= 1.E-10) ) THEN ! explicit contains mixed phase of workably -! ! large amounts; assume subgrid follows -! ! same partioning -! liq_frac = qc(k) / ( qc(k) + qi(k) ) -! ELSE -! liq_frac = MIN(1.0, MAX(0.0, (t-tice)/(t0c-tice))) ! explicit contains mixed phase, but at least one -! ! species is very small, so make a temperature- -! ! depedent guess -! ENDIF -! ELSE ! no explicit condensate, so make a temperature-dependent guess - liq_frac = MIN(1.0, MAX(0.0, (t-tice)/(t0c-tice))) -! ENDIF + endif + liq_frac = MIN(1.0, MAX(0.0, (t-tice)/(tliq-tice))) qc_bl1D(k) = liq_frac*ql_water ! apply liq_frac to ql_water and ql_ice qi_bl1D(k) = (1.0-liq_frac)*ql_ice - !Above tropopause: eliminate subgrid clouds from CB scheme - if (k .ge. k_tropo-1) then + !Above tropopause: eliminate subgrid clouds from CB scheme. Note that this was + !"k_tropo - 1" as of 20 Feb 2023. Changed to allow more high-level clouds. + if (k .ge. k_tropo) then cldfra_bl1D(K) = 0. - qc_bl1D(k) = 0. - qi_bl1D(k) = 0. + qc_bl1D(k) = 0. + qi_bl1D(k) = 0. endif - ENDDO - - !Buoyancy-flux-related calculations follow... - DO k = kts,kte-1 - t = th(k)*exner(k) + !Buoyancy-flux-related calculations follow... + !limiting Q1 to avoid too much diffusion in cloud layers + !q1k=max(Q1(k),-2.0) + if ((xland-1.5).GE.0) then ! water + q1k=max(Q1(k),-2.5) + else ! land + q1k=max(Q1(k),-2.0) + endif ! "Fng" represents the non-Gaussian transport factor ! (non-dimensional) from Bechtold et al. 1995 ! (hereafter BCMT95), section 3(c). Their suggested @@ -4072,8 +3913,7 @@ SUBROUTINE mym_condensation (kts,kte, & !ELSE ! Fng = 1.-1.5*q1k !ENDIF - !limiting to avoid mixing away stratus, was -5 - q1k=MAX(Q1(k),-1.0) + ! Use the form of "Fng" from Bechtold and Siebesma (1998, JAS) IF (q1k .GE. 1.0) THEN Fng = 1.0 ELSEIF (q1k .GE. -1.7 .AND. q1k .LT. 1.0) THEN @@ -4083,42 +3923,36 @@ SUBROUTINE mym_condensation (kts,kte, & ELSE Fng = MIN(23.9 + EXP(-1.6*(q1k+2.5)), 60.) ENDIF - Fng = MIN(Fng, 20.) - xl = xl_blend(t) - bb = b(k)*t/th(k) ! bb is "b" in BCMT95. Their "b" differs from - ! "b" in CB02 (i.e., b(k) above) by a factor + cfmax= min(cldfra_bl1D(k), 0.6) + bb = b(k)*t/th(k) ! bb is "b" in BCMT95. Their "b" differs from + ! "b" in CB02 (i.e., b(k) above) by a factor ! of T/theta. Strictly, b(k) above is formulated in ! terms of sat. mixing ratio, but bb in BCMT95 is ! cast in terms of sat. specific humidity. The - ! conversion is neglected here. + ! conversion is neglected here. qww = 1.+0.61*qw(k) alpha = 0.61*th(k) beta = (th(k)/t)*(xl/cp) - 1.61*th(k) - vt(k) = qww - MIN(cldfra_bl1D(K),0.5)*beta*bb*Fng - 1. - vq(k) = alpha + MIN(cldfra_bl1D(K),0.5)*beta*a(k)*Fng - tv0 + vt(k) = qww - cfmax*beta*bb*Fng - 1. + vq(k) = alpha + cfmax*beta*a(k)*Fng - tv0 ! vt and vq correspond to beta-theta and beta-q, respectively, ! in NN09, Eq. B8. They also correspond to the bracketed ! expressions in BCMT95, Eq. 15, since (s*ql/sigma^2) = cldfra*Fng ! The "-1" and "-tv0" terms are included for consistency with ! the legacy vt and vq formulations (above). - ! dampen the amplification factor (cld_factor) with height in order - ! to limit excessively large cloud fractions aloft - !fac_damp = 1.! -MIN(MAX( zagl-(PBLH2+1000.),0.0)/ & - ! MAX((zw(k_tropo)-(PBLH2+1000.)),500.), 1.) - fac_damp = min(zagl * 0.01, 1.0) - !cld_factor = 1.0 + fac_damp*MAX(0.0, ( RH(k) - 0.5 ) / 0.51 )**3.3 + ! dampen amplification factor where need be + fac_damp = min(zagl * 0.0025, 1.0) !cld_factor = 1.0 + fac_damp*MAX(0.0, ( RH(k) - 0.75 ) / 0.26 )**1.9 !HRRRv4 - !cld_factor = 1.0 + fac_damp*(MAX(0.0, ( RH(k) - 0.80 )) / 0.22 )**2 - cld_factor = 1.0 + fac_damp*(MAX(0.0, ( RH(k) - 0.90 )) / 0.11 )**2 - !cld_factor = 1.0 - cldfra_bl1D(K) = MIN( 1., cld_factor*cldfra_bl1D(K) ) - ENDDO + !cld_factor = 1.0 + fac_damp*min((max(0.0, ( RH(k) - 0.92 )) / 0.25 )**2, 0.3) + cld_factor = 1.0 + fac_damp*min((max(0.0, ( RH(k) - 0.92 )) / 0.145)**2, 0.35) + cldfra_bl1D(K) = min( 1., cld_factor*cldfra_bl1D(K) ) + enddo END SELECT !end cloudPDF option - !FOR TESTING PURPOSES ONLY, ISOLATE ON THE MASS-CLOUDS. + !For testing purposes only, option for isolating on the mass-flux clouds. IF (bl_mynn_cloudpdf .LT. 0) THEN DO k = kts,kte-1 cldfra_bl1D(k) = 0.0 @@ -4143,42 +3977,42 @@ SUBROUTINE mym_condensation (kts,kte, & END SUBROUTINE mym_condensation ! ================================================================== -!>\ingroup gp_mynnedmf +!>\ingroup gsd_mynn_edmf !! This subroutine solves for tendencies of U, V, \f$\theta\f$, qv, !! qc, and qi - SUBROUTINE mynn_tendencies(kts,kte,i, & - &closure, & - &delt,dz,rho, & - &u,v,th,tk,qv,qc,qi,qnc,qni, & - &psfc,p,exner, & - &thl,sqv,sqc,sqi,sqw, & - &qnwfa,qnifa,ozone, & - &ust,flt,flq,flqv,flqc,wspd, & - &uoce,voce, & - &tsq,qsq,cov, & - &tcd,qcd, & - &dfm,dfh,dfq, & - &Du,Dv,Dth,Dqv,Dqc,Dqi,Dqnc,Dqni, & - &Dqnwfa,Dqnifa,Dozone, & - &vdfg1,diss_heat, & - &s_aw,s_awthl,s_awqt,s_awqv,s_awqc, & - &s_awu,s_awv, & - &s_awqnc,s_awqni, & - &s_awqnwfa,s_awqnifa, & - &sd_aw,sd_awthl,sd_awqt,sd_awqv, & - &sd_awqc,sd_awu,sd_awv, & - &sub_thl,sub_sqv, & - &sub_u,sub_v, & - &det_thl,det_sqv,det_sqc, & - &det_u,det_v, & - &FLAG_QC,FLAG_QI,FLAG_QNC,FLAG_QNI, & - &FLAG_QNWFA,FLAG_QNIFA, & - &cldfra_bl1d, & - &bl_mynn_cloudmix, & - &bl_mynn_mixqt, & - &bl_mynn_edmf, & - &bl_mynn_edmf_mom, & - &bl_mynn_mixscalars ) + SUBROUTINE mynn_tendencies(kts,kte,i, & + &delt,dz,rho, & + &u,v,th,tk,qv,qc,qi,qs,qnc,qni, & + &psfc,p,exner, & + &thl,sqv,sqc,sqi,sqs,sqw, & + &qnwfa,qnifa,qnbca,ozone, & + &ust,flt,flq,flqv,flqc,wspd, & + &uoce,voce, & + &tsq,qsq,cov, & + &tcd,qcd, & + &dfm,dfh,dfq, & + &Du,Dv,Dth,Dqv,Dqc,Dqi,Dqs,Dqnc,Dqni, & + &Dqnwfa,Dqnifa,Dqnbca,Dozone, & + &diss_heat, & + &s_aw,s_awthl,s_awqt,s_awqv,s_awqc, & + &s_awu,s_awv, & + &s_awqnc,s_awqni, & + &s_awqnwfa,s_awqnifa,s_awqnbca, & + &sd_aw,sd_awthl,sd_awqt,sd_awqv, & + &sd_awqc,sd_awu,sd_awv, & + &sub_thl,sub_sqv, & + &sub_u,sub_v, & + &det_thl,det_sqv,det_sqc, & + &det_u,det_v, & + &FLAG_QC,FLAG_QI,FLAG_QNC,FLAG_QNI, & + &FLAG_QS, & + &FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA, & + &cldfra_bl1d, & + &bl_mynn_cloudmix, & + &bl_mynn_mixqt, & + &bl_mynn_edmf, & + &bl_mynn_edmf_mom, & + &bl_mynn_mixscalars ) !------------------------------------------------------------------- INTEGER, INTENT(in) :: kts,kte,i @@ -4188,12 +4022,11 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & # define kte HARDCODE_VERTICAL #endif - REAL, INTENT(in) :: closure - INTEGER, INTENT(in) :: bl_mynn_cloudmix,bl_mynn_mixqt,& - bl_mynn_edmf,bl_mynn_edmf_mom, & + INTEGER, INTENT(in) :: bl_mynn_cloudmix,bl_mynn_mixqt, & + bl_mynn_edmf,bl_mynn_edmf_mom, & bl_mynn_mixscalars - LOGICAL, INTENT(IN) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC,& - FLAG_QNWFA,FLAG_QNIFA + LOGICAL, INTENT(IN) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QS, & + &FLAG_QNC,FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA ! thl - liquid water potential temperature ! qw - total water @@ -4202,23 +4035,23 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & ! flq - surface flux of qw ! mass-flux plumes - REAL, DIMENSION(kts:kte+1), INTENT(in) :: s_aw,s_awthl,s_awqt,& - &s_awqnc,s_awqni,s_awqv,s_awqc,s_awu,s_awv, & - &s_awqnwfa,s_awqnifa, & + REAL, DIMENSION(kts:kte+1), INTENT(in) :: s_aw,s_awthl,s_awqt, & + &s_awqnc,s_awqni,s_awqv,s_awqc,s_awu,s_awv, & + &s_awqnwfa,s_awqnifa,s_awqnbca, & &sd_aw,sd_awthl,sd_awqt,sd_awqv,sd_awqc,sd_awu,sd_awv ! tendencies from mass-flux environmental subsidence and detrainment - REAL, DIMENSION(kts:kte), INTENT(in) :: sub_thl,sub_sqv, & + REAL, DIMENSION(kts:kte), INTENT(in) :: sub_thl,sub_sqv, & &sub_u,sub_v,det_thl,det_sqv,det_sqc,det_u,det_v - REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,th,tk,qv,qc,qi,qni,qnc,& + REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,th,tk,qv,qc,qi,qs,qni,qnc,& &rho,p,exner,dfq,dz,tsq,qsq,cov,tcd,qcd,cldfra_bl1d,diss_heat - REAL, DIMENSION(kts:kte), INTENT(inout) :: thl,sqw,sqv,sqc,sqi,& - &qnwfa,qnifa,ozone,dfm,dfh - REAL, DIMENSION(kts:kte), INTENT(inout) :: du,dv,dth,dqv,dqc,dqi,& - &dqni,dqnc,dqnwfa,dqnifa,dozone - REAL, INTENT(IN) :: delt,ust,flt,flq,flqv,flqc,wspd,uoce,voce,& - &psfc + REAL, DIMENSION(kts:kte), INTENT(inout) :: thl,sqw,sqv,sqc,sqi,sqs, & + &qnwfa,qnifa,qnbca,ozone,dfm,dfh + REAL, DIMENSION(kts:kte), INTENT(inout) :: du,dv,dth,dqv,dqc,dqi,dqs, & + &dqni,dqnc,dqnwfa,dqnifa,dqnbca,dozone + REAL, INTENT(IN) :: flt,flq,flqv,flqc,uoce,voce + REAL(kind=kind_phys), INTENT(IN) :: ust,delt,psfc,wspd !debugging - REAL ::wsp,wsp2 + REAL ::wsp,wsp2,tk2,th2 LOGICAL :: problem integer :: kproblem @@ -4227,14 +4060,13 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & !local vars REAL, DIMENSION(kts:kte) :: dtz,dfhc,dfmc,delp - REAL, DIMENSION(kts:kte) :: sqv2,sqc2,sqi2,sqw2,qni2,qnc2, & !AFTER MIXING - qnwfa2,qnifa2,ozone2 + REAL, DIMENSION(kts:kte) :: sqv2,sqc2,sqi2,sqs2,sqw2,qni2,qnc2, & !AFTER MIXING + qnwfa2,qnifa2,qnbca2,ozone2 REAL, DIMENSION(kts:kte) :: zfac,plumeKh,rhoinv REAL, DIMENSION(kts:kte) :: a,b,c,d,x REAL, DIMENSION(kts:kte+1) :: rhoz, & !rho on model interface & khdz, kmdz REAL :: rhs,gfluxm,gfluxp,dztop,maxdfh,mindfh,maxcf,maxKh,zw - REAL :: vdfg1 !Katata-fogdes REAL :: t,esat,qsl,onoff,kh,km,dzk,rhosfc REAL :: ustdrag,ustdiff,qvflux REAL :: th_new,portion_qc,portion_qi,condensate,qsat @@ -4352,7 +4184,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=u(kte) ! CALL tridiag(kte,a,b,c,d) - CALL tridiag3(kte,a,b,c,d,x) + CALL tridiag2(kte,a,b,c,d,x) +! CALL tridiag3(kte,a,b,c,d,x) DO k=kts,kte ! du(k)=(d(k-kts+1)-u(k))/delt @@ -4416,7 +4249,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=v(kte) ! CALL tridiag(kte,a,b,c,d) - CALL tridiag3(kte,a,b,c,d,x) + CALL tridiag2(kte,a,b,c,d,x) +! CALL tridiag3(kte,a,b,c,d,x) DO k=kts,kte ! dv(k)=(d(k-kts+1)-v(k))/delt @@ -4483,8 +4317,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=thl(kte) ! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,x) - CALL tridiag3(kte,a,b,c,d,x) + CALL tridiag2(kte,a,b,c,d,x) +! CALL tridiag3(kte,a,b,c,d,x) DO k=kts,kte !thl(k)=d(k-kts+1) @@ -4546,8 +4380,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=sqw(kte) ! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,sqw2) - CALL tridiag3(kte,a,b,c,d,sqw2) + CALL tridiag2(kte,a,b,c,d,sqw2) +! CALL tridiag3(kte,a,b,c,d,sqw2) ! DO k=kts,kte ! sqw2(k)=d(k-kts+1) @@ -4603,8 +4437,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=sqc(kte) ! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,sqc2) - CALL tridiag3(kte,a,b,c,d,sqc2) + CALL tridiag2(kte,a,b,c,d,sqc2) +! CALL tridiag3(kte,a,b,c,d,sqc2) ! DO k=kts,kte ! sqc2(k)=d(k-kts+1) @@ -4681,8 +4515,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=sqv(kte) ! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,sqv2) - CALL tridiag3(kte,a,b,c,d,sqv2) + CALL tridiag2(kte,a,b,c,d,sqv2) +! CALL tridiag3(kte,a,b,c,d,sqv2) ! DO k=kts,kte ! sqv2(k)=d(k-kts+1) @@ -4697,19 +4531,6 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & IF (bl_mynn_cloudmix > 0 .AND. FLAG_QI) THEN k=kts - -! a(k)=0. -! b(k)=1.+dtz(k)*dfh(k+1) -! c(k)= -dtz(k)*dfh(k+1) -! d(k)=sqi(k) !+ qcd(k)*delt !should we have qcd for ice? -! -! DO k=kts+1,kte-1 -! a(k)= -dtz(k)*dfh(k) -! b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) -! c(k)= -dtz(k)*dfh(k+1) -! d(k)=sqi(k) !+ qcd(k)*delt -! ENDDO - !rho-weighted: a(k)= -dtz(k)*khdz(k)*rhoinv(k) b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) @@ -4743,8 +4564,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=sqi(kte) ! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,sqi2) - CALL tridiag3(kte,a,b,c,d,sqi2) + CALL tridiag2(kte,a,b,c,d,sqi2) +! CALL tridiag3(kte,a,b,c,d,sqi2) ! DO k=kts,kte ! sqi2(k)=d(k-kts+1) @@ -4753,6 +4574,42 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & sqi2=sqi ENDIF +!============================================ +! MIX SNOW ( sqs ) +!============================================ +IF (bl_mynn_cloudmix > 0 .AND. FLAG_QS) THEN + + k=kts +!rho-weighted: + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) + d(k)=sqs(k) + + DO k=kts+1,kte-1 + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) + d(k)=sqs(k) + ENDDO + +!! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=sqs(kte) + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,sqs2) +! CALL tridiag3(kte,a,b,c,d,sqs2) + +! DO k=kts,kte +! sqs2(k)=d(k-kts+1) +! ENDDO +ELSE + sqs2=sqs +ENDIF + !!============================================ !! cloud ice number concentration (qni) !!============================================ @@ -4781,8 +4638,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=qni(kte) ! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,x) - CALL tridiag3(kte,a,b,c,d,x) + CALL tridiag2(kte,a,b,c,d,x) +! CALL tridiag3(kte,a,b,c,d,x) DO k=kts,kte !qni2(k)=d(k-kts+1) @@ -4799,6 +4656,7 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & !!============================================ IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNC .AND. & bl_mynn_mixscalars > 0) THEN + k=kts a(k)= -dtz(k)*khdz(k)*rhoinv(k) @@ -4821,8 +4679,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=qnc(kte) ! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,x) - CALL tridiag3(kte,a,b,c,d,x) + CALL tridiag2(kte,a,b,c,d,x) +! CALL tridiag3(kte,a,b,c,d,x) DO k=kts,kte !qnc2(k)=d(k-kts+1) @@ -4862,8 +4720,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=qnwfa(kte) ! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,x) - CALL tridiag3(kte,a,b,c,d,x) + CALL tridiag2(kte,a,b,c,d,x) +! CALL tridiag3(kte,a,b,c,d,x) DO k=kts,kte !qnwfa2(k)=d(k) @@ -4904,8 +4762,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=qnifa(kte) ! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,x) - CALL tridiag3(kte,a,b,c,d,x) + CALL tridiag2(kte,a,b,c,d,x) +! CALL tridiag3(kte,a,b,c,d,x) DO k=kts,kte !qnifa2(k)=d(k-kts+1) @@ -4917,6 +4775,48 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & qnifa2=qnifa ENDIF +!============================================ +! Black-carbon aerosols ( qnbca ). +!============================================ +IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNBCA .AND. & + bl_mynn_mixscalars > 0) THEN + + k=kts + + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) - & + & 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + d(k)=qnbca(k) - dtz(k)*rhoinv(k)*s_awqnbca(k+1)*nonloc + + DO k=kts+1,kte-1 + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*nonloc + b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) + & + & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*nonloc + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + d(k)=qnbca(k) + dtz(k)*rhoinv(k)*(s_awqnbca(k)-s_awqnbca(k+1))*nonloc + ENDDO + +! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=qnbca(kte) + +! CALL tridiag(kte,a,b,c,d) +! CALL tridiag2(kte,a,b,c,d,x) + CALL tridiag3(kte,a,b,c,d,x) + + DO k=kts,kte + !qnbca2(k)=d(k-kts+1) + qnbca2(k)=x(k) + ENDDO + +ELSE + !If not mixing aerosols, set "updated" array equal to original array + qnbca2=qnbca +ENDIF + !============================================ ! Ozone - local mixing only !============================================ @@ -4943,8 +4843,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=ozone(kte) ! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,x) - CALL tridiag3(kte,a,b,c,d,x) + CALL tridiag2(kte,a,b,c,d,x) +! CALL tridiag3(kte,a,b,c,d,x) DO k=kts,kte !ozone2(k)=d(k-kts+1) @@ -5041,6 +4941,19 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & ENDDO ENDIF + !=================== + ! CLOUD SNOW TENDENCY + !=================== + IF (FLAG_QS) THEN + DO k=kts,kte + Dqs(k)=(sqs2(k)/(1.-sqs2(k)) - qs(k))/delt + ENDDO + ELSE + DO k=kts,kte + Dqs(k) = 0. + ENDDO + ENDIF + !=================== ! CLOUD ICE NUM CONC TENDENCY !=================== @@ -5065,9 +4978,9 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & ENDIF !ensure non-negative moist species - CALL moisture_check(kte, delt, delp, exner, & - sqv2, sqc2, sqi2, thl, & - dqv, dqc, dqi, dth ) + CALL moisture_check(kte, delt, delp, exner, & + sqv2, sqc2, sqi2, sqs2, thl, & + dqv, dqc, dqi, dqs, dth ) !===================== ! OZONE TENDENCY CHECK @@ -5083,8 +4996,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & !=================== IF (FLAG_QI) THEN DO k=kts,kte - Dth(k)=(thl(k) + xlvcp/exner(k)*sqc2(k) & - & + xlscp/exner(k)*sqi2(k) & + Dth(k)=(thl(k) + xlvcp/exner(k)*sqc2(k) & + & + xlscp/exner(k)*(sqi2(k)+sqs(k)) & & - th(k))/delt !Use form from Tripoli and Cotton (1981) with their !suggested min temperature to improve accuracy: @@ -5124,6 +5037,19 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & ENDDO ENDIF + !======================== + ! BLACK-CARBON TENDENCIES + !======================== + IF (FLAG_QNBCA .AND. bl_mynn_mixscalars > 0) THEN + DO k=kts,kte + Dqnbca(k)=(qnbca2(k) - qnbca(k))/delt + ENDDO + ELSE + DO k=kts,kte + Dqnbca(k)=0. + ENDDO + ENDIF + !ensure non-negative moist species !note: if called down here, dth needs to be updated, but ! if called before the theta-tendency calculation, do not compute dth @@ -5136,21 +5062,28 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & do k=kts,kte wsp = sqrt(u(k)**2 + v(k)**2) wsp2 = sqrt((u(k)+du(k)*delt)**2 + (v(k)+du(k)*delt)**2) - if (wsp2 > 200.) then + th2 = th(k) + Dth(k)*delt + tk2 = th2*exner(k) + if (wsp2 > 200. .or. tk2 > 360. .or. tk2 < 160.) then problem = .true. - print*,"Huge wind speed: i=",i," k=",k," wsp=",wsp2 - print*," du=",du(k)*delt," dv=",dv(k)*delt + print*,"Outgoing problem at: i=",i," k=",k + print*," incoming wsp=",wsp," outgoing wsp=",wsp2 + print*," incoming T=",th(k)*exner(k),"outgoing T:",tk2 + print*," du=",du(k)*delt," dv=",dv(k)*delt," dth=",dth(k)*delt print*," km=",kmdz(k)*dz(k)," kh=",khdz(k)*dz(k) print*," u*=",ust," wspd=",wspd,"rhosfc=",rhosfc + print*," LH=",flq*rhosfc*1004.," HFX=",flt*rhosfc*1004. print*," drag term=",ust**2/wspd*dtz(k)*rhosfc/rho(kts) kproblem = k endif enddo if (problem) then - print*,"=temp:",thl(max(kproblem-5,1):min(kproblem+5,kte)) - print*,"===qv:",sqv(max(kproblem-5,1):min(kproblem+5,kte)) - print*,"====u:",u(max(kproblem-5,1):min(kproblem+5,kte)) - print*,"====v:",v(max(kproblem-5,1):min(kproblem+5,kte)) + print*,"==thl:",thl(max(kproblem-3,1):min(kproblem+3,kte)) + print*,"===qv:",sqv2(max(kproblem-3,1):min(kproblem+3,kte)) + print*,"===qc:",sqc2(max(kproblem-3,1):min(kproblem+3,kte)) + print*,"===qi:",sqi2(max(kproblem-3,1):min(kproblem+3,kte)) + print*,"====u:",u(max(kproblem-3,1):min(kproblem+3,kte)) + print*,"====v:",v(max(kproblem-3,1):min(kproblem+3,kte)) endif endif @@ -5162,11 +5095,9 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & END SUBROUTINE mynn_tendencies ! ================================================================== -!>\ingroup gp_mynnedmf -!!ensure non-negative moist species. SUBROUTINE moisture_check(kte, delt, dp, exner, & - qv, qc, qi, th, & - dqv, dqc, dqi, dth ) + qv, qc, qi, qs, th, & + dqv, dqc, dqi, dqs, dth ) ! This subroutine was adopted from the CAM-UW ShCu scheme and ! adapted for use here. @@ -5183,12 +5114,12 @@ SUBROUTINE moisture_check(kte, delt, dp, exner, & implicit none integer, intent(in) :: kte - real, intent(in) :: delt + real(kind=kind_phys), intent(in) :: delt real, dimension(kte), intent(in) :: dp, exner - real, dimension(kte), intent(inout) :: qv, qc, qi, th - real, dimension(kte), intent(inout) :: dqv, dqc, dqi, dth + real, dimension(kte), intent(inout) :: qv, qc, qi, qs, th + real, dimension(kte), intent(inout) :: dqv, dqc, dqi, dqs, dth integer k - real :: dqc2, dqi2, dqv2, sum, aa, dum + real :: dqc2, dqi2, dqs2, dqv2, sum, aa, dum real, parameter :: qvmin = 1e-20, & qcmin = 0.0, & qimin = 0.0 @@ -5196,19 +5127,22 @@ SUBROUTINE moisture_check(kte, delt, dp, exner, & do k = kte, 1, -1 ! From the top to the surface dqc2 = max(0.0, qcmin-qc(k)) !qc deficit (>=0) dqi2 = max(0.0, qimin-qi(k)) !qi deficit (>=0) + dqs2 = max(0.0, qimin-qs(k)) !qs deficit (>=0) !fix tendencies dqc(k) = dqc(k) + dqc2/delt dqi(k) = dqi(k) + dqi2/delt - dqv(k) = dqv(k) - (dqc2+dqi2)/delt + dqs(k) = dqs(k) + dqs2/delt + dqv(k) = dqv(k) - (dqc2+dqi2+dqs2)/delt dth(k) = dth(k) + xlvcp/exner(k)*(dqc2/delt) + & - xlscp/exner(k)*(dqi2/delt) + xlscp/exner(k)*((dqi2+dqs2)/delt) !update species qc(k) = qc(k) + dqc2 qi(k) = qi(k) + dqi2 - qv(k) = qv(k) - dqc2 - dqi2 + qs(k) = qs(k) + dqs2 + qv(k) = qv(k) - dqc2 - dqi2 - dqs2 th(k) = th(k) + xlvcp/exner(k)*dqc2 + & - xlscp/exner(k)*dqi2 + xlscp/exner(k)*(dqi2+dqs2) !then fix qv dqv2 = max(0.0, qvmin-qv(k)) !qv deficit (>=0) @@ -5221,6 +5155,7 @@ SUBROUTINE moisture_check(kte, delt, dp, exner, & qv(k) = max(qv(k),qvmin) qc(k) = max(qc(k),qcmin) qi(k) = max(qi(k),qimin) + qs(k) = max(qs(k),qimin) end do ! Extra moisture used to satisfy 'qv(1)>=qvmin' is proportionally ! extracted from all the layers that has 'qv > 2*qvmin'. This fully @@ -5251,8 +5186,6 @@ END SUBROUTINE moisture_check ! ================================================================== -!>\ingroup gp_mynnedmf -!! SUBROUTINE mynn_mix_chem(kts,kte,i, & delt,dz,pblh, & nchem, kdvel, ndvel, & @@ -5261,26 +5194,26 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, & flt, tcd, qcd, & dfh, & s_aw, s_awchem, & - emis_ant_no,frp, & - fire_turb ) + emis_ant_no, frp, rrfs_sd, & + enh_mix, smoke_dbg ) !------------------------------------------------------------------- INTEGER, INTENT(in) :: kts,kte,i - REAL, DIMENSION(kts:kte), INTENT(IN) :: dfh,dz,tcd,qcd REAL, DIMENSION(kts:kte), INTENT(INOUT) :: rho - REAL, INTENT(IN) :: delt,flt + REAL, INTENT(IN) :: flt + REAL(kind=kind_phys), INTENT(IN) :: delt,pblh INTEGER, INTENT(IN) :: nchem, kdvel, ndvel REAL, DIMENSION( kts:kte+1), INTENT(IN) :: s_aw REAL, DIMENSION( kts:kte, nchem ), INTENT(INOUT) :: chem1 REAL, DIMENSION( kts:kte+1,nchem), INTENT(IN) :: s_awchem REAL, DIMENSION( ndvel ), INTENT(IN) :: vd1 - REAL, INTENT(IN) :: emis_ant_no,frp,pblh - LOGICAL, INTENT(IN) :: fire_turb + REAL(kind=kind_phys), INTENT(IN) :: emis_ant_no,frp + LOGICAL, INTENT(IN) :: rrfs_sd,enh_mix,smoke_dbg !local vars REAL, DIMENSION(kts:kte) :: dtz - REAL, DIMENSION(1:kte-kts+1) :: a,b,c,d,x + REAL, DIMENSION(kts:kte) :: a,b,c,d,x REAL :: rhs,dztop REAL :: t,dzk REAL :: hght @@ -5292,9 +5225,9 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, & REAL, DIMENSION(kts:kte) :: rhoinv REAL, DIMENSION(kts:kte+1) :: rhoz,khdz - REAL, PARAMETER :: no_threshold = 0.1 - REAL, PARAMETER :: frp_threshold = 10.0 ! RAR 02/11/22: I increased the frp threshold to enhance mixing - REAL, PARAMETER :: pblh_threshold = 250.0 + REAL, PARAMETER :: NO_threshold = 10.0 ! For anthropogenic sources + REAL, PARAMETER :: frp_threshold = 10.0 ! RAR 02/11/22: I increased the frp threshold to enhance mixing over big fires + REAL, PARAMETER :: pblh_threshold = 100.0 dztop=.5*(dz(kte)+dz(kte-1)) @@ -5324,18 +5257,19 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, & khdz(k) = MAX(khdz(k), -0.5*(s_aw(k)-s_aw(k+1))) ENDDO - !Enhance diffusion over fires - IF ( fire_turb ) THEN + !Enhanced mixing over fires + IF ( rrfs_sd .and. enh_mix ) THEN DO k=kts+1,kte-1 khdz_old = khdz(k) khdz_back = pblh * 0.15 / dz(k) !Modify based on anthropogenic emissions of NO and FRP IF ( pblh < pblh_threshold ) THEN - IF ( emis_ant_no > no_threshold ) THEN - khdz(k) = MAX(1.1*khdz(k),sqrt((emis_ant_no / no_threshold)) / dz(k) * rhoz(k)) ! JLS 12/21/21 + IF ( emis_ant_no > NO_threshold ) THEN + khdz(k) = MAX(1.1*khdz(k),sqrt((emis_ant_no / NO_threshold)) / dz(k) * rhoz(k)) ! JLS 12/21/21 ! khdz(k) = MAX(khdz(k),khdz_back) ENDIF IF ( frp > frp_threshold ) THEN + kmaxfire = ceiling(log(frp)) khdz(k) = MAX(1.1*khdz(k), (1. - k/(kmaxfire*2.)) * ((log(frp))**2.- 2.*log(frp)) / dz(k)*rhoz(k)) ! JLS 12/21/21 ! khdz(k) = MAX(khdz(k),khdz_back) ENDIF @@ -5354,7 +5288,7 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, & b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) d(k)=chem1(k,ic) & !dtz(k)*flt !neglecting surface sources - & + dtz(k) * -vd1(ic)*chem1(1,ic) & + & - dtz(k)*vd1(ic)*chem1(k,ic) & & - dtz(k)*rhoinv(k)*s_awchem(k+1,ic) DO k=kts+1,kte-1 @@ -5371,11 +5305,14 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, & c(kte)=0. d(kte)=chem1(kte,ic) - !CALL tridiag(kte,a,b,c,d) CALL tridiag3(kte,a,b,c,d,x) + IF ( smoke_dbg ) THEN + print*,'aerosol mixing ic,chem1,chem2(k,ic)',ic,(chem1(kts:kts+10,ic)),(x(kts:kts+10)) + print*,'aerosol PBL mixing ic,vd1(ic)',ic,vd1(ic) + END IF + DO k=kts,kte - !chem_new(k,ic)=d(k) chem1(k,ic)=x(k) ENDDO ENDDO @@ -5383,7 +5320,7 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, & END SUBROUTINE mynn_mix_chem ! ================================================================== -!>\ingroup gp_mynnedmf +!>\ingroup gsd_mynn_edmf SUBROUTINE retrieve_exchange_coeffs(kts,kte,& &dfm,dfh,dz,K_m,K_h) @@ -5411,7 +5348,7 @@ SUBROUTINE retrieve_exchange_coeffs(kts,kte,& END SUBROUTINE retrieve_exchange_coeffs ! ================================================================== -!>\ingroup gp_mynnedmf +!>\ingroup gsd_mynn_edmf SUBROUTINE tridiag(n,a,b,c,d) !! to solve system of linear eqs on tridiagonal matrix n times n @@ -5447,7 +5384,7 @@ SUBROUTINE tridiag(n,a,b,c,d) END SUBROUTINE tridiag ! ================================================================== -!>\ingroup gp_mynnedmf +!>\ingroup gsd_mynn_edmf subroutine tridiag2(n,a,b,c,d,x) implicit none ! a - sub-diagonal (means it is the diagonal below the main diagonal) @@ -5482,7 +5419,7 @@ subroutine tridiag2(n,a,b,c,d,x) end subroutine tridiag2 ! ================================================================== -!>\ingroup gp_mynnedmf +!>\ingroup gsd_mynn_edmf subroutine tridiag3(kte,a,b,c,d,x) !ccccccccccccccccccccccccccccccc @@ -5524,65 +5461,7 @@ subroutine tridiag3(kte,a,b,c,d,x) end subroutine tridiag3 ! ================================================================== - -!>\ingroup gp_mynnedmf -!! - SUBROUTINE mynn_bl_init_driver( & - &RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN, & - &RQCBLTEN,RQIBLTEN & !,RQNIBLTEN,RQNCBLTEN & - &,QKE, & - &EXCH_H & - !&,icloud_bl,qc_bl,cldfra_bl & - &,RESTART,ALLOWED_TO_READ,LEVEL & - &,IDS,IDE,JDS,JDE,KDS,KDE & - &,IMS,IME,JMS,JME,KMS,KME & - &,ITS,ITE,JTS,JTE,KTS,KTE) - - !--------------------------------------------------------------- - LOGICAL,INTENT(IN) :: ALLOWED_TO_READ,RESTART - INTEGER,INTENT(IN) :: LEVEL !,icloud_bl - - 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),INTENT(INOUT) :: & - &RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN, & - &RQCBLTEN,RQIBLTEN,& !RQNIBLTEN,RQNCBLTEN & - &QKE,EXCH_H - - INTEGER :: I,J,K,ITF,JTF,KTF - - JTF=MIN0(JTE,JDE-1) - KTF=MIN0(KTE,KDE-1) - ITF=MIN0(ITE,IDE-1) - - IF(.NOT.RESTART)THEN - DO K=KTS,KTF - DO I=ITS,ITF - RUBLTEN(i,k)=0. - RVBLTEN(i,k)=0. - RTHBLTEN(i,k)=0. - RQVBLTEN(i,k)=0. - if( p_qc >= param_first_scalar ) RQCBLTEN(i,k)=0. - if( p_qi >= param_first_scalar ) RQIBLTEN(i,k)=0. - !if( p_qnc >= param_first_scalar ) RQNCBLTEN(i,k)=0. - !if( p_qni >= param_first_scalar ) RQNIBLTEN(i,k)=0. - !QKE(i,k)=0. - EXCH_H(i,k)=0. -! if(icloud_bl > 0) qc_bl(i,k)=0. -! if(icloud_bl > 0) cldfra_bl(i,k)=0. - ENDDO - ENDDO - ENDIF - - mynn_level=level - - END SUBROUTINE mynn_bl_init_driver - -! ================================================================== -!>\ingroup gp_mynnedmf +!>\ingroup gsd_mynn_edmf !! This subroutine calculates hybrid diagnotic boundary-layer height (PBLH). !! !! NOTES ON THE PBLH FORMULATION: The 1.5-theta-increase method defines @@ -5627,7 +5506,7 @@ SUBROUTINE GET_PBLH(KTS,KTE,zi,thetav1D,qke1D,zw1D,dz1D,landsea,kzi) # define kte HARDCODE_VERTICAL #endif - REAL, INTENT(OUT) :: zi + REAL(kind=kind_phys), INTENT(OUT) :: zi REAL, INTENT(IN) :: landsea REAL, DIMENSION(KTS:KTE), INTENT(IN) :: thetav1D, qke1D, dz1D REAL, DIMENSION(KTS:KTE+1), INTENT(IN) :: zw1D @@ -5744,7 +5623,8 @@ SUBROUTINE GET_PBLH(KTS,KTE,zi,thetav1D,qke1D,zw1D,dz1D,landsea,kzi) END SUBROUTINE GET_PBLH !> @} -!>\ingroup gp_mynnedmf +! ================================================================== +!>\ingroup gsd_mynn_edmf !! This subroutine is the Dynamic Multi-Plume (DMP) Mass-Flux Scheme. !! !! dmp_mf() calculates the nonlocal turbulent transport from the dynamic @@ -5762,46 +5642,47 @@ END SUBROUTINE GET_PBLH !! !! This scheme remains under development, so consider it experimental code. !! - SUBROUTINE DMP_mf( & - & kts,kte,dt,zw,dz,p,rho, & - & momentum_opt, & - & tke_opt, & - & scalar_opt, & - & u,v,w,th,thl,thv,tk, & - & qt,qv,qc,qke, & - & qnc,qni,qnwfa,qnifa, & - & exner,vt,vq,sgm, & - & ust,flt,fltv,flq,flqv, & - & pblh,kpbl,DX,landsea,ts, & + SUBROUTINE DMP_mf( & + & kts,kte,dt,zw,dz,p,rho, & + & momentum_opt, & + & tke_opt, & + & scalar_opt, & + & u,v,w,th,thl,thv,tk, & + & qt,qv,qc,qke, & + & qnc,qni,qnwfa,qnifa,qnbca, & + & exner,vt,vq,sgm, & + & ust,flt,fltv,flq,flqv, & + & pblh,kpbl,dx,landsea,ts, & ! outputs - updraft properties - & edmf_a,edmf_w, & - & edmf_qt,edmf_thl, & - & edmf_ent,edmf_qc, & + & edmf_a,edmf_w, & + & edmf_qt,edmf_thl, & + & edmf_ent,edmf_qc, & ! outputs - variables needed for solver - & s_aw,s_awthl,s_awqt, & - & s_awqv,s_awqc, & - & s_awu,s_awv,s_awqke, & - & s_awqnc,s_awqni, & - & s_awqnwfa,s_awqnifa, & - & sub_thl,sub_sqv, & - & sub_u,sub_v, & - & det_thl,det_sqv,det_sqc, & - & det_u,det_v, & + & s_aw,s_awthl,s_awqt, & + & s_awqv,s_awqc, & + & s_awu,s_awv,s_awqke, & + & s_awqnc,s_awqni, & + & s_awqnwfa,s_awqnifa, & + & s_awqnbca, & + & sub_thl,sub_sqv, & + & sub_u,sub_v, & + & det_thl,det_sqv,det_sqc, & + & det_u,det_v, & ! chem/smoke - & nchem,chem1,s_awchem, & - & mix_chem, & + & nchem,chem1,s_awchem, & + & mix_chem, & ! in/outputs - subgrid scale clouds & qc_bl1d,cldfra_bl1d, & & qc_bl1D_old,cldfra_bl1D_old, & ! inputs - flags for moist arrays - & F_QC,F_QI, & - F_QNC,F_QNI, & - & F_QNWFA,F_QNIFA, & - & Psig_shcu, & + & F_QC,F_QI, & + & F_QNC,F_QNI, & + & F_QNWFA,F_QNIFA,F_QNBCA, & + & Psig_shcu, & ! output info - &nup2,ktop,maxmf,ztop, & - ! unputs for stochastic perturbations - &spp_pbl,rstoch_col) + & nup2,ktop,maxmf,ztop, & + ! inputs for stochastic perturbations + & spp_pbl,rstoch_col ) ! inputs: INTEGER, INTENT(IN) :: KTS,KTE,KPBL,momentum_opt,tke_opt,scalar_opt @@ -5815,21 +5696,22 @@ SUBROUTINE DMP_mf( & INTEGER, INTENT(IN) :: spp_pbl REAL, DIMENSION(KTS:KTE) :: rstoch_col - REAL,DIMENSION(KTS:KTE), INTENT(IN) :: U,V,W,TH,THL,TK,QT,QV,QC,& - exner,dz,THV,P,rho,qke,qnc,qni,qnwfa,qnifa - REAL,DIMENSION(KTS:KTE+1), INTENT(IN) :: ZW !height at full-sigma - REAL, INTENT(IN) :: DT,UST,FLT,FLTV,FLQ,FLQV,PBLH,& - DX,Psig_shcu,landsea,ts - LOGICAL, OPTIONAL :: F_QC,F_QI,F_QNC,F_QNI,F_QNWFA,F_QNIFA + REAL,DIMENSION(KTS:KTE), INTENT(IN) :: U,V,W,TH,THL,TK,QT,QV,QC, & + exner,dz,THV,P,rho,qke,qnc,qni,qnwfa,qnifa,qnbca + REAL,DIMENSION(KTS:KTE+1), INTENT(IN) :: zw !height at full-sigma + REAL, INTENT(IN) :: flt,fltv,flq,flqv,Psig_shcu,landsea,ts + REAL(kind=kind_phys), INTENT(IN) :: dx,dt,ust,pblh + LOGICAL, OPTIONAL :: F_QC,F_QI,F_QNC,F_QNI,F_QNWFA,F_QNIFA,F_QNBCA ! outputs - updraft properties - REAL,DIMENSION(KTS:KTE), INTENT(OUT) :: edmf_a,edmf_w, & - & edmf_qt,edmf_thl, edmf_ent,edmf_qc + REAL,DIMENSION(KTS:KTE), INTENT(OUT) :: edmf_a,edmf_w, & + & edmf_qt,edmf_thl,edmf_ent,edmf_qc !add one local edmf variable: REAL,DIMENSION(KTS:KTE) :: edmf_th ! output INTEGER, INTENT(OUT) :: nup2,ktop - REAL, INTENT(OUT) :: maxmf,ztop + REAL(kind=kind_phys), INTENT(OUT) :: maxmf + REAL, INTENT(OUT) :: ztop ! outputs - variables needed for solver REAL,DIMENSION(KTS:KTE+1) :: s_aw, & !sum ai*rho*wis_awphi s_awthl, & !sum ai*rho*wi*phii @@ -5840,6 +5722,7 @@ SUBROUTINE DMP_mf( & s_awqni, & s_awqnwfa, & s_awqnifa, & + s_awqnbca, & s_awu, & s_awv, & s_awqke, s_aw2 @@ -5847,14 +5730,14 @@ SUBROUTINE DMP_mf( & REAL,DIMENSION(KTS:KTE), INTENT(INOUT) :: qc_bl1d,cldfra_bl1d, & qc_bl1d_old,cldfra_bl1d_old - INTEGER, PARAMETER :: NUP=10, debug_mf=0 + INTEGER, PARAMETER :: nup=10, debug_mf=0 !------------- local variables ------------------- ! updraft properties defined on interfaces (k=1 is the top of the ! first model layer REAL,DIMENSION(KTS:KTE+1,1:NUP) :: UPW,UPTHL,UPQT,UPQC,UPQV, & UPA,UPU,UPV,UPTHV,UPQKE,UPQNC, & - UPQNI,UPQNWFA,UPQNIFA + UPQNI,UPQNWFA,UPQNIFA,UPQNBCA ! entrainment variables REAL,DIMENSION(KTS:KTE,1:NUP) :: ENT,ENTf INTEGER,DIMENSION(KTS:KTE,1:NUP) :: ENTi @@ -5862,7 +5745,8 @@ SUBROUTINE DMP_mf( & INTEGER :: K,I,k50 REAL :: fltv2,wstar,qstar,thstar,sigmaW,sigmaQT,sigmaTH,z0, & pwmin,pwmax,wmin,wmax,wlv,Psig_w,maxw,maxqc,wpbl - REAL :: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,QNCn,QNIn,QNWFAn,QNIFAn, & + REAL :: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,QNCn,QNIn, & + QNWFAn,QNIFAn,QNBCAn, & Wn2,Wn,EntEXP,EntEXM,EntW,BCOEFF,THVkm1,THVk,Pk,rho_int ! w parameters @@ -5904,13 +5788,14 @@ SUBROUTINE DMP_mf( & ! VARIABLES FOR CHABOUREAU-BECHTOLD CLOUD FRACTION REAL,DIMENSION(KTS:KTE), INTENT(INOUT) :: vt, vq, sgm - REAL :: sigq,xl,rsl,cpm,a,qmq,mf_cf,Q1,diffqt,qsat_tk,& + REAL :: sigq,xl,rsl,cpm,a,qmq,mf_cf,Aup,Q1,diffqt,qsat_tk,& Fng,qww,alpha,beta,bb,f,pt,t,q2p,b9,satvp,rhgrid, & Ac_mf,Ac_strat,qc_mf + REAL, PARAMETER :: cf_thresh = 0.5 ! only overwrite stratus CF less than this value ! Variables for plume interpolation/saturation check REAL,DIMENSION(KTS:KTE) :: exneri,dzi - REAL :: THp, QTp, QCp, QCs, esat, qsl + REAL :: THp, QTp, QCp, QCs, esat, qsl REAL :: csigma,acfac,ac_wsp,ac_cld !plume overshoot @@ -5931,7 +5816,7 @@ SUBROUTINE DMP_mf( & REAL,DIMENSION(KTS:KTE+1) :: envi_a,envi_w !environmental variables defined at model interface REAL :: temp,sublim,qc_ent,qv_ent,qt_ent,thl_ent,detrate, & detrateUV,oow,exc_fac,aratio,detturb,qc_grid,qc_sgs,& - qc_plume + qc_plume,exc_heat,exc_moist,tk_int REAL, PARAMETER :: Cdet = 1./45. REAL, PARAMETER :: dzpmax = 300. !limit dz used in detrainment - can be excessing in thick layers !parameter "Csub" determines the propotion of upward vertical velocity that contributes to @@ -5971,6 +5856,7 @@ SUBROUTINE DMP_mf( & UPQNI=0. UPQNWFA=0. UPQNIFA=0. + UPQNBCA=0. IF ( mix_chem ) THEN UPCHEM(KTS:KTE+1,1:NUP,1:nchem)=0.0 ENDIF @@ -6000,6 +5886,7 @@ SUBROUTINE DMP_mf( & s_awqni=0. s_awqnwfa=0. s_awqnifa=0. + s_awqnbca=0. IF ( mix_chem ) THEN s_awchem(kts:kte+1,1:nchem) = 0.0 ENDIF @@ -6200,18 +6087,34 @@ SUBROUTINE DMP_mf( & UPV(1,I)=(V(KTS)*DZ(KTS+1)+V(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) UPQC(1,I)=0.0 !UPQC(1,I)=(QC(KTS)*DZ(KTS+1)+QC(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) - UPQT(1,I)=(QT(KTS)*DZ(KTS+1)+QT(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))& - & +exc_fac*UPW(1,I)*sigmaQT/sigmaW + + exc_heat = exc_fac*UPW(1,I)*sigmaTH/sigmaW UPTHV(1,I)=(THV(KTS)*DZ(KTS+1)+THV(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) & - & +exc_fac*UPW(1,I)*sigmaTH/sigmaW + & + exc_heat !was UPTHL(1,I)= UPTHV(1,I)/(1.+svp1*UPQT(1,I)) !assume no saturated parcel at surface UPTHL(1,I)=(THL(KTS)*DZ(KTS+1)+THL(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) & - & +exc_fac*UPW(1,I)*sigmaTH/sigmaW + & + exc_heat + + !calculate exc_moist by use of surface fluxes + exc_moist=exc_fac*UPW(1,I)*sigmaQT/sigmaW + !calculate exc_moist by conserving rh: +! tk_int =(tk(kts)*dz(kts+1)+tk(kts+1)*dz(kts))/(dz(kts+1)+dz(kts)) +! pk =(p(kts)*dz(kts+1)+p(kts+1)*dz(kts))/(dz(kts+1)+dz(kts)) +! qtk =(qt(kts)*dz(kts+1)+qt(kts+1)*dz(kts))/(dz(kts)+dz(kts+1)) +! qsat_tk = qsat_blend(tk_int, pk) ! saturation water vapor mixing ratio at tk and p +! rhgrid =MAX(MIN(1.0,qtk/MAX(1.E-8,qsat_tk)),0.001) +! tk_int = tk_int + exc_heat +! qsat_tk = qsat_blend(tk_int, pk) +! exc_moist= max(rhgrid*qsat_tk - qtk, 0.0) + UPQT(1,I)=(QT(KTS)*DZ(KTS+1)+QT(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))& + & +exc_moist + UPQKE(1,I)=(QKE(KTS)*DZ(KTS+1)+QKE(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) UPQNC(1,I)=(QNC(KTS)*DZ(KTS+1)+QNC(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) UPQNI(1,I)=(QNI(KTS)*DZ(KTS+1)+QNI(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) UPQNWFA(1,I)=(QNWFA(KTS)*DZ(KTS+1)+QNWFA(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) UPQNIFA(1,I)=(QNIFA(KTS)*DZ(KTS+1)+QNIFA(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) + UPQNBCA(1,I)=(QNBCA(KTS)*DZ(KTS+1)+QNBCA(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) ENDDO IF ( mix_chem ) THEN @@ -6284,6 +6187,7 @@ SUBROUTINE DMP_mf( & QNIn=UPQNI(k-1,I)*(1.-EntExp) + QNI(k)*EntExp QNWFAn=UPQNWFA(k-1,I)*(1.-EntExp) + QNWFA(k)*EntExp QNIFAn=UPQNIFA(k-1,I)*(1.-EntExp) + QNIFA(k)*EntExp + QNBCAn=UPQNBCA(k-1,I)*(1.-EntExp) + QNBCA(k)*EntExp !capture the updated qc, qt & thl modified by entranment alone, !since they will be modified later if condensation occurs. @@ -6299,14 +6203,14 @@ SUBROUTINE DMP_mf( & !Vn =V(K) *(1-EntExp)+UPV(K-1,I)*EntExp !QKEn=QKE(k)*(1-EntExp)+UPQKE(K-1,I)*EntExp - IF ( mix_chem ) THEN + if ( mix_chem ) then do ic = 1,nchem ! Exponential Entrainment: !chemn(ic) = chem(k,ic)*(1-EntExp)+UPCHEM(K-1,I,ic)*EntExp ! Linear entrainment: chemn(ic)=UPCHEM(k-1,i,ic)*(1.-EntExp) + chem1(k,ic)*EntExp enddo - ENDIF + endif ! Define pressure at model interface Pk =(P(k)*DZ(k+1)+P(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) @@ -6380,13 +6284,10 @@ SUBROUTINE DMP_mf( & dzp = dz(k) ENDIF - !Limit very tall plumes - Wn=Wn*EXP(-MAX(ZW(k+1)-MIN(pblh+2000.,3500.),0.0)/1000.) - - !JOE- minimize the plume penetratration in stratocu-topped PBL - ! IF (fltv2 < 0.06) THEN - ! IF(ZW(k+1) >= pblh-200. .AND. qc(k) > 1e-5 .AND. I > 4) Wn=0. - ! ENDIF + !minimize the plume penetratration in stratocu-topped PBL + !IF (fltv2 < 0.06) THEN + ! IF(ZW(k+1) >= pblh-200. .AND. qc(k) > 1e-5 .AND. I > 4) Wn=0. + !ENDIF !Modify environment variables (representative of the model layer - envm*) !following the updraft dynamical detrainment of Asai and Kasahara (1967, JAS). @@ -6424,6 +6325,7 @@ SUBROUTINE DMP_mf( & UPQNI(K,I)=QNIn UPQNWFA(K,I)=QNWFAn UPQNIFA(K,I)=QNIFAn + UPQNBCA(K,I)=QNBCAn UPA(K,I)=UPA(K-1,I) IF ( mix_chem ) THEN do ic = 1,nchem @@ -6479,13 +6381,13 @@ SUBROUTINE DMP_mf( & s_awthl(k+1)= s_awthl(k+1) + rho_int*UPA(K,i)*UPW(K,i)*UPTHL(K,i)*Psig_w s_awqt(k+1) = s_awqt(k+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQT(K,i)*Psig_w !to conform to grid mean properties, move qc to qv in grid mean - !saturated layers, so total water fluxes are preserve but + !saturated layers, so total water fluxes are preserved but !negative qc fluxes in unsaturated layers is reduced. - IF (qc(k) > 1e-12 .OR. qc(k+1) > 1e-12) then +! if (qc(k) > 1e-12 .or. qc(k+1) > 1e-12) then qc_plume = UPQC(K,i) - ELSE - qc_plume = 0.0 - ENDIF +! else +! qc_plume = 0.0 +! endif s_awqc(k+1) = s_awqc(k+1) + rho_int*UPA(K,i)*UPW(K,i)*qc_plume*Psig_w IF (momentum_opt > 0) THEN s_awu(k+1) = s_awu(k+1) + rho_int*UPA(K,i)*UPW(K,i)*UPU(K,i)*Psig_w @@ -6521,6 +6423,7 @@ SUBROUTINE DMP_mf( & s_awqni(k+1)= s_awqni(K+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQNI(K,i)*Psig_w s_awqnwfa(k+1)= s_awqnwfa(K+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQNWFA(K,i)*Psig_w s_awqnifa(k+1)= s_awqnifa(K+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQNIFA(K,i)*Psig_w + s_awqnbca(k+1)= s_awqnbca(K+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQNBCA(K,i)*Psig_w ENDDO ENDDO ENDIF @@ -6550,6 +6453,7 @@ SUBROUTINE DMP_mf( & s_awqni= s_awqni*adjustment s_awqnwfa= s_awqnwfa*adjustment s_awqnifa= s_awqnifa*adjustment + s_awqnbca= s_awqnbca*adjustment IF (momentum_opt > 0) THEN s_awu = s_awu*adjustment s_awv = s_awv*adjustment @@ -6596,9 +6500,9 @@ SUBROUTINE DMP_mf( & !smoke/chem IF ( mix_chem ) THEN - DO k=KTS,KTE-1 + DO k=kts,kte-1 IF(k > KTOP) exit - rho_int = (rho(k)*DZ(k+1)+rho(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) + rho_int = (rho(k)*dz(k+1)+rho(k+1)*dz(k))/(dz(k+1)+dz(k)) DO I=1,NUP !NUP2 IF(I > NUP2) exit do ic = 1,nchem @@ -6615,14 +6519,14 @@ SUBROUTINE DMP_mf( & ENDIF !Calculate the effects environmental subsidence. - !All envi_*variables are valid at the interfaces, like the edmf_* variables + !All envi_*variables are valid at the interfaces, like the edmf_* variables IF (env_subs) THEN - DO k=KTS+1,KTE-1 + DO k=kts+1,kte-1 !First, smooth the profiles of w & a, since sharp vertical gradients !in plume variables are not likely extended to env variables !Note1: w is treated as negative further below !Note2: both w & a will be transformed into env variables further below - envi_w(k) = onethird*(edmf_w(K-1)+edmf_w(K)+edmf_w(K+1)) + envi_w(k) = onethird*(edmf_w(k-1)+edmf_w(k)+edmf_w(k+1)) envi_a(k) = onethird*(edmf_a(k-1)+edmf_a(k)+edmf_a(k+1))*adjustment ENDDO !define env variables at k=1 (top of first model layer) @@ -6643,22 +6547,26 @@ SUBROUTINE DMP_mf( & sublim = 1.0 ENDIF !Transform w & a into env variables - DO k=KTS,KTE + DO k=kts,kte temp=envi_a(k) envi_a(k)=1.0-temp envi_w(k)=csub*sublim*envi_w(k)*temp/(1.-temp) ENDDO !calculate tendencies from subsidence and detrainment valid at the middle of - !each model layer - dzi(kts) = 0.5*(DZ(kts)+DZ(kts+1)) - sub_thl(kts)=0.5*envi_w(kts)*envi_a(kts)*(thl(kts+1)-thl(kts))/dzi(kts) - sub_sqv(kts)=0.5*envi_w(kts)*envi_a(kts)*(qv(kts+1)-qv(kts))/dzi(kts) - DO k=KTS+1,KTE-1 - dzi(k) = 0.5*(DZ(k)+DZ(k+1)) - sub_thl(k)=0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * & - (thl(k+1)-thl(k))/dzi(k) - sub_sqv(k)=0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * & - (qv(k+1)-qv(k))/dzi(k) + !each model layer. The lowest model layer uses an assumes w=0 at the surface. + dzi(kts) = 0.5*(dz(kts)+dz(kts+1)) + rho_int = (rho(kts)*dz(kts+1)+rho(kts+1)*dz(kts))/(dz(kts+1)+dz(kts)) + sub_thl(kts)= 0.5*envi_w(kts)*envi_a(kts)* & + (rho(kts+1)*thl(kts+1)-rho(kts)*thl(kts))/dzi(kts)/rho_int + sub_sqv(kts)= 0.5*envi_w(kts)*envi_a(kts)* & + (rho(kts+1)*qv(kts+1)-rho(kts)*qv(kts))/dzi(kts)/rho_int + DO k=kts+1,kte-1 + dzi(k) = 0.5*(dz(k)+dz(k+1)) + rho_int = (rho(k)*dz(k+1)+rho(k+1)*dz(k))/(dz(k+1)+dz(k)) + sub_thl(k)= 0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * & + (rho(k+1)*thl(k+1)-rho(k)*thl(k))/dzi(k)/rho_int + sub_sqv(k)= 0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * & + (rho(k+1)*qv(k+1)-rho(k)*qv(k))/dzi(k)/rho_int ENDDO DO k=KTS,KTE-1 @@ -6668,13 +6576,17 @@ SUBROUTINE DMP_mf( & ENDDO IF (momentum_opt > 0) THEN - sub_u(kts)=0.5*envi_w(kts)*envi_a(kts)*(u(kts+1)-u(kts))/dzi(kts) - sub_v(kts)=0.5*envi_w(kts)*envi_a(kts)*(v(kts+1)-v(kts))/dzi(kts) - DO k=KTS+1,KTE-1 + rho_int = (rho(kts)*dz(kts+1)+rho(kts+1)*dz(kts))/(dz(kts+1)+dz(kts)) + sub_u(kts)=0.5*envi_w(kts)*envi_a(kts)* & + (rho(kts+1)*u(kts+1)-rho(kts)*u(kts))/dzi(kts)/rho_int + sub_v(kts)=0.5*envi_w(kts)*envi_a(kts)* & + (rho(kts+1)*v(kts+1)-rho(kts)*v(kts))/dzi(kts)/rho_int + DO k=kts+1,kte-1 + rho_int = (rho(k)*dz(k+1)+rho(k+1)*dz(k))/(dz(k+1)+dz(k)) sub_u(k)=0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * & - (u(k+1)-u(k))/dzi(k) + (rho(k+1)*u(k+1)-rho(k)*u(k))/dzi(k)/rho_int sub_v(k)=0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * & - (v(k+1)-v(k))/dzi(k) + (rho(k+1)*v(k+1)-rho(k)*v(k))/dzi(k)/rho_int ENDDO DO k=KTS,KTE-1 @@ -6695,27 +6607,27 @@ SUBROUTINE DMP_mf( & !JOE: ADD CLDFRA_bl1d, qc_bl1d. Note that they have already been defined in ! mym_condensation. Here, a shallow-cu component is added, but no cumulus -! clouds can be added at k=1 (start loop at k=2). - DO K=KTS+1,KTE-2 - IF(k > KTOP) exit - IF(0.5*(edmf_qc(k)+edmf_qc(k-1))>0.0)THEN - - !interpolate plume thl, th, and qt to mass levels +! clouds can be added at k=1 (start loop at k=2). + do k=kts+1,kte-2 + IF(k > KTOP) exit + IF(0.5*(edmf_qc(k)+edmf_qc(k-1))>0.0 .and. (cldfra_bl1d(k) < cf_thresh))THEN + !interpolate plume quantities to mass levels + Aup = (edmf_a(k)*dzi(k-1)+edmf_a(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) THp = (edmf_th(k)*dzi(k-1)+edmf_th(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) QTp = (edmf_qt(k)*dzi(k-1)+edmf_qt(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) !convert TH to T - t = THp*exner(k) +! t = THp*exner(k) !SATURATED VAPOR PRESSURE - esat = esat_blend(t) + esat = esat_blend(tk(k)) !SATURATED SPECIFIC HUMIDITY - qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) + qsl=ep_2*esat/max(1.e-7,(p(k)-ep_3*esat)) !condensed liquid in the plume on mass levels - IF (edmf_qc(k)>0.0 .AND. edmf_qc(k-1)>0.0)THEN - QCp = 0.5*(edmf_qc(k)+edmf_qc(k-1)) - ELSE - QCp = MAX(edmf_qc(k),edmf_qc(k-1)) - ENDIF + if (edmf_qc(k)>0.0 .and. edmf_qc(k-1)>0.0) then + QCp = (edmf_qc(k)*dzi(k-1)+edmf_qc(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) + else + QCp = max(edmf_qc(k),edmf_qc(k-1)) + endif !COMPUTE CLDFRA & QC_BL FROM MASS-FLUX SCHEME and recompute vt & vq xl = xl_blend(tk(k)) ! obtain blended heat capacity @@ -6728,7 +6640,7 @@ SUBROUTINE DMP_mf( & b9 = a*rsl ! CB02 variable "b" q2p = xlvcp/exner(k) - pt = thl(k) +q2p*QCp*0.5*(edmf_a(k)+edmf_a(k-1)) ! potential temp (env + plume) + pt = thl(k) +q2p*QCp*Aup ! potential temp (env + plume) bb = b9*tk(k)/pt ! bb is "b9" in BCMT95. Their "b9" differs from ! "b9" in CB02 by a factor ! of T/theta. Strictly, b9 above is formulated in @@ -6748,17 +6660,33 @@ SUBROUTINE DMP_mf( & endif !CB form: - !sigq = 9.E-3 * 0.5*(edmf_a(k)+edmf_a(k-1)) * & - ! & 0.5*(edmf_w(k)+edmf_w(k-1)) * f ! convective component of sigma (CB2005) + !sigq = 3.5E-3 * Aup * 0.5*(edmf_w(k)+edmf_w(k-1)) * f ! convective component of sigma (CB2005) !sigq = SQRT(sigq**2 + sgm(k)**2) ! combined conv + stratus components !Per S.DeRoode 2009? - sigq = 10. * edmf_a(k) * (edmf_qt(k)-qt(k)) - - sigq = MAX(sigq, 1.0E-6) + !sigq = 5. * Aup * (QTp - qt(k)) + sigq = 10. * Aup * (QTp - qt(k)) + !constrain sigq wrt saturation: + sigq = max(sigq, qsat_tk*0.02 ) + sigq = min(sigq, qsat_tk*0.25 ) qmq = a * (qt(k) - qsat_tk) ! saturation deficit/excess; - ! the numerator of Q1 - mf_cf= min(max(0.5 + 0.36 * atan(1.55*(qmq/sigq)),0.01),0.6) + Q1 = qmq/sigq ! the numerator of Q1 + + if ((landsea-1.5).GE.0) then ! WATER + !modified form from LES + !mf_cf = min(max(0.5 + 0.36 * atan(1.20*(Q1+0.2)),0.01),0.6) + !Original CB + mf_cf = min(max(0.5 + 0.36 * atan(1.55*Q1),0.01),0.6) + mf_cf = max(mf_cf, 1.2 * Aup) + mf_cf = min(mf_cf, 5.0 * Aup) + else ! LAND + !LES form + !mf_cf = min(max(0.5 + 0.36 * atan(1.20*(Q1+0.4)),0.01),0.6) + !Original CB + mf_cf = min(max(0.5 + 0.36 * atan(1.55*Q1),0.01),0.6) + mf_cf = max(mf_cf, 1.75 * Aup) + mf_cf = min(mf_cf, 5.0 * Aup) + endif !IF ( debug_code ) THEN ! print*,"In MYNN, StEM edmf" @@ -6769,74 +6697,71 @@ SUBROUTINE DMP_mf( & !ENDIF ! Update cloud fractions and specific humidities in grid cells - ! where the mass-flux scheme is active. Now, we also use the - ! stratus component of the SGS clouds as well. The stratus cloud - ! fractions (Ac_strat) are reduced slightly to give way to the - ! mass-flux SGS cloud fractions (Ac_mf). - IF (cldfra_bl1d(k) < 0.5) THEN - IF (mf_cf > 0.5*(edmf_a(k)+edmf_a(k-1))) THEN - !cldfra_bl1d(k) = mf_cf - !qc_bl1d(k) = QCp*0.5*(edmf_a(k)+edmf_a(k-1))/mf_cf - Ac_mf = mf_cf - Ac_strat = cldfra_bl1d(k)*(1.0-mf_cf) - cldfra_bl1d(k) = Ac_mf + Ac_strat - !dillute Qc from updraft area to larger cloud area - qc_mf = QCp*0.5*(edmf_a(k)+edmf_a(k-1))/mf_cf - !The mixing ratios from the stratus component are not well - !estimated in shallow-cumulus regimes. Ensure stratus clouds - !have mixing ratio similar to cumulus - QCs = MAX(qc_bl1d(k), 0.5*qc_mf) - qc_bl1d(k) = (qc_mf*Ac_mf + QCs*Ac_strat)/cldfra_bl1d(k) - ELSE - !cldfra_bl1d(k)=0.5*(edmf_a(k)+edmf_a(k-1)) - !qc_bl1d(k) = QCp - Ac_mf = 0.5*(edmf_a(k)+edmf_a(k-1)) - Ac_strat = cldfra_bl1d(k)*(1.0-Ac_mf) - cldfra_bl1d(k)=Ac_mf + Ac_strat - qc_mf = QCp - !Ensure stratus clouds have mixing ratio similar to cumulus - QCs = MAX(qc_bl1d(k), 0.5*qc_mf) - qc_bl1d(k) = (QCp*Ac_mf + QCs*Ac_strat)/cldfra_bl1d(k) - ENDIF - ELSE - Ac_mf = mf_cf - ENDIF + ! where the mass-flux scheme is active. The specific humidities + ! are converted to grid means (not in-cloud quantities). + if ((landsea-1.5).GE.0) then ! water + if (QCp * Aup > 5e-5) then + qc_bl1d(k) = 1.86 * (QCp * Aup) - 2.2e-5 + else + qc_bl1d(k) = 1.18 * (QCp * Aup) + endif + if (mf_cf .ge. Aup) then + qc_bl1d(k) = qc_bl1d(k) / mf_cf + endif + cldfra_bl1d(k) = mf_cf + Ac_mf = mf_cf + else ! land + if (QCp * Aup > 5e-5) then + qc_bl1d(k) = 1.86 * (QCp * Aup) - 2.2e-5 + else + qc_bl1d(k) = 1.18 * (QCp * Aup) + endif + if (mf_cf .ge. Aup) then + qc_bl1d(k) = qc_bl1d(k) / mf_cf + endif + cldfra_bl1d(k) = mf_cf + Ac_mf = mf_cf + endif !Now recalculate the terms for the buoyancy flux for mass-flux clouds: - !See mym_condensation for details on these formulations. The - !cloud-fraction bounding was added to improve cloud retention, - !following RAP and HRRR testing. - !Fng = 2.05 ! the non-Gaussian transport factor (assumed constant) - !Use Bechtold and Siebesma (1998) piecewise estimation of Fng: - Q1 = qmq/MAX(sigq,1E-6) - Q1=MAX(Q1,-5.0) - IF (Q1 .GE. 1.0) THEN + !See mym_condensation for details on these formulations. + !Use Bechtold and Siebesma (1998) piecewise estimation of Fng with + !limits ,since they really should be recalculated after all the other changes...: + !Only overwrite vt & vq in non-stratus condition + !if ((landsea-1.5).GE.0) then ! WATER + Q1=max(Q1,-2.25) + !else + ! Q1=max(Q1,-2.0) + !endif + + if (Q1 .ge. 1.0) then Fng = 1.0 - ELSEIF (Q1 .GE. -1.7 .AND. Q1 .LT. 1.0) THEN + elseif (Q1 .ge. -1.7 .and. Q1 .lt. 1.0) then Fng = EXP(-0.4*(Q1-1.0)) - ELSEIF (Q1 .GE. -2.5 .AND. Q1 .LT. -1.7) THEN + elseif (Q1 .ge. -2.5 .and. Q1 .lt. -1.7) then Fng = 3.0 + EXP(-3.8*(Q1+1.7)) - ELSE - Fng = MIN(23.9 + EXP(-1.6*(Q1+2.5)), 60.) - ENDIF + else + Fng = min(23.9 + EXP(-1.6*(Q1+2.5)), 60.) + endif - vt(k) = qww - MIN(0.40,Ac_mf)*beta*bb*Fng - 1. - vq(k) = alpha + MIN(0.40,Ac_mf)*beta*a*Fng - tv0 - ENDIF - ENDDO + !link the buoyancy flux function to active clouds only (c*Aup): + vt(k) = qww - (1.5*Aup)*beta*bb*Fng - 1. + vq(k) = alpha + (1.5*Aup)*beta*a*Fng - tv0 + endif !check for (qc in plume) .and. (cldfra_bl < threshold) + enddo !k-loop ENDIF !end nup2 > 0 !modify output (negative: dry plume, positive: moist plume) - IF (ktop > 0) THEN + if (ktop > 0) then maxqc = maxval(edmf_qc(1:ktop)) - IF ( maxqc < 1.E-8) maxmf = -1.0*maxmf - ENDIF + if ( maxqc < 1.E-8) maxmf = -1.0*maxmf + endif ! -! debugging +! debugging ! -IF (edmf_w(1) > 4.0) THEN +if (edmf_w(1) > 4.0) then ! surface values print *,'flq:',flq,' fltv:',fltv2 print *,'pblh:',pblh,' wstar:',wstar @@ -6883,10 +6808,12 @@ SUBROUTINE DMP_mf( & END SUBROUTINE DMP_MF !================================================================= -!>\ingroup gp_mynnedmf -!! zero or one condensation for edmf: calculates THV and QC +!>\ingroup gsd_mynn_edmf +!! This subroutine subroutine condensation_edmf(QT,THL,P,zagl,THV,QC) ! +! zero or one condensation for edmf: calculates THV and QC +! real,intent(in) :: QT,THL,P,zagl real,intent(out) :: THV real,intent(inout):: QC @@ -6944,10 +6871,11 @@ end subroutine condensation_edmf !=============================================================== -!> zero or one condensation for edmf: calculates THL and QC -!! similar to condensation_edmf but with different inputs subroutine condensation_edmf_r(QT,THL,P,zagl,THV,QC) ! +! zero or one condensation for edmf: calculates THL and QC +! similar to condensation_edmf but with different inputs +! real,intent(in) :: QT,THV,P,zagl real,intent(out) :: THL, QC @@ -6979,10 +6907,12 @@ subroutine condensation_edmf_r(QT,THL,P,zagl,THV,QC) end subroutine condensation_edmf_r !=============================================================== -!> This is the downdraft mass flux scheme - analogus to edmf_JPL but -!! flipped updraft to downdraft. This scheme is currently only tested -!! for Stratocumulus cloud conditions. For a detailed desctiption of the -!! model, see paper. +! =================================================================== +! This is the downdraft mass flux scheme - analogus to edmf_JPL but +! flipped updraft to downdraft. This scheme is currently only tested +! for Stratocumulus cloud conditions. For a detailed desctiption of the +! model, see paper. + SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & &u,v,th,thl,thv,tk,qt,qv,qc, & &rho,exner, & @@ -6997,11 +6927,12 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & INTEGER, INTENT(IN) :: KTS,KTE,KPBL REAL,DIMENSION(KTS:KTE), INTENT(IN) :: U,V,TH,THL,TK,QT,QV,QC,& - THV,P,rho,exner,rthraten,dz + THV,P,rho,exner,dz + REAL(kind=kind_phys),DIMENSION(KTS:KTE), INTENT(IN) :: rthraten ! zw .. heights of the downdraft levels (edges of boxes) REAL,DIMENSION(KTS:KTE+1), INTENT(IN) :: ZW - REAL, INTENT(IN) :: DT,UST,WTHL,WQT,PBLH - + REAL, INTENT(IN) :: WTHL,WQT + REAL(kind=kind_phys), INTENT(IN) :: dt,ust,pblh ! outputs - downdraft properties REAL,DIMENSION(KTS:KTE), INTENT(OUT) :: edmf_a_dd,edmf_w_dd, & & edmf_qt_dd,edmf_thl_dd, edmf_ent_dd,edmf_qc_dd @@ -7342,17 +7273,19 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & END SUBROUTINE DDMF_JPL !=============================================================== -!> Add scale-aware factor (Psig) here, taken from Honnert et al. (2011) \cite Honnert_2011 -!! and/or from Shin and Hong (2013) \cite Shin_2013. + SUBROUTINE SCALE_AWARE(dx,PBL1,Psig_bl,Psig_shcu) !--------------------------------------------------------------- ! NOTES ON SCALE-AWARE FORMULATION ! + !JOE: add scale-aware factor (Psig) here, taken from Honnert et al. (2011, + ! JAS) and/or from Hyeyum Hailey Shin and Song-You Hong (2013, JAS) + ! ! Psig_bl tapers local mixing ! Psig_shcu tapers nonlocal mixing - REAL,INTENT(IN) :: dx,PBL1 + REAL(kind=kind_phys), INTENT(IN) :: dx,pbl1 REAL, INTENT(OUT) :: Psig_bl,Psig_shcu REAL :: dxdh @@ -7415,7 +7348,7 @@ SUBROUTINE SCALE_AWARE(dx,PBL1,Psig_bl,Psig_shcu) END SUBROUTINE SCALE_AWARE ! ===================================================================== -!>\ingroup gp_mynnedmf +!>\ingroup gsd_mynn_edmf !! \author JAYMES- added 22 Apr 2015 !! This function calculates saturation vapor pressure. Separate ice and liquid functions !! are used (identical to those in module_mp_thompson.F, v3.6). Then, the @@ -7428,20 +7361,40 @@ FUNCTION esat_blend(t) REAL, INTENT(IN):: t REAL :: esat_blend,XC,ESL,ESI,chi - - XC=MAX(-80.,t - t0c) !note t0c = 273.15, tice is set in module mynn_common - -! For 253 < t < 273.16 K, the vapor pressures are "blended" as a function of temperature, -! using the approach of Chaboureau and Bechtold (2002), JAS, p. 2363. The resulting + !liquid + REAL, PARAMETER:: J0= .611583699E03 + REAL, PARAMETER:: J1= .444606896E02 + REAL, PARAMETER:: J2= .143177157E01 + REAL, PARAMETER:: J3= .264224321E-1 + REAL, PARAMETER:: J4= .299291081E-3 + REAL, PARAMETER:: J5= .203154182E-5 + REAL, PARAMETER:: J6= .702620698E-8 + REAL, PARAMETER:: J7= .379534310E-11 + REAL, PARAMETER:: J8=-.321582393E-13 + !ice + REAL, PARAMETER:: K0= .609868993E03 + REAL, PARAMETER:: K1= .499320233E02 + REAL, PARAMETER:: K2= .184672631E01 + REAL, PARAMETER:: K3= .402737184E-1 + REAL, PARAMETER:: K4= .565392987E-3 + REAL, PARAMETER:: K5= .521693933E-5 + REAL, PARAMETER:: K6= .307839583E-7 + REAL, PARAMETER:: K7= .105785160E-9 + REAL, PARAMETER:: K8= .161444444E-12 + + XC=MAX(-80.,t - t0c) !note t0c = 273.15, tice is set in module mynn_common to 240 + +! For 240 < t < 268.16 K, the vapor pressures are "blended" as a function of temperature, +! using the approach similar to Chaboureau and Bechtold (2002), JAS, p. 2363. The resulting ! values are returned from the function. - IF (t .GE. t0c) THEN + IF (t .GE. (t0c-6.)) THEN esat_blend = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) ELSE IF (t .LE. tice) THEN esat_blend = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) ELSE - ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) - ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) - chi = (t0c - t)/(t0c - tice) + ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) + ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) + chi = ((t0c-6.) - t)/((t0c-6.) - tice) esat_blend = (1.-chi)*ESL + chi*ESI END IF @@ -7449,41 +7402,56 @@ END FUNCTION esat_blend ! ==================================================================== -!>\ingroup gp_mynnedmf +!>\ingroup gsd_mynn_edmf !! This function extends function "esat" and returns a "blended" -!! saturation mixing ratio. +!! saturation mixing ratio. Tice currently set to 240 K, t0c = 273.15 K. !!\author JAYMES - FUNCTION qsat_blend(t, P, waterice) + FUNCTION qsat_blend(t, P) IMPLICIT NONE REAL, INTENT(IN):: t, P - CHARACTER(LEN=1), OPTIONAL, INTENT(IN) :: waterice - CHARACTER(LEN=1) :: wrt REAL :: qsat_blend,XC,ESL,ESI,RSLF,RSIF,chi - - IF ( .NOT. PRESENT(waterice) ) THEN - wrt = 'b' - ELSE - wrt = waterice - ENDIF + !liquid + REAL, PARAMETER:: J0= .611583699E03 + REAL, PARAMETER:: J1= .444606896E02 + REAL, PARAMETER:: J2= .143177157E01 + REAL, PARAMETER:: J3= .264224321E-1 + REAL, PARAMETER:: J4= .299291081E-3 + REAL, PARAMETER:: J5= .203154182E-5 + REAL, PARAMETER:: J6= .702620698E-8 + REAL, PARAMETER:: J7= .379534310E-11 + REAL, PARAMETER:: J8=-.321582393E-13 + !ice + REAL, PARAMETER:: K0= .609868993E03 + REAL, PARAMETER:: K1= .499320233E02 + REAL, PARAMETER:: K2= .184672631E01 + REAL, PARAMETER:: K3= .402737184E-1 + REAL, PARAMETER:: K4= .565392987E-3 + REAL, PARAMETER:: K5= .521693933E-5 + REAL, PARAMETER:: K6= .307839583E-7 + REAL, PARAMETER:: K7= .105785160E-9 + REAL, PARAMETER:: K8= .161444444E-12 XC=MAX(-80.,t - t0c) - IF ((t .GE. t0c) .OR. (wrt .EQ. 'w')) THEN - ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) + IF (t .GE. (t0c-6.)) THEN + ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) + ESL = min(ESL, P*0.15) ! Even with P=1050mb and T=55C, the sat. vap. pres only contributes to ~15% of total pres. qsat_blend = 0.622*ESL/max(P-ESL, 1e-5) -! ELSE IF (t .LE. 253.) THEN ELSE IF (t .LE. tice) THEN ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) + ESI = min(ESI, P*0.15) qsat_blend = 0.622*ESI/max(P-ESI, 1e-5) ELSE ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) + ESL = min(ESL, P*0.15) ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) + ESI = min(ESI, P*0.15) RSLF = 0.622*ESL/max(P-ESL, 1e-5) RSIF = 0.622*ESI/max(P-ESI, 1e-5) -! chi = (273.16-t)/20.16 - chi = (t0c - t)/(t0c - tice) +! chi = (268.16-t)/(268.16-240.) + chi = ((t0c-6.) - t)/((t0c-6.) - tice) qsat_blend = (1.-chi)*RSLF + chi*RSIF END IF @@ -7491,7 +7459,7 @@ END FUNCTION qsat_blend ! =================================================================== -!>\ingroup gp_mynnedmf +!>\ingroup gsd_mynn_edmf !! This function interpolates the latent heats of vaporization and sublimation into !! a single, temperature-dependent, "blended" value, following !! Chaboureau and Bechtold (2002) \cite Chaboureau_2002, Appendix. @@ -7511,7 +7479,7 @@ FUNCTION xl_blend(t) ELSE xlvt = xlv + (cpv-cliq)*(t-t0c) !vaporization/condensation xlst = xls + (cpv-cice)*(t-t0c) !sublimation/deposition -! chi = (273.16-t)/20.16 +! chi = (273.16-t)/(273.16-240.) chi = (t0c - t)/(t0c - tice) xl_blend = (1.-chi)*xlvt + chi*xlst !blended END IF @@ -7519,13 +7487,14 @@ FUNCTION xl_blend(t) END FUNCTION xl_blend ! =================================================================== -!> New stability function parameters for momentum (Puhales, 2020, WRF 4.2.1) -!! The forms in unstable conditions (z/L < 0) use Grachev et al. (2000), which are a blend of -!! the classical (Kansas) forms (i.e., Paulson 1970, Dyer and Hicks 1970), valid for weakly -!! unstable conditions (-1 < z/L < 0). The stability functions for stable conditions use an -!! updated form taken from Cheng and Brutsaert (2005), which extends the validity into very -!! stable conditions [z/L ~ O(10)]. + FUNCTION phim(zet) + ! New stability function parameters for momentum (Puhales, 2020, WRF 4.2.1) + ! The forms in unstable conditions (z/L < 0) use Grachev et al. (2000), which are a blend of + ! the classical (Kansas) forms (i.e., Paulson 1970, Dyer and Hicks 1970), valid for weakly + ! unstable conditions (-1 < z/L < 0). The stability functions for stable conditions use an + ! updated form taken from Cheng and Brutsaert (2005), which extends the validity into very + ! stable conditions [z/L ~ O(10)]. IMPLICIT NONE REAL, INTENT(IN):: zet @@ -7569,14 +7538,15 @@ FUNCTION phim(zet) phim = phi_m END FUNCTION phim +! =================================================================== -!> New stability function parameters for heat (Puhales, 2020, WRF 4.2.1) -!! The forms in unstable conditions (z/L < 0) use Grachev et al. (2000), which are a blend of -!! the classical (Kansas) forms (i.e., Paulson 1970, Dyer and Hicks 1970), valid for weakly -!! unstable conditions (-1 < z/L < 0). The stability functions for stable conditions use an -!! updated form taken from Cheng and Brutsaert (2005), which extends the validity into very -!! stable conditions [z/L ~ O(10)]. FUNCTION phih(zet) + ! New stability function parameters for heat (Puhales, 2020, WRF 4.2.1) + ! The forms in unstable conditions (z/L < 0) use Grachev et al. (2000), which are a blend of + ! the classical (Kansas) forms (i.e., Paulson 1970, Dyer and Hicks 1970), valid for weakly + ! unstable conditions (-1 < z/L < 0). The stability functions for stable conditions use an + ! updated form taken from Cheng and Brutsaert (2005), which extends the validity into very + ! stable conditions [z/L ~ O(10)]. IMPLICIT NONE REAL, INTENT(IN):: zet @@ -7618,8 +7588,6 @@ FUNCTION phih(zet) END FUNCTION phih ! ================================================================== -!>\ingroup gp_mynnedmf -!! Calculate the buoyancy production of TKE from cloud-top cooling. SUBROUTINE topdown_cloudrad(kts,kte,dz1,zw,xland,kpbl,PBLH, & &sqc,sqi,sqw,thl,th1,ex1,p1,rho1,thetav, & &cldfra_bl1D,rthraten, & @@ -7628,9 +7596,11 @@ SUBROUTINE topdown_cloudrad(kts,kte,dz1,zw,xland,kpbl,PBLH, & !input integer, intent(in) :: kte,kts real, dimension(kts:kte), intent(in) :: dz1,sqc,sqi,sqw,& - thl,th1,ex1,p1,rho1,thetav,cldfra_bl1D,rthraten + thl,th1,ex1,p1,rho1,thetav,cldfra_bl1D + real(kind=kind_phys), dimension(kts:kte), intent(in) :: rthraten real, dimension(kts:kte+1), intent(in) :: zw - real, intent(in) :: pblh,xland + real(kind=kind_phys), intent(in) :: pblh + real, intent(in) :: xland integer,intent(in) :: kpbl !output real, intent(out) :: maxKHtopdown diff --git a/physics/mynnedmf_wrapper.F90 b/physics/mynnedmf_wrapper.F90 index 08a28f2bd..2467d4eda 100644 --- a/physics/mynnedmf_wrapper.F90 +++ b/physics/mynnedmf_wrapper.F90 @@ -82,12 +82,6 @@ subroutine mynnedmf_wrapper_init ( & return end if - if (lheatstrg) then - errmsg = 'Logic error: lheatstrg not implemented for MYNN PBL' - errflg = 1 - return - end if - end subroutine mynnedmf_wrapper_init !>\defgroup gp_mynnedmf MYNN-EDMF PBL and Shallow Convection Module @@ -105,13 +99,14 @@ SUBROUTINE mynnedmf_wrapper_run( & & qgrs_water_vapor, & & qgrs_liquid_cloud, & & qgrs_ice_cloud, & + & qgrs_snow_cloud, & & qgrs_cloud_droplet_num_conc, & & qgrs_cloud_ice_num_conc, & & qgrs_ozone, & & qgrs_water_aer_num_conc, & & qgrs_ice_aer_num_conc, & & qgrs_cccn, & - & prsl,exner, & + & prsl,prsi,exner, & & slmsk,tsurf,qsfc,ps, & & ust,ch,hflx,qflx,wspd,rb, & & dtsfc1,dqsfc1, & @@ -140,16 +135,18 @@ SUBROUTINE mynnedmf_wrapper_run( & & nupdraft,maxMF,ktop_plume, & & dudt, dvdt, dtdt, & & dqdt_water_vapor, dqdt_liquid_cloud, & ! <=== ntqv, ntcw - & dqdt_ice_cloud, dqdt_ozone, & ! <=== ntiw, ntoz + & dqdt_ice_cloud, dqdt_snow_cloud, & ! <=== ntiw, ntsw + & dqdt_ozone, & ! <=== ntoz & dqdt_cloud_droplet_num_conc, dqdt_ice_num_conc, & ! <=== ntlnc, ntinc & dqdt_water_aer_num_conc, dqdt_ice_aer_num_conc,& ! <=== ntwa, ntia & dqdt_cccn, & ! <=== ntccn & flag_for_pbl_generic_tend, & & dtend, dtidx, index_of_temperature, & & index_of_x_wind, index_of_y_wind, ntke, & - & ntqv, ntcw, ntiw, ntoz, ntlnc, ntinc, ntwa, ntia, & + & ntqv, ntcw, ntiw, ntsw, & + & ntoz, ntlnc, ntinc, ntwa, ntia, & & index_of_process_pbl, htrsw, htrlw, xmu, & - & bl_mynn_tkebudget, bl_mynn_tkeadvect, & + & tke_budget, bl_mynn_tkeadvect, & & bl_mynn_cloudpdf, bl_mynn_mixlength, & & bl_mynn_edmf, & & bl_mynn_edmf_mom, bl_mynn_edmf_tke, & @@ -158,14 +155,16 @@ SUBROUTINE mynnedmf_wrapper_run( & & icloud_bl, do_mynnsfclay, & & imp_physics, imp_physics_gfdl, & & imp_physics_thompson, imp_physics_wsm6, & - & chem3d, frp, mix_chem, rrfs_smoke, fire_turb, nchem, ndvel, & + & chem3d, frp, mix_chem, rrfs_sd, enh_mix, & + & nchem, ndvel, & & imp_physics_nssl, nssl_ccn_on, & - & ltaerosol, mraerosol, spp_wts_pbl, spp_pbl, lprnt, huge, errmsg, errflg ) + & ltaerosol, mraerosol, spp_wts_pbl, spp_pbl, & + & lprnt, huge, errmsg, errflg ) ! should be moved to inside the mynn: use machine, only: kind_phys use bl_mynn_common, only: cp, r_d, grav, g_inv, zero, & - xlv, xlvcp, xlscp + xlv, xlvcp, xlscp, p608 use module_bl_mynn, only: mynn_bl_driver !------------------------------------------------------------------- @@ -186,8 +185,8 @@ SUBROUTINE mynnedmf_wrapper_run( & ! NAMELIST OPTIONS (INPUT): logical, intent(in) :: & & bl_mynn_tkeadvect, & - & bl_mynn_tkebudget, & - & ltaerosol, mraerosol, & + & ltaerosol, & + & mraerosol, & & lprnt, & & do_mynnsfclay, & & flag_for_pbl_generic_tend, & @@ -204,9 +203,10 @@ SUBROUTINE mynnedmf_wrapper_run( & & bl_mynn_output, & & imp_physics, imp_physics_wsm6, & & imp_physics_thompson, imp_physics_gfdl, & - & imp_physics_nssl, & - & spp_pbl - real, intent(in) :: & + & imp_physics_nssl, imp_physics_fa, & + & spp_pbl, & + & tke_budget + real(kind=kind_phys), intent(in) :: & & bl_mynn_closure !TENDENCY DIAGNOSTICS @@ -214,28 +214,25 @@ SUBROUTINE mynnedmf_wrapper_run( & integer, intent(in) :: dtidx(:,:) integer, intent(in) :: index_of_temperature, index_of_x_wind integer, intent(in) :: index_of_y_wind, index_of_process_pbl - integer, intent(in) :: ntoz, ntqv, ntcw, ntiw, ntlnc + integer, intent(in) :: ntoz, ntqv, ntcw, ntiw, ntsw, ntlnc integer, intent(in) :: ntinc, ntwa, ntia, ntke !MISC CONFIGURATION OPTIONS - INTEGER, PARAMETER :: & + INTEGER, PARAMETER :: & & bl_mynn_mixscalars=1 - LOGICAL :: & - & FLAG_QI, FLAG_QNI, FLAG_QC, FLAG_QNC, & - & FLAG_QNWFA, FLAG_QNIFA, FLAG_OZONE + LOGICAL :: & + & FLAG_QI, FLAG_QNI, FLAG_QC, FLAG_QS, FLAG_QNC, & + & FLAG_QNWFA, FLAG_QNIFA, FLAG_QNBCA, FLAG_OZONE ! Define locally until needed from CCPP LOGICAL, PARAMETER :: cycling = .false. - INTEGER, PARAMETER :: param_first_scalar = 1 - INTEGER :: & - & p_qc, p_qr, p_qi, p_qs, p_qg, p_qnc, p_qni !MYNN-1D REAL(kind=kind_phys), intent(in) :: delt, dtf INTEGER, intent(in) :: im, levs LOGICAL, intent(in) :: flag_init, flag_restart INTEGER :: initflag, k, i - INTEGER :: IDS,IDE,JDS,JDE,KDS,KDE, & - & IMS,IME,JMS,JME,KMS,KME, & + INTEGER :: IDS,IDE,JDS,JDE,KDS,KDE, & + & IMS,IME,JMS,JME,KMS,KME, & & ITS,ITE,JTS,JTE,KTS,KTE REAL(kind=kind_phys) :: tem @@ -245,6 +242,7 @@ SUBROUTINE mynnedmf_wrapper_run( & real(kind=kind_phys), dimension(:,:), intent(inout) :: & & dtdt, dudt, dvdt, & & dqdt_water_vapor, dqdt_liquid_cloud, dqdt_ice_cloud, & + & dqdt_snow_cloud, & & dqdt_cloud_droplet_num_conc, dqdt_ice_num_conc, & & dqdt_ozone, dqdt_water_aer_num_conc, dqdt_ice_aer_num_conc real(kind=kind_phys), dimension(:,:), intent(inout) ::dqdt_cccn @@ -259,10 +257,11 @@ SUBROUTINE mynnedmf_wrapper_run( & real(kind=kind_phys), dimension(:,:), intent(inout) :: & & dqke,qWT,qSHEAR,qBUOY,qDISS real(kind=kind_phys), dimension(:,:), intent(inout) :: & - & t3d,qgrs_water_vapor,qgrs_liquid_cloud,qgrs_ice_cloud + & t3d,qgrs_water_vapor,qgrs_liquid_cloud,qgrs_ice_cloud, & + & qgrs_snow_cloud real(kind=kind_phys), dimension(:,:), intent(in) :: & & u,v,omega, & - & exner,prsl, & + & exner,prsl,prsi, & & qgrs_cloud_droplet_num_conc, & & qgrs_cloud_ice_num_conc, & & qgrs_ozone, & @@ -274,20 +273,21 @@ SUBROUTINE mynnedmf_wrapper_run( & real(kind=kind_phys), dimension(:), intent(in) :: xmu real(kind=kind_phys), dimension(:,:), intent(in) :: htrsw, htrlw ! spp_wts_pbl only allocated if spp_pbl == 1 - real(kind_phys), dimension(:,:), intent(in) :: spp_wts_pbl + real(kind=kind_phys), dimension(:,:), intent(in) :: spp_wts_pbl !LOCAL real(kind=kind_phys), dimension(im,levs) :: & - & sqv,sqc,sqi,qnc,qni,ozone,qnwfa,qnifa, & + & sqv,sqc,sqi,sqs,qnc,qni,ozone,qnwfa,qnifa,qnbca, & & dz, w, p, rho, th, qv, delp, & & RUBLTEN, RVBLTEN, RTHBLTEN, RQVBLTEN, & - & RQCBLTEN, RQNCBLTEN, RQIBLTEN, RQNIBLTEN, & - & RQNWFABLTEN, RQNIFABLTEN + & RQCBLTEN, RQNCBLTEN, RQIBLTEN, RQNIBLTEN, RQSBLTEN, & + & RQNWFABLTEN, RQNIFABLTEN, RQNBCABLTEN real(kind=kind_phys), allocatable :: old_ozone(:,:) !smoke/chem arrays - real(kind_phys), dimension(:), intent(inout) :: frp - logical, intent(in) :: mix_chem, fire_turb, rrfs_smoke + real(kind=kind_phys), dimension(:), intent(inout) :: frp + logical, intent(in) :: mix_chem, enh_mix, rrfs_sd + logical, parameter :: smoke_dbg = .false. !set temporarily real(kind=kind_phys), dimension(:,:,:), intent(inout) :: chem3d real(kind=kind_phys), dimension(im) :: emis_ant_no real(kind=kind_phys), dimension(im,ndvel) :: vdep @@ -321,7 +321,7 @@ SUBROUTINE mynnedmf_wrapper_run( & !LOCAL real, dimension(im) :: & - & hfx,qfx,rmol,xland,uoce,voce,vdfg,znt,ts + & hfx,qfx,rmol,xland,uoce,voce,znt,ts integer :: idtend real, dimension(im) :: dusfci1,dvsfci1,dtsfci1,dqsfci1 real(kind=kind_phys), allocatable :: save_qke_adv(:,:) @@ -357,63 +357,33 @@ SUBROUTINE mynnedmf_wrapper_run( & !initialize arrays for test EMIS_ANT_NO = 0. - vdep = 0. ! hli for chem dry deposition, 0 temporarily - - ! Check incoming moist species to ensure non-negative values - ! First, create height (dz) and pressure differences (delp) - ! across model layers - do k=1,levs - do i=1,im - dz(i,k)=(phii(i,k+1) - phii(i,k))*g_inv - enddo - enddo - - do i=1,im - delp(i,1) = ps(i) - (prsl(i,2)*dz(i,1) + prsl(i,1)*dz(i,2))/(dz(i,1)+dz(i,2)) - do k=2,levs-1 - delp(i,k) = (prsl(i,k)*dz(i,k-1) + prsl(i,k-1)*dz(i,k))/(dz(i,k)+dz(i,k-1)) - & - (prsl(i,k+1)*dz(i,k) + prsl(i,k)*dz(i,k+1))/(dz(i,k)+dz(i,k+1)) - enddo - delp(i,levs) = delp(i,levs-1) - enddo - - do i=1,im - call moisture_check2(levs, delt, & - delp(i,:), exner(i,:), & - qgrs_water_vapor(i,:), & - qgrs_liquid_cloud(i,:),& - qgrs_ice_cloud(i,:), & - t3d(i,:) ) - enddo + vdep = 0. FLAG_OZONE = ntoz>0 ! Assign variables for each microphysics scheme - if (imp_physics == imp_physics_wsm6) then - ! WSM6 + if (imp_physics == imp_physics_wsm6 .or. imp_physics == imp_physics_fa) then + ! WSM6 or Ferrier-Aligo FLAG_QI = .true. FLAG_QNI= .false. FLAG_QC = .true. FLAG_QNC= .false. + FLAG_QS = .false. FLAG_QNWFA= .false. FLAG_QNIFA= .false. - p_qc = 2 - p_qr = 0 - p_qi = 2 - p_qs = 0 - p_qg = 0 - p_qnc= 0 - p_qni= 0 + FLAG_QNBCA= .false. do k=1,levs do i=1,im sqv(i,k) = qgrs_water_vapor(i,k) sqc(i,k) = qgrs_liquid_cloud(i,k) sqi(i,k) = qgrs_ice_cloud(i,k) + sqs(i,k) = 0. ozone(i,k) = qgrs_ozone(i,k) qnc(i,k) = 0. qni(i,k) = 0. qnwfa(i,k) = 0. qnifa(i,k) = 0. + qnbca(i,k) = 0. enddo enddo elseif (imp_physics == imp_physics_nssl ) then @@ -422,21 +392,16 @@ SUBROUTINE mynnedmf_wrapper_run( & FLAG_QNI= .true. FLAG_QC = .true. FLAG_QNC= .true. + FLAG_QS = .false. FLAG_QNWFA= nssl_ccn_on ! ERM: Perhaps could use this field for CCN field? FLAG_QNIFA= .false. - ! p_q vars not used? - p_qc = 2 - p_qr = 0 - p_qi = 2 - p_qs = 0 - p_qg = 0 - p_qnc= 0 - p_qni= 0 + FLAG_QNBCA= .false. do k=1,levs do i=1,im sqv(i,k) = qgrs_water_vapor(i,k) sqc(i,k) = qgrs_liquid_cloud(i,k) sqi(i,k) = qgrs_ice_cloud(i,k) + sqs(i,k) = 0. ozone(i,k) = qgrs_ozone(i,k) qnc(i,k) = qgrs_cloud_droplet_num_conc(i,k) qni(i,k) = qgrs_cloud_ice_num_conc(i,k) @@ -445,6 +410,7 @@ SUBROUTINE mynnedmf_wrapper_run( & qnwfa(i,k) = qgrs_cccn(i,k) ENDIF qnifa(i,k) = 0. + qnbca(i,k) = 0. enddo enddo elseif (imp_physics == imp_physics_thompson) then @@ -453,78 +419,69 @@ SUBROUTINE mynnedmf_wrapper_run( & FLAG_QI = .true. FLAG_QNI= .true. FLAG_QC = .true. + FLAG_QS = .true. FLAG_QNC= .true. FLAG_QNWFA= .true. FLAG_QNIFA= .true. - p_qc = 2 - p_qr = 0 - p_qi = 2 - p_qs = 0 - p_qg = 0 - p_qnc= 0 - p_qni= 0 + FLAG_QNBCA= .false. do k=1,levs do i=1,im sqv(i,k) = qgrs_water_vapor(i,k) sqc(i,k) = qgrs_liquid_cloud(i,k) sqi(i,k) = qgrs_ice_cloud(i,k) + sqs(i,k) = qgrs_snow_cloud(i,k) qnc(i,k) = qgrs_cloud_droplet_num_conc(i,k) qni(i,k) = qgrs_cloud_ice_num_conc(i,k) ozone(i,k) = qgrs_ozone(i,k) qnwfa(i,k) = qgrs_water_aer_num_conc(i,k) qnifa(i,k) = qgrs_ice_aer_num_conc(i,k) + qnbca(i,k) = 0. enddo enddo else if(mraerosol) then FLAG_QI = .true. FLAG_QNI= .true. FLAG_QC = .true. + FLAG_QS = .true. FLAG_QNC= .true. FLAG_QNWFA= .false. FLAG_QNIFA= .false. - p_qc = 2 - p_qr = 0 - p_qi = 2 - p_qs = 0 - p_qg = 0 - p_qnc= 0 - p_qni= 0 + FLAG_QNBCA= .false. do k=1,levs do i=1,im sqv(i,k) = qgrs_water_vapor(i,k) sqc(i,k) = qgrs_liquid_cloud(i,k) sqi(i,k) = qgrs_ice_cloud(i,k) + sqs(i,k) = qgrs_snow_cloud(i,k) qnc(i,k) = qgrs_cloud_droplet_num_conc(i,k) qni(i,k) = qgrs_cloud_ice_num_conc(i,k) ozone(i,k) = qgrs_ozone(i,k) qnwfa(i,k) = 0. qnifa(i,k) = 0. + qnbca(i,k) = 0. enddo enddo else FLAG_QI = .true. FLAG_QNI= .true. FLAG_QC = .true. + FLAG_QS = .true. FLAG_QNC= .false. FLAG_QNWFA= .false. FLAG_QNIFA= .false. - p_qc = 2 - p_qr = 0 - p_qi = 2 - p_qs = 0 - p_qg = 0 - p_qnc= 0 - p_qni= 0 + FLAG_QNBCA= .false. do k=1,levs do i=1,im sqv(i,k) = qgrs_water_vapor(i,k) sqc(i,k) = qgrs_liquid_cloud(i,k) sqi(i,k) = qgrs_ice_cloud(i,k) + sqs(i,k) = qgrs_snow_cloud(i,k) qnc(i,k) = 0. qni(i,k) = qgrs_cloud_ice_num_conc(i,k) ozone(i,k) = qgrs_ozone(i,k) qnwfa(i,k) = 0. qnifa(i,k) = 0. + qnbca(i,k) = 0. enddo enddo endif @@ -534,15 +491,10 @@ SUBROUTINE mynnedmf_wrapper_run( & FLAG_QNI= .false. FLAG_QC = .true. FLAG_QNC= .false. + FLAG_QS = .false. FLAG_QNWFA= .false. FLAG_QNIFA= .false. - p_qc = 2 - p_qr = 0 - p_qi = 2 - p_qs = 0 - p_qg = 0 - p_qnc= 0 - p_qni= 0 + FLAG_QNBCA= .false. do k=1,levs do i=1,im sqv(i,k) = qgrs_water_vapor(i,k) @@ -550,8 +502,10 @@ SUBROUTINE mynnedmf_wrapper_run( & sqi(i,k) = qgrs_ice_cloud(i,k) qnc(i,k) = 0. qni(i,k) = 0. + sqs(i,k) = 0. qnwfa(i,k) = 0. qnifa(i,k) = 0. + qnbca(i,k) = 0. ozone(i,k) = qgrs_ozone(i,k) enddo enddo @@ -562,24 +516,21 @@ SUBROUTINE mynnedmf_wrapper_run( & FLAG_QNI= .false. FLAG_QC = .true. FLAG_QNC= .false. + FLAG_QS = .false. FLAG_QNWFA= .false. FLAG_QNIFA= .false. - p_qc = 2 - p_qr = 0 - p_qi = 0 - p_qs = 0 - p_qg = 0 - p_qnc= 0 - p_qni= 0 + FLAG_QNBCA= .false. do k=1,levs do i=1,im sqv(i,k) = qgrs_water_vapor(i,k) sqc(i,k) = qgrs_liquid_cloud(i,k) sqi(i,k) = 0. + sqs(i,k) = 0. qnc(i,k) = 0. qni(i,k) = 0. qnwfa(i,k) = 0. qnifa(i,k) = 0. + qnbca(i,k) = 0. ozone(i,k) = qgrs_ozone(i,k) enddo enddo @@ -588,21 +539,38 @@ SUBROUTINE mynnedmf_wrapper_run( & allocate(old_ozone(im,levs)) old_ozone = ozone endif - if (lprnt)write(0,*)"prepping MYNN-EDMF variables..." do k=1,levs do i=1,im - ! dz(i,k)=(phii(i,k+1) - phii(i,k))*g_inv th(i,k)=t3d(i,k)/exner(i,k) - ! keep as specific humidity - ! qv(i,k)=qvsh(i,k)/(1.0 - qvsh(i,k)) - ! qc(i,k)=qc(i,k)/(1.0 - qvsh(i,k)) - ! qi(i,k)=qi(i,k)/(1.0 - qvsh(i,k)) - rho(i,k)=prsl(i,k)/(r_d*t3d(i,k)) + rho(i,k)=prsl(i,k)/(r_d*t3d(i,k)*(1.+p608*max(sqv(i,k),1e-8))) w(i,k) = -omega(i,k)/(rho(i,k)*grav) + enddo + enddo + + ! Check incoming moist species to ensure non-negative values + ! First, create height difference (dz) + do k=1,levs + do i=1,im + dz(i,k)=(phii(i,k+1) - phii(i,k))*g_inv + enddo + enddo + + do i=1,im + do k=1,levs + delp(i,k) = prsi(i,k) - prsi(i,k+1) enddo enddo + do i=1,im + call moisture_check2(levs, delt, & + delp(i,:), exner(i,:), & + sqv(i,:), sqc(i,:), & + sqi(i,:), sqs(i,:), & + t3d(i,:) ) + enddo + + !intialize more variables do i=1,im if (slmsk(i)==1. .or. slmsk(i)==2.) then !sea/land/ice mask (=0/1/2) in FV3 xland(i)=1.0 !but land/water = (1/2) in SFCLAY_mynn @@ -611,11 +579,15 @@ SUBROUTINE mynnedmf_wrapper_run( & endif uoce(i)=0.0 voce(i)=0.0 - vdfg(i)=0.0 !ust(i) = sqrt(stress(i)) ch(i)=0.0 hfx(i)=hflx(i)*rho(i,1)*cp qfx(i)=qflx(i)*rho(i,1) + !filter bad incoming fluxes + if (hfx(i) > 1200.)hfx(i) = 1200. + if (hfx(i) < -500.)hfx(i) = -500. + if (qfx(i) > .0005)qfx(i) = 0.0005 + if (qfx(i) < -.0002)qfx(i) = -0.0002 dtsfc1(i) = hfx(i) dqsfc1(i) = qfx(i)*XLV @@ -690,7 +662,7 @@ SUBROUTINE mynnedmf_wrapper_run( & if (lprnt) then print* write(0,*)"===CALLING mynn_bl_driver; input:" - print*,"bl_mynn_tkebudget=",bl_mynn_tkebudget," bl_mynn_tkeadvect=",bl_mynn_tkeadvect + print*,"tke_budget=",tke_budget," bl_mynn_tkeadvect=",bl_mynn_tkeadvect print*,"bl_mynn_cloudpdf=",bl_mynn_cloudpdf," bl_mynn_mixlength=",bl_mynn_mixlength print*,"bl_mynn_edmf=",bl_mynn_edmf," bl_mynn_edmf_mom=",bl_mynn_edmf_mom print*,"bl_mynn_edmf_tke=",bl_mynn_edmf_tke @@ -716,7 +688,7 @@ SUBROUTINE mynnedmf_wrapper_run( & print*,"znt:",znt(1)," delt=",delt print*,"im=",im," levs=",levs print*,"PBLH=",pblh(1)," KPBL=",KPBL(1)," xland=",xland(1) - print*,"vdfg=",vdfg(1)," ch=",ch(1) + print*,"ch=",ch(1) !print*,"TKE:",TKE_PBL(1,1),TKE_PBL(1,2),TKE_PBL(1,levs) print*,"qke:",qke(1,1),qke(1,2),qke(1,levs) print*,"el_pbl:",el_pbl(1,1),el_pbl(1,2),el_pbl(1,levs) @@ -732,34 +704,36 @@ SUBROUTINE mynnedmf_wrapper_run( & & cycling=cycling, & & delt=delt,dz=dz,dx=dx,znt=znt, & & u=u,v=v,w=w,th=th,sqv3D=sqv,sqc3D=sqc, & - & sqi3D=sqi,qnc=qnc,qni=qni, & - & qnwfa=qnwfa,qnifa=qnifa,ozone=ozone, & + & sqi3D=sqi,sqs3D=sqs,qnc=qnc,qni=qni, & + & qnwfa=qnwfa,qnifa=qnifa,qnbca=qnbca,ozone=ozone, & & p=prsl,exner=exner,rho=rho,T3D=t3d, & & xland=xland,ts=ts,qsfc=qsfc,ps=ps, & & ust=ust,ch=ch,hfx=hfx,qfx=qfx,rmol=rmol, & - & wspd=wspd,uoce=uoce,voce=voce,vdfg=vdfg, & !input + & wspd=wspd,uoce=uoce,voce=voce, & !input & qke=QKE,qke_adv=qke_adv, & !output & sh3d=Sh3d,sm3d=Sm3d, & !chem/smoke & nchem=nchem,kdvel=kdvel,ndvel=ndvel, & - & Chem3d=chem3d,Vdep=vdep, & + & Chem3d=chem3d,Vdep=vdep,smoke_dbg=smoke_dbg, & & FRP=frp,EMIS_ANT_NO=emis_ant_no, & - & mix_chem=mix_chem,fire_turb=fire_turb, & - & rrfs_smoke=rrfs_smoke, & + & mix_chem=mix_chem,enh_mix=enh_mix, & + & rrfs_sd=rrfs_sd, & !----- & Tsq=tsq,Qsq=qsq,Cov=cov, & !output & RUBLTEN=RUBLTEN,RVBLTEN=RVBLTEN,RTHBLTEN=RTHBLTEN, & !output & RQVBLTEN=RQVBLTEN,RQCBLTEN=rqcblten, & & RQIBLTEN=rqiblten,RQNCBLTEN=rqncblten, & !output + & RQSBLTEN=rqsblten, & !output & RQNIBLTEN=rqniblten,RQNWFABLTEN=RQNWFABLTEN, & !output - & RQNIFABLTEN=RQNIFABLTEN,dozone=dqdt_ozone, & !output + & RQNIFABLTEN=RQNIFABLTEN,RQNBCABLTEN=RQNBCABLTEN, & !output + & dozone=dqdt_ozone, & !output & EXCH_H=exch_h,EXCH_M=exch_m, & !output & pblh=pblh,KPBL=KPBL, & !output & el_pbl=el_pbl, & !output & dqke=dqke, & !output & qWT=qWT,qSHEAR=qSHEAR,qBUOY=qBUOY,qDISS=qDISS, & !output & bl_mynn_tkeadvect=bl_mynn_tkeadvect, & - & bl_mynn_tkebudget=bl_mynn_tkebudget, & !input parameter + & tke_budget=tke_budget, & !input parameter & bl_mynn_cloudpdf=bl_mynn_cloudpdf, & !input parameter & bl_mynn_mixlength=bl_mynn_mixlength, & !input parameter & icloud_bl=icloud_bl, & !input parameter @@ -772,7 +746,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & bl_mynn_cloudmix=bl_mynn_cloudmix, & !input parameter & bl_mynn_mixqt=bl_mynn_mixqt, & !input parameter & edmf_a=edmf_a,edmf_w=edmf_w,edmf_qt=edmf_qt, & !output - & edmf_thl=edmf_thl,edmf_ent=edmf_ent,edmf_qc=edmf_qc,&!output + & edmf_thl=edmf_thl,edmf_ent=edmf_ent,edmf_qc=edmf_qc,& !output & sub_thl3D=sub_thl,sub_sqv3D=sub_sqv, & & det_thl3D=det_thl,det_sqv3D=det_sqv, & & nupdraft=nupdraft,maxMF=maxMF, & !output @@ -780,12 +754,12 @@ SUBROUTINE mynnedmf_wrapper_run( & & spp_pbl=spp_pbl,pattern_spp_pbl=spp_wts_pbl, & !input & RTHRATEN=htrlw, & !input & FLAG_QI=flag_qi,FLAG_QNI=flag_qni, & !input - & FLAG_QC=flag_qc,FLAG_QNC=flag_qnc, & !input + & FLAG_QC=flag_qc,FLAG_QNC=flag_qnc,FLAG_QS=flag_qs, & !input & FLAG_QNWFA=FLAG_QNWFA,FLAG_QNIFA=FLAG_QNIFA, & !input - & FLAG_OZONE=FLAG_OZONE, & !input + & FLAG_QNBCA=FLAG_QNBCA,FLAG_OZONE=FLAG_OZONE, & !input & IDS=1,IDE=im,JDS=1,JDE=1,KDS=1,KDE=levs, & !input & IMS=1,IME=im,JMS=1,JME=1,KMS=1,KME=levs, & !input - & ITS=1,ITE=im,JTS=1,JTE=1,KTS=1,KTE=levs) !input + & ITS=1,ITE=im,JTS=1,JTE=1,KTS=1,KTE=levs ) !input ! POST MYNN (INTERSTITIAL) WORK: @@ -826,13 +800,14 @@ SUBROUTINE mynnedmf_wrapper_run( & !enddo !DO moist/scalar/tracer tendencies: - if (imp_physics == imp_physics_wsm6) then + if (imp_physics == imp_physics_wsm6 .or. imp_physics == imp_physics_fa) then ! WSM6 do k=1,levs do i=1,im dqdt_water_vapor(i,k) = RQVBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_liquid_cloud(i,k) = RQCBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_ice_cloud(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) + dqdt_snow_cloud(i,k) = RQSBLTEN(i,k) !/(1.0 + qv(i,k)) !dqdt_ozone(i,k) = 0.0 enddo enddo @@ -860,6 +835,7 @@ SUBROUTINE mynnedmf_wrapper_run( & dqdt_cloud_droplet_num_conc(i,k) = RQNCBLTEN(i,k) dqdt_ice_cloud(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_ice_num_conc(i,k) = RQNIBLTEN(i,k) + dqdt_snow_cloud(i,k) = RQSBLTEN(i,k) !/(1.0 + qv(i,k)) !dqdt_ozone(i,k) = 0.0 dqdt_water_aer_num_conc(i,k) = RQNWFABLTEN(i,k) dqdt_ice_aer_num_conc(i,k) = RQNIFABLTEN(i,k) @@ -894,6 +870,7 @@ SUBROUTINE mynnedmf_wrapper_run( & dqdt_cloud_droplet_num_conc(i,k) = RQNCBLTEN(i,k) dqdt_ice_cloud(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_ice_num_conc(i,k) = RQNIBLTEN(i,k) + dqdt_snow_cloud(i,k) = RQSBLTEN(i,k) !/(1.0 + qv(i,k)) enddo enddo if(ldiag3d .and. .not. flag_for_pbl_generic_tend) then @@ -918,6 +895,7 @@ SUBROUTINE mynnedmf_wrapper_run( & call dtend_helper(100+ntqv,RQVBLTEN) call dtend_helper(100+ntcw,RQCBLTEN) call dtend_helper(100+ntiw,RQIBLTEN) + call dtend_helper(100+ntsw,RQSBLTEN) call dtend_helper(100+ntinc,RQNIBLTEN) endif !do k=1,levs @@ -939,6 +917,7 @@ SUBROUTINE mynnedmf_wrapper_run( & dqdt_cloud_droplet_num_conc(i,k) = RQNCBLTEN(i,k) dqdt_ice_cloud(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_ice_num_conc(i,k) = RQNIBLTEN(i,k) + dqdt_snow_cloud(i,k) = RQSBLTEN(i,k) !/(1.0 + qv(i,k)) IF ( nssl_ccn_on ) THEN ! dqdt_cccn(i,k) = RQNWFABLTEN(i,k) ENDIF @@ -1014,8 +993,7 @@ SUBROUTINE mynnedmf_wrapper_run( & print*,"znt:",znt(1)," delt=",delt print*,"im=",im," levs=",levs print*,"PBLH=",pblh(1)," KPBL=",KPBL(1)," xland=",xland(1) - print*,"vdfg=",vdfg(1)," ch=",ch(1) - !print*,"TKE:",TKE_PBL(1,1),TKE_PBL(1,2),TKE_PBL(1,levs) + print*,"ch=",ch(1) print*,"qke:",qke(1,1),qke(1,2),qke(1,levs) print*,"el_pbl:",el_pbl(1,1),el_pbl(1,2),el_pbl(1,levs) print*,"Sh3d:",Sh3d(1,1),sh3d(1,2),sh3d(1,levs) @@ -1062,7 +1040,7 @@ END SUBROUTINE dtend_helper ! ================================================================== SUBROUTINE moisture_check2(kte, delt, dp, exner, & - qv, qc, qi, th ) + qv, qc, qi, qs, th ) ! ! If qc < qcmin, qi < qimin, or qv < qvmin happens in any layer, ! force them to be larger than minimum value by (1) condensating @@ -1076,11 +1054,11 @@ SUBROUTINE moisture_check2(kte, delt, dp, exner, & implicit none integer, intent(in) :: kte - real, intent(in) :: delt - real, dimension(kte), intent(in) :: dp, exner - real, dimension(kte), intent(inout) :: qv, qc, qi, th + real(kind=kind_phys), intent(in) :: delt + real(kind=kind_phys), dimension(kte), intent(in) :: dp, exner + real(kind=kind_phys), dimension(kte), intent(inout) :: qv, qc, qi, qs, th integer k - real :: dqc2, dqi2, dqv2, sum, aa, dum + real :: dqc2, dqi2, dqs2, dqv2, sum, aa, dum real, parameter :: qvmin1= 1e-8, & !min at k=1 qvmin = 1e-20, & !min above k=1 qcmin = 0.0, & @@ -1089,17 +1067,19 @@ SUBROUTINE moisture_check2(kte, delt, dp, exner, & do k = kte, 1, -1 ! From the top to the surface dqc2 = max(0.0, qcmin-qc(k)) !qc deficit (>=0) dqi2 = max(0.0, qimin-qi(k)) !qi deficit (>=0) + dqs2 = max(0.0, qimin-qs(k)) !qs deficit (>=0) !update species qc(k) = qc(k) + dqc2 qi(k) = qi(k) + dqi2 - qv(k) = qv(k) - dqc2 - dqi2 + qs(k) = qs(k) + dqs2 + qv(k) = qv(k) - dqc2 - dqi2 - dqs2 !for theta !th(k) = th(k) + xlvcp/exner(k)*dqc2 + & ! xlscp/exner(k)*dqi2 !for temperature th(k) = th(k) + xlvcp*dqc2 + & - xlscp*dqi2 + xlscp*(dqi2+dqs2) !then fix qv if lending qv made it negative if (k .eq. 1) then @@ -1115,6 +1095,7 @@ SUBROUTINE moisture_check2(kte, delt, dp, exner, & endif qc(k) = max(qc(k),qcmin) qi(k) = max(qi(k),qimin) + qs(k) = max(qs(k),qimin) end do ! Extra moisture used to satisfy 'qv(1)>=qvmin' is proportionally diff --git a/physics/mynnedmf_wrapper.meta b/physics/mynnedmf_wrapper.meta index a44a13f1b..1703699bb 100644 --- a/physics/mynnedmf_wrapper.meta +++ b/physics/mynnedmf_wrapper.meta @@ -311,6 +311,14 @@ type = real kind = kind_phys intent = inout +[qgrs_snow_cloud] + standard_name = snow_mixing_ratio + long_name = ratio of mass of snow water to mass of dry air plus vapor (without condensates) + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout [qgrs_cloud_droplet_num_conc] standard_name = mass_number_concentration_of_cloud_liquid_water_particles_in_air long_name = number concentration of cloud droplets (liquid) @@ -367,6 +375,14 @@ type = real kind = kind_phys intent = in +[prsi] + standard_name = air_pressure_at_interface + long_name = air pressure at model layer interfaces + units = Pa + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in [exner] standard_name = dimensionless_exner_function long_name = Exner function at layers @@ -1025,6 +1041,14 @@ type = real kind = kind_phys intent = inout +[dqdt_snow_cloud] + standard_name = process_split_cumulative_tendency_of_snow_mixing_ratio + long_name = ratio of mass of snow water tendency to mass of dry air plus vapor (without condensates) due to model physics + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout [dqdt_ozone] standard_name = process_split_cumulative_tendency_of_ozone_mixing_ratio long_name = ozone mixing ratio tendency due to model physics @@ -1151,6 +1175,13 @@ dimensions = () type = integer intent = in +[ntsw] + standard_name = index_of_snow_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for snow water + units = index + dimensions = () + type = integer + intent = in [ntlnc] standard_name = index_of_mass_number_concentration_of_cloud_droplets_in_tracer_concentration_array long_name = tracer index for liquid number concentration @@ -1210,12 +1241,12 @@ type = real kind = kind_phys intent = in -[bl_mynn_tkebudget] +[tke_budget] standard_name = control_for_tke_budget_output long_name = flag for activating TKE budget units = flag dimensions = () - type = logical + type = integer intent = in [bl_mynn_tkeadvect] standard_name = flag_for_tke_advection @@ -1329,6 +1360,13 @@ dimensions = () type = integer intent = in +[imp_physics_fa] + standard_name = identifier_for_fer_hires_microphysics_scheme + long_name = choice of Ferrier-Aligo microphysics scheme + units = flag + dimensions = () + type = integer + intent = in [imp_physics_nssl] standard_name = identifier_for_nssl_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme @@ -1359,7 +1397,7 @@ type = real kind = kind_phys intent = inout -[rrfs_smoke] +[rrfs_sd] standard_name = do_smoke_coupling long_name = flag controlling rrfs_smoke collection (default off) units = flag @@ -1373,7 +1411,7 @@ dimensions = () type = logical intent = in -[fire_turb] +[enh_mix] standard_name = do_planetary_boundary_layer_fire_enhancement long_name = flag for rrfs smoke mynn enh vermix units = flag diff --git a/physics/sgscloud_radpre.F90 b/physics/sgscloud_radpre.F90 index ae0f39dde..87054128c 100644 --- a/physics/sgscloud_radpre.F90 +++ b/physics/sgscloud_radpre.F90 @@ -35,7 +35,7 @@ module sgscloud_radpre !! !>\section sgscloud_radpre_mod SGS Cloud Scheme Pre General Algorithm subroutine sgscloud_radpre_run( & - im,dt,levs, & + im,dt,fhswr,levs, & flag_init,flag_restart, & con_g, con_pi, eps, epsm1, & r_v, cpv, rcp, & @@ -43,8 +43,11 @@ subroutine sgscloud_radpre_run( & do_mynnedmf, & qc, qi, qv, T3D, P3D, exner, & qr, qs, qg, & - qci_conv,ud_mf, & + qci_conv,qlc,qli,ud_mf, & +! qci_conv_timeave, & +! ud_mf_timeave, & imfdeepcnv, imfdeepcnv_gf, & + imfdeepcnv_sas, & qc_save, qi_save, qs_save, & qc_bl,qi_bl,cldfra_bl, & delp,clouds1,clouds2,clouds3, & @@ -53,6 +56,7 @@ subroutine sgscloud_radpre_run( & nlay, plyr, xlat, dz,de_lgth, & cldsa,mtopa,mbota, & imp_physics, imp_physics_gfdl,& + imp_physics_fa, & iovr, & errmsg, errflg ) @@ -67,18 +71,20 @@ subroutine sgscloud_radpre_run( & real(kind=kind_phys), intent(in) :: con_g, con_pi, eps, epsm1 real(kind=kind_phys), intent(in) :: r_v, cpv, rcp real(kind=kind_phys), intent(in) :: xlv, xlf, cp - real(kind=kind_phys), intent(in) :: dt + real(kind=kind_phys), intent(in) :: dt,fhswr real :: xls, xlvcp, xlscp !derived below real(kind=kind_phys) :: gfac integer, intent(in) :: im, levs, imfdeepcnv, imfdeepcnv_gf, & - & nlay, imp_physics, imp_physics_gfdl + & nlay, imfdeepcnv_sas, imp_physics, imp_physics_gfdl, imp_physics_fa logical, intent(in) :: flag_init, flag_restart, do_mynnedmf real(kind=kind_phys), dimension(:,:), intent(inout) :: qc, qi real(kind=kind_phys), dimension(:,:), intent(inout) :: qr, qs, qg - ! qci_conv only allocated if GF is used + ! note: qci_conv only allocated if GF is used real(kind=kind_phys), dimension(:,:), intent(inout) :: qci_conv + real(kind=kind_phys), dimension(:,:), intent(inout) :: qlc, qli !for SAS real(kind=kind_phys), dimension(:,:), intent(in) :: ud_mf + !real(kind=kind_phys), dimension(:,:), intent(in) :: ud_mf_timeave, qci_conv_timeave real(kind=kind_phys), dimension(:,:), intent(in) :: T3D,delp real(kind=kind_phys), dimension(:,:), intent(in) :: qv,P3D,exner real(kind=kind_phys), dimension(:,:), intent(inout) :: & @@ -112,7 +118,8 @@ subroutine sgscloud_radpre_run( & real :: rhgrid,h2oliq,qsat,tem1,tem2,clwt,es,onemrh,value !Chaboureau and Bechtold (2002 and 2005) - real :: a, f, sigq, qmq, qt, xl, tlk, th, thl, rsl, cpm, cb_cf + real :: a, f, sigq, qmq, qt, xl, th, thl, rsl, cpm, cb_cf + real(kind=kind_phys) :: tlk !Option to convective cloud fraction integer, parameter :: conv_cf_opt = 0 !0: C-B, 1: X-R @@ -188,7 +195,7 @@ subroutine sgscloud_radpre_run( & !endif if (qc(i,k) < 1.e-6 .and. cldfra_bl(i,k)>0.001) then - qc(i,k) = qc_bl(i,k)*cldfra_bl(i,k) + qc(i,k) = qc_bl(i,k) !eff radius cloud water (microns) from Miles et al. (2007) if (nint(slmsk(i)) == 1) then !land @@ -206,8 +213,8 @@ subroutine sgscloud_radpre_run( & !~700 mb and decrease snow to zero by ~300 mb snow_frac = min(0.5, max((p3d(i,k)-30000.0),0.0)/140000.0) ice_frac = 1.0 - snow_frac - if (qi(i,k) < 1.e-8 .and. cldfra_bl(i,k)>0.001) then - qi(i,k) = ice_frac*qi_bl(i,k)*cldfra_bl(i,k) + if (qi(i,k) < 1.e-9 .and. cldfra_bl(i,k)>0.001) then + qi(i,k) = ice_frac*qi_bl(i,k) !eff radius cloud ice (microns), from Mishra et al. (2014, JGR Atmos, fig 6b) if(qi(i,k)>1.E-8)clouds5(i,k)=max(173.45 + 2.14*Tc, 20.) @@ -219,8 +226,8 @@ subroutine sgscloud_radpre_run( & clouds4(i,k) = max(0.0, qi(i,k) * gfac * delp(i,k)) endif - if (qs(i,k) < 1.e-8 .and. cldfra_bl(i,k)>0.001) then - qs(i,k) = snow_frac*qi_bl(i,k)*cldfra_bl(i,k) + if (qs(i,k) < 1.e-9 .and. cldfra_bl(i,k)>0.001) then + qs(i,k) = snow_frac*qi_bl(i,k) !eff radius cloud ice (microns), from Mishra et al. (2014, JGR Atmos, fig 6b) if(qs(i,k)>1.E-8)clouds9(i,k)=max(2.*(173.45 + 2.14*Tc), 50.) @@ -270,7 +277,6 @@ subroutine sgscloud_radpre_run( & if (imfdeepcnv == imfdeepcnv_gf) then do k = 1, levs do i = 1, im - !if ( qci_conv(i,k) > 0. .AND. (qi(i,k) < 1E-7 .AND. qc(i,k) < 1E-7 ) ) then if ( qci_conv(i,k) > 0. ) then Tk = T3D(i,k) Tc = Tk - 273.15 @@ -321,10 +327,15 @@ subroutine sgscloud_radpre_run( & sigq = SQRT(sigq**2 + 1e-10) ! combined conv + background components qmq = a * (qt - qsat) ! saturation deficit/excess; ! the numerator of Q1 - cb_cf= min(max(0.5 + 0.36 * atan(1.55*(qmq/sigq)),0.01),0.99) + cb_cf= min(max(0.5 + 0.36 * atan(1.55*(qmq/sigq)),0.0),0.99) + if (qci_conv(i,k) .lt. 1e-9) cb_cf = 0.0 if (do_mynnedmf .and. qmq .ge. 0.0) then ! leverage C-B stratus clouds from MYNN in saturated conditions - clouds1(i,k) = 0.5*(clouds1(i,k) + cb_cf) + if (cb_cf .gt. 0.0) then + clouds1(i,k) = 0.5*(clouds1(i,k) + cb_cf) + else + !default to MYNN clouds - already specified + endif else ! unsaturated clouds1(i,k) = cb_cf endif @@ -354,7 +365,101 @@ subroutine sgscloud_radpre_run( & endif ! qci_conv enddo enddo - endif ! imfdeepcnv_gf + + elseif (imfdeepcnv == imfdeepcnv_sas) then + + do k = 1, levs + do i = 1, im + h2oliq = qlc(i,k)+qli(i,k) + if ( h2oliq > 0. ) then + Tk = T3D(i,k) + Tc = Tk - 273.15 + + !Partition the convective clouds into water & frozen species + liqfrac = min(1., max(0., (Tk-244.)/29.)) + + qc(i,k) = qc(i,k)+qlc(i,k) + !split ice & snow 50-50% + qi(i,k) = qi(i,k)+0.5*qli(i,k) + qs(i,k) = qs(i,k)+0.5*qli(i,k) + + !eff radius cloud water (microns) + if (nint(slmsk(i)) == 1) then !land + if(qc(i,k)>1.E-8)clouds3(i,k)=5.4 + else + !from Miles et al. + if(qc(i,k)>1.E-8)clouds3(i,k)=9.6 + endif + !from Mishra et al. (2014, JGR Atmos), assume R_sno = 2*R_ice + if(qi(i,k)>1.e-8)clouds5(i,k)=max( 173.45 + 2.14*Tc , 20.) + if(qs(i,k)>1.e-8)clouds9(i,k)=max(2.0*(173.45 + 2.14*Tc), 50.) + + if ( conv_cf_opt .eq. 0 ) then + !print *,'Chab-Bechtold cloud fraction used' + !Alternatively, use Chaboureau-Bechtold (CB) convective component + !Based on both CB2002 and CB2005. + xl = xlv*liqfrac + xls*(1.-liqfrac) ! blended heat capacity + tlk = t3d(i,k) - xlvcp/exner(i,k)*qc(i,k) & + & - xlscp/exner(i,k)*qi(i,k)! liquid temp + ! get saturation water vapor mixing ratio at tl and p + es = min( p3d(i,k), fpvs( tlk ) ) ! fpvs and prsl in pa + qsat= max( QMIN, eps*es / (p3d(i,k) + epsm1*es) ) + rsl = xl*qsat / (r_v*tlk**2) ! slope of C-C curve at t = tl + ! CB02, Eqn. 4 + qt = qc(i,k) + qi(i,k) + qv(i,k) !total water + cpm = cp + qt*cpv ! CB02, sec. 2, para. 1 + a = 1./(1. + xl*rsl/cpm) ! CB02 variable "a" + !Now calculate convective component of the cloud fraction: + if (a > 0.0) then + f = min(1.0/a, 4.0) ! f is the vertical profile + else ! scaling function (CB2005) + f = 1.0 + endif + sigq = 1.5E-3 * ud_mf(i,k)/dt * f + !sigq = 3.E-3 * ud_mf(i,k)/dt * f + sigq = SQRT(sigq**2 + 1e-10) ! combined conv + background components + qmq = a * (qt - qsat) ! saturation deficit/excess; + ! the numerator of Q1 + cb_cf= min(max(0.5 + 0.36 * atan(1.55*(qmq/sigq)),0.0),0.99) + if (h2oliq .lt. 1e-9) cb_cf = 0.0 + if (do_mynnedmf .and. qmq .ge. 0.0) then + ! leverage C-B stratus clouds from MYNN in saturated conditions + if (cb_cf .gt. 0.0) then + clouds1(i,k) = 0.5*(clouds1(i,k) + cb_cf) + else + !default to MYNN clouds - already specified + endif + else ! unsaturated + clouds1(i,k) = cb_cf + endif + else + !print *,'SAS with Xu-Randall cloud fraction' + ! Xu-Randall (1996) cloud fraction + es = min( p3d(i,k), fpvs( t3d(i,k) ) ) ! fpvs and prsl in pa + qsat = max( QMIN, eps*es / (p3d(i,k) + epsm1*es) ) + rhgrid = max( 0., min( 1.00, qv(i,k)/qsat ) ) + h2oliq = qc(i,k) + qi(i,k) + qr(i,k) + qs(i,k) + qg(i,k) ! g/kg + clwt = 1.0e-6 * (p3d(i,k)*0.00001) + + if (h2oliq > clwt) then + onemrh= max( 1.e-10, 1.0-rhgrid ) + tem1 = min(max((onemrh*qsat)**0.49,0.0001),1.0) !jhan + tem1 = 100.0 / tem1 + value = max( min( tem1*(h2oliq-clwt), 50.0 ), 0.0 ) + tem2 = sqrt( sqrt(rhgrid) ) + + clouds1(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) + else + clouds1(i,k) = 0.0 + endif + !print*,"XuRandla- cf:",clouds1(i,k)," rh:",rhgrid," qt:",h2oliq + !print*,"XuRandlb- clwt:",clwt," qsat:",qsat," p:",p3d(i,k) + endif ! end convective cf choice + endif ! qlc/qli check + enddo + enddo + + endif ! convection scheme check endif ! timestep > 1 diff --git a/physics/sgscloud_radpre.meta b/physics/sgscloud_radpre.meta index 28c1b7da6..887ea0b45 100644 --- a/physics/sgscloud_radpre.meta +++ b/physics/sgscloud_radpre.meta @@ -29,6 +29,14 @@ dimensions = () type = integer intent = in +[fhswr] + standard_name = period_of_shortwave_radiation_calls + long_name = frequency for shortwave radiation + units = s + dimensions = () + type = real + kind = kind_phys + intent = in [flag_init] standard_name = flag_for_first_timestep long_name = flag signaling first time step for time integration loop @@ -218,6 +226,22 @@ type = real kind = kind_phys intent = inout +[qlc] + standard_name = cloud_condensed_water_mixing_ratio_convective_transport_tracer + long_name = ratio of mass of cloud water to mass of dry air plus vapor (without condensates) in the convectively transported tracer array + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[qli] + standard_name = ice_water_mixing_ratio_convective_transport_tracer + long_name = ratio of mass of ice water to mass of dry air plus vapor (without condensates) in the convectively transported tracer array + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout [imfdeepcnv] standard_name = control_for_deep_convection_scheme long_name = flag for mass-flux deep convection scheme @@ -232,6 +256,13 @@ dimensions = () type = integer intent = in +[imfdeepcnv_sas] + standard_name = identifier_for_simplified_arakawa_schubert_deep_convection + long_name = flag for SAS deep convection scheme + units = flag + dimensions = () + type = integer + intent = in [qc_save] standard_name = cloud_condensed_water_mixing_ratio_save long_name = ratio of mass of cloud water to mass of dry air plus vapor (without condensates) before entering a physics scheme @@ -427,6 +458,13 @@ dimensions = () type = integer intent = in +[imp_physics_fa] + standard_name = identifier_for_fer_hires_microphysics_scheme + long_name = choice of Ferrier-Aligo microphysics scheme + units = flag + dimensions = () + type = integer + intent = in [iovr] standard_name = flag_for_cloud_overlap_method_for_radiation long_name = max-random overlap clouds From 4e79188487d86b5b88a02d9c940d99ab31d4f06f Mon Sep 17 00:00:00 2001 From: joeolson42 Date: Wed, 1 Mar 2023 16:28:20 +0000 Subject: [PATCH 123/380] updating mynnedmf wrapper --- physics/mynnedmf_wrapper.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/physics/mynnedmf_wrapper.F90 b/physics/mynnedmf_wrapper.F90 index 2467d4eda..ca0b9f141 100644 --- a/physics/mynnedmf_wrapper.F90 +++ b/physics/mynnedmf_wrapper.F90 @@ -155,6 +155,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & icloud_bl, do_mynnsfclay, & & imp_physics, imp_physics_gfdl, & & imp_physics_thompson, imp_physics_wsm6, & + & imp_physics_fa, & & chem3d, frp, mix_chem, rrfs_sd, enh_mix, & & nchem, ndvel, & & imp_physics_nssl, nssl_ccn_on, & From b214ab49d5cff293d9658c4a8ddce44210d06f91 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Wed, 1 Mar 2023 21:31:05 +0000 Subject: [PATCH 124/380] correction to a comment in clm_lake.f90 --- physics/clm_lake.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90 index 3128519bb..edbfb3b58 100644 --- a/physics/clm_lake.f90 +++ b/physics/clm_lake.f90 @@ -5484,7 +5484,7 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, cycle endif - ! To handle restarts with bad lakedepth2d + ! To handle cold-start with bad lakedepth2d if ( use_lakedepth ) then if (oro_lakedepth(i) == 10.0 .or. oro_lakedepth(i) <= 0.) then !- 10.0 is the fill value for lake depth, in this case set to default value From e1679258e2ab5bd9b0c2761fa6de6d3a88c3443d Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Wed, 22 Feb 2023 10:01:32 -0500 Subject: [PATCH 125/380] Merge pull request #40 from mdtoyNOAA/ufs/dev_drag_suite_intent_mods Changed UGWP diagnostic variable declaration intents from 'out' to 'inout' --- physics/drag_suite.F90 | 4 ++-- physics/drag_suite.meta | 32 ++++++++++++++++---------------- 2 files changed, 18 insertions(+), 18 deletions(-) diff --git a/physics/drag_suite.F90 b/physics/drag_suite.F90 index 4c65a91ce..5cb49acff 100644 --- a/physics/drag_suite.F90 +++ b/physics/drag_suite.F90 @@ -383,12 +383,12 @@ subroutine drag_suite_run( & real(kind=kind_phys), intent(inout) :: & & dusfc(:), dvsfc(:) !Output (optional): - real(kind=kind_phys), intent(out) :: & + real(kind=kind_phys), intent(inout) :: & & dusfc_ms(:),dvsfc_ms(:), & & dusfc_bl(:),dvsfc_bl(:), & & dusfc_ss(:),dvsfc_ss(:), & & dusfc_fd(:),dvsfc_fd(:) - real(kind=kind_phys), intent(out) :: & + real(kind=kind_phys), intent(inout) :: & & dtaux2d_ms(:,:),dtauy2d_ms(:,:), & & dtaux2d_bl(:,:),dtauy2d_bl(:,:), & & dtaux2d_ss(:,:),dtauy2d_ss(:,:), & diff --git a/physics/drag_suite.meta b/physics/drag_suite.meta index 8f33fcc60..ff60290ae 100644 --- a/physics/drag_suite.meta +++ b/physics/drag_suite.meta @@ -277,7 +277,7 @@ dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys - intent = out + intent = inout [dtauy2d_ms] standard_name = tendency_of_y_wind_due_to_mesoscale_orographic_gravity_wave_drag long_name = y wind tendency from mesoscale gwd @@ -285,7 +285,7 @@ dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys - intent = out + intent = inout [dtaux2d_bl] standard_name = tendency_of_x_wind_due_to_blocking_drag long_name = x wind tendency from blocking drag @@ -293,7 +293,7 @@ dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys - intent = out + intent = inout [dtauy2d_bl] standard_name = tendency_of_y_wind_due_to_blocking_drag long_name = y wind tendency from blocking drag @@ -301,7 +301,7 @@ dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys - intent = out + intent = inout [dtaux2d_ss] standard_name = tendency_of_x_wind_due_to_small_scale_gravity_wave_drag long_name = x wind tendency from small scale gwd @@ -309,7 +309,7 @@ dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys - intent = out + intent = inout [dtauy2d_ss] standard_name = tendency_of_y_wind_due_to_small_scale_gravity_wave_drag long_name = y wind tendency from small scale gwd @@ -317,7 +317,7 @@ dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys - intent = out + intent = inout [dtaux2d_fd] standard_name = tendency_of_x_wind_due_to_form_drag long_name = x wind tendency from form drag @@ -325,7 +325,7 @@ dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys - intent = out + intent = inout [dtauy2d_fd] standard_name = tendency_of_y_wind_due_to_form_drag long_name = y wind tendency from form drag @@ -333,7 +333,7 @@ dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys - intent = out + intent = inout [dusfc] standard_name = instantaneous_x_stress_due_to_gravity_wave_drag long_name = zonal surface stress due to orographic gravity wave drag @@ -357,7 +357,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout [dvsfc_ms] standard_name = vertically_integrated_y_momentum_flux_due_to_mesoscale_orographic_gravity_wave_drag long_name = integrated y momentum flux from mesoscale gwd @@ -365,7 +365,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout [dusfc_bl] standard_name = vertically_integrated_x_momentum_flux_due_to_blocking_drag long_name = integrated x momentum flux from blocking drag @@ -373,7 +373,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout [dvsfc_bl] standard_name = vertically_integrated_y_momentum_flux_due_to_blocking_drag long_name = integrated y momentum flux from blocking drag @@ -381,7 +381,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout [dusfc_ss] standard_name = vertically_integrated_x_momentum_flux_due_to_small_scale_gravity_wave_drag long_name = integrated x momentum flux from small scale gwd @@ -389,7 +389,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout [dvsfc_ss] standard_name = vertically_integrated_y_momentum_flux_due_to_small_scale_gravity_wave_drag long_name = integrated y momentum flux from small scale gwd @@ -397,7 +397,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout [dusfc_fd] standard_name = vertically_integrated_x_momentum_flux_due_to_form_drag long_name = integrated x momentum flux from form drag @@ -405,7 +405,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout [dvsfc_fd] standard_name = vertically_integrated_y_momentum_flux_due_to_form_drag long_name = integrated y momentum flux from form drag @@ -413,7 +413,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout [slmsk] standard_name = area_type long_name = landmask: sea/land/ice=0/1/2 From 05e87ec99198dfd727a95f5878adb3f83a249f45 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 2 Mar 2023 14:02:13 +0000 Subject: [PATCH 126/380] restart works with FV3_HRRR suite --- physics/clm_lake.f90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90 index edbfb3b58..afcc45521 100644 --- a/physics/clm_lake.f90 +++ b/physics/clm_lake.f90 @@ -559,6 +559,8 @@ SUBROUTINE clm_lake_run( & ! FIXME: Should multiply PRCP by 1000 PRCP = (raincprv(i)+rainncprv(i))/dtime ! [mm/s] use physics timestep since PRCP comes from non-surface schemes SOLDN = DSWSFCI(I) ! SOLDN is total incoming solar + albedo(i) = ( 0.6 * lake_icefrac3d(i,1) ) + & + ( (1.0-lake_icefrac3d(i,1)) * 0.08) SOLNET = SOLDN*(1.-ALBEDO(I)) ! use mid-day albedo to determine net downward solar ! (no solar zenith angle correction) From aa57582bfd7cadcefbac63d364f4050ea7cf3c25 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 2 Mar 2023 15:20:31 +0000 Subject: [PATCH 127/380] do not freeze great salt lakes --- physics/clm_lake.f90 | 40 ++++++++++++++++++++++++++++++---------- physics/clm_lake.meta | 7 +++++++ 2 files changed, 37 insertions(+), 10 deletions(-) diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90 index afcc45521..ab9634f33 100644 --- a/physics/clm_lake.f90 +++ b/physics/clm_lake.f90 @@ -180,22 +180,24 @@ end function limit_temperature_by_climatology !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - logical function is_salty(xlat_d,xlon_positive) + subroutine is_salty(xlat_d,xlon_positive, cannot_freeze, salty) implicit none real(kind_phys), intent(in) :: xlat_d, xlon_positive + logical, intent(inout) :: cannot_freeze, salty real(kind_phys) :: xlon_d xlon_d = xlon_positive if(xlon_d>180) xlon_d = xlon_d - 360 - is_salty=limit_temperature_by_climatology(xlat_d,xlon_d) + cannot_freeze = limit_temperature_by_climatology(xlat_d,xlon_d) + salty = cannot_freeze other_locations: if(include_all_salty_locations) then ! --- The Mono Lake in California, salinity is 75 ppt with freezing point at ! --- -4.2 C (Stan). The Mono Lake lat/long (37.9-38.2, -119.3 - 118.8) if (xlon_d.gt.-119.3.and. xlon_d.lt.-118.8) then if(xlat_d.gt.37.9 .and. xlat_d.lt.38.2) then - is_salty = .true. + salty = .true. if(lakedebug) then print *,'Salty Mono Lake, i,j',xlat_d,xlon_d endif @@ -207,17 +209,17 @@ logical function is_salty(xlat_d,xlon_positive) if(lakedebug) then print *,'Salty Caspian Sea ',xlat_d,xlon_d endif - is_salty = .true. + salty = .true. end if if ( xlon_d>35.3 .and. xlon_d<35.6 .and. xlat_d>31.3 .and. xlat_d<31.8) then if(lakedebug) then print *,'Salty Dead Sea ',xlat_d,xlon_d endif - is_salty = .true. + salty = .true. endif endif other_locations !tgs --- end of special treatment for salty lakes - end function is_salty + end subroutine is_salty !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -251,7 +253,7 @@ SUBROUTINE clm_lake_run( & salty, savedtke12d, snowdp2d, h2osno2d, snl2d, t_grnd2d, t_lake3d, & lake_icefrac3d, t_soisno3d, h2osoi_ice3d, h2osoi_liq3d, h2osoi_vol3d, & z3d, dz3d, zi3d, z_lake3d, dz_lake3d, watsat3d, csol3d, sand3d, clay3d, & - tkmg3d, tkdry3d, tksatu3d, clm_lakedepth, & + tkmg3d, tkdry3d, tksatu3d, clm_lakedepth, cannot_freeze, & ! Error reporting: errflg, errmsg) @@ -308,6 +310,7 @@ SUBROUTINE clm_lake_run( & ! Lake model internal state stored by caller: ! INTEGER, DIMENSION( : ), INTENT(INOUT) :: salty + INTEGER, DIMENSION( : ), INTENT(INOUT) :: cannot_freeze real(kind_phys), dimension(: ) ,intent(inout) :: savedtke12d, & snowdp2d, & @@ -439,6 +442,8 @@ SUBROUTINE clm_lake_run( & integer :: month,num1,num2,day_of_month real(kind_phys) :: wght1,wght2,Tclim + logical salty_flag, cannot_freeze_flag + errmsg = ' ' errflg = 0 @@ -533,12 +538,20 @@ SUBROUTINE clm_lake_run( & if_lake_is_here: if (flag_iter(i) .and. use_lake_model(i)/=0) THEN - if(is_salty(xlat_d(i),xlon_d(i))) then + call is_salty(xlat_d(i),xlon_d(i),salty_flag,cannot_freeze_flag) + + if(salty_flag) then salty(i) = 1 else salty(i) = 0 endif + if(cannot_freeze_flag) then + cannot_freeze(i) = 1 + else + cannot_freeze(i) = 0 + endif + if(salty(i)/=0) then Tclim = tfrz + wght1*saltlk_T(num1) & + wght2*saltlk_T(num2) @@ -674,6 +687,14 @@ SUBROUTINE clm_lake_run( & ! Renew Lake State Variables:(14) do c = 1,column + if(cannot_freeze(i) == 1) then + t_grnd(c) = max(274.5,t_grnd(c)) + do k = 1,nlevlake + t_lake(c,k) = max(274.5,t_lake(c,k)) + lake_icefrac(c,k) = 0. + enddo + endif + savedtke12d(i) = savedtke1(c) snowdp2d(i) = snowdp(c) h2osno2d(i) = h2osno(c) @@ -694,10 +715,9 @@ SUBROUTINE clm_lake_run( & do k = -nlevsnow+0,nlevsoil zi3d(i,k) = zi(c,k) enddo - enddo - + feedback: if(feedback_to_atmosphere) then c = 1 diff --git a/physics/clm_lake.meta b/physics/clm_lake.meta index a7b6155b4..06d30fb90 100644 --- a/physics/clm_lake.meta +++ b/physics/clm_lake.meta @@ -591,6 +591,13 @@ dimensions = (horizontal_loop_extent) type = integer intent = inout +[cannot_freeze] + standard_name = clm_lake_cannot_freeze + long_name = lake at this point is so salty it cannot freeze + units = 1 + dimensions = (horizontal_loop_extent) + type = integer + intent = inout [savedtke12d] standard_name = top_level_eddy_conductivity_from_previous_timestep_in_clm_lake_model long_name = top level eddy conductivity from previous timestep in clm lake model From b3a058645427ce6c5894672d9de33ca2519cfa7c Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 2 Mar 2023 16:31:04 +0000 Subject: [PATCH 128/380] address reviewer comments --- physics/clm_lake.f90 | 63 ++++++++++++++++++++++----------------- physics/flake_driver.F90 | 34 +-------------------- physics/flake_driver.meta | 40 ------------------------- 3 files changed, 36 insertions(+), 101 deletions(-) diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90 index ab9634f33..de30a6cfa 100644 --- a/physics/clm_lake.f90 +++ b/physics/clm_lake.f90 @@ -40,7 +40,7 @@ MODULE clm_lake logical, parameter :: PERGRO = .false. logical, parameter :: USE_ETALAKE = .false. - real, parameter :: ETALAKE = 1.1925*50**(-0.424) ! Set this to your desired value if USE_ETALAKE=.true. + real(kind_phys), parameter :: ETALAKE = 1.1925*50**(-0.424) ! Set this to your desired value if USE_ETALAKE=.true. ! Level counts must be consistent with model (GFS_typedefs.F90) integer, parameter :: nlevsoil = 10 ! number of soil layers @@ -93,6 +93,8 @@ MODULE clm_lake real(kind_phys) :: hfus !Latent heat of fusion for ice [J/kg] real(kind_phys) :: hvap !Latent heat of evap for water [J/kg] real(kind_phys) :: hsub !Latent heat of sublimation [J/kg] + real(kind_phys) :: invhvap !1/hvap [kg/J] + real(kind_phys) :: invhsub !1/hsub [kg/J] real(kind_phys) :: rair !gas constant for dry air [J/kg/K] real(kind_phys) :: cpair !specific heat of dry air [J/kg/K] @@ -271,7 +273,7 @@ SUBROUTINE clm_lake_run( & ! INTEGER , INTENT (IN) :: im,km,me,master INTEGER, INTENT(IN) :: IDATE(4), kdt - REAL, INTENT(IN) :: fhour + REAL(kind_phys), INTENT(IN) :: fhour ! ! Configuration and initialization: @@ -439,6 +441,8 @@ SUBROUTINE clm_lake_run( & ! The latitude and longitude of unhappy points. real(kind_phys), allocatable, save :: unhappy_lat(:),unhappy_lon(:) + real(kind_phys) :: to_radians + integer :: month,num1,num2,day_of_month real(kind_phys) :: wght1,wght2,Tclim @@ -446,7 +450,6 @@ SUBROUTINE clm_lake_run( & errmsg = ' ' errflg = 0 - dtime=dtp if(LAKEDEBUG) then @@ -512,6 +515,8 @@ SUBROUTINE clm_lake_run( & snow_points=0 ice_points=0 + to_radians = pi/180 + month = IDATE(2) day_of_month = IDATE(3) @@ -594,7 +599,7 @@ SUBROUTINE clm_lake_run( & forc_lwrad(c) = LWDN ! [W/m/m] prec(c) = PRCP ! [mm/s] sabg(c) = SOLNET - lat(c) = XLAT_D(I)*pi/180 ! [radian] + lat(c) = XLAT_D(I)*to_radians ! [radian] do_capsnow(c) = .false. lakedepth(c) = clm_lakedepth(i) @@ -723,9 +728,9 @@ SUBROUTINE clm_lake_run( & !-- The CLM output is combined for fractional ice and water if( t_grnd(c) >= tfrz ) then - qfx = eflx_lh_tot(c)/hvap + qfx = eflx_lh_tot(c)*invhvap else - qfx = eflx_lh_tot(c)/hsub ! heat flux (W/m^2)=>mass flux(kg/(sm^2)) + qfx = eflx_lh_tot(c)*invhsub ! heat flux (W/m^2)=>mass flux(kg/(sm^2)) endif evap_wat(i) = qfx/rho0(i) ! kinematic_surface_upward_latent_heat_flux_over_water hflx_wat(i)=eflx_sh_tot(c)/(rho0(i)*cpair) ! kinematic_surface_upward_sensible_heat_flux_over_water @@ -827,7 +832,7 @@ logical function point_is_unhappy(xlat_d,xlon_d) ! If lakedebug is false, then it will return false immediately. implicit none integer :: j - real, intent(in) :: xlat_d,xlon_d + real(kind_phys), intent(in) :: xlat_d,xlon_d if(lakedebug) then do j=1,unhappy_count @@ -1356,10 +1361,10 @@ SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, if (snl(c) < 0) then betaprime(c) = 1._kind_phys !Assume all solar rad. absorbed at the surface of the top snow layer. - dzsur(c) = dz(c,jtop(c))/2._kind_phys + dzsur(c) = dz(c,jtop(c))*0.5_kind_phys else betaprime(c) = beta(islak) - dzsur(c) = dz_lake(c,1)/2._kind_phys + dzsur(c) = dz_lake(c,1)*0.5_kind_phys end if ! Originally this was 1*dz, but shouldn't it be 1/2? @@ -2224,7 +2229,7 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! phix(c,j) = phi(c,j) tx(c,j) = t_lake(c,j) else !soil layer - zx(c,j) = zx(c,nlevlake) + dz_lake(c,nlevlake)/2._kind_phys + z(c,jprime) + zx(c,j) = zx(c,nlevlake) + dz_lake(c,nlevlake)*0.5_kind_phys + z(c,jprime) cvx(c,j) = cv(c,jprime) if (j == nlevlake + 1) then !top soil layer phix(c,j) = phi_soil(c) @@ -2263,7 +2268,7 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! else if (j == nlevlake) then !bottom lake layer dzp = zx(c,j+1) - zx(c,j) tkix(c,j) = (tktopsoillay(c)*tk_lake(c,j)*dzp / & - (tktopsoillay(c)*dz_lake(c,j)/2._kind_phys + tk_lake(c,j)*z(c,1) ) ) + (tktopsoillay(c)*dz_lake(c,j)*0.5_kind_phys + tk_lake(c,j)*z(c,1) ) ) ! tktopsoillay is the conductivity at the middle of that layer, as defined in SoilThermProp_Lake else !soil layer tkix(c,j) = tk(c,jprime) @@ -4592,9 +4597,9 @@ subroutine DivideSnowLayers(lbc, ubc, & !i ! Specify a new snow layer if (dzsno(c,1) > 0.03) then msno = 2 - dzsno(c,1) = dzsno(c,1)/2. - swice(c,1) = swice(c,1)/2. - swliq(c,1) = swliq(c,1)/2. + dzsno(c,1) = dzsno(c,1)*0.5 + swice(c,1) = swice(c,1)*0.5 + swliq(c,1) = swliq(c,1)*0.5 dzsno(c,2) = dzsno(c,1) swice(c,2) = swice(c,1) swliq(c,2) = swliq(c,1) @@ -4619,9 +4624,9 @@ subroutine DivideSnowLayers(lbc, ubc, & !i ! Subdivide a new layer if (msno <= 2 .and. dzsno(c,2) > 0.07) then msno = 3 - dzsno(c,2) = dzsno(c,2)/2. - swice(c,2) = swice(c,2)/2. - swliq(c,2) = swliq(c,2)/2. + dzsno(c,2) = dzsno(c,2)*0.5 + swice(c,2) = swice(c,2)*0.5 + swliq(c,2) = swliq(c,2)*0.5 dzsno(c,3) = dzsno(c,2) swice(c,3) = swice(c,2) swliq(c,3) = swliq(c,2) @@ -4647,9 +4652,9 @@ subroutine DivideSnowLayers(lbc, ubc, & !i ! Subdivided a new layer if (msno <= 3 .and. dzsno(c,3) > 0.18) then msno = 4 - dzsno(c,3) = dzsno(c,3)/2. - swice(c,3) = swice(c,3)/2. - swliq(c,3) = swliq(c,3)/2. + dzsno(c,3) = dzsno(c,3)*0.5 + swice(c,3) = swice(c,3)*0.5 + swliq(c,3) = swliq(c,3)*0.5 dzsno(c,4) = dzsno(c,3) swice(c,4) = swice(c,3) swliq(c,4) = swliq(c,3) @@ -4675,9 +4680,9 @@ subroutine DivideSnowLayers(lbc, ubc, & !i ! Subdivided a new layer if (msno <= 4 .and. dzsno(c,4) > 0.41) then msno = 5 - dzsno(c,4) = dzsno(c,4)/2. - swice(c,4) = swice(c,4)/2. - swliq(c,4) = swliq(c,4)/2. + dzsno(c,4) = dzsno(c,4)*0.5 + swice(c,4) = swice(c,4)*0.5 + swliq(c,4) = swliq(c,4)*0.5 dzsno(c,5) = dzsno(c,4) swice(c,5) = swice(c,4) swliq(c,5) = swliq(c,4) @@ -5316,6 +5321,8 @@ subroutine clm_lake_init(con_pi,karman,con_g,con_sbc,con_t0c,rhowater,con_csol,c hfus = con_hfus hvap = con_hvap hsub = con_hfus+con_hvap + invhvap = 1._kind_phys/hvap + invhsub = 1._kind_phys/hsub rair = con_rd cpair = con_cp @@ -5461,7 +5468,7 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, !LOGICAL, DIMENSION( : ),intent(out) :: lake !REAL(KIND_PHYS), OPTIONAL, DIMENSION( : ), INTENT(IN) :: lake_depth ! no separate variable for this in CCPP - real, dimension( 1:im,1:nlevsoil ) :: bsw3d, & + real(kind_phys), dimension( 1:im,1:nlevsoil ) :: bsw3d, & bsw23d, & psisat3d, & vwcsat3d, & @@ -5639,7 +5646,7 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, dz3d(i,0) = snowdp2d(i) else if ((snowdp2d(i) > 0.03_kind_phys) .and. (snowdp2d(i) <= 0.04_kind_phys)) then snl2d(i) = -2 - dz3d(i,-1) = snowdp2d(i)/2._kind_phys + dz3d(i,-1) = snowdp2d(i)*0.5_kind_phys dz3d(i, 0) = dz3d(i,-1) else if ((snowdp2d(i) > 0.04_kind_phys) .and. (snowdp2d(i) <= 0.07_kind_phys)) then snl2d(i) = -2 @@ -5648,7 +5655,7 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, else if ((snowdp2d(i) > 0.07_kind_phys) .and. (snowdp2d(i) <= 0.12_kind_phys)) then snl2d(i) = -3 dz3d(i,-2) = 0.02_kind_phys - dz3d(i,-1) = (snowdp2d(i) - 0.02_kind_phys)/2._kind_phys + dz3d(i,-1) = (snowdp2d(i) - 0.02_kind_phys)*0.5_kind_phys dz3d(i, 0) = dz3d(i,-1) else if ((snowdp2d(i) > 0.12_kind_phys) .and. (snowdp2d(i) <= 0.18_kind_phys)) then snl2d(i) = -3 @@ -5659,7 +5666,7 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, snl2d(i) = -4 dz3d(i,-3) = 0.02_kind_phys dz3d(i,-2) = 0.05_kind_phys - dz3d(i,-1) = (snowdp2d(i) - dz3d(i,-3) - dz3d(i,-2))/2._kind_phys + dz3d(i,-1) = (snowdp2d(i) - dz3d(i,-3) - dz3d(i,-2))*0.5_kind_phys dz3d(i, 0) = dz3d(i,-1) else if ((snowdp2d(i) > 0.29_kind_phys) .and. (snowdp2d(i) <= 0.41_kind_phys)) then snl2d(i) = -4 @@ -5672,7 +5679,7 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, dz3d(i,-4) = 0.02_kind_phys dz3d(i,-3) = 0.05_kind_phys dz3d(i,-2) = 0.11_kind_phys - dz3d(i,-1) = (snowdp2d(i) - dz3d(i,-4) - dz3d(i,-3) - dz3d(i,-2))/2._kind_phys + dz3d(i,-1) = (snowdp2d(i) - dz3d(i,-4) - dz3d(i,-3) - dz3d(i,-2))*0.5_kind_phys dz3d(i, 0) = dz3d(i,-1) else if (snowdp2d(i) > 0.64_kind_phys) then snl2d(i) = -5 diff --git a/physics/flake_driver.F90 b/physics/flake_driver.F90 index a277783fb..3b5988254 100644 --- a/physics/flake_driver.F90 +++ b/physics/flake_driver.F90 @@ -8,42 +8,10 @@ module flake_driver private - public :: flake_driver_init, flake_driver_run, flake_driver_finalize + public :: flake_driver_run contains -!> \section arg_table_flake_driver_init Argument Table -!! \htmlinclude flake_driver_init.html -!! - subroutine flake_driver_init (errmsg, errflg) - - implicit none - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - end subroutine flake_driver_init - -!> \section arg_table_flake_driver_finalize Argument Table -!! \htmlinclude flake_driver_finalize.html -!! - subroutine flake_driver_finalize (errmsg, errflg) - - implicit none - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - end subroutine flake_driver_finalize - !> \section arg_table_flake_driver_run Argument Table !! \htmlinclude flake_driver_run.html !! diff --git a/physics/flake_driver.meta b/physics/flake_driver.meta index 94335a62d..e665dc962 100644 --- a/physics/flake_driver.meta +++ b/physics/flake_driver.meta @@ -3,46 +3,6 @@ type = scheme dependencies = flake.F90,machine.F -######################################################################## -[ccpp-arg-table] - name = flake_driver_init - type = scheme -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - -######################################################################## -[ccpp-arg-table] - name = flake_driver_finalize - type = scheme -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - ######################################################################## [ccpp-arg-table] name = flake_driver_run From ce8643f84cd1f06e62c35f2b72d9cf0b61ad88b0 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 2 Mar 2023 16:41:31 +0000 Subject: [PATCH 129/380] comment to resolve reviewer confusion --- physics/clm_lake.f90 | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90 index de30a6cfa..3730d2429 100644 --- a/physics/clm_lake.f90 +++ b/physics/clm_lake.f90 @@ -322,6 +322,22 @@ SUBROUTINE clm_lake_run( & real(kind_phys), dimension( :,: ) ,INTENT(inout) :: t_lake3d, & lake_icefrac3d +! Quick education on CCPP and deferred shape arrays. + +! CCPP requires deferred shape arrays as a workaround for its design +! flaw: it needs an argument that can receive either a null pointer, +! or an automatic storage array (which is not guaranteed to exist in +! memory at all). Such a thing doesn't exist in Fortran, so the design +! of CCPP assumes a compiler will accept either as an argument to a +! deferred shape array. + +! Apparently there is a misunderstanding among developers of how a +! deferred shape array is declared. If the array dimensions do not +! have an UPPER bound, then it is deferred shape. A LOWER bound is +! acceptable; it does not cease to be a deferred shape array. + +! That is why these seven arrays fit the CCPP design. + real(kind_phys), dimension( :,-nlevsnow+1: ) ,INTENT(inout) :: t_soisno3d, & h2osoi_ice3d, & h2osoi_liq3d, & From 710b9e174571659b77ac3ebaf9f3b60773474b98 Mon Sep 17 00:00:00 2001 From: Jili Dong Date: Thu, 2 Mar 2023 18:02:17 +0000 Subject: [PATCH 130/380] add nssl_alphar, nssl_ehw0_in, nssl_ehlw0_in to namelist entries for ensemble perturbations --- physics/module_mp_nssl_2mom.F90 | 1 + physics/mp_nssl.F90 | 5 ++++- physics/mp_nssl.meta | 24 ++++++++++++++++++++++++ 3 files changed, 29 insertions(+), 1 deletion(-) diff --git a/physics/module_mp_nssl_2mom.F90 b/physics/module_mp_nssl_2mom.F90 index 6b184c35f..bd879f14a 100644 --- a/physics/module_mp_nssl_2mom.F90 +++ b/physics/module_mp_nssl_2mom.F90 @@ -1228,6 +1228,7 @@ SUBROUTINE nssl_2mom_init( & rho_qh = nssl_params(8) rho_qhl = nssl_params(9) rho_qs = nssl_params(10) + alphar = nssl_params(14) ! ipelec = Nint(nssl_params(11)) ! isaund = Nint(nssl_params(12)) diff --git a/physics/mp_nssl.F90 b/physics/mp_nssl.F90 index d6de5a0a0..4e0e323ce 100644 --- a/physics/mp_nssl.F90 +++ b/physics/mp_nssl.F90 @@ -31,6 +31,7 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & con_t0c, con_cliq, con_csol, con_eps, & imp_physics, imp_physics_nssl, & nssl_cccn, nssl_alphah, nssl_alphahl, & + nssl_alphar, nssl_ehw0_in, nssl_ehlw0_in, & nssl_ccn_on, nssl_hail_on, nssl_invertccn ) @@ -52,6 +53,7 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & integer, intent(in) :: imp_physics integer, intent(in) :: imp_physics_nssl real(kind_phys), intent(in) :: nssl_cccn, nssl_alphah, nssl_alphahl + real(kind_phys), intent(in) :: nssl_alphar, nssl_ehw0_in, nssl_ehlw0_in logical, intent(in) :: nssl_ccn_on, nssl_hail_on, nssl_invertccn ! Local variables: dimensions used in nssl_init @@ -115,6 +117,7 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & nssl_params(11) = 0 ! nssl_ipelec_tmp nssl_params(12) = 11 ! nssl_isaund nssl_params(13) = 0 ! 1= turn on cccna; 0 = turn off + nssl_params(14) = nssl_alphar nssl_qccn = nssl_cccn/1.225 ! if (mpirank==mpiroot) then @@ -129,7 +132,7 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & ! write(0,*) 'call nssl_2mom_init' CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0, & - ihvol=ihailv,errmsg=errmsg,errflg=errflg,myrank=mpirank,mpiroot=mpiroot) + ihvol=ihailv,nssl_ehw0=nssl_ehw0_in,nssl_ehlw0=nssl_ehlw0_in,errmsg=errmsg,errflg=errflg,myrank=mpirank,mpiroot=mpiroot) ! For restart runs, the init is done here if (restart) then diff --git a/physics/mp_nssl.meta b/physics/mp_nssl.meta index 9b913da2b..d4420c47b 100644 --- a/physics/mp_nssl.meta +++ b/physics/mp_nssl.meta @@ -165,6 +165,30 @@ type = real kind = kind_phys intent = in +[nssl_alphar] + standard_name = nssl_alpha_rain + long_name = rain PSD shape parameter in NSSL micro + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[nssl_ehw0_in] + standard_name = nssl_hw_collec_eff + long_name = graupel droplet collection efficiency in NSSL micro + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[nssl_ehlw0_in] + standard_name = nssl_hlw_collec_eff + long_name = graupel droplet collection efficiency in NSSL micro + units = none + dimensions = () + type = real + kind = kind_phys + intent = in [nssl_ccn_on] standard_name = nssl_ccn_on long_name = CCN activation flag in NSSL micro From f9e049eea04051912c865aa21e35091e4831ae32 Mon Sep 17 00:00:00 2001 From: Samuel Trahan Date: Thu, 2 Mar 2023 20:29:24 +0000 Subject: [PATCH 131/380] coare changes and bug fixes from tanya --- physics/clm_lake.f90 | 42 +++++++++++++++++++++++++++++++++--------- physics/clm_lake.meta | 8 -------- 2 files changed, 33 insertions(+), 17 deletions(-) diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90 index ab9634f33..aa850a9c0 100644 --- a/physics/clm_lake.f90 +++ b/physics/clm_lake.f90 @@ -236,7 +236,7 @@ SUBROUTINE clm_lake_run( & ! Atmospheric model state inputs: tg3, pgr, zlvl, gt0, prsi, phii, qvcurr, gu0, gv0, xlat_d, xlon_d, & - ch, cm, dlwsfci, dswsfci, emiss, oro_lakedepth, wind, rho0, tsfc, & + ch, cm, dlwsfci, dswsfci, oro_lakedepth, wind, rho0, tsfc, & flag_iter, ISLTYP, rainncprv, raincprv, & ! Feedback to atmosphere: @@ -288,7 +288,7 @@ SUBROUTINE clm_lake_run( & ! REAL(KIND_PHYS), DIMENSION(:), INTENT(IN):: & tg3, pgr, zlvl, qvcurr, xlat_d, xlon_d, ch, cm, & - dlwsfci, dswsfci, emiss, oro_lakedepth, wind, rho0, tsfc, & + dlwsfci, dswsfci, oro_lakedepth, wind, rho0, tsfc, & rainncprv, raincprv REAL(KIND_PHYS), DIMENSION(:,:), INTENT(in) :: gu0, gv0, prsi, gt0, phii LOGICAL, DIMENSION(:), INTENT(IN) :: flag_iter @@ -416,6 +416,8 @@ SUBROUTINE clm_lake_run( & real(kind_phys) :: tkdry(1,nlevsoil) ! thermal conductivity, dry soil (W/m/Kelvin) real(kind_phys) :: csol(1,nlevsoil) ! heat capacity, soil solids (J/m**3/Kelvin) +! real(kind_phys) :: emiss ! surface emissivity + integer :: lake_points, snow_points, ice_points character*255 :: message logical, parameter :: feedback_to_atmosphere = .true. ! FIXME: REMOVE @@ -568,7 +570,9 @@ SUBROUTINE clm_lake_run( & PBOT = prsi(i,1) PSFC = pgr(i) Q2K = qvcurr(i) - LWDN = DLWSFCI(I)*EMISS(I) +! EMISS = 0.99 * lake_icefrac3d(i,1) + emg * (1.0-lake_icefrac3d(i,1)) ! emg=0.97, parameter, needs to be moved to the top + LWDN = DLWSFCI(I) ! LWDN is downward LW flux, do not use EMISS here. +! LWDN = DLWSFCI(I)*EMISS(I) ! FIXME: Should multiply PRCP by 1000 PRCP = (raincprv(i)+rainncprv(i))/dtime ! [mm/s] use physics timestep since PRCP comes from non-surface schemes SOLDN = DSWSFCI(I) ! SOLDN is total incoming solar @@ -1251,7 +1255,7 @@ SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, integer , parameter :: islak = 2 ! index of lake, 1 = deep lake, 2 = shallow lake integer , parameter :: niters = 3 ! maximum number of iterations for surface temperature real(kind_phys), parameter :: beta1 = 1._kind_phys ! coefficient of convective velocity (in computing W_*) [-] - real(kind_phys), parameter :: emg = 0.97_kind_phys ! ground emissivity (0.97 for snow) + real(kind_phys), parameter :: emg = 0.97_kind_phys ! ground emissivity (0.97 for water) real(kind_phys), parameter :: zii = 1000._kind_phys! convective boundary height [m] real(kind_phys), parameter :: tdmax = 277._kind_phys ! temperature of maximum water density real(kind_phys) :: forc_th(1) ! atmospheric potential temperature (Kelvin) @@ -1312,6 +1316,9 @@ SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, real(kind_phys) :: t_grnd_temp ! Used in surface flux correction over frozen ground real(kind_phys) :: betaprime(lbc:ubc) ! Effective beta: 1 for snow layers, beta(islak) otherwise character*256 :: message + ! tgs COARE + real(kind_phys) :: tc, visc, ren + ! This assumes all radiation is absorbed in the top snow layer and will need ! to be changed for CLM 4. ! @@ -1407,12 +1414,25 @@ SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, else ! for frozen lake with snow z0mg(p) = 0.0024_kind_phys end if - - + !- tgs - use COARE formulation for z0hg and z0qg. + !-- suggestion from Ayumi Manome (GLERL), Aug. 2018 + !-- Charusombat et al., 2018, https://doi.org/10.5194/hess-2017-725 + tc=forc_t(g)-273.15_kind_phys + visc=1.326e-5_kind_phys*(1._kind_phys + 6.542e-3_kind_phys*tc + 8.301e-6_kind_phys*tc*tc & + - 4.84e-9_kind_phys*tc*tc*tc) + + Ren = MAX(ustar(p)*z0mg(p)/visc, 0.1_kind_phys) + z0hg(p) = (5.5e-5_kind_phys)*(Ren**(-0.60_kind_phys)) - z0hg(p) = z0mg(p) - z0qg(p) = z0mg(p) + z0hg(p) = MIN(z0hg(p),1.0e-4_kind_phys) + z0hg(p) = MAX(z0hg(p),2.0e-9_kind_phys) + + z0qg(p) = z0hg(p) + + ! end COARE + !z0hg(p) = z0mg(p) + !z0qg(p) = z0mg(p) ! Latent heat @@ -2577,15 +2597,19 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! !layer will actually be. if (i == 1) zsum(c) = 0._kind_phys if ((zsum(c)+dz_lake(c,i))/nav(c) <= iceav(c)) then - lake_icefrac(c,i) = 1._kind_phys t_lake(c,i) = tav_froz(c) + tfrz + !tgs - 30jul19 - the next line is a bug and should be commented + !out. This bug prevents lake ice form completely melting. + ! lake_icefrac(c,i) = 1._kind_phys else if (zsum(c)/nav(c) < iceav(c)) then + !tgs - change ice fraction lake_icefrac(c,i) = (iceav(c)*nav(c) - zsum(c)) / dz_lake(c,i) ! Find average value that preserves correct heat content. t_lake(c,i) = ( lake_icefrac(c,i)*tav_froz(c)*cice_eff & + (1._kind_phys - lake_icefrac(c,i))*tav_unfr(c)*cwat ) & / ( lake_icefrac(c,i)*cice_eff + (1-lake_icefrac(c,i))*cwat ) + tfrz else + !tgs - remove ice lake_icefrac(c,i) = 0._kind_phys t_lake(c,i) = tav_unfr(c) + tfrz end if diff --git a/physics/clm_lake.meta b/physics/clm_lake.meta index 06d30fb90..4149fd8ef 100644 --- a/physics/clm_lake.meta +++ b/physics/clm_lake.meta @@ -251,14 +251,6 @@ type = real kind = kind_phys intent = in -[emiss] - standard_name = surface_longwave_emissivity - long_name = surface lw emissivity in fraction - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in [raincprv] standard_name = lwe_thickness_of_convective_precipitation_amount_on_previous_timestep long_name = convective_precipitation_amount from previous timestep From 06d4d9e65ca955ddf73a7642e756b37308d65734 Mon Sep 17 00:00:00 2001 From: Samuel Trahan Date: Thu, 2 Mar 2023 21:25:01 +0000 Subject: [PATCH 132/380] further updates from tanya --- physics/clm_lake.f90 | 34 +++++++++++++++++----------------- 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90 index 521f79bde..b70313da5 100644 --- a/physics/clm_lake.f90 +++ b/physics/clm_lake.f90 @@ -575,18 +575,6 @@ SUBROUTINE clm_lake_run( & cannot_freeze(i) = 0 endif - if(salty(i)/=0) then - Tclim = tfrz + wght1*saltlk_T(num1) & - + wght2*saltlk_T(num2) - if(lakedebug) print *,'Tclim,tsfc,t_lake3d',i,Tclim,tsfc_wat(i),t_lake3d(i,:),t_soisno3d(i,:) - t_grnd2d(i) = min(Tclim+3.0_kind_phys,(max(tsfc_wat(i),Tclim-3.0_kind_phys))) - do k = 1,nlevlake - t_lake3d(i,k) = min(Tclim+3.0_kind_phys,(max(t_lake3d(i,k),Tclim-3.0_kind_phys))) - enddo - t_soisno3d(i,1) = min(Tclim+3.0_kind_phys,(max(t_soisno3d(i,1),Tclim-3.0_kind_phys))) - if(lakedebug) print *,'After Tclim,tsfc,t_lake3d',i,Tclim,tsfc_wat(i),t_lake3d(i,:),t_soisno3d(i,:) - endif - SFCTMP = gt0(i,1) PBOT = prsi(i,1) PSFC = pgr(i) @@ -713,13 +701,25 @@ SUBROUTINE clm_lake_run( & do c = 1,column if(cannot_freeze(i) == 1) then - t_grnd(c) = max(274.5,t_grnd(c)) + t_grnd(c) = max(274.5_kind_phys,t_grnd(c)) do k = 1,nlevlake - t_lake(c,k) = max(274.5,t_lake(c,k)) + t_lake(c,k) = max(274.5_kind_phys,t_lake(c,k)) lake_icefrac(c,k) = 0. enddo endif - + + if(salty(i)/=0) then + Tclim = tfrz + wght1*saltlk_T(num1) & + + wght2*saltlk_T(num2) + if(lakedebug) print *,'Tclim,tsfc,t_lake3d',i,Tclim,t_grnd(c),t_lake(c,:),t_soisno(c,:) + t_grnd(c) = min(Tclim+3.0_kind_phys,(max(t_grnd(c),Tclim-3.0_kind_phys))) + do k = 1,nlevlake + t_lake(c,k) = min(Tclim+3.0_kind_phys,(max(t_lake(c,k),Tclim-3.0_kind_phys))) + enddo + t_soisno(c,1) = min(Tclim+3.0_kind_phys,(max(t_soisno(c,1),Tclim-3.0_kind_phys))) + if(lakedebug) print *,'After Tclim,tsfc,t_lake3d',i,Tclim,t_grnd(c),t_lake(c,:),t_soisno(c,:) + endif + savedtke12d(i) = savedtke1(c) snowdp2d(i) = snowdp(c) h2osno2d(i) = h2osno(c) @@ -2706,8 +2706,8 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! p = filter_shlakep(fp) c = pcolumn(p) errsoi(c) = (ncvts(c)-ocvts(c)) / dtime - fin(c) - if( (LAKEDEBUG .and. abs(errsoi(c)) < 1._kind_phys) & - .or. (.not.LAKEDEBUG .and. abs(errsoi(c)) < 10._kind_phys)) then + if( (LAKEDEBUG .and. abs(errsoi(c)) < 1._kind_phys) ) then +! .or. (.not.LAKEDEBUG .and. abs(errsoi(c)) < 10._kind_phys)) then eflx_sh_tot(p) = eflx_sh_tot(p) - errsoi(c) eflx_sh_grnd(p) = eflx_sh_grnd(p) - errsoi(c) eflx_soil_grnd(p) = eflx_soil_grnd(p) + errsoi(c) From a029c2808fa318305ecc99f724bbd70789e61fd4 Mon Sep 17 00:00:00 2001 From: Samuel Trahan Date: Thu, 2 Mar 2023 21:32:01 +0000 Subject: [PATCH 133/380] disable wordy warning without LAKEDEBUG --- physics/clm_lake.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90 index 3730d2429..904ae93dd 100644 --- a/physics/clm_lake.f90 +++ b/physics/clm_lake.f90 @@ -2682,8 +2682,8 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! p = filter_shlakep(fp) c = pcolumn(p) errsoi(c) = (ncvts(c)-ocvts(c)) / dtime - fin(c) - if( (LAKEDEBUG .and. abs(errsoi(c)) < 1._kind_phys) & - .or. (.not.LAKEDEBUG .and. abs(errsoi(c)) < 10._kind_phys)) then + if( (LAKEDEBUG .and. abs(errsoi(c)) < 1._kind_phys) ) then +! .or. (.not.LAKEDEBUG .and. abs(errsoi(c)) < 10._kind_phys)) then eflx_sh_tot(p) = eflx_sh_tot(p) - errsoi(c) eflx_sh_grnd(p) = eflx_sh_grnd(p) - errsoi(c) eflx_soil_grnd(p) = eflx_soil_grnd(p) + errsoi(c) From 078bf74ebd7bdd452f3b40e959d10a8c4cb4c78e Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Fri, 3 Mar 2023 05:01:33 +0000 Subject: [PATCH 134/380] use 64 bits for lake and disable broken coare code --- physics/clm_lake.f90 | 2160 +++++++++++++++++++++--------------------- 1 file changed, 1085 insertions(+), 1075 deletions(-) diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90 index b70313da5..75c7eab13 100644 --- a/physics/clm_lake.f90 +++ b/physics/clm_lake.f90 @@ -27,7 +27,7 @@ MODULE clm_lake - use machine, only: kind_phys + use machine, only: kind_phys, kind_dbl_prec implicit none @@ -35,18 +35,20 @@ MODULE clm_lake public :: clm_lake_run, clm_lake_init, LAKEDEBUG + integer, parameter, public :: kind_lake = kind_dbl_prec + logical :: LAKEDEBUG = .false. ! Enable lots of checks and debug prints and errors logical, parameter :: PERGRO = .false. logical, parameter :: USE_ETALAKE = .false. - real(kind_phys), parameter :: ETALAKE = 1.1925*50**(-0.424) ! Set this to your desired value if USE_ETALAKE=.true. + real(kind_lake), parameter :: ETALAKE = 1.1925*50**(-0.424) ! Set this to your desired value if USE_ETALAKE=.true. ! Level counts must be consistent with model (GFS_typedefs.F90) integer, parameter :: nlevsoil = 10 ! number of soil layers integer, parameter :: nlevlake = 10 ! number of lake layers integer, parameter :: nlevsnow = 5 ! maximum number of snow layers - real(kind_phys), parameter :: scalez = 0.025_kind_phys ! Soil layer thickness discretization (m) + real(kind_lake), parameter :: scalez = 0.025_kind_lake ! Soil layer thickness discretization (m) integer,parameter :: lbp = 1 ! pft-index bounds integer,parameter :: ubp = 1 @@ -74,56 +76,56 @@ MODULE clm_lake logical,parameter :: lakpoi(1) = .true. !Initialize physical constants not available from model: - real(kind_phys), parameter :: tcrit = 2.5 !critical temperature to determine rain or snow - real(kind_phys), parameter :: tkwat = 0.6 !thermal conductivity of water [W/m/k] - real(kind_phys), parameter :: tkice = 2.290 !thermal conductivity of ice [W/m/k] - real(kind_phys), parameter :: tkairc = 0.023 !thermal conductivity of air [W/m/k] - real(kind_phys), parameter :: snow_bd = 250 !constant snow bulk density (only used in special case here) [kg/m^3] + real(kind_lake), parameter :: tcrit = 2.5 !critical temperature to determine rain or snow + real(kind_lake), parameter :: tkwat = 0.6 !thermal conductivity of water [W/m/k] + real(kind_lake), parameter :: tkice = 2.290 !thermal conductivity of ice [W/m/k] + real(kind_lake), parameter :: tkairc = 0.023 !thermal conductivity of air [W/m/k] + real(kind_lake), parameter :: snow_bd = 250 !constant snow bulk density (only used in special case here) [kg/m^3] ! Constants that are copied from model values by clm_lake_init: - real(kind_phys) :: pi !ratio of the circumference of a circle to its diameter - real(kind_phys) :: vkc !von Karman constant [-] - real(kind_phys) :: grav !gravity constant [m/s2] - real(kind_phys) :: sb !stefan-boltzmann constant [W/m2/K4] - real(kind_phys) :: tfrz !freezing temperature [K] - real(kind_phys) :: denh2o !density of liquid water [kg/m3] - real(kind_phys) :: denice !density of ice [kg/m3] - real(kind_phys) :: cpice !Specific heat of ice [J/kg-K] - real(kind_phys) :: cpliq !Specific heat of water [J/kg-K] - real(kind_phys) :: hfus !Latent heat of fusion for ice [J/kg] - real(kind_phys) :: hvap !Latent heat of evap for water [J/kg] - real(kind_phys) :: hsub !Latent heat of sublimation [J/kg] - real(kind_phys) :: invhvap !1/hvap [kg/J] - real(kind_phys) :: invhsub !1/hsub [kg/J] - real(kind_phys) :: rair !gas constant for dry air [J/kg/K] - real(kind_phys) :: cpair !specific heat of dry air [J/kg/K] + real(kind_lake) :: pi !ratio of the circumference of a circle to its diameter + real(kind_lake) :: vkc !von Karman constant [-] + real(kind_lake) :: grav !gravity constant [m/s2] + real(kind_lake) :: sb !stefan-boltzmann constant [W/m2/K4] + real(kind_lake) :: tfrz !freezing temperature [K] + real(kind_lake) :: denh2o !density of liquid water [kg/m3] + real(kind_lake) :: denice !density of ice [kg/m3] + real(kind_lake) :: cpice !Specific heat of ice [J/kg-K] + real(kind_lake) :: cpliq !Specific heat of water [J/kg-K] + real(kind_lake) :: hfus !Latent heat of fusion for ice [J/kg] + real(kind_lake) :: hvap !Latent heat of evap for water [J/kg] + real(kind_lake) :: hsub !Latent heat of sublimation [J/kg] + real(kind_lake) :: invhvap !1/hvap [kg/J] + real(kind_lake) :: invhsub !1/hsub [kg/J] + real(kind_lake) :: rair !gas constant for dry air [J/kg/K] + real(kind_lake) :: cpair !specific heat of dry air [J/kg/K] - real(kind_phys), public, parameter :: spval = 1.e36 !special value for missing data (ocean) - real(kind_phys), parameter :: depth_c = 50. !below the level t_lake3d will be 277.0 !mchen - real(kind_phys), parameter :: zero_h2o = 1e-12 !lower mixing ratio is is treated as zero + real(kind_lake), public, parameter :: spval = 1.e36 !special value for missing data (ocean) + real(kind_lake), parameter :: depth_c = 50. !below the level t_lake3d will be 277.0 !mchen + real(kind_lake), parameter :: zero_h2o = 1e-12 !lower mixing ratio is is treated as zero ! These are tunable constants - real(kind_phys), parameter :: wimp = 0.05 !Water impermeable if porosity less than wimp - real(kind_phys), parameter :: ssi = 0.033 !Irreducible water saturation of snow - real(kind_phys), parameter :: cnfac = 0.5 !Crank Nicholson factor between 0 and 1 + real(kind_lake), parameter :: wimp = 0.05 !Water impermeable if porosity less than wimp + real(kind_lake), parameter :: ssi = 0.033 !Irreducible water saturation of snow + real(kind_lake), parameter :: cnfac = 0.5 !Crank Nicholson factor between 0 and 1 ! Initialize water type constants integer,parameter :: istsoil = 1 !soil "water" type ! percent sand - real(kind_phys), parameter :: sand(19) = & + real(kind_lake), parameter :: sand(19) = & (/92.,80.,66.,20.,5.,43.,60.,10.,32.,51., 6.,22.,39.7,0.,100.,54.,17.,100.,92./) ! percent clay - real(kind_phys), parameter :: clay(19) = & + real(kind_lake), parameter :: clay(19) = & (/ 3., 5.,10.,15.,5.,18.,27.,33.,33.,41.,47.,58.,14.7,0., 0., 8.5,54., 0., 3./) ! These are initialized in clm_lake_init and are not modified elsewhere - real(kind_phys) :: zlak(1:nlevlake) !lake z (layers) - real(kind_phys) :: dzlak(1:nlevlake) !lake dz (thickness) - real(kind_phys) :: zsoi(1:nlevsoil) !soil z (layers) - real(kind_phys) :: dzsoi(1:nlevsoil) !soil dz (thickness) - real(kind_phys) :: zisoi(0:nlevsoil) !soil zi (interfaces) + real(kind_lake) :: zlak(1:nlevlake) !lake z (layers) + real(kind_lake) :: dzlak(1:nlevlake) !lake dz (thickness) + real(kind_lake) :: zsoi(1:nlevsoil) !soil z (layers) + real(kind_lake) :: dzsoi(1:nlevsoil) !soil dz (thickness) + real(kind_lake) :: zisoi(0:nlevsoil) !soil zi (interfaces) real, parameter :: SaltLk_T(1:25) = (/ 0.5, 0.,-0.5, 3., 4., 7., 8., 12., 13., 16., 19., 21., & 23.5, 25., 26.,24.,23.,20.5,18., 15., 11.5, 8., 4., 1., 0.5/) @@ -273,7 +275,7 @@ SUBROUTINE clm_lake_run( & ! INTEGER , INTENT (IN) :: im,km,me,master INTEGER, INTENT(IN) :: IDATE(4), kdt - REAL(kind_phys), INTENT(IN) :: fhour + REAL(KIND_PHYS), INTENT(IN) :: fhour ! ! Configuration and initialization: @@ -367,74 +369,74 @@ SUBROUTINE clm_lake_run( & !local variables: ! - REAL(kind_phys) :: SFCTMP,PBOT,PSFC,Q2K,LWDN,PRCP,SOLDN,SOLNET,dtime + REAL(kind_lake) :: SFCTMP,PBOT,PSFC,Q2K,LWDN,PRCP,SOLDN,SOLNET,dtime INTEGER :: C,i,j,k !temporary varibles in: - real(kind_phys) :: forc_t(1) ! atmospheric temperature (Kelvin) - real(kind_phys) :: forc_pbot(1) ! atm bottom level pressure (Pa) - real(kind_phys) :: forc_psrf(1) ! atmospheric surface pressure (Pa) - real(kind_phys) :: forc_hgt(1) ! atmospheric reference height (m) - real(kind_phys) :: forc_hgt_q(1) ! observational height of humidity [m] - real(kind_phys) :: forc_hgt_t(1) ! observational height of temperature [m] - real(kind_phys) :: forc_hgt_u(1) ! observational height of wind [m] - real(kind_phys) :: forc_q(1) ! atmospheric specific humidity (kg/kg) - real(kind_phys) :: forc_u(1) ! atmospheric wind speed in east direction (m/s) - real(kind_phys) :: forc_v(1) ! atmospheric wind speed in north direction (m/s) - real(kind_phys) :: forc_lwrad(1) ! downward infrared (longwave) radiation (W/m**2) - real(kind_phys) :: prec(1) ! snow or rain rate [mm/s] - real(kind_phys) :: sabg(1) ! solar radiation absorbed by ground (W/m**2) - real(kind_phys) :: lat(1) ! latitude (radians) - real(kind_phys) :: z_lake(1,nlevlake) ! layer depth for lake (m) - real(kind_phys) :: dz_lake(1,nlevlake) ! layer thickness for lake (m) - - real(kind_phys) :: lakedepth(1) ! column lake depth (m) + real(kind_lake) :: forc_t(1) ! atmospheric temperature (Kelvin) + real(kind_lake) :: forc_pbot(1) ! atm bottom level pressure (Pa) + real(kind_lake) :: forc_psrf(1) ! atmospheric surface pressure (Pa) + real(kind_lake) :: forc_hgt(1) ! atmospheric reference height (m) + real(kind_lake) :: forc_hgt_q(1) ! observational height of humidity [m] + real(kind_lake) :: forc_hgt_t(1) ! observational height of temperature [m] + real(kind_lake) :: forc_hgt_u(1) ! observational height of wind [m] + real(kind_lake) :: forc_q(1) ! atmospheric specific humidity (kg/kg) + real(kind_lake) :: forc_u(1) ! atmospheric wind speed in east direction (m/s) + real(kind_lake) :: forc_v(1) ! atmospheric wind speed in north direction (m/s) + real(kind_lake) :: forc_lwrad(1) ! downward infrared (longwave) radiation (W/m**2) + real(kind_lake) :: prec(1) ! snow or rain rate [mm/s] + real(kind_lake) :: sabg(1) ! solar radiation absorbed by ground (W/m**2) + real(kind_lake) :: lat(1) ! latitude (radians) + real(kind_lake) :: z_lake(1,nlevlake) ! layer depth for lake (m) + real(kind_lake) :: dz_lake(1,nlevlake) ! layer thickness for lake (m) + + real(kind_lake) :: lakedepth(1) ! column lake depth (m) logical :: do_capsnow(1) ! true => do snow capping !in&out - real(kind_phys) :: h2osoi_vol(1,-nlevsnow+1:nlevsoil) ! volumetric soil water (0<=h2osoi_vol<=watsat)[m3/m3] - real(kind_phys) :: t_grnd(1) ! ground temperature (Kelvin) - real(kind_phys) :: h2osno(1) ! snow water (mm H2O) - real(kind_phys) :: snowdp(1) ! snow height (m) - real(kind_phys) :: z(1,-nlevsnow+1:nlevsoil) ! layer depth for snow & soil (m) - real(kind_phys) :: dz(1,-nlevsnow+1:nlevsoil) ! layer thickness for soil or snow (m) - real(kind_phys) :: t_soisno(1,-nlevsnow+1:nlevsoil) ! soil (or snow) temperature (Kelvin) - real(kind_phys) :: t_lake(1,nlevlake) ! lake temperature (Kelvin) + real(kind_lake) :: h2osoi_vol(1,-nlevsnow+1:nlevsoil) ! volumetric soil water (0<=h2osoi_vol<=watsat)[m3/m3] + real(kind_lake) :: t_grnd(1) ! ground temperature (Kelvin) + real(kind_lake) :: h2osno(1) ! snow water (mm H2O) + real(kind_lake) :: snowdp(1) ! snow height (m) + real(kind_lake) :: z(1,-nlevsnow+1:nlevsoil) ! layer depth for snow & soil (m) + real(kind_lake) :: dz(1,-nlevsnow+1:nlevsoil) ! layer thickness for soil or snow (m) + real(kind_lake) :: t_soisno(1,-nlevsnow+1:nlevsoil) ! soil (or snow) temperature (Kelvin) + real(kind_lake) :: t_lake(1,nlevlake) ! lake temperature (Kelvin) integer :: snl(1) ! number of snow layers - real(kind_phys) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) ! liquid water (kg/m2) - real(kind_phys) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) ! ice lens (kg/m2) - real(kind_phys) :: savedtke1(1) ! top level eddy conductivity from previous timestep (W/m.K) - real(kind_phys) :: zi(1,-nlevsnow+0:nlevsoil) ! interface level below a "z" level (m) - real(kind_phys) :: lake_icefrac(1,nlevlake) ! mass fraction of lake layer that is frozen + real(kind_lake) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) ! liquid water (kg/m2) + real(kind_lake) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) ! ice lens (kg/m2) + real(kind_lake) :: savedtke1(1) ! top level eddy conductivity from previous timestep (W/m.K) + real(kind_lake) :: zi(1,-nlevsnow+0:nlevsoil) ! interface level below a "z" level (m) + real(kind_lake) :: lake_icefrac(1,nlevlake) ! mass fraction of lake layer that is frozen !out: - real(kind_phys) :: eflx_gnet(1) !net heat flux into ground (W/m**2) - real(kind_phys) :: eflx_lwrad_net(1) ! net infrared (longwave) rad (W/m**2) [+ = to atm] - real(kind_phys) :: eflx_sh_tot(1) ! total sensible heat flux (W/m**2) [+ to atm] - real(kind_phys) :: eflx_lh_tot(1) ! total latent heat flux (W/m8*2) [+ to atm] - real(kind_phys) :: t_ref2m(1) ! 2 m height surface air temperature (Kelvin) - real(kind_phys) :: q_ref2m(1) ! 2 m height surface specific humidity (kg/kg) - real(kind_phys) :: taux(1) ! wind (shear) stress: e-w (kg/m/s**2) - real(kind_phys) :: tauy(1) ! wind (shear) stress: n-s (kg/m/s**2) - real(kind_phys) :: ram1(1) ! aerodynamical resistance (s/m) + real(kind_lake) :: eflx_gnet(1) !net heat flux into ground (W/m**2) + real(kind_lake) :: eflx_lwrad_net(1) ! net infrared (longwave) rad (W/m**2) [+ = to atm] + real(kind_lake) :: eflx_sh_tot(1) ! total sensible heat flux (W/m**2) [+ to atm] + real(kind_lake) :: eflx_lh_tot(1) ! total latent heat flux (W/m8*2) [+ to atm] + real(kind_lake) :: t_ref2m(1) ! 2 m height surface air temperature (Kelvin) + real(kind_lake) :: q_ref2m(1) ! 2 m height surface specific humidity (kg/kg) + real(kind_lake) :: taux(1) ! wind (shear) stress: e-w (kg/m/s**2) + real(kind_lake) :: tauy(1) ! wind (shear) stress: n-s (kg/m/s**2) + real(kind_lake) :: ram1(1) ! aerodynamical resistance (s/m) ! for calculation of decay of eddy diffusivity with depth ! Change the type variable to pass back to WRF. - real(kind_phys) :: z0mg(1) ! roughness length over ground, momentum (m( - real(kind_phys) :: qfx ! mass flux, old WRF qfx(:) variable, (kg/(sm^2)) + real(kind_lake) :: z0mg(1) ! roughness length over ground, momentum (m( + real(kind_lake) :: qfx ! mass flux, old WRF qfx(:) variable, (kg/(sm^2)) - real(kind_phys) :: ustar_out(1) ! friction velocity (temporary) [m/s] + real(kind_lake) :: ustar_out(1) ! friction velocity (temporary) [m/s] - real(kind_phys) :: discard1, discard2, discard3 ! for unused temporary data + real(kind_lake) :: discard1, discard2, discard3 ! for unused temporary data - real(kind_phys) :: watsat(1,nlevsoil) ! volumetric soil water at saturation (porosity) - real(kind_phys) :: tksatu(1,nlevsoil) ! thermal conductivity, saturated soil [W/m-K] - real(kind_phys) :: tkmg(1,nlevsoil) ! thermal conductivity, soil minerals [W/m-K] - real(kind_phys) :: tkdry(1,nlevsoil) ! thermal conductivity, dry soil (W/m/Kelvin) - real(kind_phys) :: csol(1,nlevsoil) ! heat capacity, soil solids (J/m**3/Kelvin) + real(kind_lake) :: watsat(1,nlevsoil) ! volumetric soil water at saturation (porosity) + real(kind_lake) :: tksatu(1,nlevsoil) ! thermal conductivity, saturated soil [W/m-K] + real(kind_lake) :: tkmg(1,nlevsoil) ! thermal conductivity, soil minerals [W/m-K] + real(kind_lake) :: tkdry(1,nlevsoil) ! thermal conductivity, dry soil (W/m/Kelvin) + real(kind_lake) :: csol(1,nlevsoil) ! heat capacity, soil solids (J/m**3/Kelvin) -! real(kind_phys) :: emiss ! surface emissivity +! real(kind_lake) :: emiss ! surface emissivity integer :: lake_points, snow_points, ice_points character*255 :: message @@ -457,12 +459,12 @@ SUBROUTINE clm_lake_run( & integer, save :: unhappy_count = HAVE_NOT_READ_UNHAPPY_POINTS_YET ! The latitude and longitude of unhappy points. - real(kind_phys), allocatable, save :: unhappy_lat(:),unhappy_lon(:) + real(kind_lake), allocatable, save :: unhappy_lat(:),unhappy_lon(:) - real(kind_phys) :: to_radians + real(kind_lake) :: to_radians, lat_d, lon_d, qss integer :: month,num1,num2,day_of_month - real(kind_phys) :: wght1,wght2,Tclim + real(kind_lake) :: wght1,wght2,Tclim logical salty_flag, cannot_freeze_flag @@ -549,9 +551,9 @@ SUBROUTINE clm_lake_run( & if(lakedebug) then write(0,*) 'Warning: wght2 is not 0..1: ',wght2 endif - wght2 = max(0.0_kind_phys,min(1.0_kind_phys,wght2)) + wght2 = max(0.0_kind_lake,min(1.0_kind_lake,wght2)) endif - wght1 = 1.0_kind_phys - wght2 + wght1 = 1.0_kind_lake - wght2 if(LAKEDEBUG .and. me==0) then print *,'month,num1,num2,wght1,wght2',month,num1,num2,wght1,wght2 @@ -667,6 +669,8 @@ SUBROUTINE clm_lake_run( & ram1 = -9999 z0mg = -9999 ustar_out = -9999 + lat_d = xlat_d(i) + lon_d = xlon_d(i) is_unhappy=.false. CALL LakeMain(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, & !I @@ -682,7 +686,7 @@ SUBROUTINE clm_lake_run( & t_ref2m,q_ref2m, dtime, & watsat, tksatu, tkmg, tkdry, csol, & taux,tauy,ram1,z0mg,ustar_out,errmsg,errflg, & - xlat_d(i),xlon_d(i),is_unhappy) + lat_d,lon_d,is_unhappy) if(LAKEDEBUG) then if((was_unhappy .or. is_unhappy) .and. kdt<3) then print *,'Unhappy point after LakeMain t_lake = ',t_lake(1,:) @@ -701,9 +705,9 @@ SUBROUTINE clm_lake_run( & do c = 1,column if(cannot_freeze(i) == 1) then - t_grnd(c) = max(274.5_kind_phys,t_grnd(c)) + t_grnd(c) = max(274.5_kind_lake,t_grnd(c)) do k = 1,nlevlake - t_lake(c,k) = max(274.5_kind_phys,t_lake(c,k)) + t_lake(c,k) = max(274.5_kind_lake,t_lake(c,k)) lake_icefrac(c,k) = 0. enddo endif @@ -712,11 +716,11 @@ SUBROUTINE clm_lake_run( & Tclim = tfrz + wght1*saltlk_T(num1) & + wght2*saltlk_T(num2) if(lakedebug) print *,'Tclim,tsfc,t_lake3d',i,Tclim,t_grnd(c),t_lake(c,:),t_soisno(c,:) - t_grnd(c) = min(Tclim+3.0_kind_phys,(max(t_grnd(c),Tclim-3.0_kind_phys))) + t_grnd(c) = min(Tclim+3.0_kind_lake,(max(t_grnd(c),Tclim-3.0_kind_lake))) do k = 1,nlevlake - t_lake(c,k) = min(Tclim+3.0_kind_phys,(max(t_lake(c,k),Tclim-3.0_kind_phys))) + t_lake(c,k) = min(Tclim+3.0_kind_lake,(max(t_lake(c,k),Tclim-3.0_kind_lake))) enddo - t_soisno(c,1) = min(Tclim+3.0_kind_phys,(max(t_soisno(c,1),Tclim-3.0_kind_phys))) + t_soisno(c,1) = min(Tclim+3.0_kind_lake,(max(t_soisno(c,1),Tclim-3.0_kind_lake))) if(lakedebug) print *,'After Tclim,tsfc,t_lake3d',i,Tclim,t_grnd(c),t_lake(c,:),t_soisno(c,:) endif @@ -775,7 +779,9 @@ SUBROUTINE clm_lake_run( & discard1 = -9999 discard2 = -9999 discard3 = -9999 - call QSat(t_grnd(c),psfc,discard1,discard2,qss_water(i),discard3) + qss = qss_water(i) + call QSat(t_grnd(c),psfc,discard1,discard2,qss,discard3) + qss_water(i) = qss ! Combined water-ice chh and cmm calculations come from Flake model: chh_water(i) = ch(i)*wind(i)*1.225 ! surface_drag_mass_flux_for_heat_and_moisture_in_air_over_water @@ -990,114 +996,114 @@ SUBROUTINE LakeMain(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, & !I logical :: unhappy integer, intent(inout) :: errflg character(*), intent(inout) :: errmsg - real(kind_phys),intent(in) :: dtime ! timestep - real(kind_phys),intent(in) :: xlat_d, xlon_d ! grid location for debugging - real(kind_phys),intent(in) :: forc_t(1) ! atmospheric temperature (Kelvin) - real(kind_phys),intent(in) :: forc_pbot(1) ! atm bottom level pressure (Pa) - real(kind_phys),intent(in) :: forc_psrf(1) ! atmospheric surface pressure (Pa) - real(kind_phys),intent(in) :: forc_hgt(1) ! atmospheric reference height (m) - real(kind_phys),intent(in) :: forc_hgt_q(1) ! observational height of humidity [m] - real(kind_phys),intent(in) :: forc_hgt_t(1) ! observational height of temperature [m] - real(kind_phys),intent(in) :: forc_hgt_u(1) ! observational height of wind [m] - real(kind_phys),intent(in) :: forc_q(1) ! atmospheric specific humidity (kg/kg) - real(kind_phys),intent(in) :: forc_u(1) ! atmospheric wind speed in east direction (m/s) - real(kind_phys),intent(in) :: forc_v(1) ! atmospheric wind speed in north direction (m/s) - ! real(kind_phys),intent(in) :: forc_rho(1) ! density (kg/m**3) - real(kind_phys),intent(in) :: forc_lwrad(1) ! downward infrared (longwave) radiation (W/m**2) - real(kind_phys),intent(in) :: prec(1) ! snow or rain rate [mm/s] - real(kind_phys),intent(in) :: sabg(1) ! solar radiation absorbed by ground (W/m**2) - real(kind_phys),intent(in) :: lat(1) ! latitude (radians) - real(kind_phys),intent(in) :: z_lake(1,nlevlake) ! layer depth for lake (m) - real(kind_phys),intent(in) :: dz_lake(1,nlevlake) ! layer thickness for lake (m) - real(kind_phys),intent(out) :: ustar_out(1) ! friction velocity [m/s] - real(kind_phys), intent(in) :: lakedepth(1) ! column lake depth (m) + real(kind_lake),intent(in) :: dtime ! timestep + real(kind_lake),intent(in) :: xlat_d, xlon_d ! grid location for debugging + real(kind_lake),intent(in) :: forc_t(1) ! atmospheric temperature (Kelvin) + real(kind_lake),intent(in) :: forc_pbot(1) ! atm bottom level pressure (Pa) + real(kind_lake),intent(in) :: forc_psrf(1) ! atmospheric surface pressure (Pa) + real(kind_lake),intent(in) :: forc_hgt(1) ! atmospheric reference height (m) + real(kind_lake),intent(in) :: forc_hgt_q(1) ! observational height of humidity [m] + real(kind_lake),intent(in) :: forc_hgt_t(1) ! observational height of temperature [m] + real(kind_lake),intent(in) :: forc_hgt_u(1) ! observational height of wind [m] + real(kind_lake),intent(in) :: forc_q(1) ! atmospheric specific humidity (kg/kg) + real(kind_lake),intent(in) :: forc_u(1) ! atmospheric wind speed in east direction (m/s) + real(kind_lake),intent(in) :: forc_v(1) ! atmospheric wind speed in north direction (m/s) + ! real(kind_lake),intent(in) :: forc_rho(1) ! density (kg/m**3) + real(kind_lake),intent(in) :: forc_lwrad(1) ! downward infrared (longwave) radiation (W/m**2) + real(kind_lake),intent(in) :: prec(1) ! snow or rain rate [mm/s] + real(kind_lake),intent(in) :: sabg(1) ! solar radiation absorbed by ground (W/m**2) + real(kind_lake),intent(in) :: lat(1) ! latitude (radians) + real(kind_lake),intent(in) :: z_lake(1,nlevlake) ! layer depth for lake (m) + real(kind_lake),intent(in) :: dz_lake(1,nlevlake) ! layer thickness for lake (m) + real(kind_lake),intent(out) :: ustar_out(1) ! friction velocity [m/s] + real(kind_lake), intent(in) :: lakedepth(1) ! column lake depth (m) !!!!!!!!!!!!!!!!tep(in),hydro(in) - ! real(kind_phys), intent(in) :: watsat(1,1:nlevsoil) ! volumetric soil water at saturation (porosity) + ! real(kind_lake), intent(in) :: watsat(1,1:nlevsoil) ! volumetric soil water at saturation (porosity) !!!!!!!!!!!!!!!!hydro logical , intent(in) :: do_capsnow(1) ! true => do snow capping - real(kind_phys), intent(in) :: watsat(1,nlevsoil) ! volumetric soil water at saturation (porosity) - real(kind_phys), intent(in) :: tksatu(1,nlevsoil) ! thermal conductivity, saturated soil [W/m-K] - real(kind_phys), intent(in) :: tkmg(1,nlevsoil) ! thermal conductivity, soil minerals [W/m-K] - real(kind_phys), intent(in) :: tkdry(1,nlevsoil) ! thermal conductivity, dry soil (W/m/Kelvin) - real(kind_phys), intent(in) :: csol(1,nlevsoil) ! heat capacity, soil solids (J/m**3/Kelvin) + real(kind_lake), intent(in) :: watsat(1,nlevsoil) ! volumetric soil water at saturation (porosity) + real(kind_lake), intent(in) :: tksatu(1,nlevsoil) ! thermal conductivity, saturated soil [W/m-K] + real(kind_lake), intent(in) :: tkmg(1,nlevsoil) ! thermal conductivity, soil minerals [W/m-K] + real(kind_lake), intent(in) :: tkdry(1,nlevsoil) ! thermal conductivity, dry soil (W/m/Kelvin) + real(kind_lake), intent(in) :: csol(1,nlevsoil) ! heat capacity, soil solids (J/m**3/Kelvin) !in&out - real(kind_phys),intent(inout) :: h2osoi_vol(1,-nlevsnow+1:nlevsoil) ! volumetric soil water (0<=h2osoi_vol<=watsat)[m3/m3] - real(kind_phys),intent(inout) :: t_grnd(1) ! ground temperature (Kelvin) - real(kind_phys),intent(inout) :: h2osno(1) ! snow water (mm H2O) - real(kind_phys),intent(inout) :: snowdp(1) ! snow height (m) - real(kind_phys),intent(inout) :: z(1,-nlevsnow+1:nlevsoil) ! layer depth for snow & soil (m) - real(kind_phys),intent(inout) :: dz(1,-nlevsnow+1:nlevsoil) ! layer thickness for soil or snow (m) - real(kind_phys),intent(inout) :: t_soisno(1,-nlevsnow+1:nlevsoil) ! soil (or snow) temperature (Kelvin) - real(kind_phys),intent(inout) :: t_lake(1,nlevlake) ! lake temperature (Kelvin) + real(kind_lake),intent(inout) :: h2osoi_vol(1,-nlevsnow+1:nlevsoil) ! volumetric soil water (0<=h2osoi_vol<=watsat)[m3/m3] + real(kind_lake),intent(inout) :: t_grnd(1) ! ground temperature (Kelvin) + real(kind_lake),intent(inout) :: h2osno(1) ! snow water (mm H2O) + real(kind_lake),intent(inout) :: snowdp(1) ! snow height (m) + real(kind_lake),intent(inout) :: z(1,-nlevsnow+1:nlevsoil) ! layer depth for snow & soil (m) + real(kind_lake),intent(inout) :: dz(1,-nlevsnow+1:nlevsoil) ! layer thickness for soil or snow (m) + real(kind_lake),intent(inout) :: t_soisno(1,-nlevsnow+1:nlevsoil) ! soil (or snow) temperature (Kelvin) + real(kind_lake),intent(inout) :: t_lake(1,nlevlake) ! lake temperature (Kelvin) integer ,intent(inout) :: snl(1) ! number of snow layers - real(kind_phys),intent(inout) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) ! liquid water (kg/m2) - real(kind_phys),intent(inout) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) ! ice lens (kg/m2) - real(kind_phys),intent(inout) :: savedtke1(1) ! top level eddy conductivity from previous timestep (W/m.K) - real(kind_phys),intent(inout) :: zi(1,-nlevsnow+0:nlevsoil) ! interface level below a "z" level (m) - real(kind_phys),intent(inout) :: lake_icefrac(1,nlevlake) ! mass fraction of lake layer that is frozen + real(kind_lake),intent(inout) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) ! liquid water (kg/m2) + real(kind_lake),intent(inout) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) ! ice lens (kg/m2) + real(kind_lake),intent(inout) :: savedtke1(1) ! top level eddy conductivity from previous timestep (W/m.K) + real(kind_lake),intent(inout) :: zi(1,-nlevsnow+0:nlevsoil) ! interface level below a "z" level (m) + real(kind_lake),intent(inout) :: lake_icefrac(1,nlevlake) ! mass fraction of lake layer that is frozen !out: - real(kind_phys),intent(out) :: eflx_gnet(1) !net heat flux into ground (W/m**2) - real(kind_phys),intent(out) :: eflx_lwrad_net(1) ! net infrared (longwave) rad (W/m**2) [+ = to atm] - real(kind_phys),intent(out) :: eflx_sh_tot(1) ! total sensible heat flux (W/m**2) [+ to atm] - real(kind_phys),intent(out) :: eflx_lh_tot(1) ! total latent heat flux (W/m8*2) [+ to atm] - real(kind_phys),intent(out) :: t_ref2m(1) ! 2 m height surface air temperature (Kelvin) - real(kind_phys),intent(out) :: q_ref2m(1) ! 2 m height surface specific humidity (kg/kg) - real(kind_phys),intent(out) :: taux(1) ! wind (shear) stress: e-w (kg/m/s**2) - real(kind_phys),intent(out) :: tauy(1) ! wind (shear) stress: n-s (kg/m/s**2) - real(kind_phys),intent(out) :: ram1(1) ! aerodynamical resistance (s/m) + real(kind_lake),intent(out) :: eflx_gnet(1) !net heat flux into ground (W/m**2) + real(kind_lake),intent(out) :: eflx_lwrad_net(1) ! net infrared (longwave) rad (W/m**2) [+ = to atm] + real(kind_lake),intent(out) :: eflx_sh_tot(1) ! total sensible heat flux (W/m**2) [+ to atm] + real(kind_lake),intent(out) :: eflx_lh_tot(1) ! total latent heat flux (W/m8*2) [+ to atm] + real(kind_lake),intent(out) :: t_ref2m(1) ! 2 m height surface air temperature (Kelvin) + real(kind_lake),intent(out) :: q_ref2m(1) ! 2 m height surface specific humidity (kg/kg) + real(kind_lake),intent(out) :: taux(1) ! wind (shear) stress: e-w (kg/m/s**2) + real(kind_lake),intent(out) :: tauy(1) ! wind (shear) stress: n-s (kg/m/s**2) + real(kind_lake),intent(out) :: ram1(1) ! aerodynamical resistance (s/m) ! for calculation of decay of eddy diffusivity with depth ! Change the type variable to pass back to WRF. - real(kind_phys),intent(out) :: z0mg(1) ! roughness length over ground, momentum (m( + real(kind_lake),intent(out) :: z0mg(1) ! roughness length over ground, momentum (m( !local output - real(kind_phys) :: begwb(1) ! water mass begining of the time step - real(kind_phys) :: t_veg(1) ! vegetation temperature (Kelvin) - real(kind_phys) :: eflx_soil_grnd(1) ! soil heat flux (W/m**2) [+ = into soil] - real(kind_phys) :: eflx_lh_grnd(1) ! ground evaporation heat flux (W/m**2) [+ to atm] - real(kind_phys) :: eflx_sh_grnd(1) ! sensible heat flux from ground (W/m**2) [+ to atm] - real(kind_phys) :: eflx_lwrad_out(1) ! emitted infrared (longwave) radiation (W/m**2) - real(kind_phys) :: qflx_evap_tot(1) ! qflx_evap_soi + qflx_evap_veg + qflx_tran_veg - real(kind_phys) :: qflx_evap_soi(1) ! soil evaporation (mm H2O/s) (+ = to atm) - real(kind_phys) :: qflx_prec_grnd(1) ! water onto ground including canopy runoff [kg/(m2 s)] - real(kind_phys) :: forc_snow(1) ! snow rate [mm/s] - real(kind_phys) :: forc_rain(1) ! rain rate [mm/s] - real(kind_phys) :: ws(1) ! surface friction velocity (m/s) - real(kind_phys) :: ks(1) ! coefficient passed to ShalLakeTemperature - real(kind_phys) :: qflx_snomelt(1) !snow melt (mm H2O /s) tem(out),snowwater(in) + real(kind_lake) :: begwb(1) ! water mass begining of the time step + real(kind_lake) :: t_veg(1) ! vegetation temperature (Kelvin) + real(kind_lake) :: eflx_soil_grnd(1) ! soil heat flux (W/m**2) [+ = into soil] + real(kind_lake) :: eflx_lh_grnd(1) ! ground evaporation heat flux (W/m**2) [+ to atm] + real(kind_lake) :: eflx_sh_grnd(1) ! sensible heat flux from ground (W/m**2) [+ to atm] + real(kind_lake) :: eflx_lwrad_out(1) ! emitted infrared (longwave) radiation (W/m**2) + real(kind_lake) :: qflx_evap_tot(1) ! qflx_evap_soi + qflx_evap_veg + qflx_tran_veg + real(kind_lake) :: qflx_evap_soi(1) ! soil evaporation (mm H2O/s) (+ = to atm) + real(kind_lake) :: qflx_prec_grnd(1) ! water onto ground including canopy runoff [kg/(m2 s)] + real(kind_lake) :: forc_snow(1) ! snow rate [mm/s] + real(kind_lake) :: forc_rain(1) ! rain rate [mm/s] + real(kind_lake) :: ws(1) ! surface friction velocity (m/s) + real(kind_lake) :: ks(1) ! coefficient passed to ShalLakeTemperature + real(kind_lake) :: qflx_snomelt(1) !snow melt (mm H2O /s) tem(out),snowwater(in) integer :: imelt(1,-nlevsnow+1:nlevsoil) !flag for melting (=1), freezing (=2), Not=0 (new) - real(kind_phys) :: endwb(1) ! water mass end of the time step - real(kind_phys) :: snowage(1) ! non dimensional snow age [-] - real(kind_phys) :: snowice(1) ! average snow ice lens - real(kind_phys) :: snowliq(1) ! average snow liquid water - real(kind_phys) :: t_snow(1) ! vertically averaged snow temperature - real(kind_phys) :: qflx_drain(1) ! sub-surface runoff (mm H2O /s) - real(kind_phys) :: qflx_surf(1) ! surface runoff (mm H2O /s) - real(kind_phys) :: qflx_infl(1) ! infiltration (mm H2O /s) - real(kind_phys) :: qflx_qrgwl(1) ! qflx_surf at glaciers, wetlands, lakes - real(kind_phys) :: qcharge(1) ! aquifer recharge rate (mm/s) - real(kind_phys) :: qflx_snowcap(1) ! excess precipitation due to snow capping (mm H2O /s) [+] - real(kind_phys) :: qflx_snowcap_col(1) ! excess precipitation due to snow capping (mm H2O /s) [+] - real(kind_phys) :: qflx_snow_grnd_pft(1) ! snow on ground after interception (mm H2O/s) [+] - real(kind_phys) :: qflx_snow_grnd_col(1) ! snow on ground after interception (mm H2O/s) [+] - real(kind_phys) :: qflx_rain_grnd(1) ! rain on ground after interception (mm H2O/s) [+] - real(kind_phys) :: frac_iceold(1,-nlevsnow+1:nlevsoil) ! fraction of ice relative to the tot water - real(kind_phys) :: qflx_evap_tot_col(1) !pft quantity averaged to the column (assuming one pft) - real(kind_phys) :: soilalpha(1) !factor that reduces ground saturated specific humidity (-) - real(kind_phys) :: zwt(1) !water table depth - real(kind_phys) :: fcov(1) !fractional area with water table at surface - real(kind_phys) :: rootr_column(1,1:nlevsoil) !effective fraction of roots in each soil layer - real(kind_phys) :: qflx_evap_grnd(1) ! ground surface evaporation rate (mm H2O/s) [+] - real(kind_phys) :: qflx_sub_snow(1) ! sublimation rate from snow pack (mm H2O /s) [+] - real(kind_phys) :: qflx_dew_snow(1) ! surface dew added to snow pack (mm H2O /s) [+] - real(kind_phys) :: qflx_dew_grnd(1) ! ground surface dew formation (mm H2O /s) [+] - real(kind_phys) :: qflx_rain_grnd_col(1) !rain on ground after interception (mm H2O/s) [+] + real(kind_lake) :: endwb(1) ! water mass end of the time step + real(kind_lake) :: snowage(1) ! non dimensional snow age [-] + real(kind_lake) :: snowice(1) ! average snow ice lens + real(kind_lake) :: snowliq(1) ! average snow liquid water + real(kind_lake) :: t_snow(1) ! vertically averaged snow temperature + real(kind_lake) :: qflx_drain(1) ! sub-surface runoff (mm H2O /s) + real(kind_lake) :: qflx_surf(1) ! surface runoff (mm H2O /s) + real(kind_lake) :: qflx_infl(1) ! infiltration (mm H2O /s) + real(kind_lake) :: qflx_qrgwl(1) ! qflx_surf at glaciers, wetlands, lakes + real(kind_lake) :: qcharge(1) ! aquifer recharge rate (mm/s) + real(kind_lake) :: qflx_snowcap(1) ! excess precipitation due to snow capping (mm H2O /s) [+] + real(kind_lake) :: qflx_snowcap_col(1) ! excess precipitation due to snow capping (mm H2O /s) [+] + real(kind_lake) :: qflx_snow_grnd_pft(1) ! snow on ground after interception (mm H2O/s) [+] + real(kind_lake) :: qflx_snow_grnd_col(1) ! snow on ground after interception (mm H2O/s) [+] + real(kind_lake) :: qflx_rain_grnd(1) ! rain on ground after interception (mm H2O/s) [+] + real(kind_lake) :: frac_iceold(1,-nlevsnow+1:nlevsoil) ! fraction of ice relative to the tot water + real(kind_lake) :: qflx_evap_tot_col(1) !pft quantity averaged to the column (assuming one pft) + real(kind_lake) :: soilalpha(1) !factor that reduces ground saturated specific humidity (-) + real(kind_lake) :: zwt(1) !water table depth + real(kind_lake) :: fcov(1) !fractional area with water table at surface + real(kind_lake) :: rootr_column(1,1:nlevsoil) !effective fraction of roots in each soil layer + real(kind_lake) :: qflx_evap_grnd(1) ! ground surface evaporation rate (mm H2O/s) [+] + real(kind_lake) :: qflx_sub_snow(1) ! sublimation rate from snow pack (mm H2O /s) [+] + real(kind_lake) :: qflx_dew_snow(1) ! surface dew added to snow pack (mm H2O /s) [+] + real(kind_lake) :: qflx_dew_grnd(1) ! ground surface dew formation (mm H2O /s) [+] + real(kind_lake) :: qflx_rain_grnd_col(1) !rain on ground after interception (mm H2O/s) [+] begwb = 0 ! lat = lat*pi/180 ! [radian] @@ -1214,60 +1220,60 @@ SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, integer, intent(inout) :: errflg logical :: unhappy character(len=*), intent(inout) :: errmsg - real(kind_phys),intent(in) :: xlat_d,xlon_d - real(kind_phys),intent(in) :: forc_t(1) ! atmospheric temperature (Kelvin) - real(kind_phys),intent(in) :: forc_pbot(1) ! atmospheric pressure (Pa) - real(kind_phys),intent(in) :: forc_psrf(1) ! atmospheric surface pressure (Pa) - real(kind_phys),intent(in) :: forc_hgt(1) ! atmospheric reference height (m) - real(kind_phys),intent(in) :: forc_hgt_q(1) ! observational height of humidity [m] - real(kind_phys),intent(in) :: forc_hgt_t(1) ! observational height of temperature [m] - real(kind_phys),intent(in) :: forc_hgt_u(1) ! observational height of wind [m] - real(kind_phys),intent(in) :: forc_q(1) ! atmospheric specific humidity (kg/kg) - real(kind_phys),intent(in) :: forc_u(1) ! atmospheric wind speed in east direction (m/s) - real(kind_phys),intent(in) :: forc_v(1) ! atmospheric wind speed in north direction (m/s) - real(kind_phys),intent(in) :: forc_lwrad(1) ! downward infrared (longwave) radiation (W/m**2) - ! real(kind_phys),intent(in) :: forc_rho(1) ! density (kg/m**3) - real(kind_phys),intent(in) :: forc_snow(1) ! snow rate [mm/s] - real(kind_phys),intent(in) :: forc_rain(1) ! rain rate [mm/s] - real(kind_phys),intent(in) :: h2osno(1) ! snow water (mm H2O) - real(kind_phys),intent(in) :: snowdp(1) ! snow height (m) - real(kind_phys),intent(in) :: sabg(1) ! solar radiation absorbed by ground (W/m**2) - real(kind_phys),intent(in) :: lat(1) ! latitude (radians) - real(kind_phys),intent(in) :: dz(1,-nlevsnow+1:nlevsoil) ! layer thickness for soil or snow (m) - real(kind_phys),intent(in) :: dz_lake(1,nlevlake) ! layer thickness for lake (m) - real(kind_phys),intent(in) :: t_soisno(1,-nlevsnow+1:nlevsoil) ! soil (or snow) temperature (Kelvin) - real(kind_phys),intent(in) :: t_lake(1,nlevlake) ! lake temperature (Kelvin) + real(kind_lake),intent(in) :: xlat_d,xlon_d + real(kind_lake),intent(in) :: forc_t(1) ! atmospheric temperature (Kelvin) + real(kind_lake),intent(in) :: forc_pbot(1) ! atmospheric pressure (Pa) + real(kind_lake),intent(in) :: forc_psrf(1) ! atmospheric surface pressure (Pa) + real(kind_lake),intent(in) :: forc_hgt(1) ! atmospheric reference height (m) + real(kind_lake),intent(in) :: forc_hgt_q(1) ! observational height of humidity [m] + real(kind_lake),intent(in) :: forc_hgt_t(1) ! observational height of temperature [m] + real(kind_lake),intent(in) :: forc_hgt_u(1) ! observational height of wind [m] + real(kind_lake),intent(in) :: forc_q(1) ! atmospheric specific humidity (kg/kg) + real(kind_lake),intent(in) :: forc_u(1) ! atmospheric wind speed in east direction (m/s) + real(kind_lake),intent(in) :: forc_v(1) ! atmospheric wind speed in north direction (m/s) + real(kind_lake),intent(in) :: forc_lwrad(1) ! downward infrared (longwave) radiation (W/m**2) + ! real(kind_lake),intent(in) :: forc_rho(1) ! density (kg/m**3) + real(kind_lake),intent(in) :: forc_snow(1) ! snow rate [mm/s] + real(kind_lake),intent(in) :: forc_rain(1) ! rain rate [mm/s] + real(kind_lake),intent(in) :: h2osno(1) ! snow water (mm H2O) + real(kind_lake),intent(in) :: snowdp(1) ! snow height (m) + real(kind_lake),intent(in) :: sabg(1) ! solar radiation absorbed by ground (W/m**2) + real(kind_lake),intent(in) :: lat(1) ! latitude (radians) + real(kind_lake),intent(in) :: dz(1,-nlevsnow+1:nlevsoil) ! layer thickness for soil or snow (m) + real(kind_lake),intent(in) :: dz_lake(1,nlevlake) ! layer thickness for lake (m) + real(kind_lake),intent(in) :: t_soisno(1,-nlevsnow+1:nlevsoil) ! soil (or snow) temperature (Kelvin) + real(kind_lake),intent(in) :: t_lake(1,nlevlake) ! lake temperature (Kelvin) integer ,intent(in) :: snl(1) ! number of snow layers - real(kind_phys),intent(in) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) ! liquid water (kg/m2) - real(kind_phys),intent(in) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) ! ice lens (kg/m2) - real(kind_phys),intent(in) :: savedtke1(1) ! top level eddy conductivity from previous timestep (W/m.K) + real(kind_lake),intent(in) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) ! liquid water (kg/m2) + real(kind_lake),intent(in) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) ! ice lens (kg/m2) + real(kind_lake),intent(in) :: savedtke1(1) ! top level eddy conductivity from previous timestep (W/m.K) !inout: - real(kind_phys),intent(inout) :: t_grnd(1) ! ground temperature (Kelvin) + real(kind_lake),intent(inout) :: t_grnd(1) ! ground temperature (Kelvin) !out: - real(kind_phys),intent(out):: ustar_out(1) ! friction velocity [m/s] - real(kind_phys),intent(out):: qflx_prec_grnd(1) ! water onto ground including canopy runoff [kg/(m2 s)] - real(kind_phys),intent(out):: qflx_evap_soi(1) ! soil evaporation (mm H2O/s) (+ = to atm) - real(kind_phys),intent(out):: qflx_evap_tot(1) ! qflx_evap_soi + qflx_evap_veg + qflx_tran_veg - real(kind_phys),intent(out):: eflx_sh_grnd(1) ! sensible heat flux from ground (W/m**2) [+ to atm] - real(kind_phys),intent(out):: eflx_lwrad_out(1) ! emitted infrared (longwave) radiation (W/m**2) - real(kind_phys),intent(out):: eflx_lwrad_net(1) ! net infrared (longwave) rad (W/m**2) [+ = to atm] - real(kind_phys),intent(out):: eflx_soil_grnd(1) ! soil heat flux (W/m**2) [+ = into soil] - real(kind_phys),intent(out):: eflx_sh_tot(1) ! total sensible heat flux (W/m**2) [+ to atm] - real(kind_phys),intent(out):: eflx_lh_tot(1) ! total latent heat flux (W/m8*2) [+ to atm] - real(kind_phys),intent(out):: eflx_lh_grnd(1) ! ground evaporation heat flux (W/m**2) [+ to atm] - real(kind_phys),intent(out):: t_veg(1) ! vegetation temperature (Kelvin) - real(kind_phys),intent(out):: t_ref2m(1) ! 2 m height surface air temperature (Kelvin) - real(kind_phys),intent(out):: q_ref2m(1) ! 2 m height surface specific humidity (kg/kg) - real(kind_phys),intent(out):: taux(1) ! wind (shear) stress: e-w (kg/m/s**2) - real(kind_phys),intent(out):: tauy(1) ! wind (shear) stress: n-s (kg/m/s**2) - real(kind_phys),intent(out):: ram1(1) ! aerodynamical resistance (s/m) - real(kind_phys),intent(out):: ws(1) ! surface friction velocity (m/s) - real(kind_phys),intent(out):: ks(1) ! coefficient passed to ShalLakeTemperature + real(kind_lake),intent(out):: ustar_out(1) ! friction velocity [m/s] + real(kind_lake),intent(out):: qflx_prec_grnd(1) ! water onto ground including canopy runoff [kg/(m2 s)] + real(kind_lake),intent(out):: qflx_evap_soi(1) ! soil evaporation (mm H2O/s) (+ = to atm) + real(kind_lake),intent(out):: qflx_evap_tot(1) ! qflx_evap_soi + qflx_evap_veg + qflx_tran_veg + real(kind_lake),intent(out):: eflx_sh_grnd(1) ! sensible heat flux from ground (W/m**2) [+ to atm] + real(kind_lake),intent(out):: eflx_lwrad_out(1) ! emitted infrared (longwave) radiation (W/m**2) + real(kind_lake),intent(out):: eflx_lwrad_net(1) ! net infrared (longwave) rad (W/m**2) [+ = to atm] + real(kind_lake),intent(out):: eflx_soil_grnd(1) ! soil heat flux (W/m**2) [+ = into soil] + real(kind_lake),intent(out):: eflx_sh_tot(1) ! total sensible heat flux (W/m**2) [+ to atm] + real(kind_lake),intent(out):: eflx_lh_tot(1) ! total latent heat flux (W/m8*2) [+ to atm] + real(kind_lake),intent(out):: eflx_lh_grnd(1) ! ground evaporation heat flux (W/m**2) [+ to atm] + real(kind_lake),intent(out):: t_veg(1) ! vegetation temperature (Kelvin) + real(kind_lake),intent(out):: t_ref2m(1) ! 2 m height surface air temperature (Kelvin) + real(kind_lake),intent(out):: q_ref2m(1) ! 2 m height surface specific humidity (kg/kg) + real(kind_lake),intent(out):: taux(1) ! wind (shear) stress: e-w (kg/m/s**2) + real(kind_lake),intent(out):: tauy(1) ! wind (shear) stress: n-s (kg/m/s**2) + real(kind_lake),intent(out):: ram1(1) ! aerodynamical resistance (s/m) + real(kind_lake),intent(out):: ws(1) ! surface friction velocity (m/s) + real(kind_lake),intent(out):: ks(1) ! coefficient passed to ShalLakeTemperature ! for calculation of decay of eddy diffusivity with depth - real(kind_phys),intent(out):: eflx_gnet(1) !net heat flux into ground (W/m**2) + real(kind_lake),intent(out):: eflx_gnet(1) !net heat flux into ground (W/m**2) ! Change the type variable to pass back to WRF. - real(kind_phys),intent(out):: z0mg(1) ! roughness length over ground, momentum (m( + real(kind_lake),intent(out):: z0mg(1) ! roughness length over ground, momentum (m( @@ -1275,13 +1281,13 @@ SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, integer , parameter :: islak = 2 ! index of lake, 1 = deep lake, 2 = shallow lake integer , parameter :: niters = 3 ! maximum number of iterations for surface temperature - real(kind_phys), parameter :: beta1 = 1._kind_phys ! coefficient of convective velocity (in computing W_*) [-] - real(kind_phys), parameter :: emg = 0.97_kind_phys ! ground emissivity (0.97 for water) - real(kind_phys), parameter :: zii = 1000._kind_phys! convective boundary height [m] - real(kind_phys), parameter :: tdmax = 277._kind_phys ! temperature of maximum water density - real(kind_phys) :: forc_th(1) ! atmospheric potential temperature (Kelvin) - real(kind_phys) :: forc_vp(1) !atmospheric vapor pressure (Pa) - real(kind_phys) :: forc_rho(1) ! density (kg/m**3) + real(kind_lake), parameter :: beta1 = 1._kind_lake ! coefficient of convective velocity (in computing W_*) [-] + real(kind_lake), parameter :: emg = 0.97_kind_lake ! ground emissivity (0.97 for water) + real(kind_lake), parameter :: zii = 1000._kind_lake! convective boundary height [m] + real(kind_lake), parameter :: tdmax = 277._kind_lake ! temperature of maximum water density + real(kind_lake) :: forc_th(1) ! atmospheric potential temperature (Kelvin) + real(kind_lake) :: forc_vp(1) !atmospheric vapor pressure (Pa) + real(kind_lake) :: forc_rho(1) ! density (kg/m**3) integer :: i,fc,fp,g,c,p ! do loop or array index integer :: fncopy ! number of values in pft filter copy integer :: fnold ! previous number of pft filter values @@ -1289,67 +1295,67 @@ SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, integer :: iter ! iteration index integer :: nmozsgn(lbp:ubp) ! number of times moz changes sign integer :: jtop(lbc:ubc) ! top level for each column (no longer all 1) - real(kind_phys) :: ax ! used in iteration loop for calculating t_grnd (numerator of NR solution) - real(kind_phys) :: bx ! used in iteration loop for calculating t_grnd (denomin. of NR solution) - real(kind_phys) :: degdT ! d(eg)/dT - real(kind_phys) :: dqh(lbp:ubp) ! diff of humidity between ref. height and surface - real(kind_phys) :: dth(lbp:ubp) ! diff of virtual temp. between ref. height and surface - real(kind_phys) :: dthv ! diff of vir. poten. temp. between ref. height and surface - real(kind_phys) :: dzsur(lbc:ubc) ! 1/2 the top layer thickness (m) - real(kind_phys) :: eg ! water vapor pressure at temperature T [pa] - real(kind_phys) :: htvp(lbc:ubc) ! latent heat of vapor of water (or sublimation) [j/kg] - real(kind_phys) :: obu(lbp:ubp) ! monin-obukhov length (m) - real(kind_phys) :: obuold(lbp:ubp) ! monin-obukhov length of previous iteration - real(kind_phys) :: qsatg(lbc:ubc) ! saturated humidity [kg/kg] - real(kind_phys) :: qsatgdT(lbc:ubc) ! d(qsatg)/dT - real(kind_phys) :: qstar ! moisture scaling parameter - real(kind_phys) :: ram(lbp:ubp) ! aerodynamical resistance [s/m] - real(kind_phys) :: rah(lbp:ubp) ! thermal resistance [s/m] - real(kind_phys) :: raw(lbp:ubp) ! moisture resistance [s/m] - real(kind_phys) :: stftg3(lbp:ubp) ! derivative of fluxes w.r.t ground temperature - real(kind_phys) :: temp1(lbp:ubp) ! relation for potential temperature profile - real(kind_phys) :: temp12m(lbp:ubp) ! relation for potential temperature profile applied at 2-m - real(kind_phys) :: temp2(lbp:ubp) ! relation for specific humidity profile - real(kind_phys) :: temp22m(lbp:ubp) ! relation for specific humidity profile applied at 2-m - real(kind_phys) :: tgbef(lbc:ubc) ! initial ground temperature - real(kind_phys) :: thm(lbc:ubc) ! intermediate variable (forc_t+0.0098*forc_hgt_t) - real(kind_phys) :: thv(lbc:ubc) ! virtual potential temperature (kelvin) - real(kind_phys) :: thvstar ! virtual potential temperature scaling parameter - real(kind_phys) :: tksur ! thermal conductivity of snow/soil (w/m/kelvin) - real(kind_phys) :: tsur ! top layer temperature - real(kind_phys) :: tstar ! temperature scaling parameter - real(kind_phys) :: um(lbp:ubp) ! wind speed including the stablity effect [m/s] - real(kind_phys) :: ur(lbp:ubp) ! wind speed at reference height [m/s] - real(kind_phys) :: ustar(lbp:ubp) ! friction velocity [m/s] - real(kind_phys) :: wc ! convective velocity [m/s] - real(kind_phys) :: zeta ! dimensionless height used in Monin-Obukhov theory - real(kind_phys) :: zldis(lbp:ubp) ! reference height "minus" zero displacement height [m] - real(kind_phys) :: displa(lbp:ubp) ! displacement (always zero) [m] - ! real(kind_phys) :: z0mg(lbp:ubp) ! roughness length over ground, momentum [m] - real(kind_phys) :: z0hg(lbp:ubp) ! roughness length over ground, sensible heat [m] - real(kind_phys) :: z0qg(lbp:ubp) ! roughness length over ground, latent heat [m] - real(kind_phys) :: u2m ! 2 m wind speed (m/s) - real(kind_phys) :: u10(1) ! 10-m wind (m/s) (for dust model) - real(kind_phys) :: fv(1) ! friction velocity (m/s) (for dust model) - - real(kind_phys) :: fm(lbp:ubp) ! needed for BGC only to diagnose 10m wind speed - real(kind_phys) :: bw ! partial density of water (ice + liquid) - real(kind_phys) :: t_grnd_temp ! Used in surface flux correction over frozen ground - real(kind_phys) :: betaprime(lbc:ubc) ! Effective beta: 1 for snow layers, beta(islak) otherwise + real(kind_lake) :: ax ! used in iteration loop for calculating t_grnd (numerator of NR solution) + real(kind_lake) :: bx ! used in iteration loop for calculating t_grnd (denomin. of NR solution) + real(kind_lake) :: degdT ! d(eg)/dT + real(kind_lake) :: dqh(lbp:ubp) ! diff of humidity between ref. height and surface + real(kind_lake) :: dth(lbp:ubp) ! diff of virtual temp. between ref. height and surface + real(kind_lake) :: dthv ! diff of vir. poten. temp. between ref. height and surface + real(kind_lake) :: dzsur(lbc:ubc) ! 1/2 the top layer thickness (m) + real(kind_lake) :: eg ! water vapor pressure at temperature T [pa] + real(kind_lake) :: htvp(lbc:ubc) ! latent heat of vapor of water (or sublimation) [j/kg] + real(kind_lake) :: obu(lbp:ubp) ! monin-obukhov length (m) + real(kind_lake) :: obuold(lbp:ubp) ! monin-obukhov length of previous iteration + real(kind_lake) :: qsatg(lbc:ubc) ! saturated humidity [kg/kg] + real(kind_lake) :: qsatgdT(lbc:ubc) ! d(qsatg)/dT + real(kind_lake) :: qstar ! moisture scaling parameter + real(kind_lake) :: ram(lbp:ubp) ! aerodynamical resistance [s/m] + real(kind_lake) :: rah(lbp:ubp) ! thermal resistance [s/m] + real(kind_lake) :: raw(lbp:ubp) ! moisture resistance [s/m] + real(kind_lake) :: stftg3(lbp:ubp) ! derivative of fluxes w.r.t ground temperature + real(kind_lake) :: temp1(lbp:ubp) ! relation for potential temperature profile + real(kind_lake) :: temp12m(lbp:ubp) ! relation for potential temperature profile applied at 2-m + real(kind_lake) :: temp2(lbp:ubp) ! relation for specific humidity profile + real(kind_lake) :: temp22m(lbp:ubp) ! relation for specific humidity profile applied at 2-m + real(kind_lake) :: tgbef(lbc:ubc) ! initial ground temperature + real(kind_lake) :: thm(lbc:ubc) ! intermediate variable (forc_t+0.0098*forc_hgt_t) + real(kind_lake) :: thv(lbc:ubc) ! virtual potential temperature (kelvin) + real(kind_lake) :: thvstar ! virtual potential temperature scaling parameter + real(kind_lake) :: tksur ! thermal conductivity of snow/soil (w/m/kelvin) + real(kind_lake) :: tsur ! top layer temperature + real(kind_lake) :: tstar ! temperature scaling parameter + real(kind_lake) :: um(lbp:ubp) ! wind speed including the stablity effect [m/s] + real(kind_lake) :: ur(lbp:ubp) ! wind speed at reference height [m/s] + real(kind_lake) :: ustar(lbp:ubp) ! friction velocity [m/s] + real(kind_lake) :: wc ! convective velocity [m/s] + real(kind_lake) :: zeta ! dimensionless height used in Monin-Obukhov theory + real(kind_lake) :: zldis(lbp:ubp) ! reference height "minus" zero displacement height [m] + real(kind_lake) :: displa(lbp:ubp) ! displacement (always zero) [m] + ! real(kind_lake) :: z0mg(lbp:ubp) ! roughness length over ground, momentum [m] + real(kind_lake) :: z0hg(lbp:ubp) ! roughness length over ground, sensible heat [m] + real(kind_lake) :: z0qg(lbp:ubp) ! roughness length over ground, latent heat [m] + real(kind_lake) :: u2m ! 2 m wind speed (m/s) + real(kind_lake) :: u10(1) ! 10-m wind (m/s) (for dust model) + real(kind_lake) :: fv(1) ! friction velocity (m/s) (for dust model) + + real(kind_lake) :: fm(lbp:ubp) ! needed for BGC only to diagnose 10m wind speed + real(kind_lake) :: bw ! partial density of water (ice + liquid) + real(kind_lake) :: t_grnd_temp ! Used in surface flux correction over frozen ground + real(kind_lake) :: betaprime(lbc:ubc) ! Effective beta: 1 for snow layers, beta(islak) otherwise character*256 :: message ! tgs COARE - real(kind_phys) :: tc, visc, ren + real(kind_lake) :: tc, visc, ren ! This assumes all radiation is absorbed in the top snow layer and will need ! to be changed for CLM 4. ! ! Constants for lake temperature model ! - real(kind_phys), parameter :: beta(2) = & ! fraction solar rad absorbed at surface: depends on lake type - (/0.4_kind_phys, 0.4_kind_phys/) ! (deep lake, shallow lake) + real(kind_lake), parameter :: beta(2) = & ! fraction solar rad absorbed at surface: depends on lake type + (/0.4_kind_lake, 0.4_kind_lake/) ! (deep lake, shallow lake) ! This is the energy absorbed at the lake surface if no snow. - ! data za /0.6_kind_phys, 0.5_kind_phys/ - ! data eta /0.1_kind_phys, 0.5_kind_phys/ + ! data za /0.6_kind_lake, 0.5_kind_lake/ + ! data eta /0.1_kind_lake, 0.5_kind_lake/ !----------------------------------------------------------------------- unhappy=.false. @@ -1383,11 +1389,11 @@ SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, if (snl(c) < 0) then - betaprime(c) = 1._kind_phys !Assume all solar rad. absorbed at the surface of the top snow layer. - dzsur(c) = dz(c,jtop(c))*0.5_kind_phys + betaprime(c) = 1._kind_lake !Assume all solar rad. absorbed at the surface of the top snow layer. + dzsur(c) = dz(c,jtop(c))*0.5_kind_lake else betaprime(c) = beta(islak) - dzsur(c) = dz_lake(c,1)*0.5_kind_phys + dzsur(c) = dz_lake(c,1)*0.5_kind_lake end if ! Originally this was 1*dz, but shouldn't it be 1/2? @@ -1399,8 +1405,8 @@ SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, ! Potential, virtual potential temperature, and wind speed at the ! reference height - thm(c) = forc_t(g) + 0.0098_kind_phys*forc_hgt_t(g) ! intermediate variable - thv(c) = forc_th(g)*(1._kind_phys+0.61_kind_phys*forc_q(g)) ! virtual potential T + thm(c) = forc_t(g) + 0.0098_kind_lake*forc_hgt_t(g) ! intermediate variable + thv(c) = forc_th(g)*(1._kind_lake+0.61_kind_lake*forc_q(g)) ! virtual potential T end do !dir$ concurrent @@ -1411,49 +1417,53 @@ SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, g = pgridcell(p) nmozsgn(p) = 0 - obuold(p) = 0._kind_phys - displa(p) = 0._kind_phys + obuold(p) = 0._kind_lake + displa(p) = 0._kind_lake ! Roughness lengths ! changed by Hongping Gu ! if (t_grnd(c) >= tfrz) then ! for unfrozen lake - ! z0mg(p) = 0.01_kind_phys + ! z0mg(p) = 0.01_kind_lake ! else ! for frozen lake ! ! Is this okay even if it is snow covered? What is the roughness over ! non-veg. snow? - ! z0mg(p) = 0.04_kind_phys + ! z0mg(p) = 0.04_kind_lake ! end if if (t_grnd(c) >= tfrz) then ! for unfrozen lake - z0mg(p) = 0.001_kind_phys !original 0.01 + z0mg(p) = 0.001_kind_lake !original 0.01 else if(snl(c) == 0 ) then ! for frozen lake ! Is this okay even if it is snow covered? What is the roughness over ! non-veg. snow? - z0mg(p) = 0.005_kind_phys !original 0.04, now for frozen lake without snow + z0mg(p) = 0.005_kind_lake !original 0.04, now for frozen lake without snow else ! for frozen lake with snow - z0mg(p) = 0.0024_kind_phys + z0mg(p) = 0.0024_kind_lake end if + if(.false.) then + ! This can't work since it uses ustar before ustar is initialized !- tgs - use COARE formulation for z0hg and z0qg. !-- suggestion from Ayumi Manome (GLERL), Aug. 2018 !-- Charusombat et al., 2018, https://doi.org/10.5194/hess-2017-725 - tc=forc_t(g)-273.15_kind_phys - visc=1.326e-5_kind_phys*(1._kind_phys + 6.542e-3_kind_phys*tc + 8.301e-6_kind_phys*tc*tc & - - 4.84e-9_kind_phys*tc*tc*tc) - - Ren = MAX(ustar(p)*z0mg(p)/visc, 0.1_kind_phys) - z0hg(p) = (5.5e-5_kind_phys)*(Ren**(-0.60_kind_phys)) + tc=forc_t(g)-273.15_kind_lake + visc=1.326e-5_kind_lake*(1._kind_lake + 6.542e-3_kind_lake*tc + 8.301e-6_kind_lake*tc*tc & + - 4.84e-9_kind_lake*tc*tc*tc) + visc=max(1e-7_kind_lake, visc) - z0hg(p) = MIN(z0hg(p),1.0e-4_kind_phys) - z0hg(p) = MAX(z0hg(p),2.0e-9_kind_phys) + Ren = MAX(ustar(p)*z0mg(p)/visc, 0.1_kind_lake) + z0hg(p) = (5.5e-5_kind_lake)*(Ren**(-0.60_kind_lake)) + + z0hg(p) = MIN(z0hg(p),1.0e-4_kind_lake) + z0hg(p) = MAX(z0hg(p),2.0e-9_kind_lake) z0qg(p) = z0hg(p) ! end COARE - !z0hg(p) = z0mg(p) - !z0qg(p) = z0mg(p) + endif + z0hg(p) = z0mg(p) + z0qg(p) = z0mg(p) ! Latent heat @@ -1472,11 +1482,11 @@ SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, ! Initialize stability variables - ur(p) = max(1.0_kind_phys,sqrt(forc_u(g)*forc_u(g)+forc_v(g)*forc_v(g))) + ur(p) = max(1.0_kind_lake,sqrt(forc_u(g)*forc_u(g)+forc_v(g)*forc_v(g))) dth(p) = thm(c)-t_grnd(c) dqh(p) = forc_q(g)-qsatg(c) - dthv = dth(p)*(1._kind_phys+0.61_kind_phys*forc_q(g))+0.61_kind_phys*forc_th(g)*dqh(p) - zldis(p) = forc_hgt_u(g) - 0._kind_phys + dthv = dth(p)*(1._kind_lake+0.61_kind_lake*forc_q(g))+0.61_kind_lake*forc_th(g)*dqh(p) + zldis(p) = forc_hgt_u(g) - 0._kind_lake ! Initialize Monin-Obukhov length and wind speed @@ -1524,15 +1534,15 @@ SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, else !Need to calculate thermal conductivity of the top snow layer bw = (h2osoi_ice(c,jtop(c))+h2osoi_liq(c,jtop(c)))/dz(c,jtop(c)) - tksur = tkairc + (7.75e-5_kind_phys *bw + 1.105e-6_kind_phys*bw*bw)*(tkice-tkairc) + tksur = tkairc + (7.75e-5_kind_lake *bw + 1.105e-6_kind_lake*bw*bw)*(tkice-tkairc) tsur = t_soisno(c,jtop(c)) end if ! Determine aerodynamic resistances - ram(p) = 1._kind_phys/(ustar(p)*ustar(p)/um(p)) - rah(p) = 1._kind_phys/(temp1(p)*ustar(p)) - raw(p) = 1._kind_phys/(temp2(p)*ustar(p)) + ram(p) = 1._kind_lake/(ustar(p)*ustar(p)/um(p)) + rah(p) = 1._kind_lake/(temp1(p)*ustar(p)) + raw(p) = 1._kind_lake/(temp2(p)*ustar(p)) ram1(p) = ram(p) !pass value to global variable ! Get derivative of fluxes with respect to ground temperature @@ -1541,12 +1551,12 @@ SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, ! Changed surface temperature from t_lake(c,1) to tsur. ! Also adjusted so that if there are snow layers present, all radiation is absorbed in the top layer. - ax = betaprime(c)*sabg(p) + emg*forc_lwrad(g) + 3._kind_phys*stftg3(p)*tgbef(c) & + ax = betaprime(c)*sabg(p) + emg*forc_lwrad(g) + 3._kind_lake*stftg3(p)*tgbef(c) & + forc_rho(g)*cpair/rah(p)*thm(c) & - htvp(c)*forc_rho(g)/raw(p)*(qsatg(c)-qsatgdT(c)*tgbef(c) - forc_q(g)) & + tksur*tsur/dzsur(c) !Changed sabg(p) and to betaprime(c)*sabg(p). - bx = 4._kind_phys*stftg3(p) + forc_rho(g)*cpair/rah(p) & + bx = 4._kind_lake*stftg3(p) + forc_rho(g)*cpair/rah(p) & + htvp(c)*forc_rho(g)/raw(p)*qsatgdT(c) + tksur/dzsur(c) t_grnd(c) = ax/bx @@ -1577,20 +1587,20 @@ SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, tstar = temp1(p)*dth(p) qstar = temp2(p)*dqh(p) - thvstar=tstar*(1._kind_phys+0.61_kind_phys*forc_q(g)) + 0.61_kind_phys*forc_th(g)*qstar + thvstar=tstar*(1._kind_lake+0.61_kind_lake*forc_q(g)) + 0.61_kind_lake*forc_th(g)*qstar zeta=zldis(p)*vkc * grav*thvstar/(ustar(p)**2*thv(c)) - if (zeta >= 0._kind_phys) then !stable - zeta = min(2._kind_phys,max(zeta,0.01_kind_phys)) - um(p) = max(ur(p),0.1_kind_phys) + if (zeta >= 0._kind_lake) then !stable + zeta = min(2._kind_lake,max(zeta,0.01_kind_lake)) + um(p) = max(ur(p),0.1_kind_lake) else !unstable - zeta = max(-100._kind_phys,min(zeta,-0.01_kind_phys)) - wc = beta1*(-grav*ustar(p)*thvstar*zii/thv(c))**0.333_kind_phys + zeta = max(-100._kind_lake,min(zeta,-0.01_kind_lake)) + wc = beta1*(-grav*ustar(p)*thvstar*zii/thv(c))**0.333_kind_lake um(p) = sqrt(ur(p)*ur(p)+wc*wc) end if obu(p) = zldis(p)/zeta - if (obuold(p)*obu(p) < 0._kind_phys) nmozsgn(p) = nmozsgn(p)+1 + if (obuold(p)*obu(p) < 0._kind_lake) nmozsgn(p) = nmozsgn(p)+1 obuold(p) = obu(p) @@ -1630,7 +1640,7 @@ SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, ! Should this happen if the lake temperature is below freezing, too? I'll assume that for now. ! Also, allow convection if ground temp is colder than lake but warmer than 4C, or warmer than ! lake which is warmer than freezing but less than 4C. - if ( (h2osno(c) > 0.5_kind_phys .or. t_lake(c,1) <= tfrz) .and. t_grnd(c) > tfrz) then + if ( (h2osno(c) > 0.5_kind_lake .or. t_lake(c,1) <= tfrz) .and. t_grnd(c) > tfrz) then t_grnd_temp = t_grnd(c) t_grnd(c) = tfrz eflx_sh_grnd(p) = forc_rho(g)*cpair*(t_grnd(c)-thm(c))/rah(p) @@ -1655,9 +1665,9 @@ SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, ! Net longwave from ground to atmosphere - ! eflx_lwrad_out(p) = (1._kind_phys-emg)*forc_lwrad(g) + stftg3(p)*(-3._kind_phys*tgbef(c)+4._kind_phys*t_grnd(c)) + ! eflx_lwrad_out(p) = (1._kind_lake-emg)*forc_lwrad(g) + stftg3(p)*(-3._kind_lake*tgbef(c)+4._kind_lake*t_grnd(c)) ! What is tgbef doing in this equation? Can't it be exact now? --Zack Subin, 4/14/09 - eflx_lwrad_out(p) = (1._kind_phys-emg)*forc_lwrad(g) + emg*sb*t_grnd(c)**4 + eflx_lwrad_out(p) = (1._kind_lake-emg)*forc_lwrad(g) + emg*sb*t_grnd(c)**4 ! Ground heat flux @@ -1696,10 +1706,10 @@ SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, endif endif ! 2 m height air temperature - t_ref2m(p) = thm(c) + temp1(p)*dth(p)*(1._kind_phys/temp12m(p) - 1._kind_phys/temp1(p)) + t_ref2m(p) = thm(c) + temp1(p)*dth(p)*(1._kind_lake/temp12m(p) - 1._kind_lake/temp1(p)) ! 2 m height specific humidity - q_ref2m(p) = forc_q(g) + temp2(p)*dqh(p)*(1._kind_phys/temp22m(p) - 1._kind_phys/temp2(p)) + q_ref2m(p) = forc_q(g) + temp2(p)*dqh(p)*(1._kind_lake/temp22m(p) - 1._kind_lake/temp2(p)) ! Energy residual used for melting snow ! Effectively moved to ShalLakeTemp @@ -1714,14 +1724,14 @@ SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, ! This is the actual heat flux from the ground interface into the lake, not including ! the light that penetrates the surface. - ! u2m = max(1.0_kind_phys,ustar(p)/vkc*log(2._kind_phys/z0mg(p))) + ! u2m = max(1.0_kind_lake,ustar(p)/vkc*log(2._kind_lake/z0mg(p))) ! u2 often goes below 1 m/s; it seems like the only reason for this minimum is to ! keep it from being zero in the ks equation below; 0.1 m/s is a better limit for ! stable conditions --ZS - u2m = max(0.1_kind_phys,ustar(p)/vkc*log(2._kind_phys/z0mg(p))) + u2m = max(0.1_kind_lake,ustar(p)/vkc*log(2._kind_lake/z0mg(p))) - ws(c) = 1.2e-03_kind_phys * u2m - ks(c) = 6.6_kind_phys*sqrt(abs(sin(lat(g))))*(u2m**(-1.84_kind_phys)) + ws(c) = 1.2e-03_kind_lake * u2m + ks(c) = 6.6_kind_lake*sqrt(abs(sin(lat(g))))*(u2m**(-1.84_kind_lake)) end do @@ -1845,126 +1855,126 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! !in: integer, intent(inout) :: errflg - real(kind_phys), intent(in) :: watsat(1,nlevsoil) ! volumetric soil water at saturation (porosity) - real(kind_phys), intent(in) :: tksatu(1,nlevsoil) ! thermal conductivity, saturated soil [W/m-K] - real(kind_phys), intent(in) :: tkmg(1,nlevsoil) ! thermal conductivity, soil minerals [W/m-K] - real(kind_phys), intent(in) :: tkdry(1,nlevsoil) ! thermal conductivity, dry soil (W/m/Kelvin) - real(kind_phys), intent(in) :: csol(1,nlevsoil) ! heat capacity, soil solids (J/m**3/Kelvin) + real(kind_lake), intent(in) :: watsat(1,nlevsoil) ! volumetric soil water at saturation (porosity) + real(kind_lake), intent(in) :: tksatu(1,nlevsoil) ! thermal conductivity, saturated soil [W/m-K] + real(kind_lake), intent(in) :: tkmg(1,nlevsoil) ! thermal conductivity, soil minerals [W/m-K] + real(kind_lake), intent(in) :: tkdry(1,nlevsoil) ! thermal conductivity, dry soil (W/m/Kelvin) + real(kind_lake), intent(in) :: csol(1,nlevsoil) ! heat capacity, soil solids (J/m**3/Kelvin) character(*), intent(inout) :: errmsg - real(kind_phys), intent(in) :: t_grnd(1) ! ground temperature (Kelvin) - real(kind_phys), intent(inout) :: h2osno(1) ! snow water (mm H2O) - real(kind_phys), intent(in) :: sabg(1) ! solar radiation absorbed by ground (W/m**2) - real(kind_phys), intent(in) :: dz(1,-nlevsnow + 1:nlevsoil) ! layer thickness for snow & soil (m) - real(kind_phys), intent(in) :: dz_lake(1,nlevlake) ! layer thickness for lake (m) - real(kind_phys), intent(in) :: z(1,-nlevsnow+1:nlevsoil) ! layer depth for snow & soil (m) - real(kind_phys), intent(in) :: zi(1,-nlevsnow+0:nlevsoil) ! interface level below a "z" level (m) + real(kind_lake), intent(in) :: t_grnd(1) ! ground temperature (Kelvin) + real(kind_lake), intent(inout) :: h2osno(1) ! snow water (mm H2O) + real(kind_lake), intent(in) :: sabg(1) ! solar radiation absorbed by ground (W/m**2) + real(kind_lake), intent(in) :: dz(1,-nlevsnow + 1:nlevsoil) ! layer thickness for snow & soil (m) + real(kind_lake), intent(in) :: dz_lake(1,nlevlake) ! layer thickness for lake (m) + real(kind_lake), intent(in) :: z(1,-nlevsnow+1:nlevsoil) ! layer depth for snow & soil (m) + real(kind_lake), intent(in) :: zi(1,-nlevsnow+0:nlevsoil) ! interface level below a "z" level (m) ! the other z and dz variables - real(kind_phys), intent(in) :: z_lake(1,nlevlake) ! layer depth for lake (m) - real(kind_phys), intent(in) :: ws(1) ! surface friction velocity (m/s) - real(kind_phys), intent(in) :: ks(1) ! coefficient passed to ShalLakeTemperature + real(kind_lake), intent(in) :: z_lake(1,nlevlake) ! layer depth for lake (m) + real(kind_lake), intent(in) :: ws(1) ! surface friction velocity (m/s) + real(kind_lake), intent(in) :: ks(1) ! coefficient passed to ShalLakeTemperature ! for calculation of decay of eddy diffusivity with depth integer , intent(in) :: snl(1) ! negative of number of snow layers - real(kind_phys), intent(inout) :: eflx_gnet(1) ! net heat flux into ground (W/m**2) at the surface interface - real(kind_phys), intent(in) :: lakedepth(1) ! column lake depth (m) + real(kind_lake), intent(inout) :: eflx_gnet(1) ! net heat flux into ground (W/m**2) at the surface interface + real(kind_lake), intent(in) :: lakedepth(1) ! column lake depth (m) - ! real(kind_phys), intent(in) :: watsat(1,nlevsoil) ! volumetric soil water at saturation (porosity) - real(kind_phys), intent(inout) :: snowdp(1) !snow height (m) - real(kind_phys), intent(in) :: dtime !timestep + ! real(kind_lake), intent(in) :: watsat(1,nlevsoil) ! volumetric soil water at saturation (porosity) + real(kind_lake), intent(inout) :: snowdp(1) !snow height (m) + real(kind_lake), intent(in) :: dtime !timestep !out: - real(kind_phys), intent(out) :: eflx_sh_grnd(1) ! sensible heat flux from ground (W/m**2) [+ to atm] - real(kind_phys), intent(out) :: eflx_sh_tot(1) ! total sensible heat flux (W/m**2) [+ to atm] - real(kind_phys), intent(out) :: eflx_soil_grnd(1) ! heat flux into snow / lake (W/m**2) [+ = into soil] + real(kind_lake), intent(out) :: eflx_sh_grnd(1) ! sensible heat flux from ground (W/m**2) [+ to atm] + real(kind_lake), intent(out) :: eflx_sh_tot(1) ! total sensible heat flux (W/m**2) [+ to atm] + real(kind_lake), intent(out) :: eflx_soil_grnd(1) ! heat flux into snow / lake (W/m**2) [+ = into soil] ! Here this includes the whole lake radiation absorbed. - !real(kind_phys), intent(out) :: qmelt(1) ! snow melt [mm/s] [temporary] - - real(kind_phys), intent(inout) :: t_lake(1,nlevlake) ! lake temperature (Kelvin) - real(kind_phys), intent(inout) :: t_soisno(1,-nlevsnow+1:nlevsoil) ! soil (or snow) temperature (Kelvin) - real(kind_phys), intent(inout) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) ! liquid water (kg/m2) [for snow & soil layers] - real(kind_phys), intent(inout) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) ! ice lens (kg/m2) [for snow & soil layers] - real(kind_phys), intent(inout) :: lake_icefrac(1,nlevlake) ! mass fraction of lake layer that is frozen - real(kind_phys), intent(out) :: savedtke1(1) ! top level thermal conductivity (W/mK) - real(kind_phys), intent(out) :: frac_iceold(1,-nlevsnow+1:nlevsoil) ! fraction of ice relative to the tot water - real(kind_phys), intent(out) :: qflx_snomelt(1) !snow melt (mm H2O /s) + !real(kind_lake), intent(out) :: qmelt(1) ! snow melt [mm/s] [temporary] + + real(kind_lake), intent(inout) :: t_lake(1,nlevlake) ! lake temperature (Kelvin) + real(kind_lake), intent(inout) :: t_soisno(1,-nlevsnow+1:nlevsoil) ! soil (or snow) temperature (Kelvin) + real(kind_lake), intent(inout) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) ! liquid water (kg/m2) [for snow & soil layers] + real(kind_lake), intent(inout) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) ! ice lens (kg/m2) [for snow & soil layers] + real(kind_lake), intent(inout) :: lake_icefrac(1,nlevlake) ! mass fraction of lake layer that is frozen + real(kind_lake), intent(out) :: savedtke1(1) ! top level thermal conductivity (W/mK) + real(kind_lake), intent(out) :: frac_iceold(1,-nlevsnow+1:nlevsoil) ! fraction of ice relative to the tot water + real(kind_lake), intent(out) :: qflx_snomelt(1) !snow melt (mm H2O /s) integer, intent(out) :: imelt(1,-nlevsnow+1:nlevsoil) !flag for melting (=1), freezing (=2), Not=0 (new) ! OTHER LOCAL VARIABLES: integer , parameter :: islak = 2 ! index of lake, 1 = deep lake, 2 = shallow lake - real(kind_phys), parameter :: p0 = 1._kind_phys ! neutral value of turbulent prandtl number + real(kind_lake), parameter :: p0 = 1._kind_lake ! neutral value of turbulent prandtl number integer :: i,j,fc,fp,g,c,p ! do loop or array index - real(kind_phys) :: eta(2) ! light extinction coefficient (/m): depends on lake type - real(kind_phys) :: cwat ! specific heat capacity of water (j/m**3/kelvin) - real(kind_phys) :: cice_eff ! effective heat capacity of ice (using density of + real(kind_lake) :: eta(2) ! light extinction coefficient (/m): depends on lake type + real(kind_lake) :: cwat ! specific heat capacity of water (j/m**3/kelvin) + real(kind_lake) :: cice_eff ! effective heat capacity of ice (using density of ! water because layer depth is not adjusted when freezing - real(kind_phys) :: cfus ! effective heat of fusion per unit volume + real(kind_lake) :: cfus ! effective heat of fusion per unit volume ! using water density as above - real(kind_phys) :: km ! molecular diffusion coefficient (m**2/s) - real(kind_phys) :: tkice_eff ! effective conductivity since layer depth is constant - real(kind_phys) :: a(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) ! "a" vector for tridiagonal matrix - real(kind_phys) :: b(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) ! "b" vector for tridiagonal matrix - real(kind_phys) :: c1(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) ! "c" vector for tridiagonal matrix - real(kind_phys) :: r(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) ! "r" vector for tridiagonal solution - real(kind_phys) :: rhow(lbc:ubc,nlevlake) ! density of water (kg/m**3) - real(kind_phys) :: phi(lbc:ubc,nlevlake) ! solar radiation absorbed by layer (w/m**2) - real(kind_phys) :: kme(lbc:ubc,nlevlake) ! molecular + eddy diffusion coefficient (m**2/s) - real(kind_phys) :: rsfin ! relative flux of solar radiation into layer - real(kind_phys) :: rsfout ! relative flux of solar radiation out of layer - real(kind_phys) :: phi_soil(lbc:ubc) ! solar radiation into top soil layer (W/m**2) - real(kind_phys) :: ri ! richardson number - real(kind_phys) :: fin(lbc:ubc) ! net heat flux into lake at ground interface (w/m**2) - real(kind_phys) :: ocvts(lbc:ubc) ! (cwat*(t_lake[n ])*dz - real(kind_phys) :: ncvts(lbc:ubc) ! (cwat*(t_lake[n+1])*dz - real(kind_phys) :: ke ! eddy diffusion coefficient (m**2/s) - real(kind_phys) :: zin ! depth at top of layer (m) - real(kind_phys) :: zout ! depth at bottom of layer (m) - real(kind_phys) :: drhodz ! d [rhow] /dz (kg/m**4) - real(kind_phys) :: n2 ! brunt-vaisala frequency (/s**2) - real(kind_phys) :: num ! used in calculating ri - real(kind_phys) :: den ! used in calculating ri - real(kind_phys) :: tav_froz(lbc:ubc) ! used in aver temp for convectively mixed layers (C) - real(kind_phys) :: tav_unfr(lbc:ubc) ! " - real(kind_phys) :: nav(lbc:ubc) ! used in aver temp for convectively mixed layers - real(kind_phys) :: phidum ! temporary value of phi - real(kind_phys) :: iceav(lbc:ubc) ! used in calc aver ice for convectively mixed layers - real(kind_phys) :: qav(lbc:ubc) ! used in calc aver heat content for conv. mixed layers + real(kind_lake) :: km ! molecular diffusion coefficient (m**2/s) + real(kind_lake) :: tkice_eff ! effective conductivity since layer depth is constant + real(kind_lake) :: a(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) ! "a" vector for tridiagonal matrix + real(kind_lake) :: b(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) ! "b" vector for tridiagonal matrix + real(kind_lake) :: c1(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) ! "c" vector for tridiagonal matrix + real(kind_lake) :: r(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) ! "r" vector for tridiagonal solution + real(kind_lake) :: rhow(lbc:ubc,nlevlake) ! density of water (kg/m**3) + real(kind_lake) :: phi(lbc:ubc,nlevlake) ! solar radiation absorbed by layer (w/m**2) + real(kind_lake) :: kme(lbc:ubc,nlevlake) ! molecular + eddy diffusion coefficient (m**2/s) + real(kind_lake) :: rsfin ! relative flux of solar radiation into layer + real(kind_lake) :: rsfout ! relative flux of solar radiation out of layer + real(kind_lake) :: phi_soil(lbc:ubc) ! solar radiation into top soil layer (W/m**2) + real(kind_lake) :: ri ! richardson number + real(kind_lake) :: fin(lbc:ubc) ! net heat flux into lake at ground interface (w/m**2) + real(kind_lake) :: ocvts(lbc:ubc) ! (cwat*(t_lake[n ])*dz + real(kind_lake) :: ncvts(lbc:ubc) ! (cwat*(t_lake[n+1])*dz + real(kind_lake) :: ke ! eddy diffusion coefficient (m**2/s) + real(kind_lake) :: zin ! depth at top of layer (m) + real(kind_lake) :: zout ! depth at bottom of layer (m) + real(kind_lake) :: drhodz ! d [rhow] /dz (kg/m**4) + real(kind_lake) :: n2 ! brunt-vaisala frequency (/s**2) + real(kind_lake) :: num ! used in calculating ri + real(kind_lake) :: den ! used in calculating ri + real(kind_lake) :: tav_froz(lbc:ubc) ! used in aver temp for convectively mixed layers (C) + real(kind_lake) :: tav_unfr(lbc:ubc) ! " + real(kind_lake) :: nav(lbc:ubc) ! used in aver temp for convectively mixed layers + real(kind_lake) :: phidum ! temporary value of phi + real(kind_lake) :: iceav(lbc:ubc) ! used in calc aver ice for convectively mixed layers + real(kind_lake) :: qav(lbc:ubc) ! used in calc aver heat content for conv. mixed layers integer :: jtop(lbc:ubc) ! top level for each column (no longer all 1) - real(kind_phys) :: cv (lbc:ubc,-nlevsnow+1:nlevsoil) !heat capacity of soil/snow [J/(m2 K)] - real(kind_phys) :: tk (lbc:ubc,-nlevsnow+1:nlevsoil) !thermal conductivity of soil/snow [W/(m K)] + real(kind_lake) :: cv (lbc:ubc,-nlevsnow+1:nlevsoil) !heat capacity of soil/snow [J/(m2 K)] + real(kind_lake) :: tk (lbc:ubc,-nlevsnow+1:nlevsoil) !thermal conductivity of soil/snow [W/(m K)] !(at interface below, except for j=0) - real(kind_phys) :: cv_lake (lbc:ubc,1:nlevlake) !heat capacity [J/(m2 K)] - real(kind_phys) :: tk_lake (lbc:ubc,1:nlevlake) !thermal conductivity at layer node [W/(m K)] - real(kind_phys) :: cvx (lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) !heat capacity for whole column [J/(m2 K)] - real(kind_phys) :: tkix(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) !thermal conductivity at layer interfaces + real(kind_lake) :: cv_lake (lbc:ubc,1:nlevlake) !heat capacity [J/(m2 K)] + real(kind_lake) :: tk_lake (lbc:ubc,1:nlevlake) !thermal conductivity at layer node [W/(m K)] + real(kind_lake) :: cvx (lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) !heat capacity for whole column [J/(m2 K)] + real(kind_lake) :: tkix(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) !thermal conductivity at layer interfaces !for whole column [W/(m K)] - real(kind_phys) :: tx(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) ! temperature of whole column [K] - real(kind_phys) :: tktopsoillay(lbc:ubc) ! thermal conductivity [W/(m K)] - real(kind_phys) :: fnx(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) !heat diffusion through the layer interface below [W/m2] - real(kind_phys) :: phix(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) !solar source term for whole column [W/m**2] - real(kind_phys) :: zx(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) !interface depth (+ below surface) for whole column [m] - real(kind_phys) :: dzm !used in computing tridiagonal matrix [m] - real(kind_phys) :: dzp !used in computing tridiagonal matrix [m] + real(kind_lake) :: tx(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) ! temperature of whole column [K] + real(kind_lake) :: tktopsoillay(lbc:ubc) ! thermal conductivity [W/(m K)] + real(kind_lake) :: fnx(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) !heat diffusion through the layer interface below [W/m2] + real(kind_lake) :: phix(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) !solar source term for whole column [W/m**2] + real(kind_lake) :: zx(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) !interface depth (+ below surface) for whole column [m] + real(kind_lake) :: dzm !used in computing tridiagonal matrix [m] + real(kind_lake) :: dzp !used in computing tridiagonal matrix [m] integer :: jprime ! j - nlevlake - real(kind_phys) :: factx(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) !coefficient used in computing tridiagonal matrix - real(kind_phys) :: t_lake_bef(lbc:ubc,1:nlevlake) !beginning lake temp for energy conservation check [K] - real(kind_phys) :: t_soisno_bef(lbc:ubc,-nlevsnow+1:nlevsoil) !beginning soil temp for E cons. check [K] - real(kind_phys) :: lhabs(lbc:ubc) ! total per-column latent heat abs. from phase change (J/m^2) - real(kind_phys) :: esum1(lbc:ubc) ! temp for checking energy (J/m^2) - real(kind_phys) :: esum2(lbc:ubc) ! "" - real(kind_phys) :: zsum(lbc:ubc) ! temp for putting ice at the top during convection (m) - real(kind_phys) :: wsum(lbc:ubc) ! temp for checking water (kg/m^2) - real(kind_phys) :: wsum_end(lbc:ubc) ! temp for checking water (kg/m^2) - real(kind_phys) :: errsoi(1) ! soil/lake energy conservation error (W/m**2) - real(kind_phys) :: eflx_snomelt(1) !snow melt heat flux (W/m**2) + real(kind_lake) :: factx(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) !coefficient used in computing tridiagonal matrix + real(kind_lake) :: t_lake_bef(lbc:ubc,1:nlevlake) !beginning lake temp for energy conservation check [K] + real(kind_lake) :: t_soisno_bef(lbc:ubc,-nlevsnow+1:nlevsoil) !beginning soil temp for E cons. check [K] + real(kind_lake) :: lhabs(lbc:ubc) ! total per-column latent heat abs. from phase change (J/m^2) + real(kind_lake) :: esum1(lbc:ubc) ! temp for checking energy (J/m^2) + real(kind_lake) :: esum2(lbc:ubc) ! "" + real(kind_lake) :: zsum(lbc:ubc) ! temp for putting ice at the top during convection (m) + real(kind_lake) :: wsum(lbc:ubc) ! temp for checking water (kg/m^2) + real(kind_lake) :: wsum_end(lbc:ubc) ! temp for checking water (kg/m^2) + real(kind_lake) :: errsoi(1) ! soil/lake energy conservation error (W/m**2) + real(kind_lake) :: eflx_snomelt(1) !snow melt heat flux (W/m**2) CHARACTER*256 :: message ! ! Constants for lake temperature model ! - real(kind_phys), parameter :: beta(2) = & ! fraction solar rad absorbed at surface: depends on lake type - (/0.4_kind_phys, 0.4_kind_phys/) ! (deep lake, shallow lake) - real(kind_phys), parameter :: za(2) = & ! base of surface absorption layer (m): depends on lake type - (/0.6_kind_phys, 0.6_kind_phys/) + real(kind_lake), parameter :: beta(2) = & ! fraction solar rad absorbed at surface: depends on lake type + (/0.4_kind_lake, 0.4_kind_lake/) ! (deep lake, shallow lake) + real(kind_lake), parameter :: za(2) = & ! base of surface absorption layer (m): depends on lake type + (/0.6_kind_lake, 0.6_kind_lake/) ! For now, keep beta and za for shallow lake the same as deep lake, until better data is found. ! It looks like eta is key and that larger values give better results for shallow lakes. Use ! empirical expression from Hakanson (below). This is still a very unconstrained parameter @@ -1993,10 +2003,10 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! ! Initialize Ebal quantities computed below - ocvts(c) = 0._kind_phys - ncvts(c) = 0._kind_phys - esum1(c) = 0._kind_phys - esum2(c) = 0._kind_phys + ocvts(c) = 0._kind_lake + ncvts(c) = 0._kind_lake + esum1(c) = 0._kind_lake + esum2(c) = 0._kind_lake end do @@ -2022,7 +2032,7 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! !cdir nodep do fc = 1, num_shlakec c = filter_shlakec(fc) - if (j == 1) wsum(c) = 0._kind_phys + if (j == 1) wsum(c) = 0._kind_lake wsum(c) = wsum(c) + h2osoi_ice(c,j) + h2osoi_liq(c,j) end do end do @@ -2050,8 +2060,8 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! !cdir nodep do fc = 1, num_shlakec c = filter_shlakec(fc) - rhow(c,j) = (1._kind_phys - lake_icefrac(c,j)) * & - 1000._kind_phys*( 1.0_kind_phys - 1.9549e-05_kind_phys*(abs(t_lake(c,j)-277._kind_phys))**1.68_kind_phys ) & + rhow(c,j) = (1._kind_lake - lake_icefrac(c,j)) * & + 1000._kind_lake*( 1.0_kind_lake - 1.9549e-05_kind_lake*(abs(t_lake(c,j)-277._kind_lake))**1.68_kind_lake ) & + lake_icefrac(c,j)*denice ! Allow for ice fraction; assume constant ice density. ! Is this the right weighted average? @@ -2071,27 +2081,27 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! n2 = grav / rhow(c,j) * drhodz ! Fixed sign error here: our z goes up going down into the lake, so no negative ! sign is needed to make this positive unlike in Hostetler. --ZS - num = 40._kind_phys * n2 * (vkc*z_lake(c,j))**2 - den = max( (ws(c)**2) * exp(-2._kind_phys*ks(c)*z_lake(c,j)), 1.e-10_kind_phys ) - ri = ( -1._kind_phys + sqrt( max(1._kind_phys+num/den, 0._kind_phys) ) ) / 20._kind_phys + num = 40._kind_lake * n2 * (vkc*z_lake(c,j))**2 + den = max( (ws(c)**2) * exp(-2._kind_lake*ks(c)*z_lake(c,j)), 1.e-10_kind_lake ) + ri = ( -1._kind_lake + sqrt( max(1._kind_lake+num/den, 0._kind_lake) ) ) / 20._kind_lake if (t_grnd(c) > tfrz .and. t_lake(c,1) > tfrz .and. snl(c) == 0) then - ! ke = vkc*ws(c)*z_lake(c,j)/p0 * exp(-ks(c)*z_lake(c,j)) / (1._kind_phys+37._kind_phys*ri*ri) + ! ke = vkc*ws(c)*z_lake(c,j)/p0 * exp(-ks(c)*z_lake(c,j)) / (1._kind_lake+37._kind_lake*ri*ri) - if( t_lake(c,1) > 277.15_kind_phys ) then + if( t_lake(c,1) > 277.15_kind_lake ) then if (lakedepth(c) > 15.0 ) then - ke = 1.e+2_kind_phys*vkc*ws(c)*z_lake(c,j)/p0 * exp(-ks(c)*z_lake(c,j)) / (1._kind_phys+37._kind_phys*ri*ri) + ke = 1.e+2_kind_lake*vkc*ws(c)*z_lake(c,j)/p0 * exp(-ks(c)*z_lake(c,j)) / (1._kind_lake+37._kind_lake*ri*ri) else - ke = vkc*ws(c)*z_lake(c,j)/p0 * exp(-ks(c)*z_lake(c,j)) / (1._kind_phys+37._kind_phys*ri*ri) + ke = vkc*ws(c)*z_lake(c,j)/p0 * exp(-ks(c)*z_lake(c,j)) / (1._kind_lake+37._kind_lake*ri*ri) endif else if (lakedepth(c) > 15.0 ) then if (lakedepth(c) > 150.0 ) then - ke = 1.e+5_kind_phys*vkc*ws(c)*z_lake(c,j)/p0 * exp(-ks(c)*z_lake(c,j)) / (1._kind_phys+37._kind_phys*ri*ri) + ke = 1.e+5_kind_lake*vkc*ws(c)*z_lake(c,j)/p0 * exp(-ks(c)*z_lake(c,j)) / (1._kind_lake+37._kind_lake*ri*ri) else - ke =1.e+4_kind_phys*vkc*ws(c)*z_lake(c,j)/p0 * exp(-ks(c)*z_lake(c,j)) / (1._kind_phys+37._kind_phys*ri*ri) + ke =1.e+4_kind_lake*vkc*ws(c)*z_lake(c,j)/p0 * exp(-ks(c)*z_lake(c,j)) / (1._kind_lake+37._kind_lake*ri*ri) end if else - ke = vkc*ws(c)*z_lake(c,j)/p0 * exp(-ks(c)*z_lake(c,j)) / (1._kind_phys+37._kind_phys*ri*ri) + ke = vkc*ws(c)*z_lake(c,j)/p0 * exp(-ks(c)*z_lake(c,j)) / (1._kind_lake+37._kind_lake*ri*ri) endif end if @@ -2102,7 +2112,7 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! ! diffusivity equation assumes water. else kme(c,j) = km - tk_lake(c,j) = tkwat*tkice_eff / ( (1._kind_phys-lake_icefrac(c,j))*tkice_eff & + tk_lake(c,j) = tkwat*tkice_eff / ( (1._kind_lake-lake_icefrac(c,j))*tkice_eff & + tkwat*lake_icefrac(c,j) ) ! Assume the resistances add as for the calculation of conductivities at layer interfaces. end if @@ -2120,7 +2130,7 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! if (t_grnd(c) > tfrz .and. t_lake(c,1) > tfrz .and. snl(c) == 0) then tk_lake(c,j) = tk_lake(c,j-1) else - tk_lake(c,j) = tkwat*tkice_eff / ( (1._kind_phys-lake_icefrac(c,j))*tkice_eff & + tk_lake(c,j) = tkwat*tkice_eff / ( (1._kind_lake-lake_icefrac(c,j))*tkice_eff & + tkwat*lake_icefrac(c,j) ) end if @@ -2142,29 +2152,29 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! ! (regression of Secchi Depth with lake depth for small glacial basin lakes), and the ! Poole & Atkins expression for extinction coeffient of 1.7 / Secchi Depth (m). if(.not.USE_ETALAKE) then - eta(:) = 1.1925_kind_phys*lakedepth(c)**(-0.424) + eta(:) = 1.1925_kind_lake*lakedepth(c)**(-0.424) else eta(:) = ETALAKE endif - zin = z_lake(c,j) - 0.5_kind_phys*dz_lake(c,j) - zout = z_lake(c,j) + 0.5_kind_phys*dz_lake(c,j) - rsfin = exp( -eta(islak)*max( zin-za(islak),0._kind_phys ) ) - rsfout = exp( -eta(islak)*max( zout-za(islak),0._kind_phys ) ) + zin = z_lake(c,j) - 0.5_kind_lake*dz_lake(c,j) + zout = z_lake(c,j) + 0.5_kind_lake*dz_lake(c,j) + rsfin = exp( -eta(islak)*max( zin-za(islak),0._kind_lake ) ) + rsfout = exp( -eta(islak)*max( zout-za(islak),0._kind_lake ) ) ! Let rsfout for bottom layer go into soil. ! This looks like it should be robust even for pathological cases, ! like lakes thinner than za. if (t_grnd(c) > tfrz .and. t_lake(c,1) > tfrz .and. snl(c) == 0) then - phidum = (rsfin-rsfout) * sabg(p) * (1._kind_phys-beta(islak)) + phidum = (rsfin-rsfout) * sabg(p) * (1._kind_lake-beta(islak)) if (j == nlevlake) then - phi_soil(c) = rsfout * sabg(p) * (1._kind_phys-beta(islak)) + phi_soil(c) = rsfout * sabg(p) * (1._kind_lake-beta(islak)) end if else if (j == 1 .and. snl(c) == 0) then !if frozen but no snow layers - phidum = sabg(p) * (1._kind_phys-beta(islak)) + phidum = sabg(p) * (1._kind_lake-beta(islak)) else !radiation absorbed at surface - phidum = 0._kind_phys - if (j == nlevlake) phi_soil(c) = 0._kind_phys + phidum = 0._kind_lake + if (j == nlevlake) phi_soil(c) = 0._kind_lake end if phi(c,j) = phidum @@ -2180,7 +2190,7 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! do fc = 1, num_shlakec c = filter_shlakec(fc) - cv_lake(c,j) = dz_lake(c,j) * (cwat*(1._kind_phys-lake_icefrac(c,j)) + cice_eff*lake_icefrac(c,j)) + cv_lake(c,j) = dz_lake(c,j) * (cwat*(1._kind_lake-lake_icefrac(c,j)) + cice_eff*lake_icefrac(c,j)) end do end do @@ -2204,7 +2214,7 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! ! ocvts(c) = ocvts(c) + cv_lake(c,j)*t_lake(c,j) & ocvts(c) = ocvts(c) + cv_lake(c,j)*(t_lake(c,j)-tfrz) & - + cfus*dz_lake(c,j)*(1._kind_phys-lake_icefrac(c,j)) !& + + cfus*dz_lake(c,j)*(1._kind_lake-lake_icefrac(c,j)) !& ! + (cwat-cice_eff)*lake_icefrac(c)*tfrz*dz_lake(c,j) !enthalpy reconciliation term t_lake_bef(c,j) = t_lake(c,j) end do @@ -2222,7 +2232,7 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! ocvts(c) = ocvts(c) + cv(c,j)*(t_soisno(c,j)-tfrz) & + hfus*h2osoi_liq(c,j) !& ! + (cpliq-cpice)*h2osoi_ice(c,j)*tfrz !enthalpy reconciliation term - if (j == 1 .and. h2osno(c) > 0._kind_phys .and. j == jtop(c)) then + if (j == 1 .and. h2osno(c) > 0._kind_lake .and. j == jtop(c)) then ocvts(c) = ocvts(c) - h2osno(c)*hfus end if t_soisno_bef(c,j) = t_soisno(c,j) @@ -2257,7 +2267,7 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! if (j < 1) then !snow layer zx(c,j) = z(c,j) cvx(c,j) = cv(c,j) - phix(c,j) = 0._kind_phys + phix(c,j) = 0._kind_lake tx(c,j) = t_soisno(c,j) else if (j <= nlevlake) then !lake layer zx(c,j) = z_lake(c,j) @@ -2265,12 +2275,12 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! phix(c,j) = phi(c,j) tx(c,j) = t_lake(c,j) else !soil layer - zx(c,j) = zx(c,nlevlake) + dz_lake(c,nlevlake)*0.5_kind_phys + z(c,jprime) + zx(c,j) = zx(c,nlevlake) + dz_lake(c,nlevlake)*0.5_kind_lake + z(c,jprime) cvx(c,j) = cv(c,jprime) if (j == nlevlake + 1) then !top soil layer phix(c,j) = phi_soil(c) else !middle or bottom soil layer - phix(c,j) = 0._kind_phys + phix(c,j) = 0._kind_lake end if tx(c,j) = t_soisno(c,jprime) end if @@ -2304,7 +2314,7 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! else if (j == nlevlake) then !bottom lake layer dzp = zx(c,j+1) - zx(c,j) tkix(c,j) = (tktopsoillay(c)*tk_lake(c,j)*dzp / & - (tktopsoillay(c)*dz_lake(c,j)*0.5_kind_phys + tk_lake(c,j)*z(c,1) ) ) + (tktopsoillay(c)*dz_lake(c,j)*0.5_kind_lake + tk_lake(c,j)*z(c,1) ) ) ! tktopsoillay is the conductivity at the middle of that layer, as defined in SoilThermProp_Lake else !soil layer tkix(c,j) = tk(c,jprime) @@ -2331,7 +2341,7 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! fnx(c,j) = tkix(c,j)*(tx(c,j+1)-tx(c,j))/(zx(c,j+1)-zx(c,j)) else !bottom soil layer factx(c,j) = dtime/cvx(c,j) - fnx(c,j) = 0._kind_phys !not used + fnx(c,j) = 0._kind_lake !not used end if end if enddo @@ -2346,22 +2356,22 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! if (j >= jtop(c)) then if (j == jtop(c)) then !top layer dzp = zx(c,j+1)-zx(c,j) - a(c,j) = 0._kind_phys - b(c,j) = 1+(1._kind_phys-cnfac)*factx(c,j)*tkix(c,j)/dzp - c1(c,j) = -(1._kind_phys-cnfac)*factx(c,j)*tkix(c,j)/dzp + a(c,j) = 0._kind_lake + b(c,j) = 1+(1._kind_lake-cnfac)*factx(c,j)*tkix(c,j)/dzp + c1(c,j) = -(1._kind_lake-cnfac)*factx(c,j)*tkix(c,j)/dzp r(c,j) = tx(c,j) + factx(c,j)*( fin(c) + phix(c,j) + cnfac*fnx(c,j) ) else if (j < nlevlake+nlevsoil) then !middle layer dzm = (zx(c,j)-zx(c,j-1)) dzp = (zx(c,j+1)-zx(c,j)) - a(c,j) = - (1._kind_phys-cnfac)*factx(c,j)* tkix(c,j-1)/dzm - b(c,j) = 1._kind_phys+ (1._kind_phys-cnfac)*factx(c,j)*(tkix(c,j)/dzp + tkix(c,j-1)/dzm) - c1(c,j) = - (1._kind_phys-cnfac)*factx(c,j)* tkix(c,j)/dzp + a(c,j) = - (1._kind_lake-cnfac)*factx(c,j)* tkix(c,j-1)/dzm + b(c,j) = 1._kind_lake+ (1._kind_lake-cnfac)*factx(c,j)*(tkix(c,j)/dzp + tkix(c,j-1)/dzm) + c1(c,j) = - (1._kind_lake-cnfac)*factx(c,j)* tkix(c,j)/dzp r(c,j) = tx(c,j) + cnfac*factx(c,j)*( fnx(c,j) - fnx(c,j-1) ) + factx(c,j)*phix(c,j) else !bottom soil layer dzm = (zx(c,j)-zx(c,j-1)) - a(c,j) = - (1._kind_phys-cnfac)*factx(c,j)*tkix(c,j-1)/dzm - b(c,j) = 1._kind_phys+ (1._kind_phys-cnfac)*factx(c,j)*tkix(c,j-1)/dzm - c1(c,j) = 0._kind_phys + a(c,j) = - (1._kind_lake-cnfac)*factx(c,j)*tkix(c,j-1)/dzm + b(c,j) = 1._kind_lake+ (1._kind_lake-cnfac)*factx(c,j)*tkix(c,j-1)/dzm + c1(c,j) = 0._kind_lake r(c,j) = tx(c,j) - cnfac*factx(c,j)*fnx(c,j-1) end if end if @@ -2437,7 +2447,7 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! errsoi(c) = esum1(c)/dtime - eflx_soil_grnd(p) ! eflx_soil_grnd includes all the solar radiation absorbed in the lake, ! unlike eflx_gnet - if(abs(errsoi(c)) > .001_kind_phys) then ! 1.e-5_kind_phys) then + if(abs(errsoi(c)) > .001_kind_lake) then ! 1.e-5_kind_lake) then WRITE( message,* )'Primary soil energy conservation error in shlake & column during Tridiagonal Solution,', 'error (W/m^2):', c, errsoi(c) errmsg=trim(message) @@ -2499,7 +2509,7 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! ! Again assuming only one pft per column esum2(c) = esum2(c) - lhabs(c) errsoi(c) = esum2(c)/dtime - if(abs(errsoi(c)) > 1.e-5_kind_phys) then + if(abs(errsoi(c)) > 1.e-5_kind_lake) then write(message,*)'Primary soil energy conservation error in shlake column during Phase Change, error (W/m^2):', & c, errsoi(c) errmsg=trim(message) @@ -2515,10 +2525,10 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! !cdir nodep do fc = 1, num_shlakec c = filter_shlakec(fc) - if (j == 1) wsum_end(c) = 0._kind_phys + if (j == 1) wsum_end(c) = 0._kind_lake wsum_end(c) = wsum_end(c) + h2osoi_ice(c,j) + h2osoi_liq(c,j) if (j == nlevsoil) then - if (abs(wsum(c)-wsum_end(c))>1.e-7_kind_phys) then + if (abs(wsum(c)-wsum_end(c))>1.e-7_kind_lake) then write(message,*)'Soil water balance error during phase change in ShalLakeTemperature.', & 'column, error (kg/m^2):', c, wsum_end(c)-wsum(c) errmsg=trim(message) @@ -2542,8 +2552,8 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! !cdir nodep do fc = 1, num_shlakec c = filter_shlakec(fc) - rhow(c,j) = (1._kind_phys - lake_icefrac(c,j)) * & - 1000._kind_phys*( 1.0_kind_phys - 1.9549e-05_kind_phys*(abs(t_lake(c,j)-277._kind_phys))**1.68_kind_phys ) & + rhow(c,j) = (1._kind_lake - lake_icefrac(c,j)) * & + 1000._kind_lake*( 1.0_kind_lake - 1.9549e-05_kind_lake*(abs(t_lake(c,j)-277._kind_lake))**1.68_kind_lake ) & + lake_icefrac(c,j)*denice end do end do @@ -2553,9 +2563,9 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! !cdir nodep do fc = 1, num_shlakec c = filter_shlakec(fc) - qav(c) = 0._kind_phys - nav(c) = 0._kind_phys - iceav(c) = 0._kind_phys + qav(c) = 0._kind_lake + nav(c) = 0._kind_lake + iceav(c) = 0._kind_lake end do do i = 1, j+1 @@ -2564,14 +2574,14 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! do fc = 1, num_shlakec c = filter_shlakec(fc) if (rhow(c,j) > rhow(c,j+1) .or. & - (lake_icefrac(c,j) < 1._kind_phys .and. lake_icefrac(c,j+1) > 0._kind_phys) ) then + (lake_icefrac(c,j) < 1._kind_lake .and. lake_icefrac(c,j+1) > 0._kind_lake) ) then if(LAKEDEBUG) then if (i==1) then print *, 'Convective Mixing in column ', c, '.' endif endif qav(c) = qav(c) + dz_lake(c,i)*(t_lake(c,i)-tfrz) * & - ((1._kind_phys - lake_icefrac(c,i))*cwat + lake_icefrac(c,i)*cice_eff) + ((1._kind_lake - lake_icefrac(c,i))*cwat + lake_icefrac(c,i)*cice_eff) ! tav(c) = tav(c) + t_lake(c,i)*dz_lake(c,i) iceav(c) = iceav(c) + lake_icefrac(c,i)*dz_lake(c,i) nav(c) = nav(c) + dz_lake(c,i) @@ -2584,20 +2594,20 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! do fc = 1, num_shlakec c = filter_shlakec(fc) if (rhow(c,j) > rhow(c,j+1) .or. & - (lake_icefrac(c,j) < 1._kind_phys .and. lake_icefrac(c,j+1) > 0._kind_phys) ) then + (lake_icefrac(c,j) < 1._kind_lake .and. lake_icefrac(c,j+1) > 0._kind_lake) ) then qav(c) = qav(c)/nav(c) iceav(c) = iceav(c)/nav(c) !If the average temperature is above freezing, put the extra energy into the water. !If it is below freezing, take it away from the ice. - if (qav(c) > 0._kind_phys) then - tav_froz(c) = 0._kind_phys !Celsius - tav_unfr(c) = qav(c) / ((1._kind_phys - iceav(c))*cwat) - else if (qav(c) < 0._kind_phys) then + if (qav(c) > 0._kind_lake) then + tav_froz(c) = 0._kind_lake !Celsius + tav_unfr(c) = qav(c) / ((1._kind_lake - iceav(c))*cwat) + else if (qav(c) < 0._kind_lake) then tav_froz(c) = qav(c) / (iceav(c)*cice_eff) - tav_unfr(c) = 0._kind_phys !Celsius + tav_unfr(c) = 0._kind_lake !Celsius else - tav_froz(c) = 0._kind_phys - tav_unfr(c) = 0._kind_phys + tav_froz(c) = 0._kind_lake + tav_unfr(c) = 0._kind_lake end if end if end do @@ -2607,7 +2617,7 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! !cdir nodep do fc = 1, num_shlakec c = filter_shlakec(fc) - if (nav(c) > 0._kind_phys) then + if (nav(c) > 0._kind_lake) then ! if(0==1) then !Put all the ice at the top.! @@ -2616,28 +2626,28 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! !For the layer with both ice & water, be careful to use the average temperature !that preserves the correct total heat content given what the heat capacity of that !layer will actually be. - if (i == 1) zsum(c) = 0._kind_phys + if (i == 1) zsum(c) = 0._kind_lake if ((zsum(c)+dz_lake(c,i))/nav(c) <= iceav(c)) then t_lake(c,i) = tav_froz(c) + tfrz !tgs - 30jul19 - the next line is a bug and should be commented !out. This bug prevents lake ice form completely melting. - ! lake_icefrac(c,i) = 1._kind_phys + ! lake_icefrac(c,i) = 1._kind_lake else if (zsum(c)/nav(c) < iceav(c)) then !tgs - change ice fraction lake_icefrac(c,i) = (iceav(c)*nav(c) - zsum(c)) / dz_lake(c,i) ! Find average value that preserves correct heat content. t_lake(c,i) = ( lake_icefrac(c,i)*tav_froz(c)*cice_eff & - + (1._kind_phys - lake_icefrac(c,i))*tav_unfr(c)*cwat ) & + + (1._kind_lake - lake_icefrac(c,i))*tav_unfr(c)*cwat ) & / ( lake_icefrac(c,i)*cice_eff + (1-lake_icefrac(c,i))*cwat ) + tfrz else !tgs - remove ice - lake_icefrac(c,i) = 0._kind_phys + lake_icefrac(c,i) = 0._kind_lake t_lake(c,i) = tav_unfr(c) + tfrz end if zsum(c) = zsum(c) + dz_lake(c,i) - rhow(c,i) = (1._kind_phys - lake_icefrac(c,i)) * & - 1000._kind_phys*( 1.0_kind_phys - 1.9549e-05_kind_phys*(abs(t_lake(c,i)-277._kind_phys))**1.68_kind_phys ) & + rhow(c,i) = (1._kind_lake - lake_icefrac(c,i)) * & + 1000._kind_lake*( 1.0_kind_lake - 1.9549e-05_kind_lake*(abs(t_lake(c,i)-277._kind_lake))**1.68_kind_lake ) & + lake_icefrac(c,i)*denice end if end do @@ -2653,7 +2663,7 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! do fc = 1, num_shlakec c = filter_shlakec(fc) - cv_lake(c,j) = dz_lake(c,j) * (cwat*(1._kind_phys-lake_icefrac(c,j)) + cice_eff*lake_icefrac(c,j)) + cv_lake(c,j) = dz_lake(c,j) * (cwat*(1._kind_lake-lake_icefrac(c,j)) + cice_eff*lake_icefrac(c,j)) if (LAKEDEBUG) then print *,'Lake Ice Fraction, c, level:', c, j, lake_icefrac(c,j) endif @@ -2674,7 +2684,7 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! ! ncvts(c) = ncvts(c) + cv_lake(c,j)*t_lake(c,j) & ncvts(c) = ncvts(c) + cv_lake(c,j)*(t_lake(c,j)-tfrz) & - + cfus*dz_lake(c,j)*(1._kind_phys-lake_icefrac(c,j)) !& + + cfus*dz_lake(c,j)*(1._kind_lake-lake_icefrac(c,j)) !& ! + (cwat-cice_eff)*lake_icefrac(c)*tfrz*dz_lake(c,j) !enthalpy reconciliation term fin(c) = fin(c) + phi(c,j) end do @@ -2691,7 +2701,7 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! ncvts(c) = ncvts(c) + cv(c,j)*(t_soisno(c,j)-tfrz) & + hfus*h2osoi_liq(c,j) !& ! + (cpliq-cpice)*h2osoi_ice(c,j)*tfrz !enthalpy reconciliation term - if (j == 1 .and. h2osno(c) > 0._kind_phys .and. j == jtop(c)) then + if (j == 1 .and. h2osno(c) > 0._kind_lake .and. j == jtop(c)) then ncvts(c) = ncvts(c) - h2osno(c)*hfus end if end if @@ -2706,17 +2716,17 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! p = filter_shlakep(fp) c = pcolumn(p) errsoi(c) = (ncvts(c)-ocvts(c)) / dtime - fin(c) - if( (LAKEDEBUG .and. abs(errsoi(c)) < 1._kind_phys) ) then -! .or. (.not.LAKEDEBUG .and. abs(errsoi(c)) < 10._kind_phys)) then + if( (LAKEDEBUG .and. abs(errsoi(c)) < 1._kind_lake) ) then +! .or. (.not.LAKEDEBUG .and. abs(errsoi(c)) < 10._kind_lake)) then eflx_sh_tot(p) = eflx_sh_tot(p) - errsoi(c) eflx_sh_grnd(p) = eflx_sh_grnd(p) - errsoi(c) eflx_soil_grnd(p) = eflx_soil_grnd(p) + errsoi(c) eflx_gnet(p) = eflx_gnet(p) + errsoi(c) - ! if (abs(errsoi(c)) > 1.e-3_kind_phys) then - if (abs(errsoi(c)) > 1.e-1_kind_phys) then + ! if (abs(errsoi(c)) > 1.e-3_kind_lake) then + if (abs(errsoi(c)) > 1.e-1_kind_lake) then print *,'errsoi incorporated into sensible heat in ShalLakeTemperature: c, (W/m^2):', c, errsoi(c) end if - errsoi(c) = 0._kind_phys + errsoi(c) = 0._kind_lake else if(LAKEDEBUG) then print *,'Soil Energy Balance Error at column, ', c, 'G, fintotal, column E tendency = ', & eflx_gnet(p), fin(c), (ncvts(c)-ocvts(c)) / dtime @@ -2761,23 +2771,23 @@ subroutine SoilThermProp_Lake (snl,dz,zi,z,t_soisno,h2osoi_liq,h2osoi_ice, & integer, intent(inout) :: errflg character(*), intent(inout) :: errmsg integer , intent(in) :: snl(1) ! number of snow layers - ! real(kind_phys), intent(in) :: h2osno(1) ! snow water (mm H2O) - real(kind_phys), intent(in) :: watsat(1,nlevsoil) ! volumetric soil water at saturation (porosity) - real(kind_phys), intent(in) :: tksatu(1,nlevsoil) ! thermal conductivity, saturated soil [W/m-K] - real(kind_phys), intent(in) :: tkmg(1,nlevsoil) ! thermal conductivity, soil minerals [W/m-K] - real(kind_phys), intent(in) :: tkdry(1,nlevsoil) ! thermal conductivity, dry soil (W/m/Kelvin) - real(kind_phys), intent(in) :: csol(1,nlevsoil) ! heat capacity, soil solids (J/m**3/Kelvin) - real(kind_phys), intent(in) :: dz(1,-nlevsnow+1:nlevsoil) ! layer thickness (m) - real(kind_phys), intent(in) :: zi(1,-nlevsnow+0:nlevsoil) ! interface level below a "z" level (m) - real(kind_phys), intent(in) :: z(1,-nlevsnow+1:nlevsoil) ! layer depth (m) - real(kind_phys), intent(in) :: t_soisno(1,-nlevsnow+1:nlevsoil) ! soil temperature (Kelvin) - real(kind_phys), intent(in) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) ! liquid water (kg/m2) - real(kind_phys), intent(in) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) ! ice lens (kg/m2) + ! real(kind_lake), intent(in) :: h2osno(1) ! snow water (mm H2O) + real(kind_lake), intent(in) :: watsat(1,nlevsoil) ! volumetric soil water at saturation (porosity) + real(kind_lake), intent(in) :: tksatu(1,nlevsoil) ! thermal conductivity, saturated soil [W/m-K] + real(kind_lake), intent(in) :: tkmg(1,nlevsoil) ! thermal conductivity, soil minerals [W/m-K] + real(kind_lake), intent(in) :: tkdry(1,nlevsoil) ! thermal conductivity, dry soil (W/m/Kelvin) + real(kind_lake), intent(in) :: csol(1,nlevsoil) ! heat capacity, soil solids (J/m**3/Kelvin) + real(kind_lake), intent(in) :: dz(1,-nlevsnow+1:nlevsoil) ! layer thickness (m) + real(kind_lake), intent(in) :: zi(1,-nlevsnow+0:nlevsoil) ! interface level below a "z" level (m) + real(kind_lake), intent(in) :: z(1,-nlevsnow+1:nlevsoil) ! layer depth (m) + real(kind_lake), intent(in) :: t_soisno(1,-nlevsnow+1:nlevsoil) ! soil temperature (Kelvin) + real(kind_lake), intent(in) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) ! liquid water (kg/m2) + real(kind_lake), intent(in) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) ! ice lens (kg/m2) !out - real(kind_phys), intent(out) :: cv(lbc:ubc,-nlevsnow+1:nlevsoil) ! heat capacity [J/(m2 K)] - real(kind_phys), intent(out) :: tk(lbc:ubc,-nlevsnow+1:nlevsoil) ! thermal conductivity [W/(m K)] - real(kind_phys), intent(out) :: tktopsoillay(lbc:ubc) ! thermal conductivity [W/(m K)] + real(kind_lake), intent(out) :: cv(lbc:ubc,-nlevsnow+1:nlevsoil) ! heat capacity [J/(m2 K)] + real(kind_lake), intent(out) :: tk(lbc:ubc,-nlevsnow+1:nlevsoil) ! thermal conductivity [W/(m K)] + real(kind_lake), intent(out) :: tktopsoillay(lbc:ubc) ! thermal conductivity [W/(m K)] !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !CALLED FROM: ! subroutine ShalLakeTemperature in this module. @@ -2804,15 +2814,15 @@ subroutine SoilThermProp_Lake (snl,dz,zi,z,t_soisno,h2osoi_liq,h2osoi_ice, & integer :: l,c,j ! indices integer :: fc ! lake filtered column indices - real(kind_phys) :: bw ! partial density of water (ice + liquid) - real(kind_phys) :: dksat ! thermal conductivity for saturated soil (j/(k s m)) - real(kind_phys) :: dke ! kersten number - real(kind_phys) :: fl ! fraction of liquid or unfrozen water to total water - real(kind_phys) :: satw ! relative total water content of soil. - real(kind_phys) :: thk(lbc:ubc,-nlevsnow+1:nlevsoil) ! thermal conductivity of layer + real(kind_lake) :: bw ! partial density of water (ice + liquid) + real(kind_lake) :: dksat ! thermal conductivity for saturated soil (j/(k s m)) + real(kind_lake) :: dke ! kersten number + real(kind_lake) :: fl ! fraction of liquid or unfrozen water to total water + real(kind_lake) :: satw ! relative total water content of soil. + real(kind_lake) :: thk(lbc:ubc,-nlevsnow+1:nlevsoil) ! thermal conductivity of layer character*256 :: message - real(kind_phys) :: denom + real(kind_lake) :: denom ! Thermal conductivity of soil from Farouki (1981) @@ -2831,8 +2841,8 @@ subroutine SoilThermProp_Lake (snl,dz,zi,z,t_soisno,h2osoi_liq,h2osoi_ice, & ! Soil should be saturated. if (LAKEDEBUG) then satw = (h2osoi_liq(c,j)/denh2o + h2osoi_ice(c,j)/denice)/(dz(c,j)*watsat(c,j)) - ! satw = min(1._kind_phys, satw) - if (satw < 0.999_kind_phys) then + ! satw = min(1._kind_lake, satw) + if (satw < 0.999_kind_lake) then write(message,*)'WARNING: soil layer unsaturated in SoilThermProp_Lake, satw, j = ', satw, j ! errmsg=trim(message) ! errflg=1 @@ -2842,7 +2852,7 @@ subroutine SoilThermProp_Lake (snl,dz,zi,z,t_soisno,h2osoi_liq,h2osoi_ice, & ! since we're not yet doing excess ice. ! But take care of this in HydrologyLake. endif - satw = 1._kind_phys + satw = 1._kind_lake denom = (h2osoi_ice(c,j)+h2osoi_liq(c,j)) if(denom>zero_h2o) then fl = h2osoi_liq(c,j)/denom @@ -2854,13 +2864,13 @@ subroutine SoilThermProp_Lake (snl,dz,zi,z,t_soisno,h2osoi_liq,h2osoi_ice, & write(0,'(A)') trim(message) endif if (t_soisno(c,j) >= tfrz) then ! Unfrozen soil - dke = max(0._kind_phys, log10(satw) + 1.0_kind_phys) + dke = max(0._kind_lake, log10(satw) + 1.0_kind_lake) dksat = tksatu(c,j) else ! Frozen soil dke = satw - dksat = tkmg(c,j)*0.249_kind_phys**(fl*watsat(c,j))*2.29_kind_phys**watsat(c,j) + dksat = tkmg(c,j)*0.249_kind_lake**(fl*watsat(c,j))*2.29_kind_lake**watsat(c,j) endif - thk(c,j) = dke*dksat + (1._kind_phys-dke)*tkdry(c,j) + thk(c,j) = dke*dksat + (1._kind_lake-dke)*tkdry(c,j) ! else ! thk(c,j) = tkwat ! if (t_soisno(c,j) < tfrz) thk(c,j) = tkice @@ -2871,7 +2881,7 @@ subroutine SoilThermProp_Lake (snl,dz,zi,z,t_soisno,h2osoi_liq,h2osoi_ice, & ! Only examine levels from snl(c)+1 -> 0 where snl(c) < 1 if (snl(c)+1 < 1 .AND. (j >= snl(c)+1) .AND. (j <= 0)) then bw = (h2osoi_ice(c,j)+h2osoi_liq(c,j))/dz(c,j) - thk(c,j) = tkairc + (7.75e-5_kind_phys *bw + 1.105e-6_kind_phys*bw*bw)*(tkice-tkairc) + thk(c,j) = tkairc + (7.75e-5_kind_lake *bw + 1.105e-6_kind_lake*bw*bw)*(tkice-tkairc) end if end do @@ -2894,7 +2904,7 @@ subroutine SoilThermProp_Lake (snl,dz,zi,z,t_soisno,h2osoi_liq,h2osoi_ice, & else if (j == 0) then tk(c,j) = thk(c,j) else if (j == nlevsoil) then - tk(c,j) = 0._kind_phys + tk(c,j) = 0._kind_lake end if ! For top soil layer. if (j == 1) tktopsoillay(c) = thk(c,j) @@ -2916,7 +2926,7 @@ subroutine SoilThermProp_Lake (snl,dz,zi,z,t_soisno,h2osoi_liq,h2osoi_ice, & ! cv(c,j) = (h2osoi_ice(c,j)*cpice + h2osoi_liq(c,j)*cpliq) ! endif ! if (j == 1) then - ! if (snl(c)+1 == 1 .AND. h2osno(c) > 0._kind_phys) then + ! if (snl(c)+1 == 1 .AND. h2osno(c) > 0._kind_lake) then ! cv(c,j) = cv(c,j) + cpice*h2osno(c) ! end if ! end if @@ -2983,38 +2993,38 @@ subroutine PhaseChange_Lake (snl,h2osno,dz,dz_lake, & !i !in: integer , intent(in) :: snl(1) !number of snow layers - real(kind_phys), intent(inout) :: h2osno(1) !snow water (mm H2O) - real(kind_phys), intent(in) :: dz(1,-nlevsnow+1:nlevsoil) !layer thickness (m) - real(kind_phys), intent(in) :: dz_lake(1,nlevlake) !lake layer thickness (m) + real(kind_lake), intent(inout) :: h2osno(1) !snow water (mm H2O) + real(kind_lake), intent(in) :: dz(1,-nlevsnow+1:nlevsoil) !layer thickness (m) + real(kind_lake), intent(in) :: dz_lake(1,nlevlake) !lake layer thickness (m) ! Needed in case snow height is less than critical value. !inout: - real(kind_phys), intent(inout) :: snowdp(1) !snow height (m) - real(kind_phys), intent(inout) :: t_soisno(1,-nlevsnow+1:nlevsoil) !soil temperature (Kelvin) - real(kind_phys), intent(inout) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) !liquid water (kg/m2) - real(kind_phys), intent(inout) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) !ice lens (kg/m2) - real(kind_phys), intent(inout) :: lake_icefrac(1,nlevlake) ! mass fraction of lake layer that is frozen - real(kind_phys), intent(inout) :: t_lake(1,nlevlake) ! lake temperature (Kelvin) + real(kind_lake), intent(inout) :: snowdp(1) !snow height (m) + real(kind_lake), intent(inout) :: t_soisno(1,-nlevsnow+1:nlevsoil) !soil temperature (Kelvin) + real(kind_lake), intent(inout) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) !liquid water (kg/m2) + real(kind_lake), intent(inout) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) !ice lens (kg/m2) + real(kind_lake), intent(inout) :: lake_icefrac(1,nlevlake) ! mass fraction of lake layer that is frozen + real(kind_lake), intent(inout) :: t_lake(1,nlevlake) ! lake temperature (Kelvin) !out: - real(kind_phys), intent(out) :: qflx_snomelt(1) !snow melt (mm H2O /s) - real(kind_phys), intent(out) :: eflx_snomelt(1) !snow melt heat flux (W/m**2) + real(kind_lake), intent(out) :: qflx_snomelt(1) !snow melt (mm H2O /s) + real(kind_lake), intent(out) :: eflx_snomelt(1) !snow melt heat flux (W/m**2) integer, intent(out) :: imelt(1,-nlevsnow+1:nlevsoil) !flag for melting (=1), freezing (=2), Not=0 (new) !What's the sign of this? Is it just output? - real(kind_phys), intent(inout) :: cv(lbc:ubc,-nlevsnow+1:nlevsoil) ! heat capacity [J/(m2 K)] - real(kind_phys), intent(inout) :: cv_lake (lbc:ubc,1:nlevlake) ! heat capacity [J/(m2 K)] - real(kind_phys), intent(out):: lhabs(lbc:ubc) ! total per-column latent heat abs. (J/m^2) + real(kind_lake), intent(inout) :: cv(lbc:ubc,-nlevsnow+1:nlevsoil) ! heat capacity [J/(m2 K)] + real(kind_lake), intent(inout) :: cv_lake (lbc:ubc,1:nlevlake) ! heat capacity [J/(m2 K)] + real(kind_lake), intent(out):: lhabs(lbc:ubc) ! total per-column latent heat abs. (J/m^2) ! OTHER LOCAL VARIABLES: integer :: j,c,g !do loop index integer :: fc !lake filtered column indices - real(kind_phys) :: heatavail !available energy for melting or freezing (J/m^2) - real(kind_phys) :: heatrem !energy residual or loss after melting or freezing - real(kind_phys) :: melt !actual melting (+) or freezing (-) [kg/m2] - real(kind_phys), parameter :: smallnumber = 1.e-7_kind_phys !to prevent tiny residuals from rounding error + real(kind_lake) :: heatavail !available energy for melting or freezing (J/m^2) + real(kind_lake) :: heatrem !energy residual or loss after melting or freezing + real(kind_lake) :: melt !actual melting (+) or freezing (-) [kg/m2] + real(kind_lake), parameter :: smallnumber = 1.e-7_kind_lake !to prevent tiny residuals from rounding error logical :: dophasechangeflag !----------------------------------------------------------------------- @@ -3025,9 +3035,9 @@ subroutine PhaseChange_Lake (snl,h2osno,dz,dz_lake, & !i do fc = 1,num_shlakec c = filter_shlakec(fc) - qflx_snomelt(c) = 0._kind_phys - eflx_snomelt(c) = 0._kind_phys - lhabs(c) = 0._kind_phys + qflx_snomelt(c) = 0._kind_lake + eflx_snomelt(c) = 0._kind_lake + lhabs(c) = 0._kind_lake end do do j = -nlevsnow+1,0 @@ -3047,19 +3057,19 @@ subroutine PhaseChange_Lake (snl,h2osno,dz,dz_lake, & !i do fc = 1,num_shlakec c = filter_shlakec(fc) - if (snl(c) == 0 .and. h2osno(c) > 0._kind_phys .and. t_lake(c,1) > tfrz) then + if (snl(c) == 0 .and. h2osno(c) > 0._kind_lake .and. t_lake(c,1) > tfrz) then heatavail = (t_lake(c,1) - tfrz) * cv_lake(c,1) melt = min(h2osno(c), heatavail/hfus) - heatrem = max(heatavail - melt*hfus, 0._kind_phys) + heatrem = max(heatavail - melt*hfus, 0._kind_lake) !catch small negative value to keep t at tfrz t_lake(c,1) = tfrz + heatrem/(cv_lake(c,1)) - snowdp(c) = snowdp(c)*(1._kind_phys - melt/h2osno(c)) + snowdp(c) = snowdp(c)*(1._kind_lake - melt/h2osno(c)) h2osno(c) = h2osno(c) - melt lhabs(c) = lhabs(c) + melt*hfus qflx_snomelt(c) = qflx_snomelt(c) + melt ! Prevent tiny residuals - if (h2osno(c) < smallnumber) h2osno(c) = 0._kind_phys - if (snowdp(c) < smallnumber) snowdp(c) = 0._kind_phys + if (h2osno(c) < smallnumber) h2osno(c) = 0._kind_lake + if (snowdp(c) < smallnumber) snowdp(c) = 0._kind_lake end if end do @@ -3072,19 +3082,19 @@ subroutine PhaseChange_Lake (snl,h2osno,dz,dz_lake, & !i c = filter_shlakec(fc) dophasechangeflag = .false. - if (t_lake(c,j) > tfrz .and. lake_icefrac(c,j) > 0._kind_phys) then ! melting + if (t_lake(c,j) > tfrz .and. lake_icefrac(c,j) > 0._kind_lake) then ! melting dophasechangeflag = .true. heatavail = (t_lake(c,j) - tfrz) * cv_lake(c,j) melt = min(lake_icefrac(c,j)*denh2o*dz_lake(c,j), heatavail/hfus) !denh2o is used because layer thickness is not adjusted for freezing - heatrem = max(heatavail - melt*hfus, 0._kind_phys) + heatrem = max(heatavail - melt*hfus, 0._kind_lake) !catch small negative value to keep t at tfrz - else if (t_lake(c,j) < tfrz .and. lake_icefrac(c,j) < 1._kind_phys) then !freezing + else if (t_lake(c,j) < tfrz .and. lake_icefrac(c,j) < 1._kind_lake) then !freezing dophasechangeflag = .true. heatavail = (t_lake(c,j) - tfrz) * cv_lake(c,j) - melt = max(-(1._kind_phys-lake_icefrac(c,j))*denh2o*dz_lake(c,j), heatavail/hfus) + melt = max(-(1._kind_lake-lake_icefrac(c,j))*denh2o*dz_lake(c,j), heatavail/hfus) !denh2o is used because layer thickness is not adjusted for freezing - heatrem = min(heatavail - melt*hfus, 0._kind_phys) + heatrem = min(heatavail - melt*hfus, 0._kind_lake) !catch small positive value to keep t at tfrz end if ! Update temperature and ice fraction. @@ -3095,8 +3105,8 @@ subroutine PhaseChange_Lake (snl,h2osno,dz,dz_lake, & !i cv_lake(c,j) = cv_lake(c,j) + melt*(cpliq-cpice) t_lake(c,j) = tfrz + heatrem/cv_lake(c,j) ! Prevent tiny residuals - if (lake_icefrac(c,j) > 1._kind_phys - smallnumber) lake_icefrac(c,j) = 1._kind_phys - if (lake_icefrac(c,j) < smallnumber) lake_icefrac(c,j) = 0._kind_phys + if (lake_icefrac(c,j) > 1._kind_lake - smallnumber) lake_icefrac(c,j) = 1._kind_lake + if (lake_icefrac(c,j) < smallnumber) lake_icefrac(c,j) = 0._kind_lake end if end do end do @@ -3112,21 +3122,21 @@ subroutine PhaseChange_Lake (snl,h2osno,dz,dz_lake, & !i if (j >= snl(c) + 1) then - if (t_soisno(c,j) > tfrz .and. h2osoi_ice(c,j) > 0._kind_phys) then ! melting + if (t_soisno(c,j) > tfrz .and. h2osoi_ice(c,j) > 0._kind_lake) then ! melting dophasechangeflag = .true. heatavail = (t_soisno(c,j) - tfrz) * cv(c,j) melt = min(h2osoi_ice(c,j), heatavail/hfus) - heatrem = max(heatavail - melt*hfus, 0._kind_phys) + heatrem = max(heatavail - melt*hfus, 0._kind_lake) !catch small negative value to keep t at tfrz if (j <= 0) then !snow imelt(c,j) = 1 qflx_snomelt(c) = qflx_snomelt(c) + melt end if - else if (t_soisno(c,j) < tfrz .and. h2osoi_liq(c,j) > 0._kind_phys) then !freezing + else if (t_soisno(c,j) < tfrz .and. h2osoi_liq(c,j) > 0._kind_lake) then !freezing dophasechangeflag = .true. heatavail = (t_soisno(c,j) - tfrz) * cv(c,j) melt = max(-h2osoi_liq(c,j), heatavail/hfus) - heatrem = min(heatavail - melt*hfus, 0._kind_phys) + heatrem = min(heatavail - melt*hfus, 0._kind_lake) !catch small positive value to keep t at tfrz if (j <= 0) then !snow imelt(c,j) = 2 @@ -3145,8 +3155,8 @@ subroutine PhaseChange_Lake (snl,h2osno,dz,dz_lake, & !i cv(c,j) = cv(c,j) + melt*(cpliq-cpice) t_soisno(c,j) = tfrz + heatrem/cv(c,j) ! Prevent tiny residuals - if (h2osoi_ice(c,j) < smallnumber) h2osoi_ice(c,j) = 0._kind_phys - if (h2osoi_liq(c,j) < smallnumber) h2osoi_liq(c,j) = 0._kind_phys + if (h2osoi_ice(c,j) < smallnumber) h2osoi_ice(c,j) = 0._kind_lake + if (h2osoi_liq(c,j) < smallnumber) h2osoi_liq(c,j) = 0._kind_lake end if end if @@ -3226,88 +3236,88 @@ subroutine ShalLakeHydrology(dz_lake,forc_rain,forc_snow, & integer, intent(inout) :: errflg character(*), intent(inout) :: errmsg - real(kind_phys) :: watsat(1,nlevsoil) ! volumetric soil water at saturation (porosity) - real(kind_phys) :: tksatu(1,nlevsoil) ! thermal conductivity, saturated soil [W/m-K] - real(kind_phys) :: tkmg(1,nlevsoil) ! thermal conductivity, soil minerals [W/m-K] - real(kind_phys) :: tkdry(1,nlevsoil) ! thermal conductivity, dry soil (W/m/Kelvin) - real(kind_phys) :: csol(1,nlevsoil) ! heat capacity, soil solids (J/m**3/Kelvin) + real(kind_lake) :: watsat(1,nlevsoil) ! volumetric soil water at saturation (porosity) + real(kind_lake) :: tksatu(1,nlevsoil) ! thermal conductivity, saturated soil [W/m-K] + real(kind_lake) :: tkmg(1,nlevsoil) ! thermal conductivity, soil minerals [W/m-K] + real(kind_lake) :: tkdry(1,nlevsoil) ! thermal conductivity, dry soil (W/m/Kelvin) + real(kind_lake) :: csol(1,nlevsoil) ! heat capacity, soil solids (J/m**3/Kelvin) ! integer , intent(in) :: clandunit(1) ! column's landunit ! integer , intent(in) :: ityplun(1) ! landunit type - real(kind_phys), intent(in) :: dtime ! timestep - real(kind_phys), intent(in) :: dz_lake(1,nlevlake) ! layer thickness for lake (m) - real(kind_phys), intent(in) :: forc_rain(1) ! rain rate [mm/s] - real(kind_phys), intent(in) :: forc_snow(1) ! snow rate [mm/s] - real(kind_phys), intent(in) :: qflx_evap_tot(1) ! qflx_evap_soi + qflx_evap_veg + qflx_tran_veg - real(kind_phys), intent(in) :: forc_t(1) ! atmospheric temperature (Kelvin) + real(kind_lake), intent(in) :: dtime ! timestep + real(kind_lake), intent(in) :: dz_lake(1,nlevlake) ! layer thickness for lake (m) + real(kind_lake), intent(in) :: forc_rain(1) ! rain rate [mm/s] + real(kind_lake), intent(in) :: forc_snow(1) ! snow rate [mm/s] + real(kind_lake), intent(in) :: qflx_evap_tot(1) ! qflx_evap_soi + qflx_evap_veg + qflx_tran_veg + real(kind_lake), intent(in) :: forc_t(1) ! atmospheric temperature (Kelvin) - !real(kind_phys), intent(in),optional :: flfall(1) ! fraction of liquid water within falling precipitation (unused) + !real(kind_lake), intent(in),optional :: flfall(1) ! fraction of liquid water within falling precipitation (unused) logical , intent(in) :: do_capsnow(1) ! true => do snow capping - real(kind_phys), intent(in) :: t_grnd(1) ! ground temperature (Kelvin) - real(kind_phys), intent(in) :: qflx_evap_soi(1) ! soil evaporation (mm H2O/s) (+ = to atm) - real(kind_phys), intent(in) :: qflx_snomelt(1) !snow melt (mm H2O /s) + real(kind_lake), intent(in) :: t_grnd(1) ! ground temperature (Kelvin) + real(kind_lake), intent(in) :: qflx_evap_soi(1) ! soil evaporation (mm H2O/s) (+ = to atm) + real(kind_lake), intent(in) :: qflx_snomelt(1) !snow melt (mm H2O /s) integer, intent(in) :: imelt(1,-nlevsnow+1:nlevsoil) !flag for melting (=1), freezing (=2), Not=0 !inout: - real(kind_phys), intent(inout) :: begwb(1) ! water mass begining of the time step + real(kind_lake), intent(inout) :: begwb(1) ! water mass begining of the time step ! inout: - real(kind_phys), intent(inout) :: z(1,-nlevsnow+1:nlevsoil) ! layer depth (m) - real(kind_phys), intent(inout) :: dz(1,-nlevsnow+1:nlevsoil) ! layer thickness depth (m) - real(kind_phys), intent(inout) :: zi(1,-nlevsnow+0:nlevsoil) ! interface depth (m) + real(kind_lake), intent(inout) :: z(1,-nlevsnow+1:nlevsoil) ! layer depth (m) + real(kind_lake), intent(inout) :: dz(1,-nlevsnow+1:nlevsoil) ! layer thickness depth (m) + real(kind_lake), intent(inout) :: zi(1,-nlevsnow+0:nlevsoil) ! interface depth (m) integer , intent(inout) :: snl(1) ! number of snow layers - real(kind_phys), intent(inout) :: h2osno(1) ! snow water (mm H2O) - real(kind_phys), intent(inout) :: snowdp(1) ! snow height (m) - real(kind_phys), intent(inout) :: lake_icefrac(1,nlevlake) ! mass fraction of lake layer that is frozen - real(kind_phys), intent(inout) :: t_lake(1,nlevlake) ! lake temperature (Kelvin) + real(kind_lake), intent(inout) :: h2osno(1) ! snow water (mm H2O) + real(kind_lake), intent(inout) :: snowdp(1) ! snow height (m) + real(kind_lake), intent(inout) :: lake_icefrac(1,nlevlake) ! mass fraction of lake layer that is frozen + real(kind_lake), intent(inout) :: t_lake(1,nlevlake) ! lake temperature (Kelvin) - real(kind_phys), intent(inout) :: frac_iceold(1,-nlevsnow+1:nlevsoil) ! fraction of ice relative to the tot water + real(kind_lake), intent(inout) :: frac_iceold(1,-nlevsnow+1:nlevsoil) ! fraction of ice relative to the tot water ! out: - real(kind_phys), intent(out) :: endwb(1) ! water mass end of the time step - real(kind_phys), intent(out) :: snowage(1) ! non dimensional snow age [-] - real(kind_phys), intent(out) :: snowice(1) ! average snow ice lens - real(kind_phys), intent(out) :: snowliq(1) ! average snow liquid water - real(kind_phys), intent(out) :: t_snow(1) ! vertically averaged snow temperature - real(kind_phys), intent(out) :: t_soisno(1,-nlevsnow+1:nlevsoil) ! snow temperature (Kelvin) - real(kind_phys), intent(out) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) ! ice lens (kg/m2) - real(kind_phys), intent(out) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) ! liquid water (kg/m2) - real(kind_phys), intent(out) :: h2osoi_vol(1,-nlevsnow+1:nlevsoil) ! volumetric soil water (0<=h2osoi_vol<=watsat)[m3/m3] - real(kind_phys), intent(out) :: qflx_drain(1) ! sub-surface runoff (mm H2O /s) - real(kind_phys), intent(out) :: qflx_surf(1) ! surface runoff (mm H2O /s) - real(kind_phys), intent(out) :: qflx_infl(1) ! infiltration (mm H2O /s) - real(kind_phys), intent(out) :: qflx_qrgwl(1) ! qflx_surf at glaciers, wetlands, lakes - real(kind_phys), intent(out) :: qcharge(1) ! aquifer recharge rate (mm/s) - real(kind_phys), intent(out) :: qflx_prec_grnd(1) ! water onto ground including canopy runoff [kg/(m2 s)] - real(kind_phys), intent(out) :: qflx_snowcap(1) ! excess precipitation due to snow capping (mm H2O /s) [+] - real(kind_phys), intent(out) :: qflx_snowcap_col(1) ! excess precipitation due to snow capping (mm H2O /s) [+] - real(kind_phys), intent(out) :: qflx_snow_grnd_pft(1) ! snow on ground after interception (mm H2O/s) [+] - real(kind_phys), intent(out) :: qflx_snow_grnd_col(1) ! snow on ground after interception (mm H2O/s) [+] - real(kind_phys), intent(out) :: qflx_rain_grnd(1) ! rain on ground after interception (mm H2O/s) [+] - real(kind_phys), intent(out) :: qflx_evap_tot_col(1) !pft quantity averaged to the column (assuming one pft) - real(kind_phys) ,intent(out) :: soilalpha(1) !factor that reduces ground saturated specific humidity (-) - real(kind_phys), intent(out) :: zwt(1) !water table depth - real(kind_phys), intent(out) :: fcov(1) !fractional area with water table at surface - real(kind_phys), intent(out) :: rootr_column(1,1:nlevsoil) !effective fraction of roots in each soil layer - real(kind_phys), intent(out) :: qflx_evap_grnd(1) ! ground surface evaporation rate (mm H2O/s) [+] - real(kind_phys), intent(out) :: qflx_sub_snow(1) ! sublimation rate from snow pack (mm H2O /s) [+] - real(kind_phys), intent(out) :: qflx_dew_snow(1) ! surface dew added to snow pack (mm H2O /s) [+] - real(kind_phys), intent(out) :: qflx_dew_grnd(1) ! ground surface dew formation (mm H2O /s) [+] - real(kind_phys), intent(out) :: qflx_rain_grnd_col(1) !rain on ground after interception (mm H2O/s) [+] + real(kind_lake), intent(out) :: endwb(1) ! water mass end of the time step + real(kind_lake), intent(out) :: snowage(1) ! non dimensional snow age [-] + real(kind_lake), intent(out) :: snowice(1) ! average snow ice lens + real(kind_lake), intent(out) :: snowliq(1) ! average snow liquid water + real(kind_lake), intent(out) :: t_snow(1) ! vertically averaged snow temperature + real(kind_lake), intent(out) :: t_soisno(1,-nlevsnow+1:nlevsoil) ! snow temperature (Kelvin) + real(kind_lake), intent(out) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) ! ice lens (kg/m2) + real(kind_lake), intent(out) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) ! liquid water (kg/m2) + real(kind_lake), intent(out) :: h2osoi_vol(1,-nlevsnow+1:nlevsoil) ! volumetric soil water (0<=h2osoi_vol<=watsat)[m3/m3] + real(kind_lake), intent(out) :: qflx_drain(1) ! sub-surface runoff (mm H2O /s) + real(kind_lake), intent(out) :: qflx_surf(1) ! surface runoff (mm H2O /s) + real(kind_lake), intent(out) :: qflx_infl(1) ! infiltration (mm H2O /s) + real(kind_lake), intent(out) :: qflx_qrgwl(1) ! qflx_surf at glaciers, wetlands, lakes + real(kind_lake), intent(out) :: qcharge(1) ! aquifer recharge rate (mm/s) + real(kind_lake), intent(out) :: qflx_prec_grnd(1) ! water onto ground including canopy runoff [kg/(m2 s)] + real(kind_lake), intent(out) :: qflx_snowcap(1) ! excess precipitation due to snow capping (mm H2O /s) [+] + real(kind_lake), intent(out) :: qflx_snowcap_col(1) ! excess precipitation due to snow capping (mm H2O /s) [+] + real(kind_lake), intent(out) :: qflx_snow_grnd_pft(1) ! snow on ground after interception (mm H2O/s) [+] + real(kind_lake), intent(out) :: qflx_snow_grnd_col(1) ! snow on ground after interception (mm H2O/s) [+] + real(kind_lake), intent(out) :: qflx_rain_grnd(1) ! rain on ground after interception (mm H2O/s) [+] + real(kind_lake), intent(out) :: qflx_evap_tot_col(1) !pft quantity averaged to the column (assuming one pft) + real(kind_lake) ,intent(out) :: soilalpha(1) !factor that reduces ground saturated specific humidity (-) + real(kind_lake), intent(out) :: zwt(1) !water table depth + real(kind_lake), intent(out) :: fcov(1) !fractional area with water table at surface + real(kind_lake), intent(out) :: rootr_column(1,1:nlevsoil) !effective fraction of roots in each soil layer + real(kind_lake), intent(out) :: qflx_evap_grnd(1) ! ground surface evaporation rate (mm H2O/s) [+] + real(kind_lake), intent(out) :: qflx_sub_snow(1) ! sublimation rate from snow pack (mm H2O /s) [+] + real(kind_lake), intent(out) :: qflx_dew_snow(1) ! surface dew added to snow pack (mm H2O /s) [+] + real(kind_lake), intent(out) :: qflx_dew_grnd(1) ! ground surface dew formation (mm H2O /s) [+] + real(kind_lake), intent(out) :: qflx_rain_grnd_col(1) !rain on ground after interception (mm H2O/s) [+] ! Block of biogeochem currently not used. - real(kind_phys), pointer :: sucsat(:,:) ! minimum soil suction (mm) - real(kind_phys), pointer :: bsw(:,:) ! Clapp and Hornberger "b" - real(kind_phys), pointer :: bsw2(:,:) ! Clapp and Hornberger "b" for CN code - real(kind_phys), pointer :: psisat(:,:) ! soil water potential at saturation for CN code (MPa) - real(kind_phys), pointer :: vwcsat(:,:) ! volumetric water content at saturation for CN code (m3/m3) - real(kind_phys), pointer :: wf(:) ! soil water as frac. of whc for top 0.5 m - real(kind_phys), pointer :: soilpsi(:,:) ! soil water potential in each soil layer (MPa) + real(kind_lake), pointer :: sucsat(:,:) ! minimum soil suction (mm) + real(kind_lake), pointer :: bsw(:,:) ! Clapp and Hornberger "b" + real(kind_lake), pointer :: bsw2(:,:) ! Clapp and Hornberger "b" for CN code + real(kind_lake), pointer :: psisat(:,:) ! soil water potential at saturation for CN code (MPa) + real(kind_lake), pointer :: vwcsat(:,:) ! volumetric water content at saturation for CN code (m3/m3) + real(kind_lake), pointer :: wf(:) ! soil water as frac. of whc for top 0.5 m + real(kind_lake), pointer :: soilpsi(:,:) ! soil water potential in each soil layer (MPa) ! OTHER LOCAL VARIABLES: @@ -3317,22 +3327,22 @@ subroutine ShalLakeHydrology(dz_lake,forc_rain,forc_snow, & integer :: num_shlakenosnowc ! number of column non-snow points integer :: filter_shlakenosnowc(ubc-lbc+1) ! column filter for non-snow points integer :: newnode ! flag when new snow node is set, (1=yes, 0=no) - real(kind_phys) :: dz_snowf ! layer thickness rate change due to precipitation [mm/s] - real(kind_phys) :: bifall ! bulk density of newly fallen dry snow [kg/m3] - real(kind_phys) :: fracsnow(lbp:ubp) ! frac of precipitation that is snow - real(kind_phys) :: fracrain(lbp:ubp) ! frac of precipitation that is rain - real(kind_phys) :: qflx_prec_grnd_snow(lbp:ubp) ! snow precipitation incident on ground [mm/s] - real(kind_phys) :: qflx_prec_grnd_rain(lbp:ubp) ! rain precipitation incident on ground [mm/s] - real(kind_phys) :: qflx_evap_soi_lim ! temporary evap_soi limited by top snow layer content [mm/s] - real(kind_phys) :: h2osno_temp ! temporary h2osno [kg/m^2] - real(kind_phys) :: sumsnowice(lbc:ubc) ! sum of snow ice if snow layers found above unfrozen lake [kg/m&2] + real(kind_lake) :: dz_snowf ! layer thickness rate change due to precipitation [mm/s] + real(kind_lake) :: bifall ! bulk density of newly fallen dry snow [kg/m3] + real(kind_lake) :: fracsnow(lbp:ubp) ! frac of precipitation that is snow + real(kind_lake) :: fracrain(lbp:ubp) ! frac of precipitation that is rain + real(kind_lake) :: qflx_prec_grnd_snow(lbp:ubp) ! snow precipitation incident on ground [mm/s] + real(kind_lake) :: qflx_prec_grnd_rain(lbp:ubp) ! rain precipitation incident on ground [mm/s] + real(kind_lake) :: qflx_evap_soi_lim ! temporary evap_soi limited by top snow layer content [mm/s] + real(kind_lake) :: h2osno_temp ! temporary h2osno [kg/m^2] + real(kind_lake) :: sumsnowice(lbc:ubc) ! sum of snow ice if snow layers found above unfrozen lake [kg/m&2] logical :: unfrozen(lbc:ubc) ! true if top lake layer is unfrozen with snow layers above - real(kind_phys) :: heatrem ! used in case above [J/m^2] - real(kind_phys) :: heatsum(lbc:ubc) ! used in case above [J/m^2] - real(kind_phys) :: qflx_top_soil(1) !net water input into soil from top (mm/s) + real(kind_lake) :: heatrem ! used in case above [J/m^2] + real(kind_lake) :: heatsum(lbc:ubc) ! used in case above [J/m^2] + real(kind_lake) :: qflx_top_soil(1) !net water input into soil from top (mm/s) character*256 :: message - real(kind_phys),allocatable :: snow_water(:) ! temporary sum of snow water for Bal Check [kg/m^2] + real(kind_lake),allocatable :: snow_water(:) ! temporary sum of snow water for Bal Check [kg/m^2] !----------------------------------------------------------------------- ! Determine step size @@ -3377,10 +3387,10 @@ subroutine ShalLakeHydrology(dz_lake,forc_rain,forc_snow, & if (do_capsnow(c)) then qflx_snowcap(p) = qflx_prec_grnd_snow(p) + qflx_prec_grnd_rain(p) - qflx_snow_grnd_pft(p) = 0._kind_phys - qflx_rain_grnd(p) = 0._kind_phys + qflx_snow_grnd_pft(p) = 0._kind_lake + qflx_rain_grnd(p) = 0._kind_lake else - qflx_snowcap(p) = 0._kind_phys + qflx_snowcap(p) = 0._kind_lake qflx_snow_grnd_pft(p) = qflx_prec_grnd_snow(p) ! ice onto ground (mm/s) qflx_rain_grnd(p) = qflx_prec_grnd_rain(p) ! liquid water onto ground (mm/s) end if @@ -3404,14 +3414,14 @@ subroutine ShalLakeHydrology(dz_lake,forc_rain,forc_snow, & ! Progress Rep. 1, Alta Avalanche Study Center:Snow Layer Densification. if (do_capsnow(c)) then - dz_snowf = 0._kind_phys + dz_snowf = 0._kind_lake else - if (forc_t(g) > tfrz + 2._kind_phys) then - bifall=50._kind_phys + 1.7_kind_phys*(17.0_kind_phys)**1.5_kind_phys - else if (forc_t(g) > tfrz - 15._kind_phys) then - bifall=50._kind_phys + 1.7_kind_phys*(forc_t(g) - tfrz + 15._kind_phys)**1.5_kind_phys + if (forc_t(g) > tfrz + 2._kind_lake) then + bifall=50._kind_lake + 1.7_kind_lake*(17.0_kind_lake)**1.5_kind_lake + else if (forc_t(g) > tfrz - 15._kind_lake) then + bifall=50._kind_lake + 1.7_kind_lake*(forc_t(g) - tfrz + 15._kind_lake)**1.5_kind_lake else - bifall=50._kind_phys + bifall=50._kind_lake end if dz_snowf = qflx_snow_grnd_col(c)/bifall snowdp(c) = snowdp(c) + dz_snowf*dtime @@ -3419,9 +3429,9 @@ subroutine ShalLakeHydrology(dz_lake,forc_rain,forc_snow, & end if ! if (itype(l)==istwet .and. t_grnd(c)>tfrz) then - ! h2osno(c)=0._kind_phys - ! snowdp(c)=0._kind_phys - ! snowage(c)=0._kind_phys + ! h2osno(c)=0._kind_lake + ! snowdp(c)=0._kind_lake + ! snowage(c)=0._kind_lake ! end if ! Take care of this later in function. @@ -3430,17 +3440,17 @@ subroutine ShalLakeHydrology(dz_lake,forc_rain,forc_snow, & ! as the surface air temperature newnode = 0 ! flag for when snow node will be initialized - if (snl(c) == 0 .and. qflx_snow_grnd_col(c) > 0.0_kind_phys .and. snowdp(c) >= 0.01_kind_phys) then + if (snl(c) == 0 .and. qflx_snow_grnd_col(c) > 0.0_kind_lake .and. snowdp(c) >= 0.01_kind_lake) then newnode = 1 snl(c) = -1 dz(c,0) = snowdp(c) ! meter - z(c,0) = -0.5_kind_phys*dz(c,0) + z(c,0) = -0.5_kind_lake*dz(c,0) zi(c,-1) = -dz(c,0) - snowage(c) = 0._kind_phys ! snow age + snowage(c) = 0._kind_lake ! snow age t_soisno(c,0) = min(tfrz, forc_t(g)) ! K h2osoi_ice(c,0) = h2osno(c) ! kg/m2 - h2osoi_liq(c,0) = 0._kind_phys ! kg/m2 - frac_iceold(c,0) = 1._kind_phys + h2osoi_liq(c,0) = 0._kind_lake ! kg/m2 + frac_iceold(c,0) = 1._kind_lake end if ! The change of ice partial density of surface node due to precipitation. @@ -3464,26 +3474,26 @@ subroutine ShalLakeHydrology(dz_lake,forc_rain,forc_snow, & jtop = snl(c)+1 ! Use column variables here - qflx_evap_grnd(c) = 0._kind_phys - qflx_sub_snow(c) = 0._kind_phys - qflx_dew_snow(c) = 0._kind_phys - qflx_dew_grnd(c) = 0._kind_phys + qflx_evap_grnd(c) = 0._kind_lake + qflx_sub_snow(c) = 0._kind_lake + qflx_dew_snow(c) = 0._kind_lake + qflx_dew_grnd(c) = 0._kind_lake if (jtop <= 0) then ! snow layers j = jtop ! Assign ground evaporation to sublimation from soil ice or to dew ! on snow or ground - if (qflx_evap_soi(p) >= 0._kind_phys) then + if (qflx_evap_soi(p) >= 0._kind_lake) then ! for evaporation partitioning between liquid evap and ice sublimation, ! use the ratio of liquid to (liquid+ice) in the top layer to determine split ! Since we're not limiting evap over lakes, but still can't remove more from top ! snow layer than there is there, create temp. limited evap_soi. qflx_evap_soi_lim = min(qflx_evap_soi(p), (h2osoi_liq(c,j)+h2osoi_ice(c,j))/dtime) - if ((h2osoi_liq(c,j)+h2osoi_ice(c,j)) > 0._kind_phys) then - qflx_evap_grnd(c) = max(qflx_evap_soi_lim*(h2osoi_liq(c,j)/(h2osoi_liq(c,j)+h2osoi_ice(c,j))), 0._kind_phys) + if ((h2osoi_liq(c,j)+h2osoi_ice(c,j)) > 0._kind_lake) then + qflx_evap_grnd(c) = max(qflx_evap_soi_lim*(h2osoi_liq(c,j)/(h2osoi_liq(c,j)+h2osoi_ice(c,j))), 0._kind_lake) else - qflx_evap_grnd(c) = 0._kind_phys + qflx_evap_grnd(c) = 0._kind_lake end if qflx_sub_snow(c) = qflx_evap_soi_lim - qflx_evap_grnd(c) else @@ -3499,13 +3509,13 @@ subroutine ShalLakeHydrology(dz_lake,forc_rain,forc_snow, & if (do_capsnow(c)) qflx_snowcap(p) = qflx_snowcap(p) + qflx_dew_snow(c) + qflx_dew_grnd(c) else ! No snow layers: do as in HydrologyLake but with actual clmtype variables - if (qflx_evap_soi(p) >= 0._kind_phys) then + if (qflx_evap_soi(p) >= 0._kind_lake) then ! Sublimation: do not allow for more sublimation than there is snow ! after melt. Remaining surface evaporation used for infiltration. qflx_sub_snow(c) = min(qflx_evap_soi(p), h2osno(c)/dtime) qflx_evap_grnd(c) = qflx_evap_soi(p) - qflx_sub_snow(c) else - if (t_grnd(c) < tfrz-0.1_kind_phys) then + if (t_grnd(c) < tfrz-0.1_kind_lake) then qflx_dew_snow(c) = abs(qflx_evap_soi(p)) else qflx_dew_grnd(c) = abs(qflx_evap_soi(p)) @@ -3520,16 +3530,16 @@ subroutine ShalLakeHydrology(dz_lake,forc_rain,forc_snow, & else h2osno(c) = h2osno(c) + (-qflx_sub_snow(c)+qflx_dew_snow(c))*dtime end if - if (h2osno_temp > 0._kind_phys) then + if (h2osno_temp > 0._kind_lake) then snowdp(c) = snowdp(c) * h2osno(c) / h2osno_temp else snowdp(c) = h2osno(c)/snow_bd !Assume a constant snow bulk density = 250. end if if (PERGRO) then - if (abs(h2osno(c)) < 1.e-10_kind_phys) h2osno(c) = 0._kind_phys + if (abs(h2osno(c)) < 1.e-10_kind_lake) h2osno(c) = 0._kind_lake else - h2osno(c) = max(h2osno(c), 0._kind_phys) + h2osno(c) = max(h2osno(c), 0._kind_lake) endif end if @@ -3611,7 +3621,7 @@ subroutine ShalLakeHydrology(dz_lake,forc_rain,forc_snow, & do fc = 1, num_shlakesnowc c = filter_shlakesnowc(fc) - h2osno(c) = 0._kind_phys + h2osno(c) = 0._kind_lake end do do j = -nlevsnow+1,0 do fc = 1, num_shlakesnowc @@ -3634,7 +3644,7 @@ subroutine ShalLakeHydrology(dz_lake,forc_rain,forc_snow, & do fc = 1, num_shlakec c = filter_shlakec(fc) - if (t_lake(c,1) > tfrz .and. lake_icefrac(c,1) == 0._kind_phys .and. snl(c) < 0) then + if (t_lake(c,1) > tfrz .and. lake_icefrac(c,1) == 0._kind_lake .and. snl(c) < 0) then unfrozen(c) = .true. else unfrozen(c) = .false. @@ -3649,8 +3659,8 @@ subroutine ShalLakeHydrology(dz_lake,forc_rain,forc_snow, & if (unfrozen(c)) then if (j == -nlevsnow+1) then - sumsnowice(c) = 0._kind_phys - heatsum(c) = 0._kind_phys + sumsnowice(c) = 0._kind_lake + heatsum(c) = 0._kind_lake end if if (j >= snl(c)+1) then sumsnowice(c) = sumsnowice(c) + h2osoi_ice(c,j) @@ -3670,16 +3680,16 @@ subroutine ShalLakeHydrology(dz_lake,forc_rain,forc_snow, & heatsum(c) = heatsum(c) + sumsnowice(c)*hfus heatrem = (t_lake(c,1) - tfrz)*cpliq*denh2o*dz_lake(c,1) - heatsum(c) - if (heatrem + denh2o*dz_lake(c,1)*hfus > 0._kind_phys) then + if (heatrem + denh2o*dz_lake(c,1)*hfus > 0._kind_lake) then ! Remove snow and subtract the latent heat from the top layer. - h2osno(c) = 0._kind_phys + h2osno(c) = 0._kind_lake snl(c) = 0 ! The rest of the bookkeeping for the removed snow will be done below. if (LAKEDEBUG) then print *,'Snow layers removed above unfrozen lake for column, snowice:', & c, sumsnowice(c) endif - if (heatrem > 0._kind_phys) then ! simply subtract the heat from the layer + if (heatrem > 0._kind_lake) then ! simply subtract the heat from the layer t_lake(c,1) = t_lake(c,1) - heatrem/(cpliq*denh2o*dz_lake(c,1)) else !freeze part of the layer t_lake(c,1) = tfrz @@ -3697,7 +3707,7 @@ subroutine ShalLakeHydrology(dz_lake,forc_rain,forc_snow, & do fc = 1, num_shlakesnowc c = filter_shlakesnowc(fc) if (snl(c) == 0) then - snowage(c) = 0._kind_phys + snowage(c) = 0._kind_lake end if end do @@ -3709,12 +3719,12 @@ subroutine ShalLakeHydrology(dz_lake,forc_rain,forc_snow, & do fc = 1, num_shlakesnowc c = filter_shlakesnowc(fc) if (j <= snl(c) .and. snl(c) > -nlevsnow) then - h2osoi_ice(c,j) = 0._kind_phys - h2osoi_liq(c,j) = 0._kind_phys - t_soisno(c,j) = 0._kind_phys - dz(c,j) = 0._kind_phys - z(c,j) = 0._kind_phys - zi(c,j-1) = 0._kind_phys + h2osoi_ice(c,j) = 0._kind_lake + h2osoi_liq(c,j) = 0._kind_lake + t_soisno(c,j) = 0._kind_lake + dz(c,j) = 0._kind_lake + z(c,j) = 0._kind_lake + zi(c,j-1) = 0._kind_lake end if end do end do @@ -3731,9 +3741,9 @@ subroutine ShalLakeHydrology(dz_lake,forc_rain,forc_snow, & !cdir nodep do fc = 1, num_shlakesnowc c = filter_shlakesnowc(fc) - t_snow(c) = 0._kind_phys - snowice(c) = 0._kind_phys - snowliq(c) = 0._kind_phys + t_snow(c) = 0._kind_lake + snowice(c) = 0._kind_lake + snowliq(c) = 0._kind_lake end do !dir$ concurrent !cdir nodep @@ -3788,10 +3798,10 @@ subroutine ShalLakeHydrology(dz_lake,forc_rain,forc_snow, & c = filter_shlakec(fc) jtop = snl(c)+1 - if(j == jtop) snow_water(c) = 0._kind_phys + if(j == jtop) snow_water(c) = 0._kind_lake if(j >= jtop) then snow_water(c) = snow_water(c) + h2osoi_ice(c,j) + h2osoi_liq(c,j) - if(j == 0 .and. abs(snow_water(c)-h2osno(c))>1.e-7_kind_phys) then + if(j == 0 .and. abs(snow_water(c)-h2osno(c))>1.e-7_kind_lake) then write(message,*)'h2osno does not equal sum of snow layers in ShalLakeHydrology:', & 'column, h2osno, sum of snow layers =', c, h2osno(c), snow_water(c) ! errmsg=trim(message) @@ -3813,9 +3823,9 @@ subroutine ShalLakeHydrology(dz_lake,forc_rain,forc_snow, & c = pcolumn(p) g = pgridcell(p) - qflx_infl(c) = 0._kind_phys - qflx_surf(c) = 0._kind_phys - qflx_drain(c) = 0._kind_phys + qflx_infl(c) = 0._kind_lake + qflx_surf(c) = 0._kind_lake + qflx_drain(c) = 0._kind_lake rootr_column(c,:) = spval soilalpha(c) = spval zwt(c) = spval @@ -3849,12 +3859,12 @@ subroutine QSat (T, p, es, esdT, qs, qsdT) ! ! !ARGUMENTS: implicit none - real(kind_phys), intent(in) :: T ! temperature (K) - real(kind_phys), intent(in) :: p ! surface atmospheric pressure (pa) - real(kind_phys), intent(out) :: es ! vapor pressure (pa) - real(kind_phys), intent(out) :: esdT ! d(es)/d(T) - real(kind_phys), intent(out) :: qs ! humidity (kg/kg) - real(kind_phys), intent(out) :: qsdT ! d(qs)/d(T) + real(kind_lake), intent(in) :: T ! temperature (K) + real(kind_lake), intent(in) :: p ! surface atmospheric pressure (pa) + real(kind_lake), intent(out) :: es ! vapor pressure (pa) + real(kind_lake), intent(out) :: esdT ! d(es)/d(T) + real(kind_lake), intent(out) :: qs ! humidity (kg/kg) + real(kind_lake), intent(out) :: qsdT ! d(qs)/d(T) ! ! !CALLED FROM: ! subroutine Biogeophysics1 in module Biogeophysics1Mod @@ -3869,56 +3879,56 @@ subroutine QSat (T, p, es, esdT, qs, qsdT) ! ! !LOCAL VARIABLES: ! - real(kind_phys) :: T_limit - real(kind_phys) :: td,vp,vp1,vp2 + real(kind_lake) :: T_limit + real(kind_lake) :: td,vp,vp1,vp2 ! ! For water vapor (temperature range 0C-100C) ! - real(kind_phys), parameter :: a0 = 6.11213476 - real(kind_phys), parameter :: a1 = 0.444007856 - real(kind_phys), parameter :: a2 = 0.143064234e-01 - real(kind_phys), parameter :: a3 = 0.264461437e-03 - real(kind_phys), parameter :: a4 = 0.305903558e-05 - real(kind_phys), parameter :: a5 = 0.196237241e-07 - real(kind_phys), parameter :: a6 = 0.892344772e-10 - real(kind_phys), parameter :: a7 = -0.373208410e-12 - real(kind_phys), parameter :: a8 = 0.209339997e-15 + real(kind_lake), parameter :: a0 = 6.11213476 + real(kind_lake), parameter :: a1 = 0.444007856 + real(kind_lake), parameter :: a2 = 0.143064234e-01 + real(kind_lake), parameter :: a3 = 0.264461437e-03 + real(kind_lake), parameter :: a4 = 0.305903558e-05 + real(kind_lake), parameter :: a5 = 0.196237241e-07 + real(kind_lake), parameter :: a6 = 0.892344772e-10 + real(kind_lake), parameter :: a7 = -0.373208410e-12 + real(kind_lake), parameter :: a8 = 0.209339997e-15 ! ! For derivative:water vapor ! - real(kind_phys), parameter :: b0 = 0.444017302 - real(kind_phys), parameter :: b1 = 0.286064092e-01 - real(kind_phys), parameter :: b2 = 0.794683137e-03 - real(kind_phys), parameter :: b3 = 0.121211669e-04 - real(kind_phys), parameter :: b4 = 0.103354611e-06 - real(kind_phys), parameter :: b5 = 0.404125005e-09 - real(kind_phys), parameter :: b6 = -0.788037859e-12 - real(kind_phys), parameter :: b7 = -0.114596802e-13 - real(kind_phys), parameter :: b8 = 0.381294516e-16 + real(kind_lake), parameter :: b0 = 0.444017302 + real(kind_lake), parameter :: b1 = 0.286064092e-01 + real(kind_lake), parameter :: b2 = 0.794683137e-03 + real(kind_lake), parameter :: b3 = 0.121211669e-04 + real(kind_lake), parameter :: b4 = 0.103354611e-06 + real(kind_lake), parameter :: b5 = 0.404125005e-09 + real(kind_lake), parameter :: b6 = -0.788037859e-12 + real(kind_lake), parameter :: b7 = -0.114596802e-13 + real(kind_lake), parameter :: b8 = 0.381294516e-16 ! ! For ice (temperature range -75C-0C) ! - real(kind_phys), parameter :: c0 = 6.11123516 - real(kind_phys), parameter :: c1 = 0.503109514 - real(kind_phys), parameter :: c2 = 0.188369801e-01 - real(kind_phys), parameter :: c3 = 0.420547422e-03 - real(kind_phys), parameter :: c4 = 0.614396778e-05 - real(kind_phys), parameter :: c5 = 0.602780717e-07 - real(kind_phys), parameter :: c6 = 0.387940929e-09 - real(kind_phys), parameter :: c7 = 0.149436277e-11 - real(kind_phys), parameter :: c8 = 0.262655803e-14 + real(kind_lake), parameter :: c0 = 6.11123516 + real(kind_lake), parameter :: c1 = 0.503109514 + real(kind_lake), parameter :: c2 = 0.188369801e-01 + real(kind_lake), parameter :: c3 = 0.420547422e-03 + real(kind_lake), parameter :: c4 = 0.614396778e-05 + real(kind_lake), parameter :: c5 = 0.602780717e-07 + real(kind_lake), parameter :: c6 = 0.387940929e-09 + real(kind_lake), parameter :: c7 = 0.149436277e-11 + real(kind_lake), parameter :: c8 = 0.262655803e-14 ! ! For derivative:ice ! - real(kind_phys), parameter :: d0 = 0.503277922 - real(kind_phys), parameter :: d1 = 0.377289173e-01 - real(kind_phys), parameter :: d2 = 0.126801703e-02 - real(kind_phys), parameter :: d3 = 0.249468427e-04 - real(kind_phys), parameter :: d4 = 0.313703411e-06 - real(kind_phys), parameter :: d5 = 0.257180651e-08 - real(kind_phys), parameter :: d6 = 0.133268878e-10 - real(kind_phys), parameter :: d7 = 0.394116744e-13 - real(kind_phys), parameter :: d8 = 0.498070196e-16 + real(kind_lake), parameter :: d0 = 0.503277922 + real(kind_lake), parameter :: d1 = 0.377289173e-01 + real(kind_lake), parameter :: d2 = 0.126801703e-02 + real(kind_lake), parameter :: d3 = 0.249468427e-04 + real(kind_lake), parameter :: d4 = 0.313703411e-06 + real(kind_lake), parameter :: d5 = 0.257180651e-08 + real(kind_lake), parameter :: d6 = 0.133268878e-10 + real(kind_lake), parameter :: d7 = 0.394116744e-13 + real(kind_lake), parameter :: d8 = 0.498070196e-16 !----------------------------------------------------------------------- T_limit = T - tfrz @@ -3964,11 +3974,11 @@ subroutine Tridiagonal (lbc, ubc, lbj, ubj, jtop, numf, filter, & integer , intent(in) :: jtop(lbc:ubc) ! top level for each column integer , intent(in) :: numf ! filter dimension integer , intent(in) :: filter(1:numf) ! filter - real(kind_phys), intent(in) :: a(lbc:ubc, lbj:ubj) ! "a" left off diagonal of tridiagonal matrix - real(kind_phys), intent(in) :: b(lbc:ubc, lbj:ubj) ! "b" diagonal column for tridiagonal matrix - real(kind_phys), intent(in) :: c(lbc:ubc, lbj:ubj) ! "c" right off diagonal tridiagonal matrix - real(kind_phys), intent(in) :: r(lbc:ubc, lbj:ubj) ! "r" forcing term of tridiagonal matrix - real(kind_phys), intent(inout) :: u(lbc:ubc, lbj:ubj) ! solution + real(kind_lake), intent(in) :: a(lbc:ubc, lbj:ubj) ! "a" left off diagonal of tridiagonal matrix + real(kind_lake), intent(in) :: b(lbc:ubc, lbj:ubj) ! "b" diagonal column for tridiagonal matrix + real(kind_lake), intent(in) :: c(lbc:ubc, lbj:ubj) ! "c" right off diagonal tridiagonal matrix + real(kind_lake), intent(in) :: r(lbc:ubc, lbj:ubj) ! "r" forcing term of tridiagonal matrix + real(kind_lake), intent(inout) :: u(lbc:ubc, lbj:ubj) ! solution ! ! !CALLED FROM: ! subroutine BiogeophysicsLake in module BiogeophysicsLakeMod @@ -3985,8 +3995,8 @@ subroutine Tridiagonal (lbc, ubc, lbj, ubj, jtop, numf, filter, & ! !OTHER LOCAL VARIABLES: ! integer :: j,ci,fc !indices - real(kind_phys) :: gam(lbc:ubc,lbj:ubj) !temporary - real(kind_phys) :: bet(lbc:ubc) !temporary + real(kind_lake) :: gam(lbc:ubc,lbj:ubj) !temporary + real(kind_lake) :: bet(lbc:ubc) !temporary !----------------------------------------------------------------------- ! Solve the matrix @@ -4073,35 +4083,35 @@ subroutine SnowWater(lbc, ubc, num_snowc, filter_snowc, & !i integer , intent(in) :: snl(1) !number of snow layers logical , intent(in) :: do_capsnow(1) !true => do snow capping - real(kind_phys), intent(in) :: dtime !timestep - real(kind_phys), intent(in) :: qflx_snomelt(1) !snow melt (mm H2O /s) - real(kind_phys), intent(in) :: qflx_rain_grnd(1) !rain on ground after interception (mm H2O/s) [+] - real(kind_phys), intent(in) :: qflx_sub_snow(1) !sublimation rate from snow pack (mm H2O /s) [+] - real(kind_phys), intent(in) :: qflx_evap_grnd(1) !ground surface evaporation rate (mm H2O/s) [+] - real(kind_phys), intent(in) :: qflx_dew_snow(1) !surface dew added to snow pack (mm H2O /s) [+] - real(kind_phys), intent(in) :: qflx_dew_grnd(1) !ground surface dew formation (mm H2O /s) [+] - real(kind_phys), intent(in) :: dz(1,-nlevsnow+1:nlevsoil) !layer depth (m) + real(kind_lake), intent(in) :: dtime !timestep + real(kind_lake), intent(in) :: qflx_snomelt(1) !snow melt (mm H2O /s) + real(kind_lake), intent(in) :: qflx_rain_grnd(1) !rain on ground after interception (mm H2O/s) [+] + real(kind_lake), intent(in) :: qflx_sub_snow(1) !sublimation rate from snow pack (mm H2O /s) [+] + real(kind_lake), intent(in) :: qflx_evap_grnd(1) !ground surface evaporation rate (mm H2O/s) [+] + real(kind_lake), intent(in) :: qflx_dew_snow(1) !surface dew added to snow pack (mm H2O /s) [+] + real(kind_lake), intent(in) :: qflx_dew_grnd(1) !ground surface dew formation (mm H2O /s) [+] + real(kind_lake), intent(in) :: dz(1,-nlevsnow+1:nlevsoil) !layer depth (m) !inout: - real(kind_phys), intent(inout) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) !ice lens (kg/m2) - real(kind_phys), intent(inout) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) !liquid water (kg/m2) + real(kind_lake), intent(inout) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) !ice lens (kg/m2) + real(kind_lake), intent(inout) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) !liquid water (kg/m2) !out: - real(kind_phys), intent(out) :: qflx_top_soil(1) !net water input into soil from top (mm/s) + real(kind_lake), intent(out) :: qflx_top_soil(1) !net water input into soil from top (mm/s) ! OTHER LOCAL VARIABLES: integer :: c, j, fc !do loop/array indices - real(kind_phys) :: qin(lbc:ubc) !water flow into the elmement (mm/s) - real(kind_phys) :: qout(lbc:ubc) !water flow out of the elmement (mm/s) - real(kind_phys) :: wgdif !ice mass after minus sublimation - real(kind_phys) :: vol_liq(lbc:ubc,-nlevsnow+1:0) !partial volume of liquid water in layer - real(kind_phys) :: vol_ice(lbc:ubc,-nlevsnow+1:0) !partial volume of ice lens in layer - real(kind_phys) :: eff_porosity(lbc:ubc,-nlevsnow+1:0) !effective porosity = porosity - vol_ice + real(kind_lake) :: qin(lbc:ubc) !water flow into the elmement (mm/s) + real(kind_lake) :: qout(lbc:ubc) !water flow out of the elmement (mm/s) + real(kind_lake) :: wgdif !ice mass after minus sublimation + real(kind_lake) :: vol_liq(lbc:ubc,-nlevsnow+1:0) !partial volume of liquid water in layer + real(kind_lake) :: vol_ice(lbc:ubc,-nlevsnow+1:0) !partial volume of ice lens in layer + real(kind_lake) :: eff_porosity(lbc:ubc,-nlevsnow+1:0) !effective porosity = porosity - vol_ice !----------------------------------------------------------------------- ! Renew the mass of ice lens (h2osoi_ice) and liquid (h2osoi_liq) in the ! surface snow layer resulting from sublimation (frost) / evaporation (condense) @@ -4128,7 +4138,7 @@ subroutine SnowWater(lbc, ubc, num_snowc, filter_snowc, & !i h2osoi_liq(c,snl(c)+1) = h2osoi_liq(c,snl(c)+1) + & (qflx_rain_grnd(c) + qflx_dew_grnd(c) - qflx_evap_grnd(c)) * dtime end if - h2osoi_liq(c,snl(c)+1) = max(0._kind_phys, h2osoi_liq(c,snl(c)+1)) + h2osoi_liq(c,snl(c)+1) = max(0._kind_lake, h2osoi_liq(c,snl(c)+1)) end do ! Porosity and partial volume @@ -4139,7 +4149,7 @@ subroutine SnowWater(lbc, ubc, num_snowc, filter_snowc, & !i do fc = 1, num_snowc c = filter_snowc(fc) if (j >= snl(c)+1) then - vol_ice(c,j) = min(1._kind_phys, h2osoi_ice(c,j)/(dz(c,j)*denice)) + vol_ice(c,j) = min(1._kind_lake, h2osoi_ice(c,j)/(dz(c,j)*denice)) eff_porosity(c,j) = 1. - vol_ice(c,j) vol_liq(c,j) = min(eff_porosity(c,j),h2osoi_liq(c,j)/(dz(c,j)*denh2o)) end if @@ -4154,7 +4164,7 @@ subroutine SnowWater(lbc, ubc, num_snowc, filter_snowc, & !i ! when the liquid water of layer exceeds the layer's holding ! capacity, the excess meltwater adds to the underlying neighbor layer. - qin(:) = 0._kind_phys + qin(:) = 0._kind_lake do j = -nlevsnow+1, 0 !dir$ concurrent @@ -4166,13 +4176,13 @@ subroutine SnowWater(lbc, ubc, num_snowc, filter_snowc, & !i if (j <= -1) then ! No runoff over snow surface, just ponding on surface if (eff_porosity(c,j) < wimp .OR. eff_porosity(c,j+1) < wimp) then - qout(c) = 0._kind_phys + qout(c) = 0._kind_lake else - qout(c) = max(0._kind_phys,(vol_liq(c,j)-ssi*eff_porosity(c,j))*dz(c,j)) + qout(c) = max(0._kind_lake,(vol_liq(c,j)-ssi*eff_porosity(c,j))*dz(c,j)) qout(c) = min(qout(c),(1.-vol_ice(c,j+1)-vol_liq(c,j+1))*dz(c,j+1)) end if else - qout(c) = max(0._kind_phys,(vol_liq(c,j) - ssi*eff_porosity(c,j))*dz(c,j)) + qout(c) = max(0._kind_lake,(vol_liq(c,j) - ssi*eff_porosity(c,j))*dz(c,j)) end if qout(c) = qout(c)*1000. h2osoi_liq(c,j) = h2osoi_liq(c,j) - qout(c) @@ -4234,43 +4244,43 @@ subroutine SnowCompaction(lbc, ubc, num_snowc, filter_snowc, &!i integer, intent(in) :: filter_snowc(ubc-lbc+1) ! column filter for snow points integer, intent(in) :: snl(1) !number of snow layers integer, intent(in) :: imelt(1,-nlevsnow+1:nlevsoil) !flag for melting (=1), freezing (=2), Not=0 - real(kind_phys), intent(in) :: dtime - real(kind_phys), intent(in) :: frac_iceold(1,-nlevsnow+1:nlevsoil) !fraction of ice relative to the tot water - real(kind_phys), intent(in) :: t_soisno(1,-nlevsnow+1:nlevsoil) !soil temperature (Kelvin) - real(kind_phys), intent(in) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) !ice lens (kg/m2) - real(kind_phys), intent(in) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) !liquid water (kg/m2) + real(kind_lake), intent(in) :: dtime + real(kind_lake), intent(in) :: frac_iceold(1,-nlevsnow+1:nlevsoil) !fraction of ice relative to the tot water + real(kind_lake), intent(in) :: t_soisno(1,-nlevsnow+1:nlevsoil) !soil temperature (Kelvin) + real(kind_lake), intent(in) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) !ice lens (kg/m2) + real(kind_lake), intent(in) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) !liquid water (kg/m2) !inout: - real(kind_phys), intent(inout) :: dz(1,-nlevsnow+1:nlevsoil) !layer depth (m) + real(kind_lake), intent(inout) :: dz(1,-nlevsnow+1:nlevsoil) !layer depth (m) ! OTHER LOCAL VARIABLES: integer :: j, c, fc ! indices - real(kind_phys), parameter :: c2 = 23.e-3 ! [m3/kg] - real(kind_phys), parameter :: c3 = 2.777e-6 ! [1/s] - real(kind_phys), parameter :: c4 = 0.04 ! [1/K] - real(kind_phys), parameter :: c5 = 2.0 ! - real(kind_phys), parameter :: dm = 100.0 ! Upper Limit on Destructive Metamorphism Compaction [kg/m3] - real(kind_phys), parameter :: eta0 = 9.e+5 ! The Viscosity Coefficient Eta0 [kg-s/m2] - real(kind_phys) :: burden(lbc:ubc) ! pressure of overlying snow [kg/m2] - real(kind_phys) :: ddz1 ! Rate of settling of snowpack due to destructive metamorphism. - real(kind_phys) :: ddz2 ! Rate of compaction of snowpack due to overburden. - real(kind_phys) :: ddz3 ! Rate of compaction of snowpack due to melt [1/s] - real(kind_phys) :: dexpf ! expf=exp(-c4*(273.15-t_soisno)). - real(kind_phys) :: fi ! Fraction of ice relative to the total water content at current time step - real(kind_phys) :: td ! t_soisno - tfrz [K] - real(kind_phys) :: pdzdtc ! Nodal rate of change in fractional-thickness due to compaction [fraction/s] - real(kind_phys) :: void ! void (1 - vol_ice - vol_liq) - real(kind_phys) :: wx ! water mass (ice+liquid) [kg/m2] - real(kind_phys) :: bi ! partial density of ice [kg/m3] + real(kind_lake), parameter :: c2 = 23.e-3 ! [m3/kg] + real(kind_lake), parameter :: c3 = 2.777e-6 ! [1/s] + real(kind_lake), parameter :: c4 = 0.04 ! [1/K] + real(kind_lake), parameter :: c5 = 2.0 ! + real(kind_lake), parameter :: dm = 100.0 ! Upper Limit on Destructive Metamorphism Compaction [kg/m3] + real(kind_lake), parameter :: eta0 = 9.e+5 ! The Viscosity Coefficient Eta0 [kg-s/m2] + real(kind_lake) :: burden(lbc:ubc) ! pressure of overlying snow [kg/m2] + real(kind_lake) :: ddz1 ! Rate of settling of snowpack due to destructive metamorphism. + real(kind_lake) :: ddz2 ! Rate of compaction of snowpack due to overburden. + real(kind_lake) :: ddz3 ! Rate of compaction of snowpack due to melt [1/s] + real(kind_lake) :: dexpf ! expf=exp(-c4*(273.15-t_soisno)). + real(kind_lake) :: fi ! Fraction of ice relative to the total water content at current time step + real(kind_lake) :: td ! t_soisno - tfrz [K] + real(kind_lake) :: pdzdtc ! Nodal rate of change in fractional-thickness due to compaction [fraction/s] + real(kind_lake) :: void ! void (1 - vol_ice - vol_liq) + real(kind_lake) :: wx ! water mass (ice+liquid) [kg/m2] + real(kind_lake) :: bi ! partial density of ice [kg/m3] !----------------------------------------------------------------------- ! Begin calculation - note that the following column loops are only invoked if snl(c) < 0 - burden(:) = 0._kind_phys + burden(:) = 0._kind_lake do j = -nlevsnow+1, 0 !dir$ concurrent @@ -4305,9 +4315,9 @@ subroutine SnowCompaction(lbc, ubc, num_snowc, filter_snowc, &!i ! Compaction occurring during melt if (imelt(c,j) == 1) then - ddz3 = - 1./dtime * max(0._kind_phys,(frac_iceold(c,j) - fi)/frac_iceold(c,j)) + ddz3 = - 1./dtime * max(0._kind_lake,(frac_iceold(c,j) - fi)/frac_iceold(c,j)) else - ddz3 = 0._kind_phys + ddz3 = 0._kind_lake end if ! Time rate of fractional change in dz (units of s-1) @@ -4362,17 +4372,17 @@ subroutine CombineSnowLayers(lbc, ubc, & !i integer, intent(inout) :: num_snowc ! number of column snow points in column filter integer, intent(inout) :: filter_snowc(ubc-lbc+1) ! column filter for snow points integer , intent(inout) :: snl(1) !number of snow layers - real(kind_phys), intent(inout) :: h2osno(1) !snow water (mm H2O) - real(kind_phys), intent(inout) :: snowdp(1) !snow height (m) - real(kind_phys), intent(inout) :: dz(1,-nlevsnow+1:nlevsoil) !layer depth (m) - real(kind_phys), intent(inout) :: zi(1,-nlevsnow+0:nlevsoil) !interface level below a "z" level (m) - real(kind_phys), intent(inout) :: t_soisno(1,-nlevsnow+1:nlevsoil) !soil temperature (Kelvin) - real(kind_phys), intent(inout) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) !ice lens (kg/m2) - real(kind_phys), intent(inout) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) !liquid water (kg/m2) + real(kind_lake), intent(inout) :: h2osno(1) !snow water (mm H2O) + real(kind_lake), intent(inout) :: snowdp(1) !snow height (m) + real(kind_lake), intent(inout) :: dz(1,-nlevsnow+1:nlevsoil) !layer depth (m) + real(kind_lake), intent(inout) :: zi(1,-nlevsnow+0:nlevsoil) !interface level below a "z" level (m) + real(kind_lake), intent(inout) :: t_soisno(1,-nlevsnow+1:nlevsoil) !soil temperature (Kelvin) + real(kind_lake), intent(inout) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) !ice lens (kg/m2) + real(kind_lake), intent(inout) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) !liquid water (kg/m2) !out: - real(kind_phys), intent(out) :: z(1,-nlevsnow+1:nlevsoil) !layer thickness (m) + real(kind_lake), intent(out) :: z(1,-nlevsnow+1:nlevsoil) !layer thickness (m) ! !EOP ! @@ -4384,9 +4394,9 @@ subroutine CombineSnowLayers(lbc, ubc, & !i integer :: msn_old(lbc:ubc) ! number of top snow layer integer :: mssi(lbc:ubc) ! node index integer :: neibor ! adjacent node selected for combination - real(kind_phys):: zwice(lbc:ubc) ! total ice mass in snow - real(kind_phys):: zwliq (lbc:ubc) ! total liquid water in snow - real(kind_phys), parameter :: dzmin(5) = & ! minimum of top snow layer + real(kind_lake):: zwice(lbc:ubc) ! total ice mass in snow + real(kind_lake):: zwliq (lbc:ubc) ! total liquid water in snow + real(kind_lake), parameter :: dzmin(5) = & ! minimum of top snow layer (/0.010, 0.015, 0.025, 0.055, 0.115/) !----------------------------------------------------------------------- @@ -4433,10 +4443,10 @@ subroutine CombineSnowLayers(lbc, ubc, & !i !cdir nodep do fc = 1, num_snowc c = filter_snowc(fc) - h2osno(c) = 0._kind_phys - snowdp(c) = 0._kind_phys - zwice(c) = 0._kind_phys - zwliq(c) = 0._kind_phys + h2osno(c) = 0._kind_lake + snowdp(c) = 0._kind_lake + zwice(c) = 0._kind_lake + zwliq(c) = 0._kind_lake end do do j = -nlevsnow+1,0 @@ -4464,7 +4474,7 @@ subroutine CombineSnowLayers(lbc, ubc, & !i if (snowdp(c) < 0.01 .and. snowdp(c) > 0.) then snl(c) = 0 h2osno(c) = zwice(c) - if (h2osno(c) <= 0.) snowdp(c) = 0._kind_phys + if (h2osno(c) <= 0.) snowdp(c) = 0._kind_lake ! if (ityplun(l) == istsoil) h2osoi_liq(c,1) = h2osoi_liq(c,1) + zwliq(c) !change by guhp end if end do @@ -4583,30 +4593,30 @@ subroutine DivideSnowLayers(lbc, ubc, & !i integer, intent(inout) :: num_snowc ! number of column snow points in column filter integer, intent(inout) :: filter_snowc(ubc-lbc+1) ! column filter for snow points integer , intent(inout) :: snl(1) !number of snow layers - real(kind_phys), intent(inout) :: dz(1,-nlevsnow+1:nlevsoil) !layer depth (m) - real(kind_phys), intent(inout) :: zi(1,-nlevsnow+0:nlevsoil) !interface level below a "z" level (m) - real(kind_phys), intent(inout) :: t_soisno(1,-nlevsnow+1:nlevsoil) !soil temperature (Kelvin) - real(kind_phys), intent(inout) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) !ice lens (kg/m2) - real(kind_phys), intent(inout) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) !liquid water (kg/m2) + real(kind_lake), intent(inout) :: dz(1,-nlevsnow+1:nlevsoil) !layer depth (m) + real(kind_lake), intent(inout) :: zi(1,-nlevsnow+0:nlevsoil) !interface level below a "z" level (m) + real(kind_lake), intent(inout) :: t_soisno(1,-nlevsnow+1:nlevsoil) !soil temperature (Kelvin) + real(kind_lake), intent(inout) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) !ice lens (kg/m2) + real(kind_lake), intent(inout) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) !liquid water (kg/m2) !out: - real(kind_phys), intent(out) :: z(1,-nlevsnow+1:nlevsoil) !layer thickness (m) + real(kind_lake), intent(out) :: z(1,-nlevsnow+1:nlevsoil) !layer thickness (m) ! OTHER LOCAL VARIABLES: integer :: j, c, fc ! indices - real(kind_phys) :: drr ! thickness of the combined [m] + real(kind_lake) :: drr ! thickness of the combined [m] integer :: msno ! number of snow layer 1 (top) to msno (bottom) - real(kind_phys) :: dzsno(lbc:ubc,nlevsnow) ! Snow layer thickness [m] - real(kind_phys) :: swice(lbc:ubc,nlevsnow) ! Partial volume of ice [m3/m3] - real(kind_phys) :: swliq(lbc:ubc,nlevsnow) ! Partial volume of liquid water [m3/m3] - real(kind_phys) :: tsno(lbc:ubc ,nlevsnow) ! Nodel temperature [K] - real(kind_phys) :: zwice ! temporary - real(kind_phys) :: zwliq ! temporary - real(kind_phys) :: propor ! temporary + real(kind_lake) :: dzsno(lbc:ubc,nlevsnow) ! Snow layer thickness [m] + real(kind_lake) :: swice(lbc:ubc,nlevsnow) ! Partial volume of ice [m3/m3] + real(kind_lake) :: swliq(lbc:ubc,nlevsnow) ! Partial volume of liquid water [m3/m3] + real(kind_lake) :: tsno(lbc:ubc ,nlevsnow) ! Nodel temperature [K] + real(kind_lake) :: zwice ! temporary + real(kind_lake) :: zwliq ! temporary + real(kind_lake) :: propor ! temporary !----------------------------------------------------------------------- ! Begin calculation - note that the following column loops are only invoked @@ -4792,14 +4802,14 @@ subroutine Combo(dz, wliq, wice, t, dz2, wliq2, wice2, t2) ! ! !ARGUMENTS: implicit none - real(kind_phys), intent(in) :: dz2 ! nodal thickness of 2 elements being combined [m] - real(kind_phys), intent(in) :: wliq2 ! liquid water of element 2 [kg/m2] - real(kind_phys), intent(in) :: wice2 ! ice of element 2 [kg/m2] - real(kind_phys), intent(in) :: t2 ! nodal temperature of element 2 [K] - real(kind_phys), intent(inout) :: dz ! nodal thickness of 1 elements being combined [m] - real(kind_phys), intent(inout) :: wliq ! liquid water of element 1 - real(kind_phys), intent(inout) :: wice ! ice of element 1 [kg/m2] - real(kind_phys), intent(inout) :: t ! nodel temperature of elment 1 [K] + real(kind_lake), intent(in) :: dz2 ! nodal thickness of 2 elements being combined [m] + real(kind_lake), intent(in) :: wliq2 ! liquid water of element 2 [kg/m2] + real(kind_lake), intent(in) :: wice2 ! ice of element 2 [kg/m2] + real(kind_lake), intent(in) :: t2 ! nodal temperature of element 2 [K] + real(kind_lake), intent(inout) :: dz ! nodal thickness of 1 elements being combined [m] + real(kind_lake), intent(inout) :: wliq ! liquid water of element 1 + real(kind_lake), intent(inout) :: wice ! ice of element 1 [kg/m2] + real(kind_lake), intent(inout) :: t ! nodel temperature of elment 1 [K] ! ! !CALLED FROM: ! subroutine CombineSnowLayers in this module @@ -4814,13 +4824,13 @@ subroutine Combo(dz, wliq, wice, t, dz2, wliq2, wice2, t2) ! ! !LOCAL VARIABLES: ! - real(kind_phys) :: dzc ! Total thickness of nodes 1 and 2 (dzc=dz+dz2). - real(kind_phys) :: wliqc ! Combined liquid water [kg/m2] - real(kind_phys) :: wicec ! Combined ice [kg/m2] - real(kind_phys) :: tc ! Combined node temperature [K] - real(kind_phys) :: h ! enthalpy of element 1 [J/m2] - real(kind_phys) :: h2 ! enthalpy of element 2 [J/m2] - real(kind_phys) :: hc ! temporary + real(kind_lake) :: dzc ! Total thickness of nodes 1 and 2 (dzc=dz+dz2). + real(kind_lake) :: wliqc ! Combined liquid water [kg/m2] + real(kind_lake) :: wicec ! Combined ice [kg/m2] + real(kind_lake) :: tc ! Combined node temperature [K] + real(kind_lake) :: h ! enthalpy of element 1 [J/m2] + real(kind_lake) :: h2 ! enthalpy of element 2 [J/m2] + real(kind_lake) :: hc ! temporary !----------------------------------------------------------------------- dzc = dz+dz2 @@ -4939,44 +4949,44 @@ subroutine FrictionVelocity(pgridcell,forc_hgt,forc_hgt_u, & !i !in: integer , intent(in) :: pgridcell(1) ! pft's gridcell index - real(kind_phys), intent(in) :: forc_hgt(1) ! atmospheric reference height (m) - real(kind_phys), intent(in) :: forc_hgt_u(1) ! observational height of wind [m] - real(kind_phys), intent(in) :: forc_hgt_t(1) ! observational height of temperature [m] - real(kind_phys), intent(in) :: forc_hgt_q(1) ! observational height of humidity [m] + real(kind_lake), intent(in) :: forc_hgt(1) ! atmospheric reference height (m) + real(kind_lake), intent(in) :: forc_hgt_u(1) ! observational height of wind [m] + real(kind_lake), intent(in) :: forc_hgt_t(1) ! observational height of temperature [m] + real(kind_lake), intent(in) :: forc_hgt_q(1) ! observational height of humidity [m] integer , intent(in) :: lbp, ubp ! pft array bounds integer , intent(in) :: fn ! number of filtered pft elements integer , intent(in) :: filterp(fn) ! pft filter - real(kind_phys), intent(in) :: displa(lbp:ubp) ! displacement height (m) - real(kind_phys), intent(in) :: z0m(lbp:ubp) ! roughness length over vegetation, momentum [m] - real(kind_phys), intent(in) :: z0h(lbp:ubp) ! roughness length over vegetation, sensible heat [m] - real(kind_phys), intent(in) :: z0q(lbp:ubp) ! roughness length over vegetation, latent heat [m] - real(kind_phys), intent(in) :: obu(lbp:ubp) ! monin-obukhov length (m) + real(kind_lake), intent(in) :: displa(lbp:ubp) ! displacement height (m) + real(kind_lake), intent(in) :: z0m(lbp:ubp) ! roughness length over vegetation, momentum [m] + real(kind_lake), intent(in) :: z0h(lbp:ubp) ! roughness length over vegetation, sensible heat [m] + real(kind_lake), intent(in) :: z0q(lbp:ubp) ! roughness length over vegetation, latent heat [m] + real(kind_lake), intent(in) :: obu(lbp:ubp) ! monin-obukhov length (m) integer, intent(in) :: iter ! iteration number - real(kind_phys), intent(in) :: ur(lbp:ubp) ! wind speed at reference height [m/s] - real(kind_phys), intent(in) :: um(lbp:ubp) ! wind speed including the stablity effect [m/s] + real(kind_lake), intent(in) :: ur(lbp:ubp) ! wind speed at reference height [m/s] + real(kind_lake), intent(in) :: um(lbp:ubp) ! wind speed including the stablity effect [m/s] !out: - real(kind_phys), intent(out) :: ustar(lbp:ubp) ! friction velocity [m/s] - real(kind_phys), intent(out) :: temp1(lbp:ubp) ! relation for potential temperature profile - real(kind_phys), intent(out) :: temp12m(lbp:ubp) ! relation for potential temperature profile applied at 2-m - real(kind_phys), intent(out) :: temp2(lbp:ubp) ! relation for specific humidity profile - real(kind_phys), intent(out) :: temp22m(lbp:ubp) ! relation for specific humidity profile applied at 2-m - real(kind_phys), intent(out) :: u10(1) ! 10-m wind (m/s) (for dust model) - real(kind_phys), intent(out) :: fv(1) ! friction velocity (m/s) (for dust model) + real(kind_lake), intent(out) :: ustar(lbp:ubp) ! friction velocity [m/s] + real(kind_lake), intent(out) :: temp1(lbp:ubp) ! relation for potential temperature profile + real(kind_lake), intent(out) :: temp12m(lbp:ubp) ! relation for potential temperature profile applied at 2-m + real(kind_lake), intent(out) :: temp2(lbp:ubp) ! relation for specific humidity profile + real(kind_lake), intent(out) :: temp22m(lbp:ubp) ! relation for specific humidity profile applied at 2-m + real(kind_lake), intent(out) :: u10(1) ! 10-m wind (m/s) (for dust model) + real(kind_lake), intent(out) :: fv(1) ! friction velocity (m/s) (for dust model) !inout: - real(kind_phys), intent(inout) :: fm(lbp:ubp) ! needed for DGVM only to diagnose 10m wind + real(kind_lake), intent(inout) :: fm(lbp:ubp) ! needed for DGVM only to diagnose 10m wind ! OTHER LOCAL VARIABLES: - real(kind_phys), parameter :: zetam = 1.574_kind_phys ! transition point of flux-gradient relation (wind profile) - real(kind_phys), parameter :: zetat = 0.465_kind_phys ! transition point of flux-gradient relation (temp. profile) + real(kind_lake), parameter :: zetam = 1.574_kind_lake ! transition point of flux-gradient relation (wind profile) + real(kind_lake), parameter :: zetat = 0.465_kind_lake ! transition point of flux-gradient relation (temp. profile) integer :: f ! pft-filter index integer :: p ! pft index integer :: g ! gridcell index - real(kind_phys):: zldis(lbp:ubp) ! reference height "minus" zero displacement heght [m] - real(kind_phys):: zeta(lbp:ubp) ! dimensionless height used in Monin-Obukhov theory + real(kind_lake):: zldis(lbp:ubp) ! reference height "minus" zero displacement heght [m] + real(kind_lake):: zeta(lbp:ubp) ! dimensionless height used in Monin-Obukhov theory !------------------------------------------------------------------------------ @@ -4999,16 +5009,16 @@ subroutine FrictionVelocity(pgridcell,forc_hgt,forc_hgt_u, & !i ustar(p) = vkc*um(p)/(log(-zetam*obu(p)/z0m(p))& - StabilityFunc1(-zetam) & + StabilityFunc1(z0m(p)/obu(p)) & - + 1.14_kind_phys*((-zeta(p))**0.333_kind_phys-(zetam)**0.333_kind_phys)) - else if (zeta(p) < 0._kind_phys) then + + 1.14_kind_lake*((-zeta(p))**0.333_kind_lake-(zetam)**0.333_kind_lake)) + else if (zeta(p) < 0._kind_lake) then ustar(p) = vkc*um(p)/(log(zldis(p)/z0m(p))& - StabilityFunc1(zeta(p))& + StabilityFunc1(z0m(p)/obu(p))) - else if (zeta(p) <= 1._kind_phys) then - ustar(p) = vkc*um(p)/(log(zldis(p)/z0m(p)) + 5._kind_phys*zeta(p) -5._kind_phys*z0m(p)/obu(p)) + else if (zeta(p) <= 1._kind_lake) then + ustar(p) = vkc*um(p)/(log(zldis(p)/z0m(p)) + 5._kind_lake*zeta(p) -5._kind_lake*z0m(p)/obu(p)) else - ustar(p) = vkc*um(p)/(log(obu(p)/z0m(p))+5._kind_phys-5._kind_phys*z0m(p)/obu(p) & - +(5._kind_phys*log(zeta(p))+zeta(p)-1._kind_phys)) + ustar(p) = vkc*um(p)/(log(obu(p)/z0m(p))+5._kind_lake-5._kind_lake*z0m(p)/obu(p) & + +(5._kind_lake*log(zeta(p))+zeta(p)-1._kind_lake)) end if ! Temperature profile @@ -5019,16 +5029,16 @@ subroutine FrictionVelocity(pgridcell,forc_hgt,forc_hgt_u, & !i temp1(p) = vkc/(log(-zetat*obu(p)/z0h(p))& - StabilityFunc2(-zetat) & + StabilityFunc2(z0h(p)/obu(p)) & - + 0.8_kind_phys*((zetat)**(-0.333_kind_phys)-(-zeta(p))**(-0.333_kind_phys))) - else if (zeta(p) < 0._kind_phys) then + + 0.8_kind_lake*((zetat)**(-0.333_kind_lake)-(-zeta(p))**(-0.333_kind_lake))) + else if (zeta(p) < 0._kind_lake) then temp1(p) = vkc/(log(zldis(p)/z0h(p)) & - StabilityFunc2(zeta(p)) & + StabilityFunc2(z0h(p)/obu(p))) - else if (zeta(p) <= 1._kind_phys) then - temp1(p) = vkc/(log(zldis(p)/z0h(p)) + 5._kind_phys*zeta(p) - 5._kind_phys*z0h(p)/obu(p)) + else if (zeta(p) <= 1._kind_lake) then + temp1(p) = vkc/(log(zldis(p)/z0h(p)) + 5._kind_lake*zeta(p) - 5._kind_lake*z0h(p)/obu(p)) else - temp1(p) = vkc/(log(obu(p)/z0h(p)) + 5._kind_phys - 5._kind_phys*z0h(p)/obu(p) & - + (5._kind_phys*log(zeta(p))+zeta(p)-1._kind_phys)) + temp1(p) = vkc/(log(obu(p)/z0h(p)) + 5._kind_lake - 5._kind_lake*z0h(p)/obu(p) & + + (5._kind_lake*log(zeta(p))+zeta(p)-1._kind_lake)) end if ! Humidity profile @@ -5042,37 +5052,37 @@ subroutine FrictionVelocity(pgridcell,forc_hgt,forc_hgt_u, & !i temp2(p) = vkc/(log(-zetat*obu(p)/z0q(p)) & - StabilityFunc2(-zetat) & + StabilityFunc2(z0q(p)/obu(p)) & - + 0.8_kind_phys*((zetat)**(-0.333_kind_phys)-(-zeta(p))**(-0.333_kind_phys))) - else if (zeta(p) < 0._kind_phys) then + + 0.8_kind_lake*((zetat)**(-0.333_kind_lake)-(-zeta(p))**(-0.333_kind_lake))) + else if (zeta(p) < 0._kind_lake) then temp2(p) = vkc/(log(zldis(p)/z0q(p)) & - StabilityFunc2(zeta(p)) & + StabilityFunc2(z0q(p)/obu(p))) - else if (zeta(p) <= 1._kind_phys) then - temp2(p) = vkc/(log(zldis(p)/z0q(p)) + 5._kind_phys*zeta(p)-5._kind_phys*z0q(p)/obu(p)) + else if (zeta(p) <= 1._kind_lake) then + temp2(p) = vkc/(log(zldis(p)/z0q(p)) + 5._kind_lake*zeta(p)-5._kind_lake*z0q(p)/obu(p)) else - temp2(p) = vkc/(log(obu(p)/z0q(p)) + 5._kind_phys - 5._kind_phys*z0q(p)/obu(p) & - + (5._kind_phys*log(zeta(p))+zeta(p)-1._kind_phys)) + temp2(p) = vkc/(log(obu(p)/z0q(p)) + 5._kind_lake - 5._kind_lake*z0q(p)/obu(p) & + + (5._kind_lake*log(zeta(p))+zeta(p)-1._kind_lake)) end if endif ! Temperature profile applied at 2-m - zldis(p) = 2.0_kind_phys + z0h(p) + zldis(p) = 2.0_kind_lake + z0h(p) zeta(p) = zldis(p)/obu(p) if (zeta(p) < -zetat) then temp12m(p) = vkc/(log(-zetat*obu(p)/z0h(p))& - StabilityFunc2(-zetat) & + StabilityFunc2(z0h(p)/obu(p)) & - + 0.8_kind_phys*((zetat)**(-0.333_kind_phys)-(-zeta(p))**(-0.333_kind_phys))) - else if (zeta(p) < 0._kind_phys) then + + 0.8_kind_lake*((zetat)**(-0.333_kind_lake)-(-zeta(p))**(-0.333_kind_lake))) + else if (zeta(p) < 0._kind_lake) then temp12m(p) = vkc/(log(zldis(p)/z0h(p)) & - StabilityFunc2(zeta(p)) & + StabilityFunc2(z0h(p)/obu(p))) - else if (zeta(p) <= 1._kind_phys) then - temp12m(p) = vkc/(log(zldis(p)/z0h(p)) + 5._kind_phys*zeta(p) - 5._kind_phys*z0h(p)/obu(p)) + else if (zeta(p) <= 1._kind_lake) then + temp12m(p) = vkc/(log(zldis(p)/z0h(p)) + 5._kind_lake*zeta(p) - 5._kind_lake*z0h(p)/obu(p)) else - temp12m(p) = vkc/(log(obu(p)/z0h(p)) + 5._kind_phys - 5._kind_phys*z0h(p)/obu(p) & - + (5._kind_phys*log(zeta(p))+zeta(p)-1._kind_phys)) + temp12m(p) = vkc/(log(obu(p)/z0h(p)) + 5._kind_lake - 5._kind_lake*z0h(p)/obu(p) & + + (5._kind_lake*log(zeta(p))+zeta(p)-1._kind_lake)) end if ! Humidity profile applied at 2-m @@ -5080,20 +5090,20 @@ subroutine FrictionVelocity(pgridcell,forc_hgt,forc_hgt_u, & !i if (z0q(p) == z0h(p)) then temp22m(p) = temp12m(p) else - zldis(p) = 2.0_kind_phys + z0q(p) + zldis(p) = 2.0_kind_lake + z0q(p) zeta(p) = zldis(p)/obu(p) if (zeta(p) < -zetat) then temp22m(p) = vkc/(log(-zetat*obu(p)/z0q(p)) - & StabilityFunc2(-zetat) + StabilityFunc2(z0q(p)/obu(p)) & - + 0.8_kind_phys*((zetat)**(-0.333_kind_phys)-(-zeta(p))**(-0.333_kind_phys))) - else if (zeta(p) < 0._kind_phys) then + + 0.8_kind_lake*((zetat)**(-0.333_kind_lake)-(-zeta(p))**(-0.333_kind_lake))) + else if (zeta(p) < 0._kind_lake) then temp22m(p) = vkc/(log(zldis(p)/z0q(p)) - & StabilityFunc2(zeta(p))+StabilityFunc2(z0q(p)/obu(p))) - else if (zeta(p) <= 1._kind_phys) then - temp22m(p) = vkc/(log(zldis(p)/z0q(p)) + 5._kind_phys*zeta(p)-5._kind_phys*z0q(p)/obu(p)) + else if (zeta(p) <= 1._kind_lake) then + temp22m(p) = vkc/(log(zldis(p)/z0q(p)) + 5._kind_lake*zeta(p)-5._kind_lake*z0q(p)/obu(p)) else - temp22m(p) = vkc/(log(obu(p)/z0q(p)) + 5._kind_phys - 5._kind_phys*z0q(p)/obu(p) & - + (5._kind_phys*log(zeta(p))+zeta(p)-1._kind_phys)) + temp22m(p) = vkc/(log(obu(p)/z0q(p)) + 5._kind_lake - 5._kind_lake*z0q(p)/obu(p) & + + (5._kind_lake*log(zeta(p))+zeta(p)-1._kind_lake)) end if end if end do @@ -5116,9 +5126,9 @@ subroutine FrictionVelocity(pgridcell,forc_hgt,forc_hgt_u, & !i zeta(p) = zldis(p)/obu(p) if (zeta(p) < -zetam) then ! zeta < -1 ustar(p) = vkc * um(p) / log(-zetam*obu(p)/z0m(p)) - else if (zeta(p) < 0._kind_phys) then ! -1 <= zeta < 0 + else if (zeta(p) < 0._kind_lake) then ! -1 <= zeta < 0 ustar(p) = vkc * um(p) / log(zldis(p)/z0m(p)) - else if (zeta(p) <= 1._kind_phys) then ! 0 <= ztea <= 1 + else if (zeta(p) <= 1._kind_lake) then ! 0 <= ztea <= 1 ustar(p)=vkc * um(p)/log(zldis(p)/z0m(p)) else ! 1 < zeta, phi=5+zeta ustar(p)=vkc * um(p)/log(obu(p)/z0m(p)) @@ -5128,9 +5138,9 @@ subroutine FrictionVelocity(pgridcell,forc_hgt,forc_hgt_u, & !i zeta(p) = zldis(p)/obu(p) if (zeta(p) < -zetat) then temp1(p)=vkc/log(-zetat*obu(p)/z0h(p)) - else if (zeta(p) < 0._kind_phys) then + else if (zeta(p) < 0._kind_lake) then temp1(p)=vkc/log(zldis(p)/z0h(p)) - else if (zeta(p) <= 1._kind_phys) then + else if (zeta(p) <= 1._kind_lake) then temp1(p)=vkc/log(zldis(p)/z0h(p)) else temp1(p)=vkc/log(obu(p)/z0h(p)) @@ -5140,33 +5150,33 @@ subroutine FrictionVelocity(pgridcell,forc_hgt,forc_hgt_u, & !i zeta(p) = zldis(p)/obu(p) if (zeta(p) < -zetat) then temp2(p)=vkc/log(-zetat*obu(p)/z0q(p)) - else if (zeta(p) < 0._kind_phys) then + else if (zeta(p) < 0._kind_lake) then temp2(p)=vkc/log(zldis(p)/z0q(p)) - else if (zeta(p) <= 1._kind_phys) then + else if (zeta(p) <= 1._kind_lake) then temp2(p)=vkc/log(zldis(p)/z0q(p)) else temp2(p)=vkc/log(obu(p)/z0q(p)) end if - zldis(p) = 2.0_kind_phys + z0h(p) + zldis(p) = 2.0_kind_lake + z0h(p) zeta(p) = zldis(p)/obu(p) if (zeta(p) < -zetat) then temp12m(p)=vkc/log(-zetat*obu(p)/z0h(p)) - else if (zeta(p) < 0._kind_phys) then + else if (zeta(p) < 0._kind_lake) then temp12m(p)=vkc/log(zldis(p)/z0h(p)) - else if (zeta(p) <= 1._kind_phys) then + else if (zeta(p) <= 1._kind_lake) then temp12m(p)=vkc/log(zldis(p)/z0h(p)) else temp12m(p)=vkc/log(obu(p)/z0h(p)) end if - zldis(p) = 2.0_kind_phys + z0q(p) + zldis(p) = 2.0_kind_lake + z0q(p) zeta(p) = zldis(p)/obu(p) if (zeta(p) < -zetat) then temp22m(p)=vkc/log(-zetat*obu(p)/z0q(p)) - else if (zeta(p) < 0._kind_phys) then + else if (zeta(p) < 0._kind_lake) then temp22m(p)=vkc/log(zldis(p)/z0q(p)) - else if (zeta(p) <= 1._kind_phys) then + else if (zeta(p) <= 1._kind_lake) then temp22m(p)=vkc/log(zldis(p)/z0q(p)) else temp22m(p)=vkc/log(obu(p)/z0q(p)) @@ -5180,7 +5190,7 @@ end subroutine FrictionVelocity ! !IROUTINE: StabilityFunc ! ! !INTERFACE: - real(kind_phys) function StabilityFunc1(zeta) + real(kind_lake) function StabilityFunc1(zeta) ! ! !DESCRIPTION: ! Stability function for rib < 0. @@ -5191,7 +5201,7 @@ real(kind_phys) function StabilityFunc1(zeta) ! ! !ARGUMENTS: implicit none - real(kind_phys), intent(in) :: zeta ! dimensionless height used in Monin-Obukhov theory + real(kind_lake), intent(in) :: zeta ! dimensionless height used in Monin-Obukhov theory ! ! !CALLED FROM: ! subroutine FrictionVelocity in this module @@ -5204,15 +5214,15 @@ real(kind_phys) function StabilityFunc1(zeta) !EOP ! ! !LOCAL VARIABLES: - real(kind_phys) :: chik, chik2 + real(kind_lake) :: chik, chik2 !------------------------------------------------------------------------------ - chik2 = sqrt(1._kind_phys-16._kind_phys*zeta) + chik2 = sqrt(1._kind_lake-16._kind_lake*zeta) chik = sqrt(chik2) - StabilityFunc1 = 2._kind_phys*log((1._kind_phys+chik)*0.5_kind_phys) & + StabilityFunc1 = 2._kind_lake*log((1._kind_lake+chik)*0.5_kind_lake) & !Changed to pie, Zack Subin, 7/9/08 !Spelling corrected, changed to pi, Sam Trahan the Killjoy, 6/2/22 - + log((1._kind_phys+chik2)*0.5_kind_phys)-2._kind_phys*atan(chik)+pi*0.5_kind_phys + + log((1._kind_lake+chik2)*0.5_kind_lake)-2._kind_lake*atan(chik)+pi*0.5_kind_lake end function StabilityFunc1 @@ -5222,7 +5232,7 @@ end function StabilityFunc1 ! !IROUTINE: StabilityFunc2 ! ! !INTERFACE: - real(kind_phys) function StabilityFunc2(zeta) + real(kind_lake) function StabilityFunc2(zeta) ! ! !DESCRIPTION: ! Stability function for rib < 0. @@ -5233,7 +5243,7 @@ real(kind_phys) function StabilityFunc2(zeta) ! ! !ARGUMENTS: implicit none - real(kind_phys), intent(in) :: zeta ! dimensionless height used in Monin-Obukhov theory + real(kind_lake), intent(in) :: zeta ! dimensionless height used in Monin-Obukhov theory ! ! !CALLED FROM: ! subroutine FrictionVelocity in this module @@ -5246,11 +5256,11 @@ real(kind_phys) function StabilityFunc2(zeta) !EOP ! ! !LOCAL VARIABLES: - real(kind_phys) :: chik2 + real(kind_lake) :: chik2 !------------------------------------------------------------------------------ - chik2 = sqrt(1._kind_phys-16._kind_phys*zeta) - StabilityFunc2 = 2._kind_phys*log((1._kind_phys+chik2)*0.5_kind_phys) + chik2 = sqrt(1._kind_lake-16._kind_lake*zeta) + StabilityFunc2 = 2._kind_lake*log((1._kind_lake+chik2)*0.5_kind_lake) end function StabilityFunc2 @@ -5273,13 +5283,13 @@ subroutine MoninObukIni (ur, thv, dthv, zldis, z0m, um, obu) ! ! !ARGUMENTS: implicit none - real(kind_phys), intent(in) :: ur ! wind speed at reference height [m/s] - real(kind_phys), intent(in) :: thv ! virtual potential temperature (kelvin) - real(kind_phys), intent(in) :: dthv ! diff of vir. poten. temp. between ref. height and surface - real(kind_phys), intent(in) :: zldis ! reference height "minus" zero displacement heght [m] - real(kind_phys), intent(in) :: z0m ! roughness length, momentum [m] - real(kind_phys), intent(out) :: um ! wind speed including the stability effect [m/s] - real(kind_phys), intent(out) :: obu ! monin-obukhov length (m) + real(kind_lake), intent(in) :: ur ! wind speed at reference height [m/s] + real(kind_lake), intent(in) :: thv ! virtual potential temperature (kelvin) + real(kind_lake), intent(in) :: dthv ! diff of vir. poten. temp. between ref. height and surface + real(kind_lake), intent(in) :: zldis ! reference height "minus" zero displacement heght [m] + real(kind_lake), intent(in) :: z0m ! roughness length, momentum [m] + real(kind_lake), intent(out) :: um ! wind speed including the stability effect [m/s] + real(kind_lake), intent(out) :: obu ! monin-obukhov length (m) ! ! !CALLED FROM: ! subroutine BareGroundFluxes in module BareGroundFluxesMod.F90 @@ -5295,33 +5305,33 @@ subroutine MoninObukIni (ur, thv, dthv, zldis, z0m, um, obu) ! ! !LOCAL VARIABLES: ! - real(kind_phys) :: wc ! convective velocity [m/s] - real(kind_phys) :: rib ! bulk Richardson number - real(kind_phys) :: zeta ! dimensionless height used in Monin-Obukhov theory - real(kind_phys) :: ustar ! friction velocity [m/s] + real(kind_lake) :: wc ! convective velocity [m/s] + real(kind_lake) :: rib ! bulk Richardson number + real(kind_lake) :: zeta ! dimensionless height used in Monin-Obukhov theory + real(kind_lake) :: ustar ! friction velocity [m/s] !----------------------------------------------------------------------- ! Initial values of u* and convective velocity - ustar=0.06_kind_phys - wc=0.5_kind_phys - if (dthv >= 0._kind_phys) then - um=max(ur,0.1_kind_phys) + ustar=0.06_kind_lake + wc=0.5_kind_lake + if (dthv >= 0._kind_lake) then + um=max(ur,0.1_kind_lake) else um=sqrt(ur*ur+wc*wc) endif rib=grav*zldis*dthv/(thv*um*um) if (PERGRO) then - rib = 0._kind_phys + rib = 0._kind_lake endif - if (rib >= 0._kind_phys) then ! neutral or stable - zeta = rib*log(zldis/z0m)/(1._kind_phys-5._kind_phys*min(rib,0.19_kind_phys)) - zeta = min(2._kind_phys,max(zeta,0.01_kind_phys )) + if (rib >= 0._kind_lake) then ! neutral or stable + zeta = rib*log(zldis/z0m)/(1._kind_lake-5._kind_lake*min(rib,0.19_kind_lake)) + zeta = min(2._kind_lake,max(zeta,0.01_kind_lake )) else ! unstable zeta=rib*log(zldis/z0m) - zeta = max(-100._kind_phys,min(zeta,-0.01_kind_phys )) + zeta = max(-100._kind_lake,min(zeta,-0.01_kind_lake )) endif obu=zldis/zeta @@ -5361,71 +5371,71 @@ subroutine clm_lake_init(con_pi,karman,con_g,con_sbc,con_t0c,rhowater,con_csol,c hfus = con_hfus hvap = con_hvap hsub = con_hfus+con_hvap - invhvap = 1._kind_phys/hvap - invhsub = 1._kind_phys/hsub + invhvap = 1._kind_lake/hvap + invhsub = 1._kind_lake/hsub rair = con_rd cpair = con_cp - ! dzlak(1) = 0.1_kind_phys - ! dzlak(2) = 1._kind_phys - ! dzlak(3) = 2._kind_phys - ! dzlak(4) = 3._kind_phys - ! dzlak(5) = 4._kind_phys - ! dzlak(6) = 5._kind_phys - ! dzlak(7) = 7._kind_phys - ! dzlak(8) = 7._kind_phys - ! dzlak(9) = 10.45_kind_phys - ! dzlak(10)= 10.45_kind_phys + ! dzlak(1) = 0.1_kind_lake + ! dzlak(2) = 1._kind_lake + ! dzlak(3) = 2._kind_lake + ! dzlak(4) = 3._kind_lake + ! dzlak(5) = 4._kind_lake + ! dzlak(6) = 5._kind_lake + ! dzlak(7) = 7._kind_lake + ! dzlak(8) = 7._kind_lake + ! dzlak(9) = 10.45_kind_lake + ! dzlak(10)= 10.45_kind_lake ! - ! zlak(1) = 0.05_kind_phys - ! zlak(2) = 0.6_kind_phys - ! zlak(3) = 2.1_kind_phys - ! zlak(4) = 4.6_kind_phys - ! zlak(5) = 8.1_kind_phys - ! zlak(6) = 12.6_kind_phys - ! zlak(7) = 18.6_kind_phys - ! zlak(8) = 25.6_kind_phys - ! zlak(9) = 34.325_kind_phys - ! zlak(10)= 44.775_kind_phys - dzlak(1) = 0.1_kind_phys - dzlak(2) = 0.1_kind_phys - dzlak(3) = 0.1_kind_phys - dzlak(4) = 0.1_kind_phys - dzlak(5) = 0.1_kind_phys - dzlak(6) = 0.1_kind_phys - dzlak(7) = 0.1_kind_phys - dzlak(8) = 0.1_kind_phys - dzlak(9) = 0.1_kind_phys - dzlak(10)= 0.1_kind_phys + ! zlak(1) = 0.05_kind_lake + ! zlak(2) = 0.6_kind_lake + ! zlak(3) = 2.1_kind_lake + ! zlak(4) = 4.6_kind_lake + ! zlak(5) = 8.1_kind_lake + ! zlak(6) = 12.6_kind_lake + ! zlak(7) = 18.6_kind_lake + ! zlak(8) = 25.6_kind_lake + ! zlak(9) = 34.325_kind_lake + ! zlak(10)= 44.775_kind_lake + dzlak(1) = 0.1_kind_lake + dzlak(2) = 0.1_kind_lake + dzlak(3) = 0.1_kind_lake + dzlak(4) = 0.1_kind_lake + dzlak(5) = 0.1_kind_lake + dzlak(6) = 0.1_kind_lake + dzlak(7) = 0.1_kind_lake + dzlak(8) = 0.1_kind_lake + dzlak(9) = 0.1_kind_lake + dzlak(10)= 0.1_kind_lake - zlak(1) = 0.05_kind_phys - zlak(2) = 0.15_kind_phys - zlak(3) = 0.25_kind_phys - zlak(4) = 0.35_kind_phys - zlak(5) = 0.45_kind_phys - zlak(6) = 0.55_kind_phys - zlak(7) = 0.65_kind_phys - zlak(8) = 0.75_kind_phys - zlak(9) = 0.85_kind_phys - zlak(10)= 0.95_kind_phys + zlak(1) = 0.05_kind_lake + zlak(2) = 0.15_kind_lake + zlak(3) = 0.25_kind_lake + zlak(4) = 0.35_kind_lake + zlak(5) = 0.45_kind_lake + zlak(6) = 0.55_kind_lake + zlak(7) = 0.65_kind_lake + zlak(8) = 0.75_kind_lake + zlak(9) = 0.85_kind_lake + zlak(10)= 0.95_kind_lake ! "0" refers to soil surface and "nlevsoil" refers to the bottom of model soil do j = 1, nlevsoil - zsoi(j) = scalez*(exp(0.5_kind_phys*(j-0.5_kind_phys))-1._kind_phys) !node depths + zsoi(j) = scalez*(exp(0.5_kind_lake*(j-0.5_kind_lake))-1._kind_lake) !node depths enddo - dzsoi(1) = 0.5_kind_phys*(zsoi(1)+zsoi(2)) !thickness b/n two interfaces + dzsoi(1) = 0.5_kind_lake*(zsoi(1)+zsoi(2)) !thickness b/n two interfaces do j = 2,nlevsoil-1 - dzsoi(j)= 0.5_kind_phys*(zsoi(j+1)-zsoi(j-1)) + dzsoi(j)= 0.5_kind_lake*(zsoi(j+1)-zsoi(j-1)) enddo dzsoi(nlevsoil) = zsoi(nlevsoil)-zsoi(nlevsoil-1) - zisoi(0) = 0._kind_phys + zisoi(0) = 0._kind_lake do j = 1, nlevsoil-1 - zisoi(j) = 0.5_kind_phys*(zsoi(j)+zsoi(j+1)) !interface depths + zisoi(j) = 0.5_kind_lake*(zsoi(j)+zsoi(j+1)) !interface depths enddo - zisoi(nlevsoil) = zsoi(nlevsoil) + 0.5_kind_phys*dzsoi(nlevsoil) + zisoi(nlevsoil) = zsoi(nlevsoil) + 0.5_kind_lake*dzsoi(nlevsoil) end subroutine clm_lake_init @@ -5508,7 +5518,7 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, !LOGICAL, DIMENSION( : ),intent(out) :: lake !REAL(KIND_PHYS), OPTIONAL, DIMENSION( : ), INTENT(IN) :: lake_depth ! no separate variable for this in CCPP - real(kind_phys), dimension( 1:im,1:nlevsoil ) :: bsw3d, & + real(kind_lake), dimension( 1:im,1:nlevsoil ) :: bsw3d, & bsw23d, & psisat3d, & vwcsat3d, & @@ -5517,19 +5527,19 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, hksat3d, & sucsat3d integer :: n,i,j,k,ib,lev,bottom ! indices - real(kind_phys),dimension(1:im ) :: bd2d ! bulk density of dry soil material [kg/m^3] - real(kind_phys),dimension(1:im ) :: tkm2d ! mineral conductivity - real(kind_phys),dimension(1:im ) :: xksat2d ! maximum hydraulic conductivity of soil [mm/s] - real(kind_phys),dimension(1:im ) :: depthratio2d ! ratio of lake depth to standard deep lake depth - real(kind_phys),dimension(1:im ) :: clay2d ! temporary - real(kind_phys),dimension(1:im ) :: sand2d ! temporary + real(kind_lake),dimension(1:im ) :: bd2d ! bulk density of dry soil material [kg/m^3] + real(kind_lake),dimension(1:im ) :: tkm2d ! mineral conductivity + real(kind_lake),dimension(1:im ) :: xksat2d ! maximum hydraulic conductivity of soil [mm/s] + real(kind_lake),dimension(1:im ) :: depthratio2d ! ratio of lake depth to standard deep lake depth + real(kind_lake),dimension(1:im ) :: clay2d ! temporary + real(kind_lake),dimension(1:im ) :: sand2d ! temporary logical,parameter :: arbinit = .false. - real(kind_phys),parameter :: defval = -999.0 + real(kind_lake),parameter :: defval = -999.0 integer :: isl integer :: numb_lak ! for debug character*256 :: message - real(kind_phys) :: ht + real(kind_lake) :: ht logical :: climatology_limits @@ -5538,7 +5548,7 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, integer :: used_lakedepth_default, init_points, month, julday integer :: mon, iday, num2, num1, juld, day2, day1, wght1, wght2 - real(kind_phys) :: Tclim + real(kind_lake) :: Tclim used_lakedepth_default=0 @@ -5639,35 +5649,35 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, do k = 1,nlevsoil clay2d(i) = clay3d(i,k) sand2d(i) = sand3d(i,k) - watsat3d(i,k) = 0.489_kind_phys - 0.00126_kind_phys*sand2d(i) - bd2d(i) = (1._kind_phys-watsat3d(i,k))*2.7e3_kind_phys - xksat2d(i) = 0.0070556_kind_phys *( 10._kind_phys**(-0.884_kind_phys+0.0153_kind_phys*sand2d(i)) ) ! mm/s - tkm2d(i) = (8.80_kind_phys*sand2d(i)+2.92_kind_phys*clay2d(i))/(sand2d(i)+clay2d(i)) ! W/(m K) - - bsw3d(i,k) = 2.91_kind_phys + 0.159_kind_phys*clay2d(i) - bsw23d(i,k) = -(3.10_kind_phys + 0.157_kind_phys*clay2d(i) - 0.003_kind_phys*sand2d(i)) - psisat3d(i,k) = -(exp((1.54_kind_phys - 0.0095_kind_phys*sand2d(i) + 0.0063_kind_phys*(100.0_kind_phys-sand2d(i) & - -clay2d(i)))*log(10.0_kind_phys))*9.8e-5_kind_phys) - vwcsat3d(i,k) = (50.5_kind_phys - 0.142_kind_phys*sand2d(i) - 0.037_kind_phys*clay2d(i))/100.0_kind_phys + watsat3d(i,k) = 0.489_kind_lake - 0.00126_kind_lake*sand2d(i) + bd2d(i) = (1._kind_lake-watsat3d(i,k))*2.7e3_kind_lake + xksat2d(i) = 0.0070556_kind_lake *( 10._kind_lake**(-0.884_kind_lake+0.0153_kind_lake*sand2d(i)) ) ! mm/s + tkm2d(i) = (8.80_kind_lake*sand2d(i)+2.92_kind_lake*clay2d(i))/(sand2d(i)+clay2d(i)) ! W/(m K) + + bsw3d(i,k) = 2.91_kind_lake + 0.159_kind_lake*clay2d(i) + bsw23d(i,k) = -(3.10_kind_lake + 0.157_kind_lake*clay2d(i) - 0.003_kind_lake*sand2d(i)) + psisat3d(i,k) = -(exp((1.54_kind_lake - 0.0095_kind_lake*sand2d(i) + 0.0063_kind_lake*(100.0_kind_lake-sand2d(i) & + -clay2d(i)))*log(10.0_kind_lake))*9.8e-5_kind_lake) + vwcsat3d(i,k) = (50.5_kind_lake - 0.142_kind_lake*sand2d(i) - 0.037_kind_lake*clay2d(i))/100.0_kind_lake hksat3d(i,k) = xksat2d(i) - sucsat3d(i,k) = 10._kind_phys * ( 10._kind_phys**(1.88_kind_phys-0.0131_kind_phys*sand2d(i)) ) - tkmg3d(i,k) = tkm2d(i) ** (1._kind_phys- watsat3d(i,k)) - tksatu3d(i,k) = tkmg3d(i,k)*0.57_kind_phys**watsat3d(i,k) - tkdry3d(i,k) = (0.135_kind_phys*bd2d(i) + 64.7_kind_phys) / (2.7e3_kind_phys - 0.947_kind_phys*bd2d(i)) - csol3d(i,k) = (2.128_kind_phys*sand2d(i)+2.385_kind_phys*clay2d(i)) / (sand2d(i)+clay2d(i))*1.e6_kind_phys ! J/(m3 K) - watdry3d(i,k) = watsat3d(i,k) * (316230._kind_phys/sucsat3d(i,k)) ** (-1._kind_phys/bsw3d(i,k)) - watopt3d(i,k) = watsat3d(i,k) * (158490._kind_phys/sucsat3d(i,k)) ** (-1._kind_phys/bsw3d(i,k)) + sucsat3d(i,k) = 10._kind_lake * ( 10._kind_lake**(1.88_kind_lake-0.0131_kind_lake*sand2d(i)) ) + tkmg3d(i,k) = tkm2d(i) ** (1._kind_lake- watsat3d(i,k)) + tksatu3d(i,k) = tkmg3d(i,k)*0.57_kind_lake**watsat3d(i,k) + tkdry3d(i,k) = (0.135_kind_lake*bd2d(i) + 64.7_kind_lake) / (2.7e3_kind_lake - 0.947_kind_lake*bd2d(i)) + csol3d(i,k) = (2.128_kind_lake*sand2d(i)+2.385_kind_lake*clay2d(i)) / (sand2d(i)+clay2d(i))*1.e6_kind_lake ! J/(m3 K) + watdry3d(i,k) = watsat3d(i,k) * (316230._kind_lake/sucsat3d(i,k)) ** (-1._kind_lake/bsw3d(i,k)) + watopt3d(i,k) = watsat3d(i,k) * (158490._kind_lake/sucsat3d(i,k)) ** (-1._kind_lake/bsw3d(i,k)) end do if (clm_lakedepth(i) == spval) then - clm_lakedepth(i) = zlak(nlevlake) + 0.5_kind_phys*dzlak(nlevlake) + clm_lakedepth(i) = zlak(nlevlake) + 0.5_kind_lake*dzlak(nlevlake) z_lake3d(i,1:nlevlake) = zlak(1:nlevlake) dz_lake3d(i,1:nlevlake) = dzlak(1:nlevlake) else - depthratio2d(i) = clm_lakedepth(i) / (zlak(nlevlake) + 0.5_kind_phys*dzlak(nlevlake)) + depthratio2d(i) = clm_lakedepth(i) / (zlak(nlevlake) + 0.5_kind_lake*dzlak(nlevlake)) z_lake3d(i,1) = zlak(1) dz_lake3d(i,1) = dzlak(1) dz_lake3d(i,2:nlevlake) = dzlak(2:nlevlake)*depthratio2d(i) - z_lake3d(i,2:nlevlake) = zlak(2:nlevlake)*depthratio2d(i) + dz_lake3d(i,1)*(1._kind_phys - depthratio2d(i)) + z_lake3d(i,2:nlevlake) = zlak(2:nlevlake)*depthratio2d(i) + dz_lake3d(i,1)*(1._kind_lake - depthratio2d(i)) end if z3d(i,1:nlevsoil) = zsoi(1:nlevsoil) zi3d(i,0:nlevsoil) = zisoi(0:nlevsoil) @@ -5675,64 +5685,64 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, savedtke12d(i) = tkwat ! Initialize for first timestep. - if (snowdp2d(i) < 0.01_kind_phys) then + if (snowdp2d(i) < 0.01_kind_lake) then snl2d(i) = 0 - dz3d(i,-nlevsnow+1:0) = 0._kind_phys - z3d (i,-nlevsnow+1:0) = 0._kind_phys - zi3d(i,-nlevsnow+0:0) = 0._kind_phys + dz3d(i,-nlevsnow+1:0) = 0._kind_lake + z3d (i,-nlevsnow+1:0) = 0._kind_lake + zi3d(i,-nlevsnow+0:0) = 0._kind_lake else - if ((snowdp2d(i) >= 0.01_kind_phys) .and. (snowdp2d(i) <= 0.03_kind_phys)) then + if ((snowdp2d(i) >= 0.01_kind_lake) .and. (snowdp2d(i) <= 0.03_kind_lake)) then snl2d(i) = -1 dz3d(i,0) = snowdp2d(i) - else if ((snowdp2d(i) > 0.03_kind_phys) .and. (snowdp2d(i) <= 0.04_kind_phys)) then + else if ((snowdp2d(i) > 0.03_kind_lake) .and. (snowdp2d(i) <= 0.04_kind_lake)) then snl2d(i) = -2 - dz3d(i,-1) = snowdp2d(i)*0.5_kind_phys + dz3d(i,-1) = snowdp2d(i)*0.5_kind_lake dz3d(i, 0) = dz3d(i,-1) - else if ((snowdp2d(i) > 0.04_kind_phys) .and. (snowdp2d(i) <= 0.07_kind_phys)) then + else if ((snowdp2d(i) > 0.04_kind_lake) .and. (snowdp2d(i) <= 0.07_kind_lake)) then snl2d(i) = -2 - dz3d(i,-1) = 0.02_kind_phys + dz3d(i,-1) = 0.02_kind_lake dz3d(i, 0) = snowdp2d(i) - dz3d(i,-1) - else if ((snowdp2d(i) > 0.07_kind_phys) .and. (snowdp2d(i) <= 0.12_kind_phys)) then + else if ((snowdp2d(i) > 0.07_kind_lake) .and. (snowdp2d(i) <= 0.12_kind_lake)) then snl2d(i) = -3 - dz3d(i,-2) = 0.02_kind_phys - dz3d(i,-1) = (snowdp2d(i) - 0.02_kind_phys)*0.5_kind_phys + dz3d(i,-2) = 0.02_kind_lake + dz3d(i,-1) = (snowdp2d(i) - 0.02_kind_lake)*0.5_kind_lake dz3d(i, 0) = dz3d(i,-1) - else if ((snowdp2d(i) > 0.12_kind_phys) .and. (snowdp2d(i) <= 0.18_kind_phys)) then + else if ((snowdp2d(i) > 0.12_kind_lake) .and. (snowdp2d(i) <= 0.18_kind_lake)) then snl2d(i) = -3 - dz3d(i,-2) = 0.02_kind_phys - dz3d(i,-1) = 0.05_kind_phys + dz3d(i,-2) = 0.02_kind_lake + dz3d(i,-1) = 0.05_kind_lake dz3d(i, 0) = snowdp2d(i) - dz3d(i,-2) - dz3d(i,-1) - else if ((snowdp2d(i) > 0.18_kind_phys) .and. (snowdp2d(i) <= 0.29_kind_phys)) then + else if ((snowdp2d(i) > 0.18_kind_lake) .and. (snowdp2d(i) <= 0.29_kind_lake)) then snl2d(i) = -4 - dz3d(i,-3) = 0.02_kind_phys - dz3d(i,-2) = 0.05_kind_phys - dz3d(i,-1) = (snowdp2d(i) - dz3d(i,-3) - dz3d(i,-2))*0.5_kind_phys + dz3d(i,-3) = 0.02_kind_lake + dz3d(i,-2) = 0.05_kind_lake + dz3d(i,-1) = (snowdp2d(i) - dz3d(i,-3) - dz3d(i,-2))*0.5_kind_lake dz3d(i, 0) = dz3d(i,-1) - else if ((snowdp2d(i) > 0.29_kind_phys) .and. (snowdp2d(i) <= 0.41_kind_phys)) then + else if ((snowdp2d(i) > 0.29_kind_lake) .and. (snowdp2d(i) <= 0.41_kind_lake)) then snl2d(i) = -4 - dz3d(i,-3) = 0.02_kind_phys - dz3d(i,-2) = 0.05_kind_phys - dz3d(i,-1) = 0.11_kind_phys + dz3d(i,-3) = 0.02_kind_lake + dz3d(i,-2) = 0.05_kind_lake + dz3d(i,-1) = 0.11_kind_lake dz3d(i, 0) = snowdp2d(i) - dz3d(i,-3) - dz3d(i,-2) - dz3d(i,-1) - else if ((snowdp2d(i) > 0.41_kind_phys) .and. (snowdp2d(i) <= 0.64_kind_phys)) then + else if ((snowdp2d(i) > 0.41_kind_lake) .and. (snowdp2d(i) <= 0.64_kind_lake)) then snl2d(i) = -5 - dz3d(i,-4) = 0.02_kind_phys - dz3d(i,-3) = 0.05_kind_phys - dz3d(i,-2) = 0.11_kind_phys - dz3d(i,-1) = (snowdp2d(i) - dz3d(i,-4) - dz3d(i,-3) - dz3d(i,-2))*0.5_kind_phys + dz3d(i,-4) = 0.02_kind_lake + dz3d(i,-3) = 0.05_kind_lake + dz3d(i,-2) = 0.11_kind_lake + dz3d(i,-1) = (snowdp2d(i) - dz3d(i,-4) - dz3d(i,-3) - dz3d(i,-2))*0.5_kind_lake dz3d(i, 0) = dz3d(i,-1) - else if (snowdp2d(i) > 0.64_kind_phys) then + else if (snowdp2d(i) > 0.64_kind_lake) then snl2d(i) = -5 - dz3d(i,-4) = 0.02_kind_phys - dz3d(i,-3) = 0.05_kind_phys - dz3d(i,-2) = 0.11_kind_phys - dz3d(i,-1) = 0.23_kind_phys + dz3d(i,-4) = 0.02_kind_lake + dz3d(i,-3) = 0.05_kind_lake + dz3d(i,-2) = 0.11_kind_lake + dz3d(i,-1) = 0.23_kind_lake dz3d(i, 0)=snowdp2d(i)-dz3d(i,-4)-dz3d(i,-3)-dz3d(i,-2)-dz3d(i,-1) endif end if do k = 0, snl2d(i)+1, -1 - z3d(i,k) = zi3d(i,k) - 0.5_kind_phys*dz3d(i,k) + z3d(i,k) = zi3d(i,k) - 0.5_kind_lake*dz3d(i,k) zi3d(i,k-1) = zi3d(i,k) - dz3d(i,k) end do @@ -5773,15 +5783,15 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, end if do k = 1,nlevsoil - h2osoi_vol3d(i,k) = 1.0_kind_phys + h2osoi_vol3d(i,k) = 1.0_kind_lake h2osoi_vol3d(i,k) = min(h2osoi_vol3d(i,k),watsat3d(i,k)) ! soil layers if (t_soisno3d(i,k) <= tfrz) then h2osoi_ice3d(i,k) = dz3d(i,k)*denice*h2osoi_vol3d(i,k) - h2osoi_liq3d(i,k) = 0._kind_phys + h2osoi_liq3d(i,k) = 0._kind_lake else - h2osoi_ice3d(i,k) = 0._kind_phys + h2osoi_ice3d(i,k) = 0._kind_lake h2osoi_liq3d(i,k) = dz3d(i,k)*denh2o*h2osoi_vol3d(i,k) endif enddo @@ -5789,7 +5799,7 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, do k = -nlevsnow+1, 0 if (k > snl2d(i)) then h2osoi_ice3d(i,k) = dz3d(i,k)*snow_bd - h2osoi_liq3d(i,k) = 0._kind_phys + h2osoi_liq3d(i,k) = 0._kind_lake end if end do From 251c17f86cde8f60486136502ed20e59707371e2 Mon Sep 17 00:00:00 2001 From: Lisa Bengtsson Date: Mon, 6 Mar 2023 18:24:31 +0000 Subject: [PATCH 135/380] Unified convection scheme --- physics/GFS_debug.F90 | 2 +- physics/GFS_rrtmg_pre.F90 | 8 +- physics/GFS_rrtmg_pre.meta | 7 + physics/cu_unified_deep.F90 | 5738 +++++++++++++++++++++++++++ physics/cu_unified_driver.F90 | 1160 ++++++ physics/cu_unified_driver.meta | 586 +++ physics/cu_unified_driver_post.F90 | 65 + physics/cu_unified_driver_post.meta | 93 + physics/cu_unified_driver_pre.F90 | 84 + physics/cu_unified_driver_pre.meta | 139 + physics/cu_unified_sh.F90 | 1045 +++++ physics/radiation_clouds.f | 12 +- physics/sgscloud_radpre.F90 | 7 +- physics/sgscloud_radpre.meta | 7 + 14 files changed, 8941 insertions(+), 12 deletions(-) create mode 100644 physics/cu_unified_deep.F90 create mode 100644 physics/cu_unified_driver.F90 create mode 100644 physics/cu_unified_driver.meta create mode 100644 physics/cu_unified_driver_post.F90 create mode 100644 physics/cu_unified_driver_post.meta create mode 100644 physics/cu_unified_driver_pre.F90 create mode 100644 physics/cu_unified_driver_pre.meta create mode 100644 physics/cu_unified_sh.F90 diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 5387e6300..63af85b6a 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -613,7 +613,7 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%in_nm' , Tbd%in_nm) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%ccn_nm' , Tbd%ccn_nm) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%aer_nm' , Tbd%aer_nm) - if (Model%imfdeepcnv == Model%imfdeepcnv_gf) then + if (Model%imfdeepcnv == Model%imfdeepcnv_gf .or. Model%imfdeepcnv == Model%imfdeepcnv_unified) then call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%cactiv' , Tbd%cactiv) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%cactiv_m' , Tbd%cactiv_m) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%aod_gf' , Tbd%aod_gf) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index d05f02dae..b2843a139 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -18,7 +18,7 @@ module GFS_rrtmg_pre !! !>\section rrtmg_pre_gen General Algorithm subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, lextop, ltp, & - n_var_lndp, imfdeepcnv, imfdeepcnv_gf, me, ncnd, ntrac, num_p3d, & + n_var_lndp, imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_unified, me, ncnd, ntrac, num_p3d, & npdf3d, ncnvcld3d, ntqv, ntcw,ntiw, ntlnc, ntinc, ntrnc, ntsnc, ntccn, & ntrw, ntsw, ntgl, nthl, ntwa, ntoz, & ntclamt, nleffr, nieffr, nseffr, lndp_type, kdt, & @@ -87,7 +87,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, lextop, ltp, & integer, intent(in) :: im, levs, lm, lmk, lmp, ltp, & n_var_lndp, imfdeepcnv, & - imfdeepcnv_gf, me, ncnd, ntrac, & + imfdeepcnv_gf, imfdeepcnv_unified, me, ncnd, ntrac, & num_p3d, npdf3d, ncnvcld3d, ntqv, & ntcw, ntiw, ntlnc, ntinc, & ntrnc, ntsnc,ntccn, & @@ -812,7 +812,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, lextop, ltp, & enddo endif elseif (imp_physics == imp_physics_gfdl) then ! GFDL MP - if ((imfdeepcnv==imfdeepcnv_gf) .and. kdt>1) then + if ((imfdeepcnv==imfdeepcnv_gf .or. imfdeepcnv==imfdeepcnv_unified) .and. kdt>1) then do k=1,lm k1 = k + kd do i=1,im @@ -969,7 +969,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, lextop, ltp, & & imp_physics_mg, iovr_rand, iovr_maxrand, iovr_max, & & iovr_dcorr, iovr_exp, iovr_exprand, idcor_con, & & idcor_hogan, idcor_oreopoulos, & - & imfdeepcnv, imfdeepcnv_gf, do_mynnedmf, lgfdlmprad, & + & imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_unified, do_mynnedmf, lgfdlmprad, & & uni_cld, lmfshal, lmfdeep2, cldcov, clouds1, & & effrl, effri, effrr, effrs, effr_in, & & effrl_inout, effri_inout, effrs_inout, & diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 63ab11d3e..c783cd57c 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -79,6 +79,13 @@ dimensions = () type = integer intent = in +[imfdeepcnv_unified] + standard_name = identifier_for_unified_deep_convection + long_name = flag for Unified deep convection scheme + units = flag + dimensions = () + type = integer + intent = in [me] standard_name = mpi_rank long_name = current MPI-rank diff --git a/physics/cu_unified_deep.F90 b/physics/cu_unified_deep.F90 new file mode 100644 index 000000000..902fd60fc --- /dev/null +++ b/physics/cu_unified_deep.F90 @@ -0,0 +1,5738 @@ +!>\file cu_unified_deep.F90 +!! This file is the unified deep convection scheme. + +module cu_unified_deep + use machine , only : kind_phys + real(kind=kind_phys), parameter::g=9.81 + real(kind=kind_phys), parameter:: cp=1004. + real(kind=kind_phys), parameter:: xlv=2.5e6 + real(kind=kind_phys), parameter::r_v=461. + real(kind=kind_phys), parameter :: tcrit=258. +!> tuning constant for cloudwater/ice detrainment + real(kind=kind_phys), parameter:: c1= 0.003 !.002 ! .0005 +!> parameter to turn on or off evaporation of rainwater as done in sas + integer, parameter :: irainevap=1 +!> max allowed fractional coverage (frh_thresh) + real(kind=kind_phys), parameter::frh_thresh = .9 +!> rh threshold. if fractional coverage ~ frh_thres, do not use cupa any further + real(kind=kind_phys), parameter::rh_thresh = .97 +!> tuning constant for j. brown closure (ichoice = 4,5,6) + real(kind=kind_phys), parameter::betajb=1.2 +!> tuning for shallow and mid convection. ec uses 1.5 + integer, parameter:: use_excess=0 + real(kind=kind_phys), parameter :: fluxtune=1.5 +!> flag to turn off or modify mom transport by downdrafts + real(kind=kind_phys), parameter :: pgcd = 0.1 +! +!> aerosol awareness, do not use yet! + integer, parameter :: autoconv=2 + integer, parameter :: aeroevap=3 + real(kind=kind_phys), parameter :: scav_factor = 0.5 +!> still 16 ensembles for clousres + integer, parameter:: maxens3=16 + +!---meltglac------------------------------------------------- + logical, parameter :: melt_glac = .true. !<- turn on/off ice phase/melting + real(kind=kind_phys), parameter :: & + t_0 = 273.16, & !< k + t_ice = 250.16, & !< k + xlf = 0.333e6 !< latent heat of freezing (j k-1 kg-1) +!---meltglac------------------------------------------------- +!-----srf-08aug2017-----begin + real(kind=kind_phys), parameter :: qrc_crit= 2.e-4 +!-----srf-08aug2017-----end + +contains + +!>\defgroup cu_unified_deep_group Grell-Freitas Deep Convection Module +!>\ingroup cu_unified_group +!! This is Grell-Freitas deep convection scheme module +!> @{ + integer function my_maxloc1d(A,N) +!$acc routine vector + implicit none + real(kind_phys), intent(in) :: A(:) + integer, intent(in) :: N + + real(kind_phys) :: imaxval + integer :: i + + imaxval = MAXVAL(A) + my_maxloc1d = 1 +!$acc loop + do i = 1, N + if ( A(i) == imaxval ) then + my_maxloc1d = i + return + endif + end do + return + end function my_maxloc1d + +!>Driver for the deep or congestus GF routine. +!! \section general_unified_deep Grell-Freitas Deep Convection General Algorithm + subroutine cu_unified_deep_run( & + itf,ktf,its,ite, kts,kte & + ,dicycle & ! diurnal cycle flag + ,ichoice & ! choice of closure, use "0" for ensemble average + ,ipr & ! this flag can be used for debugging prints + ,ccn & ! not well tested yet + ,ccnclean & + ,dtime & ! dt over which forcing is applied + ,imid & ! flag to turn on mid level convection + ,kpbl & ! level of boundary layer height + ,dhdt & ! boundary layer forcing (one closure for shallow) + ,xland & ! land mask + ,zo & ! heights above surface + ,forcing & ! only diagnostic + ,t & ! t before forcing + ,q & ! q before forcing + ,z1 & ! terrain + ,tn & ! t including forcing + ,qo & ! q including forcing + ,po & ! pressure (mb) + ,psur & ! surface pressure (mb) + ,us & ! u on mass points + ,vs & ! v on mass points + ,rho & ! density + ,hfx & ! w/m2, positive upward + ,qfx & ! w/m2, positive upward + ,dx & ! dx is grid point dependent here + ,ca_deep & ! cellular automaton for deep convection + ,mconv & ! integrated vertical advection of moisture + ,omeg & ! omega (pa/s) + ,csum & ! used to implement memory, set to zero if not avail + ,cnvwt & ! gfs needs this + ,zuo & ! nomalized updraft mass flux + ,zdo & ! nomalized downdraft mass flux + ,zdm & ! nomalized downdraft mass flux from mid scheme + ,edto & ! + ,edtm & ! + ,xmb_out & ! the xmb's may be needed for dicycle + ,xmbm_in & ! + ,xmbs_in & ! + ,pre & ! + ,outu & ! momentum tendencies at mass points + ,outv & ! + ,outt & ! temperature tendencies + ,outq & ! q tendencies + ,outqc & ! ql/qice tendencies + ,kbcon & ! lfc of parcel from k22 + ,ktop & ! cloud top + ,cupclw & ! used for direct coupling to radiation, but with tuning factors + ,frh_out & ! fractional coverage + ,rainevap & ! Integrated rain evaporation saved for input to cellular automata + ,ierr & ! ierr flags are error flags, used for debugging + ,ierrc & ! the following should be set to zero if not available + ,rand_mom & ! for stochastics mom, if temporal and spatial patterns exist + ,rand_vmas & ! for stochastics vertmass, if temporal and spatial patterns exist + ,rand_clos & ! for stochastics closures, if temporal and spatial patterns exist + ,nranflag & ! flag to what you want perturbed + !! 1 = momentum transport + !! 2 = normalized vertical mass flux profile + !! 3 = closures + !! more is possible, talk to developer or + !! implement yourself. pattern is expected to be + !! betwee -1 and +1 + ,do_capsuppress,cap_suppress_j & ! + ,k22 & ! + ,jmin,tropics) ! + + implicit none + + integer & + ,intent (in ) :: & + nranflag,itf,ktf,its,ite, kts,kte,ipr,imid + integer, intent (in ) :: & + ichoice + real(kind=kind_phys), dimension (its:ite,4) & + ,intent (in ) :: rand_clos + real(kind=kind_phys), dimension (its:ite) & + ,intent (in ) :: rand_mom,rand_vmas +!$acc declare copyin(rand_clos,rand_mom,rand_vmas) + real(kind=kind_phys), intent(in), dimension (its:ite) :: ca_deep(:) + integer, intent(in) :: do_capsuppress + real(kind=kind_phys), intent(in), dimension(:) :: cap_suppress_j +!$acc declare create(cap_suppress_j) + ! + ! + ! + real(kind=kind_phys), dimension (its:ite,1:maxens3) :: xf_ens,pr_ens +!$acc declare create(xf_ens,pr_ens) + ! outtem = output temp tendency (per s) + ! outq = output q tendency (per s) + ! outqc = output qc tendency (per s) + ! pre = output precip + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (inout ) :: & + cnvwt,outu,outv,outt,outq,outqc,cupclw + real(kind=kind_phys), dimension (its:ite) & + ,intent (out ) :: & + frh_out,rainevap + real(kind=kind_phys), dimension (its:ite) & + ,intent (inout ) :: & + pre,xmb_out +!$acc declare copy(cnvwt,outu,outv,outt,outq,outqc,cupclw,frh_out,pre,xmb_out) + real(kind=kind_phys), dimension (its:ite) & + ,intent (in ) :: & + hfx,qfx,xmbm_in,xmbs_in +!$acc declare copyin(hfx,qfx,xmbm_in,xmbs_in) + integer, dimension (its:ite) & + ,intent (inout ) :: & + kbcon,ktop +!$acc declare copy(kbcon,ktop) + integer, dimension (its:ite) & + ,intent (in ) :: & + kpbl,tropics +!$acc declare copyin(kpbl,tropics) + ! + ! basic environmental input includes moisture convergence (mconv) + ! omega (omeg), windspeed (us,vs), and a flag (ierr) to turn off + ! convection for this call only and at that particular gridpoint + ! + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + dhdt,rho,t,po,us,vs,tn +!$acc declare copyin(dhdt,rho,t,po,us,vs,tn) + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (inout ) :: & + omeg +!$acc declare copy(omeg) + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (inout) :: & + q,qo,zuo,zdo,zdm +!$acc declare copy(q,qo,zuo,zdo,zdm) + real(kind=kind_phys), dimension (its:ite) & + ,intent (in ) :: & + dx,z1,psur,xland +!$acc declare copyin(dx,z1,psur,xland) + real(kind=kind_phys), dimension (its:ite) & + ,intent (inout ) :: & + mconv,ccn +!$acc declare copy(mconv,ccn) + + + real(kind=kind_phys) & + ,intent (in ) :: & + dtime,ccnclean + + +! +! local ensemble dependent variables in this routine +! + real(kind=kind_phys), dimension (its:ite,1) :: & + xaa0_ens + real(kind=kind_phys), dimension (its:ite,1) :: & + edtc + real(kind=kind_phys), dimension (its:ite,kts:kte,1) :: & + dellat_ens,dellaqc_ens,dellaq_ens,pwo_ens +!$acc declare create(xaa0_ens,edtc,dellat_ens,dellaqc_ens,dellaq_ens,pwo_ens) +! +! +! +!***************** the following are your basic environmental +! variables. they carry a "_cup" if they are +! on model cloud levels (staggered). they carry +! an "o"-ending (z becomes zo), if they are the forced +! variables. they are preceded by x (z becomes xz) +! to indicate modification by some typ of cloud +! + ! z = heights of model levels + ! q = environmental mixing ratio + ! qes = environmental saturation mixing ratio + ! t = environmental temp + ! p = environmental pressure + ! he = environmental moist static energy + ! hes = environmental saturation moist static energy + ! z_cup = heights of model cloud levels + ! q_cup = environmental q on model cloud levels + ! qes_cup = saturation q on model cloud levels + ! t_cup = temperature (kelvin) on model cloud levels + ! p_cup = environmental pressure + ! he_cup = moist static energy on model cloud levels + ! hes_cup = saturation moist static energy on model cloud levels + ! gamma_cup = gamma on model cloud levels +! +! + ! hcd = moist static energy in downdraft + ! zd normalized downdraft mass flux + ! dby = buoancy term + ! entr = entrainment rate + ! zd = downdraft normalized mass flux + ! entr= entrainment rate + ! hcd = h in model cloud + ! bu = buoancy term + ! zd = normalized downdraft mass flux + ! gamma_cup = gamma on model cloud levels + ! qcd = cloud q (including liquid water) after entrainment + ! qrch = saturation q in cloud + ! pwd = evaporate at that level + ! pwev = total normalized integrated evaoprate (i2) + ! entr= entrainment rate + ! z1 = terrain elevation + ! entr = downdraft entrainment rate + ! jmin = downdraft originating level + ! kdet = level above ground where downdraft start detraining + ! psur = surface pressure + ! z1 = terrain elevation + ! pr_ens = precipitation ensemble + ! xf_ens = mass flux ensembles + ! omeg = omega from large scale model + ! mconv = moisture convergence from large scale model + ! zd = downdraft normalized mass flux + ! zu = updraft normalized mass flux + ! dir = "storm motion" + ! mbdt = arbitrary numerical parameter + ! dtime = dt over which forcing is applied + ! kbcon = lfc of parcel from k22 + ! k22 = updraft originating level + ! ichoice = flag if only want one closure (usually set to zero!) + ! dby = buoancy term + ! ktop = cloud top (output) + ! xmb = total base mass flux + ! hc = cloud moist static energy + ! hkb = moist static energy at originating level + + real(kind=kind_phys), dimension (its:ite,kts:kte) :: & + entr_rate_2d,mentrd_rate_2d,he,hes,qes,z, heo,heso,qeso,zo, & + xhe,xhes,xqes,xz,xt,xq,qes_cup,q_cup,he_cup,hes_cup,z_cup, & + p_cup,gamma_cup,t_cup, qeso_cup,qo_cup,heo_cup,heso_cup, & + zo_cup,po_cup,gammao_cup,tn_cup, & + xqes_cup,xq_cup,xhe_cup,xhes_cup,xz_cup, & + xt_cup, dby,hc,zu,clw_all, & + dbyo,qco,qrcdo,pwdo,pwo,hcdo,qcdo,dbydo,hco,qrco, & + dbyt,xdby,xhc,xzu, & + + ! cd = detrainment function for updraft + ! cdd = detrainment function for downdraft + ! dellat = change of temperature per unit mass flux of cloud ensemble + ! dellaq = change of q per unit mass flux of cloud ensemble + ! dellaqc = change of qc per unit mass flux of cloud ensemble + + cd,cdd,dellah,dellaq,dellat,dellaqc, & + u_cup,v_cup,uc,vc,ucd,vcd,dellu,dellv +!$acc declare create( & +!$acc entr_rate_2d,mentrd_rate_2d,he,hes,qes,z, heo,heso,qeso,zo, & +!$acc xhe,xhes,xqes,xz,xt,xq,qes_cup,q_cup,he_cup,hes_cup,z_cup, & +!$acc p_cup,gamma_cup,t_cup, qeso_cup,qo_cup,heo_cup,heso_cup, & +!$acc zo_cup,po_cup,gammao_cup,tn_cup, & +!$acc xqes_cup,xq_cup,xhe_cup,xhes_cup,xz_cup, & +!$acc xt_cup, dby,hc,zu,clw_all, & +!$acc dbyo,qco,qrcdo,pwdo,pwo,hcdo,qcdo,dbydo,hco,qrco, & +!$acc dbyt,xdby,xhc,xzu, & +!$acc cd,cdd,dellah,dellaq,dellat,dellaqc, & +!$acc u_cup,v_cup,uc,vc,ucd,vcd,dellu,dellv) + + ! aa0 cloud work function for downdraft + ! edt = epsilon + ! aa0 = cloud work function without forcing effects + ! aa1 = cloud work function with forcing effects + ! xaa0 = cloud work function with cloud effects (ensemble dependent) + ! edt = epsilon + + real(kind=kind_phys), dimension (its:ite) :: & + edt,edto,edtm,aa1,aa0,xaa0,hkb, & + hkbo,xhkb, & + xmb,pwavo,ccnloss, & + pwevo,bu,bud,cap_max, & + cap_max_increment,closure_n,psum,psumh,sig,sigd + real(kind=kind_phys), dimension (its:ite) :: & + axx,edtmax,edtmin,entr_rate + integer, dimension (its:ite) :: & + kzdown,kdet,k22,jmin,kstabi,kstabm,k22x,xland1, & + ktopdby,kbconx,ierr2,ierr3,kbmax +!$acc declare create(edt,edto,edtm,aa1,aa0,xaa0,hkb, & +!$acc hkbo,xhkb, & +!$acc xmb,pwavo,ccnloss, & +!$acc pwevo,bu,bud,cap_max, & +!$acc cap_max_increment,closure_n,psum,psumh,sig,sigd, & +!$acc axx,edtmax,edtmin,entr_rate, & +!$acc kzdown,kdet,k22,jmin,kstabi,kstabm,k22x,xland1, & +!$acc ktopdby,kbconx,ierr2,ierr3,kbmax) + + integer, dimension (its:ite), intent(inout) :: ierr + integer, dimension (its:ite), intent(in) :: csum +!$acc declare copy(ierr) copyin(csum) + integer :: & + iloop,nens3,ki,kk,i,k + real(kind=kind_phys) :: & + dz,dzo,mbdt,radius, & + zcutdown,depth_min,zkbmax,z_detr,zktop, & + dh,cap_maxs,trash,trash2,frh,sig_thresh + real(kind=kind_phys), dimension (its:ite) :: pefc + real(kind=kind_phys) entdo,dp,subin,detdo,entup, & + detup,subdown,entdoj,entupk,detupk,totmas + + real(kind=kind_phys), dimension (its:ite) :: lambau,flux_tun,zws,ztexec,zqexec +!$acc declare create(lambau,flux_tun,zws,ztexec,zqexec) + + integer :: jprnt,jmini,start_k22 + logical :: keep_going,flg(its:ite) +!$acc declare create(flg) + + character*50 :: ierrc(its:ite) + character*4 :: cumulus + real(kind=kind_phys), dimension (its:ite,kts:kte) :: & + up_massentr,up_massdetr,c1d & + ,up_massentro,up_massdetro,dd_massentro,dd_massdetro + real(kind=kind_phys), dimension (its:ite,kts:kte) :: & + up_massentru,up_massdetru,dd_massentru,dd_massdetru +!$acc declare create(up_massentr,up_massdetr,c1d,up_massentro,up_massdetro,dd_massentro,dd_massdetro, & +!$acc up_massentru,up_massdetru,dd_massentru,dd_massdetru) + real(kind=kind_phys) c1_max,buo_flux,pgcon,pgc,blqe + + real(kind=kind_phys) :: xff_mid(its:ite,2) +!$acc declare create(xff_mid) + integer :: iversion=1 + real(kind=kind_phys) :: denom,h_entr,umean,t_star,dq + integer, intent(in) :: dicycle + real(kind=kind_phys), dimension (its:ite) :: aa1_bl,hkbo_bl,tau_bl,tau_ecmwf,wmean + real(kind=kind_phys), dimension (its:ite,kts:kte) :: tn_bl, qo_bl, qeso_bl, heo_bl, heso_bl & + ,qeso_cup_bl,qo_cup_bl, heo_cup_bl,heso_cup_bl & + ,gammao_cup_bl,tn_cup_bl,hco_bl,dbyo_bl + real(kind=kind_phys), dimension(its:ite) :: xf_dicycle +!$acc declare create(aa1_bl,hkbo_bl,tau_bl,tau_ecmwf,wmean, & +!$acc tn_bl, qo_bl, qeso_bl, heo_bl, heso_bl, & +!$acc qeso_cup_bl,qo_cup_bl, heo_cup_bl,heso_cup_bl, & +!$acc gammao_cup_bl,tn_cup_bl,hco_bl,dbyo_bl,xf_dicycle) + real(kind=kind_phys), intent(inout), dimension(its:ite,10) :: forcing +!$acc declare copy(forcing) + integer :: turn,pmin_lev(its:ite),start_level(its:ite),ktopkeep(its:ite) + real(kind=kind_phys), dimension (its:ite,kts:kte) :: dtempdz + integer, dimension (its:ite,kts:kte) :: k_inv_layers + real(kind=kind_phys), dimension (its:ite) :: c0 ! HCB +!$acc declare create(pmin_lev,start_level,ktopkeep,dtempdz,k_inv_layers,c0) + +! rainevap from sas + real(kind=kind_phys) zuh2(40) + real(kind=kind_phys), dimension (its:ite) :: rntot,delqev,delq2,qevap,rn,qcond +!$acc declare create(zuh2,rntot,delqev,delq2,qevap,rn,qcond) + real(kind=kind_phys) :: rain,t1,q1,elocp,evef,el2orc,evfact,evfactl,g_rain,e_dn,c_up + real(kind=kind_phys) :: pgeoh,dts,fp,fpi,pmin,x_add,beta,beta_u + real(kind=kind_phys) :: cbeg,cmid,cend,const_a,const_b,const_c +!---meltglac------------------------------------------------- + + real(kind=kind_phys), dimension (its:ite,kts:kte) :: p_liq_ice,melting_layer,melting +!$acc declare create(p_liq_ice,melting_layer,melting) + + integer :: itemp + +!---meltglac------------------------------------------------- +!$acc kernels + melting_layer(:,:)=0. + melting(:,:)=0. + flux_tun(:)=fluxtune +!$acc end kernels +! if(imid.eq.1)flux_tun(:)=fluxtune+.5 + cumulus='deep' + if(imid.eq.1)cumulus='mid' + pmin=150. + if(imid.eq.1)pmin=75. +!$acc kernels + ktopdby(:)=0 +!$acc end kernels + c1_max=c1 + elocp=xlv/cp + el2orc=xlv*xlv/(r_v*cp) + evfact=0.25 ! .4 + evfactl=0.25 ! .2 + !evfact=.0 ! for 4F5f + !evfactl=.4 + +!cc + rainevap(:)=0 +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +!proportionality constant to estimate pressure gradient of updraft (zhang and wu, 2003, jas +! +! ecmwf + pgcon=0. +!$acc kernels + lambau(:)=2.0 + if(imid.eq.1)lambau(:)=2.0 +! here random must be between -1 and 1 + if(nranflag == 1)then + lambau(:)=1.5+rand_mom(:) + endif +!$acc end kernels +! sas +! lambau=0. +! pgcon=-.55 +! +!---------------------------------------------------- ! HCB +! Set cloud water to rain water conversion rate (c0) +!$acc kernels + c0(:)=0.004 + do i=its,itf + xland1(i)=int(xland(i)+.0001) ! 1. + if(xland(i).gt.1.5 .or. xland(i).lt.0.5)then + xland1(i)=0 + endif + if(xland1(i).eq.1)c0(i)=0.002 + if(imid.eq.1)then + c0(i)=0.002 + endif + enddo +!$acc end kernels + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!$acc kernels + ztexec(:) = 0. + zqexec(:) = 0. + zws(:) = 0. + + do i=its,itf + !- buoyancy flux (h+le) + buo_flux= (hfx(i)/cp+0.608*t(i,1)*qfx(i)/xlv)/rho(i,1) + pgeoh = zo(i,2)*g + !-convective-scale velocity w* + zws(i) = max(0.,flux_tun(i)*0.41*buo_flux*zo(i,2)*g/t(i,1)) + if(zws(i) > tiny(pgeoh)) then + !-convective-scale velocity w* + zws(i) = 1.2*zws(i)**.3333 + !- temperature excess + ztexec(i) = max(flux_tun(i)*hfx(i)/(rho(i,1)*zws(i)*cp),0.0) + !- moisture excess + zqexec(i) = max(flux_tun(i)*qfx(i)/xlv/(rho(i,1)*zws(i)),0.) + endif + !- zws for shallow convection closure (grant 2001) + !- height of the pbl + zws(i) = max(0.,.001-flux_tun(i)*0.41*buo_flux*zo(i,kpbl(i))*g/t(i,kpbl(i))) + zws(i) = 1.2*zws(i)**.3333 + zws(i) = zws(i)*rho(i,kpbl(i)) !check if zrho is correct + enddo +!$acc end kernels +! cap_maxs=225. +! if(imid.eq.1)cap_maxs=150. + cap_maxs=75. ! 150. +! if(imid.eq.1)cap_maxs=100. +!$acc kernels + do i=its,itf + edto(i)=0. + closure_n(i)=16. + xmb_out(i)=0. + cap_max(i)=cap_maxs + cap_max_increment(i)=20. +! if(imid.eq.1)cap_max_increment(i)=10. +! +! for water or ice +! + if (xland1(i)==0) then +! if(imid.eq.0)cap_max(i)=cap_maxs-25. +! if(imid.eq.1)cap_max(i)=cap_maxs-50. + cap_max_increment(i)=20. + else + if(ztexec(i).gt.0.)cap_max(i)=cap_max(i)+25. + if(ztexec(i).lt.0.)cap_max(i)=cap_max(i)-25. + endif +#ifndef _OPENACC + ierrc(i)=" " +#endif +! cap_max_increment(i)=1. + enddo +!$acc end kernels + if(use_excess == 0 )then +!$acc kernels + ztexec(:)=0 + zqexec(:)=0 +!$acc end kernels + endif + if(do_capsuppress == 1) then +!$acc kernels + do i=its,itf + cap_max(i)=cap_maxs + if (abs(cap_suppress_j(i) - 1.0 ) < 0.1 ) then + cap_max(i)=cap_maxs+75. + elseif (abs(cap_suppress_j(i) - 0.0 ) < 0.1 ) then + cap_max(i)=10.0 + endif + enddo +!$acc end kernels + endif +! +!--- initial entrainment rate (these may be changed later on in the +!--- program +! +!$acc kernels + start_level(:)=kte +!$acc end kernels + +!$acc kernels +!$acc loop private(radius,frh) + do i=its,ite + c1d(i,:)= 0. !c1 ! 0. ! c1 ! max(.003,c1+float(csum(i))*.0001) + entr_rate(i)=7.e-5 - min(20.,float(csum(i))) * 3.e-6 + if(xland1(i) == 0)entr_rate(i)=7.e-5 + if(imid.eq.1)entr_rate(i)=3.e-4 +! if(imid.eq.1)c1d(i,:)=c1 ! comment to test warm bias 08/14/17 + radius=.2/entr_rate(i) + frh=min(1.,3.14*radius*radius/dx(i)/dx(i)) + if(frh > frh_thresh)then + frh=frh_thresh + radius=sqrt(frh*dx(i)*dx(i)/3.14) + entr_rate(i)=.2/radius + endif + sig(i)=(1.-frh)**2 + frh_out(i) = frh + enddo +!$acc end kernels + sig_thresh = (1.-frh_thresh)**2 + + +! +!--- entrainment of mass +! +! +!--- initial detrainmentrates +! +!$acc kernels + do k=kts,ktf + do i=its,itf + cnvwt(i,k)=0. + zuo(i,k)=0. + zdo(i,k)=0. + z(i,k)=zo(i,k) + xz(i,k)=zo(i,k) + cupclw(i,k)=0. + cd(i,k)=.1*entr_rate(i) !1.e-9 ! 1.*entr_rate + if(imid.eq.1)cd(i,k)=.5*entr_rate(i) + cdd(i,k)=1.e-9 + hcdo(i,k)=0. + qrcdo(i,k)=0. + dellaqc(i,k)=0. + enddo + enddo +!$acc end kernels +! +!--- max/min allowed value for epsilon (ratio downdraft base mass flux/updraft +! base mass flux +! +!$acc kernels + edtmax(:)=1. + if(imid.eq.1)edtmax(:)=.15 + edtmin(:)=.1 + if(imid.eq.1)edtmin(:)=.05 +!$acc end kernels +! +!--- minimum depth (m), clouds must have +! + depth_min=3000. + if(imid.eq.1)depth_min=2500. +! +!--- maximum depth (mb) of capping +!--- inversion (larger cap = no convection) +! +!$acc kernels + do i=its,itf +! if(imid.eq.0)then +! edtmax(i)=max(0.5,.8-float(csum(i))*.015) !.3) +! if(xland1(i) == 1 )edtmax(i)=max(0.7,1.-float(csum(i))*.015) !.3) +! endif + kbmax(i)=1 + aa0(i)=0. + aa1(i)=0. + edt(i)=0. + kstabm(i)=ktf-1 + ierr2(i)=0 + ierr3(i)=0 + enddo +!$acc end kernels + x_add=0. +! do i=its,itf +! cap_max(i)=cap_maxs +! cap_max3(i)=25. + +! enddo +! +!--- max height(m) above ground where updraft air can originate +! + zkbmax=4000. + if(imid.eq.1)zkbmax=2000. +! +!--- height(m) above which no downdrafts are allowed to originate +! + zcutdown=4000. +! +!--- depth(m) over which downdraft detrains all its mass +! + z_detr=500. +! if(imid.eq.1)z_detr=800. +! + +! +!--- environmental conditions, first heights +! +!$acc kernels + do i=its,itf + do k=1,maxens3 + xf_ens(i,k)=0. + pr_ens(i,k)=0. + enddo + enddo +!$acc end kernels +! +!> - Call cup_env() to calculate moist static energy, heights, qes +! + call cup_env(z,qes,he,hes,t,q,po,z1, & + psur,ierr,tcrit,-1, & + itf,ktf, & + its,ite, kts,kte) + call cup_env(zo,qeso,heo,heso,tn,qo,po,z1, & + psur,ierr,tcrit,-1, & + itf,ktf, & + its,ite, kts,kte) + +! +!> - Call cup_env_clev() to calculate environmental values on cloud levels +! + call cup_env_clev(t,qes,q,he,hes,z,po,qes_cup,q_cup,he_cup, & + hes_cup,z_cup,p_cup,gamma_cup,t_cup,psur, & + ierr,z1, & + itf,ktf, & + its,ite, kts,kte) + call cup_env_clev(tn,qeso,qo,heo,heso,zo,po,qeso_cup,qo_cup, & + heo_cup,heso_cup,zo_cup,po_cup,gammao_cup,tn_cup,psur, & + ierr,z1, & + itf,ktf, & + its,ite, kts,kte) +!---meltglac------------------------------------------------- +!> - Call get_partition_liq_ice() to calculate partition between liq/ice cloud contents + call get_partition_liq_ice(ierr,tn,po_cup,p_liq_ice,melting_layer,& + itf,ktf,its,ite,kts,kte,cumulus) +!---meltglac------------------------------------------------- +!$acc kernels + do i=its,itf + if(ierr(i).eq.0)then + if(kpbl(i).gt.5 .and. imid.eq.1)cap_max(i)=po_cup(i,kpbl(i)) + u_cup(i,kts)=us(i,kts) + v_cup(i,kts)=vs(i,kts) + do k=kts+1,ktf + u_cup(i,k)=.5*(us(i,k-1)+us(i,k)) + v_cup(i,k)=.5*(vs(i,k-1)+vs(i,k)) + enddo + endif + enddo + do i=its,itf + if(ierr(i).eq.0)then + do k=kts,ktf + if(zo_cup(i,k).gt.zkbmax+z1(i))then + kbmax(i)=k + go to 25 + endif + enddo + 25 continue +! +!> - Compute the level where detrainment for downdraft starts (\p kdet) +! + do k=kts,ktf + if(zo_cup(i,k).gt.z_detr+z1(i))then + kdet(i)=k + go to 26 + endif + enddo + 26 continue +! + endif + enddo +!$acc end kernels + +! +! +! +!> - Determine level with highest moist static energy content (\p k22) +! + start_k22=2 +!$acc parallel loop + do 36 i=its,itf + if(ierr(i).eq.0)then + k22(i)=maxloc(heo_cup(i,start_k22:kbmax(i)+2),1)+start_k22-1 + if(k22(i).ge.kbmax(i))then + ierr(i)=2 +#ifndef _OPENACC + ierrc(i)="could not find k22" +#endif + ktop(i)=0 + k22(i)=0 + kbcon(i)=0 + endif + endif + 36 continue +!$acc end parallel + +! +!> - call get_cloud_bc() and cup_kbcon() to determine the +!! level of convective cloud base (\p kbcon) +! +!$acc parallel loop private(x_add) + do i=its,itf + if(ierr(i).eq.0)then + x_add = xlv*zqexec(i)+cp*ztexec(i) + call get_cloud_bc(kte,he_cup (i,1:kte),hkb (i),k22(i),x_add) + call get_cloud_bc(kte,heo_cup (i,1:kte),hkbo (i),k22(i),x_add) + endif ! ierr + enddo +!$acc end parallel + + jprnt=0 + iloop=1 + if(imid.eq.1)iloop=5 + call cup_kbcon(ierrc,cap_max_increment,iloop,k22,kbcon,heo_cup,heso_cup, & + hkbo,ierr,kbmax,po_cup,cap_max, & + ztexec,zqexec, & + jprnt,itf,ktf, & + its,ite, kts,kte, & + z_cup,entr_rate,heo,imid) +! +!> - Call cup_minimi() to increase detrainment in stable layers +! + call cup_minimi(heso_cup,kbcon,kstabm,kstabi,ierr, & + itf,ktf, & + its,ite, kts,kte) +!$acc parallel loop private(frh,x_add) + do i=its,itf + if(ierr(i) == 0)then + frh = min(qo_cup(i,kbcon(i))/qeso_cup(i,kbcon(i)),1.) + if(frh >= rh_thresh .and. sig(i) <= sig_thresh )then + ierr(i)=231 + cycle + endif +! +! never go too low... +! +! if(imid.eq.0 .and. xland1(i).eq.0)x_add=150. + x_add=0. +!$acc loop seq + do k=kbcon(i)+1,ktf + if(po(i,kbcon(i))-po(i,k) > pmin+x_add)then + pmin_lev(i)=k + exit + endif + enddo +! +!> - Call get_cloud_bc() to initial conditions for updraft +! + start_level(i)=k22(i) + x_add = xlv*zqexec(i)+cp*ztexec(i) + call get_cloud_bc(kte,he_cup (i,1:kte),hkb (i),k22(i),x_add) + endif + enddo +!$acc end parallel + +! +!> - Call get_inversion_layer() to get inversion layers for mid level cloud tops +! + if(imid.eq.1)then + call get_inversion_layers(ierr,p_cup,t_cup,z_cup,q_cup,qes_cup,k_inv_layers, & + kbcon,kstabi,dtempdz,itf,ktf,its,ite, kts,kte) + endif +!$acc kernels + do i=its,itf + if(kstabi(i).lt.kbcon(i))then + kbcon(i)=1 + ierr(i)=42 + endif + do k=kts,ktf + entr_rate_2d(i,k)=entr_rate(i) + enddo + if(ierr(i).eq.0)then +! if(imid.eq.0 .and. pmin_lev(i).lt.kbcon(i)+3)pmin_lev(i)=kbcon(i)+3 + kbcon(i)=max(2,kbcon(i)) + do k=kts+1,ktf + frh = min(qo_cup(i,k)/qeso_cup(i,k),1.) + entr_rate_2d(i,k)=entr_rate(i) *(1.3-frh) + enddo + if(imid.eq.1)then + if(k_inv_layers(i,2).gt.0 .and. & + (po_cup(i,k22(i))-po_cup(i,k_inv_layers(i,2))).lt.500.)then + + ktop(i)=min(kstabi(i),k_inv_layers(i,2)) + ktopdby(i)=ktop(i) + else +!$acc loop seq + do k=kbcon(i)+1,ktf + if((po_cup(i,k22(i))-po_cup(i,k)).gt.500.)then + ktop(i)=k + ktopdby(i)=ktop(i) + exit + endif + enddo + endif ! k_inv_lay + endif + + endif + enddo +!$acc end kernels + +! +!> - Call rates_up_pdf() to get normalized mass flux, entrainment and detrainmentrates for updraft +! + i=0 + !- for mid level clouds we do not allow clouds taller than where stability + !- changes + if(imid.eq.1)then + call rates_up_pdf(rand_vmas,ipr,'mid',ktop,ierr,po_cup,entr_rate_2d,hkbo,heo,heso_cup,zo_cup, & + xland1,kstabi,k22,kbcon,its,ite,itf,kts,kte,ktf,zuo,kpbl,ktopdby,csum,pmin_lev) + else + call rates_up_pdf(rand_vmas,ipr,'deep',ktop,ierr,po_cup,entr_rate_2d,hkbo,heo,heso_cup,zo_cup, & + xland1,kstabi,k22,kbcon,its,ite,itf,kts,kte,ktf,zuo,kbcon,ktopdby,csum,pmin_lev) + endif +! +! +! +!$acc kernels + do i=its,itf + if(ierr(i).eq.0)then + + if(k22(i).gt.1)then +!$acc loop independent + do k=1,k22(i) -1 + zuo(i,k)=0. + zu (i,k)=0. + xzu(i,k)=0. + enddo + endif +!$acc loop independent + do k=k22(i),ktop(i) + xzu(i,k)= zuo(i,k) + zu (i,k)= zuo(i,k) + enddo +!$acc loop independent + do k=ktop(i)+1,kte + zuo(i,k)=0. + zu (i,k)=0. + xzu(i,k)=0. + enddo + endif + enddo +!$acc end kernels +! +!> - Call get_lateral_massflux() to calculate mass entrainment and detrainment +! + if(imid.eq.1)then + call get_lateral_massflux(itf,ktf, its,ite, kts,kte & + ,ierr,ktop,zo_cup,zuo,cd,entr_rate_2d & + ,up_massentro, up_massdetro ,up_massentr, up_massdetr & + ,3,kbcon,k22,up_massentru,up_massdetru,lambau) + else + call get_lateral_massflux(itf,ktf, its,ite, kts,kte & + ,ierr,ktop,zo_cup,zuo,cd,entr_rate_2d & + ,up_massentro, up_massdetro ,up_massentr, up_massdetr & + ,1,kbcon,k22,up_massentru,up_massdetru,lambau) + endif + + +! +! note: ktop here already includes overshooting, ktopdby is without +! overshooting +! +!$acc kernels + do k=kts,ktf + do i=its,itf + uc (i,k)=0. + vc (i,k)=0. + hc (i,k)=0. + dby (i,k)=0. + hco (i,k)=0. + dbyo(i,k)=0. + enddo + enddo + do i=its,itf + if(ierr(i).eq.0)then + do k=1,start_level(i) + uc(i,k)=u_cup(i,k) + vc(i,k)=v_cup(i,k) + enddo + do k=1,start_level(i)-1 + hc (i,k)=he_cup(i,k) + hco(i,k)=heo_cup(i,k) + enddo + k=start_level(i) + hc (i,k)=hkb(i) + hco(i,k)=hkbo(i) + endif + enddo +!$acc end kernels +! +!---meltglac------------------------------------------------- + ! + !--- 1st guess for moist static energy and dbyo (not including ice phase) + ! +!$acc parallel loop private(denom,kk,ki) + do i=its,itf + ktopkeep(i)=0 + dbyt(i,:)=0. + if(ierr(i) /= 0) cycle + ktopkeep(i)=ktop(i) +!$acc loop seq + do k=start_level(i) +1,ktop(i) !mass cons option + + denom=zuo(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1) + if(denom.lt.1.e-8)then + ierr(i)=51 + exit + endif + hco(i,k)=(hco(i,k-1)*zuo(i,k-1)-.5*up_massdetro(i,k-1)*hco(i,k-1)+ & + up_massentro(i,k-1)*heo(i,k-1)) / & + (zuo(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1)) + dbyo(i,k)=hco(i,k)-heso_cup(i,k) + enddo + ! for now no overshooting (only very little) + !kk=maxloc(dbyt(i,:),1) + !ki=maxloc(zuo(i,:),1) +!$acc loop seq + do k=ktop(i)-1,kbcon(i),-1 + if(dbyo(i,k).gt.0.)then + ktopkeep(i)=k+1 + exit + endif + enddo + !ktop(i)=ktopkeep(i) + !if(ierr(i).eq.0)ktop(i)=ktopkeep(i) + enddo +!$acc end parallel + +!$acc kernels + do 37 i=its,itf + kzdown(i)=0 + if(ierr(i).eq.0)then + zktop=(zo_cup(i,ktop(i))-z1(i))*.6 + if(imid.eq.1)zktop=(zo_cup(i,ktop(i))-z1(i))*.4 + zktop=min(zktop+z1(i),zcutdown+z1(i)) +!$acc loop seq + do k=kts,ktf + if(zo_cup(i,k).gt.zktop)then + kzdown(i)=k + kzdown(i)=min(kzdown(i),kstabi(i)-1) ! + go to 37 + endif + enddo + endif + 37 continue +!$acc end kernels + +! +!> - Call cup_minimi() to calculate downdraft originating level (\p jmin) +! + call cup_minimi(heso_cup,k22,kzdown,jmin,ierr, & + itf,ktf, & + its,ite, kts,kte) +!$acc kernels + do 100 i=its,itf + if(ierr(i).eq.0)then +! +!-----srf-08aug2017-----begin +! if(imid .ne. 1 .and. melt_glac) jmin(i)=max(jmin(i),maxloc(melting_layer(i,:),1)) +!-----srf-08aug2017-----end + +!--- check whether it would have buoyancy, if there where +!--- no entrainment/detrainment +! + jmini = jmin(i) + keep_going = .true. + do while ( keep_going ) + keep_going = .false. + if ( jmini - 1 .lt. kdet(i) ) kdet(i) = jmini-1 + if ( jmini .ge. ktop(i)-1 ) jmini = ktop(i) - 2 + ki = jmini + hcdo(i,ki)=heso_cup(i,ki) + dz=zo_cup(i,ki+1)-zo_cup(i,ki) + dh=0. +!$acc loop seq + do k=ki-1,1,-1 + hcdo(i,k)=heso_cup(i,jmini) + dz=zo_cup(i,k+1)-zo_cup(i,k) + dh=dh+dz*(hcdo(i,k)-heso_cup(i,k)) + if(dh.gt.0.)then + jmini=jmini-1 + if ( jmini .gt. 5 ) then + keep_going = .true. + else + ierr(i) = 9 +#ifndef _OPENACC + ierrc(i) = "could not find jmini9" +#endif + exit + endif + endif + enddo + enddo + jmin(i) = jmini + if ( jmini .le. 5 ) then + ierr(i)=4 +#ifndef _OPENACC + ierrc(i) = "could not find jmini4" +#endif + endif + endif +100 continue + do i=its,itf + if(ierr(i) /= 0) cycle +! do k=kbcon(i)+1,ktop(i)-1 +!c do k=jmin(i)+1,ktop(i)-1 +!c c1d(i,k)=c1 +!c enddo + !if(imid.eq.1)c1d(i,:)=0. +! do k=kts,ktop(i) +! if(po(i,k).gt.700.)then +! c1d(i,k)=0. +! elseif(po(i,k).gt.600.)then +! c1d(i,k)=0.001 +! elseif(po(i,k).gt.500.)then +! c1d(i,k)=0.002 +! elseif(po(i,k).gt.400.)then +! c1d(i,k)=0.003 +! elseif(po(i,k).gt.300.)then +! c1d(i,k)=0.004 +! elseif(po(i,k).gt.200.)then +! c1d(i,k)=0.005 +! endif +! enddo +! if(imid.eq.1)c1d(i,:)=0.003 +!$acc loop independent + do k=ktop(i)+1,ktf + hco(i,k)=heso_cup(i,k) + dbyo(i,k)=0. + enddo + enddo +!$acc end kernels + ! +!> - Call cup_up_moisture() to calculate moisture properties of updraft + ! + if(imid.eq.1)then + call cup_up_moisture('mid',ierr,zo_cup,qco,qrco,pwo,pwavo, & + p_cup,kbcon,ktop,dbyo,clw_all,xland1, & + qo,gammao_cup,zuo,qeso_cup,k22,qo_cup,c0, & + zqexec,ccn,ccnclean,rho,c1d,tn_cup,autoconv,up_massentr,up_massdetr,psum,psumh, & + 1,itf,ktf, & + its,ite, kts,kte) + else + call cup_up_moisture('deep',ierr,zo_cup,qco,qrco,pwo,pwavo, & + p_cup,kbcon,ktop,dbyo,clw_all,xland1, & + qo,gammao_cup,zuo,qeso_cup,k22,qo_cup,c0, & + zqexec,ccn,ccnclean,rho,c1d,tn_cup,autoconv,up_massentr,up_massdetr,psum,psumh, & + 1,itf,ktf, & + its,ite, kts,kte) + endif +! !--- get melting profile +! call get_melting_profile(ierr,tn_cup,po_cup, p_liq_ice,melting_layer,qrco & +! ,pwo,edto,pwdo,melting & +! ,itf,ktf,its,ite, kts,kte, cumulus ) +!---meltglac------------------------------------------------- + +!$acc kernels + do i=its,itf + + ktopkeep(i)=0 + dbyt(i,:)=0. + if(ierr(i) /= 0) cycle + ktopkeep(i)=ktop(i) +!$acc loop seq + do k=start_level(i) +1,ktop(i) !mass cons option + + denom=zuo(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1) + if(denom.lt.1.e-8)then + ierr(i)=51 + exit + endif + + hc(i,k)=(hc(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)*hc(i,k-1)+ & + up_massentr(i,k-1)*he(i,k-1)) / & + (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) + uc(i,k)=(uc(i,k-1)*zu(i,k-1)-.5*up_massdetru(i,k-1)*uc(i,k-1)+ & + up_massentru(i,k-1)*us(i,k-1) & + -pgcon*.5*(zu(i,k)+zu(i,k-1))*(u_cup(i,k)-u_cup(i,k-1))) / & + (zu(i,k-1)-.5*up_massdetru(i,k-1)+up_massentru(i,k-1)) + vc(i,k)=(vc(i,k-1)*zu(i,k-1)-.5*up_massdetru(i,k-1)*vc(i,k-1)+ & + up_massentru(i,k-1)*vs(i,k-1) & + -pgcon*.5*(zu(i,k)+zu(i,k-1))*(v_cup(i,k)-v_cup(i,k-1))) / & + (zu(i,k-1)-.5*up_massdetru(i,k-1)+up_massentru(i,k-1)) + dby(i,k)=hc(i,k)-hes_cup(i,k) + hco(i,k)=(hco(i,k-1)*zuo(i,k-1)-.5*up_massdetro(i,k-1)*hco(i,k-1)+ & + up_massentro(i,k-1)*heo(i,k-1)) / & + (zuo(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1)) +!---meltglac------------------------------------------------- + ! + !- include glaciation effects on hc,hco + ! ------ ice content -------- + hc (i,k)= hc (i,k)+(1.-p_liq_ice(i,k))*qrco(i,k)*xlf + hco(i,k)= hco(i,k)+(1.-p_liq_ice(i,k))*qrco(i,k)*xlf + + dby(i,k)=hc(i,k)-hes_cup(i,k) +!---meltglac------------------------------------------------- + dbyo(i,k)=hco(i,k)-heso_cup(i,k) + dz=zo_cup(i,k+1)-zo_cup(i,k) + dbyt(i,k)=dbyt(i,k-1)+dbyo(i,k)*dz + + enddo +! for now no overshooting (only very little) + kk=maxloc(dbyt(i,:),1) + ki=maxloc(zuo(i,:),1) +! if(ipr .eq.1)write(16,*)'cupgf2',kk,ki +! if(kk.lt.ki+3)then +! ierr(i)=423 +! endif +! +!$acc loop seq + do k=ktop(i)-1,kbcon(i),-1 + if(dbyo(i,k).gt.0.)then + ktopkeep(i)=k+1 + exit + endif + enddo + !ktop(i)=ktopkeep(i) + !if(ierr(i).eq.0)ktop(i)=ktopkeep(i) + enddo +!$acc end kernels + +41 continue +!$acc kernels + do i=its,itf + if(ierr(i) /= 0) cycle + do k=ktop(i)+1,ktf + hc(i,k)=hes_cup(i,k) + uc(i,k)=u_cup(i,k) + vc(i,k)=v_cup(i,k) + hco(i,k)=heso_cup(i,k) + dby(i,k)=0. + dbyo(i,k)=0. + zu(i,k)=0. + zuo(i,k)=0. + cd(i,k)=0. + entr_rate_2d(i,k)=0. + up_massentr(i,k)=0. + up_massdetr(i,k)=0. + up_massentro(i,k)=0. + up_massdetro(i,k)=0. + enddo + enddo +! + do i=its,itf + if(ierr(i)/=0)cycle + if(ktop(i).lt.kbcon(i)+2)then + ierr(i)=5 +#ifndef _OPENACC + ierrc(i)='ktop too small deep' +#endif + ktop(i)=0 + endif + enddo +!$acc end kernels + +!! do 37 i=its,itf +! kzdown(i)=0 +! if(ierr(i).eq.0)then +! zktop=(zo_cup(i,ktop(i))-z1(i))*.6 +! if(imid.eq.1)zktop=(zo_cup(i,ktop(i))-z1(i))*.4 +! zktop=min(zktop+z1(i),zcutdown+z1(i)) +! do k=kts,ktf +! if(zo_cup(i,k).gt.zktop)then +! kzdown(i)=k +! kzdown(i)=min(kzdown(i),kstabi(i)-1) ! +! go to 37 +! endif +! enddo +! endif +! 37 continue +!! +!!--- downdraft originating level - jmin +!! +! call cup_minimi(heso_cup,k22,kzdown,jmin,ierr, & +! itf,ktf, & +! its,ite, kts,kte) +! do 100 i=its,itf +! if(ierr(i).eq.0)then +!! +!!-----srf-08aug2017-----begin +!! if(imid .ne. 1 .and. melt_glac) jmin(i)=max(jmin(i),maxloc(melting_layer(i,:),1)) +!!-----srf-08aug2017-----end +! +!!--- check whether it would have buoyancy, if there where +!!--- no entrainment/detrainment +!! +! jmini = jmin(i) +! keep_going = .true. +! do while ( keep_going ) +! keep_going = .false. +! if ( jmini - 1 .lt. kdet(i) ) kdet(i) = jmini-1 +! if ( jmini .ge. ktop(i)-1 ) jmini = ktop(i) - 2 +! ki = jmini +! hcdo(i,ki)=heso_cup(i,ki) +! dz=zo_cup(i,ki+1)-zo_cup(i,ki) +! dh=0. +! do k=ki-1,1,-1 +! hcdo(i,k)=heso_cup(i,jmini) +! dz=zo_cup(i,k+1)-zo_cup(i,k) +! dh=dh+dz*(hcdo(i,k)-heso_cup(i,k)) +! if(dh.gt.0.)then +! jmini=jmini-1 +! if ( jmini .gt. 5 ) then +! keep_going = .true. +! else +! ierr(i) = 9 +! ierrc(i) = "could not find jmini9" +! exit +! endif +! endif +! enddo +! enddo +! jmin(i) = jmini +! if ( jmini .le. 5 ) then +! ierr(i)=4 +! ierrc(i) = "could not find jmini4" +! endif +! endif +!100 continue +!! +! - must have at least depth_min m between cloud convective base +! and cloud top. +! +!$acc kernels + do i=its,itf + if(ierr(i).eq.0)then + if ( jmin(i) - 1 .lt. kdet(i) ) kdet(i) = jmin(i)-1 + if(-zo_cup(i,kbcon(i))+zo_cup(i,ktop(i)).lt.depth_min)then + ierr(i)=6 +#ifndef _OPENACC + ierrc(i)="cloud depth very shallow" +#endif + endif + endif + enddo +!$acc end kernels + +! +!--- normalized downdraft mass flux profile,also work on bottom detrainment +!--- in this routine +! +!$acc kernels + do k=kts,ktf + do i=its,itf + zdo(i,k)=0. + cdd(i,k)=0. + dd_massentro(i,k)=0. + dd_massdetro(i,k)=0. + dd_massentru(i,k)=0. + dd_massdetru(i,k)=0. + hcdo(i,k)=heso_cup(i,k) + ucd(i,k)=u_cup(i,k) + vcd(i,k)=v_cup(i,k) + dbydo(i,k)=0. + mentrd_rate_2d(i,k)=entr_rate(i) + enddo + enddo +!$acc end kernels + +!$acc parallel loop private(beta,itemp,dzo,h_entr) + do i=its,itf + if(ierr(i)/=0)cycle + beta=max(.025,.055-float(csum(i))*.0015) !.02 + if(imid.eq.0 .and. xland1(i) == 0)then + edtmax(i)=max(0.1,.4-float(csum(i))*.015) !.3) + endif + if(imid.eq.1)beta=.025 + bud(i)=0. + cdd(i,1:jmin(i))=.1*entr_rate(i) + cdd(i,jmin(i))=0. + dd_massdetro(i,:)=0. + dd_massentro(i,:)=0. + call get_zu_zd_pdf_fim(0,po_cup(i,:),rand_vmas(i),0.0_kind_phys,ipr,xland1(i),zuh2,4, & + ierr(i),kdet(i),jmin(i)+1,zdo(i,:),kts,kte,ktf,beta,kpbl(i),csum(i),pmin_lev(i)) + if(zdo(i,jmin(i)) .lt.1.e-8)then + zdo(i,jmin(i))=0. + jmin(i)=jmin(i)-1 + cdd(i,jmin(i):ktf)=0. + zdo(i,jmin(i)+1:ktf)=0. + if(zdo(i,jmin(i)) .lt.1.e-8)then + ierr(i)=876 + cycle + endif + endif + + itemp = maxloc(zdo(i,:),1) + do ki=jmin(i) , itemp,-1 + !=> from jmin to maximum value zd -> change entrainment + dzo=zo_cup(i,ki+1)-zo_cup(i,ki) + dd_massdetro(i,ki)=cdd(i,ki)*dzo*zdo(i,ki+1) + dd_massentro(i,ki)=zdo(i,ki)-zdo(i,ki+1)+dd_massdetro(i,ki) + if(dd_massentro(i,ki).lt.0.)then + dd_massentro(i,ki)=0. + dd_massdetro(i,ki)=zdo(i,ki+1)-zdo(i,ki) + if(zdo(i,ki+1).gt.0.)cdd(i,ki)=dd_massdetro(i,ki)/(dzo*zdo(i,ki+1)) + endif + if(zdo(i,ki+1).gt.0.)mentrd_rate_2d(i,ki)=dd_massentro(i,ki)/(dzo*zdo(i,ki+1)) + enddo + mentrd_rate_2d(i,1)=0. + do ki=itemp-1,1,-1 + !=> from maximum value zd to surface -> change detrainment + dzo=zo_cup(i,ki+1)-zo_cup(i,ki) + dd_massentro(i,ki)=mentrd_rate_2d(i,ki)*dzo*zdo(i,ki+1) + dd_massdetro(i,ki) = zdo(i,ki+1)+dd_massentro(i,ki)-zdo(i,ki) + if(dd_massdetro(i,ki).lt.0.)then + dd_massdetro(i,ki)=0. + dd_massentro(i,ki)=zdo(i,ki)-zdo(i,ki+1) + if(zdo(i,ki+1).gt.0.)mentrd_rate_2d(i,ki)=dd_massentro(i,ki)/(dzo*zdo(i,ki+1)) + endif + if(zdo(i,ki+1).gt.0.)cdd(i,ki)= dd_massdetro(i,ki)/(dzo*zdo(i,ki+1)) + enddo +! cbeg=800. !po_cup(i,kbcon(i)) !850. +! cend=min(po_cup(i,ktop(i)),200.) +! cmid=.5*(cbeg+cend) !600. +! const_b=c1/((cmid*cmid-cbeg*cbeg)*(cbeg-cend)/(cend*cend-cbeg*cbeg)+cmid-cbeg) +! const_a=const_b*(cbeg-cend)/(cend*cend-cbeg*cbeg) +! const_c=-const_a*cbeg*cbeg-const_b*cbeg +! do k=kbcon(i)+1,ktop(i)-1 +! c1d(i,k)=const_a*po_cup(i,k)*po_cup(i,k)+const_b*po_cup(i,k)+const_c +! c1d(i,k)=max(0.,c1d(i,k)) +!! c1d(i,k)=c1 +! enddo +!! if(imid.eq.1)c1d(i,:)=0. +!! do k=1,jmin(i) +!! c1d(i,k)=0. +!! enddo +!! c1d(i,jmin(i)-2)=c1/40. +!! if(imid.eq.1)c1d(i,jmin(i)-2)=c1/20. +!! do k=jmin(i)-1,ktop(i) +!! dz=zo_cup(i,ktop(i))-zo_cup(i,jmin(i)) +!! c1d(i,k)=c1d(i,k-1)+c1*(zo_cup(i,k+1)-zo_cup(i,k))/dz +!! c1d(i,k)=max(0.,c1d(i,k)) +!! c1d(i,k)=min(.002,c1d(i,k)) +!! enddo +! +! +!> - Compute downdraft moist static energy + moisture budget + do k=2,jmin(i)+1 + dd_massentru(i,k-1)=dd_massentro(i,k-1)+lambau(i)*dd_massdetro(i,k-1) + dd_massdetru(i,k-1)=dd_massdetro(i,k-1)+lambau(i)*dd_massdetro(i,k-1) + enddo + dbydo(i,jmin(i))=hcdo(i,jmin(i))-heso_cup(i,jmin(i)) + bud(i)=dbydo(i,jmin(i))*(zo_cup(i,jmin(i)+1)-zo_cup(i,jmin(i))) + ucd(i,jmin(i)+1)=.5*(uc(i,jmin(i)+1)+u_cup(i,jmin(i)+1)) +!$acc loop seq + do ki=jmin(i) ,1,-1 + dzo=zo_cup(i,ki+1)-zo_cup(i,ki) + h_entr=.5*(heo(i,ki)+.5*(hco(i,ki)+hco(i,ki+1))) + ucd(i,ki)=(ucd(i,ki+1)*zdo(i,ki+1) & + -.5*dd_massdetru(i,ki)*ucd(i,ki+1)+ & + dd_massentru(i,ki)*us(i,ki) & + -pgcon*zdo(i,ki+1)*(us(i,ki+1)-us(i,ki))) / & + (zdo(i,ki+1)-.5*dd_massdetru(i,ki)+dd_massentru(i,ki)) + vcd(i,ki)=(vcd(i,ki+1)*zdo(i,ki+1) & + -.5*dd_massdetru(i,ki)*vcd(i,ki+1)+ & + dd_massentru(i,ki)*vs(i,ki) & + -pgcon*zdo(i,ki+1)*(vs(i,ki+1)-vs(i,ki))) / & + (zdo(i,ki+1)-.5*dd_massdetru(i,ki)+dd_massentru(i,ki)) + hcdo(i,ki)=(hcdo(i,ki+1)*zdo(i,ki+1) & + -.5*dd_massdetro(i,ki)*hcdo(i,ki+1)+ & + dd_massentro(i,ki)*h_entr) / & + (zdo(i,ki+1)-.5*dd_massdetro(i,ki)+dd_massentro(i,ki)) + dbydo(i,ki)=hcdo(i,ki)-heso_cup(i,ki) + bud(i)=bud(i)+dbydo(i,ki)*dzo + enddo + ! endif + + if(bud(i).gt.0)then + ierr(i)=7 +#ifndef _OPENACC + ierrc(i)='downdraft is not negatively buoyant ' +#endif + endif + enddo +!$acc end parallel + +! +!> - Call cup_dd_moisture() to calculate moisture properties of downdraft +! + call cup_dd_moisture(ierrc,zdo,hcdo,heso_cup,qcdo,qeso_cup, & + pwdo,qo_cup,zo_cup,dd_massentro,dd_massdetro,jmin,ierr,gammao_cup, & + pwevo,bu,qrcdo,qo,heo,1, & + itf,ktf, & + its,ite, kts,kte) +! +!---meltglac------------------------------------------------- +!--- calculate moisture properties of updraft +! +! if(imid.eq.1)then +! call cup_up_moisture('mid',ierr,zo_cup,qco,qrco,pwo,pwavo, & +! p_cup,kbcon,ktop,dbyo,clw_all,xland1, & +! qo,gammao_cup,zuo,qeso_cup,k22,qo_cup,c0, & +! zqexec,ccn,rho,c1d,tn_cup,up_massentr,up_massdetr,psum,psumh, & +! 1,itf,ktf, & +! its,ite, kts,kte) +! else +! call cup_up_moisture('deep',ierr,zo_cup,qco,qrco,pwo,pwavo, & +! p_cup,kbcon,ktop,dbyo,clw_all,xland1, & +! qo,gammao_cup,zuo,qeso_cup,k22,qo_cup,c0, & +! zqexec,ccn,rho,c1d,tn_cup,up_massentr,up_massdetr,psum,psumh, & +! 1,itf,ktf, & +! its,ite, kts,kte) +! endif +!---meltglac------------------------------------------------- +!$acc kernels + do i=its,itf + if(ierr(i)/=0)cycle + do k=kts+1,ktop(i) + dp=100.*(po_cup(i,1)-po_cup(i,2)) + cupclw(i,k)=qrco(i,k) ! my mod + cnvwt(i,k)=zuo(i,k)*cupclw(i,k)*g/dp + enddo + enddo +!$acc end kernels +! +!> - Call cup_up_aa0() to calculate workfunctions for updrafts +! + call cup_up_aa0(aa0,z,zu,dby,gamma_cup,t_cup, & + kbcon,ktop,ierr, & + itf,ktf, & + its,ite, kts,kte) + call cup_up_aa0(aa1,zo,zuo,dbyo,gammao_cup,tn_cup, & + kbcon,ktop,ierr, & + itf,ktf, & + its,ite, kts,kte) + +!$acc kernels + do i=its,itf + if(ierr(i)/=0)cycle + if(aa1(i).eq.0.)then + ierr(i)=17 +#ifndef _OPENACC + ierrc(i)="cloud work function zero" +#endif + endif + enddo +!$acc end kernels + +! +!--- diurnal cycle closure +! + !--- aa1 from boundary layer (bl) processes only +!$acc kernels + aa1_bl (:) = 0.0 + xf_dicycle (:) = 0.0 + tau_ecmwf (:) = 0. +!$acc end kernels + !- way to calculate the fraction of cape consumed by shallow convection + iversion=1 ! ecmwf + !iversion=0 ! orig + ! + ! betchold et al 2008 time-scale of cape removal +! +! wmean is of no meaning over land.... +! still working on replacing it over water +! +!$acc kernels + do i=its,itf + if(ierr(i).eq.0)then + !- mean vertical velocity + wmean(i) = 3.0 ! m/s ! in the future change for wmean == integral( w dz) / cloud_depth + if(imid.eq.1)wmean(i) = 3.0 + !- time-scale cape removal from betchold et al. 2008 + tau_ecmwf(i)=( zo_cup(i,ktop(i))- zo_cup(i,kbcon(i)) ) / wmean(i) + tau_ecmwf(i)=max(tau_ecmwf(i),720.) + tau_ecmwf(i)= tau_ecmwf(i) * (1.0061 + 1.23e-2 * (dx(i)/1000.))! dx(i) must be in meters + endif + enddo + tau_bl(:) = 0. +!$acc end kernels + + ! + if(dicycle == 1) then +!$acc kernels + do i=its,itf + + if(ierr(i).eq.0)then + if(xland1(i) == 0 ) then + !- over water + umean= 2.0+sqrt(0.5*(us(i,1)**2+vs(i,1)**2+us(i,kbcon(i))**2+vs(i,kbcon(i))**2)) + tau_bl(i) = (zo_cup(i,kbcon(i))- z1(i)) /umean + else + !- over land + tau_bl(i) =( zo_cup(i,ktopdby(i))- zo_cup(i,kbcon(i)) ) / wmean(i) + endif + + endif + enddo +!$acc end kernels + + if(iversion == 1) then + !-- version ecmwf + t_star=1. + + !-- calculate pcape from bl forcing only +!> - Call cup_up_aa1bl() to calculate ECMWF version diurnal cycle closure + call cup_up_aa1bl(aa1_bl,t,tn,q,qo,dtime, & + zo_cup,zuo,dbyo_bl,gammao_cup_bl,tn_cup_bl, & + kbcon,ktop,ierr, & + itf,ktf,its,ite, kts,kte) +!$acc kernels + do i=its,itf + + if(ierr(i).eq.0)then + + !- only for convection rooting in the pbl + !if(zo_cup(i,kbcon(i))-z1(i) > zo(i,kpbl(i)+1)) then + ! aa1_bl(i) = 0.0 + !else + !- multiply aa1_bl the " time-scale" - tau_bl + ! aa1_bl(i) = max(0.,aa1_bl(i)/t_star* tau_bl(i)) + aa1_bl(i) = ( aa1_bl(i)/t_star)* tau_bl(i) + !endif + endif + enddo +!$acc end kernels + + else + + !- version for real cloud-work function + +!$acc kernels + !-get the profiles modified only by bl tendencies + do i=its,itf + tn_bl(i,:)=0.;qo_bl(i,:)=0. + if ( ierr(i) == 0 )then + !below kbcon -> modify profiles + tn_bl(i,1:kbcon(i)) = tn(i,1:kbcon(i)) + qo_bl(i,1:kbcon(i)) = qo(i,1:kbcon(i)) + !above kbcon -> keep environment profiles + tn_bl(i,kbcon(i)+1:ktf) = t(i,kbcon(i)+1:ktf) + qo_bl(i,kbcon(i)+1:ktf) = q(i,kbcon(i)+1:ktf) + endif + enddo +!$acc end kernels + !> - Call cup_env() to calculate moist static energy, heights, qes, ... only by bl tendencies + call cup_env(zo,qeso_bl,heo_bl,heso_bl,tn_bl,qo_bl,po,z1, & + psur,ierr,tcrit,-1, & + itf,ktf, its,ite, kts,kte) + !> - Call cup_env_clev() to calculate environmental values on cloud levels only by bl tendencies + call cup_env_clev(tn_bl,qeso_bl,qo_bl,heo_bl,heso_bl,zo,po,qeso_cup_bl,qo_cup_bl, & + heo_cup_bl,heso_cup_bl,zo_cup,po_cup,gammao_cup_bl,tn_cup_bl,psur, & + ierr,z1, & + itf,ktf,its,ite, kts,kte) +!$acc kernels + do i=its,itf + if(ierr(i).eq.0)then + hkbo_bl(i)=heo_cup_bl(i,k22(i)) + endif ! ierr + enddo + do k=kts,ktf + do i=its,itf + hco_bl (i,k)=0. + dbyo_bl(i,k)=0. + enddo + enddo + do i=its,itf + if(ierr(i).eq.0)then + do k=1,kbcon(i)-1 + hco_bl(i,k)=hkbo_bl(i) + enddo + k=kbcon(i) + hco_bl (i,k)=hkbo_bl(i) + dbyo_bl(i,k)=hkbo_bl(i) - heso_cup_bl(i,k) + endif + enddo +! +! + do i=its,itf + if(ierr(i).eq.0)then + do k=kbcon(i)+1,ktop(i) + hco_bl(i,k)=(hco_bl(i,k-1)*zuo(i,k-1)-.5*up_massdetro(i,k-1)*hco_bl(i,k-1)+ & + up_massentro(i,k-1)*heo_bl(i,k-1)) / & + (zuo(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1)) + dbyo_bl(i,k)=hco_bl(i,k)-heso_cup_bl(i,k) + enddo + do k=ktop(i)+1,ktf + hco_bl (i,k)=heso_cup_bl(i,k) + dbyo_bl(i,k)=0.0 + enddo + endif + enddo +!$acc end kernels + !> - Call cup_ip_aa0() to calculate workfunctions for updrafts + call cup_up_aa0(aa1_bl,zo,zuo,dbyo_bl,gammao_cup_bl,tn_cup_bl, & + kbcon,ktop,ierr, & + itf,ktf,its,ite, kts,kte) +!$acc kernels + do i=its,itf + + if(ierr(i).eq.0)then + !- get the increment on aa0 due the bl processes + aa1_bl(i) = aa1_bl(i) - aa0(i) + !- only for convection rooting in the pbl + !if(zo_cup(i,kbcon(i))-z1(i) > 500.0) then !- instead 500 -> zo_cup(kpbl(i)) + ! aa1_bl(i) = 0.0 + !else + ! !- multiply aa1_bl the "normalized time-scale" - tau_bl/ model_timestep + aa1_bl(i) = aa1_bl(i)* tau_bl(i)/ dtime + !endif +#ifndef _OPENACC + print*,'aa0,aa1bl=',aa0(i),aa1_bl(i),aa0(i)-aa1_bl(i),tau_bl(i)!,dtime,xland(i) +#endif + endif + enddo +!$acc end kernels + endif + endif ! version of implementation + +!$acc kernels + axx(:)=aa1(:) +!$acc end kernels + +! +!> - Call cup_dd_edt() to determine downdraft strength in terms of windshear +! + call cup_dd_edt(ierr,us,vs,zo,ktop,kbcon,edt,po,pwavo, & + pwo,ccn,ccnclean,pwevo,edtmax,edtmin,edtc,psum,psumh, & + rho,aeroevap,pefc,itf,ktf, & + its,ite, kts,kte) + do i=its,itf + if(ierr(i)/=0)cycle + edto(i)=edtc(i,1) + enddo + +!> - Call get_melting_profile() to get melting profile + call get_melting_profile(ierr,tn_cup,po_cup, p_liq_ice,melting_layer,qrco & + ,pwo,edto,pwdo,melting & + ,itf,ktf,its,ite, kts,kte, cumulus ) +!$acc kernels + do k=kts,ktf + do i=its,itf + dellat_ens (i,k,1)=0. + dellaq_ens (i,k,1)=0. + dellaqc_ens(i,k,1)=0. + pwo_ens (i,k,1)=0. + enddo + enddo +! +!--- change per unit mass that a model cloud would modify the environment +! +!--- 1. in bottom layer +! + do k=kts,kte + do i=its,itf + dellu (i,k)=0. + dellv (i,k)=0. + dellah (i,k)=0. + dellat (i,k)=0. + dellaq (i,k)=0. + dellaqc(i,k)=0. + enddo + enddo +!$acc end kernels +! +!---------------------------------------------- cloud level ktop +! +!- - - - - - - - - - - - - - - - - - - - - - - - model level ktop-1 +! . . . +! . . . +! . . . +! . . . +! . . . +! . . . +! +!---------------------------------------------- cloud level k+2 +! +!- - - - - - - - - - - - - - - - - - - - - - - - model level k+1 +! +!---------------------------------------------- cloud level k+1 +! +!- - - - - - - - - - - - - - - - - - - - - - - - model level k +! +!---------------------------------------------- cloud level k +! +! . . . +! . . . +! . . . +! . . . +! . . . +! . . . +! . . . +! . . . +! . . . +! . . . +! +!---------------------------------------------- cloud level 3 +! +!- - - - - - - - - - - - - - - - - - - - - - - - model level 2 +! +!---------------------------------------------- cloud level 2 +! +!- - - - - - - - - - - - - - - - - - - - - - - - model level 1 +!$acc kernels + do i=its,itf + if(ierr(i)/=0)cycle + dp=100.*(po_cup(i,1)-po_cup(i,2)) + dellu(i,1)=pgcd*(edto(i)*zdo(i,2)*ucd(i,2) & + -edto(i)*zdo(i,2)*u_cup(i,2))*g/dp & + -zuo(i,2)*(uc (i,2)-u_cup(i,2)) *g/dp + dellv(i,1)=pgcd*(edto(i)*zdo(i,2)*vcd(i,2) & + -edto(i)*zdo(i,2)*v_cup(i,2))*g/dp & + -zuo(i,2)*(vc (i,2)-v_cup(i,2)) *g/dp + + do k=kts+1,ktop(i) + ! these three are only used at or near mass detrainment and/or entrainment levels + pgc=pgcon + entupk=0. + if(k == k22(i)-1) entupk=zuo(i,k+1) + detupk=0. + entdoj=0. + ! detrainment and entrainment for fowndrafts + detdo=edto(i)*dd_massdetro(i,k) + entdo=edto(i)*dd_massentro(i,k) + ! entrainment/detrainment for updraft + entup=up_massentro(i,k) + detup=up_massdetro(i,k) + ! subsidence by downdrafts only + subin=-zdo(i,k+1)*edto(i) + subdown=-zdo(i,k)*edto(i) + ! special levels + if(k.eq.ktop(i))then + detupk=zuo(i,ktop(i)) + subin=0. + subdown=0. + detdo=0. + entdo=0. + entup=0. + detup=0. + endif + totmas=subin-subdown+detup-entup-entdo+ & + detdo-entupk-entdoj+detupk+zuo(i,k+1)-zuo(i,k) + if(abs(totmas).gt.1.e-6)then +#ifndef _OPENACC + write(0,123)'totmas=',k22(i),kbcon(i),k,entup,detup,edto(i),zdo(i,k+1),dd_massdetro(i,k),dd_massentro(i,k) +123 format(a7,1x,3i3,2e12.4,1(1x,f5.2),3e12.4) +#endif + endif + dp=100.*(po_cup(i,k)-po_cup(i,k+1)) + pgc=pgcon + if(k.ge.ktop(i))pgc=0. + + dellu(i,k) =-(zuo(i,k+1)*(uc (i,k+1)-u_cup(i,k+1) ) - & + zuo(i,k )*(uc (i,k )-u_cup(i,k ) ) )*g/dp & + +(zdo(i,k+1)*(ucd(i,k+1)-u_cup(i,k+1) ) - & + zdo(i,k )*(ucd(i,k )-u_cup(i,k ) ) )*g/dp*edto(i)*pgcd + dellv(i,k) =-(zuo(i,k+1)*(vc (i,k+1)-v_cup(i,k+1) ) - & + zuo(i,k )*(vc (i,k )-v_cup(i,k ) ) )*g/dp & + +(zdo(i,k+1)*(vcd(i,k+1)-v_cup(i,k+1) ) - & + zdo(i,k )*(vcd(i,k )-v_cup(i,k ) ) )*g/dp*edto(i)*pgcd + + enddo ! k + + enddo + + + do i=its,itf + !trash = 0.0 + !trash2 = 0.0 + if(ierr(i).eq.0)then + + dp=100.*(po_cup(i,1)-po_cup(i,2)) + + dellah(i,1)=(edto(i)*zdo(i,2)*hcdo(i,2) & + -edto(i)*zdo(i,2)*heo_cup(i,2))*g/dp & + -zuo(i,2)*(hco(i,2)-heo_cup(i,2))*g/dp + + dellaq (i,1)=(edto(i)*zdo(i,2)*qcdo(i,2) & + -edto(i)*zdo(i,2)*qo_cup(i,2))*g/dp & + -zuo(i,2)*(qco(i,2)-qo_cup(i,2))*g/dp + + g_rain= 0.5*(pwo (i,1)+pwo (i,2))*g/dp + e_dn = -0.5*(pwdo(i,1)+pwdo(i,2))*g/dp*edto(i) ! pwdo < 0 and e_dn must > 0 + dellaq(i,1) = dellaq(i,1)+ e_dn-g_rain + + !--- conservation check + !- water mass balance + !trash = trash + (dellaq(i,1)+dellaqc(i,1)+g_rain-e_dn)*dp/g + !- h budget + !trash2 = trash2+ (dellah(i,1))*dp/g + + + do k=kts+1,ktop(i) + dp=100.*(po_cup(i,k)-po_cup(i,k+1)) + ! these three are only used at or near mass detrainment and/or entrainment levels + + dellah(i,k) =-(zuo(i,k+1)*(hco (i,k+1)-heo_cup(i,k+1) ) - & + zuo(i,k )*(hco (i,k )-heo_cup(i,k ) ) )*g/dp & + +(zdo(i,k+1)*(hcdo(i,k+1)-heo_cup(i,k+1) ) - & + zdo(i,k )*(hcdo(i,k )-heo_cup(i,k ) ) )*g/dp*edto(i) + +!---meltglac------------------------------------------------- + + dellah(i,k) = dellah(i,k) + xlf*((1.-p_liq_ice(i,k))*0.5*(qrco(i,k+1)+qrco(i,k)) & + - melting(i,k))*g/dp + +!---meltglac------------------------------------------------- + + !- check h conservation + ! trash2 = trash2+ (dellah(i,k))*dp/g + + + !-- take out cloud liquid water for detrainment + detup=up_massdetro(i,k) + dz=zo_cup(i,k)-zo_cup(i,k-1) +!! if(k.lt.ktop(i) .and. k.ge.jmin(i)) then +!! if(k.lt.ktop(i) .and. c1d(i,k).gt.0) then + if(k.lt.ktop(i)) then + dellaqc(i,k) = zuo(i,k)*c1d(i,k)*qrco(i,k)*dz/dp*g + else + dellaqc(i,k)= detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp + endif +!! if(imid.eq.1) dellaqc(i,k)= detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp +! if(k.eq.ktop(i))dellaqc(i,k)= detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp +! !--- + g_rain= 0.5*(pwo (i,k)+pwo (i,k+1))*g/dp + e_dn = -0.5*(pwdo(i,k)+pwdo(i,k+1))*g/dp*edto(i) ! pwdo < 0 and e_dn must > 0 + !-- condensation source term = detrained + flux divergence of + !-- cloud liquid water (qrco) + converted to rain + + c_up = dellaqc(i,k)+(zuo(i,k+1)* qrco(i,k+1) - & + zuo(i,k )* qrco(i,k ) )*g/dp + g_rain +! c_up = dellaqc(i,k)+ g_rain + !-- water vapor budget + !-- = flux divergence z*(q_c - q_env)_up_and_down & + !-- - condensation term + evaporation + dellaq(i,k) =-(zuo(i,k+1)*(qco (i,k+1)-qo_cup(i,k+1) ) - & + zuo(i,k )*(qco (i,k )-qo_cup(i,k ) ) )*g/dp & + +(zdo(i,k+1)*(qcdo(i,k+1)-qo_cup(i,k+1) ) - & + zdo(i,k )*(qcdo(i,k )-qo_cup(i,k ) ) )*g/dp*edto(i) & + - c_up + e_dn + !- check water conservation liq+condensed (including rainfall) + ! trash= trash+ (dellaq(i,k)+dellaqc(i,k)+ g_rain-e_dn)*dp/g + + enddo ! k + endif + + enddo +!$acc end kernels + +444 format(1x,i2,1x,7e12.4) !,1x,f7.2,2x,e13.5) +! +!--- using dellas, calculate changed environmental profiles +! + mbdt=.1 +!$acc kernels + do i=its,itf + xaa0_ens(i,1)=0. + enddo + + do i=its,itf + if(ierr(i).eq.0)then + do k=kts,ktf + xhe(i,k)=dellah(i,k)*mbdt+heo(i,k) +! xq(i,k)=max(1.e-16,(dellaqc(i,k)+dellaq(i,k))*mbdt+qo(i,k)) + xq(i,k)=max(1.e-16,dellaq(i,k)*mbdt+qo(i,k)) + dellat(i,k)=(1./cp)*(dellah(i,k)-xlv*dellaq(i,k)) +! xt(i,k)= (dellat(i,k)-xlv/cp*dellaqc(i,k))*mbdt+tn(i,k) + xt(i,k)= dellat(i,k)*mbdt+tn(i,k) + xt(i,k)=max(190.,xt(i,k)) + enddo + + ! Smooth dellas (HCB) + do k=kts+1,ktf + xt(i,k)=tn(i,k)+0.25*(dellat(i,k-1) + 2.*dellat(i,k) + dellat(i,k+1)) * mbdt + xt(i,k)=max(190.,xt(i,k)) + xq(i,k)=max(1.e-16, qo(i,k)+0.25*(dellaq(i,k-1) + 2.*dellaq(i,k) + dellaq(i,k+1)) * mbdt) + xhe(i,k)=heo(i,k)+0.25*(dellah(i,k-1) + 2.*dellah(i,k) + dellah(i,k+1)) * mbdt + enddo + endif + enddo + do i=its,itf + if(ierr(i).eq.0)then + xhe(i,ktf)=heo(i,ktf) + xq(i,ktf)=qo(i,ktf) + xt(i,ktf)=tn(i,ktf) + endif + enddo +!$acc end kernels +! +!> - Call cup_env() to calculate moist static energy, heights, qes +! + call cup_env(xz,xqes,xhe,xhes,xt,xq,po,z1, & + psur,ierr,tcrit,-1, & + itf,ktf, & + its,ite, kts,kte) +! +!> - Call cup_env_clev() to calculate environmental values on cloud levels +! + call cup_env_clev(xt,xqes,xq,xhe,xhes,xz,po,xqes_cup,xq_cup, & + xhe_cup,xhes_cup,xz_cup,po_cup,gamma_cup,xt_cup,psur, & + ierr,z1, & + itf,ktf, & + its,ite, kts,kte) +! +! +!**************************** static control +! +!--- moist static energy inside cloud +! +!$acc kernels + do k=kts,ktf + do i=its,itf + xhc(i,k)=0. + xdby(i,k)=0. + enddo + enddo +!$acc end kernels +!$acc parallel loop private(x_add,k) + do i=its,itf + if(ierr(i).eq.0)then + x_add = xlv*zqexec(i)+cp*ztexec(i) + call get_cloud_bc(kte,xhe_cup (i,1:kte),xhkb (i),k22(i),x_add) + do k=1,start_level(i)-1 + xhc(i,k)=xhe_cup(i,k) + enddo + k=start_level(i) + xhc(i,k)=xhkb(i) + endif !ierr + enddo +!$acc end parallel +! +! +!$acc kernels + do i=its,itf + if(ierr(i).eq.0)then +!$acc loop seq + do k=start_level(i) +1,ktop(i) + xhc(i,k)=(xhc(i,k-1)*xzu(i,k-1)-.5*up_massdetro(i,k-1)*xhc(i,k-1) + & + up_massentro(i,k-1)*xhe(i,k-1)) / & + (xzu(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1)) + + +!---meltglac------------------------------------------------- + ! + !- include glaciation effects on xhc + ! ------ ice content -------- + xhc (i,k)= xhc (i,k)+ xlf*(1.-p_liq_ice(i,k))*qrco(i,k) +!---meltglac------------------------------------------------- + + xdby(i,k)=xhc(i,k)-xhes_cup(i,k) + enddo +!$acc loop independent + do k=ktop(i)+1,ktf + xhc (i,k)=xhes_cup(i,k) + xdby(i,k)=0. + enddo + endif + enddo +!$acc end kernels +! +!> - Call cup_up_aa0() to calculate workfunctions for updraft +! + call cup_up_aa0(xaa0,xz,xzu,xdby,gamma_cup,xt_cup, & + kbcon,ktop,ierr, & + itf,ktf, & + its,ite, kts,kte) +!$acc parallel loop + do i=its,itf + if(ierr(i).eq.0)then + xaa0_ens(i,1)=xaa0(i) +!$acc loop seq + do k=kts,ktop(i) +!$acc loop independent + do nens3=1,maxens3 + if(nens3.eq.7)then +!--- b=0 + pr_ens(i,nens3)=pr_ens(i,nens3) & + +pwo(i,k)+edto(i)*pwdo(i,k) +!--- b=beta + else if(nens3.eq.8)then + pr_ens(i,nens3)=pr_ens(i,nens3)+ & + pwo(i,k)+edto(i)*pwdo(i,k) +!--- b=beta/2 + else if(nens3.eq.9)then + pr_ens(i,nens3)=pr_ens(i,nens3) & + + pwo(i,k)+edto(i)*pwdo(i,k) + else + pr_ens(i,nens3)=pr_ens(i,nens3)+ & + pwo(i,k) +edto(i)*pwdo(i,k) + endif + enddo + enddo + if(pr_ens(i,7).lt.1.e-6)then + ierr(i)=18 +#ifndef _OPENACC + ierrc(i)="total normalized condensate too small" +#endif + do nens3=1,maxens3 + pr_ens(i,nens3)=0. + enddo + endif + do nens3=1,maxens3 + if(pr_ens(i,nens3).lt.1.e-5)then + pr_ens(i,nens3)=0. + endif + enddo + endif + enddo +!$acc end parallel + 200 continue +! +!--- large scale forcing +! +! +!------- check wether aa0 should have been zero, assuming this +! ensemble is chosen +! +! +!$acc kernels + do i=its,itf + ierr2(i)=ierr(i) + ierr3(i)=ierr(i) + k22x(i)=k22(i) + enddo +!$acc end kernels + call cup_maximi(heo_cup,2,kbmax,k22x,ierr, & + itf,ktf, & + its,ite, kts,kte) + iloop=2 + call cup_kbcon(ierrc,cap_max_increment,iloop,k22x,kbconx,heo_cup, & + heso_cup,hkbo,ierr2,kbmax,po_cup,cap_max, & + ztexec,zqexec, & + 0,itf,ktf, & + its,ite, kts,kte, & + z_cup,entr_rate,heo,imid) + iloop=3 + call cup_kbcon(ierrc,cap_max_increment,iloop,k22x,kbconx,heo_cup, & + heso_cup,hkbo,ierr3,kbmax,po_cup,cap_max, & + ztexec,zqexec, & + 0,itf,ktf, & + its,ite, kts,kte, & + z_cup,entr_rate,heo,imid) +! +!> - Call cup_forcing_ens_3d() to calculate cloud base mass flux +! +!$acc kernels + do i = its,itf + mconv(i) = 0 + if(ierr(i)/=0)cycle +!$acc loop independent + do k=1,ktop(i) + dq=(qo_cup(i,k+1)-qo_cup(i,k)) +!$acc atomic update + mconv(i)=mconv(i)+omeg(i,k)*dq/g + enddo + enddo +!$acc end kernels + call cup_forcing_ens_3d(closure_n,xland1,aa0,aa1,xaa0_ens,mbdt,dtime, & + ierr,ierr2,ierr3,xf_ens,axx,forcing, & + maxens3,mconv,rand_clos, & + po_cup,ktop,omeg,zdo,zdm,k22,zuo,pr_ens,edto,edtm,kbcon, & + ichoice, & + imid,ipr,itf,ktf, & + its,ite, kts,kte, & + dicycle,tau_ecmwf,aa1_bl,xf_dicycle) +! +!$acc kernels + do k=kts,ktf + do i=its,itf + if(ierr(i).eq.0)then + dellat_ens (i,k,1)=dellat(i,k) + dellaq_ens (i,k,1)=dellaq(i,k) + dellaqc_ens(i,k,1)=dellaqc(i,k) + pwo_ens (i,k,1)=pwo(i,k) +edto(i)*pwdo(i,k) + else + dellat_ens (i,k,1)=0. + dellaq_ens (i,k,1)=0. + dellaqc_ens(i,k,1)=0. + pwo_ens (i,k,1)=0. + endif + enddo + enddo +!$acc end kernels + + 250 continue +! +!--- feedback +! + if(imid.eq.1 .and. ichoice .le.2)then +!$acc kernels + do i=its,itf + !-boundary layer qe + xff_mid(i,1)=0. + xff_mid(i,2)=0. + if(ierr(i).eq.0)then + blqe=0. + trash=0. + if(k22(i).lt.kpbl(i)+1)then + do k=1,kpbl(i) + blqe=blqe+100.*dhdt(i,k)*(po_cup(i,k)-po_cup(i,k+1))/g + enddo + trash=max((hco(i,kbcon(i))-heo_cup(i,kbcon(i))),1.e1) + xff_mid(i,1)=max(0.,blqe/trash) + xff_mid(i,1)=min(0.1,xff_mid(i,1)) + endif + xff_mid(i,2)=min(0.1,.03*zws(i)) + endif + enddo +!$acc end kernels + endif + call cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat_ens,dellaq_ens, & + dellaqc_ens,outt, & + outq,outqc,zuo,pre,pwo_ens,xmb,ktop, & + edto,pwdo,'deep',ierr2,ierr3, & + po_cup,pr_ens,maxens3, & + sig,closure_n,xland1,xmbm_in,xmbs_in, & + ichoice,imid,ipr,itf,ktf, & + its,ite, kts,kte, & + dicycle,xf_dicycle ) + +!> - Call rain_evap_below_cloudbase() to calculate evaporation below cloud base + + call rain_evap_below_cloudbase(itf,ktf,its,ite, & + kts,kte,ierr,kbcon,xmb,psur,xland,qo_cup, & + po_cup,qes_cup,pwavo,edto,pwevo,pre,outt,outq) !,outbuoy) + + k=1 +!$acc kernels + do i=its,itf + if(ierr(i).eq.0 .and.pre(i).gt.0.) then + pre(i)=max(pre(i),0.) + xmb_out(i)=xmb(i) + outu(i,1)=dellu(i,1)*xmb(i) + outv(i,1)=dellv(i,1)*xmb(i) + do k=kts+1,ktop(i) + outu(i,k)=.25*(dellu(i,k-1)+2.*dellu(i,k)+dellu(i,k+1))*xmb(i) + outv(i,k)=.25*(dellv(i,k-1)+2.*dellv(i,k)+dellv(i,k+1))*xmb(i) + enddo + elseif(ierr(i).ne.0 .or. pre(i).eq.0.)then + ktop(i)=0 + do k=kts,kte + outt(i,k)=0. + outq(i,k)=0. + outqc(i,k)=0. + outu(i,k)=0. + outv(i,k)=0. + enddo + endif + enddo +!$acc end kernels +! rain evaporation as in sas +! + if(irainevap.eq.1)then +!$acc kernels + do i = its,itf + rntot(i) = 0. + delqev(i) = 0. + delq2(i) = 0. + rn(i) = 0. + rntot(i) = 0. + rain=0. + if(ierr(i).eq.0)then +!$acc loop independent + do k = ktop(i), 1, -1 + rain = pwo(i,k) + edto(i) * pwdo(i,k) +!$acc atomic + rntot(i) = rntot(i) + rain * xmb(i)* .001 * dtime + enddo + endif + enddo + do i = its,itf + qevap(i) = 0. + flg(i) = .true. + if(ierr(i).eq.0)then + evef = edt(i) * evfact * sig(i)**2 + if(xland(i).gt.0.5 .and. xland(i).lt.1.5) evef = edt(i) * evfactl * sig(i)**2 +!$acc loop seq + do k = ktop(i), 1, -1 + rain = pwo(i,k) + edto(i) * pwdo(i,k) + rn(i) = rn(i) + rain * xmb(i) * .001 * dtime + !if(po(i,k).gt.400.)then + if(flg(i))then + q1=qo(i,k)+(outq(i,k))*dtime + t1=tn(i,k)+(outt(i,k))*dtime + qcond(i) = evef * (q1 - qeso(i,k)) & + & / (1. + el2orc * qeso(i,k) / t1**2) + dp = -100.*(p_cup(i,k+1)-p_cup(i,k)) + if(rn(i).gt.0. .and. qcond(i).lt.0.) then + qevap(i) = -qcond(i) * (1.-exp(-.32*sqrt(dtime*rn(i)))) + qevap(i) = min(qevap(i), rn(i)*1000.*g/dp) + delq2(i) = delqev(i) + .001 * qevap(i) * dp / g + endif + if(rn(i).gt.0..and.qcond(i).lt.0..and. & + & delq2(i).gt.rntot(i)) then + qevap(i) = 1000.* g * (rntot(i) - delqev(i)) / dp + flg(i) = .false. + endif + if(rn(i).gt.0..and.qevap(i).gt.0.) then + outq(i,k) = outq(i,k) + qevap(i)/dtime + outt(i,k) = outt(i,k) - elocp * qevap(i)/dtime + rn(i) = max(0.,rn(i) - .001 * qevap(i) * dp / g) + pre(i) = pre(i) - qevap(i) * dp /g/dtime + pre(i)=max(pre(i),0.) + delqev(i) = delqev(i) + .001*dp*qevap(i)/g + endif + !endif ! 400mb + endif + enddo +! pre(i)=1000.*rn(i)/dtime + endif + enddo + if(do_ca)then + do i = its,itf + rainevap(i)=delqev(i) + enddo + endif +!$acc end kernels + endif + +!$acc kernels + do i=its,itf + if(ierr(i).eq.0) then + if(aeroevap.gt.1)then + ! aerosol scavagening + ccnloss(i)=ccn(i)*pefc(i)*xmb(i) ! HCB + ccn(i) = ccn(i) - ccnloss(i)*scav_factor + endif + endif + enddo +!$acc end kernels + +! +!> - Since kinetic energy is being dissipated, add heating accordingly (from ecmwf) +! +!$acc kernels + do i=its,itf + if(ierr(i).eq.0) then + dts=0. + fpi=0. + do k=kts,ktop(i) + dp=(po_cup(i,k)-po_cup(i,k+1))*100. +!total ke dissiptaion estimate + dts= dts -(outu(i,k)*us(i,k)+outv(i,k)*vs(i,k))*dp/g +! fpi needed for calcualtion of conversion to pot. energyintegrated + fpi = fpi +sqrt(outu(i,k)*outu(i,k) + outv(i,k)*outv(i,k))*dp + enddo + if(fpi.gt.0.)then + do k=kts,ktop(i) + fp= sqrt((outu(i,k)*outu(i,k)+outv(i,k)*outv(i,k)))/fpi + outt(i,k)=outt(i,k)+fp*dts*g/cp + enddo + endif + endif + enddo +!$acc end kernels + +! +!---------------------------done------------------------------ +! + + end subroutine cu_unified_deep_run + + +!> Calculates tracer fluxes due to subsidence, only up-stream differencing +!! is currently used but flux corrected transport can be turn on. + subroutine fct1d3 (ktop,n,dt,z,tracr,massflx,trflx_in,dellac,g) +!$acc routine vector +! --- modify a 1-D array of tracer fluxes for the purpose of maintaining +! --- monotonicity (including positive-definiteness) in the tracer field +! --- during tracer transport. + +! --- the underlying transport equation is (d tracr/dt) = - (d trflx/dz) +! --- where dz = |z(k+1)-z(k)| (k=1,...,n) and trflx = massflx * tracr +! --- physical dimensions of tracr,trflx,dz are arbitrary to some extent +! --- but are subject to the constraint dim[trflx] = dim[tracr*(dz/dt)]. + +! --- note: tracr is carried in grid cells while z and fluxes are carried on +! --- interfaces. interface variables at index k are at grid location k-1/2. +! --- sign convention: mass fluxes are considered positive in +k direction. + +! --- massflx and trflx_in must be provided independently to allow the +! --- algorithm to generate an auxiliary low-order (diffusive) tracer flux +! --- as a stepping stone toward the final product trflx_out. + + implicit none + integer,intent(in) :: n,ktop ! number of grid cells + real(kind=kind_phys) ,intent(in) :: dt,g ! transport time step + real(kind=kind_phys) ,intent(in) :: z(n+0) ! location of cell interfaces + real(kind=kind_phys) ,intent(in) :: tracr(n) ! the transported variable + real(kind=kind_phys) ,intent(in) :: massflx(n+0) ! mass flux across interfaces + real(kind=kind_phys) ,intent(in) :: trflx_in(n+0) ! original tracer flux + real(kind=kind_phys) ,intent(out):: dellac(n+0) ! modified tracr flux + real(kind=kind_phys) :: trflx_out(n+0) ! modified tracr flux + integer k,km1,kp1 + logical :: NaN, error=.false., vrbos=.true. + real(kind=kind_phys) dtovdz(n),trmax(n),trmin(n),flx_lo(n+0),antifx(n+0),clipped(n+0), & + soln_hi(n),totlin(n),totlout(n),soln_lo(n),clipin(n),clipout(n),arg + real(kind=kind_phys),parameter :: epsil=1.e-22 ! prevent division by zero + real(kind=kind_phys),parameter :: damp=1. ! damper of antidff flux (1=no damping) + NaN(arg) = .not. (arg.ge.0. .or. arg.le.0.) ! NaN detector + dtovdz(:)=0. + soln_lo(:)=0. + antifx(:)=0. + clipin(:)=0. + totlin(:)=0. + totlout(:)=0. + clipout(:)=0. + flx_lo(:)=0. + trmin(:)=0. + trmax(:)=0. + clipped(:)=0. + trflx_out(:)=0. + do k=1,ktop + dtovdz(k)=.01*dt/abs(z(k+1)-z(k))*g ! time step / grid spacing + if (z(k).eq.z(k+1)) error=.true. + end do +! if (vrbos .or. error) print '(a/(8es10.3))','(fct1d) dtovdz =',dtovdz + + do k=2,ktop + if (massflx(k).ge.0.) then + flx_lo(k)=massflx(k)*tracr(k-1) ! low-order flux, upstream + else + flx_lo(k)=massflx(k)*tracr(k) ! low-order flux, upstream + end if + antifx(k)=trflx_in(k)-flx_lo(k) ! antidiffusive flux + end do + flx_lo( 1)=trflx_in( 1) + flx_lo(ktop+1)=trflx_in(ktop+1) + antifx( 1)=0. + antifx(ktop+1)=0. +! --- clip low-ord fluxes to make sure they don't violate positive-definiteness + do k=1,ktop + totlout(k)=max(0.,flx_lo(k+1))-min(0.,flx_lo(k )) ! total flux out + clipout(k)=min(1.,tracr(k)/max(epsil,totlout(k))/ (1.0001*dtovdz(k))) + end do + + do k=2,ktop + if (massflx(k).ge.0.) then + flx_lo(k)=flx_lo(k)*clipout(k-1) + else + flx_lo(k)=flx_lo(k)*clipout(k) + end if + end do + if (massflx( 1).lt.0.) flx_lo( 1)=flx_lo( 1)*clipout(1) + if (massflx(ktop+1).gt.0.)flx_lo(ktop+1)=flx_lo(ktop+1)*clipout(ktop) + +! --- a positive-definite low-order (diffusive) solution can now be constructed + + do k=1,ktop + soln_lo(k)=tracr(k)-(flx_lo(k+1)-flx_lo(k))*dtovdz(k) ! low-ord solutn + dellac(k)=-(flx_lo(k+1)-flx_lo(k))*dtovdz(k)/dt + !dellac(k)=soln_lo(k) + end do + return + do k=1,ktop + km1=max(1,k-1) + kp1=min(ktop,k+1) + trmax(k)= max(soln_lo(km1),soln_lo(k),soln_lo(kp1), & + tracr (km1),tracr (k),tracr (kp1)) ! upper bound + trmin(k)=max(0.,min(soln_lo(km1),soln_lo(k),soln_lo(kp1), & + tracr (km1),tracr (k),tracr (kp1))) ! lower bound + end do + + do k=1,ktop + totlin (k)=max(0.,antifx(k ))-min(0.,antifx(k+1)) ! total flux in + totlout(k)=max(0.,antifx(k+1))-min(0.,antifx(k )) ! total flux out + + clipin (k)=min(damp,(trmax(k)-soln_lo(k))/max(epsil,totlin (k)) & + / (1.0001*dtovdz(k))) + clipout(k)=min(damp,(soln_lo(k)-trmin(k))/max(epsil,totlout(k)) & + / (1.0001*dtovdz(k))) +#ifndef _OPENACC + if (NaN(clipin(k))) print *,'(fct1d) error: clipin is NaN, k=',k + if (NaN(clipout(k))) print *,'(fct1d) error: clipout is NaN, k=',k +#endif + + if (clipin(k).lt.0.) then +! print 100,'(fct1d) error: clipin < 0 at k =',k, & +! 'clipin',clipin(k),'trmax',trmax(k),'soln_lo',soln_lo(k), & +! 'totlin',totlin(k),'dt/dz',dtovdz(k) + error=.true. + end if + if (clipout(k).lt.0.) then +! print 100,'(fct1d) error: clipout < 0 at k =',k, & +! 'clipout',clipout(k),'trmin',trmin(k),'soln_lo',soln_lo(k), & +! 'totlout',totlout(k),'dt/dz',dtovdz(k) + error=.true. + end if +! 100 format (a,i3/(4(a10,"=",es9.2))) + end do + + do k=2,ktop + if (antifx(k).gt.0.) then + clipped(k)=antifx(k)*min(clipout(k-1),clipin(k)) + else + clipped(k)=antifx(k)*min(clipout(k),clipin(k-1)) + end if + trflx_out(k)=flx_lo(k)+clipped(k) + if (NaN(trflx_out(k))) then +#ifndef _OPENACC + print *,'(fct1d) error: trflx_out is NaN, k=',k +#endif + error=.true. + end if + end do + trflx_out( 1)=trflx_in( 1) + trflx_out(ktop+1)=trflx_in(ktop+1) + do k=1,ktop + soln_hi(k)=tracr(k)-(trflx_out(k+1)-trflx_out(k))*dtovdz(k) + dellac(k)=-g*(trflx_out(k+1)-trflx_out(k))*dtovdz(k)/dt + !dellac(k)=soln_hi(k) + end do + +#ifndef _OPENACC + if (vrbos .or. error) then +! do k=2,ktop +! write(32,99)k, & +! 'tracr(k)', tracr(k), & +! 'flx_in(k)', trflx_in(k), & +! 'flx_in(k+1)', trflx_in(k+1), & +! 'flx_lo(k)', flx_lo(k), & +! 'flx_lo(k+1)', flx_lo(k+1), & +! 'soln_lo(k)', soln_lo(k), & +! 'trmin(k)', trmin(k), & +! 'trmax(k)', trmax(k), & +! 'totlin(k)', totlin(k), & +! 'totlout(k)', totlout(k), & +! 'clipin(k-1)', clipin(k-1), & +! 'clipin(k)', clipin(k), & +! 'clipout(k-1)', clipout(k-1), & +! 'clipout(k)', clipout(k), & +! 'antifx(k)', antifx(k), & +! 'antifx(k+1)', antifx(k+1), & +! 'clipped(k)', clipped(k), & +! 'clipped(k+1)', clipped(k+1), & +! 'flx_out(k)', trflx_out(k), & +! 'flx_out(k+1)', trflx_out(k+1), & +! 'dt/dz(k)', dtovdz(k), & +! 'final', tracr(k)-(trflx_out(k+1)-trflx_out(k))*dtovdz(k) +! 99 format ('(trc1d) k =',i4/(3(a13,'=',es13.6))) +! end do + if (error) stop '(fct1d error)' + end if +#endif + + return + end subroutine fct1d3 + +!> Calculates rain evaporation below cloud base. + subroutine rain_evap_below_cloudbase(itf,ktf, its,ite, kts,kte,ierr, & + kbcon,xmb,psur,xland,qo_cup, & + po_cup,qes_cup,pwavo,edto,pwevo,pre,outt,outq) !,outbuoy) + + implicit none + real(kind=kind_phys), parameter :: alp1=5.44e-4 & !1/sec + ,alp2=5.09e-3 & !unitless + ,alp3=0.5777 & !unitless + ,c_conv=0.05 !conv fraction area, unitless + + + integer ,intent(in) :: itf,ktf, its,ite, kts,kte + integer, dimension(its:ite) ,intent(in) :: ierr,kbcon + real(kind=kind_phys), dimension(its:ite) ,intent(in) ::psur,xland,pwavo,edto,pwevo,xmb + real(kind=kind_phys), dimension(its:ite,kts:kte),intent(in) :: po_cup,qo_cup,qes_cup + real(kind=kind_phys), dimension(its:ite) ,intent(inout) :: pre + real(kind=kind_phys), dimension(its:ite,kts:kte),intent(inout) :: outt,outq !,outbuoy +!$acc declare copyin(ierr,kbcon,psur,xland,pwavo,edto,pwevo,xmb,po_cup,qo_cup,qes_cup) +!$acc declare copy(pre,outt,outq) + + !real, dimension(its:ite) ,intent(out) :: tot_evap_bcb + !real, dimension(its:ite,kts:kte),intent(out) :: evap_bcb,net_prec_bcb + + !-- locals + integer :: i,k + real(kind=kind_phys) :: RH_cr , del_t,del_q,dp,q_deficit + real(kind=kind_phys), dimension(its:ite,kts:kte) :: evap_bcb,net_prec_bcb + real(kind=kind_phys), dimension(its:ite) :: tot_evap_bcb +!$acc declare create(evap_bcb,net_prec_bcb,tot_evap_bcb) + +!$acc kernels + do i=its,itf + evap_bcb (i,:)= 0.0 + net_prec_bcb(i,:)= 0.0 + tot_evap_bcb(i) = 0.0 + if(ierr(i) /= 0) cycle + + !-- critical rel humidity + RH_cr=0.9*xland(i)+0.7*(1-xland(i)) + !RH_cr=1. + + !-- net precipitation (after downdraft evap) at cloud base, available to + !evap + k=kbcon(i) + !net_prec_bcb(i,k) = xmb(i)*(pwavo(i)+edto(i)*pwevo(i)) !-- pwevo<0. + net_prec_bcb(i,k) = pre(i) + +!$acc loop seq + do k=kbcon(i)-1, kts, -1 + + q_deficit = max(0.,(RH_cr*qes_cup(i,k) -qo_cup(i,k))) + + if(q_deficit < 1.e-6) then + net_prec_bcb(i,k)= net_prec_bcb(i,k+1) + cycle + endif + + dp = 100.*(po_cup(i,k)-po_cup(i,k+1)) + + !--units here: kg[water]/kg[air}/sec + evap_bcb(i,k) = c_conv * alp1 * q_deficit * & + ( sqrt(po_cup(i,k)/psur(i))/alp2 *net_prec_bcb(i,k+1)/c_conv )**alp3 + + !--units here: kg[water]/kg[air}/sec * kg[air]/m3 * m = kg[water]/m2/sec + evap_bcb(i,k)= evap_bcb(i,k)*dp/g + + if((net_prec_bcb(i,k+1) - evap_bcb(i,k)).lt.0.) cycle + if((pre(i) - evap_bcb(i,k)).lt.0.) cycle + net_prec_bcb(i,k)= net_prec_bcb(i,k+1) - evap_bcb(i,k) + + tot_evap_bcb(i) = tot_evap_bcb(i)+evap_bcb(i,k) + + !-- feedback + del_q = evap_bcb(i,k)*g/dp ! > 0., units: kg[water]/kg[air}/sec + del_t = -evap_bcb(i,k)*g/dp*(xlv/cp) ! < 0., units: K/sec + +! print*,"ebcb2",k,del_q*86400,del_t*86400 + + outq (i,k) = outq (i,k) + del_q + outt (i,k) = outt (i,k) + del_t + !outbuoy(i,k) = outbuoy(i,k) + cp*del_t+xlv*del_q + + pre(i) = pre(i) - evap_bcb(i,k) + enddo + enddo +!$acc end kernels + + end subroutine rain_evap_below_cloudbase + +!> Calculates strength of downdraft based on windshear and/or +!! aerosol content. + subroutine cup_dd_edt(ierr,us,vs,z,ktop,kbcon,edt,p,pwav, & + pw,ccn,ccnclean,pwev,edtmax,edtmin,edtc,psum2,psumh, & + rho,aeroevap,pefc,itf,ktf, & + its,ite, kts,kte ) + + implicit none + + integer & + ,intent (in ) :: & + aeroevap,itf,ktf, & + its,ite, kts,kte + ! + ! ierr error value, maybe modified in this routine + ! + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + rho,us,vs,z,p,pw + real(kind=kind_phys), dimension (its:ite,1) & + ,intent (out ) :: & + edtc + real(kind=kind_phys), dimension (its:ite) & + ,intent (out ) :: & + pefc + real(kind=kind_phys), dimension (its:ite) & + ,intent (out ) :: & + edt + real(kind=kind_phys), dimension (its:ite) & + ,intent (in ) :: & + pwav,pwev,psum2,psumh,edtmax,edtmin + integer, dimension (its:ite) & + ,intent (in ) :: & + ktop,kbcon + real(kind=kind_phys), intent (in ) :: & !HCB + ccnclean + real(kind=kind_phys), dimension (its:ite) & + ,intent (inout ) :: & + ccn + integer, dimension (its:ite) & + ,intent (inout) :: & + ierr +!$acc declare copyin(rho,us,vs,z,p,pw,pwav,pwev,psum2,psumh,edtmax,edtmin,ktop,kbcon) +!$acc declare copyout(edtc,edt) copy(ccn,ierr) +! +! local variables in this routine +! + + integer i,k,kk + real(kind=kind_phys) einc,pef,pefb,prezk,zkbc + real(kind=kind_phys), dimension (its:ite) :: & + vshear,sdp,vws +!$acc declare create(vshear,sdp,vws) + real(kind=kind_phys) :: prop_c,aeroadd,alpha3,beta3 + prop_c=0. !10.386 + alpha3 = 0.75 + beta3 = -0.15 + pefc(:)=0. + pefb=0. + pef=0. + +! +!--- determine downdraft strength in terms of windshear +! +! */ calculate an average wind shear over the depth of the cloud +! +!$acc kernels + do i=its,itf + edt(i)=0. + vws(i)=0. + sdp(i)=0. + vshear(i)=0. + enddo + do i=its,itf + edtc(i,1)=0. + enddo + do kk = kts,ktf-1 + do 62 i=its,itf + if(ierr(i).ne.0)go to 62 + if (kk .le. min0(ktop(i),ktf) .and. kk .ge. kbcon(i)) then + vws(i) = vws(i)+ & + (abs((us(i,kk+1)-us(i,kk))/(z(i,kk+1)-z(i,kk))) & + + abs((vs(i,kk+1)-vs(i,kk))/(z(i,kk+1)-z(i,kk)))) * & + (p(i,kk) - p(i,kk+1)) + sdp(i) = sdp(i) + p(i,kk) - p(i,kk+1) + endif + if (kk .eq. ktf-1)vshear(i) = 1.e3 * vws(i) / sdp(i) + 62 continue + end do + do i=its,itf + if(ierr(i).eq.0)then + pef=(1.591-.639*vshear(i)+.0953*(vshear(i)**2) & + -.00496*(vshear(i)**3)) + if(pef.gt.0.9)pef=0.9 + if(pef.lt.0.1)pef=0.1 +! +!--- cloud base precip efficiency +! + zkbc=z(i,kbcon(i))*3.281e-3 + prezk=.02 + if(zkbc.gt.3.)then + prezk=.96729352+zkbc*(-.70034167+zkbc*(.162179896+zkbc & + *(- 1.2569798e-2+zkbc*(4.2772e-4-zkbc*5.44e-6)))) + endif + if(zkbc.gt.25)then + prezk=2.4 + endif + pefb=1./(1.+prezk) + if(pefb.gt.0.9)pefb=0.9 + if(pefb.lt.0.1)pefb=0.1 + pefb=pef + + edt(i)=1.-.5*(pefb+pef) + if(aeroevap.gt.1)then + aeroadd=0. + if((psumh(i)>0.).and.(psum2(i)>0.))then + aeroadd=((1.e-2*ccnclean)**beta3)*(psumh(i)**(alpha3-1)) + prop_c=.5*(pefb+pef)/aeroadd + aeroadd=((1.e-2*ccn(i))**beta3)*(psum2(i)**(alpha3-1)) + aeroadd=prop_c*aeroadd + pefc(i)=aeroadd + + if(pefc(i).gt.0.9)pefc(i)=0.9 + if(pefc(i).lt.0.1)pefc(i)=0.1 + edt(i)=1.-pefc(i) + if(aeroevap.eq.2)edt(i)=1.-.25*(pefb+pef+2.*pefc(i)) + endif + endif + + +!--- edt here is 1-precipeff! + einc=.2*edt(i) + edtc(i,1)=edt(i)-einc + endif + enddo + do i=its,itf + if(ierr(i).eq.0)then + edtc(i,1)=-edtc(i,1)*pwav(i)/pwev(i) + if(edtc(i,1).gt.edtmax(i))edtc(i,1)=edtmax(i) + if(edtc(i,1).lt.edtmin(i))edtc(i,1)=edtmin(i) + endif + enddo +!$acc end kernels + + end subroutine cup_dd_edt + +!> Calcultes moisture properties of downdrafts. + subroutine cup_dd_moisture(ierrc,zd,hcd,hes_cup,qcd,qes_cup, & + pwd,q_cup,z_cup,dd_massentr,dd_massdetr,jmin,ierr, & + gamma_cup,pwev,bu,qrcd, & + q,he,iloop, & + itf,ktf, & + its,ite, kts,kte ) + + implicit none + + integer & + ,intent (in ) :: & + itf,ktf, & + its,ite, kts,kte + ! cdd= detrainment function + ! q = environmental q on model levels + ! q_cup = environmental q on model cloud levels + ! qes_cup = saturation q on model cloud levels + ! hes_cup = saturation h on model cloud levels + ! hcd = h in model cloud + ! bu = buoancy term + ! zd = normalized downdraft mass flux + ! gamma_cup = gamma on model cloud levels + ! mentr_rate = entrainment rate + ! qcd = cloud q (including liquid water) after entrainment + ! qrch = saturation q in cloud + ! pwd = evaporate at that level + ! pwev = total normalized integrated evaoprate (i2) + ! entr= entrainment rate + ! + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + zd,hes_cup,hcd,qes_cup,q_cup,z_cup, & + dd_massentr,dd_massdetr,gamma_cup,q,he +!$acc declare copyin(zd,hes_cup,hcd,qes_cup,q_cup,z_cup,dd_massentr,dd_massdetr,gamma_cup,q,he) + integer & + ,intent (in ) :: & + iloop + integer, dimension (its:ite) & + ,intent (in ) :: & + jmin +!$acc declare copyin(jmin) + integer, dimension (its:ite) & + ,intent (inout) :: & + ierr +!$acc declare copy(ierr) + real(kind=kind_phys), dimension (its:ite,kts:kte)& + ,intent (out ) :: & + qcd,qrcd,pwd + real(kind=kind_phys), dimension (its:ite)& + ,intent (out ) :: & + pwev,bu +!$acc declare copyout(qcd,qrcd,pwd,pwev,bu) + character*50 :: ierrc(its:ite) +! +! local variables in this routine +! + + integer :: & + i,k,ki + real(kind=kind_phys) :: & + denom,dh,dz,dqeva + +!$acc kernels + do i=its,itf + bu(i)=0. + pwev(i)=0. + enddo + do k=kts,ktf + do i=its,itf + qcd(i,k)=0. + qrcd(i,k)=0. + pwd(i,k)=0. + enddo + enddo +! +! +! + do 100 i=its,itf + if(ierr(i).eq.0)then + k=jmin(i) + dz=z_cup(i,k+1)-z_cup(i,k) + qcd(i,k)=q_cup(i,k) + dh=hcd(i,k)-hes_cup(i,k) + if(dh.lt.0)then + qrcd(i,k)=(qes_cup(i,k)+(1./xlv)*(gamma_cup(i,k) & + /(1.+gamma_cup(i,k)))*dh) + else + qrcd(i,k)=qes_cup(i,k) + endif + pwd(i,jmin(i))=zd(i,jmin(i))*min(0.,qcd(i,k)-qrcd(i,k)) + qcd(i,k)=qrcd(i,k) + pwev(i)=pwev(i)+pwd(i,jmin(i)) ! *dz +! + bu(i)=dz*dh +!$acc loop seq + do ki=jmin(i)-1,1,-1 + dz=z_cup(i,ki+1)-z_cup(i,ki) +! qcd(i,ki)=(qcd(i,ki+1)*(1.-.5*cdd(i,ki+1)*dz) & +! +entr*dz*q(i,ki) & +! )/(1.+entr*dz-.5*cdd(i,ki+1)*dz) +! dz=qcd(i,ki) +!print*,"i=",i," k=",ki," qcd(i,ki+1)=",qcd(i,ki+1) +!print*,"zd=",zd(i,ki+1)," dd_ma=",dd_massdetr(i,ki)," q=",q(i,ki) +!joe-added check for non-zero denominator: + denom=zd(i,ki+1)-.5*dd_massdetr(i,ki)+dd_massentr(i,ki) + if(denom.lt.1.e-16)then + ierr(i)=51 + exit + endif + qcd(i,ki)=(qcd(i,ki+1)*zd(i,ki+1) & + -.5*dd_massdetr(i,ki)*qcd(i,ki+1)+ & + dd_massentr(i,ki)*q(i,ki)) / & + (zd(i,ki+1)-.5*dd_massdetr(i,ki)+dd_massentr(i,ki)) +! +!--- to be negatively buoyant, hcd should be smaller than hes! +!--- ideally, dh should be negative till dd hits ground, but that is not always +!--- the case +! + dh=hcd(i,ki)-hes_cup(i,ki) + bu(i)=bu(i)+dz*dh + qrcd(i,ki)=qes_cup(i,ki)+(1./xlv)*(gamma_cup(i,ki) & + /(1.+gamma_cup(i,ki)))*dh + dqeva=qcd(i,ki)-qrcd(i,ki) + if(dqeva.gt.0.)then + dqeva=0. + qrcd(i,ki)=qcd(i,ki) + endif + pwd(i,ki)=zd(i,ki)*dqeva + qcd(i,ki)=qrcd(i,ki) + pwev(i)=pwev(i)+pwd(i,ki) ! *dz +! if(iloop.eq.1.and.i.eq.102.and.j.eq.62)then +! print *,'in cup_dd_moi ', hcd(i,ki),hes_cup(i,ki),dh,dqeva +! endif + enddo +! +!--- end loop over i + if( (pwev(i).eq.0.) .and. (iloop.eq.1))then +! print *,'problem with buoy in cup_dd_moisture',i + ierr(i)=7 +#ifndef _OPENACC + ierrc(i)="problem with buoy in cup_dd_moisture" +#endif + endif + if(bu(i).ge.0.and.iloop.eq.1)then +! print *,'problem with buoy in cup_dd_moisture',i + ierr(i)=7 +#ifndef _OPENACC + ierrc(i)="problem2 with buoy in cup_dd_moisture" +#endif + endif + endif +100 continue +!$acc end kernels + + end subroutine cup_dd_moisture + +!> Calculates environmental moist static energy, saturation +!! moist static energy, heights, and saturation mixing ratio. + subroutine cup_env(z,qes,he,hes,t,q,p,z1, & + psur,ierr,tcrit,itest, & + itf,ktf, & + its,ite, kts,kte ) + + implicit none + + integer & + ,intent (in ) :: & + itf,ktf, & + its,ite, kts,kte + ! + ! + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + p,t,q +!$acc declare copyin(p,t,q) + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (out ) :: & + hes,qes +!$acc declare copyout(hes,qes) + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (inout) :: & + he,z +!$acc declare copy(he,z) + real(kind=kind_phys), dimension (its:ite) & + ,intent (in ) :: & + psur,z1 +!$acc declare copyin(psur,z1) + integer, dimension (its:ite) & + ,intent (inout) :: & + ierr +!$acc declare copy(ierr) + integer & + ,intent (in ) :: & + itest +! +! local variables in this routine +! + + integer :: & + i,k +! real(kind=kind_phys), dimension (1:2) :: ae,be,ht + real(kind=kind_phys), dimension (its:ite,kts:kte) :: tv +!$acc declare create(tv) + real(kind=kind_phys) :: tcrit,e,tvbar +! real(kind=kind_phys), external :: satvap +! real(kind=kind_phys) :: satvap + + +! ht(1)=xlv/cp +! ht(2)=2.834e6/cp +! be(1)=.622*ht(1)/.286 +! ae(1)=be(1)/273.+alog(610.71) +! be(2)=.622*ht(2)/.286 +! ae(2)=be(2)/273.+alog(610.71) +!$acc parallel loop collapse(2) private(e) + do k=kts,ktf + do i=its,itf + if(ierr(i).eq.0)then +!csgb - iph is for phase, dependent on tcrit (water or ice) +! iph=1 +! if(t(i,k).le.tcrit)iph=2 +! print *, 'ae(iph),be(iph) = ',ae(iph),be(iph),ae(iph)-be(iph),t(i,k),i,k +! e=exp(ae(iph)-be(iph)/t(i,k)) +! print *, 'p, e = ', p(i,k), e +! qes(i,k)=.622*e/(100.*p(i,k)-e) + e=satvap(t(i,k)) + qes(i,k)=0.622*e/max(1.e-8,(p(i,k)-e)) + if(qes(i,k).le.1.e-16)qes(i,k)=1.e-16 + if(qes(i,k).lt.q(i,k))qes(i,k)=q(i,k) +! if(q(i,k).gt.qes(i,k))q(i,k)=qes(i,k) + tv(i,k)=t(i,k)+.608*q(i,k)*t(i,k) + endif + enddo + enddo +!$acc end parallel +! +!--- z's are calculated with changed h's and q's and t's +!--- if itest=2 +! + if(itest.eq.1 .or. itest.eq.0)then +!$acc kernels + do i=its,itf + if(ierr(i).eq.0)then + z(i,1)=max(0.,z1(i))-(log(p(i,1))- & + log(psur(i)))*287.*tv(i,1)/9.81 + endif + enddo + +! --- calculate heights +!$acc loop seq + do k=kts+1,ktf +!$acc loop private(tvbar) + do i=its,itf + if(ierr(i).eq.0)then + tvbar=.5*tv(i,k)+.5*tv(i,k-1) + z(i,k)=z(i,k-1)-(log(p(i,k))- & + log(p(i,k-1)))*287.*tvbar/9.81 + endif + enddo + enddo +!$acc end kernels + else if(itest.eq.2)then +!$acc kernels + do k=kts,ktf + do i=its,itf + if(ierr(i).eq.0)then + z(i,k)=(he(i,k)-1004.*t(i,k)-2.5e6*q(i,k))/9.81 + z(i,k)=max(1.e-3,z(i,k)) + endif + enddo + enddo +!$acc end kernels + else if(itest.eq.-1)then + endif +! +!--- calculate moist static energy - he +! saturated moist static energy - hes +! +!$acc kernels + do k=kts,ktf + do i=its,itf + if(ierr(i).eq.0)then + if(itest.le.0)he(i,k)=9.81*z(i,k)+1004.*t(i,k)+2.5e06*q(i,k) + hes(i,k)=9.81*z(i,k)+1004.*t(i,k)+2.5e06*qes(i,k) + if(he(i,k).ge.hes(i,k))he(i,k)=hes(i,k) + endif + enddo + enddo +!$acc end kernels + + end subroutine cup_env + +!> Calculates environmental values on cloud levels. +!>\param t environmental temperature +!!\param qes environmental saturation mixing ratio +!!\param q environmental mixing ratio +!!\param he environmental moist static energy +!!\param hes environmental saturation moist static energy +!!\param z environmental heights +!!\param p environmental pressure +!!\param qes_cup environmental saturation mixing ratio on cloud levels +!!\param q_cup environmental mixing ratio on cloud levels +!!\param he_cup environmental moist static energy on cloud levels +!!\param hes_cup environmental saturation moist static energy on cloud levels +!!\param z_cup environmental heights on cloud levels +!!\param p_cup environmental pressure on cloud levels +!!\param gamma_cup gamma on cloud levels +!!\param t_cup environmental temperature on cloud levels +!!\param psur surface pressure +!!\param ierr error value, maybe modified in this routine +!!\param z1 terrain elevation +!!\param itf,ktf,its,ite,kts,kte horizontal and vertical dimension + subroutine cup_env_clev(t,qes,q,he,hes,z,p,qes_cup,q_cup, & + he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup,psur, & + ierr,z1, & + itf,ktf, & + its,ite, kts,kte ) + + implicit none + + integer & + ,intent (in ) :: & + itf,ktf, & + its,ite, kts,kte + ! + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + qes,q,he,hes,z,p,t +!$acc declare copyin(qes,q,he,hes,z,p,t) + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (out ) :: & + qes_cup,q_cup,he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup +!$acc declare copyout(qes_cup,q_cup,he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup) + real(kind=kind_phys), dimension (its:ite) & + ,intent (in ) :: & + psur,z1 +!$acc declare copyin(psur,z1) + integer, dimension (its:ite) & + ,intent (inout) :: & + ierr +!$acc declare copy(ierr) +! +! local variables in this routine +! + + integer :: & + i,k + +!$acc kernels + do k=kts,ktf + do i=its,itf + qes_cup(i,k)=0. + q_cup(i,k)=0. + hes_cup(i,k)=0. + he_cup(i,k)=0. + z_cup(i,k)=0. + p_cup(i,k)=0. + t_cup(i,k)=0. + gamma_cup(i,k)=0. + enddo + enddo + do k=kts+1,ktf + do i=its,itf + if(ierr(i).eq.0)then + qes_cup(i,k)=.5*(qes(i,k-1)+qes(i,k)) + q_cup(i,k)=.5*(q(i,k-1)+q(i,k)) + hes_cup(i,k)=.5*(hes(i,k-1)+hes(i,k)) + he_cup(i,k)=.5*(he(i,k-1)+he(i,k)) + if(he_cup(i,k).gt.hes_cup(i,k))he_cup(i,k)=hes_cup(i,k) + z_cup(i,k)=.5*(z(i,k-1)+z(i,k)) + p_cup(i,k)=.5*(p(i,k-1)+p(i,k)) + t_cup(i,k)=.5*(t(i,k-1)+t(i,k)) + gamma_cup(i,k)=(xlv/cp)*(xlv/(r_v*t_cup(i,k) & + *t_cup(i,k)))*qes_cup(i,k) + endif + enddo + enddo + do i=its,itf + if(ierr(i).eq.0)then + qes_cup(i,1)=qes(i,1) + q_cup(i,1)=q(i,1) +! hes_cup(i,1)=hes(i,1) +! he_cup(i,1)=he(i,1) + hes_cup(i,1)=9.81*z1(i)+1004.*t(i,1)+2.5e6*qes(i,1) + he_cup(i,1)=9.81*z1(i)+1004.*t(i,1)+2.5e6*q(i,1) + z_cup(i,1)=.5*(z(i,1)+z1(i)) + p_cup(i,1)=.5*(p(i,1)+psur(i)) + z_cup(i,1)=z1(i) + p_cup(i,1)=psur(i) + t_cup(i,1)=t(i,1) + gamma_cup(i,1)=xlv/cp*(xlv/(r_v*t_cup(i,1) & + *t_cup(i,1)))*qes_cup(i,1) + endif + enddo +!$acc end kernels + end subroutine cup_env_clev + +!> Calculates an ensemble of closures and the resulting ensemble +!! average to determine cloud base mass-flux. + subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2,ierr3,& + xf_ens,axx,forcing,maxens3,mconv,rand_clos, & + p_cup,ktop,omeg,zd,zdm,k22,zu,pr_ens,edt,edtm,kbcon, & + ichoice, & + imid,ipr,itf,ktf, & + its,ite, kts,kte, & + dicycle,tau_ecmwf,aa1_bl,xf_dicycle ) + + implicit none + + integer & + ,intent (in ) :: & + imid,ipr,itf,ktf, & + its,ite, kts,kte + integer, intent (in ) :: & + maxens3 + ! + ! ierr error value, maybe modified in this routine + ! pr_ens = precipitation ensemble + ! xf_ens = mass flux ensembles + ! massfln = downdraft mass flux ensembles used in next timestep + ! omeg = omega from large scale model + ! mconv = moisture convergence from large scale model + ! zd = downdraft normalized mass flux + ! zu = updraft normalized mass flux + ! aa0 = cloud work function without forcing effects + ! aa1 = cloud work function with forcing effects + ! xaa0 = cloud work function with cloud effects (ensemble dependent) + ! edt = epsilon + ! dir = "storm motion" + ! mbdt = arbitrary numerical parameter + ! dtime = dt over which forcing is applied + ! iact_gr_old = flag to tell where convection was active + ! kbcon = lfc of parcel from k22 + ! k22 = updraft originating level + ! ichoice = flag if only want one closure (usually set to zero!) + ! + real(kind=kind_phys), dimension (its:ite,1:maxens3) & + ,intent (inout) :: & + pr_ens + real(kind=kind_phys), dimension (its:ite,1:maxens3) & + ,intent (inout ) :: & + xf_ens +!$acc declare copy(pr_ens,xf_ens) + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + zd,zu,p_cup,zdm + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + omeg + real(kind=kind_phys), dimension (its:ite,1) & + ,intent (in ) :: & + xaa0 + real(kind=kind_phys), dimension (its:ite,4) & + ,intent (in ) :: & + rand_clos + real(kind=kind_phys), dimension (its:ite) & + ,intent (in ) :: & + aa1,edt,edtm + real(kind=kind_phys), dimension (its:ite) & + ,intent (in ) :: & + mconv,axx +!$acc declare copyin(zd,zu,p_cup,zdm,omeg,xaa0,rand_clos,aa1,edt,edtm,mconv,axx) + real(kind=kind_phys), dimension (its:ite) & + ,intent (inout) :: & + aa0,closure_n +!$acc declare copy(aa0,closure_n) + real(kind=kind_phys) & + ,intent (in ) :: & + mbdt + real(kind=kind_phys) & + ,intent (in ) :: & + dtime + integer, dimension (its:ite) & + ,intent (inout ) :: & + k22,kbcon,ktop + integer, dimension (its:ite) & + ,intent (in ) :: & + xland + integer, dimension (its:ite) & + ,intent (inout) :: & + ierr,ierr2,ierr3 +!$acc declare copy(k22,kbcon,ktop,ierr,ierr2,ierr3) copyin(xland) + integer & + ,intent (in ) :: & + ichoice + integer, intent(in) :: dicycle + real(kind=kind_phys), intent(in) , dimension (its:ite) :: aa1_bl,tau_ecmwf + real(kind=kind_phys), intent(inout), dimension (its:ite) :: xf_dicycle + real(kind=kind_phys), intent(inout), dimension (its:ite,10) :: forcing +!$acc declare copyin(aa1_bl,tau_ecmwf) copy(xf_dicycle,forcing) + !- local var + real(kind=kind_phys) :: xff_dicycle +! +! local variables in this routine +! + + real(kind=kind_phys), dimension (1:maxens3) :: & + xff_ens3 + real(kind=kind_phys), dimension (1) :: & + xk + integer :: & + kk,i,k,n,ne +! integer, parameter :: mkxcrt=15 +! real(kind=kind_phys), dimension(1:mkxcrt) :: & +! pcrit,acrit,acritt + integer, dimension (its:ite) :: kloc + real(kind=kind_phys) :: & + a1,a_ave,xff0,xomg!,aclim1,aclim2,aclim3,aclim4 + + real(kind=kind_phys), dimension (its:ite) :: ens_adj +!$acc declare create(kloc,ens_adj) + + + +! +!$acc kernels + ens_adj(:)=1. +!$acc end kernels + xff_dicycle = 0. + +!--- large scale forcing +! +!$acc kernels +!$acc loop private(xff_ens3,xk) + do 100 i=its,itf + kloc(i)=1 + if(ierr(i).eq.0)then +! kloc(i)=maxloc(zu(i,:),1) + kloc(i)=kbcon(i) + ens_adj(i)=1. +!ss --- comment out adjustment over ocean +!ss if(ierr2(i).gt.0.and.ierr3(i).eq.0)ens_adj(i)=0.666 ! 2./3. +!ss if(ierr2(i).gt.0.and.ierr3(i).gt.0)ens_adj(i)=0.333 +! + a_ave=0. + a_ave=axx(i) + a_ave=max(0.,a_ave) + a_ave=min(a_ave,aa1(i)) + a_ave=max(0.,a_ave) + xff_ens3(:)=0. + xff0= (aa1(i)-aa0(i))/dtime + xff_ens3(1)=max(0.,(aa1(i)-aa0(i))/dtime) + xff_ens3(2)=max(0.,(aa1(i)-aa0(i))/dtime) + xff_ens3(3)=max(0.,(aa1(i)-aa0(i))/dtime) + xff_ens3(16)=max(0.,(aa1(i)-aa0(i))/dtime) + forcing(i,1)=xff_ens3(2) +! +!--- omeg is in bar/s, mconv done with omeg in pa/s +! more like brown (1979), or frank-cohen (199?) +! +! average aaround kbcon +! + xomg=0. + kk=0 + xff_ens3(4)=0. + xff_ens3(5)=0. + xff_ens3(6)=0. + do k=kbcon(i)-1,kbcon(i)+1 + if(zu(i,k).gt.0.)then + xomg=xomg-omeg(i,k)/9.81/max(0.3,(1.-(edt(i)*zd(i,k)-edtm(i)*zdm(i,k))/zu(i,k))) + kk=kk+1 + endif + enddo + if(kk.gt.0)xff_ens3(4)=xomg/float(kk) + +! +! max below kbcon +! xff_ens3(6)=-omeg(i,k22(i))/9.81 +! do k=k22(i),kbcon(i) +! xomg=-omeg(i,k)/9.81 +! if(xomg.gt.xff_ens3(6))xff_ens3(6)=xomg +! enddo +! +! if(zu(i,kbcon(i)) > 0)xff_ens3(6)=betajb*xff_ens3(6)/zu(i,kbcon(i)) + xff_ens3(4)=betajb*xff_ens3(4) + xff_ens3(5)=xff_ens3(4) + xff_ens3(6)=xff_ens3(4) + if(xff_ens3(4).lt.0.)xff_ens3(4)=0. + if(xff_ens3(5).lt.0.)xff_ens3(5)=0. + if(xff_ens3(6).lt.0.)xff_ens3(6)=0. + xff_ens3(14)=xff_ens3(4) + forcing(i,2)=xff_ens3(4) +! +!--- more like krishnamurti et al.; pick max and average values +! + xff_ens3(7)= mconv(i) !/max(0.5,(1.-edt(i)*zd(i,kbcon(i))/zu(i,kloc(i)))) + xff_ens3(8)= mconv(i) !/max(0.5,(1.-edt(i)*zd(i,kbcon(i))/zu(i,kloc(i)))) + xff_ens3(9)= mconv(i) !/max(0.5,(1.-edt(i)*zd(i,kbcon(i))/zu(i,kloc(i)))) + xff_ens3(15)=mconv(i) !/max(0.5,(1.-edt(i)*zd(i,kbcon(i))/zu(i,kloc(i)))) + forcing(i,3)=xff_ens3(8) +! +!--- more like fritsch chappel or kain fritsch (plus triggers) +! + xff_ens3(10)=aa1(i)/tau_ecmwf(i) + xff_ens3(11)=aa1(i)/tau_ecmwf(i) + xff_ens3(12)=aa1(i)/tau_ecmwf(i) + xff_ens3(13)=(aa1(i))/tau_ecmwf(i) !(60.*15.) !tau_ecmwf(i) +! forcing(i,4)=xff_ens3(10) + +!!- more like bechtold et al. (jas 2014) +!! if(dicycle == 1) xff_dicycle = max(0.,aa1_bl(i)/tau_ecmwf(i)) !(60.*30.) !tau_ecmwf(i) +!gtest + if(ichoice.eq.0)then + if(xff0.lt.0.)then + xff_ens3(1)=0. + xff_ens3(2)=0. + xff_ens3(3)=0. + xff_ens3(10)=0. + xff_ens3(11)=0. + xff_ens3(12)=0. + xff_ens3(13)= 0. + xff_ens3(16)= 0. +! closure_n(i)=12. +! xff_dicycle = 0. + endif !xff0 + endif ! ichoice + + xk(1)=(xaa0(i,1)-aa1(i))/mbdt + forcing(i,4)=aa0(i) + forcing(i,5)=aa1(i) + forcing(i,6)=xaa0(i,1) + forcing(i,7)=xk(1) + if(xk(1).le.0.and.xk(1).gt.-.01*mbdt) & + xk(1)=-.01*mbdt + if(xk(1).gt.0.and.xk(1).lt.1.e-2) & + xk(1)=1.e-2 + ! enddo +! +!--- add up all ensembles +! +! +! over water, enfor!e small cap for some of the closures +! + if(xland(i).lt.0.1)then + if(ierr2(i).gt.0.or.ierr3(i).gt.0)then + xff_ens3(1) =ens_adj(i)*xff_ens3(1) + xff_ens3(2) =ens_adj(i)*xff_ens3(2) + xff_ens3(3) =ens_adj(i)*xff_ens3(3) + xff_ens3(4) =ens_adj(i)*xff_ens3(4) + xff_ens3(5) =ens_adj(i)*xff_ens3(5) + xff_ens3(6) =ens_adj(i)*xff_ens3(6) + xff_ens3(7) =ens_adj(i)*xff_ens3(7) + xff_ens3(8) =ens_adj(i)*xff_ens3(8) + xff_ens3(9) =ens_adj(i)*xff_ens3(9) + xff_ens3(10) =ens_adj(i)*xff_ens3(10) + xff_ens3(11) =ens_adj(i)*xff_ens3(11) + xff_ens3(12) =ens_adj(i)*xff_ens3(12) + xff_ens3(13) =ens_adj(i)*xff_ens3(13) + xff_ens3(14) =ens_adj(i)*xff_ens3(14) + xff_ens3(15) =ens_adj(i)*xff_ens3(15) + xff_ens3(16) =ens_adj(i)*xff_ens3(16) +!! !srf +!! xff_dicycle = ens_adj(i)*xff_dicycle +!! !srf end +! xff_ens3(7) =0. +! xff_ens3(8) =0. +! xff_ens3(9) =0. + endif ! ierr2 + endif ! xland +! +! end water treatment +! +! + +! +!--- special treatment for stability closures +! + if(xk(1).lt.0.)then + if(xff_ens3(1).gt.0)xf_ens(i,1)=max(0.,-xff_ens3(1)/xk(1)) + if(xff_ens3(2).gt.0)xf_ens(i,2)=max(0.,-xff_ens3(2)/xk(1)) + if(xff_ens3(3).gt.0)xf_ens(i,3)=max(0.,-xff_ens3(3)/xk(1)) + if(xff_ens3(16).gt.0)xf_ens(i,16)=max(0.,-xff_ens3(16)/xk(1)) + xf_ens(i,1)= xf_ens(i,1)+xf_ens(i,1)*rand_clos(i,1) + xf_ens(i,2)= xf_ens(i,2)+xf_ens(i,2)*rand_clos(i,1) + xf_ens(i,3)= xf_ens(i,3)+xf_ens(i,3)*rand_clos(i,1) + xf_ens(i,16)=xf_ens(i,16)+xf_ens(i,16)*rand_clos(i,1) + else + xff_ens3(1)= 0 + xff_ens3(2)= 0 + xff_ens3(3)= 0 + xff_ens3(16)=0 + endif +! +!--- if iresult.eq.1, following independent of xff0 +! + xf_ens(i,4)=max(0.,xff_ens3(4)) + xf_ens(i,5)=max(0.,xff_ens3(5)) + xf_ens(i,6)=max(0.,xff_ens3(6)) + xf_ens(i,14)=max(0.,xff_ens3(14)) + a1=max(1.e-3,pr_ens(i,7)) + xf_ens(i,7)=max(0.,xff_ens3(7)/a1) + a1=max(1.e-3,pr_ens(i,8)) + xf_ens(i,8)=max(0.,xff_ens3(8)/a1) +! forcing(i,7)=xf_ens(i,8) + a1=max(1.e-3,pr_ens(i,9)) + xf_ens(i,9)=max(0.,xff_ens3(9)/a1) + a1=max(1.e-3,pr_ens(i,15)) + xf_ens(i,15)=max(0.,xff_ens3(15)/a1) + xf_ens(i,4)=xf_ens(i,4)+xf_ens(i,4)*rand_clos(i,2) + xf_ens(i,5)=xf_ens(i,5)+xf_ens(i,5)*rand_clos(i,2) + xf_ens(i,6)=xf_ens(i,6)+xf_ens(i,6)*rand_clos(i,2) + xf_ens(i,14)=xf_ens(i,14)+xf_ens(i,14)*rand_clos(i,2) + xf_ens(i,7)=xf_ens(i,7)+xf_ens(i,7)*rand_clos(i,3) + xf_ens(i,8)=xf_ens(i,8)+xf_ens(i,8)*rand_clos(i,3) + xf_ens(i,9)=xf_ens(i,9)+xf_ens(i,9)*rand_clos(i,3) + xf_ens(i,15)=xf_ens(i,15)+xf_ens(i,15)*rand_clos(i,3) + if(xk(1).lt.0.)then + xf_ens(i,10)=max(0.,-xff_ens3(10)/xk(1)) + xf_ens(i,11)=max(0.,-xff_ens3(11)/xk(1)) + xf_ens(i,12)=max(0.,-xff_ens3(12)/xk(1)) + xf_ens(i,13)=max(0.,-xff_ens3(13)/xk(1)) + xf_ens(i,10)=xf_ens(i,10)+xf_ens(i,10)*rand_clos(i,4) + xf_ens(i,11)=xf_ens(i,11)+xf_ens(i,11)*rand_clos(i,4) + xf_ens(i,12)=xf_ens(i,12)+xf_ens(i,12)*rand_clos(i,4) + xf_ens(i,13)=xf_ens(i,13)+xf_ens(i,13)*rand_clos(i,4) + forcing(i,8)=xf_ens(i,11) + else + xf_ens(i,10)=0. + xf_ens(i,11)=0. + xf_ens(i,12)=0. + xf_ens(i,13)=0. + forcing(i,8)=0. + endif +!srf-begin +!! if(xk(1).lt.0.)then +!! xf_dicycle(i) = max(0.,-xff_dicycle /xk(1)) +!! forcing(i,9)=xf_dicycle(i) +!! else +!! xf_dicycle(i) = 0. +!! endif +!srf-end + if(ichoice.ge.1)then +! closure_n(i)=0. + xf_ens(i,1)=xf_ens(i,ichoice) + xf_ens(i,2)=xf_ens(i,ichoice) + xf_ens(i,3)=xf_ens(i,ichoice) + xf_ens(i,4)=xf_ens(i,ichoice) + xf_ens(i,5)=xf_ens(i,ichoice) + xf_ens(i,6)=xf_ens(i,ichoice) + xf_ens(i,7)=xf_ens(i,ichoice) + xf_ens(i,8)=xf_ens(i,ichoice) + xf_ens(i,9)=xf_ens(i,ichoice) + xf_ens(i,10)=xf_ens(i,ichoice) + xf_ens(i,11)=xf_ens(i,ichoice) + xf_ens(i,12)=xf_ens(i,ichoice) + xf_ens(i,13)=xf_ens(i,ichoice) + xf_ens(i,14)=xf_ens(i,ichoice) + xf_ens(i,15)=xf_ens(i,ichoice) + xf_ens(i,16)=xf_ens(i,ichoice) + endif + elseif(ierr(i).ne.20.and.ierr(i).ne.0)then + do n=1,maxens3 + xf_ens(i,n)=0. +!! +!! xf_dicycle(i) = 0. +!! + enddo + endif ! ierror + 100 continue + !$acc end kernels + + +!- +!- diurnal cycle mass flux +!- +if(dicycle == 1 )then +!$acc kernels +!$acc loop private(xk) + do i=its,itf + xf_dicycle(i) = 0. + if(ierr(i) /= 0)cycle + + xk(1)=(xaa0(i,1)-aa1(i))/mbdt + if(xk(1).le.0.and.xk(1).gt.-.01*mbdt) xk(1)=-.01*mbdt + if(xk(1).gt.0.and.xk(1).lt.1.e-2) xk(1)=1.e-2 + + xff_dicycle = (aa1(i)-aa1_bl(i))/tau_ecmwf(i) + if(xk(1).lt.0) xf_dicycle(i)= max(0.,-xff_dicycle/xk(1)) + + xf_dicycle(i)= xf_ens(i,10)-xf_dicycle(i) + enddo +!$acc end kernels +else +!$acc kernels + xf_dicycle(:) = 0. +!$acc end kernels +endif +!--------- + + + + end subroutine cup_forcing_ens_3d + +!> Calculates the level of convective cloud base. + subroutine cup_kbcon(ierrc,cap_inc,iloop_in,k22,kbcon,he_cup,hes_cup, & + hkb,ierr,kbmax,p_cup,cap_max, & + ztexec,zqexec, & + jprnt,itf,ktf, & + its,ite, kts,kte, & + z_cup,entr_rate,heo,imid ) + + implicit none +! + + ! only local wrf dimensions are need as of now in this routine + + integer & + ,intent (in ) :: & + jprnt,itf,ktf,imid, & + its,ite, kts,kte + ! + ! + ! + ! ierr error value, maybe modified in this routine + ! + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + he_cup,hes_cup,p_cup +!$acc declare copyin(he_cup,hes_cup,p_cup) + real(kind=kind_phys), dimension (its:ite) & + ,intent (in ) :: & + entr_rate,ztexec,zqexec,cap_inc,cap_max +!$acc declare copyin(entr_rate,ztexec,zqexec,cap_inc,cap_max) + real(kind=kind_phys), dimension (its:ite) & + ,intent (inout ) :: & + hkb !,cap_max +!$acc declare copy(hkb) + integer, dimension (its:ite) & + ,intent (in ) :: & + kbmax +!$acc declare copyin(kbmax) + integer, dimension (its:ite) & + ,intent (inout) :: & + kbcon,k22,ierr +!$acc declare copy(kbcon,k22,ierr) + integer & + ,intent (in ) :: & + iloop_in + character*50 :: ierrc(its:ite) + real(kind=kind_phys), dimension (its:ite,kts:kte),intent (in) :: z_cup,heo +!$acc declare copyin(z_cup,heo) + integer, dimension (its:ite) :: iloop,start_level +!$acc declare create(iloop,start_level) +! +! local variables in this routine +! + + integer :: & + i,k + real(kind=kind_phys) :: & + x_add,pbcdif,plus,hetest,dz + real(kind=kind_phys), dimension (its:ite,kts:kte) ::hcot +!$acc declare create(hcot) + +! +!--- determine the level of convective cloud base - kbcon +! +!$acc kernels + iloop(:)=iloop_in +!$acc end kernels + +!$acc parallel loop + do 27 i=its,itf + kbcon(i)=1 +! +! reset iloop for mid level convection + if(cap_max(i).gt.200 .and. imid.eq.1)iloop(i)=5 +! + if(ierr(i).ne.0)go to 27 + start_level(i)=k22(i) + kbcon(i)=k22(i)+1 + if(iloop(i).eq.5)kbcon(i)=k22(i) +! if(iloop_in.eq.5)start_level(i)=kbcon(i) + !== including entrainment for hetest + hcot(i,1:start_level(i)) = hkb(i) +!$acc loop seq + do k=start_level(i)+1,kbmax(i)+3 + dz=z_cup(i,k)-z_cup(i,k-1) + hcot(i,k)= ( (1.-0.5*entr_rate(i)*dz)*hcot(i,k-1) & + + entr_rate(i)*dz*heo(i,k-1) )/ & + (1.+0.5*entr_rate(i)*dz) + enddo + !== + + go to 32 + 31 continue + kbcon(i)=kbcon(i)+1 + if(kbcon(i).gt.kbmax(i)+2)then + if(iloop(i).ne.4)then + ierr(i)=3 +#ifndef _OPENACC + ierrc(i)="could not find reasonable kbcon in cup_kbcon" +#endif + endif + go to 27 + endif + 32 continue + hetest=hcot(i,kbcon(i)) !hkb(i) ! he_cup(i,k22(i)) + if(hetest.lt.hes_cup(i,kbcon(i)))then + go to 31 + endif + +! cloud base pressure and max moist static energy pressure +! i.e., the depth (in mb) of the layer of negative buoyancy + if(kbcon(i)-k22(i).eq.1)go to 27 + if(iloop(i).eq.5 .and. (kbcon(i)-k22(i)).le.2)go to 27 + pbcdif=-p_cup(i,kbcon(i))+p_cup(i,k22(i)) + plus=max(25.,cap_max(i)-float(iloop(i)-1)*cap_inc(i)) + if(iloop(i).eq.4)plus=cap_max(i) +! +! for shallow convection, if cap_max is greater than 25, it is the pressure at pbltop + if(iloop(i).eq.5)plus=150. + if(iloop(i).eq.5.and.cap_max(i).gt.200)pbcdif=-p_cup(i,kbcon(i))+cap_max(i) + if(pbcdif.le.plus)then + go to 27 + elseif(pbcdif.gt.plus)then + k22(i)=k22(i)+1 + kbcon(i)=k22(i)+1 +!== since k22 has be changed, hkb has to be re-calculated + x_add = xlv*zqexec(i)+cp*ztexec(i) + call get_cloud_bc(kte,he_cup (i,1:kte),hkb (i),k22(i),x_add) + + start_level(i)=k22(i) +! if(iloop_in.eq.5)start_level(i)=kbcon(i) + hcot(i,1:start_level(i)) = hkb(i) +!$acc loop seq + do k=start_level(i)+1,kbmax(i)+3 + dz=z_cup(i,k)-z_cup(i,k-1) + + hcot(i,k)= ( (1.-0.5*entr_rate(i)*dz)*hcot(i,k-1) & + + entr_rate(i)*dz*heo(i,k-1) )/ & + (1.+0.5*entr_rate(i)*dz) + enddo + !== + + if(iloop(i).eq.5)kbcon(i)=k22(i) + if(kbcon(i).gt.kbmax(i)+2)then + if(iloop(i).ne.4)then + ierr(i)=3 +#ifndef _OPENACC + ierrc(i)="could not find reasonable kbcon in cup_kbcon" +#endif + endif + go to 27 + endif + go to 32 + endif + 27 continue + !$acc end parallel + + end subroutine cup_kbcon + +!> Calculates the level at which the maximum value in an array +!! occurs. + subroutine cup_maximi(array,ks,ke,maxx,ierr, & + itf,ktf, & + its,ite, kts,kte ) + + implicit none +! +! on input +! + + ! only local wrf dimensions are need as of now in this routine + + integer & + ,intent (in ) :: & + itf,ktf, & + its,ite, kts,kte + ! array input array + ! x output array with return values + ! kt output array of levels + ! ks,kend check-range + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + array +!$acc declare copyin(array) + integer, dimension (its:ite) & + ,intent (in ) :: & + ierr,ke +!$acc declare copyin(ierr,ke) + integer & + ,intent (in ) :: & + ks + integer, dimension (its:ite) & + ,intent (out ) :: & + maxx +!$acc declare copyout(maxx) + real(kind=kind_phys), dimension (its:ite) :: & + x +!$acc declare create(x) + real(kind=kind_phys) :: & + xar + integer :: & + i,k + +!$acc kernels + do 200 i=its,itf + maxx(i)=ks + if(ierr(i).eq.0)then + x(i)=array(i,ks) +! +!$acc loop seq + do 100 k=ks,ke(i) + xar=array(i,k) + if(xar.ge.x(i)) then + x(i)=xar + maxx(i)=k + endif + 100 continue + endif + 200 continue + !$acc end kernels + + end subroutine cup_maximi + +!> Calculates the level at which the minimum value in an array occurs. + subroutine cup_minimi(array,ks,kend,kt,ierr, & + itf,ktf, & + its,ite, kts,kte ) + + implicit none +! +! on input +! + + ! only local wrf dimensions are need as of now in this routine + + integer & + ,intent (in ) :: & + itf,ktf, & + its,ite, kts,kte + ! array input array + ! x output array with return values + ! kt output array of levels + ! ks,kend check-range + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + array +!$acc declare copyin(array) + integer, dimension (its:ite) & + ,intent (in ) :: & + ierr,ks,kend +!$acc declare copyin(ierr,ks,kend) + integer, dimension (its:ite) & + ,intent (out ) :: & + kt +!$acc declare copyout(kt) + real(kind=kind_phys), dimension (its:ite) :: & + x +!$acc declare create(x) + integer :: & + i,k,kstop + +!$acc kernels + do 200 i=its,itf + kt(i)=ks(i) + if(ierr(i).eq.0)then + x(i)=array(i,ks(i)) + kstop=max(ks(i)+1,kend(i)) +! +!$acc loop seq + do 100 k=ks(i)+1,kstop + if(array(i,k).lt.x(i)) then + x(i)=array(i,k) + kt(i)=k + endif + 100 continue + endif + 200 continue + !$acc end kernels + + end subroutine cup_minimi + +!> Calculates the cloud work functions for updrafts. + subroutine cup_up_aa0(aa0,z,zu,dby,gamma_cup,t_cup, & + kbcon,ktop,ierr, & + itf,ktf, & + its,ite, kts,kte ) + + implicit none +! +! on input +! + + ! only local wrf dimensions are need as of now in this routine + + integer & + ,intent (in ) :: & + itf,ktf, & + its,ite, kts,kte + ! aa0 cloud work function + ! gamma_cup = gamma on model cloud levels + ! t_cup = temperature (kelvin) on model cloud levels + ! dby = buoancy term + ! zu= normalized updraft mass flux + ! z = heights of model levels + ! ierr error value, maybe modified in this routine + ! + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + z,zu,gamma_cup,t_cup,dby + integer, dimension (its:ite) & + ,intent (in ) :: & + kbcon,ktop +!$acc declare copyin(z,zu,gamma_cup,t_cup,dby,kbcon,ktop) +! +! input and output +! + + + integer, dimension (its:ite) & + ,intent (inout) :: & + ierr +!$acc declare copy(ierr) + real(kind=kind_phys), dimension (its:ite) & + ,intent (out ) :: & + aa0 +!$acc declare copyout(aa0) +! +! local variables in this routine +! + + integer :: & + i,k + real(kind=kind_phys) :: & + dz,da +! +!$acc kernels + do i=its,itf + aa0(i)=0. + enddo + do k=kts+1,ktf + do i=its,itf + if(ierr(i).ne.0) cycle + if(k.lt.kbcon(i)) cycle + if(k.gt.ktop(i)) cycle + dz=z(i,k)-z(i,k-1) + da=zu(i,k)*dz*(9.81/(1004.*( & + (t_cup(i,k)))))*dby(i,k-1)/ & + (1.+gamma_cup(i,k)) + ! if(k.eq.ktop(i).and.da.le.0.)go to 100 + aa0(i)=aa0(i)+max(0.,da) + if(aa0(i).lt.0.)aa0(i)=0. + enddo + enddo +!$acc end kernels + + end subroutine cup_up_aa0 + +!==================================================================== + +!> Checks for negative or excessive tendencies and corrects in a mass +!! conversing way by adjusting the cloud base mass-flux. + subroutine neg_check(name,j,dt,q,outq,outt,outu,outv, & + outqc,pret,its,ite,kts,kte,itf,ktf,ktop) + + integer, intent(in ) :: j,its,ite,kts,kte,itf,ktf + integer, dimension (its:ite ), intent(in ) :: ktop + + real(kind=kind_phys), dimension (its:ite,kts:kte ) , & + intent(inout ) :: & + outq,outt,outqc,outu,outv + real(kind=kind_phys), dimension (its:ite,kts:kte ) , & + intent(inout ) :: & + q + real(kind=kind_phys), dimension (its:ite ) , & + intent(inout ) :: & + pret +!$acc declare copy(outq,outt,outqc,outu,outv,q,pret) + character *(*), intent (in) :: & + name + real(kind=kind_phys) & + ,intent (in ) :: & + dt + real(kind=kind_phys) :: names,scalef,thresh,qmem,qmemf,qmem2,qtest,qmem1 + integer :: icheck +! +! first do check on vertical heating rate +! + thresh=300.01 +! thresh=200.01 !ss +! thresh=250.01 + names=1. + if(name == 'shallow' .or. name == 'mid')then + thresh=148.01 + names=1. + endif + scalef=86400. +!$acc kernels +!$acc loop private(qmemf,qmem,icheck) + do i=its,itf + if(ktop(i) <= 2)cycle + icheck=0 + qmemf=1. + qmem=0. +!$acc loop reduction(min:qmemf) + do k=kts,ktop(i) + qmem=(outt(i,k))*86400. + if(qmem.gt.thresh)then + qmem2=thresh/qmem + qmemf=min(qmemf,qmem2) + icheck=1 +! +! +! print *,'1',' adjusted massflux by factor ',i,j,k,qmem,qmem2,qmemf,dt + endif + if(qmem.lt.-.5*thresh*names)then + qmem2=-.5*names*thresh/qmem + qmemf=min(qmemf,qmem2) + icheck=2 +! +! + endif + enddo + do k=kts,ktop(i) + outq(i,k)=outq(i,k)*qmemf + outt(i,k)=outt(i,k)*qmemf + outu(i,k)=outu(i,k)*qmemf + outv(i,k)=outv(i,k)*qmemf + outqc(i,k)=outqc(i,k)*qmemf + enddo + pret(i)=pret(i)*qmemf + enddo +!$acc end kernels +! return +! +! check whether routine produces negative q's. this can happen, since +! tendencies are calculated based on forced q's. this should have no +! influence on conservation properties, it scales linear through all +! tendencies +! +! return +! write(14,*)'return' + thresh=1.e-32 +!$acc kernels +!$acc loop private(qmemf,qmem,icheck) + do i=its,itf + if(ktop(i) <= 2)cycle + qmemf=1. +!$acc loop reduction(min:qmemf) + do k=kts,ktop(i) + qmem=outq(i,k) + if(abs(qmem).gt.0. .and. q(i,k).gt.1.e-6)then + qtest=q(i,k)+(outq(i,k))*dt + if(qtest.lt.thresh)then +! +! qmem2 would be the maximum allowable tendency +! + qmem1=abs(outq(i,k)) + qmem2=abs((thresh-q(i,k))/dt) + qmemf=min(qmemf,qmem2/qmem1) + qmemf=max(0.,qmemf) + endif + endif + enddo + do k=kts,ktop(i) + outq(i,k)=outq(i,k)*qmemf + outt(i,k)=outt(i,k)*qmemf + outu(i,k)=outu(i,k)*qmemf + outv(i,k)=outv(i,k)*qmemf + outqc(i,k)=outqc(i,k)*qmemf + enddo + pret(i)=pret(i)*qmemf + enddo +!$acc end kernels + end subroutine neg_check + +!> This subroutine calculates final output fields including +!! physical tendencies, precipitation, and mass-flux. + subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & + outtem,outq,outqc, & + zu,pre,pw,xmb,ktop, & + edt,pwd,name,ierr2,ierr3,p_cup,pr_ens, & + maxens3, & + sig,closure_n,xland1,xmbm_in,xmbs_in, & + ichoice,imid,ipr,itf,ktf, & + its,ite, kts,kte, & + dicycle,xf_dicycle ) + + implicit none +! +! on input +! + ! only local wrf dimensions are need as of now in this routine + + integer & + ,intent (in ) :: & + ichoice,imid,ipr,itf,ktf, & + its,ite, kts,kte + integer, intent (in ) :: & + maxens3 + ! xf_ens = ensemble mass fluxes + ! pr_ens = precipitation ensembles + ! dellat = change of temperature per unit mass flux of cloud ensemble + ! dellaq = change of q per unit mass flux of cloud ensemble + ! dellaqc = change of qc per unit mass flux of cloud ensemble + ! outtem = output temp tendency (per s) + ! outq = output q tendency (per s) + ! outqc = output qc tendency (per s) + ! pre = output precip + ! xmb = total base mass flux + ! xfac1 = correction factor + ! pw = pw -epsilon*pd (ensemble dependent) + ! ierr error value, maybe modified in this routine + ! + real(kind=kind_phys), dimension (its:ite,1:maxens3) & + ,intent (inout) :: & + xf_ens,pr_ens + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (inout ) :: & + outtem,outq,outqc + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + zu,pwd,p_cup + real(kind=kind_phys), dimension (its:ite) & + ,intent (in ) :: & + sig,xmbm_in,xmbs_in,edt + real(kind=kind_phys), dimension (its:ite,2) & + ,intent (in ) :: & + xff_mid + real(kind=kind_phys), dimension (its:ite) & + ,intent (inout ) :: & + pre,xmb + real(kind=kind_phys), dimension (its:ite) & + ,intent (inout ) :: & + closure_n + real(kind=kind_phys), dimension (its:ite,kts:kte,1) & + ,intent (in ) :: & + dellat,dellaqc,dellaq,pw + integer, dimension (its:ite) & + ,intent (in ) :: & + ktop,xland1 + integer, dimension (its:ite) & + ,intent (inout) :: & + ierr,ierr2,ierr3 + integer, intent(in) :: dicycle + real(kind=kind_phys), intent(in), dimension (its:ite) :: xf_dicycle +!$acc declare copyin(zu,pwd,p_cup,sig,xmbm_in,xmbs_in,edt,xff_mid,dellat,dellaqc,dellaq,pw,ktop,xland1,xf_dicycle) +!$acc declare copy(xf_ens,pr_ens,outtem,outq,outqc,pre,xmb,closure_n,ierr,ierr2,ierr3) +! +! local variables in this routine +! + + integer :: & + i,k,n + real(kind=kind_phys) :: & + clos_wei,dtt,dp,dtq,dtqc,dtpw,dtpwd + real(kind=kind_phys), dimension (its:ite) :: & + pre2,xmb_ave,pwtot +!$acc declare create(pre2,xmb_ave,pwtot) +! + character *(*), intent (in) :: & + name + +! +!$acc kernels + do k=kts,kte + do i=its,ite + outtem (i,k)=0. + outq (i,k)=0. + outqc (i,k)=0. + enddo + enddo + do i=its,itf + pre(i)=0. + xmb(i)=0. + enddo + do i=its,itf + if(ierr(i).eq.0)then + do n=1,maxens3 + if(pr_ens(i,n).le.0.)then + xf_ens(i,n)=0. + endif + enddo + endif + enddo +!$acc end kernels +! +!--- calculate ensemble average mass fluxes +! + +! +!-- now do feedback +! +!!!!! deep convection !!!!!!!!!! + if(imid.eq.0)then +!$acc kernels + do i=its,itf + if(ierr(i).eq.0)then + k=0 + xmb_ave(i)=0. +!$acc loop seq + do n=1,maxens3 + k=k+1 + xmb_ave(i)=xmb_ave(i)+xf_ens(i,n) + + enddo + !print *,'xf_ens',xf_ens + xmb_ave(i)=xmb_ave(i)/float(k) + !print *,'k,xmb_ave',k,xmb_ave + !srf begin + if(dicycle == 2 )then + xmb_ave(i)=xmb_ave(i)-max(0.,xmbs_in(i)) + xmb_ave(i)=max(0.,xmb_ave(i)) + else if (dicycle == 1) then +! xmb_ave(i)=min(xmb_ave(i),xmb_ave(i) - xf_dicycle(i)) + xmb_ave(i)=xmb_ave(i) - xf_dicycle(i) + xmb_ave(i)=max(0.,xmb_ave(i)) + endif + !print *,"2 xmb_ave,xf_dicycle",xmb_ave,xf_dicycle +! --- now use proper count of how many closures were actually +! used in cup_forcing_ens (including screening of some +! closures over water) to properly normalize xmb + clos_wei=16./max(1.,closure_n(i)) + xmb_ave(i)=min(xmb_ave(i),100.) + xmb(i)=clos_wei*sig(i)*xmb_ave(i) + + if(xmb(i) < 1.e-16)then + ierr(i)=19 + endif +! xfac1(i)=xmb(i) +! xfac2(i)=xmb(i) + + endif + enddo +!$acc end kernels +!!!!! not so deep convection !!!!!!!!!! + else ! imid == 1 +!$acc kernels + do i=its,itf + xmb_ave(i)=0. + if(ierr(i).eq.0)then +! ! first get xmb_ves, depend on ichoicee +! + if(ichoice.eq.1 .or. ichoice.eq.2)then + xmb_ave(i)=sig(i)*xff_mid(i,ichoice) + else if(ichoice.gt.2)then + k=0 +!$acc loop seq + do n=1,maxens3 + k=k+1 + xmb_ave(i)=xmb_ave(i)+xf_ens(i,n) + enddo + xmb_ave(i)=xmb_ave(i)/float(k) + else if(ichoice == 0)then + xmb_ave(i)=.5*sig(i)*(xff_mid(i,1)+xff_mid(i,2)) + endif ! ichoice gt.2 +! which dicycle method + if(dicycle == 2 )then + xmb(i)=max(0.,xmb_ave(i)-xmbs_in(i)) + else if (dicycle == 1) then +! xmb(i)=min(xmb_ave(i),xmb_ave(i) - xf_dicycle(i)) + xmb(i)=xmb_ave(i) - xf_dicycle(i) + xmb(i)=max(0.,xmb_ave(i)) + else if (dicycle == 0) then + xmb(i)=max(0.,xmb_ave(i)) + endif ! dicycle=1,2 + endif ! ierr >0 + enddo ! i +!$acc end kernels + endif ! imid=1 + +!$acc kernels + do i=its,itf + if(ierr(i).eq.0)then + dtpw=0. + do k=kts,ktop(i) + dtpw=dtpw+pw(i,k,1) + outtem(i,k)= xmb(i)* dellat (i,k,1) + outq (i,k)= xmb(i)* dellaq (i,k,1) + outqc (i,k)= xmb(i)* dellaqc(i,k,1) + enddo + PRE(I)=PRE(I)+XMB(I)*dtpw + endif + enddo +!$acc end kernels + return + +!$acc kernels + do i=its,itf + pwtot(i)=0. + pre2(i)=0. + if(ierr(i).eq.0)then + do k=kts,ktop(i) + pwtot(i)=pwtot(i)+pw(i,k,1) + enddo + do k=kts,ktop(i) + dp=100.*(p_cup(i,k)-p_cup(i,k+1))/g + dtt =dellat (i,k,1) + dtq =dellaq (i,k,1) +! necessary to drive downdraft + dtpwd=-pwd(i,k)*edt(i) +! take from dellaqc first + dtqc=dellaqc (i,k,1)*dp - dtpwd +! if this is negative, use dellaqc first, rest needs to come from rain + if(dtqc < 0.)then + dtpwd=dtpwd-dellaqc(i,k,1)*dp + dtqc=0. +! if this is positive, can come from clw detrainment + else + dtqc=dtqc/dp + dtpwd=0. + endif + outtem(i,k)= xmb(i)* dtt + outq (i,k)= xmb(i)* dtq + outqc (i,k)= xmb(i)* dtqc + xf_ens(i,:)=sig(i)*xf_ens(i,:) +! what is evaporated + pre(i)=pre(i)-xmb(i)*dtpwd + pre2(i)=pre2(i)+xmb(i)*(pw(i,k,1)+edt(i)*pwd(i,k)) +! write(15,124)k,dellaqc(i,k,1),dtqc,-pwd(i,k)*edt(i),dtpwd + enddo + pre(i)=-pre(i)+xmb(i)*pwtot(i) + endif +#ifndef _OPENACC +124 format(1x,i3,4e13.4) +125 format(1x,2e13.4) +#endif + enddo +!$acc end kernels + + end subroutine cup_output_ens_3d +!------------------------------------------------------- +!> Calculates moisture properties of the updraft. + subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & + p_cup,kbcon,ktop,dby,clw_all,xland1, & + q,gamma_cup,zu,qes_cup,k22,qe_cup,c0, & + zqexec,ccn,ccnclean,rho,c1d,t,autoconv, & + up_massentr,up_massdetr,psum,psumh, & + itest,itf,ktf, & + its,ite, kts,kte ) + + implicit none + real(kind=kind_phys), parameter :: bdispm = 0.366 ! 273.16) then + c0t = c0(i) + else + c0t = c0(i) * exp(c0_iceconv * (t(i,k) - 273.16)) + endif + qc(i,k)= (qc(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)* qc(i,k-1)+ & + up_massentr(i,k-1)*q(i,k-1)) / & + (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) +! qrch=qes_cup(i,k) + qrch=qes_cup(i,k)+(1./xlv)*(gamma_cup(i,k) & + /(1.+gamma_cup(i,k)))*dby(i,k) + if(k.lt.kbcon(i))qrch=qc(i,k) + if(qc(i,k).gt.qrch)then + dz=z_cup(i,k)-z_cup(i,k-1) + qrc(i,k)=(qc(i,k)-qrch)/(1.+c0t*dz) + pw(i,k)=c0t*dz*qrc(i,k)*zu(i,k) + qc(i,k)=qrch+qrc(i,k) + clw_all(i,k)=qrc(i,k) + endif + enddo + ! endif +! +!now do the rest +! + kklev(i)=maxloc(zu(i,:),1) +!$acc loop seq + do k=kbcon(i)+1,ktop(i) + if(t(i,k) > 273.16) then + c0t = c0(i) + else + c0t = c0(i) * exp(c0_iceconv * (t(i,k) - 273.16)) + endif + if(is_mid)c0t=0.004 + + denom=zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1) + if(denom.lt.1.e-16)then + ierr(i)=51 + exit + endif + + + rhoc=.5*(rho(i,k)+rho(i,k-1)) + dz=z_cup(i,k)-z_cup(i,k-1) + dp=p_cup(i,k)-p_cup(i,k-1) +! +!--- saturation in cloud, this is what is allowed to be in it +! + qrch=qes_cup(i,k)+(1./xlv)*(gamma_cup(i,k) & + /(1.+gamma_cup(i,k)))*dby(i,k) +! +!------ 1. steady state plume equation, for what could +!------ be in cloud without condensation +! +! + qc(i,k)= (qc(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)* qc(i,k-1)+ & + up_massentr(i,k-1)*q(i,k-1)) / & + (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) + qch(i,k)= (qch(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)*qch(i,k-1)+ & + up_massentr(i,k-1)*q(i,k-1)) / & + (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) + + if(qc(i,k).le.qrch)then + qc(i,k)=qrch+1e-8 + endif + if(qch(i,k).le.qrch)then + qch(i,k)=qrch+1e-8 + endif +! +!------- total condensed water before rainout +! + clw_all(i,k)=max(0.,qc(i,k)-qrch) + qrc(i,k)=max(0.,(qc(i,k)-qrch)) ! /(1.+c0(i)*dz*zu(i,k)) + clw_allh(i,k)=max(0.,qch(i,k)-qrch) + qrcb(i,k)=max(0.,(qch(i,k)-qrch)) ! /(1.+c0(i)*dz*zu(i,k)) + if(is_deep)then + clwdet=0.1 !0.02 ! 05/11/2021 + if(k.lt.kklev(i)) clwdet=0. ! 05/05/2021 + else + clwdet=0.1 !0.02 ! 05/05/2021 + if(k.lt.kklev(i)) clwdet=0. ! 05/25/2021 + endif + if(k.gt.kbcon(i)+1)c1d(i,k)=clwdet*up_massdetr(i,k-1) + if(k.gt.kbcon(i)+1)c1d_b(i,k)=clwdet*up_massdetr(i,k-1) + + if(autoconv.eq.2) then +! +! normalized berry +! +! first calculate for average conditions, used in cup_dd_edt! +! this will also determine proportionality constant prop_b, which, if applied, +! would give the same results as c0 under these conditions +! + q1=1.e3*rhoc*clw_allh(i,k) ! g/m^3 ! g[h2o]/cm^3 + berryc0=q1*q1/(60.0*(5.0 + 0.0366*ccnclean/ & + ( q1 * bdsp) ) ) !/( + qrcb_h=(qch(i,k)-qrch)/(1.+(c1d_b(i,k)+c0t)*dz) + prop_b(k)=(c0t*qrcb_h)/max(1.e-8,(1.e-3*berryc0)) + if(prop_b(k)>5.) prop_b(k)=5. + pwh(i,k)=zu(i,k)*1.e-3*berryc0*dz*prop_b(k) ! 2. + qrcb(i,k)=(max(0.,(qch(i,k)-qrch))*zu(i,k)-pwh(i,k))/(zu(i,k)*(1+c1d_b(i,k)*dz)) + if(qrcb(i,k).lt.0.)then + berryc0=max(0.,(qch(i,k)-qrch))/(1.e-3*dz*prop_b(k)) + pwh(i,k)=zu(i,k)*1.e-3*berryc0*dz*prop_b(k) + qrcb(i,k)=0. + endif + qch(i,k)=qrcb(i,k)+qrch + pwavh(i)=pwavh(i)+pwh(i,k) + psumh(i)=psumh(i)+pwh(i,k) ! HCB + !psumh(i)=psumh(i)+clw_allh(i,k)*zu(i,k) *dz + ! +! then the real berry +! + q1=1.e3*rhoc*clw_all(i,k) ! g/m^3 ! g[h2o]/cm^3 + berryc0=q1*q1/(60.0*(5.0 + 0.0366*ccn(i)/ & + ( q1 * bdsp) ) ) !/( + berryc0=1.e-3*berryc0*dz*prop_b(k) ! 2. + qrc(i,k)=(max(0.,(qc(i,k)-qrch))*zu(i,k)-zu(i,k)*berryc0)/(zu(i,k)*(1+c1d(i,k)*dz)) + if(qrc(i,k).lt.0.)then + berryc0=max(0.,(qc(i,k)-qrch))/(1.e-3*dz*prop_b(k)) + qrc(i,k)=0. + endif + pw(i,k)=berryc0*zu(i,k) + qc(i,k)=qrc(i,k)+qrch + +! if not running with berry at all, do the following +! + else !c0=.002 + if(iall.eq.1)then + qrc(i,k)=0. + pw(i,k)=(qc(i,k)-qrch)*zu(i,k) + if(pw(i,k).lt.0.)pw(i,k)=0. + else +! create clw detrainment profile that depends on mass detrainment and +! in-cloud clw/ice +! + !c1d(i,k)=clwdet*up_massdetr(i,k-1)*qrc(i,k-1) + qrc(i,k)=(qc(i,k)-qrch)/(1.+(c1d(i,k)+c0t)*dz) + if(qrc(i,k).lt.0.)then ! hli new test 02/12/19 + qrc(i,k)=0. + endif + pw(i,k)=c0t*dz*qrc(i,k)*zu(i,k) + +!-----srf-08aug2017-----begin +! pw(i,k)=(c1d(i,k)+c0)*dz*max(0.,qrc(i,k) -qrc_crit)! units kg[rain]/kg[air] +!-----srf-08aug2017-----end + if(qrc(i,k).lt.0)then + qrc(i,k)=0. + pw(i,k)=0. + endif + endif + qc(i,k)=qrc(i,k)+qrch + endif !autoconv + pwav(i)=pwav(i)+pw(i,k) + psum(i)=psum(i)+pw(i,k) ! HCB + enddo ! k=kbcon,ktop +! do not include liquid/ice in qc +!$acc loop independent + do k=k22(i)+1,ktop(i) +!$acc atomic + qc(i,k)=qc(i,k)-qrc(i,k) + enddo + endif ! ierr +! +!--- integrated normalized ondensate +! + 100 continue +!$acc end kernels + prop_ave=0. + iprop=0 +!$acc parallel loop reduction(+:prop_ave,iprop) + do k=kts,kte + prop_ave=prop_ave+prop_b(k) + if(prop_b(k).gt.0)iprop=iprop+1 + enddo +!$acc end parallel + iprop=max(iprop,1) + + end subroutine cup_up_moisture + +!-------------------------------------------------------------------- +!> Calculates saturation vapor pressure. + real function satvap(temp2) +!$acc routine seq + implicit none + real(kind=kind_phys) :: temp2, temp, toot, toto, eilog, tsot, & + & ewlog, ewlog2, ewlog3, ewlog4 + temp = temp2-273.155 + if (temp.lt.-20.) then !!!! ice saturation + toot = 273.16 / temp2 + toto = 1 / toot + eilog = -9.09718 * (toot - 1) - 3.56654 * (log(toot) / & + & log(10.)) + .876793 * (1 - toto) + (log(6.1071) / log(10.)) + satvap = 10 ** eilog + else + tsot = 373.16 / temp2 + ewlog = -7.90298 * (tsot - 1) + 5.02808 * & + & (log(tsot) / log(10.)) + ewlog2 = ewlog - 1.3816e-07 * & + & (10 ** (11.344 * (1 - (1 / tsot))) - 1) + ewlog3 = ewlog2 + .0081328 * & + & (10 ** (-3.49149 * (tsot - 1)) - 1) + ewlog4 = ewlog3 + (log(1013.246) / log(10.)) + satvap = 10 ** ewlog4 + end if + end function +!-------------------------------------------------------------------- +!> Calculates the average value of a variable at the updraft originating level. + subroutine get_cloud_bc(mzp,array,x_aver,k22,add) +!$acc routine seq + implicit none + integer, intent(in) :: mzp,k22 + real(kind=kind_phys) , dimension(:), intent(in) :: array + real(kind=kind_phys) , intent(in) :: add + real(kind=kind_phys) , intent(out) :: x_aver + integer :: i,local_order_aver,order_aver + + !-- dimension of the average + !-- a) to pick the value at k22 level, instead of a average between + !-- k22-order_aver, ..., k22-1, k22 set order_aver=1) + !-- b) to average between 1 and k22 => set order_aver = k22 + order_aver = 3 !=> average between k22, k22-1 and k22-2 + + local_order_aver=min(k22,order_aver) + + x_aver=0. + do i = 1,local_order_aver + x_aver = x_aver + array(k22-i+1) + enddo + x_aver = x_aver/float(local_order_aver) + x_aver = x_aver + add + + end subroutine get_cloud_bc + !======================================================================================== +!> Driver for the normalized mass-flux routine. + subroutine rates_up_pdf(rand_vmas,ipr,name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo,heso_cup,z_cup, & + xland,kstabi,k22,kbcon,its,ite,itf,kts,kte,ktf,zuo,kpbl,ktopdby,csum,pmin_lev) + implicit none + character *(*), intent (in) :: name + integer, intent(in) :: ipr,its,ite,itf,kts,kte,ktf + real(kind=kind_phys), dimension (its:ite,kts:kte),intent (inout) :: entr_rate_2d,zuo + real(kind=kind_phys), dimension (its:ite,kts:kte),intent (in) ::p_cup, heo,heso_cup,z_cup + real(kind=kind_phys), dimension (its:ite),intent (in) :: hkbo,rand_vmas + integer, dimension (its:ite),intent (in) :: kstabi,k22,kpbl,csum,xland,pmin_lev + integer, dimension (its:ite),intent (inout) :: kbcon,ierr,ktop,ktopdby +!$acc declare copy(entr_rate_2d,zuo,kbcon,ierr,ktop,ktopdby) & +!$acc copyin(p_cup, heo,heso_cup,z_cup,hkbo,rand_vmas,kstabi,k22,kpbl,csum,xland,pmin_lev) + + !-local vars + real(kind=kind_phys), dimension (its:ite,kts:kte) :: hcot +!$acc declare create(hcot) + real(kind=kind_phys) :: entr_init,beta_u,dz,dbythresh,dzh2,zustart,zubeg,massent,massdetr + real(kind=kind_phys) :: dby(kts:kte),dbm(kts:kte),zux(kts:kte) + real(kind=kind_phys) zuh2(40),zh2(40) + integer :: kklev,i,kk,kbegin,k,kfinalzu + integer, dimension (its:ite) :: start_level +!$acc declare create(start_level) + logical :: is_deep, is_mid, is_shallow + ! + zustart=.1 + dbythresh= 0.8 !.0.95 ! 0.85, 0.6 + if(name == 'shallow' .or. name == 'mid') dbythresh=1. + + !dby(:)=0. + + is_deep = (name .eq. 'deep') + is_mid = (name .eq. 'mid') + is_shallow = (name .eq. 'shallow') + +!$acc parallel loop private(beta_u,entr_init,dz,massent,massdetr,zubeg,kklev,kfinalzu,dby,dbm,zux,zuh2,zh2) + do i=its,itf + if(ierr(i) > 0 )cycle + zux(:)=0. + beta_u=max(.1,.2-float(csum(i))*.01) + zuo(i,:)=0. + dby(:)=0. + dbm(:)=0. + kbcon(i)=max(kbcon(i),2) + start_level(i)=k22(i) + zuo(i,start_level(i))=zustart + zux(start_level(i))=zustart + entr_init=entr_rate_2d(i,kts) +!$acc loop seq + do k=start_level(i)+1,kbcon(i) + dz=z_cup(i,k)-z_cup(i,k-1) + massent=dz*entr_rate_2d(i,k-1)*zuo(i,k-1) +! massdetr=dz*1.e-9*zuo(i,k-1) + massdetr=dz*.1*entr_init*zuo(i,k-1) + zuo(i,k)=zuo(i,k-1)+massent-massdetr + zux(k)=zuo(i,k) + enddo + zubeg=zustart !zuo(i,kbcon(i)) + if(is_deep)then + ktop(i)=0 + hcot(i,start_level(i))=hkbo(i) + dz=z_cup(i,start_level(i))-z_cup(i,start_level(i)-1) +!$acc loop seq + do k=start_level(i)+1,ktf-2 + dz=z_cup(i,k)-z_cup(i,k-1) + + hcot(i,k)=( (1.-0.5*entr_rate_2d(i,k-1)*dz)*hcot(i,k-1) & + + entr_rate_2d(i,k-1)*dz*heo(i,k-1))/ & + (1.+0.5*entr_rate_2d(i,k-1)*dz) + if(k >= kbcon(i)) dby(k)=dby(k-1)+(hcot(i,k)-heso_cup(i,k))*dz + if(k >= kbcon(i)) dbm(k)=hcot(i,k)-heso_cup(i,k) + enddo + ktopdby(i)=maxloc(dby(:),1) + kklev=maxloc(dbm(:),1) +!$acc loop seq + do k=maxloc(dby(:),1)+1,ktf-2 + if(dby(k).lt.dbythresh*maxval(dby))then + kfinalzu=k - 1 + ktop(i)=kfinalzu + go to 412 + endif + enddo + kfinalzu=ktf-2 + ktop(i)=kfinalzu +412 continue + ktop(i)=ktopdby(i) ! HCB + kklev=min(kklev+3,ktop(i)-2) +! +! at least overshoot by one level +! +! kfinalzu=min(max(kfinalzu,ktopdby(i)+1),ktopdby(i)+2) +! ktop(i)=kfinalzu + if(kfinalzu.le.kbcon(i)+2)then + ierr(i)=41 + ktop(i)= 0 + else +! call get_zu_zd_pdf_fim(ipr,xland(i),zuh2,"up",ierr(i),start_level(i), & +! call get_zu_zd_pdf_fim(rand_vmas(i),zubeg,ipr,xland(i),zuh2,"up",ierr(i),kbcon(i), & +! kfinalzu,zuo(i,kts:kte),kts,kte,ktf,beta_u,kpbl(i),csum(i),pmin_lev(i)) + call get_zu_zd_pdf_fim(kklev,p_cup(i,:),rand_vmas(i),zubeg,ipr,xland(i),zuh2,1,ierr(i),k22(i), & + kfinalzu+1,zuo(i,kts:kte),kts,kte,ktf,beta_u,kbcon(i),csum(i),pmin_lev(i)) + endif + endif ! end deep + if ( is_mid ) then + if(ktop(i) <= kbcon(i)+2)then + ierr(i)=41 + ktop(i)= 0 + else + kfinalzu=ktop(i) + ktopdby(i)=ktop(i)+1 + call get_zu_zd_pdf_fim(kklev,p_cup(i,:),rand_vmas(i),zubeg,ipr,xland(i),zuh2,3, & + ierr(i),k22(i),ktopdby(i)+1,zuo(i,kts:kte),kts,kte,ktf,beta_u,kbcon(i),csum(i),pmin_lev(i)) + endif + endif ! mid + if ( is_shallow ) then + if(ktop(i) <= kbcon(i)+2)then + ierr(i)=41 + ktop(i)= 0 + else + kfinalzu=ktop(i) + ktopdby(i)=ktop(i)+1 + call get_zu_zd_pdf_fim(kbcon(i),p_cup(i,:),rand_vmas(i),zubeg,ipr,xland(i),zuh2,2,ierr(i),k22(i), & + ktopdby(i)+1,zuo(i,kts:kte),kts,kte,ktf,beta_u,kbcon(i),csum(i),pmin_lev(i)) + + endif + endif ! shal + enddo +!$acc end parallel loop + + end subroutine rates_up_pdf +!------------------------------------------------------------------------- +!> Calculates a normalized mass-flux profile for updrafts and downdrafts using the beta function. + subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,kb,kt,zu,kts,kte,ktf,max_mass,kpbli,csum,pmin_lev) +!$acc routine vector + + implicit none +! real(kind=kind_phys), parameter :: beta_deep=1.3,g_beta_deep=0.8974707 +! real(kind=kind_phys), parameter :: beta_deep=1.2,g_beta_deep=0.8974707 +! real(kind=kind_phys), parameter :: beta_sh=2.5,g_beta_sh=1.329340 + real(kind=kind_phys), parameter :: beta_sh=2.2,g_beta_sh=0.8974707 + real(kind=kind_phys), parameter :: beta_mid=1.3,g_beta_mid=0.8974707 +! real(kind=kind_phys), parameter :: beta_mid=1.8,g_beta_mid=0.8974707 + real(kind=kind_phys), parameter :: beta_dd=4.0,g_beta_dd=6. + integer, intent(in) ::ipr,xland,kb,kklev,kt,kts,kte,ktf,kpbli,csum,pmin_lev + real(kind=kind_phys), intent(in) ::max_mass,zubeg + real(kind=kind_phys), intent(inout) :: zu(kts:kte) + real(kind=kind_phys), intent(in) :: p(kts:kte) + real(kind=kind_phys) :: trash,beta_deep,zuh(kts:kte),zuh2(1:40) + integer, intent(inout) :: ierr + integer, intent(in) ::draft + + !- local var + integer :: k1,kk,k,kb_adj,kpbli_adj,kmax + real(kind=kind_phys) :: maxlim,krmax,kratio,tunning,fzu,rand_vmas,lev_start + real(kind=kind_phys) :: a,b,x1,y1,g_a,g_b,alpha2,g_alpha2 +! +! very simple lookup tables +! + real(kind=kind_phys), dimension(30) :: alpha,g_alpha + data (alpha(k),k=1,30)/3.699999,3.699999,3.699999,3.699999,& + 3.024999,2.559999,2.249999,2.028571,1.862500, & + 1.733333,1.630000,1.545454,1.475000,1.415385, & + 1.364286,1.320000,1.281250,1.247059,1.216667, & + 1.189474,1.165000,1.142857,1.122727,1.104348, & + 1.087500,1.075000,1.075000,1.075000,1.075000,1.075000/ + data (g_alpha(k),k=1,30)/4.170645,4.170645,4.170645,4.170645, & + 2.046925 , 1.387837, 1.133003, 1.012418,0.9494680, & + 0.9153771,0.8972442,0.8885444,0.8856795,0.8865333, & + 0.8897996,0.8946404,0.9005030,0.9070138,0.9139161, & + 0.9210315,0.9282347,0.9354376,0.9425780,0.9496124, & + 0.9565111,0.9619183,0.9619183,0.9619183,0.9619183,0.9619183/ + + !- kb cannot be at 1st level + + !-- fill zu with zeros + zu(:)=0.0 + zuh(:)=0.0 + kb_adj=max(kb,2) + +! Dan: replaced draft string with integer +! up = 1 +! sh2 = 2 +! mid = 3 +! down = 4 +! downm = 5 + + if(draft == 1) then + lev_start=min(.9,.1+csum*.013) + kb_adj=max(kb,2) + tunning=max(p(kklev+1),.5*(p(kpbli)+p(kt))) + tunning=p(kklev) +! tunning=p(kklev+1) !p(kpbli+1) !p(kklev) !p(kt)+(p(kpbli)-p(kt))*lev_start +! tunning=.5*(p(kb_adj)+p(kt)) !p(kpbli+1) !p(kklev) !p(kt)+(p(kpbli)-p(kt))*lev_start + trash=-p(kt)+p(kb_adj) + beta_deep=1.3 +(1.-trash/1200.) + tunning =min(0.95, (tunning-p(kb_adj))/(p(kt)-p(kb_adj))) !=.6 + tunning =max(0.02, tunning) + alpha2= (tunning*(beta_deep -2.)+1.)/(1.-tunning) + do k=27,3,-1 + if(alpha(k) >= alpha2)exit + enddo + k1=k+1 + if(alpha(k1) .ne. alpha(k1-1))then +! write(0,*)'k1 = ',k1 + a=alpha(k1)-alpha(k1-1) + b=alpha(k1-1)*(k1) -(k1-1)*alpha(k1) + x1= (alpha2-b)/a + y1=a*x1+b +! write(0,*)'x1,y1,a,b ',x1,y1,a,b + g_a=g_alpha(k1)-g_alpha(k1-1) + g_b=g_alpha(k1-1)*k1 - (k1-1)*g_alpha(k1) + g_alpha2=g_a*x1+g_b +! write(0,*)'g_a,g_b,g_alpha2 ',g_a,g_b,g_alpha2 + else + g_alpha2=g_alpha(k1) + endif + +! fzu = gamma(alpha2 + beta_deep)/(g_alpha2*g_beta_deep) + fzu = gamma(alpha2 + beta_deep)/(gamma(alpha2)*gamma(beta_deep)) + zu(kb_adj)=zubeg + do k=kb_adj+1,min(kte,kt-1) + kratio= (p(k)-p(kb_adj))/(p(kt)-p(kb_adj)) !float(k)/float(kt+1) + zu(k) = zubeg+fzu*kratio**(alpha2-1.0) * (1.0-kratio)**(beta_deep-1.0) + enddo + + if(zu(kpbli).gt.0.) & + zu(kts:min(ktf,kt-1))= zu(kts:min(ktf,kt-1))/zu(kpbli) + do k=my_maxloc1d(zu(:),kte),1,-1 + if(zu(k).lt.1.e-6)then + kb_adj=k+1 + exit + endif + enddo + kb_adj=max(2,kb_adj) + do k=kts,kb_adj-1 + zu(k)=0. + enddo + maxlim=1.2 + a=maxval(zu)-zu(kb_adj) + do k=kb_adj,kt + trash=zu(k) + if(a.gt.maxlim)then + zu(k)=(zu(k)-zu(kb_adj))*maxlim/a+zu(kb_adj) +! if(p(kt).gt.400.)write(32,122)k,p(k),zu(k),trash + endif + enddo +#ifndef _OPENACC +122 format(1x,i4,1x,f8.1,1x,f6.2,1x,f6.2) +#endif + elseif(draft == 2) then + k=kklev + if(kpbli.gt.5)k=kpbli +!new nov18 + tunning=p(kklev) !p(kpbli+1) !p(kklev) !p(kt)+(p(kpbli)-p(kt))*lev_start +!end new + tunning =min(0.95, (tunning-p(kb_adj))/(p(kt)-p(kb_adj))) !=.6 + tunning =max(0.02, tunning) + alpha2= (tunning*(beta_sh -2.)+1.)/(1.-tunning) + do k=27,3,-1 + if(alpha(k) >= alpha2)exit + enddo + k1=k+1 + if(alpha(k1) .ne. alpha(k1-1))then + a=alpha(k1)-alpha(k1-1) + b=alpha(k1-1)*(k1) -(k1-1)*alpha(k1) + x1= (alpha2-b)/a + y1=a*x1+b + g_a=g_alpha(k1)-g_alpha(k1-1) + g_b=g_alpha(k1-1)*k1 - (k1-1)*g_alpha(k1) + g_alpha2=g_a*x1+g_b + else + g_alpha2=g_alpha(k1) + endif + + fzu = gamma(alpha2 + beta_sh)/(g_alpha2*g_beta_sh) + zu(kb_adj) = zubeg + do k=kb_adj+1,min(kte,kt-1) + kratio= (p(k)-p(kb_adj))/(p(kt)-p(kb_adj)) !float(k)/float(kt+1) + zu(k) = zubeg+fzu*kratio**(alpha2-1.0) * (1.0-kratio)**(beta_sh-1.0) + enddo + +! beta = 2.5 !2.5 ! max(2.5,2./tunning) +! if(maxval(zu(kts:min(ktf,kt+1))).gt.0.) & +! zu(kts:min(ktf,kt+1))= zu(kts:min(ktf,kt+1))/maxval(zu(kts:min(ktf,kt+1))) + if(zu(kpbli).gt.0.) & + zu(kts:min(ktf,kt-1))= zu(kts:min(ktf,kt-1))/zu(kpbli) + do k=my_maxloc1d(zu(:),kte),1,-1 + if(zu(k).lt.1.e-6)then + kb_adj=k+1 + exit + endif + enddo + maxlim=1. + a=maxval(zu)-zu(kb_adj) + do k=kts,kt + if(a.gt.maxlim)zu(k)=(zu(k)-zu(kb_adj))*maxlim/a+zu(kb_adj) +! write(32,122)k,p(k),zu(k) + enddo + + elseif(draft == 3) then + kb_adj=max(kb,2) + tunning=.5*(p(kt)+p(kpbli)) !p(kt)+(p(kb_adj)-p(kt))*.9 !*.33 +!new nov18 +! tunning=p(kpbli) !p(kpbli+1) !p(kklev) !p(kt)+(p(kpbli)-p(kt))*lev_start +!end new + tunning =min(0.95, (tunning-p(kb_adj))/(p(kt)-p(kb_adj))) !=.6 + tunning =max(0.02, tunning) + alpha2= (tunning*(beta_mid -2.)+1.)/(1.-tunning) + do k=27,3,-1 + if(alpha(k) >= alpha2)exit + enddo + k1=k+1 + if(alpha(k1) .ne. alpha(k1-1))then + a=alpha(k1)-alpha(k1-1) + b=alpha(k1-1)*(k1) -(k1-1)*alpha(k1) + x1= (alpha2-b)/a + y1=a*x1+b + g_a=g_alpha(k1)-g_alpha(k1-1) + g_b=g_alpha(k1-1)*k1 - (k1-1)*g_alpha(k1) + g_alpha2=g_a*x1+g_b + else + g_alpha2=g_alpha(k1) + endif + +! fzu = gamma(alpha2 + beta_deep)/(g_alpha2*g_beta_deep) + fzu = gamma(alpha2 + beta_mid)/(gamma(alpha2)*gamma(beta_mid)) +! fzu = gamma(alpha2 + beta_mid)/(g_alpha2*g_beta_mid) + zu(kb_adj) = zubeg + do k=kb_adj+1,min(kte,kt-1) + kratio= (p(k)-p(kb_adj))/(p(kt)-p(kb_adj)) !float(k)/float(kt+1) + zu(k) = zubeg+fzu*kratio**(alpha2-1.0) * (1.0-kratio)**(beta_mid-1.0) + enddo + + if(zu(kpbli).gt.0.) & + zu(kts:min(ktf,kt-1))= zu(kts:min(ktf,kt-1))/zu(kpbli) + do k=my_maxloc1d(zu(:),kte),1,-1 + if(zu(k).lt.1.e-6)then + kb_adj=k+1 + exit + endif + enddo + kb_adj=max(2,kb_adj) + do k=kts,kb_adj-1 + zu(k)=0. + enddo + maxlim=1.5 + a=maxval(zu)-zu(kb_adj) + do k=kts,kt + if(a.gt.maxlim)zu(k)=(zu(k)-zu(kb_adj))*maxlim/a+zu(kb_adj) +! write(33,122)k,p(k),zu(k) + enddo + + elseif(draft == 4 .or. draft == 5) then + + tunning=p(kb) + tunning =min(0.95, (tunning-p(1))/(p(kt)-p(1))) !=.6 + tunning =max(0.02, tunning) + alpha2= (tunning*(beta_dd -2.)+1.)/(1.-tunning) + do k=27,3,-1 + if(alpha(k) >= alpha2)exit + enddo + k1=k+1 + if(alpha(k1) .ne. alpha(k1-1))then + a=alpha(k1)-alpha(k1-1) + b=alpha(k1-1)*(k1) -(k1-1)*alpha(k1) + x1= (alpha2-b)/a + y1=a*x1+b + g_a=g_alpha(k1)-g_alpha(k1-1) + g_b=g_alpha(k1-1)*k1 - (k1-1)*g_alpha(k1) + g_alpha2=g_a*x1+g_b + else + g_alpha2=g_alpha(k1) + endif + + fzu = gamma(alpha2 + beta_dd)/(g_alpha2*g_beta_dd) +! fzu = gamma(alpha2 + beta_dd)/(gamma(alpha2)*gamma(beta_dd)) + zu(:)=0. + do k=2,min(kte,kt-1) + kratio= (p(k)-p(1))/(p(kt)-p(1)) !float(k)/float(kt+1) + zu(k) = fzu*kratio**(alpha2-1.0) * (1.0-kratio)**(beta_dd-1.0) + enddo + + fzu=maxval(zu(kts:min(ktf,kt-1))) + if(fzu.gt.0.) & + zu(kts:min(ktf,kt-1))= zu(kts:min(ktf,kt-1))/fzu + zu(1)=0. + do k=1,kb-2 !kb,2,-1 + zu(kb-k)=zu(kb-k+1)-zu(kb)*(p(kb-k)-p(kb-k+1))/(p(1)-p(kb)) + enddo + zu(1)=0. + endif + end subroutine get_zu_zd_pdf_fim + +!------------------------------------------------------------------------- +!> Calculates the cloud work function based on boundary layer forcing. + subroutine cup_up_aa1bl(aa0,t,tn,q,qo,dtime, & + z_cup,zu,dby,gamma_cup,t_cup, & + kbcon,ktop,ierr, & + itf,ktf, & + its,ite, kts,kte ) + + implicit none +! +! on input +! + + ! only local wrf dimensions are need as of now in this routine + + integer & + ,intent (in ) :: & + itf,ktf, & + its,ite, kts,kte + ! aa0 cloud work function + ! gamma_cup = gamma on model cloud levels + ! t_cup = temperature (kelvin) on model cloud levels + ! dby = buoancy term + ! zu= normalized updraft mass flux + ! z = heights of model levels + ! ierr error value, maybe modified in this routine + ! + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + z_cup,zu,gamma_cup,t_cup,dby,t,tn,q,qo + integer, dimension (its:ite) & + ,intent (in ) :: & + kbcon,ktop + real(kind=kind_phys), intent(in) :: dtime +! +! input and output +! + integer, dimension (its:ite) & + ,intent (inout) :: & + ierr + real(kind=kind_phys), dimension (its:ite) & + ,intent (out ) :: & + aa0 +! +! local variables in this routine +! + integer :: & + i,k + real(kind=kind_phys) :: & + dz,da +! +!$acc kernels + do i=its,itf + aa0(i)=0. + enddo + do i=its,itf +!$acc loop independent + do k=kts,kbcon(i) + if(ierr(i).ne.0 ) cycle +! if(k.gt.kbcon(i)) cycle + + dz = (z_cup (i,k+1)-z_cup (i,k))*g + da = dz*(tn(i,k)*(1.+0.608*qo(i,k))-t(i,k)*(1.+0.608*q(i,k)))/dtime +!$acc atomic + aa0(i)=aa0(i)+da + enddo + enddo +!$acc end kernels + + end subroutine cup_up_aa1bl +!---------------------------------------------------------------------- +!> Finds temperature inversions using the first and second derivative of temperature. + subroutine get_inversion_layers(ierr,p_cup,t_cup,z_cup,qo_cup,qeso_cup,k_inv_layers,& + kstart,kend,dtempdz,itf,ktf,its,ite, kts,kte) + + implicit none + integer ,intent (in ) :: itf,ktf,its,ite,kts,kte + integer, dimension (its:ite) ,intent (in ) :: ierr,kstart,kend +!$acc declare copyin(ierr,kstart,kend) + integer, dimension (its:ite) :: kend_p3 +!$acc declare create(kend_p3) + + real(kind=kind_phys), dimension (its:ite,kts:kte), intent (in ) :: p_cup,t_cup,z_cup,qo_cup,qeso_cup + real(kind=kind_phys), dimension (its:ite,kts:kte), intent (out) :: dtempdz + integer, dimension (its:ite,kts:kte), intent (out) :: k_inv_layers +!$acc declare copyin(p_cup,t_cup,z_cup,qo_cup,qeso_cup) +!$acc declare copyout(dtempdz,k_inv_layers) + !-local vars + real(kind=kind_phys) :: dp,l_mid,l_shal,first_deriv(kts:kte),sec_deriv(kts:kte) + integer:: ken,kadd,kj,i,k,ilev,kk,ix,k800,k550,mid,shal + ! + !-initialize k_inv_layers as undef + l_mid=300. + l_shal=100. +!$acc kernels + k_inv_layers(:,:) = 1 +!$acc end kernels +!$acc parallel loop private(first_deriv,sec_deriv,ilev,ix,k,kadd,ken) + do i = its,itf + if(ierr(i) == 0)then + sec_deriv(:)=0. + kend_p3(i)=kend(i)+3 + do k = kts+1,kend_p3(i)+4 + !- get the 1st der + first_deriv(k)= (t_cup(i,k+1)-t_cup(i,k-1))/(z_cup(i,k+1)-z_cup(i,k-1)) + dtempdz(i,k)=first_deriv(k) + enddo + do k = kts+2,kend_p3(i)+3 + ! get the 2nd der + sec_deriv(k)= (first_deriv(k+1)-first_deriv(k-1))/(z_cup(i,k+1)-z_cup(i,k-1)) + sec_deriv(k)= abs(sec_deriv(k)) + enddo + + ilev=max(kts+3,kstart(i)+1) + ix=1 + k=ilev + do while (ilev < kend_p3(i)) !(z_cup(i,ilev)<15000.) +!$acc loop seq + do kk=k,kend_p3(i)+2 !k,ktf-2 + + if(sec_deriv(kk) < sec_deriv(kk+1) .and. & + sec_deriv(kk) < sec_deriv(kk-1) ) then + k_inv_layers(i,ix)=kk + ix=min(5,ix+1) + ilev=kk+1 + exit + endif + ilev=kk+1 + enddo + k=ilev + enddo + !- 2nd criteria + kadd=0 + ken=maxloc(k_inv_layers(i,:),1) +!$acc loop seq + do k=1,ken + kk=k_inv_layers(i,k+kadd) + if(kk.eq.1)exit + + if( dtempdz(i,kk) < dtempdz(i,kk-1) .and. & + dtempdz(i,kk) < dtempdz(i,kk+1) ) then ! the layer is not a local maximum + kadd=kadd+1 + do kj = k,ken + if(k_inv_layers(i,kj+kadd).gt.1)k_inv_layers(i,kj) = k_inv_layers(i,kj+kadd) + if(k_inv_layers(i,kj+kadd).eq.1)k_inv_layers(i,kj) = 1 + enddo + endif + enddo + endif + enddo +!$acc end parallel +100 format(1x,16i3) + !- find the locations of inversions around 800 and 550 hpa +!$acc parallel loop private(sec_deriv,shal,mid) + do i = its,itf + if(ierr(i) /= 0) cycle + + !- now find the closest layers of 800 and 550 hpa. + sec_deriv(:)=1.e9 + do k=1,maxloc(k_inv_layers(i,:),1) !kts,kte !kstart(i),kend(i) !kts,kte + dp=p_cup(i,k_inv_layers(i,k))-p_cup(i,kstart(i)) + sec_deriv(k)=abs(dp)-l_shal + enddo + k800=minloc(abs(sec_deriv),1) + sec_deriv(:)=1.e9 + + do k=1,maxloc(k_inv_layers(i,:),1) !kts,kte !kstart(i),kend(i) !kts,kte + dp=p_cup(i,k_inv_layers(i,k))-p_cup(i,kstart(i)) + sec_deriv(k)=abs(dp)-l_mid + enddo + k550=minloc(abs(sec_deriv),1) + !-save k800 and k550 in k_inv_layers array + shal=1 + mid=2 + k_inv_layers(i,shal)=k_inv_layers(i,k800) ! this is for shallow convection + k_inv_layers(i,mid )=k_inv_layers(i,k550) ! this is for mid/congestus convection + k_inv_layers(i,mid+1:kte)=-1 + enddo +!$acc end parallel + + end subroutine get_inversion_layers +!----------------------------------------------------------------------------------- +! DH* 20220604 - this isn't used at all +!!!!>\ingroup cu_unified_deep_group +!!!!> This function calcualtes +!!! function deriv3(xx, xi, yi, ni, m) +!!!!$acc routine vector +!!! !============================================================================*/ +!!! ! evaluate first- or second-order derivatives +!!! ! using three-point lagrange interpolation +!!! ! written by: alex godunov (october 2009) +!!! ! input ... +!!! ! xx - the abscissa at which the interpolation is to be evaluated +!!! ! xi() - the arrays of data abscissas +!!! ! yi() - the arrays of data ordinates +!!! ! ni - size of the arrays xi() and yi() +!!! ! m - order of a derivative (1 or 2) +!!! ! output ... +!!! ! deriv3 - interpolated value +!!! !============================================================================*/ +!!! +!!! implicit none +!!! integer, parameter :: n=3 +!!! integer ni, m,i, j, k, ix +!!! real(kind=kind_phys):: deriv3, xx +!!! real(kind=kind_phys):: xi(ni), yi(ni), x(n), f(n) +!!! +!!! ! exit if too high-order derivative was needed, +!!! if (m > 2) then +!!! deriv3 = 0.0 +!!! return +!!! end if +!!! +!!! ! if x is ouside the xi(1)-xi(ni) interval set deriv3=0.0 +!!! if (xx < xi(1) .or. xx > xi(ni)) then +!!! deriv3 = 0.0 +!!!#ifndef _OPENACC +!!! stop "problems with finding the 2nd derivative" +!!!#else +!!! return +!!!#endif +!!! end if +!!! +!!! ! a binary (bisectional) search to find i so that xi(i-1) < x < xi(i) +!!! i = 1 +!!! j = ni +!!! do while (j > i+1) +!!! k = (i+j)/2 +!!! if (xx < xi(k)) then +!!! j = k +!!! else +!!! i = k +!!! end if +!!! end do +!!! +!!! ! shift i that will correspond to n-th order of interpolation +!!! ! the search point will be in the middle in x_i, x_i+1, x_i+2 ... +!!! i = i + 1 - n/2 +!!! +!!! ! check boundaries: if i is ouside of the range [1, ... n] -> shift i +!!! if (i < 1) i=1 +!!! if (i + n > ni) i=ni-n+1 +!!! +!!! ! old output to test i +!!! ! write(*,100) xx, i +!!! ! 100 format (f10.5, i5) +!!! +!!! ! just wanted to use index i +!!! ix = i +!!! ! initialization of f(n) and x(n) +!!! do i=1,n +!!! f(i) = yi(ix+i-1) +!!! x(i) = xi(ix+i-1) +!!! end do +!!! +!!! ! calculate the first-order derivative using lagrange interpolation +!!! if (m == 1) then +!!! deriv3 = (2.0*xx - (x(2)+x(3)))*f(1)/((x(1)-x(2))*(x(1)-x(3))) +!!! deriv3 = deriv3 + (2.0*xx - (x(1)+x(3)))*f(2)/((x(2)-x(1))*(x(2)-x(3))) +!!! deriv3 = deriv3 + (2.0*xx - (x(1)+x(2)))*f(3)/((x(3)-x(1))*(x(3)-x(2))) +!!! ! calculate the second-order derivative using lagrange interpolation +!!! else +!!! deriv3 = 2.0*f(1)/((x(1)-x(2))*(x(1)-x(3))) +!!! deriv3 = deriv3 + 2.0*f(2)/((x(2)-x(1))*(x(2)-x(3))) +!!! deriv3 = deriv3 + 2.0*f(3)/((x(3)-x(1))*(x(3)-x(2))) +!!! end if +!!! end function deriv3 +! *DH 20220604 +!============================================================================================= +!> Calculates mass entranment and detrainment rates. + subroutine get_lateral_massflux(itf,ktf, its,ite, kts,kte & + ,ierr,ktop,zo_cup,zuo,cd,entr_rate_2d & + ,up_massentro, up_massdetro ,up_massentr, up_massdetr & + ,draft,kbcon,k22,up_massentru,up_massdetru,lambau) + + implicit none + integer, intent (in) :: draft + integer, intent(in):: itf,ktf, its,ite, kts,kte + integer, intent(in) , dimension(its:ite) :: ierr,ktop,kbcon,k22 +!$acc declare copyin(ierr,ktop,kbcon,k22) + !real(kind=kind_phys), intent(in), optional , dimension(its:ite):: lambau + real(kind=kind_phys), intent(inout), optional , dimension(its:ite):: lambau + real(kind=kind_phys), intent(in) , dimension(its:ite,kts:kte) :: zo_cup,zuo + real(kind=kind_phys), intent(inout), dimension(its:ite,kts:kte) :: cd,entr_rate_2d + real(kind=kind_phys), intent( out), dimension(its:ite,kts:kte) :: up_massentro, up_massdetro & + ,up_massentr, up_massdetr + real(kind=kind_phys), intent( out), dimension(its:ite,kts:kte), optional :: & + up_massentru,up_massdetru +!$acc declare copy(lambau,cd,entr_rate_2d) copyin(zo_cup,zuo) copyout(up_massentro, up_massdetro,up_massentr, up_massdetr) +!$acc declare copyout(up_massentro, up_massdetro,up_massentr, up_massdetr, up_massentru,up_massdetru) + !-- local vars + integer :: i,k, incr1,incr2,turn + real(kind=kind_phys) :: dz,trash,trash2 + +!$acc kernels + do k=kts,kte + do i=its,ite + up_massentro(i,k)=0. + up_massdetro(i,k)=0. + up_massentr (i,k)=0. + up_massdetr (i,k)=0. + enddo + enddo +!$acc end kernels + if(present(up_massentru) .and. present(up_massdetru))then +!$acc kernels + do k=kts,kte + do i=its,ite + up_massentru(i,k)=0. + up_massdetru(i,k)=0. + enddo + enddo +!$acc end kernels + endif +!$acc parallel loop + do i=its,itf + if(ierr(i).eq.0)then + +!$acc loop private(dz) + do k=max(2,k22(i)+1),maxloc(zuo(i,:),1) + !=> below maximum value zu -> change entrainment + dz=zo_cup(i,k)-zo_cup(i,k-1) + + up_massdetro(i,k-1)=cd(i,k-1)*dz*zuo(i,k-1) + up_massentro(i,k-1)=zuo(i,k)-zuo(i,k-1)+up_massdetro(i,k-1) + if(up_massentro(i,k-1).lt.0.)then + up_massentro(i,k-1)=0. + up_massdetro(i,k-1)=zuo(i,k-1)-zuo(i,k) + if(zuo(i,k-1).gt.0.)cd(i,k-1)=up_massdetro(i,k-1)/(dz*zuo(i,k-1)) + endif + if(zuo(i,k-1).gt.0.)entr_rate_2d(i,k-1)=(up_massentro(i,k-1))/(dz*zuo(i,k-1)) + enddo +!$acc loop private(dz) + do k=maxloc(zuo(i,:),1)+1,ktop(i) + !=> above maximum value zu -> change detrainment + dz=zo_cup(i,k)-zo_cup(i,k-1) + up_massentro(i,k-1)=entr_rate_2d(i,k-1)*dz*zuo(i,k-1) + up_massdetro(i,k-1)=zuo(i,k-1)+up_massentro(i,k-1)-zuo(i,k) + if(up_massdetro(i,k-1).lt.0.)then + up_massdetro(i,k-1)=0. + up_massentro(i,k-1)=zuo(i,k)-zuo(i,k-1) + if(zuo(i,k-1).gt.0.)entr_rate_2d(i,k-1)=(up_massentro(i,k-1))/(dz*zuo(i,k-1)) + endif + + if(zuo(i,k-1).gt.0.)cd(i,k-1)=up_massdetro(i,k-1)/(dz*zuo(i,k-1)) + enddo + up_massdetro(i,ktop(i))=zuo(i,ktop(i)) + up_massentro(i,ktop(i))=0. + do k=ktop(i)+1,ktf + cd(i,k)=0. + entr_rate_2d(i,k)=0. + up_massentro(i,k)=0. + up_massdetro(i,k)=0. + enddo + do k=2,ktf-1 + up_massentr (i,k-1)=up_massentro(i,k-1) + up_massdetr (i,k-1)=up_massdetro(i,k-1) + enddo +! Dan: draft +! deep = 1 +! shallow = 2 +! mid = 3 + if(present(up_massentru) .and. present(up_massdetru) .and. draft == 1)then + !turn=maxloc(zuo(i,:),1) + !do k=2,turn + ! up_massentru(i,k-1)=up_massentro(i,k-1)+.1*lambau(i)*up_massentro(i,k-1) + ! up_massdetru(i,k-1)=up_massdetro(i,k-1)+.1*lambau(i)*up_massentro(i,k-1) + !enddo + !do k=turn+1,ktf-1 + do k=2,ktf-1 + up_massentru(i,k-1)=up_massentro(i,k-1)+lambau(i)*up_massdetro(i,k-1) + up_massdetru(i,k-1)=up_massdetro(i,k-1)+lambau(i)*up_massdetro(i,k-1) + enddo + else if(present(up_massentru) .and. present(up_massdetru) .and. draft == 2)then + do k=2,ktf-1 + up_massentru(i,k-1)=up_massentro(i,k-1)+lambau(i)*up_massdetro(i,k-1) + up_massdetru(i,k-1)=up_massdetro(i,k-1)+lambau(i)*up_massdetro(i,k-1) + enddo + else if(present(up_massentru) .and. present(up_massdetru) .and. draft == 3)then + lambau(i)=0. + do k=2,ktf-1 + up_massentru(i,k-1)=up_massentro(i,k-1)+lambau(i)*up_massdetro(i,k-1) + up_massdetru(i,k-1)=up_massdetro(i,k-1)+lambau(i)*up_massdetro(i,k-1) + enddo + endif + + trash=0. + trash2=0. + do k=k22(i)+1,ktop(i) + trash2=trash2+entr_rate_2d(i,k) + enddo + do k=k22(i)+1,kbcon(i) + trash=trash+entr_rate_2d(i,k) + enddo + + endif + enddo +!$acc end parallel + end subroutine get_lateral_massflux +!---meltglac------------------------------------------------- +!------------------------------------------------------------------------------------ +!> Calculates the partition between cloud water and cloud ice. + subroutine get_partition_liq_ice(ierr,tn,po_cup, p_liq_ice,melting_layer & + ,itf,ktf,its,ite, kts,kte, cumulus ) + implicit none + character *(*), intent (in) :: cumulus + integer ,intent (in ) :: itf,ktf, its,ite, kts,kte + real(kind=kind_phys), intent (in ), dimension(its:ite,kts:kte) :: tn,po_cup + real(kind=kind_phys), intent (inout), dimension(its:ite,kts:kte) :: p_liq_ice,melting_layer +!$acc declare copyin(tn,po_cup) copy(p_liq_ice,melting_layer) + integer , intent (in ), dimension(its:ite) :: ierr +!$acc declare copyin(ierr) + integer :: i,k + real(kind=kind_phys) :: dp + real(kind=kind_phys), dimension(its:ite) :: norm +!$acc declare create(norm) + real(kind=kind_phys), parameter :: t1=276.16 + + ! hli initialize at the very beginning +!$acc kernels + p_liq_ice (:,:) = 1. + melting_layer(:,:) = 0. +!$acc end kernels + !-- get function of t for partition of total condensate into liq and ice phases. + if(melt_glac .and. cumulus == 'deep') then +!$acc kernels + do i=its,itf + if(ierr(i).eq.0)then + do k=kts,ktf + + if (tn(i,k) <= t_ice) then + + p_liq_ice(i,k) = 0. + elseif( tn(i,k) > t_ice .and. tn(i,k) < t_0) then + + p_liq_ice(i,k) = ((tn(i,k)-t_ice)/(t_0-t_ice))**2 + else + p_liq_ice(i,k) = 1. + endif + + !melting_layer(i,k) = p_liq_ice(i,k) * (1.-p_liq_ice(i,k)) + enddo + endif + enddo + !go to 655 + !-- define the melting layer (the layer will be between t_0+1 < temp < t_1 + do i=its,itf + if(ierr(i).eq.0)then + do k=kts,ktf + if (tn(i,k) <= t_0+1) then + melting_layer(i,k) = 0. + + elseif( tn(i,k) > t_0+1 .and. tn(i,k) < t1) then + melting_layer(i,k) = ((tn(i,k)-t_0+1)/(t1-t_0+1))**2 + + else + melting_layer(i,k) = 1. + endif + melting_layer(i,k) = melting_layer(i,k)*(1-melting_layer(i,k)) + enddo + endif + enddo + 655 continue + !-normalize vertical integral of melting_layer to 1 + norm(:)=0. + !do k=kts,ktf + do i=its,itf + if(ierr(i).eq.0)then +!$acc loop independent + do k=kts,ktf-1 + dp = 100.*(po_cup(i,k)-po_cup(i,k+1)) +!$acc atomic update + norm(i) = norm(i) + melting_layer(i,k)*dp/g + enddo + endif + enddo + do i=its,itf + if(ierr(i).eq.0)then + !print*,"i1=",i,maxval(melting_layer(i,:)),minval(melting_layer(i,:)),norm(i) + melting_layer(i,:)=melting_layer(i,:)/(norm(i)+1.e-6)*(100*(po_cup(i,kts)-po_cup(i,ktf))/g) + endif + !print*,"i2=",i,maxval(melting_layer(i,:)),minval(melting_layer(i,:)),norm(i) + enddo + !--check +! norm(:)=0. +! do k=kts,ktf-1 +! do i=its,itf +! dp = 100.*(po_cup(i,k)-po_cup(i,k+1)) +! norm(i) = norm(i) + melting_layer(i,k)*dp/g/(100*(po_cup(i,kts)-po_cup(i,ktf))/g) +! !print*,"n=",i,k,norm(i) +! enddo +! enddo +!$acc end kernels + else +!$acc kernels + p_liq_ice (:,:) = 1. + melting_layer(:,:) = 0. +!$acc end kernels + endif + end subroutine get_partition_liq_ice + +!------------------------------------------------------------------------------------ +!> Calculates the melting profile. + subroutine get_melting_profile(ierr,tn_cup,po_cup, p_liq_ice,melting_layer,qrco & + ,pwo,edto,pwdo,melting & + ,itf,ktf,its,ite, kts,kte, cumulus ) + implicit none + character *(*), intent (in) :: cumulus + integer ,intent (in ) :: itf,ktf, its,ite, kts,kte + integer ,intent (in ), dimension(its:ite) :: ierr + real(kind=kind_phys) ,intent (in ), dimension(its:ite) :: edto + real(kind=kind_phys) ,intent (in ), dimension(its:ite,kts:kte) :: tn_cup,po_cup,qrco,pwo & + ,pwdo,p_liq_ice,melting_layer + real(kind=kind_phys) ,intent (inout), dimension(its:ite,kts:kte) :: melting +!$acc declare copyin(ierr,edto,tn_cup,po_cup,qrco,pwo,pwdo,p_liq_ice,melting_layer,melting) + integer :: i,k + real(kind=kind_phys) :: dp + real(kind=kind_phys), dimension(its:ite) :: norm,total_pwo_solid_phase + real(kind=kind_phys), dimension(its:ite,kts:kte) :: pwo_solid_phase,pwo_eff +!$acc declare create(norm,total_pwo_solid_phase,pwo_solid_phase,pwo_eff) + + if(melt_glac .and. cumulus == 'deep') then +!$acc kernels + !-- set melting mixing ratio to zero for columns that do not have deep convection + do i=its,itf + if(ierr(i) > 0) melting(i,:) = 0. + enddo + + !-- now, get it for columns where deep convection is activated + total_pwo_solid_phase(:)=0. + + !do k=kts,ktf + do k=kts,ktf-1 + do i=its,itf + if(ierr(i) /= 0) cycle + dp = 100.*(po_cup(i,k)-po_cup(i,k+1)) + + !-- effective precip (after evaporation by downdraft) + pwo_eff(i,k) = 0.5*(pwo(i,k)+pwo(i,k+1) + edto(i)*(pwdo(i,k)+pwdo(i,k+1))) + + !-- precipitation at solid phase(ice/snow) + pwo_solid_phase(i,k) = (1.-p_liq_ice(i,k))*pwo_eff(i,k) + + !-- integrated precip at solid phase(ice/snow) + total_pwo_solid_phase(i) = total_pwo_solid_phase(i)+pwo_solid_phase(i,k)*dp/g + enddo + enddo + + do k=kts,ktf + do i=its,itf + if(ierr(i) /= 0) cycle + !-- melting profile (kg/kg) + melting(i,k) = melting_layer(i,k)*(total_pwo_solid_phase(i)/(100*(po_cup(i,kts)-po_cup(i,ktf))/g)) + !print*,"mel=",k,melting(i,k),pwo_solid_phase(i,k),po_cup(i,k) + enddo + enddo + +!-- check conservation of total solid phase precip +! norm(:)=0. +! do k=kts,ktf-1 +! do i=its,itf +! dp = 100.*(po_cup(i,k)-po_cup(i,k+1)) +! norm(i) = norm(i) + melting(i,k)*dp/g +! enddo +! enddo +! +! do i=its,itf +! print*,"cons=",i,norm(i),total_pwo_solid_phase(i) +! enddo +!-- +!$acc end kernels + else +!$acc kernels + !-- no melting allowed in this run + melting (:,:) = 0. +!$acc end kernels + endif + end subroutine get_melting_profile +!---meltglac------------------------------------------------- +!-----srf-08aug2017-----begin +!> Calculates the cloud top height. + subroutine get_cloud_top(name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo,heso_cup,z_cup, & + kstabi,k22,kbcon,its,ite,itf,kts,kte,ktf,zuo,kpbl,klcl,hcot) + implicit none + integer, intent(in) :: its,ite,itf,kts,kte,ktf + real(kind=kind_phys), dimension (its:ite,kts:kte),intent (inout) :: entr_rate_2d,zuo + real(kind=kind_phys), dimension (its:ite,kts:kte),intent (in) ::p_cup, heo,heso_cup,z_cup + real(kind=kind_phys), dimension (its:ite),intent (in) :: hkbo + integer, dimension (its:ite),intent (in) :: kstabi,k22,kbcon,kpbl,klcl + integer, dimension (its:ite),intent (inout) :: ierr,ktop +!$acc declare copy(entr_rate_2d,zuo,ierr,ktop) copyin(p_cup, heo,heso_cup,z_cup,hkbo,kstabi,k22,kbcon,kpbl,klcl) + real(kind=kind_phys), dimension (its:ite,kts:kte) :: hcot +!$acc declare create(hcot) + character *(*), intent (in) :: name + real(kind=kind_phys) :: dz,dh, dbythresh + real(kind=kind_phys) :: dby(kts:kte) + integer :: i,k,ipr,kdefi,kstart,kbegzu,kfinalzu + integer, dimension (its:ite) :: start_level +!$acc declare create(start_level) + integer,parameter :: find_ktop_option = 1 !0=original, 1=new + + dbythresh=0.8 !0.95 ! the range of this parameter is 0-1, higher => lower + ! overshoting (cheque aa0 calculation) + ! rainfall is too sensible this parameter + ! for now, keep =1. + if(name == 'shallow'.or. name == 'mid')then + dbythresh=1.0 + endif + ! print*,"================================cumulus=",name; call flush(6) +!$acc parallel loop private(dby,kfinalzu,dz) + do i=its,itf + kfinalzu=ktf-2 + ktop(i)=kfinalzu + if(ierr(i).eq.0)then + dby (kts:kte)=0.0 + + start_level(i)=kbcon(i) + !-- hcot below kbcon + hcot(i,kts:start_level(i))=hkbo(i) + + dz=z_cup(i,start_level(i))-z_cup(i,start_level(i)-1) + dby(start_level(i))=(hcot(i,start_level(i))-heso_cup(i,start_level(i)))*dz + + !print*,'hco1=',start_level(i),kbcon(i),hcot(i,start_level(i))/heso_cup(i,start_level(i)) +!$acc loop seq + do k=start_level(i)+1,ktf-2 + dz=z_cup(i,k)-z_cup(i,k-1) + + hcot(i,k)=( (1.-0.5*entr_rate_2d(i,k-1)*dz)*hcot(i,k-1) & + +entr_rate_2d(i,k-1)*dz *heo (i,k-1) )/ & + (1.+0.5*entr_rate_2d(i,k-1)*dz) + dby(k)=dby(k-1)+(hcot(i,k)-heso_cup(i,k))*dz + !print*,'hco2=',k,hcot(i,k)/heso_cup(i,k),dby(k),entr_rate_2d(i,k-1) + + enddo + if(find_ktop_option==0) then + do k=maxloc(dby(:),1),ktf-2 + !~ print*,'hco30=',k,dby(k),dbythresh*maxval(dby) + + if(dby(k).lt.dbythresh*maxval(dby))then + kfinalzu = k - 1 + ktop(i) = kfinalzu + !print*,'hco4=',k,kfinalzu,ktop(i),kbcon(i)+1;call flush(6) + go to 412 + endif + enddo + 412 continue + else + do k=start_level(i)+1,ktf-2 + !~ print*,'hco31=',k,dby(k),dbythresh*maxval(dby) + + if(hcot(i,k) < heso_cup(i,k) )then + kfinalzu = k - 1 + ktop(i) = kfinalzu + !print*,'hco40=',k,kfinalzu,ktop(i),kbcon(i)+1;call flush(6) + exit + endif + enddo + endif + if(kfinalzu.le.kbcon(i)+1) ierr(i)=41 + !~ print*,'hco5=',k,kfinalzu,ktop(i),kbcon(i)+1,ierr(i);call flush(6) + ! + endif + enddo +!$acc end parallel + end subroutine get_cloud_top +!------------------------------------------------------------------------------------ +!> @} +end module cu_unified_deep diff --git a/physics/cu_unified_driver.F90 b/physics/cu_unified_driver.F90 new file mode 100644 index 000000000..5ce640d5c --- /dev/null +++ b/physics/cu_unified_driver.F90 @@ -0,0 +1,1160 @@ +!>\file cu_unified_driver.F90 +!! This file is the unified cumulus scheme driver. + + +module cu_unified_driver + + ! DH* TODO: replace constants with arguments to cu_unified_driver_run + !use physcons , g => con_g, cp => con_cp, xlv => con_hvap, r_v => con_rv + use machine , only: kind_phys + use cu_unified_deep, only: cu_unified_deep_run,neg_check,fct1d3 + use cu_unified_sh , only: cu_unified_sh_run + + implicit none + + private + + public :: cu_unified_driver_init, cu_unified_driver_run + +contains + +!> \defgroup cu_unified_group Grell-Freitas Convection Module +!! This is the Grell-Freitas scale and aerosol aware scheme. +!>@{ +!>\defgroup cu_unified_driver Grell-Freitas Convection Driver Module +!> \ingroup cu_unified_group +!> This is Grell-Freitas cumulus scheme driver module. +!! +!! \section arg_table_cu_unified_driver_init Argument Table +!! \htmlinclude cu_unified_driver_init.html +!! + subroutine cu_unified_driver_init(imfshalcnv, imfshalcnv_unified, imfdeepcnv, & + imfdeepcnv_unified,mpirank, mpiroot, errmsg, errflg) + + implicit none + + integer, intent(in) :: imfshalcnv, imfshalcnv_unified + integer, intent(in) :: imfdeepcnv, imfdeepcnv_unified + integer, intent(in) :: mpirank + integer, intent(in) :: mpiroot + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + + ! initialize ccpp error handling variables + errmsg = '' + errflg = 0 + + end subroutine cu_unified_driver_init + +! +! t2di is temp after advection, but before physics +! t = current temp (t2di + physics up to now) +!=================== + +!> This is the Grell-Freitas convection scheme driver module. +!! \section arg_table_cu_unified_driver_run Argument Table +!! \htmlinclude cu_unified_driver_run.html +!! +!>\section gen_unified_driver Grell-Freitas Cumulus Scheme Driver General Algorithm + subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& + cactiv,cactiv_m,g,cp,xlv,r_v,forcet,forceqv_spechum,phil,raincv, & + qv_spechum,t,cld1d,us,vs,t2di,w,qv2di_spechum,p2di,psuri, & + hbot,htop,kcnv,xland,hfx2,qfx2,aod_gf,cliw,clcw, & + pbl,ud_mf,dd_mf,dt_mf,cnvw_moist,cnvc,imfshalcnv, & + flag_for_scnv_generic_tend,flag_for_dcnv_generic_tend, & + dtend,dtidx,ntqv,ntiw,ntcw,index_of_temperature,index_of_x_wind, & + index_of_y_wind,index_of_process_scnv,index_of_process_dcnv, & + fhour,fh_dfi_radar,ix_dfi_radar,num_dfi_radar,cap_suppress, & + dfi_radar_max_intervals,ldiag3d,qci_conv,do_cap_suppress, & + errmsg,errflg) +!------------------------------------------------------------- + implicit none + integer, parameter :: maxiens=1 + integer, parameter :: maxens=1 + integer, parameter :: maxens2=1 + integer, parameter :: maxens3=16 + integer, parameter :: ensdim=16 + integer, parameter :: imid_gf=1 ! testgf2 turn on middle gf conv. + integer, parameter :: ideep=1 + integer, parameter :: ichoice=0 ! 0 2 5 13 8 + !integer, parameter :: ichoicem=5 ! 0 2 5 13 + integer, parameter :: ichoicem=13 ! 0 2 5 13 + integer, parameter :: ichoice_s=3 ! 0 1 2 3 + + logical, intent(in) :: do_cap_suppress + real(kind=kind_phys), parameter :: aodc0=0.14 + real(kind=kind_phys), parameter :: aodreturn=30. + real(kind=kind_phys) :: dts,fpi,fp + integer, parameter :: dicycle=0 ! diurnal cycle flag + integer, parameter :: dicycle_m=0 !- diurnal cycle flag + integer :: ishallow_g3 ! depend on imfshalcnv +!------------------------------------------------------------- + integer :: its,ite, jts,jte, kts,kte + integer, intent(in ) :: im,km,ntracer + logical, intent(in ) :: flag_init, flag_restart + logical, intent(in ) :: flag_for_scnv_generic_tend,flag_for_dcnv_generic_tend + real (kind=kind_phys), intent(in) :: g,cp,xlv,r_v + logical, intent(in ) :: ldiag3d + + real(kind=kind_phys), intent(inout) :: dtend(:,:,:) +!$acc declare copy(dtend) + integer, intent(in) :: dtidx(:,:), & + index_of_x_wind, index_of_y_wind, index_of_temperature, & + index_of_process_scnv, index_of_process_dcnv, ntqv, ntcw, ntiw +!$acc declare copyin(dtidx) + real(kind=kind_phys), dimension( : , : ), intent(in ) :: forcet,forceqv_spechum,w,phil + real(kind=kind_phys), dimension( : , : ), intent(inout ) :: t,us,vs + real(kind=kind_phys), dimension( : , : ), intent(inout ) :: qci_conv + real(kind=kind_phys), dimension( : , : ), intent(out ) :: cnvw_moist,cnvc + real(kind=kind_phys), dimension( : , : ), intent(inout ) :: cliw, clcw +!$acc declare copyin(forcet,forceqv_spechum,w,phil) +!$acc declare copy(t,us,vs,qci_conv,cliw, clcw) +!$acc declare copyout(cnvw_moist,cnvc) + + real(kind=kind_phys), allocatable :: clcw_save(:,:), cliw_save(:,:) + + integer, intent(in) :: dfi_radar_max_intervals + real(kind=kind_phys), intent(in) :: fhour, fh_dfi_radar(:) + integer, intent(in) :: num_dfi_radar, ix_dfi_radar(:) + real(kind=kind_phys), intent(in) :: cap_suppress(:,:) +!$acc declare copyin(fh_dfi_radar,ix_dfi_radar,cap_suppress) + + integer, dimension (:), intent(out) :: hbot,htop,kcnv + integer, dimension (:), intent(in) :: xland + real(kind=kind_phys), dimension (:), intent(in) :: pbl +!$acc declare copyout(hbot,htop,kcnv) +!$acc declare copyin(xland,pbl) + integer, dimension (im) :: tropics +!$acc declare create(tropics) +! ruc variable + real(kind=kind_phys), dimension (:), intent(in) :: hfx2,qfx2,psuri + real(kind=kind_phys), dimension (:,:), intent(out) :: ud_mf,dd_mf,dt_mf + real(kind=kind_phys), dimension (:), intent(out) :: raincv,cld1d + real(kind=kind_phys), dimension (:,:), intent(in) :: t2di,p2di +!$acc declare copyin(hfx2,qfx2,psuri,t2di,p2di) +!$acc declare copyout(ud_mf,dd_mf,dt_mf,raincv,cld1d) + ! Specific humidity from FV3 + real(kind=kind_phys), dimension (:,:), intent(in) :: qv2di_spechum + real(kind=kind_phys), dimension (:,:), intent(inout) :: qv_spechum + real(kind=kind_phys), dimension (:), intent(inout) :: aod_gf +!$acc declare copyin(qv2di_spechum) copy(qv_spechum,aod_gf) + ! Local water vapor mixing ratios and cloud water mixing ratios + real(kind=kind_phys), dimension (im,km) :: qv2di, qv, forceqv, cnvw +!$acc declare create(qv2di, qv, forceqv, cnvw) + ! + real(kind=kind_phys), dimension(:),intent(in) :: garea +!$acc declare copyin(garea) + real(kind=kind_phys), intent(in ) :: dt + + integer, intent(in ) :: imfshalcnv + integer, dimension(:), intent(inout) :: cactiv,cactiv_m +!$acc declare copy(cactiv,cactiv_m) + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +! local variables + integer, dimension(im) :: k22_shallow,kbcon_shallow,ktop_shallow + real(kind=kind_phys), dimension (im) :: rand_mom,rand_vmas + real(kind=kind_phys), dimension (im,4) :: rand_clos + real(kind=kind_phys), dimension (im,km,11) :: gdc,gdc2 + real(kind=kind_phys), dimension (im) :: ht + real(kind=kind_phys), dimension (im) :: ccn_gf,ccn_m + real(kind=kind_phys) :: ccnclean + real(kind=kind_phys), dimension (im) :: dx + real(kind=kind_phys), dimension (im) :: frhm,frhd + real(kind=kind_phys), dimension (im,km) :: outt,outq,outqc,phh,subm,cupclw,cupclws + real(kind=kind_phys), dimension (im,km) :: dhdt,zu,zus,zd,phf,zum,zdm,outum,outvm + real(kind=kind_phys), dimension (im,km) :: outts,outqs,outqcs,outu,outv,outus,outvs + real(kind=kind_phys), dimension (im,km) :: outtm,outqm,outqcm,submm,cupclwm + real(kind=kind_phys), dimension (im,km) :: cnvwt,cnvwts,cnvwtm + real(kind=kind_phys), dimension (im,km) :: hco,hcdo,zdo,zdd,hcom,hcdom,zdom + real(kind=kind_phys), dimension (km) :: zh + real(kind=kind_phys), dimension (im) :: tau_ecmwf,edt,edtm,edtd,ter11,aa0,xlandi + real(kind=kind_phys), dimension (im) :: pret,prets,pretm,hexec + real(kind=kind_phys), dimension (im,10) :: forcing,forcing2 + + integer, dimension (im) :: kbcon, ktop,ierr,ierrs,ierrm,kpbli + integer, dimension (im) :: k22s,kbcons,ktops,k22,jmin,jminm + integer, dimension (im) :: kbconm,ktopm,k22m +!$acc declare create(k22_shallow,kbcon_shallow,ktop_shallow,rand_mom,rand_vmas, & +!$acc rand_clos,gdc,gdc2,ht,ccn_gf,ccn_m,dx,frhm,frhd, & +!$acc outt,outq,outqc,phh,subm,cupclw,cupclws, & +!$acc dhdt,zu,zus,zd,phf,zum,zdm,outum,outvm, & +!$acc outts,outqs,outqcs,outu,outv,outus,outvs, & +!$acc outtm,outqm,outqcm,submm,cupclwm, & +!$acc cnvwt,cnvwts,cnvwtm,hco,hcdo,zdo,zdd,hcom,hcdom,zdom, & +!$acc tau_ecmwf,edt,edtm,edtd,ter11,aa0,xlandi, & +!$acc pret,prets,pretm,hexec,forcing,forcing2, & +!$acc kbcon, ktop,ierr,ierrs,ierrm,kpbli, & +!$acc k22s,kbcons,ktops,k22,jmin,jminm,kbconm,ktopm,k22m) + + integer :: iens,ibeg,iend,jbeg,jend,n + integer :: ibegh,iendh,jbegh,jendh + integer :: ibegc,iendc,jbegc,jendc,kstop + real(kind=kind_phys), dimension(im,km) :: rho_dryar +!$acc declare create(rho_dryar) + real(kind=kind_phys) :: pten,pqen,paph,zrho,pahfs,pqhfl,zkhvfl,pgeoh + integer, parameter :: ipn = 0 + +! +! basic environmental input includes moisture convergence (mconv) +! omega (omeg), windspeed (us,vs), and a flag (ierr) to turn off +! convection for this call only and at that particular gridpoint +! + real(kind=kind_phys), dimension (im,km) :: qcheck,zo,t2d,q2d,po,p2d,rhoi,clw_ten + real(kind=kind_phys), dimension (im,km) :: tn,qo,tshall,qshall,dz8w,omeg + real(kind=kind_phys), dimension (im) :: z1,psur,cuten,cutens,cutenm + real(kind=kind_phys), dimension (im) :: umean,vmean,pmean + real(kind=kind_phys), dimension (im) :: xmbs,xmbs2,xmb,xmbm,xmb_dumm,mconv +!$acc declare create(qcheck,zo,t2d,q2d,po,p2d,rhoi,clw_ten,tn,qo,tshall,qshall,dz8w,omeg, & +!$acc z1,psur,cuten,cutens,cutenm,umean,vmean,pmean, & +!$acc xmbs,xmbs2,xmb,xmbm,xmb_dumm,mconv) + + integer :: i,j,k,icldck,ipr,jpr,jpr_deep,ipr_deep,uidx,vidx,tidx,qidx + integer :: itf,jtf,ktf,iss,jss,nbegin,nend,cliw_idx,clcw_idx + integer :: high_resolution + real(kind=kind_phys) :: clwtot,clwtot1,excess,tcrit,tscl_kf,dp,dq,sub_spread,subcenter + real(kind=kind_phys) :: dsubclw,dsubclws,dsubclwm,dtime_max,ztm,ztq,hfm,qfm,rkbcon,rktop + real(kind=kind_phys), dimension(km) :: massflx,trcflx_in1,clw_in1,po_cup +! real(kind=kind_phys), dimension(km) :: trcflx_in2,clw_in2,clw_ten2 + real(kind=kind_phys), dimension (im) :: flux_tun,tun_rad_mid,tun_rad_shall,tun_rad_deep +!$acc declare create(flux_tun,tun_rad_mid,tun_rad_shall,tun_rad_deep) + character*50 :: ierrc(im),ierrcm(im) + character*50 :: ierrcs(im) +! ruc variable +! hfx2 -- sensible heat flux (k m/s), positive upward from sfc +! qfx2 -- latent heat flux (kg/kg m/s), positive upward from sfc +! gf needs them in w/m2. define hfx and qfx after simple unit conversion + real(kind=kind_phys), dimension (im) :: hfx,qfx +!$acc declare create(hfx,qfx) + real(kind=kind_phys) tem,tem1,tf,tcr,tcrf + real(kind=kind_phys) :: cliw_shal,clcw_shal,tem_shal, cliw_both, weight_sum + real(kind=kind_phys) :: cliw_deep,clcw_deep,tem_deep, clcw_both + integer :: cliw_deep_idx, clcw_deep_idx, cliw_shal_idx, clcw_shal_idx + + real(kind=kind_phys) :: cap_suppress_j(im) +!$acc declare create(cap_suppress_j) + integer :: itime, do_cap_suppress_here + logical :: exit_func + + !parameter (tf=243.16, tcr=270.16, tcrf=1.0/(tcr-tf)) ! FV3 original + !parameter (tf=263.16, tcr=273.16, tcrf=1.0/(tcr-tf)) + !parameter (tf=233.16, tcr=263.16, tcrf=1.0/(tcr-tf)) + parameter (tf=258.16, tcr=273.16, tcrf=1.0/(tcr-tf)) ! as fim, HCB tuning + ! initialize ccpp error handling variables + errmsg = '' + errflg = 0 + + if(do_cap_suppress) then +!$acc serial + do itime=1,num_dfi_radar + if(ix_dfi_radar(itime)<1) cycle + if(fhour=fh_dfi_radar(itime+1)) cycle + exit + enddo +!$acc end serial + endif + if(do_cap_suppress .and. itime<=num_dfi_radar) then + do_cap_suppress_here = 1 +!$acc kernels + cap_suppress_j(:) = cap_suppress(:,itime) +!$acc end kernels + else + do_cap_suppress_here = 0 +!$acc kernels + cap_suppress_j(:) = 0 +!$acc end kernels + endif + + if(ldiag3d) then + if(flag_for_dcnv_generic_tend) then + cliw_deep_idx=0 + clcw_deep_idx=0 + else + cliw_deep_idx=dtidx(100+ntiw,index_of_process_dcnv) + clcw_deep_idx=dtidx(100+ntcw,index_of_process_dcnv) + endif + if(flag_for_scnv_generic_tend) then + cliw_shal_idx=0 + clcw_shal_idx=0 + else + cliw_shal_idx=dtidx(100+ntiw,index_of_process_scnv) + clcw_shal_idx=dtidx(100+ntcw,index_of_process_scnv) + endif + if(cliw_deep_idx>=1 .or. clcw_deep_idx>=1 .or. & + cliw_shal_idx>=1 .or. clcw_shal_idx>=1) then + allocate(clcw_save(im,km), cliw_save(im,km)) +!$acc enter data create(clcw_save,cliw_save) +!$acc kernels + clcw_save(:,:)=clcw(:,:) + cliw_save(:,:)=cliw(:,:) +!$acc end kernels + endif + endif + +! +! Scale specific humidity to dry mixing ratio +! +!$acc kernels + ! state in before physics + qv2di = qv2di_spechum/(1.0_kind_phys-qv2di_spechum) + ! forcing by dynamics, based on state in + forceqv = forceqv_spechum/(1.0_kind_phys-qv2di_spechum) + ! current state (updated by preceeding physics) + qv = qv_spechum/(1.0_kind_phys-qv_spechum) +! +! +! these should be coming in from outside +! +! cactiv(:) = 0 + rand_mom(:) = 0. + rand_vmas(:) = 0. + rand_clos(:,:) = 0. +!$acc end kernels +! + its=1 + ite=im + itf=ite + jts=1 + jte=1 + jtf=jte + kts=1 + kte=km + ktf=kte-1 +!$acc kernels +! + tropics(:)=0 +! +!> - Set tuning constants for radiation coupling +! + tun_rad_shall(:)=.01 + tun_rad_mid(:)=.3 !.02 + tun_rad_deep(:)=.3 !.065 + edt(:)=0. + edtm(:)=0. + edtd(:)=0. + zdd(:,:)=0. + flux_tun(:)=5. +! 10/11/2016 dx and tscl_kf are replaced with input dx(i), is dlength. +! dx for scale awareness +! dx=40075000./float(lonf) +! tscl_kf=dx/25000. +!$acc end kernels + + if (imfshalcnv == 3) then + ishallow_g3 = 1 + else + ishallow_g3 = 0 + end if + high_resolution=0 + subcenter=0. + iens=1 +! +! these can be set for debugging +! + ipr=0 + jpr=0 + ipr_deep=0 + jpr_deep= 0 !53322 ! 528196 !0 ! 1136 !0 !421755 !3536 +! +! + ibeg=its + iend=ite + tcrit=258. + + ztm=0. + ztq=0. + hfm=0. + qfm=0. +!$acc kernels + ud_mf(:,:) =0. + dd_mf(:,:) =0. + dt_mf(:,:) =0. + tau_ecmwf(:)=0. +!$acc end kernels +! + j=1 +!$acc kernels + ht(:)=phil(:,1)/g +!$acc loop private(zh) + do i=its,ite + cld1d(i)=0. + zo(i,:)=phil(i,:)/g + dz8w(i,1)=zo(i,2)-zo(i,1) + zh(1)=0. + kpbli(i)=2 + do k=kts+1,ktf + dz8w(i,k)=zo(i,k+1)-zo(i,k) + enddo +!$acc loop seq + do k=kts+1,ktf + zh(k)=zh(k-1)+dz8w(i,k-1) + if(zh(k).gt.pbl(i))then + kpbli(i)=max(2,k) + exit + endif + enddo + enddo +!$acc end kernels + +!$acc kernels + do i= its,itf + forcing(i,:)=0. + forcing2(i,:)=0. + ccn_gf(i) = 0. + ccn_m(i) = 0. + + ! set aod and ccn + if (flag_init .and. .not.flag_restart) then + aod_gf(i)=aodc0 + else + if((cactiv(i).eq.0) .and. (cactiv_m(i).eq.0))then + if(aodc0>aod_gf(i)) aod_gf(i)=aod_gf(i)+((aodc0-aod_gf(i))*(dt/(aodreturn*60))) + if(aod_gf(i)>aodc0) aod_gf(i)=aodc0 + endif + endif + + ccn_gf(i)=max(5., (aod_gf(i)/0.0027)**(1/0.640)) + ccn_m(i)=ccn_gf(i) + + ccnclean=max(5., (aodc0/0.0027)**(1/0.640)) + + hbot(i) =kte + htop(i) =kts + raincv(i)=0. + xlandi(i)=real(xland(i)) +! if(abs(xlandi(i)-1.).le.1.e-3) tun_rad_shall(i)=.15 +! if(abs(xlandi(i)-1.).le.1.e-3) flux_tun(i)=1.5 + enddo + do i= its,itf + mconv(i)=0. + enddo + do k=kts,kte + do i= its,itf + omeg(i,k)=0. + zu(i,k)=0. + zum(i,k)=0. + zus(i,k)=0. + zd(i,k)=0. + zdm(i,k)=0. + enddo + enddo + + psur(:)=0.01*psuri(:) + do i=its,itf + ter11(i)=max(0.,ht(i)) + enddo + do k=kts,kte + do i=its,ite + cnvw(i,k)=0. + cnvc(i,k)=0. + gdc(i,k,1)=0. + gdc(i,k,2)=0. + gdc(i,k,3)=0. + gdc(i,k,4)=0. + gdc(i,k,7)=0. + gdc(i,k,8)=0. + gdc(i,k,9)=0. + gdc(i,k,10)=0. + gdc2(i,k,1)=0. + enddo + enddo + ierr(:)=0 + ierrm(:)=0 + ierrs(:)=0 + cuten(:)=0. + cutenm(:)=0. + cutens(:)=0. +!$acc end kernels + ierrc(:)=" " +!$acc kernels + + + kbcon(:)=0 + kbcons(:)=0 + kbconm(:)=0 + + ktop(:)=0 + ktops(:)=0 + ktopm(:)=0 + + xmb(:)=0. + xmb_dumm(:)=0. + xmbm(:)=0. + xmbs(:)=0. + xmbs2(:)=0. + + k22s(:)=0 + k22m(:)=0 + k22(:)=0 + + jmin(:)=0 + jminm(:)=0 + + pret(:)=0. + prets(:)=0. + pretm(:)=0. + + umean(:)=0. + vmean(:)=0. + pmean(:)=0. + + cupclw(:,:)=0. + cupclwm(:,:)=0. + cupclws(:,:)=0. + + cnvwt(:,:)=0. + cnvwts(:,:)=0. + cnvwtm(:,:)=0. + + hco(:,:)=0. + hcom(:,:)=0. + hcdo(:,:)=0. + hcdom(:,:)=0. + + outt(:,:)=0. + outts(:,:)=0. + outtm(:,:)=0. + + outu(:,:)=0. + outus(:,:)=0. + outum(:,:)=0. + + outv(:,:)=0. + outvs(:,:)=0. + outvm(:,:)=0. + + outq(:,:)=0. + outqs(:,:)=0. + outqm(:,:)=0. + + outqc(:,:)=0. + outqcs(:,:)=0. + outqcm(:,:)=0. + + subm(:,:)=0. + dhdt(:,:)=0. + + do k=kts,ktf + do i=its,itf + p2d(i,k)=0.01*p2di(i,k) + po(i,k)=p2d(i,k) !*.01 + rhoi(i,k) = 100.*p2d(i,k)/(287.04*(t2di(i,k)*(1.+0.608*qv2di(i,k)))) + qcheck(i,k)=qv(i,k) + tn(i,k)=t(i,k)!+forcet(i,k)*dt + qo(i,k)=max(1.e-16,qv(i,k))!+forceqv(i,k)*dt + t2d(i,k)=t2di(i,k)-forcet(i,k)*dt + q2d(i,k)=max(1.e-16,qv2di(i,k)-forceqv(i,k)*dt) + if(qo(i,k).lt.1.e-16)qo(i,k)=1.e-16 + tshall(i,k)=t2d(i,k) + qshall(i,k)=q2d(i,k) + enddo + enddo +!$acc end kernels +123 format(1x,i2,1x,2(1x,f8.0),1x,2(1x,f8.3),3(1x,e13.5)) +!$acc kernels + do i=its,itf + do k=kts,kpbli(i) + tshall(i,k)=t(i,k) + qshall(i,k)=max(1.e-16,qv(i,k)) + enddo + enddo +! +! converting hfx2 and qfx2 to w/m2 +! hfx=cp*rho*hfx2 +! qfx=xlv*qfx2 + do i=its,itf + hfx(i)=hfx2(i)*cp*rhoi(i,1) + qfx(i)=qfx2(i)*xlv*rhoi(i,1) + dx(i) = sqrt(garea(i)) + enddo + + do i=its,itf + do k=kts,kpbli(i) + tn(i,k)=t(i,k) + qo(i,k)=max(1.e-16,qv(i,k)) + enddo + enddo + nbegin=0 + nend=0 + do i=its,itf + do k=kts,kpbli(i) + dhdt(i,k)=cp*(forcet(i,k)+(t(i,k)-t2di(i,k))/dt) + & + xlv*(forceqv(i,k)+(qv(i,k)-qv2di(i,k))/dt) +! tshall(i,k)=t(i,k) +! qshall(i,k)=qv(i,k) + enddo + enddo +!$acc loop collapse(2) independent private(dp) + do k= kts+1,ktf-1 + do i = its,itf + if((p2d(i,1)-p2d(i,k)).gt.150.and.p2d(i,k).gt.300)then + dp=-.5*(p2d(i,k+1)-p2d(i,k-1)) +!$acc atomic + umean(i)=umean(i)+us(i,k)*dp +!$acc atomic + vmean(i)=vmean(i)+vs(i,k)*dp +!$acc atomic + pmean(i)=pmean(i)+dp + endif + enddo + enddo + do k=kts,ktf-1 + do i = its,itf + omeg(i,k)= w(i,k) !-g*rhoi(i,k)*w(i,k) +! dq=(q2d(i,k+1)-q2d(i,k)) +! mconv(i)=mconv(i)+omeg(i,k)*dq/g + enddo + enddo + do i = its,itf + if(mconv(i).lt.0.)mconv(i)=0. + enddo +!$acc end kernels +! +!---- call cumulus parameterization +! + if(ishallow_g3.eq.1)then + +!$acc kernels + do i=its,ite + ierrs(i)=0 + ierrm(i)=0 + enddo +!$acc end kernels +! +!> - Call shallow: cu_unified_sh_run() +! + call cu_unified_sh_run (us,vs, & +! input variables, must be supplied + zo,t2d,q2d,ter11,tshall,qshall,p2d,psur,dhdt,kpbli, & + rhoi,hfx,qfx,xlandi,ichoice_s,tcrit,dt, & +! input variables. ierr should be initialized to zero or larger than zero for +! turning off shallow convection for grid points + zus,xmbs,kbcons,ktops,k22s,ierrs,ierrcs, & +! output tendencies + outts,outqs,outqcs,outus,outvs,cnvwt,prets,cupclws, & +! dimesnional variables + itf,ktf,its,ite, kts,kte,ipr,tropics) + +!$acc kernels + do i=its,itf + if(xmbs(i).gt.0.)cutens(i)=1. + enddo +!$acc end kernels +!> - Call neg_check() for GF shallow convection + call neg_check('shallow',ipn,dt,qcheck,outqs,outts,outus,outvs, & + outqcs,prets,its,ite,kts,kte,itf,ktf,ktops) + endif + + ipr=0 + jpr_deep=0 !340765 +!> - Call cu_unified_deep_run() for middle GF convection + if(imid_gf == 1)then + call cu_unified_deep_run( & + itf,ktf,its,ite, kts,kte & + ,dicycle_m & + ,ichoicem & + ,ipr & + ,ccn_m & + ,ccnclean & + ,dt & + ,imid_gf & + ,kpbli & + ,dhdt & + ,xlandi & + + ,zo & + ,forcing2 & + ,t2d & + ,q2d & + ,ter11 & + ,tshall & + ,qshall & + ,p2d & + ,psur & + ,us & + ,vs & + ,rhoi & + ,hfx & + ,qfx & + ,dx & !hj dx(im) + ,mconv & + ,omeg & + + ,cactiv_m & + ,cnvwtm & + ,zum & + ,zdm & ! hli + ,zdd & + ,edtm & + ,edtd & ! hli + ,xmbm & + ,xmb_dumm & + ,xmbs & + ,pretm & + ,outum & + ,outvm & + ,outtm & + ,outqm & + ,outqcm & + ,kbconm & + ,ktopm & + ,cupclwm & + ,frhm & + ,ierrm & + ,ierrcm & +! the following should be set to zero if not available + ,rand_mom & ! for stochastics mom, if temporal and spatial patterns exist + ,rand_vmas & ! for stochastics vertmass, if temporal and spatial patterns exist + ,rand_clos & ! for stochastics closures, if temporal and spatial patterns exist + ,0 & ! flag to what you want perturbed + ! 1 = momentum transport + ! 2 = normalized vertical mass flux profile + ! 3 = closures + ! more is possible, talk to developer or + ! implement yourself. pattern is expected to be + ! betwee -1 and +1 + ,do_cap_suppress_here,cap_suppress_j & + ,k22m & + ,jminm,tropics) +!$acc kernels + do i=its,itf + do k=kts,ktf + qcheck(i,k)=qv(i,k) +outqs(i,k)*dt + enddo + enddo +!$acc end kernels +!> - Call neg_check() for middle GF convection + call neg_check('mid',ipn,dt,qcheck,outqm,outtm,outum,outvm, & + outqcm,pretm,its,ite,kts,kte,itf,ktf,ktopm) + endif +!> - Call cu_unified_deep_run() for deep GF convection + if(ideep.eq.1)then + call cu_unified_deep_run( & + itf,ktf,its,ite, kts,kte & + + ,dicycle & + ,ichoice & + ,ipr & + ,ccn_gf & + ,ccnclean & + ,dt & + ,0 & + + ,kpbli & + ,dhdt & + ,xlandi & + + ,zo & + ,forcing & + ,t2d & + ,q2d & + ,ter11 & + ,tn & + ,qo & + ,p2d & + ,psur & + ,us & + ,vs & + ,rhoi & + ,hfx & + ,qfx & + ,dx & !hj replace dx(im) + ,mconv & + ,omeg & + + ,cactiv & + ,cnvwt & + ,zu & + ,zd & + ,zdm & ! hli + ,edt & + ,edtm & ! hli + ,xmb & + ,xmbm & + ,xmbs & + ,pret & + ,outu & + ,outv & + ,outt & + ,outq & + ,outqc & + ,kbcon & + ,ktop & + ,cupclw & + ,frhd & + ,ierr & + ,ierrc & +! the following should be set to zero if not available + ,rand_mom & ! for stochastics mom, if temporal and spatial patterns exist + ,rand_vmas & ! for stochastics vertmass, if temporal and spatial patterns exist + ,rand_clos & ! for stochastics closures, if temporal and spatial patterns exist + ,0 & ! flag to what you want perturbed + ! 1 = momentum transport + ! 2 = normalized vertical mass flux profile + ! 3 = closures + ! more is possible, talk to developer or + ! implement yourself. pattern is expected to be + ! betwee -1 and +1 + ,do_cap_suppress_here,cap_suppress_j & + ,k22 & + ,jmin,tropics) + jpr=0 + ipr=0 +!$acc kernels + do i=its,itf + do k=kts,ktf + qcheck(i,k)=qv(i,k) +(outqs(i,k)+outqm(i,k))*dt + enddo + enddo +!$acc end kernels +!> - Call neg_check() for deep GF convection + call neg_check('deep',ipn,dt,qcheck,outq,outt,outu,outv, & + outqc,pret,its,ite,kts,kte,itf,ktf,ktop) +! + endif +! do i=its,itf +! kcnv(i)=0 +! if(pret(i).gt.0.)then +! cuten(i)=1. +! kcnv(i)= 1 !jmin(i) +! else +! kbcon(i)=0 +! ktop(i)=0 +! cuten(i)=0. +! endif ! pret > 0 +! if(pretm(i).gt.0.)then +! kcnv(i)= 1 !jmin(i) +! cutenm(i)=1. +! else +! kbconm(i)=0 +! ktopm(i)=0 +! cutenm(i)=0. +! endif ! pret > 0 +! enddo +!$acc kernels + do i=its,itf + kcnv(i)=0 + if(pretm(i).gt.0.)then + kcnv(i)= 1 !jmin(i) + cutenm(i)=1. + else + kbconm(i)=0 + ktopm(i)=0 + cutenm(i)=0. + endif ! pret > 0 + + if(pret(i).gt.0.)then + cuten(i)=1. + cutenm(i)=0. + pretm(i)=0. + kcnv(i)= 1 !jmin(i) + ktopm(i)=0 + kbconm(i)=0 + else + kbcon(i)=0 + ktop(i)=0 + cuten(i)=0. + endif ! pret > 0 + enddo +!$acc end kernels +! +!$acc parallel loop private(kstop,dtime_max,massflx,trcflx_in1,clw_in1,po_cup) + do i=its,itf + massflx(:)=0. + trcflx_in1(:)=0. + clw_in1(:)=0. + do k=kts,ktf + clw_ten(i, k)=0. + enddo + po_cup(:)=0. + kstop=kts + if(ktopm(i).gt.kts .or. ktop(i).gt.kts)kstop=max(ktopm(i),ktop(i)) + if(ktops(i).gt.kts)kstop=max(kstop,ktops(i)) + if(kstop.gt.2)then + htop(i)=kstop + if(kbcon(i).gt.2 .or. kbconm(i).gt.2)then + hbot(i)=max(kbconm(i),kbcon(i)) !jmin(i) + endif + + dtime_max=dt + do k=kts,kstop + cnvc(i,k) = 0.04 * log(1. + 675. * zu(i,k) * xmb(i)) + & + 0.04 * log(1. + 675. * zum(i,k) * xmbm(i)) + & + 0.04 * log(1. + 675. * zus(i,k) * xmbs(i)) + cnvc(i,k) = min(cnvc(i,k), 0.6) + cnvc(i,k) = max(cnvc(i,k), 0.0) + cnvw(i,k)=cnvwt(i,k)*xmb(i)*dt+cnvwts(i,k)*xmbs(i)*dt+cnvwtm(i,k)*xmbm(i)*dt + ud_mf(i,k)=cuten(i)*zu(i,k)*xmb(i)*dt + dd_mf(i,k)=cuten(i)*zd(i,k)*edt(i)*xmb(i)*dt + t(i,k)=t(i,k)+dt*(cutens(i)*outts(i,k)+cutenm(i)*outtm(i,k)+outt(i,k)*cuten(i)) + qv(i,k)=max(1.e-16,qv(i,k)+dt*(cutens(i)*outqs(i,k)+cutenm(i)*outqm(i,k)+outq(i,k)*cuten(i))) + gdc(i,k,7)=sqrt(us(i,k)**2 +vs(i,k)**2) + us(i,k)=us(i,k)+outu(i,k)*cuten(i)*dt +outum(i,k)*cutenm(i)*dt +outus(i,k)*cutens(i)*dt + vs(i,k)=vs(i,k)+outv(i,k)*cuten(i)*dt +outvm(i,k)*cutenm(i)*dt +outvs(i,k)*cutens(i)*dt + + gdc(i,k,1)= max(0.,tun_rad_shall(i)*cupclws(i,k)*cutens(i)) ! my mod + !gdc2(i,k,1)=max(0.,tun_rad_deep(i)*(cupclwm(i,k)*cutenm(i)+cupclw(i,k)*cuten(i))) + !gdc2(i,k,1)=max(0.,tun_rad_mid(i)*cupclwm(i,k)*cutenm(i)+tun_rad_deep(i)*cupclw(i,k)*cuten(i)+tun_rad_shall(i)*cupclws(i,k)*cutens(i)) + gdc2(i,k,1) = min(0.1, max(0.01, tun_rad_mid(i)*frhm(i)))*cupclwm(i,k)*cutenm(i) + min(0.1, max(0.01, tun_rad_deep(i)*(frhd(i))))*cupclw(i,k)*cuten(i) + tun_rad_shall(i)*cupclws(i,k)*cutens(i) + qci_conv(i,k)=gdc2(i,k,1) + gdc(i,k,2)=(outt(i,k))*86400. + gdc(i,k,3)=(outtm(i,k))*86400. + gdc(i,k,4)=(outts(i,k))*86400. + gdc(i,k,7)=-(gdc(i,k,7)-sqrt(us(i,k)**2 +vs(i,k)**2))/dt + !gdc(i,k,8)=(outq(i,k))*86400.*xlv/cp + gdc(i,k,8)=(outqm(i,k)+outqs(i,k)+outq(i,k))*86400.*xlv/cp + gdc(i,k,9)=gdc(i,k,2)+gdc(i,k,3)+gdc(i,k,4) +! +!> - Calculate subsidence effect on clw +! +! dsubclw=0. +! dsubclwm=0. +! dsubclws=0. +! dp=100.*(p2d(i,k)-p2d(i,k+1)) +! if (clcw(i,k) .gt. -999.0 .and. clcw(i,k+1) .gt. -999.0 )then +! clwtot = cliw(i,k) + clcw(i,k) +! clwtot1= cliw(i,k+1) + clcw(i,k+1) +! dsubclw=((-edt(i)*zd(i,k+1)+zu(i,k+1))*clwtot1 & +! -(-edt(i)*zd(i,k) +zu(i,k)) *clwtot )*g/dp +! dsubclwm=((-edtm(i)*zdm(i,k+1)+zum(i,k+1))*clwtot1 & +! -(-edtm(i)*zdm(i,k) +zum(i,k)) *clwtot )*g/dp +! dsubclws=(zus(i,k+1)*clwtot1-zus(i,k)*clwtot)*g/dp +! dsubclw=dsubclw+(zu(i,k+1)*clwtot1-zu(i,k)*clwtot)*g/dp +! dsubclwm=dsubclwm+(zum(i,k+1)*clwtot1-zum(i,k)*clwtot)*g/dp +! dsubclws=dsubclws+(zus(i,k+1)*clwtot1-zus(i,k)*clwtot)*g/dp +! endif +! tem = dt*(outqcs(i,k)*cutens(i)+outqc(i,k)*cuten(i) & +! +outqcm(i,k)*cutenm(i) & +! +dsubclw*xmb(i)+dsubclws*xmbs(i)+dsubclwm*xmbm(i) & +! ) +! tem1 = max(0.0, min(1.0, (tcr-t(i,k))*tcrf)) +! if (clcw(i,k) .gt. -999.0) then +! cliw(i,k) = max(0.,cliw(i,k) + tem * tem1) ! ice +! clcw(i,k) = max(0.,clcw(i,k) + tem *(1.0-tem1)) ! water +! else +! cliw(i,k) = max(0.,cliw(i,k) + tem) +! endif +! +! enddo + +!> - FCT treats subsidence effect to cloud ice/water (begin) + dp=100.*(p2d(i,k)-p2d(i,k+1)) + dtime_max=min(dtime_max,.5*dp) + po_cup(k)=.5*(p2d(i,k)+p2d(i,k+1)) + if (clcw(i,k) .gt. -999.0 .and. clcw(i,k+1) .gt. -999.0 )then + clwtot = cliw(i,k) + clcw(i,k) + if(clwtot.lt.1.e-32)clwtot=0. + clwtot1= cliw(i,k+1) + clcw(i,k+1) + if(clwtot1.lt.1.e-32)clwtot1=0. + clw_in1(k)=clwtot + massflx(k)=-(xmb(i) *( zu(i,k)- edt(i)* zd(i,k))) & + -(xmbm(i)*(zdm(i,k)-edtm(i)*zdm(i,k))) & + -(xmbs(i)*zus(i,k)) + trcflx_in1(k)=massflx(k)*.5*(clwtot+clwtot1) + endif + enddo + + massflx (1)=0. + trcflx_in1(1)=0. + call fct1d3 (kstop,kte,dtime_max,po_cup, & + clw_in1,massflx,trcflx_in1,clw_ten(i,:),g) + + do k=1,kstop + tem = dt*(outqcs(i,k)*cutens(i)+outqc(i,k)*cuten(i) & + +outqcm(i,k)*cutenm(i) & + +clw_ten(i,k) & + ) + tem1 = max(0.0, min(1.0, (tcr-t(i,k))*tcrf)) + if (clcw(i,k) .gt. -999.0) then + cliw(i,k) = max(0.,cliw(i,k) + tem * tem1) ! ice + clcw(i,k) = max(0.,clcw(i,k) + tem *(1.0-tem1)) ! water + else + cliw(i,k) = max(0.,cliw(i,k) + tem) + endif + + enddo + + gdc(i,1,10)=forcing(i,1) + gdc(i,2,10)=forcing(i,2) + gdc(i,3,10)=forcing(i,3) + gdc(i,4,10)=forcing(i,4) + gdc(i,5,10)=forcing(i,5) + gdc(i,6,10)=forcing(i,6) + gdc(i,7,10)=forcing(i,7) + gdc(i,8,10)=forcing(i,8) + gdc(i,10,10)=xmb(i) + gdc(i,11,10)=xmbm(i) + gdc(i,12,10)=xmbs(i) + gdc(i,13,10)=hfx(i) + gdc(i,15,10)=qfx(i) + gdc(i,16,10)=pret(i)*3600. + if(ktop(i).gt.2 .and.pret(i).gt.0.)dt_mf(i,ktop(i)-1)=ud_mf(i,ktop(i)) + endif + enddo +!$acc end parallel +!$acc kernels + do i=its,itf + if(pret(i).gt.0.)then + cactiv(i)=1 + raincv(i)=.001*(cutenm(i)*pretm(i)+cutens(i)*prets(i)+cuten(i)*pret(i))*dt + else + cactiv(i)=0 + if(pretm(i).gt.0)raincv(i)=.001*cutenm(i)*pretm(i)*dt + endif ! pret > 0 + + if(pretm(i).gt.0)then + cactiv_m(i)=1 + else + cactiv_m(i)=0 + endif + + ! Unify ccn + if(ccn_m(i).lt.ccn_gf(i))then + ccn_gf(i)=ccn_m(i) + endif + + if(ccn_gf(i)<0) ccn_gf(i)=0 + + ! Convert ccn back to aod + aod_gf(i)=0.0027*(ccn_gf(i)**0.64) + if(aod_gf(i)<0.007)then + aod_gf(i)=0.007 + ccn_gf(i)=(aod_gf(i)/0.0027)**(1/0.640) + elseif(aod_gf(i)>aodc0)then + aod_gf(i)=aodc0 + ccn_gf(i)=(aod_gf(i)/0.0027)**(1/0.640) + endif + enddo +!$acc end kernels + 100 continue +! +! Scale dry mixing ratios for water wapor and cloud water to specific humidy / moist mixing ratios +! +!$acc kernels + qv_spechum = qv/(1.0_kind_phys+qv) + cnvw_moist = cnvw/(1.0_kind_phys+qv) +!$acc end kernels +! +! Diagnostic tendency updates +! + if(ldiag3d) then + if(ishallow_g3.eq.1 .and. .not.flag_for_scnv_generic_tend) then + uidx=dtidx(index_of_x_wind,index_of_process_scnv) + vidx=dtidx(index_of_y_wind,index_of_process_scnv) + tidx=dtidx(index_of_temperature,index_of_process_scnv) + qidx=dtidx(100+ntqv,index_of_process_scnv) + if(uidx>=1) then +!$acc kernels + do k=kts,ktf + dtend(:,k,uidx) = dtend(:,k,uidx) + cutens(:)*outus(:,k) * dt + enddo +!$acc end kernels + endif + if(vidx>=1) then +!$acc kernels + do k=kts,ktf + dtend(:,k,vidx) = dtend(:,k,vidx) + cutens(:)*outvs(:,k) * dt + enddo +!$acc end kernels + endif + if(tidx>=1) then +!$acc kernels + do k=kts,ktf + dtend(:,k,tidx) = dtend(:,k,tidx) + cutens(:)*outts(:,k) * dt + enddo +!$acc end kernels + endif + if(qidx>=1) then +!$acc kernels + do k=kts,ktf + do i=its,itf + tem = cutens(i)*outqs(i,k)* dt + tem = tem/(1.0_kind_phys+tem) + dtend(i,k,qidx) = dtend(i,k,qidx) + tem + enddo + enddo +!$acc end kernels + endif + endif + if((ideep.eq.1. .or. imid_gf.eq.1) .and. .not.flag_for_dcnv_generic_tend) then + uidx=dtidx(index_of_x_wind,index_of_process_dcnv) + vidx=dtidx(index_of_y_wind,index_of_process_dcnv) + tidx=dtidx(index_of_temperature,index_of_process_dcnv) + if(uidx>=1) then +!$acc kernels + do k=kts,ktf + dtend(:,k,uidx) = dtend(:,k,uidx) + (cuten*outu(:,k)+cutenm*outum(:,k)) * dt + enddo +!$acc end kernels + endif + if(vidx>=1) then +!$acc kernels + do k=kts,ktf + dtend(:,k,vidx) = dtend(:,k,vidx) + (cuten*outv(:,k)+cutenm*outvm(:,k)) * dt + enddo +!$acc end kernels + endif + if(tidx>=1) then +!$acc kernels + do k=kts,ktf + dtend(:,k,tidx) = dtend(:,k,tidx) + (cuten*outt(:,k)+cutenm*outtm(:,k)) * dt + enddo +!$acc end kernels + endif + + qidx=dtidx(100+ntqv,index_of_process_dcnv) + if(qidx>=1) then +!$acc kernels + do k=kts,ktf + do i=its,itf + tem = (cuten(i)*outq(i,k) + cutenm(i)*outqm(i,k))* dt + tem = tem/(1.0_kind_phys+tem) + dtend(i,k,qidx) = dtend(i,k,qidx) + tem + enddo + enddo +!$acc end kernels + endif + endif + if(allocated(clcw_save)) then +!$acc parallel loop collapse(2) private(tem_shal,tem_deep,tem,tem1,weight_sum,cliw_both,clcw_both) + do k=kts,ktf + do i=its,itf + tem_shal = dt*(outqcs(i,k)*cutens(i)+outqcm(i,k)*cutenm(i)) + tem_deep = dt*(outqc(i,k)*cuten(i)+clw_ten(i,k)) + tem = tem_shal+tem_deep + tem1 = max(0.0, min(1.0, (tcr-t(i,k))*tcrf)) + weight_sum = abs(tem_shal)+abs(tem_deep) + if(weight_sum<1e-12) then + cycle + endif + + if (clcw_save(i,k) .gt. -999.0) then + cliw_both = max(0.,cliw_save(i,k) + tem * tem1) - cliw_save(i,k) + clcw_both = max(0.,clcw_save(i,k) + tem) - clcw_save(i,k) + else if(cliw_idx>=1) then + cliw_both = max(0.,cliw_save(i,k) + tem) - cliw_save(i,k) + clcw_both = 0 + endif + if(cliw_deep_idx>=1) then + dtend(i,k,cliw_deep_idx) = dtend(i,k,cliw_deep_idx) + abs(tem_deep)/weight_sum*cliw_both + endif + if(clcw_deep_idx>=1) then + dtend(i,k,clcw_deep_idx) = dtend(i,k,clcw_deep_idx) + abs(tem_deep)/weight_sum*clcw_both + endif + if(cliw_shal_idx>=1) then + dtend(i,k,cliw_shal_idx) = dtend(i,k,cliw_shal_idx) + abs(tem_shal)/weight_sum*cliw_both + endif + if(clcw_shal_idx>=1) then + dtend(i,k,clcw_shal_idx) = dtend(i,k,clcw_shal_idx) + abs(tem_shal)/weight_sum*clcw_both + endif + enddo + enddo +!$acc end parallel + endif + endif + end subroutine cu_unified_driver_run +!>@} +end module cu_unified_driver diff --git a/physics/cu_unified_driver.meta b/physics/cu_unified_driver.meta new file mode 100644 index 000000000..ba989e65f --- /dev/null +++ b/physics/cu_unified_driver.meta @@ -0,0 +1,586 @@ +[ccpp-table-properties] + name = cu_unified_driver + type = scheme + dependencies = cu_unified_deep.F90,cu_unified_sh.F90,machine.F,physcons.F90 + +######################################################################## +[ccpp-arg-table] + name = cu_unified_driver_init + type = scheme +[imfshalcnv] + standard_name = control_for_shallow_convection_scheme + long_name = flag for mass-flux shallow convection scheme + units = flag + dimensions = () + type = integer + intent = in +[imfshalcnv_unified] + standard_name = identifier_for_unified_shallow_convection + long_name = flag for Unified shallow convection scheme + units = flag + dimensions = () + type = integer + intent = in +[imfdeepcnv] + standard_name = control_for_deep_convection_scheme + long_name = flag for mass-flux deep convection scheme + units = flag + dimensions = () + type = integer + intent = in +[imfdeepcnv_unified] + standard_name = identifier_for_unified_deep_convection + long_name = flag for Unified deep convection scheme + units = flag + dimensions = () + type = integer + intent = in +[mpirank] + standard_name = mpi_rank + long_name = current MPI-rank + units = index + dimensions = () + type = integer + intent = in +[mpiroot] + standard_name = mpi_root + long_name = master MPI-rank + units = index + dimensions = () + type = integer + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out + +######################################################################## +[ccpp-arg-table] + name = cu_unified_driver_run + type = scheme +[ntracer] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in +[garea] + standard_name = cell_area + long_name = grid cell area + units = m2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[km] + standard_name = vertical_layer_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in +[dt] + standard_name = timestep_for_physics + long_name = physics time step + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[flag_init] + standard_name = flag_for_first_timestep + long_name = flag signaling first time step for time integration loop + units = flag + dimensions = () + type = logical + intent = in +[flag_restart] + standard_name = flag_for_restart + long_name = flag for restart (warmstart) or coldstart + units = flag + dimensions = () + type = logical + intent = in +[cactiv] + standard_name = counter_for_grell_freitas_convection + long_name = convective activity memory + units = none + dimensions = (horizontal_loop_extent) + type = integer + intent = inout +[cactiv_m] + standard_name = counter_for_grell_freitas_mid_level_convection + long_name = mid-level cloud convective activity memory + units = none + dimensions = (horizontal_loop_extent) + type = integer + intent = inout +[g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat !of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[xlv] + standard_name = latent_heat_of_vaporization_of_water_at_0C + long_name = latent heat of evaporation/sublimation + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[r_v] + standard_name = gas_constant_water_vapor + long_name = ideal gas constant for water vapor + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[forcet] + standard_name = tendency_of_air_temperature_due_to_nonphysics + long_name = temperature tendency due to dynamics only + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[forceqv_spechum] + standard_name = tendendy_of_specific_humidity_due_to_nonphysics + long_name = moisture tendency due to dynamics only + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[phil] + standard_name = geopotential + long_name = layer geopotential + units = m2 s-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[raincv] + standard_name = lwe_thickness_of_deep_convective_precipitation_amount + long_name = deep convective rainfall amount on physics timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[qv_spechum] + standard_name = specific_humidity_of_new_state + long_name = water vapor specific humidity updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[t] + standard_name = air_temperature_of_new_state + long_name = updated temperature + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[cld1d] + standard_name = cloud_work_function + long_name = cloud work function + units = m2 s-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[us] + standard_name = x_wind_of_new_state + long_name = updated x-direction wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[vs] + standard_name = y_wind_of_new_state + long_name = updated y-direction wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[t2di] + standard_name = air_temperature + long_name = mid-layer temperature + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[w] + standard_name = lagrangian_tendency_of_air_pressure + long_name = layer mean vertical velocity + units = Pa s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[qv2di_spechum] + standard_name = specific_humidity + long_name = water vapor specific humidity + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[p2di] + standard_name = air_pressure + long_name = mean layer pressure + units = Pa + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[psuri] + standard_name = surface_air_pressure + long_name = surface pressure + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[hbot] + standard_name = vertical_index_at_cloud_base + long_name = index for cloud base + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = out +[htop] + standard_name = vertical_index_at_cloud_top + long_name = index for cloud top + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = out +[kcnv] + standard_name = flag_deep_convection + long_name = deep convection: 0=no, 1=yes + units = flag + dimensions = (horizontal_loop_extent) + type = integer + intent = out +[xland] + standard_name = sea_land_ice_mask + long_name = landmask: sea/land/ice=0/1/2 + units = flag + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[hfx2] + standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness_and_vegetation + long_name = kinematic surface upward sensible heat flux reduced by surface roughness and vegetation + units = K m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[qfx2] + standard_name = surface_upward_specific_humidity_flux + long_name = kinematic surface upward latent heat flux + units = kg kg-1 m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[aod_gf] + standard_name = aerosol_optical_depth_for_grell_freitas_deep_convection + long_name = aerosol optical depth used in Grell-Freitas Convective Parameterization + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[cliw] + standard_name = ice_water_mixing_ratio_convective_transport_tracer + long_name = ratio of mass of ice water to mass of dry air plus vapor (without condensates) in the convectively transported tracer array + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[clcw] + standard_name = cloud_condensed_water_mixing_ratio_convective_transport_tracer + long_name = ratio of mass of cloud water to mass of dry air plus vapor (without condensates) in the convectively transported tracer array + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[pbl] + standard_name = atmosphere_boundary_layer_thickness + long_name = PBL thickness + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[ud_mf] + standard_name = instantaneous_atmosphere_updraft_convective_mass_flux + long_name = (updraft mass flux) * delt + units = kg m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[dd_mf] + standard_name = instantaneous_atmosphere_downdraft_convective_mass_flux + long_name = (downdraft mass flux) * delt + units = kg m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[dt_mf] + standard_name = instantaneous_atmosphere_detrainment_convective_mass_flux + long_name = (detrainment mass flux) * delt + units = kg m-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[cnvw_moist] + standard_name = convective_cloud_water_mixing_ratio + long_name = moist convective cloud water mixing ratio + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[cnvc] + standard_name = convective_cloud_cover + long_name = convective cloud cover + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[imfshalcnv] + standard_name = control_for_shallow_convection_scheme + long_name = flag for mass-flux shallow convection scheme + units = flag + dimensions = () + type = integer + intent = in +[flag_for_scnv_generic_tend] + standard_name = flag_for_generic_tendency_due_to_shallow_convection + long_name = true if GFS_SCNV_generic should calculate tendencies + units = flag + dimensions = () + type = logical + intent = in +[flag_for_dcnv_generic_tend] + standard_name = flag_for_generic_tendency_due_to_deep_convection + long_name = true if GFS_DCNV_generic should calculate tendencies + units = flag + dimensions = () + type = logical + intent = in +[dtend] + standard_name = cumulative_change_of_state_variables + long_name = diagnostic tendencies for state variables + units = mixed + dimensions = (horizontal_loop_extent,vertical_layer_dimension,cumulative_change_of_state_variables_outer_index_max) + type = real + kind = kind_phys + intent = inout +[dtidx] + standard_name = cumulative_change_of_state_variables_outer_index + long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index + units = index + dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes) + type = integer + intent = in +[ntqv] + standard_name = index_of_specific_humidity_in_tracer_concentration_array + long_name = tracer index for water vapor (specific humidity) + units = index + dimensions = () + type = integer + intent = in +[ntcw] + standard_name = index_of_cloud_liquid_water_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for cloud condensate (or liquid water) + units = index + dimensions = () + type = integer + intent = in +[ntiw] + standard_name = index_of_cloud_ice_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for ice water + units = index + dimensions = () + type = integer + intent = in +[index_of_temperature] + standard_name = index_of_temperature_in_cumulative_change_index + long_name = index of temperature in first dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_x_wind] + standard_name = index_of_x_wind_in_cumulative_change_index + long_name = index of x-wind in first dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_y_wind] + standard_name = index_of_y_wind_in_cumulative_change_index + long_name = index of x-wind in first dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_process_scnv] + standard_name = index_of_shallow_convection_process_process_in_cumulative_change_index + long_name = index of shallow convection process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_process_dcnv] + standard_name = index_of_deep_convection_process_process_in_cumulative_change_index + long_name = index of deep convection process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[dfi_radar_max_intervals] + standard_name = maximum_number_of_radar_derived_temperature_or_convection_suppression_intervals + long_name = maximum allowed number of time ranges with radar-derived microphysics temperature tendencies or radar-derived convection suppression + units = count + dimensions = () + type = integer + intent = in +[ldiag3d] + standard_name = flag_for_diagnostics_3D + long_name = flag for 3d diagnostic fields + units = flag + dimensions = () + type = logical + intent = in +[qci_conv] + standard_name = convective_cloud_condesate_after_rainout + long_name = convective cloud condesate after rainout + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[fhour] + standard_name = forecast_time + long_name = current forecast time + units = h + dimensions = () + type = real + kind = kind_phys + intent = in +[do_cap_suppress] + standard_name = flag_for_radar_derived_convection_suppression + long_name = flag for radar-derived convection suppression + units = flag + dimensions = () + type = logical + intent = in +[fh_dfi_radar] + standard_name = forecast_lead_times_bounding_radar_derived_temperature_or_convection_suppression_intervals + long_name = forecast lead times bounding radar derived temperature or convection suppression intervals + units = h + dimensions = (maximum_number_of_radar_derived_temperature_or_convection_suppression_intervals_plus_one) + type = real + kind = kind_phys + intent = in +[ix_dfi_radar] + standard_name = indices_with_radar_derived_temperature_or_convection_suppression_data + long_name = indices with radar derived temperature or convection suppression data + units = index + dimensions = (maximum_number_of_radar_derived_temperature_or_convection_suppression_intervals) + type = integer + intent = in +[num_dfi_radar] + standard_name = number_of_radar_derived_temperature_or_convection_suppression_intervals + long_name = number of time ranges with radar-derived microphysics temperature tendencies or radar-derived convection suppression + units = count + dimensions = () + type = integer + intent = in +[cap_suppress] + standard_name = radar_derived_convection_suppression + long_name = radar-derived convection suppression + units = unitless + dimensions = (horizontal_loop_extent,number_of_radar_derived_temperature_or_convection_suppression_intervals) + type = real + kind = kind_phys + intent = in +[ca_deep] + standard_name = cellular_automata_area_fraction_for_deep_convection_from_coupled_process + long_name = fraction of cellular automata for deep convection + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[rainevap] + standard_name = physics_field_for_coupling + long_name = physics_field_for_coupling + units = m2 s-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out diff --git a/physics/cu_unified_driver_post.F90 b/physics/cu_unified_driver_post.F90 new file mode 100644 index 000000000..821992bff --- /dev/null +++ b/physics/cu_unified_driver_post.F90 @@ -0,0 +1,65 @@ +!> \file cu_unified_driver_post.F90 +!! Contains code related to unified convective schemes to be used within the GFS physics suite. + +module cu_unified_driver_post + + implicit none + + private + + public :: cu_unified_driver_post_run + + contains + +!>\ingroup cu_unified_group +!> \section arg_table_cu_unified_driver_post_run Argument Table +!! \htmlinclude cu_unified_driver_post_run.html +!! + subroutine cu_unified_driver_post_run (im, t, q, prevst, prevsq, cactiv, cactiv_m, conv_act, conv_act_m, errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + ! Interface variables + integer, intent(in) :: im + real(kind_phys), intent(in) :: t(:,:) + real(kind_phys), intent(in) :: q(:,:) + real(kind_phys), intent(out) :: prevst(:,:) + real(kind_phys), intent(out) :: prevsq(:,:) + integer, intent(in) :: cactiv(:) + integer, intent(in) :: cactiv_m(:) + real(kind_phys), intent(out) :: conv_act(:) + real(kind_phys), intent(out) :: conv_act_m(:) + character(len=*), intent(out) :: errmsg +!$acc declare copyin(t,q,cactiv,cactiv_m) copyout(prevst,prevsq,conv_act,conv_act_m) + integer, intent(out) :: errflg + + ! Local variables + integer :: i + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + +!$acc kernels + prevst(:,:) = t(:,:) + prevsq(:,:) = q(:,:) + + do i = 1, im + if (cactiv(i).gt.0) then + conv_act(i) = conv_act(i)+1.0 + else + conv_act(i)=0.0 + endif + if (cactiv_m(i).gt.0) then + conv_act_m(i) = conv_act_m(i)+1.0 + else + conv_act_m(i)=0.0 + endif + enddo +!$acc end kernels + + end subroutine cu_unified_driver_post_run + +end module cu_unified_driver_post diff --git a/physics/cu_unified_driver_post.meta b/physics/cu_unified_driver_post.meta new file mode 100644 index 000000000..5266b86e2 --- /dev/null +++ b/physics/cu_unified_driver_post.meta @@ -0,0 +1,93 @@ +[ccpp-table-properties] + name = cu_unified_driver_post + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = cu_unified_driver_post_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[t] + standard_name = air_temperature_of_new_state + long_name = temperature updated by physics + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[q] + standard_name = specific_humidity_of_new_state + long_name = water vapor specific humidity updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[prevst] + standard_name = air_temperature_on_previous_timestep + long_name = temperature from previous time step + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[prevsq] + standard_name = specific_humidity_on_previous_timestep + long_name = moisture from previous time step + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[cactiv] + standard_name = counter_for_grell_freitas_convection + long_name = convective activity memory + units = none + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[cactiv_m] + standard_name = counter_for_grell_freitas_mid_level_convection + long_name = midlevel convective activity memory + units = none + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[conv_act] + standard_name = consecutive_calls_for_grell_freitas_convection + long_name = Memory counter for GF + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[conv_act_m] + standard_name = consecutive_calls_for_grell_freitas_mid_level_convection + long_name = Memory counter for GF midlevel + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out diff --git a/physics/cu_unified_driver_pre.F90 b/physics/cu_unified_driver_pre.F90 new file mode 100644 index 000000000..69d6d9be4 --- /dev/null +++ b/physics/cu_unified_driver_pre.F90 @@ -0,0 +1,84 @@ +!> \file cu_unified_driver_pre.F90 +!! Contains code related to the unified convective schemes to be used within the GFS physics suite. + +module cu_unified_driver_pre + + implicit none + + private + + public :: cu_unified_driver_pre_run + + contains + +!>\ingroup cu_unified_group +!> \section arg_table_cu_unified_driver_pre_run Argument Table +!! \htmlinclude cu_unified_driver_pre_run.html +!! + subroutine cu_unified_driver_pre_run (flag_init, flag_restart, kdt, fhour, dtp, t, q, prevst, prevsq, & + forcet, forceq, cactiv, cactiv_m, conv_act, conv_act_m, & + errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + logical, intent(in) :: flag_init + logical, intent(in) :: flag_restart + integer, intent(in) :: kdt + real(kind_phys), intent(in) :: fhour + real(kind_phys), intent(in) :: dtp + real(kind_phys), intent(in) :: t(:,:) + real(kind_phys), intent(in) :: q(:,:) + real(kind_phys), intent(in) :: prevst(:,:) + real(kind_phys), intent(in) :: prevsq(:,:) +!$acc declare copyin(t,q,prevst,prevsq) + real(kind_phys), intent(out) :: forcet(:,:) + real(kind_phys), intent(out) :: forceq(:,:) + integer, intent(out) :: cactiv(:) + integer, intent(out) :: cactiv_m(:) +!$acc declare copyout(forcet,forceq,cactiv,cactiv_m) + real(kind_phys), intent(in) :: conv_act(:) + real(kind_phys), intent(in) :: conv_act_m(:) +!$acc declare copyin(conv_act,conv_act_m) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! local variables + real(kind=kind_phys) :: dtdyn + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! For restart runs, can assume that prevst and prevsq + ! are read from the restart files beforehand, same + ! for conv_act. + if(flag_init .and. .not.flag_restart) then +!$acc kernels + forcet(:,:)=0.0 + forceq(:,:)=0.0 +!$acc end kernels + else + dtdyn=3600.0*(fhour)/kdt + if(dtp > dtdyn) then +!$acc kernels + forcet(:,:)=(t(:,:) - prevst(:,:))/dtp + forceq(:,:)=(q(:,:) - prevsq(:,:))/dtp +!$acc end kernels + else +!$acc kernels + forcet(:,:)=(t(:,:) - prevst(:,:))/dtdyn + forceq(:,:)=(q(:,:) - prevsq(:,:))/dtdyn +!$acc end kernels + endif + endif + +!$acc kernels + cactiv(:)=nint(conv_act(:)) + cactiv_m(:)=nint(conv_act_m(:)) +!$acc end kernels + + end subroutine cu_unified_driver_pre_run + +end module cu_unified_driver_pre diff --git a/physics/cu_unified_driver_pre.meta b/physics/cu_unified_driver_pre.meta new file mode 100644 index 000000000..aa8b870db --- /dev/null +++ b/physics/cu_unified_driver_pre.meta @@ -0,0 +1,139 @@ +[ccpp-table-properties] + name = cu_unified_driver_pre + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = cu_unified_driver_pre_run + type = scheme +[flag_init] + standard_name = flag_for_first_timestep + long_name = flag signaling first time step for time integration loop + units = flag + dimensions = () + type = logical + intent = in +[flag_restart] + standard_name = flag_for_restart + long_name = flag for restart (warmstart) or coldstart + units = flag + dimensions = () + type = logical + intent = in +[kdt] + standard_name = index_of_timestep + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = in +[fhour] + standard_name = forecast_time + long_name = curent forecast time + units = h + dimensions = () + type = real + kind = kind_phys + intent = in +[dtp] + standard_name = timestep_for_physics + long_name = physics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[t] + standard_name = air_temperature + long_name = model layer mean temperature + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[q] + standard_name = specific_humidity + long_name = water vapor specific humidity + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[prevst] + standard_name = air_temperature_on_previous_timestep + long_name = temperature from previous time step + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[prevsq] + standard_name = specific_humidity_on_previous_timestep + long_name = moisture from previous time step + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[forcet] + standard_name = tendency_of_air_temperature_due_to_nonphysics + long_name = temperature tendency due to dynamics only + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[forceq] + standard_name = tendendy_of_specific_humidity_due_to_nonphysics + long_name = moisture tendency due to dynamics only + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[cactiv] + standard_name = counter_for_grell_freitas_convection + long_name = convective activity memory + units = none + dimensions = (horizontal_loop_extent) + type = integer + intent = out +[cactiv_m] + standard_name = counter_for_grell_freitas_mid_level_convection + long_name = midlevel convective activity memory + units = none + dimensions = (horizontal_loop_extent) + type = integer + intent = out +[conv_act] + standard_name = consecutive_calls_for_grell_freitas_convection + long_name = Memory counter for GF + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[conv_act_m] + standard_name = consecutive_calls_for_grell_freitas_mid_level_convection + long_name = Memory counter for GF midlevel + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out diff --git a/physics/cu_unified_sh.F90 b/physics/cu_unified_sh.F90 new file mode 100644 index 000000000..f0d0455f4 --- /dev/null +++ b/physics/cu_unified_sh.F90 @@ -0,0 +1,1045 @@ +!>\file cu_unified_sh.F90 +!! This file contains unified shallow convection scheme. + +module cu_unified_sh + use machine , only : kind_phys + !real(kind=kind_phys), parameter:: c1_shal=0.0015! .0005 + real(kind=kind_phys), parameter:: c1_shal=0. !0.005! .0005 + real(kind=kind_phys), parameter:: g =9.81 + real(kind=kind_phys), parameter:: cp =1004. + real(kind=kind_phys), parameter:: xlv=2.5e6 + real(kind=kind_phys), parameter:: r_v=461. + real(kind=kind_phys), parameter:: c0_shal=.001 + real(kind=kind_phys), parameter:: fluxtune=1.5 + +contains + +!>\defgroup cu_unified_sh_group Grell-Freitas Shallow Convection Module +!! This module contains Grell-Freitas shallow convection scheme. +!> \ingroup cu_unified_group +!> @{ +!> GF shallow convection as described in Grell and +!! Freitas (2014) \cite grell_and_freitas_2014. input variables are: +!!\param us x wind updated by physics +!!\param vs y wind updated by physics +!!\param zo height at model levels +!!\param t,tn temperature without and with forcing at model levels +!!\param q,qo mixing ratio without and with forcing at model levels +!!\param po pressure at model levels (mb) +!!\param psur surface pressure (mb) +!!\param z1 surface height +!!\param dhdt forcing for boundary layer equilibrium +!!\param hfx,qfx in w/m2 (positive, if upward from sfc) +!!\param kpbl level of boundaty layer height +!!\param rho moist air density +!!\param xland land mask (1. for land) +!!\param ichoice which closure to choose +!!\n 1: old g +!!\n 2: zws +!!\n 3: dhdt +!!\n 0: average +!!\param tcrit parameter for water/ice conversion (258) +!!\param dtime physics time step +!!\param zuo normalized mass flux profile +!!\param xmb_out base mass flux +!!\param kbcon convective cloud base +!!\param ktop cloud top +!!\param k22 level of updraft originating air +!!\param ierr error flag +!!\param ierrc error description +!!\param outt temperature tendency (k/s) +!!\param outq mixing ratio tendency (kg/kg/s) +!!\param outqc cloud water/ice tendency (kg/kg/s) +!!\param outu x wind tendency +!!\param outv y wind tendency +!!\param pre precip rate (mm/s) +!!\param cupclw incloud mixing ratio of cloudwater/ice (for radiation) +!! this needs heavy tuning factors, since cloud fraction is +!! not included (kg/kg) +!!\param cnvwt required for gfs physics +!!\param itf,ktf,its,ite, kts,kte are dimensions +!!\param ipr horizontal index of printed column +!!\param tropics =0 +!>\section gen_cu_unified_sh_run Grell-Freitas Shallow Convection General Algorithm + subroutine cu_unified_sh_run ( & + us,vs,zo,t,q,z1,tn,qo,po,psur,dhdt,kpbl,rho, & ! input variables, must be supplied + hfx,qfx,xland,ichoice,tcrit,dtime, & + zuo,xmb_out,kbcon,ktop,k22,ierr,ierrc, & + outt,outq,outqc,outu,outv,cnvwt,pre,cupclw, & ! output tendencies + itf,ktf,its,ite, kts,kte,ipr,tropics) ! dimesnional variables +! +! this module needs some subroutines from gf_deep +! + use cu_unified_deep,only:cup_env,cup_env_clev,get_cloud_bc,cup_minimi, & + get_inversion_layers,rates_up_pdf,get_cloud_bc, & + cup_up_aa0,cup_kbcon,get_lateral_massflux + implicit none + integer & + ,intent (in ) :: & + itf,ktf, & + its,ite, kts,kte,ipr + logical :: make_calc_for_xk = .true. + integer, intent (in ) :: & + ichoice + ! + ! + ! + ! outtem = output temp tendency (per s) + ! outq = output q tendency (per s) + ! outqc = output qc tendency (per s) + ! pre = output precip + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (inout ) :: & + cnvwt,outt,outq,outqc,cupclw,zuo,outu,outv +!$acc declare copy(cnvwt,outt,outq,outqc,cupclw,zuo,outu,outv) + real(kind=kind_phys), dimension (its:ite) & + ,intent (out ) :: & + xmb_out + integer, dimension (its:ite) & + ,intent (inout ) :: & + ierr + integer, dimension (its:ite) & + ,intent (out ) :: & + kbcon,ktop,k22 + integer, dimension (its:ite) & + ,intent (in ) :: & + kpbl,tropics +!$acc declare copyout(xmb_out,kbcon,ktop,k22) copyin(kpbl,tropics) copy(ierr) + ! + ! basic environmental input includes a flag (ierr) to turn off + ! convection for this call only and at that particular gridpoint + ! + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + t,po,tn,dhdt,rho,us,vs + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (inout) :: & + q,qo + real(kind=kind_phys), dimension (its:ite) & + ,intent (in ) :: & + xland,z1,psur,hfx,qfx + + real(kind=kind_phys) & + ,intent (in ) :: & + dtime,tcrit +!$acc declare copyin(t,po,tn,dhdt,rho,us,vs) copy(q,qo) copyin(xland,z1,psur,hfx,qfx) copyin(dtime,tcrit) + ! + !***************** the following are your basic environmental + ! variables. they carry a "_cup" if they are + ! on model cloud levels (staggered). they carry + ! an "o"-ending (z becomes zo), if they are the forced + ! variables. + ! + ! z = heights of model levels + ! q = environmental mixing ratio + ! qes = environmental saturation mixing ratio + ! t = environmental temp + ! p = environmental pressure + ! he = environmental moist static energy + ! hes = environmental saturation moist static energy + ! z_cup = heights of model cloud levels + ! q_cup = environmental q on model cloud levels + ! qes_cup = saturation q on model cloud levels + ! t_cup = temperature (kelvin) on model cloud levels + ! p_cup = environmental pressure + ! he_cup = moist static energy on model cloud levels + ! hes_cup = saturation moist static energy on model cloud levels + ! gamma_cup = gamma on model cloud levels + ! dby = buoancy term + ! entr = entrainment rate + ! bu = buoancy term + ! gamma_cup = gamma on model cloud levels + ! qrch = saturation q in cloud + ! pwev = total normalized integrated evaoprate (i2) + ! z1 = terrain elevation + ! psur = surface pressure + ! zu = updraft normalized mass flux + ! kbcon = lfc of parcel from k22 + ! k22 = updraft originating level + ! ichoice = flag if only want one closure (usually set to zero!) + ! dby = buoancy term + ! ktop = cloud top (output) + ! xmb = total base mass flux + ! hc = cloud moist static energy + ! hkb = moist static energy at originating level + + real(kind=kind_phys), dimension (its:ite,kts:kte) :: & + entr_rate_2d,he,hes,qes,z, & + heo,heso,qeso,zo, & + xhe,xhes,xqes,xz,xt,xq, & + qes_cup,q_cup,he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup, & + qeso_cup,qo_cup,heo_cup,heso_cup,zo_cup,po_cup,gammao_cup, & + tn_cup, & + xqes_cup,xq_cup,xhe_cup,xhes_cup,xz_cup, & + xt_cup,dby,hc,zu, & + dbyo,qco,pwo,hco,qrco, & + dbyt,xdby,xhc,xzu, & + + ! cd = detrainment function for updraft + ! dellat = change of temperature per unit mass flux of cloud ensemble + ! dellaq = change of q per unit mass flux of cloud ensemble + ! dellaqc = change of qc per unit mass flux of cloud ensemble + + cd,dellah,dellaq,dellat,dellaqc,uc,vc,dellu,dellv,u_cup,v_cup + +!$acc declare create( & +!$acc entr_rate_2d,he,hes,qes,z, & +!$acc heo,heso,qeso,zo, & +!$acc xhe,xhes,xqes,xz,xt,xq, & +!$acc qes_cup,q_cup,he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup, & +!$acc qeso_cup,qo_cup,heo_cup,heso_cup,zo_cup,po_cup,gammao_cup, & +!$acc tn_cup, & +!$acc xqes_cup,xq_cup,xhe_cup,xhes_cup,xz_cup, & +!$acc xt_cup,dby,hc,zu, & +!$acc dbyo,qco,pwo,hco,qrco, & +!$acc dbyt,xdby,xhc,xzu, & +!$acc cd,dellah,dellaq,dellat,dellaqc,uc,vc,dellu,dellv,u_cup,v_cup) + + ! aa0 cloud work function for downdraft + ! aa0 = cloud work function without forcing effects + ! aa1 = cloud work function with forcing effects + ! xaa0 = cloud work function with cloud effects (ensemble dependent) + + real(kind=kind_phys), dimension (its:ite) :: & + zws,ztexec,zqexec,pre,aa1,aa0,xaa0,hkb, & + flux_tun,hkbo,xhkb, & + rand_vmas,xmbmax,xmb, & + cap_max,entr_rate, & + cap_max_increment,lambau + integer, dimension (its:ite) :: & + kstabi,xland1,kbmax,ktopx +!$acc declare create( & +!$acc zws,ztexec,zqexec,pre,aa1,aa0,xaa0,hkb, & +!$acc flux_tun,hkbo,xhkb, & +!$acc rand_vmas,xmbmax,xmb, & +!$acc cap_max,entr_rate, & +!$acc cap_max_increment,lambau, & +!$acc kstabi,xland1,kbmax,ktopx) + + integer :: & + kstart,i,k,ki + real(kind=kind_phys) :: & + dz,mbdt,zkbmax, & + cap_maxs,trash,trash2,frh + + real(kind=kind_phys) buo_flux,pgeoh,dp,entup,detup,totmas + + real(kind=kind_phys) xff_shal(3),blqe,xkshal + character*50 :: ierrc(its:ite) + real(kind=kind_phys), dimension (its:ite,kts:kte) :: & + up_massentr,up_massdetr,up_massentro,up_massdetro,up_massentru,up_massdetru +!$acc declare create(up_massentr,up_massdetr,up_massentro,up_massdetro,up_massentru,up_massdetru) + real(kind=kind_phys) :: c_up,x_add,qaver,dts,fp,fpi + real(kind=kind_phys), dimension (its:ite,kts:kte) :: c1d,dtempdz + integer, dimension (its:ite,kts:kte) :: k_inv_layers + integer, dimension (its:ite) :: start_level, pmin_lev +!$acc declare create(c1d,dtempdz,k_inv_layers,start_level, pmin_lev) + + real(kind=kind_phys), parameter :: zero = 0 + +!$acc kernels + start_level(:)=0 + rand_vmas(:)=0. + flux_tun(:)=fluxtune + lambau(:)=2. + c1d(:,:)=0. +!$acc end kernels + +!$acc kernels + do i=its,itf + xland1(i)=int(xland(i)+.001) ! 1. + ktopx(i)=0 + if(xland(i).gt.1.5 .or. xland(i).lt.0.5)then + xland1(i)=0 +! ierr(i)=100 + endif + pre(i)=0. + xmb_out(i)=0. + cap_max_increment(i)=25. + entr_rate(i) = 1.e-3 !9.e-5 ! 1.75e-3 ! 1.2e-3 ! .2/50. + enddo +!$acc end kernels + + do i=its,itf + ierrc(i)=" " + enddo +! +!--- initial entrainment rate (these may be changed later on in the +!--- program +! + +! +!> - Initial detrainmentrates +! +!$acc kernels + do k=kts,ktf + do i=its,itf + up_massentro(i,k)=0. + up_massdetro(i,k)=0. + up_massentru(i,k)=0. + up_massdetru(i,k)=0. + z(i,k)=zo(i,k) + xz(i,k)=zo(i,k) + qrco(i,k)=0. + pwo(i,k)=0. + cd(i,k)=.75*entr_rate(i) + dellaqc(i,k)=0. + cupclw(i,k)=0. + enddo + enddo +!$acc end kernels +! +!--- max/min allowed value for epsilon (ratio downdraft base mass flux/updraft +! +!--- minimum depth (m), clouds must have +! +! +!--- maximum depth (mb) of capping +!--- inversion (larger cap = no convection) +! +!$acc kernels + cap_maxs=175. + do i=its,itf + kbmax(i)=1 + aa0(i)=0. + aa1(i)=0. + enddo + do i=its,itf + cap_max(i)=cap_maxs + ztexec(i) = 0. + zqexec(i) = 0. + zws(i) = 0. + enddo + do i=its,itf + !- buoyancy flux (h+le) + buo_flux= (hfx(i)/cp+0.608*t(i,1)*qfx(i)/xlv)/rho(i,1) + pgeoh = zo(i,2)*g + !-convective-scale velocity w* + zws(i) = max(0.,flux_tun(i)*0.41*buo_flux*zo(i,2)*g/t(i,1)) + if(zws(i) > tiny(pgeoh)) then + !-convective-scale velocity w* + zws(i) = 1.2*zws(i)**.3333 + !- temperature excess + ztexec(i) = max(flux_tun(i)*hfx(i)/(rho(i,1)*zws(i)*cp),0.0) + !- moisture excess + zqexec(i) = max(flux_tun(i)*qfx(i)/xlv/(rho(i,1)*zws(i)),0.) + endif + !> - Calculate zws for shallow convection closure (grant 2001) + !- height of the pbl + zws(i) = max(0.,flux_tun(i)*0.41*buo_flux*zo(i,kpbl(i))*g/t(i,kpbl(i))) + zws(i) = 1.2*zws(i)**.3333 + zws(i) = zws(i)*rho(i,kpbl(i)) !check if zrho is correct + + enddo +!$acc end kernels +! +!> - Determin max height(m) above ground where updraft air can originate +! + zkbmax=3000. +! +!> - Call cup_env() to calculate moist static energy, heights, qes +! + call cup_env(z,qes,he,hes,t,q,po,z1, & + psur,ierr,tcrit,-1, & + itf,ktf, & + its,ite, kts,kte) + call cup_env(zo,qeso,heo,heso,tn,qo,po,z1, & + psur,ierr,tcrit,-1, & + itf,ktf, & + its,ite, kts,kte) + +! +!> - Call cup_env_clev() to calculate environmental values on cloud levels +! + call cup_env_clev(t,qes,q,he,hes,z,po,qes_cup,q_cup,he_cup, & + hes_cup,z_cup,p_cup,gamma_cup,t_cup,psur, & + ierr,z1, & + itf,ktf, & + its,ite, kts,kte) + call cup_env_clev(tn,qeso,qo,heo,heso,zo,po,qeso_cup,qo_cup, & + heo_cup,heso_cup,zo_cup,po_cup,gammao_cup,tn_cup,psur, & + ierr,z1, & + itf,ktf, & + its,ite, kts,kte) + +!$acc kernels + do i=its,itf + if(ierr(i).eq.0)then + u_cup(i,kts)=us(i,kts) + v_cup(i,kts)=vs(i,kts) + do k=kts+1,ktf + u_cup(i,k)=.5*(us(i,k-1)+us(i,k)) + v_cup(i,k)=.5*(vs(i,k-1)+vs(i,k)) + enddo + endif + enddo + + do i=its,itf + if(ierr(i).eq.0)then +! +!$acc loop seq + do k=kts,ktf + if(zo_cup(i,k).gt.zkbmax+z1(i))then + kbmax(i)=k + go to 25 + endif + enddo + 25 continue +! + kbmax(i)=min(kbmax(i),ktf/2) + endif + enddo +!$acc end kernels + +! +! +! +!> - Determine level with highest moist static energy content (\p k22) +! +!$acc parallel loop + do 36 i=its,itf + if(kpbl(i).gt.3)cap_max(i)=po_cup(i,kpbl(i)) + if(ierr(i) == 0)then + k22(i)=maxloc(heo_cup(i,2:kbmax(i)),1) + k22(i)=max(2,k22(i)) + if(k22(i).gt.kbmax(i))then + ierr(i)=2 +#ifndef _OPENACC + ierrc(i)="could not find k22" +#endif + ktop(i)=0 + k22(i)=0 + kbcon(i)=0 + endif + endif + 36 continue +!$acc end parallel +! +!> - Call get_cloud_bc() and cup_kbcon() to determine the level of +!! convective cloud base (\p kbcon) +! +!$acc parallel loop private(x_add) + do i=its,itf + if(ierr(i).eq.0)then + x_add = xlv*zqexec(i)+cp*ztexec(i) + call get_cloud_bc(kte,he_cup (i,1:kte),hkb (i),k22(i),x_add) + call get_cloud_bc(kte,heo_cup(i,1:kte),hkbo(i),k22(i),x_add) + endif ! ierr + enddo +!$acc end parallel + +!joe-georg and saulo's new idea: + +!$acc kernels + do i=its,itf + do k=kts,ktf + dbyo(i,k)= 0. !hkbo(i)-heso_cup(i,k) + enddo + enddo +!$acc end kernels + + + call cup_kbcon(ierrc,cap_max_increment,5,k22,kbcon,heo_cup,heso_cup, & + hkbo,ierr,kbmax,po_cup,cap_max, & + ztexec,zqexec, & + 0,itf,ktf, & + its,ite, kts,kte, & + z_cup,entr_rate,heo,0) + +!> - Call cup_minimi() and get_inversion_layers() to get inversion layers for cloud tops + call cup_minimi(heso_cup,kbcon,kbmax,kstabi,ierr, & + itf,ktf, & + its,ite, kts,kte) +! + call get_inversion_layers(ierr,p_cup,t_cup,z_cup,q_cup,qes_cup,k_inv_layers,& + kbcon,kstabi,dtempdz,itf,ktf,its,ite, kts,kte) +! +! +!$acc parallel loop private(frh,kstart,x_add) + do i=its,itf + entr_rate_2d(i,:)=entr_rate(i) + if(ierr(i) == 0)then + start_level(i)=k22(i) + x_add = xlv*zqexec(i)+cp*ztexec(i) + call get_cloud_bc(kte,he_cup (i,1:kte),hkb (i),k22(i),x_add) + if(kbcon(i).gt.ktf-4)then + ierr(i)=231 + endif + do k=kts,ktf + frh = 2.*min(qo_cup(i,k)/qeso_cup(i,k),1.) + entr_rate_2d(i,k)=entr_rate(i) !*(2.3-frh) + cd(i,k)=.75*entr_rate_2d(i,k) + enddo +! +! first estimate for shallow convection +! + ktop(i)=1 + kstart=kpbl(i) + if(kpbl(i).lt.5)kstart=kbcon(i) +! if(k_inv_layers(i,1).gt.0)then +!! ktop(i)=min(k_inv_layers(i,1),k_inv_layers(i,2)) + if(k_inv_layers(i,1).gt.0 .and. & + (po_cup(i,kstart)-po_cup(i,k_inv_layers(i,1))).lt.200.)then + ktop(i)=k_inv_layers(i,1) + else + do k=kbcon(i)+1,ktf + if((po_cup(i,kstart)-po_cup(i,k)).gt.200.)then + ktop(i)=k + exit + endif + enddo + endif + endif + enddo +!$acc end parallel +!> - Call rates_up_pdf() to get normalized mass flux profile + call rates_up_pdf(rand_vmas,ipr,'shallow',ktop,ierr,po_cup,entr_rate_2d,hkbo,heo,heso_cup,zo_cup, & + xland1,kstabi,k22,kbcon,its,ite,itf,kts,kte,ktf,zuo,kpbl,ktopx,kbcon,pmin_lev) +!$acc kernels + do i=its,itf + if(ierr(i).eq.0)then +! do k=maxloc(zuo(i,:),1),1,-1 ! ktop(i)-1,1,-1 +! if(zuo(i,k).lt.1.e-6)then +! k22(i)=k+1 +! start_level(i)=k22(i) +! exit +! endif +! enddo + if(k22(i).gt.1)then +!$acc loop independent + do k=1,k22(i)-1 + zuo(i,k)=0. + zu (i,k)=0. + xzu(i,k)=0. + enddo + endif +!$acc loop seq + do k=maxloc(zuo(i,:),1),ktop(i) + if(zuo(i,k).lt.1.e-6)then + ktop(i)=k-1 + exit + endif + enddo +!$acc loop independent + do k=k22(i),ktop(i) + xzu(i,k)= zuo(i,k) + zu(i,k)= zuo(i,k) + enddo +!$acc loop independent + do k=ktop(i)+1,ktf + zuo(i,k)=0. + zu (i,k)=0. + xzu(i,k)=0. + enddo + k22(i)=max(2,k22(i)) + endif + enddo +!$acc end kernels +! +!> - Call get_lateral_massflux() to calculate mass entrainment and detrainment +! + call get_lateral_massflux(itf,ktf, its,ite, kts,kte & + ,ierr,ktop,zo_cup,zuo,cd,entr_rate_2d & + ,up_massentro, up_massdetro ,up_massentr, up_massdetr & + ,2,kbcon,k22,up_massentru,up_massdetru,lambau) +!$acc kernels + do k=kts,ktf + do i=its,itf + hc(i,k)=0. + qco(i,k)=0. + qrco(i,k)=0. + dby(i,k)=0. + hco(i,k)=0. + dbyo(i,k)=0. + enddo + enddo + do i=its,itf + if(ierr(i) /= 0) cycle + do k=1,start_level(i) + uc(i,k)=u_cup(i,k) + vc(i,k)=v_cup(i,k) + enddo + do k=1,start_level(i)-1 + hc(i,k)=he_cup(i,k) + hco(i,k)=heo_cup(i,k) + enddo + k=start_level(i) + hc(i,k)=hkb(i) + hco(i,k)=hkbo(i) + enddo +!$acc end kernels +! +! + +!$acc parallel loop private(ki,qaver,k,trash,trash2,dz,dp) + do 42 i=its,itf + dbyt(i,:)=0. + if(ierr(i) /= 0) cycle +!$acc loop seq + do k=start_level(i)+1,ktop(i) + hc(i,k)=(hc(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)*hc(i,k-1)+ & + up_massentr(i,k-1)*he(i,k-1)) / & + (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) + uc(i,k)=(uc(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)*uc(i,k-1)+ & + up_massentr(i,k-1)*us(i,k-1)) / & + (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) + vc(i,k)=(vc(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)*vc(i,k-1)+ & + up_massentr(i,k-1)*vs(i,k-1))/ & + (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) + dby(i,k)=max(0.,hc(i,k)-hes_cup(i,k)) + hco(i,k)=(hco(i,k-1)*zuo(i,k-1)-.5*up_massdetro(i,k-1)*hco(i,k-1)+ & + up_massentro(i,k-1)*heo(i,k-1)) / & + (zuo(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1)) + dbyo(i,k)=hco(i,k)-heso_cup(i,k) + dz=zo_cup(i,k+1)-zo_cup(i,k) + if(k.ge.kbcon(i))dbyt(i,k)=dbyt(i,k-1)+dbyo(i,k)*dz + enddo + ki=maxloc(dbyt(i,:),1) + if(ktop(i).gt.ki+1)then + ktop(i)=ki+1 + zuo(i,ktop(i)+1:ktf)=0. + zu(i,ktop(i)+1:ktf)=0. + cd(i,ktop(i)+1:ktf)=0. + up_massdetro(i,ktop(i))=zuo(i,ktop(i)) +! up_massentro(i,ktop(i))=0. + up_massentro(i,ktop(i):ktf)=0. + up_massdetro(i,ktop(i)+1:ktf)=0. + entr_rate_2d(i,ktop(i)+1:ktf)=0. + +! ierr(i)=423 + endif + + if(ktop(i).lt.kbcon(i)+1)then + ierr(i)=5 +#ifndef _OPENACC + ierrc(i)='ktop is less than kbcon+1' +#endif + go to 42 + endif + if(ktop(i).gt.ktf-2)then + ierr(i)=5 +#ifndef _OPENACC + ierrc(i)="ktop is larger than ktf-2" +#endif + go to 42 + endif +! + call get_cloud_bc(kte,qo_cup (i,1:kte),qaver,k22(i),zero) + qaver = qaver + zqexec(i) + do k=1,start_level(i)-1 + qco (i,k)= qo_cup(i,k) + enddo + k=start_level(i) + qco (i,k)= qaver +! +!$acc loop seq + do k=start_level(i)+1,ktop(i) + trash=qeso_cup(i,k)+(1./xlv)*(gammao_cup(i,k) & + /(1.+gammao_cup(i,k)))*dbyo(i,k) + !- total water liq+vapour + trash2 = qco(i,k-1) ! +qrco(i,k-1) + qco (i,k)= (trash2* ( zuo(i,k-1)-0.5*up_massdetr(i,k-1)) + & + up_massentr(i,k-1)*qo(i,k-1)) / & + (zuo(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)) + + if(qco(i,k)>=trash ) then + dz=z_cup(i,k)-z_cup(i,k-1) + ! cloud liquid water + c1d(i,k)=.02*up_massdetr(i,k-1) + qrco(i,k)= (qco(i,k)-trash)/(1.+(c0_shal+c1d(i,k))*dz) + if(qrco(i,k).lt.0.)then ! hli new test 02/12/19 + qrco(i,k)=0. + c1d(i,k)=0. + endif + pwo(i,k)=c0_shal*dz*qrco(i,k)*zuo(i,k) + ! cloud water vapor + qco (i,k)= trash+qrco(i,k) + + else + qrco(i,k)= 0.0 + endif + cupclw(i,k)=qrco(i,k) + enddo + trash=0. + trash2=0. +!$acc loop independent + do k=k22(i)+1,ktop(i) + dp=100.*(po_cup(i,k)-po_cup(i,k+1)) + cnvwt(i,k)=zuo(i,k)*cupclw(i,k)*g/dp +!$acc atomic + trash2=trash2+entr_rate_2d(i,k) +!$acc atomic + qco(i,k)=qco(i,k)-qrco(i,k) + enddo +!$acc loop independent + do k=k22(i)+1,max(kbcon(i),k22(i)+1) +!$acc atomic + trash=trash+entr_rate_2d(i,k) + enddo +!$acc loop independent + do k=ktop(i)+1,ktf-1 + hc (i,k)=hes_cup (i,k) + hco (i,k)=heso_cup(i,k) + qco (i,k)=qeso_cup(i,k) + uc(i,k)=u_cup(i,k) + vc(i,k)=v_cup(i,k) + qrco(i,k)=0. + dby (i,k)=0. + dbyo(i,k)=0. + zu (i,k)=0. + xzu (i,k)=0. + zuo (i,k)=0. + enddo + 42 continue +!$acc end parallel +! +!--- calculate workfunctions for updrafts +! + if(make_calc_for_xk) then + call cup_up_aa0(aa0,z,zu,dby,gamma_cup,t_cup, & + kbcon,ktop,ierr, & + itf,ktf, its,ite, kts,kte) + call cup_up_aa0(aa1,zo,zuo,dbyo,gammao_cup,tn_cup, & + kbcon,ktop,ierr, & + itf,ktf, its,ite, kts,kte) +!$acc kernels + do i=its,itf + if(ierr(i) == 0)then + if(aa1(i) <= 0.)then + ierr(i)=17 +#ifndef _OPENACC + ierrc(i)="cloud work function zero" +#endif + endif + endif + enddo +!$acc end kernels + endif +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! +!--- change per unit mass that a model cloud would modify the environment +! +!--- 1. in bottom layer +! +!$acc kernels + do k=kts,kte + do i=its,itf + dellah(i,k)=0. + dellaq(i,k)=0. + dellaqc(i,k)=0. + dellu (i,k)=0. + dellv (i,k)=0. + enddo + enddo +!$acc end kernels +! +!---------------------------------------------- cloud level ktop +! +!- - - - - - - - - - - - - - - - - - - - - - - - model level ktop-1 +! . . . +! . . . +! . . . +! . . . +! . . . +! . . . +! +!---------------------------------------------- cloud level k+2 +! +!- - - - - - - - - - - - - - - - - - - - - - - - model level k+1 +! +!---------------------------------------------- cloud level k+1 +! +!- - - - - - - - - - - - - - - - - - - - - - - - model level k +! +!---------------------------------------------- cloud level k +! +! . . . +! . . . +! . . . +! . . . +! . . . +! . . . +! . . . +! . . . +! . . . +! . . . +! +!---------------------------------------------- cloud level 3 +! +!- - - - - - - - - - - - - - - - - - - - - - - - model level 2 +! +!---------------------------------------------- cloud level 2 +! +!- - - - - - - - - - - - - - - - - - - - - - - - model level 1 + trash2=0. +!$acc kernels +!$acc loop independent + do i=its,itf + if(ierr(i).eq.0)then + dp=100.*(po_cup(i,1)-po_cup(i,2)) + dellu(i,1)= -zuo(i,2)*(uc (i,2)-u_cup(i,2)) *g/dp + dellv(i,1)= -zuo(i,2)*(vc (i,2)-v_cup(i,2)) *g/dp + dellah(i,1)=-zuo(i,2)*(hco(i,2)-heo_cup(i,2))*g/dp + + dellaq (i,1)=-zuo(i,2)*(qco(i,2)-qo_cup(i,2))*g/dp + + do k=k22(i),ktop(i) + ! entrainment/detrainment for updraft + entup=up_massentro(i,k) + detup=up_massdetro(i,k) + totmas=detup-entup+zuo(i,k+1)-zuo(i,k) +#ifndef _OPENACC + if(abs(totmas).gt.1.e-6)then + write(0,*)'*********************',i,k,totmas + write(0,*)k22(i),kbcon(i),ktop(i) + endif +#endif + dp=100.*(po_cup(i,k)-po_cup(i,k+1)) + dellah(i,k) =-(zuo(i,k+1)*(hco(i,k+1)-heo_cup(i,k+1) )- & + zuo(i,k )*(hco(i,k )-heo_cup(i,k ) ))*g/dp + + !-- take out cloud liquid water for detrainment + dz=zo_cup(i,k+1)-zo_cup(i,k) + if(k.lt.ktop(i) .and. c1d(i,k) > 0)then + dellaqc(i,k)= zuo(i,k)*c1d(i,k)*qrco(i,k)*dz/dp*g ! detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp + else + dellaqc(i,k)=detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp +! dellaqc(i,k)= detup*qrco(i,k) *g/dp + endif + + !-- condensation source term = detrained + flux divergence of + !-- cloud liquid water (qrco) + c_up = dellaqc(i,k)+(zuo(i,k+1)* qrco(i,k+1) - & + zuo(i,k )* qrco(i,k ) )*g/dp +! c_up = dellaqc(i,k) + !-- water vapor budget (flux divergence of q_up-q_env - condensation + !term) + dellaq(i,k) =-(zuo(i,k+1)*(qco(i,k+1)-qo_cup(i,k+1) ) - & + zuo(i,k )*(qco(i,k )-qo_cup(i,k ) ) )*g/dp & + - c_up - 0.5*(pwo (i,k)+pwo (i,k+1))*g/dp + dellu(i,k) =-(zuo(i,k+1)*(uc (i,k+1)-u_cup(i,k+1) ) - & + zuo(i,k )*(uc (i,k )-u_cup(i,k ) ) )*g/dp + dellv(i,k) =-(zuo(i,k+1)*(vc (i,k+1)-v_cup(i,k+1) ) - & + zuo(i,k )*(vc (i,k )-v_cup(i,k ) ) )*g/dp + + enddo + endif + enddo +!$acc end kernels + +! +!--- using dellas, calculate changed environmental profiles +! + mbdt=.5 !3.e-4 +!$acc kernels + do k=kts,ktf + do i=its,itf + dellat(i,k)=0. + if(ierr(i)/=0)cycle + xhe(i,k)=dellah(i,k)*mbdt+heo(i,k) + xq (i,k)=max(1.e-16,(dellaq(i,k)+dellaqc(i,k))*mbdt+qo(i,k)) + dellat(i,k)=(1./cp)*(dellah(i,k)-xlv*(dellaq(i,k))) + xt (i,k)= (-dellaqc(i,k)*xlv/cp+dellat(i,k))*mbdt+tn(i,k) + xt (i,k)= max(190.,xt(i,k)) + + enddo + enddo + do i=its,itf + if(ierr(i).eq.0)then +! xhkb(i)=hkbo(i)+(dellah(i,k22(i)))*mbdt + xhe(i,ktf)=heo(i,ktf) + xq(i,ktf)=qo(i,ktf) + xt(i,ktf)=tn(i,ktf) + endif + enddo +!$acc end kernels +! +! + if(make_calc_for_xk) then +! +!--- calculate moist static energy, heights, qes +! + call cup_env(xz,xqes,xhe,xhes,xt,xq,po,z1, & + psur,ierr,tcrit,-1, & + itf,ktf, & + its,ite, kts,kte) +! +!--- environmental values on cloud levels +! + call cup_env_clev(xt,xqes,xq,xhe,xhes,xz,po,xqes_cup,xq_cup, & + xhe_cup,xhes_cup,xz_cup,po_cup,gamma_cup,xt_cup,psur, & + ierr,z1, & + itf,ktf, & + its,ite, kts,kte) +! +! +!**************************** static control +!$acc kernels + do k=kts,ktf + do i=its,itf + xhc(i,k)=0. + xdby(i,k)=0. + enddo + enddo +!$acc end kernels + +!$acc parallel loop private(x_add) + do i=its,itf + if(ierr(i).eq.0)then + x_add = xlv*zqexec(i)+cp*ztexec(i) + call get_cloud_bc(kte,xhe_cup (i,1:kte),xhkb (i),k22(i),x_add) + do k=1,start_level(i)-1 + xhc(i,k)=xhe_cup(i,k) + enddo + k=start_level(i) + xhc(i,k)=xhkb(i) + endif !ierr + enddo +!$acc end parallel +! +! +!$acc kernels + do i=its,itf + if(ierr(i).eq.0)then + xzu(i,1:ktf)=zuo(i,1:ktf) +!$acc loop seq + do k=start_level(i)+1,ktop(i) + xhc(i,k)=(xhc(i,k-1)*xzu(i,k-1)-.5*up_massdetro(i,k-1)*xhc(i,k-1)+ & + up_massentro(i,k-1)*xhe(i,k-1)) / & + (xzu(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1)) + xdby(i,k)=xhc(i,k)-xhes_cup(i,k) + enddo +!$acc loop independent + do k=ktop(i)+1,ktf + xhc (i,k)=xhes_cup(i,k) + xdby(i,k)=0. + xzu (i,k)=0. + enddo + endif + enddo +!$acc end kernels + +! +!--- workfunctions for updraft +! + call cup_up_aa0(xaa0,xz,xzu,xdby,gamma_cup,xt_cup, & + kbcon,ktop,ierr, & + itf,ktf, & + its,ite, kts,kte) +! + endif +! +! +! now for shallow forcing +! +!$acc kernels +!$acc loop private(xff_shal) + do i=its,itf + xmb(i)=0. + xff_shal(1:3)=0. + if(ierr(i).eq.0)then + xmbmax(i)=1.0 +! xmbmax(i)=100.*(p(i,kbcon(i))-p(i,kbcon(i)+1))/(g*dtime) +! +!-stabilization closure + xkshal=(xaa0(i)-aa1(i))/mbdt + if(xkshal.le.0.and.xkshal.gt.-.01*mbdt) & + xkshal=-.01*mbdt + if(xkshal.gt.0.and.xkshal.lt.1.e-2) & + xkshal=1.e-2 + + xff_shal(1)=max(0.,-(aa1(i)-aa0(i))/(xkshal*dtime)) +! +!- closure from grant (2001) + xff_shal(2)=.03*zws(i) +!- boundary layer qe closure + blqe=0. + trash=0. + do k=1,kbcon(i) + blqe=blqe+100.*dhdt(i,k)*(po_cup(i,k)-po_cup(i,k+1))/g + enddo + trash=max((hc(i,kbcon(i))-he_cup(i,kbcon(i))),1.e1) + xff_shal(3)=max(0.,blqe/trash) + xff_shal(3)=min(xmbmax(i),xff_shal(3)) +!- average + xmb(i)=(xff_shal(1)+xff_shal(2)+xff_shal(3))/3. + xmb(i)=min(xmbmax(i),xmb(i)) + if(ichoice > 0)xmb(i)=min(xmbmax(i),xff_shal(ichoice)) + if(xmb(i) <= 0.)then + ierr(i)=21 +#ifndef _OPENACC + ierrc(i)="21" +#endif + endif + endif + if(ierr(i).ne.0)then + k22 (i)=0 + kbcon(i)=0 + ktop (i)=0 + xmb (i)=0. + outt (i,:)=0. + outu (i,:)=0. + outv (i,:)=0. + outq (i,:)=0. + outqc(i,:)=0. + else if(ierr(i).eq.0)then + xmb_out(i)=xmb(i) +! +! final tendencies +! + pre(i)=0. +!$acc loop independent + do k=2,ktop(i) + outt (i,k)= dellat (i,k)*xmb(i) + outq (i,k)= dellaq (i,k)*xmb(i) + outqc(i,k)= dellaqc(i,k)*xmb(i) +!$acc atomic + pre (i) = pre(i)+pwo(i,k)*xmb(i) + enddo + outt (i,1)= dellat (i,1)*xmb(i) + outq (i,1)= dellaq (i,1)*xmb(i) + outu(i,1)=dellu(i,1)*xmb(i) + outv(i,1)=dellv(i,1)*xmb(i) + do k=kts+1,ktop(i) + outu(i,k)=.25*(dellu(i,k-1)+2.*dellu(i,k)+dellu(i,k+1))*xmb(i) + outv(i,k)=.25*(dellv(i,k-1)+2.*dellv(i,k)+dellv(i,k+1))*xmb(i) + enddo + + endif + enddo +! +! since kinetic energy is being dissipated, add heating accordingly (from ecmwf) +! + do i=its,itf + if(ierr(i).eq.0) then + dts=0. + fpi=0. + do k=kts,ktop(i) + dp=(po_cup(i,k)-po_cup(i,k+1))*100. +!total ke dissiptaion estimate + dts= dts -(outu(i,k)*us(i,k)+outv(i,k)*vs(i,k))*dp/g +! fpi needed for calcualtion of conversion to pot. energyintegrated + fpi = fpi +sqrt(outu(i,k)*outu(i,k) + outv(i,k)*outv(i,k))*dp + enddo + if(fpi.gt.0.)then + do k=kts,ktop(i) + fp= sqrt((outu(i,k)*outu(i,k)+outv(i,k)*outv(i,k)))/fpi + outt(i,k)=outt(i,k)+fp*dts*g/cp + enddo + endif + endif + enddo +!$acc end kernels +! +! done shallow +!--------------------------done------------------------------ +! +! do k=1,30 +! print*,'hlisq',qco(1,k),qrco(1,k),pwo(1,k) +! enddo + + end subroutine cu_unified_sh_run +!> @} +end module cu_unified_sh diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index 7255f1578..b10763f2e 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -32,7 +32,7 @@ ! imp_physics_mg, iovr_rand, iovr_maxrand, iovr_max, ! ! iovr_dcorr, iovr_exp, iovr_exprand, idcor_con, ! ! idcor_hogan, idcor_oreopoulos, ! -! imfdeepcnv, imfdeepcnv_gf, do_mynnedmf, lgfdlmprad, ! +! imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_unified, do_mynnedmf, lgfdlmprad, ! ! uni_cld, lmfshal, lmfdeep2, cldcov, clouds1, ! ! effrl, effri, effrr, effrs, effr_in, ! ! effrl_inout, effri_inout, effrs_inout, ! @@ -402,7 +402,8 @@ subroutine radiation_clouds_prop & & imp_physics_mg, iovr_rand, iovr_maxrand, iovr_max, & & iovr_dcorr, iovr_exp, iovr_exprand, idcor_con, & & idcor_hogan, idcor_oreopoulos, & - & imfdeepcnv, imfdeepcnv_gf, do_mynnedmf, lgfdlmprad, & + & imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_unified, do_mynnedmf,& + & lgfdlmprad, & & uni_cld, lmfshal, lmfdeep2, cldcov, clouds1, & & effrl, effri, effrr, effrs, effr_in, & & effrl_inout, effri_inout, effrs_inout, & @@ -501,6 +502,7 @@ subroutine radiation_clouds_prop & ! idcor_oreopoulos: choice for decorrelation-length: (=2) ! imfdeepcnv : flag for mass-flux deep convection scheme ! ! imfdeepcnv_gf : flag for scale- & aerosol-aware Grell-Freitas scheme (GSD) +! imfdeepcnv_unified : flag for unified convection scheme ! do_mynnedmf : flag for MYNN-EDMF ! ! lgfdlmprad : flag for GFDLMP radiation interaction ! ! uni_cld : logical - true for cloud fraction from shoc ! @@ -751,7 +753,8 @@ subroutine radiation_clouds_prop & elseif ( imp_physics == imp_physics_nssl ) then ! NSSL MP - if(do_mynnedmf .or. imfdeepcnv == imfdeepcnv_gf ) then ! MYNN PBL or GF conv + if(do_mynnedmf .or. imfdeepcnv == imfdeepcnv_gf .or. & + imfdeepcnv == imfdeepcnv_unified) then ! MYNN PBL or GF or unified conv !-- MYNN PBL or convective GF !-- use cloud fractions with SGS clouds do k=1,NLAY @@ -790,7 +793,8 @@ subroutine radiation_clouds_prop & elseif(imp_physics == imp_physics_thompson) then ! Thompson MP - if(do_mynnedmf .or. imfdeepcnv == imfdeepcnv_gf ) then ! MYNN PBL or GF conv + if(do_mynnedmf .or. imfdeepcnv == imfdeepcnv_gf & + .or. imfdeepcnv == imfdeepcnv_unified) then ! MYNN PBL or GF conv if (icloud == 3) then call progcld_thompson (plyr,plvl,tlyr,qlyr,qstl,rhly, & ! --- inputs diff --git a/physics/sgscloud_radpre.F90 b/physics/sgscloud_radpre.F90 index ae0f39dde..7c2340279 100644 --- a/physics/sgscloud_radpre.F90 +++ b/physics/sgscloud_radpre.F90 @@ -45,6 +45,7 @@ subroutine sgscloud_radpre_run( & qr, qs, qg, & qci_conv,ud_mf, & imfdeepcnv, imfdeepcnv_gf, & + imfdeepcnv_unified, & qc_save, qi_save, qs_save, & qc_bl,qi_bl,cldfra_bl, & delp,clouds1,clouds2,clouds3, & @@ -71,7 +72,7 @@ subroutine sgscloud_radpre_run( & real :: xls, xlvcp, xlscp !derived below real(kind=kind_phys) :: gfac integer, intent(in) :: im, levs, imfdeepcnv, imfdeepcnv_gf, & - & nlay, imp_physics, imp_physics_gfdl + & imfdeepcnv_unified, nlay, imp_physics, imp_physics_gfdl logical, intent(in) :: flag_init, flag_restart, do_mynnedmf real(kind=kind_phys), dimension(:,:), intent(inout) :: qc, qi @@ -267,7 +268,7 @@ subroutine sgscloud_radpre_run( & ! At this point, we have cloud properties for all non-deep convective clouds. ! So now we add the convective clouds: - if (imfdeepcnv == imfdeepcnv_gf) then + if (imfdeepcnv == imfdeepcnv_gf .or. imfdeepcnv == imfdeepcnv_unified) then do k = 1, levs do i = 1, im !if ( qci_conv(i,k) > 0. .AND. (qi(i,k) < 1E-7 .AND. qc(i,k) < 1E-7 ) ) then @@ -354,7 +355,7 @@ subroutine sgscloud_radpre_run( & endif ! qci_conv enddo enddo - endif ! imfdeepcnv_gf + endif ! imfdeepcnv endif ! timestep > 1 diff --git a/physics/sgscloud_radpre.meta b/physics/sgscloud_radpre.meta index 28c1b7da6..57eed817d 100644 --- a/physics/sgscloud_radpre.meta +++ b/physics/sgscloud_radpre.meta @@ -232,6 +232,13 @@ dimensions = () type = integer intent = in +[imfdeepcnv_unified] + standard_name = identifier_for_unified_deep_convection + long_name = flag for Unified deep convection scheme + units = flag + dimensions = () + type = integer + intent = in [qc_save] standard_name = cloud_condensed_water_mixing_ratio_save long_name = ratio of mass of cloud water to mass of dry air plus vapor (without condensates) before entering a physics scheme From df21575243659ff74080226e422d31b7a56fb595 Mon Sep 17 00:00:00 2001 From: Lisa Bengtsson Date: Mon, 6 Mar 2023 20:15:43 +0000 Subject: [PATCH 136/380] further development --- physics/GFS_rrtmg_pre.F90 | 20 +++---- physics/cu_unified_deep.F90 | 2 + physics/cu_unified_driver.F90 | 17 +++--- physics/cu_unified_driver.meta | 7 +++ physics/cu_unified_driver_post.F90~ | 65 ++++++++++++++++++++++ physics/cu_unified_driver_pre.F90~ | 84 +++++++++++++++++++++++++++++ physics/radiation_clouds.f | 17 +++--- 7 files changed, 189 insertions(+), 23 deletions(-) create mode 100644 physics/cu_unified_driver_post.F90~ create mode 100644 physics/cu_unified_driver_pre.F90~ diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 1cc1aecf3..319099471 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -17,10 +17,10 @@ module GFS_rrtmg_pre !! \htmlinclude GFS_rrtmg_pre_run.html !! !>\section rrtmg_pre_gen General Algorithm - - subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, lextop, ltp, & - n_var_lndp, imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_unified, me, ncnd, ntrac, num_p3d, & - npdf3d, ncnvcld3d, ntqv, ntcw,ntiw, ntlnc, ntinc, ntrnc, ntsnc, ntccn, & + subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& + ltp, imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_unified, me, ncnd, ntrac, & + num_p3d, npdf3d, & + ncnvcld3d,ntqv, ntcw,ntiw, ntlnc, ntinc, ntrnc, ntsnc, ntccn, top_at_1,& ntrw, ntsw, ntgl, nthl, ntwa, ntoz, & ntclamt, nleffr, nieffr, nseffr, lndp_type, kdt, & ntdu1, ntdu2, ntdu3, ntdu4, ntdu5, ntss1, ntss2, & @@ -85,7 +85,8 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, lextop, ltp, & integer, intent(in) :: im, levs, lm, lmk, lmp, ltp, & n_var_lndp, imfdeepcnv, & - imfdeepcnv_gf, imfdeepcnv_unified, me, ncnd, ntrac, & + imfdeepcnv_gf, imfdeepcnv_unified, & + me, ncnd, ntrac, & num_p3d, npdf3d, ncnvcld3d, ntqv, & ntcw, ntiw, ntlnc, ntinc, & ntrnc, ntsnc,ntccn, & @@ -967,10 +968,11 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, lextop, ltp, & & imp_physics, imp_physics_nssl, imp_physics_fer_hires, & & imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, & & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & - & imp_physics_mg, iovr_rand, iovr_maxrand, iovr_max, & - & iovr_dcorr, iovr_exp, iovr_exprand, idcor_con, & - & idcor_hogan, idcor_oreopoulos, & - & imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_unified, do_mynnedmf, lgfdlmprad, & + & imp_physics_mg, iovr, iovr_rand, iovr_maxrand, iovr_max, & + & iovr_dcorr, iovr_exp, iovr_exprand, idcor, idcor_con, & + & idcor_hogan, idcor_oreopoulos, lcrick, lcnorm, & + & imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_gf, do_mynnedmf, & + & lgfdlmprad, & & uni_cld, lmfshal, lmfdeep2, cldcov, clouds1, & & effrl, effri, effrr, effrs, effr_in, & & effrl_inout, effri_inout, effrs_inout, & diff --git a/physics/cu_unified_deep.F90 b/physics/cu_unified_deep.F90 index 902fd60fc..76526c741 100644 --- a/physics/cu_unified_deep.F90 +++ b/physics/cu_unified_deep.F90 @@ -98,6 +98,7 @@ subroutine cu_unified_deep_run( & ,hfx & ! w/m2, positive upward ,qfx & ! w/m2, positive upward ,dx & ! dx is grid point dependent here + ,do_ca & ! Flag to turn on cellular automata ,ca_deep & ! cellular automaton for deep convection ,mconv & ! integrated vertical advection of moisture ,omeg & ! omega (pa/s) @@ -368,6 +369,7 @@ subroutine cu_unified_deep_run( & integer :: jprnt,jmini,start_k22 logical :: keep_going,flg(its:ite) + logical :: do_ca !$acc declare create(flg) character*50 :: ierrc(its:ite) diff --git a/physics/cu_unified_driver.F90 b/physics/cu_unified_driver.F90 index 5ce640d5c..478fd254a 100644 --- a/physics/cu_unified_driver.F90 +++ b/physics/cu_unified_driver.F90 @@ -57,9 +57,9 @@ end subroutine cu_unified_driver_init !! !>\section gen_unified_driver Grell-Freitas Cumulus Scheme Driver General Algorithm subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& - cactiv,cactiv_m,g,cp,xlv,r_v,forcet,forceqv_spechum,phil,raincv, & + do_ca,cactiv,cactiv_m,g,cp,xlv,r_v,forcet,forceqv_spechum,phil,raincv, & qv_spechum,t,cld1d,us,vs,t2di,w,qv2di_spechum,p2di,psuri, & - hbot,htop,kcnv,xland,hfx2,qfx2,aod_gf,cliw,clcw, & + hbot,htop,kcnv,xland,hfx2,qfx2,aod_gf,cliw,clcw,ca_deep,rainevap,& pbl,ud_mf,dd_mf,dt_mf,cnvw_moist,cnvc,imfshalcnv, & flag_for_scnv_generic_tend,flag_for_dcnv_generic_tend, & dtend,dtidx,ntqv,ntiw,ntcw,index_of_temperature,index_of_x_wind, & @@ -92,7 +92,7 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& integer :: its,ite, jts,jte, kts,kte integer, intent(in ) :: im,km,ntracer logical, intent(in ) :: flag_init, flag_restart - logical, intent(in ) :: flag_for_scnv_generic_tend,flag_for_dcnv_generic_tend + logical, intent(in ) :: flag_for_scnv_generic_tend,flag_for_dcnv_generic_tend,do_ca real (kind=kind_phys), intent(in) :: g,cp,xlv,r_v logical, intent(in ) :: ldiag3d @@ -127,9 +127,9 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& integer, dimension (im) :: tropics !$acc declare create(tropics) ! ruc variable - real(kind=kind_phys), dimension (:), intent(in) :: hfx2,qfx2,psuri + real(kind=kind_phys), dimension (:), intent(in) :: hfx2,qfx2,psuri,ca_deep real(kind=kind_phys), dimension (:,:), intent(out) :: ud_mf,dd_mf,dt_mf - real(kind=kind_phys), dimension (:), intent(out) :: raincv,cld1d + real(kind=kind_phys), dimension (:), intent(out) :: raincv,cld1d,rainevap real(kind=kind_phys), dimension (:,:), intent(in) :: t2di,p2di !$acc declare copyin(hfx2,qfx2,psuri,t2di,p2di) !$acc declare copyout(ud_mf,dd_mf,dt_mf,raincv,cld1d) @@ -680,9 +680,10 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,hfx & ,qfx & ,dx & !hj dx(im) + ,do_ca & + ,ca_deep & ,mconv & ,omeg & - ,cactiv_m & ,cnvwtm & ,zum & @@ -703,6 +704,7 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,ktopm & ,cupclwm & ,frhm & + ,rainevap & ,ierrm & ,ierrcm & ! the following should be set to zero if not available @@ -762,6 +764,8 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,hfx & ,qfx & ,dx & !hj replace dx(im) + ,do_ca & + ,ca_deep & ,mconv & ,omeg & @@ -785,6 +789,7 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,ktop & ,cupclw & ,frhd & + ,rainevap & ,ierr & ,ierrc & ! the following should be set to zero if not available diff --git a/physics/cu_unified_driver.meta b/physics/cu_unified_driver.meta index ba989e65f..67cd71203 100644 --- a/physics/cu_unified_driver.meta +++ b/physics/cu_unified_driver.meta @@ -120,6 +120,13 @@ dimensions = () type = logical intent = in +[do_ca] + standard_name = flag_for_cellular_automata + long_name = cellular automata main switch + units = flag + dimensions = () + type = logical + intent = in [cactiv] standard_name = counter_for_grell_freitas_convection long_name = convective activity memory diff --git a/physics/cu_unified_driver_post.F90~ b/physics/cu_unified_driver_post.F90~ new file mode 100644 index 000000000..963817beb --- /dev/null +++ b/physics/cu_unified_driver_post.F90~ @@ -0,0 +1,65 @@ +!> \file cu_unified_driver_post.F90 +!! Contains code related to unified convective schemes to be used within the GFS physics suite. + +module cu_gf_driver_post + + implicit none + + private + + public :: cu_gf_driver_post_run + + contains + +!>\ingroup cu_gf_group +!> \section arg_table_cu_gf_driver_post_run Argument Table +!! \htmlinclude cu_gf_driver_post_run.html +!! + subroutine cu_gf_driver_post_run (im, t, q, prevst, prevsq, cactiv, cactiv_m, conv_act, conv_act_m, errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + ! Interface variables + integer, intent(in) :: im + real(kind_phys), intent(in) :: t(:,:) + real(kind_phys), intent(in) :: q(:,:) + real(kind_phys), intent(out) :: prevst(:,:) + real(kind_phys), intent(out) :: prevsq(:,:) + integer, intent(in) :: cactiv(:) + integer, intent(in) :: cactiv_m(:) + real(kind_phys), intent(out) :: conv_act(:) + real(kind_phys), intent(out) :: conv_act_m(:) + character(len=*), intent(out) :: errmsg +!$acc declare copyin(t,q,cactiv,cactiv_m) copyout(prevst,prevsq,conv_act,conv_act_m) + integer, intent(out) :: errflg + + ! Local variables + integer :: i + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + +!$acc kernels + prevst(:,:) = t(:,:) + prevsq(:,:) = q(:,:) + + do i = 1, im + if (cactiv(i).gt.0) then + conv_act(i) = conv_act(i)+1.0 + else + conv_act(i)=0.0 + endif + if (cactiv_m(i).gt.0) then + conv_act_m(i) = conv_act_m(i)+1.0 + else + conv_act_m(i)=0.0 + endif + enddo +!$acc end kernels + + end subroutine cu_gf_driver_post_run + +end module cu_gf_driver_post diff --git a/physics/cu_unified_driver_pre.F90~ b/physics/cu_unified_driver_pre.F90~ new file mode 100644 index 000000000..5742f8bc8 --- /dev/null +++ b/physics/cu_unified_driver_pre.F90~ @@ -0,0 +1,84 @@ +!> \file cu_unified_driver_pre.F90 +!! Contains code related to the unified convective schemes to be used within the GFS physics suite. + +module cu_gf_driver_pre + + implicit none + + private + + public :: cu_gf_driver_pre_run + + contains + +!>\ingroup cu_gf_group +!> \section arg_table_cu_gf_driver_pre_run Argument Table +!! \htmlinclude cu_gf_driver_pre_run.html +!! + subroutine cu_gf_driver_pre_run (flag_init, flag_restart, kdt, fhour, dtp, t, q, prevst, prevsq, & + forcet, forceq, cactiv, cactiv_m, conv_act, conv_act_m, & + errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + logical, intent(in) :: flag_init + logical, intent(in) :: flag_restart + integer, intent(in) :: kdt + real(kind_phys), intent(in) :: fhour + real(kind_phys), intent(in) :: dtp + real(kind_phys), intent(in) :: t(:,:) + real(kind_phys), intent(in) :: q(:,:) + real(kind_phys), intent(in) :: prevst(:,:) + real(kind_phys), intent(in) :: prevsq(:,:) +!$acc declare copyin(t,q,prevst,prevsq) + real(kind_phys), intent(out) :: forcet(:,:) + real(kind_phys), intent(out) :: forceq(:,:) + integer, intent(out) :: cactiv(:) + integer, intent(out) :: cactiv_m(:) +!$acc declare copyout(forcet,forceq,cactiv,cactiv_m) + real(kind_phys), intent(in) :: conv_act(:) + real(kind_phys), intent(in) :: conv_act_m(:) +!$acc declare copyin(conv_act,conv_act_m) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! local variables + real(kind=kind_phys) :: dtdyn + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! For restart runs, can assume that prevst and prevsq + ! are read from the restart files beforehand, same + ! for conv_act. + if(flag_init .and. .not.flag_restart) then +!$acc kernels + forcet(:,:)=0.0 + forceq(:,:)=0.0 +!$acc end kernels + else + dtdyn=3600.0*(fhour)/kdt + if(dtp > dtdyn) then +!$acc kernels + forcet(:,:)=(t(:,:) - prevst(:,:))/dtp + forceq(:,:)=(q(:,:) - prevsq(:,:))/dtp +!$acc end kernels + else +!$acc kernels + forcet(:,:)=(t(:,:) - prevst(:,:))/dtdyn + forceq(:,:)=(q(:,:) - prevsq(:,:))/dtdyn +!$acc end kernels + endif + endif + +!$acc kernels + cactiv(:)=nint(conv_act(:)) + cactiv_m(:)=nint(conv_act_m(:)) +!$acc end kernels + + end subroutine cu_gf_driver_pre_run + +end module cu_gf_driver_pre diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index 87c4f5544..3029398e9 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -344,11 +344,11 @@ subroutine radiation_clouds_prop & & imp_physics, imp_physics_nssl, imp_physics_fer_hires, & & imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, & & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & - & imp_physics_mg, iovr_rand, iovr_maxrand, iovr_max, & - & iovr_dcorr, iovr_exp, iovr_exprand, idcor_con, & - & idcor_hogan, idcor_oreopoulos, & - & imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_unified, do_mynnedmf,& - & lgfdlmprad, & + & imp_physics_mg, iovr, iovr_rand, iovr_maxrand, iovr_max, & + & iovr_dcorr, iovr_exp, iovr_exprand, idcor, idcor_con, & + & idcor_hogan, idcor_oreopoulos, lcrick, lcnorm, & + & imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_unified, & + & do_mynnedmf, lgfdlmprad, & & uni_cld, lmfshal, lmfdeep2, cldcov, clouds1, & & effrl, effri, effrr, effrs, effr_in, & & effrl_inout, effri_inout, effrs_inout, & @@ -510,7 +510,8 @@ subroutine radiation_clouds_prop & integer, intent(in) :: IX, LM, NLAY, NLP1, me, ncndl, icloud integer, intent(in) :: ntrac, ntcw, ntiw, ntrw, ntsw, ntgl, & & ntclamt - integer, intent(in) :: kdt, imfdeepcnv, imfdeepcnv_gf + integer, intent(in) :: kdt, imfdeepcnv, imfdeepcnv_gf, & + & imfdeepcnv_unified integer, intent(in) :: & & imp_physics, ! Flag for MP scheme & imp_physics_nssl, ! Flag for NSSL scheme @@ -701,7 +702,7 @@ subroutine radiation_clouds_prop & elseif ( imp_physics == imp_physics_nssl ) then ! NSSL MP if(do_mynnedmf .or. imfdeepcnv == imfdeepcnv_gf .or. & - imfdeepcnv == imfdeepcnv_unified) then ! MYNN PBL or GF or unified conv + & imfdeepcnv == imfdeepcnv_unified) then ! MYNN PBL or GF or unified conv !-- MYNN PBL or convective GF !-- use cloud fractions with SGS clouds do k=1,NLAY @@ -741,7 +742,7 @@ subroutine radiation_clouds_prop & elseif(imp_physics == imp_physics_thompson) then ! Thompson MP if(do_mynnedmf .or. imfdeepcnv == imfdeepcnv_gf & - .or. imfdeepcnv == imfdeepcnv_unified) then ! MYNN PBL or GF conv + & .or. imfdeepcnv == imfdeepcnv_unified) then ! MYNN PBL or GF conv if (icloud == 3) then call progcld_thompson (plyr,plvl,tlyr,qlyr,qstl,rhly, & ! --- inputs From 78568907b5237bb7057a20923fea6506de7c1016 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Mon, 6 Mar 2023 22:36:10 +0000 Subject: [PATCH 137/380] resolve reviewer comments in lightning code --- physics/maximum_hourly_diagnostics.meta | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/physics/maximum_hourly_diagnostics.meta b/physics/maximum_hourly_diagnostics.meta index afe533375..9fa33a667 100644 --- a/physics/maximum_hourly_diagnostics.meta +++ b/physics/maximum_hourly_diagnostics.meta @@ -239,8 +239,8 @@ kind = kind_phys intent = inout [wgrs] - standard_name = z_wind - long_name = vertical wind + standard_name = unsmoothed_nonhydrostatic_upward_air_velocity + long_name = unsmoothed non-hydrostatic upward air velocity units = m s-1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real @@ -287,31 +287,31 @@ kind = kind_phys intent = in [lightning_threat] - standard_name = lightning_threat_indices_enabled - long_name = lightning threat indices enabled + standard_name = do_lightning_threat_index_calculations + long_name = enables the lightning threat index calculations units = flag dimensions = () type = logical intent = in [ltg1_max] - standard_name = gsl_lightning_threat_index_1 - long_name = GSL lightning threat index 1 + standard_name = lightning_threat_index_1 + long_name = lightning threat index 1 units = flashes 5 min-1 dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout [ltg2_max] - standard_name = gsl_lightning_threat_index_2 - long_name = GSL lightning threat index 2 + standard_name = lightning_threat_index_2 + long_name = lightning threat index 2 units = flashes 5 min-1 dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout [ltg3_max] - standard_name = gsl_lightning_threat_index_3 - long_name = GSL lightning threat index 3 + standard_name = lightning_threat_index_3 + long_name = lightning threat index 3 units = flashes 5 min-1 dimensions = (horizontal_loop_extent) type = real From 3d36fb27569f80d8e26ae3d2bf7615ad1b5d2096 Mon Sep 17 00:00:00 2001 From: joeolson42 Date: Mon, 6 Mar 2023 22:43:14 +0000 Subject: [PATCH 138/380] Precision (kind_phys) changes to address reviewer comments --- physics/module_bl_mynn.F90 | 940 +++++++++++++++++------------------ physics/mynnedmf_wrapper.F90 | 114 ++--- 2 files changed, 527 insertions(+), 527 deletions(-) diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index b95f401c4..dab09871c 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -256,45 +256,45 @@ MODULE module_bl_mynn !=================================================================== ! From here on, these are MYNN-specific parameters: ! The parameters below depend on stability functions of module_sf_mynn. - REAL, PARAMETER :: cphm_st=5.0, cphm_unst=16.0, & - cphh_st=5.0, cphh_unst=16.0 + real(kind_phys), PARAMETER :: cphm_st=5.0, cphm_unst=16.0, & + cphh_st=5.0, cphh_unst=16.0 ! Closure constants - REAL, PARAMETER :: & - &pr = 0.74, & - &g1 = 0.235, & ! NN2009 = 0.235 - &b1 = 24.0, & - &b2 = 15.0, & ! CKmod NN2009 - &c2 = 0.729, & ! 0.729, & !0.75, & - &c3 = 0.340, & ! 0.340, & !0.352, & - &c4 = 0.0, & - &c5 = 0.2, & + real(kind_phys), PARAMETER :: & + &pr = 0.74, & + &g1 = 0.235, & ! NN2009 = 0.235 + &b1 = 24.0, & + &b2 = 15.0, & ! CKmod NN2009 + &c2 = 0.729, & ! 0.729, & !0.75, & + &c3 = 0.340, & ! 0.340, & !0.352, & + &c4 = 0.0, & + &c5 = 0.2, & &a1 = b1*( 1.0-3.0*g1 )/6.0, & ! &c1 = g1 -1.0/( 3.0*a1*b1**(1.0/3.0) ), & &c1 = g1 -1.0/( 3.0*a1*2.88449914061481660), & &a2 = a1*( g1-c1 )/( g1*pr ), & &g2 = b2/b1*( 1.0-c3 ) +2.0*a1/b1*( 3.0-2.0*c2 ) - REAL, PARAMETER :: & - &cc2 = 1.0-c2, & - &cc3 = 1.0-c3, & - &e1c = 3.0*a2*b2*cc3, & - &e2c = 9.0*a1*a2*cc2, & + real(kind_phys), PARAMETER :: & + &cc2 = 1.0-c2, & + &cc3 = 1.0-c3, & + &e1c = 3.0*a2*b2*cc3, & + &e2c = 9.0*a1*a2*cc2, & &e3c = 9.0*a2*a2*cc2*( 1.0-c5 ), & - &e4c = 12.0*a1*a2*cc2, & + &e4c = 12.0*a1*a2*cc2, & &e5c = 6.0*a1*a1 ! Constants for min tke in elt integration (qmin), max z/L in els (zmax), ! and factor for eddy viscosity for TKE (Kq = Sqfac*Km): - REAL, PARAMETER :: qmin=0.0, zmax=1.0, Sqfac=3.0 + real(kind_phys), PARAMETER :: qmin=0.0, zmax=1.0, Sqfac=3.0 ! Note that the following mixing-length constants are now specified in mym_length ! &cns=3.5, alp1=0.23, alp2=0.3, alp3=3.0, alp4=10.0, alp5=0.2 - REAL, PARAMETER :: gpw=5./3., qcgmin=1.e-8, qkemin=1.e-12 - REAL, PARAMETER :: tliq = 269. !all hydrometeors are liquid when T > tliq + real(kind_phys), PARAMETER :: gpw=5./3., qcgmin=1.e-8, qkemin=1.e-12 + real(kind_phys), PARAMETER :: tliq = 269. !all hydrometeors are liquid when T > tliq ! Constants for cloud PDF (mym_condensation) - REAL, PARAMETER :: rr2=0.7071068, rrp=0.3989423 + real(kind_phys), PARAMETER :: rr2=0.7071068, rrp=0.3989423 !>Use Canuto/Kitamura mod (remove Ric and negative TKE) (1:yes, 0:no) !!For more info, see Canuto et al. (2008 JAS) and Kitamura (Journal of the @@ -304,12 +304,12 @@ MODULE module_bl_mynn !!(above) back to NN2009 values (see commented out lines next to the !!parameters above). This only removes the negative TKE problem !!but does not necessarily improve performance - neutral impact. - REAL, PARAMETER :: CKmod=1. + real(kind_phys), PARAMETER :: CKmod=1. !>Use Ito et al. (2015, BLM) scale-aware (0: no, 1: yes). Note that this also has impacts !!on the cloud PDF and mass-flux scheme, using Honnert et al. (2011) similarity function !!for TKE in the upper PBL/cloud layer. - REAL, PARAMETER :: scaleaware=1. + real(kind_phys), PARAMETER :: scaleaware=1. !>Of the following the options, use one OR the other, not both. !>Adding top-down diffusion driven by cloud-top radiative cooling @@ -416,7 +416,7 @@ SUBROUTINE mynn_bl_driver( & INTEGER, INTENT(in) :: bl_mynn_cloudmix INTEGER, INTENT(in) :: bl_mynn_mixqt INTEGER, INTENT(in) :: icloud_bl - REAL(kind=kind_phys), INTENT(in) :: closure + real(kind_phys), INTENT(in) :: closure LOGICAL, INTENT(in) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC,& FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA, & @@ -444,80 +444,82 @@ SUBROUTINE mynn_bl_driver( & ! to prevent a crash on Cheyenne. Do not change it back without testing if the code runs ! on Cheyenne with the GNU compiler. - REAL(kind=kind_phys), INTENT(in) :: delt - REAL(kind=kind_phys), DIMENSION(:), INTENT(in) :: dx - REAL(kind=kind_phys), DIMENSION(:,:), INTENT(in) :: dz, & + real(kind_phys), INTENT(in) :: delt + real(kind_phys), DIMENSION(:), INTENT(in) :: dx + real(kind_phys), DIMENSION(:,:), INTENT(in) :: dz, & &u,v,w,th,sqv3D,p,exner,rho,T3D - REAL(kind=kind_phys), DIMENSION(:,:), INTENT(in) :: & + real(kind_phys), DIMENSION(:,:), INTENT(in) :: & &sqc3D,sqi3D,sqs3D,qni,qnc,qnwfa,qnifa,qnbca - REAL(kind=kind_phys), DIMENSION(:,:), INTENT(in):: ozone - REAL(kind=kind_phys), DIMENSION(:), INTENT(in):: ust, & + real(kind_phys), DIMENSION(:,:), INTENT(in):: ozone + real(kind_phys), DIMENSION(:), INTENT(in):: ust, & &ch,qsfc,ps,wspd - REAL(kind=kind_phys), DIMENSION(:,:), INTENT(inout) :: & + real(kind_phys), DIMENSION(:,:), INTENT(inout) :: & &Qke,Tsq,Qsq,Cov,qke_adv - REAL(kind=kind_phys), DIMENSION(:,:), INTENT(inout) :: & - &rublten,rvblten,rthblten,rqvblten,rqcblten, & - &rqiblten,rqsblten,rqniblten,rqncblten, & + real(kind_phys), DIMENSION(:,:), INTENT(inout) :: & + &rublten,rvblten,rthblten,rqvblten,rqcblten, & + &rqiblten,rqsblten,rqniblten,rqncblten, & &rqnwfablten,rqnifablten,rqnbcablten - REAL(kind=kind_phys), DIMENSION(:,:), INTENT(inout) :: dozone - REAL(kind=kind_phys), DIMENSION(:,:), INTENT(in) :: rthraten + real(kind_phys), DIMENSION(:,:), INTENT(inout) :: dozone + real(kind_phys), DIMENSION(:,:), INTENT(in) :: rthraten - REAL(kind=kind_phys), DIMENSION(:,:), INTENT(out) :: exch_h,exch_m - REAL, DIMENSION(:), INTENT(in) :: xland,ts,znt,hfx,qfx, & - &uoce,voce + real(kind_phys), DIMENSION(:,:), INTENT(out) :: exch_h,exch_m + real(kind_phys), DIMENSION(:), INTENT(in) :: xland, & + &ts,znt,hfx,qfx,uoce,voce !These 10 arrays are only allocated when bl_mynn_output > 0 - REAL(kind=kind_phys), DIMENSION(:,:), INTENT(inout) :: & - & edmf_a,edmf_w,edmf_qt,edmf_thl,edmf_ent,edmf_qc, & + real(kind_phys), DIMENSION(:,:), INTENT(inout) :: & + & edmf_a,edmf_w,edmf_qt,edmf_thl,edmf_ent,edmf_qc, & & sub_thl3D,sub_sqv3D,det_thl3D,det_sqv3D -! REAL, DIMENSION(IMS:IME,KMS:KME) :: & +! real, DIMENSION(IMS:IME,KMS:KME) :: & ! & edmf_a_dd,edmf_w_dd,edmf_qt_dd,edmf_thl_dd,edmf_ent_dd,edmf_qc_dd - REAL(kind=kind_phys), DIMENSION(:), INTENT(inout) :: Pblh - REAL, DIMENSION(:), INTENT(inout) :: rmol + real(kind_phys), DIMENSION(:), INTENT(inout) :: Pblh + real(kind_phys), DIMENSION(:), INTENT(inout) :: rmol - REAL, DIMENSION(IMS:IME) :: psig_bl,psig_shcu + real(kind_phys), DIMENSION(IMS:IME) :: psig_bl,psig_shcu - INTEGER,DIMENSION(:),INTENT(INOUT) :: & + INTEGER,DIMENSION(:),INTENT(INOUT) :: & &KPBL,nupdraft,ktop_plume - REAL(kind=kind_phys), DIMENSION(:), INTENT(out) :: maxmf + real(kind_phys), DIMENSION(:), INTENT(out) :: maxmf - REAL(kind=kind_phys), DIMENSION(:,:), INTENT(inout) :: el_pbl + real(kind_phys), DIMENSION(:,:), INTENT(inout) :: el_pbl - REAL(kind=kind_phys), DIMENSION(:,:), INTENT(out) :: & + real(kind_phys), DIMENSION(:,:), INTENT(out) :: & &qWT,qSHEAR,qBUOY,qDISS,dqke ! 3D budget arrays are not allocated when tke_budget == 0 ! 1D (local) budget arrays are used for passing between subroutines. - REAL, DIMENSION(kts:kte) :: qwt1,qshear1,qbuoy1,qdiss1, & - &dqke1,diss_heat + real(kind_phys), DIMENSION(kts:kte) :: & + &qwt1,qshear1,qbuoy1,qdiss1,dqke1,diss_heat - REAL(kind=kind_phys), DIMENSION(:,:), intent(out) :: Sh3D,Sm3D + real(kind_phys), DIMENSION(:,:), intent(out) :: Sh3D,Sm3D - REAL(kind=kind_phys), DIMENSION(:,:), INTENT(inout) :: & + real(kind_phys), DIMENSION(:,:), INTENT(inout) :: & &qc_bl,qi_bl,cldfra_bl - REAL, DIMENSION(KTS:KTE) :: qc_bl1D,qi_bl1D,cldfra_bl1D, & - qc_bl1D_old,qi_bl1D_old,cldfra_bl1D_old + real(kind_phys), DIMENSION(KTS:KTE) :: qc_bl1D,qi_bl1D, & + &cldfra_bl1D,qc_bl1D_old,qi_bl1D_old,cldfra_bl1D_old ! smoke/chemical arrays INTEGER, INTENT(IN ) :: nchem, kdvel, ndvel - REAL(kind=kind_phys), DIMENSION(:,:,:), INTENT(INOUT) :: chem3d - REAL(kind=kind_phys), DIMENSION(:,:), INTENT(IN) :: vdep - REAL(kind=kind_phys), DIMENSION(:), INTENT(IN) :: frp,EMIS_ANT_NO + real(kind_phys), DIMENSION(:,:,:), INTENT(INOUT) :: chem3d + real(kind_phys), DIMENSION(:,:), INTENT(IN) :: vdep + real(kind_phys), DIMENSION(:), INTENT(IN) :: frp,EMIS_ANT_NO !local - REAL, DIMENSION(kts:kte ,nchem) :: chem1 - REAL, DIMENSION(kts:kte+1,nchem) :: s_awchem1 - REAL, DIMENSION(ndvel) :: vd1 + real(kind_phys), DIMENSION(kts:kte ,nchem) :: chem1 + real(kind_phys), DIMENSION(kts:kte+1,nchem) :: s_awchem1 + real(kind_phys), DIMENSION(ndvel) :: vd1 INTEGER :: ic !local vars INTEGER :: ITF,JTF,KTF, IMD,JMD INTEGER :: i,j,k,kproblem - REAL, DIMENSION(KTS:KTE) :: thl,tl,qv1,qc1,qi1,qs1,sqw, & + real(kind_phys), DIMENSION(KTS:KTE) :: & + &thl,tl,qv1,qc1,qi1,qs1,sqw, & &el, dfm, dfh, dfq, tcd, qcd, pdk, pdt, pdq, pdc, & &vt, vq, sgm - REAL, DIMENSION(KTS:KTE) :: thetav,sh,sm,u1,v1,w1,p1, & + real(kind_phys), DIMENSION(KTS:KTE) :: & + &thetav,sh,sm,u1,v1,w1,p1, & &ex1,dz1,th1,tk1,rho1,qke1,tsq1,qsq1,cov1, & &sqv,sqi,sqc,sqs, & &du1,dv1,dth1,dqv1,dqc1,dqi1,dqs1,ozone1, & @@ -525,40 +527,46 @@ SUBROUTINE mynn_bl_driver( & &qnbca1,dqnwfa1,dqnifa1,dqnbca1,dozone1 !mass-flux variables - REAL, DIMENSION(KTS:KTE) :: dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf - REAL, DIMENSION(KTS:KTE) :: edmf_a1,edmf_w1,edmf_qt1, & - &edmf_thl1,edmf_ent1,edmf_qc1 - REAL, DIMENSION(KTS:KTE) :: edmf_a_dd1,edmf_w_dd1, & - &edmf_qt_dd1,edmf_thl_dd1, & + real(kind_phys), DIMENSION(KTS:KTE) :: & + &dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf + real(kind_phys), DIMENSION(KTS:KTE) :: & + &edmf_a1,edmf_w1,edmf_qt1,edmf_thl1, & + &edmf_ent1,edmf_qc1 + real(kind_phys), DIMENSION(KTS:KTE) :: & + &edmf_a_dd1,edmf_w_dd1,edmf_qt_dd1,edmf_thl_dd1, & &edmf_ent_dd1,edmf_qc_dd1 - REAL, DIMENSION(KTS:KTE) :: sub_thl,sub_sqv,sub_u,sub_v,& - det_thl,det_sqv,det_sqc,det_u,det_v - REAL,DIMENSION(KTS:KTE+1) :: s_aw1,s_awthl1,s_awqt1, & - s_awqv1,s_awqc1,s_awu1,s_awv1,s_awqke1, & - s_awqnc1,s_awqni1,s_awqnwfa1,s_awqnifa1, & - s_awqnbca1 - REAL,DIMENSION(KTS:KTE+1) :: sd_aw1,sd_awthl1,sd_awqt1, & - sd_awqv1,sd_awqc1,sd_awu1,sd_awv1,sd_awqke1 - - REAL, DIMENSION(KTS:KTE+1) :: zw - REAL :: cpm,sqcg,flt,fltv,flq,flqv,flqc,pmz,phh,exnerg,zet,phi_m,& - & afk,abk,ts_decay, qc_bl2, qi_bl2, & - & th_sfc,ztop_plume,wsp + real(kind_phys), DIMENSION(KTS:KTE) :: & + &sub_thl,sub_sqv,sub_u,sub_v, & + &det_thl,det_sqv,det_sqc,det_u,det_v + real(kind_phys), DIMENSION(KTS:KTE+1) :: & + &s_aw1,s_awthl1,s_awqt1, & + &s_awqv1,s_awqc1,s_awu1,s_awv1,s_awqke1, & + &s_awqnc1,s_awqni1,s_awqnwfa1,s_awqnifa1, & + &s_awqnbca1 + real(kind_phys), DIMENSION(KTS:KTE+1) :: & + &sd_aw1,sd_awthl1,sd_awqt1, & + &sd_awqv1,sd_awqc1,sd_awu1,sd_awv1,sd_awqke1 + + real(kind_phys), DIMENSION(KTS:KTE+1) :: zw + real(kind_phys) :: cpm,sqcg,flt,fltv,flq,flqv,flqc, & + &pmz,phh,exnerg,zet,phi_m, & + &afk,abk,ts_decay, qc_bl2, qi_bl2, & + &th_sfc,ztop_plume,wsp !top-down diffusion - REAL, DIMENSION(ITS:ITE) :: maxKHtopdown - REAL, DIMENSION(KTS:KTE) :: KHtopdown,TKEprodTD + real(kind_phys), DIMENSION(ITS:ITE) :: maxKHtopdown + real(kind_phys), DIMENSION(KTS:KTE) :: KHtopdown,TKEprodTD LOGICAL :: INITIALIZE_QKE,problem ! Stochastic fields - INTEGER, INTENT(IN) :: spp_pbl - REAL(kind=kind_phys), DIMENSION( :, :), INTENT(IN) :: pattern_spp_pbl - REAL, DIMENSION(KTS:KTE) :: rstoch_col + INTEGER, INTENT(IN) :: spp_pbl + real(kind_phys), DIMENSION(:,:), INTENT(IN) :: pattern_spp_pbl + real(kind_phys), DIMENSION(KTS:KTE) :: rstoch_col ! Substepping TKE INTEGER :: nsub - real(kind=kind_phys) :: delt2 + real(kind_phys) :: delt2 if (debug_code) then !check incoming values @@ -1502,26 +1510,27 @@ SUBROUTINE mym_initialize ( & & spp_pbl,rstoch_col) ! !------------------------------------------------------------------- - - INTEGER, INTENT(IN) :: kts,kte - INTEGER, INTENT(IN) :: bl_mynn_mixlength - LOGICAL, INTENT(IN) :: INITIALIZE_QKE -! REAL, INTENT(IN) :: ust, rmo, pmz, phh, flt, flq - REAL, INTENT(IN) :: rmo, Psig_bl, xland - REAL(kind=kind_phys), INTENT(IN) :: dx, ust, zi - REAL, DIMENSION(kts:kte), INTENT(in) :: dz - REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw - REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,qw,cldfra_bl1D,& - edmf_w1,edmf_a1 - REAL, DIMENSION(kts:kte), INTENT(out) :: tsq,qsq,cov - REAL, DIMENSION(kts:kte), INTENT(inout) :: el,qke - REAL, DIMENSION(kts:kte) :: & - &ql,pdk,pdt,pdq,pdc,dtl,dqw,dtv,& + + integer, INTENT(IN) :: kts,kte + integer, INTENT(IN) :: bl_mynn_mixlength + logical, INTENT(IN) :: INITIALIZE_QKE +! real(kind_phys), INTENT(IN) :: ust, rmo, pmz, phh, flt, flq + real(kind_phys), INTENT(IN) :: rmo, Psig_bl, xland + real(kind_phys), INTENT(IN) :: dx, ust, zi + real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: dz + real(kind_phys), DIMENSION(kts:kte+1), INTENT(in) :: zw + real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: u,v,thl,& + &qw,cldfra_bl1D,edmf_w1,edmf_a1 + real(kind_phys), DIMENSION(kts:kte), INTENT(out) :: tsq,qsq,cov + real(kind_phys), DIMENSION(kts:kte), INTENT(inout) :: el,qke + real(kind_phys), DIMENSION(kts:kte) :: & + &ql,pdk,pdt,pdq,pdc,dtl,dqw,dtv, & &gm,gh,sm,sh,qkw,vt,vq INTEGER :: k,l,lmax - REAL :: phm,vkz,elq,elv,b1l,b2l,pmz=1.,phh=1.,flt=0.,fltv=0.,flq=0.,tmpq - REAL, DIMENSION(kts:kte) :: theta,thetav - REAL, DIMENSION(kts:kte) :: rstoch_col + real(kind_phys):: phm,vkz,elq,elv,b1l,b2l,pmz=1.,phh=1., & + &flt=0.,fltv=0.,flq=0.,tmpq + real(kind_phys), DIMENSION(kts:kte) :: theta,thetav + real(kind_phys), DIMENSION(kts:kte) :: rstoch_col INTEGER ::spp_pbl !> - At first ql, vt and vq are set to zero. @@ -1706,18 +1715,19 @@ SUBROUTINE mym_level2 (kts,kte, & # define kte HARDCODE_VERTICAL #endif - REAL, DIMENSION(kts:kte), INTENT(in) :: dz - REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,qw,ql,vt,vq,& - thetav - REAL, DIMENSION(kts:kte), INTENT(out) :: & + real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: dz + real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: u,v, & + &thl,qw,ql,vt,vq,thetav + real(kind_phys), DIMENSION(kts:kte), INTENT(out) :: & &dtl,dqw,dtv,gm,gh,sm,sh - INTEGER :: k + integer :: k - REAL :: rfc,f1,f2,rf1,rf2,smc,shc,& - &ri1,ri2,ri3,ri4,duz,dtz,dqz,vtt,vqq,dtq,dzk,afk,abk,ri,rf + real(kind_phys):: rfc,f1,f2,rf1,rf2,smc,shc, & + &ri1,ri2,ri3,ri4,duz,dtz,dqz,vtt,vqq,dtq,dzk, & + &afk,abk,ri,rf - REAL :: a2fac + real(kind_phys):: a2fac ! ev = 2.5e6 ! tv0 = 0.61*tref @@ -1844,51 +1854,49 @@ SUBROUTINE mym_length ( & #endif INTEGER, INTENT(IN) :: bl_mynn_mixlength - REAL, DIMENSION(kts:kte), INTENT(in) :: dz - REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw - REAL, INTENT(in) :: rmo,flt,fltv,flq,Psig_bl,xland - REAL(kind=kind_phys), INTENT(IN) :: dx,zi - REAL, DIMENSION(kts:kte), INTENT(IN) :: u1,v1,qke,vt,vq,cldfra_bl1D,& - edmf_w1,edmf_a1 - REAL, DIMENSION(kts:kte), INTENT(out) :: qkw, el - REAL, DIMENSION(kts:kte), INTENT(in) :: dtv - - REAL :: elt,vsc - - REAL, DIMENSION(kts:kte), INTENT(IN) :: theta - REAL, DIMENSION(kts:kte) :: qtke,elBLmin,elBLavg,thetaw - REAL :: wt,wt2,zi2,h1,h2,hs,elBLmin0,elBLavg0,cldavg + real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: dz + real(kind_phys), DIMENSION(kts:kte+1), INTENT(in) :: zw + real(kind_phys), INTENT(in) :: rmo,flt,fltv,flq,Psig_bl,xland + real(kind_phys), INTENT(IN) :: dx,zi + real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: u1,v1, & + &qke,vt,vq,cldfra_bl1D,edmf_w1,edmf_a1 + real(kind_phys), DIMENSION(kts:kte), INTENT(out) :: qkw, el + real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: dtv + real(kind_phys):: elt,vsc + real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: theta + real(kind_phys), DIMENSION(kts:kte) :: qtke,elBLmin,elBLavg,thetaw + real(kind_phys):: wt,wt2,zi2,h1,h2,hs,elBLmin0,elBLavg0,cldavg ! THE FOLLOWING CONSTANTS ARE IMPORTANT FOR REGULATING THE ! MIXING LENGTHS: - REAL :: cns, & !< for surface layer (els) in stable conditions - alp1, & !< for turbulent length scale (elt) - alp2, & !< for buoyancy length scale (elb) - alp3, & !< for buoyancy enhancement factor of elb - alp4, & !< for surface layer (els) in unstable conditions - alp5, & !< for BouLac mixing length or above PBLH - alp6 !< for mass-flux/ + real(kind_phys):: cns, & !< for surface layer (els) in stable conditions + alp1, & !< for turbulent length scale (elt) + alp2, & !< for buoyancy length scale (elb) + alp3, & !< for buoyancy enhancement factor of elb + alp4, & !< for surface layer (els) in unstable conditions + alp5, & !< for BouLac mixing length or above PBLH + alp6 !< for mass-flux/ !THE FOLLOWING LIMITS DO NOT DIRECTLY AFFECT THE ACTUAL PBLH. !THEY ONLY IMPOSE LIMITS ON THE CALCULATION OF THE MIXING LENGTH !SCALES SO THAT THE BOULAC MIXING LENGTH (IN FREE ATMOS) DOES !NOT ENCROACH UPON THE BOUNDARY LAYER MIXING LENGTH (els, elb & elt). - REAL, PARAMETER :: minzi = 300. !< min mixed-layer height - REAL, PARAMETER :: maxdz = 750. !< max (half) transition layer depth + real(kind_phys), PARAMETER :: minzi = 300. !< min mixed-layer height + real(kind_phys), PARAMETER :: maxdz = 750. !< max (half) transition layer depth !! =0.3*2500 m PBLH, so the transition !! layer stops growing for PBLHs > 2.5 km. - REAL, PARAMETER :: mindz = 300. !< 300 !min (half) transition layer depth + real(kind_phys), PARAMETER :: mindz = 300. !< 300 !min (half) transition layer depth !SURFACE LAYER LENGTH SCALE MODS TO REDUCE IMPACT IN UPPER BOUNDARY LAYER - REAL, PARAMETER :: ZSLH = 100. !< Max height correlated to surface conditions (m) - REAL, PARAMETER :: CSL = 2. !< CSL = constant of proportionality to L O(1) + real(kind_phys), PARAMETER :: ZSLH = 100. !< Max height correlated to surface conditions (m) + real(kind_phys), PARAMETER :: CSL = 2. !< CSL = constant of proportionality to L O(1) INTEGER :: i,j,k - REAL :: afk,abk,zwk,zwk1,dzk,qdz,vflx,bv,tau_cloud,wstar,elb,els, & - & elf,el_stab,el_mf,el_stab_mf,elb_mf, & + real(kind_phys):: afk,abk,zwk,zwk1,dzk,qdz,vflx,bv,tau_cloud, & + & wstar,elb,els,elf,el_stab,el_mf,el_stab_mf,elb_mf, & & PBLH_PLUS_ENT,Uonset,Ugrid,wt_u,el_les - REAL, PARAMETER :: ctau = 1000. !constant for tau_cloud + real(kind_phys), PARAMETER :: ctau = 1000. !constant for tau_cloud ! tv0 = 0.61*tref ! gtr = 9.81/tref @@ -2249,14 +2257,14 @@ SUBROUTINE boulac_length0(k,kts,kte,zw,dz,qtke,theta,lb1,lb2) !------------------------------------------------------------------- INTEGER, INTENT(IN) :: k,kts,kte - REAL, DIMENSION(kts:kte), INTENT(IN) :: qtke,dz,theta - REAL, INTENT(OUT) :: lb1,lb2 - REAL, DIMENSION(kts:kte+1), INTENT(IN) :: zw + real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: qtke,dz,theta + real(kind_phys), INTENT(OUT) :: lb1,lb2 + real(kind_phys), DIMENSION(kts:kte+1), INTENT(IN) :: zw !LOCAL VARS INTEGER :: izz, found - REAL :: dlu,dld - REAL :: dzt, zup, beta, zup_inf, bbb, tl, zdo, zdo_sup, zzz + real(kind_phys):: dlu,dld + real(kind_phys):: dzt, zup, beta, zup_inf, bbb, tl, zdo, zdo_sup, zzz !---------------------------------- @@ -2399,15 +2407,15 @@ SUBROUTINE boulac_length(kts,kte,zw,dz,qtke,theta,lb1,lb2) !------------------------------------------------------------------- INTEGER, INTENT(IN) :: kts,kte - REAL, DIMENSION(kts:kte), INTENT(IN) :: qtke,dz,theta - REAL, DIMENSION(kts:kte), INTENT(OUT) :: lb1,lb2 - REAL, DIMENSION(kts:kte+1), INTENT(IN) :: zw + real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: qtke,dz,theta + real(kind_phys), DIMENSION(kts:kte), INTENT(OUT):: lb1,lb2 + real(kind_phys), DIMENSION(kts:kte+1), INTENT(IN) :: zw !LOCAL VARS INTEGER :: iz, izz, found - REAL, DIMENSION(kts:kte) :: dlu,dld - REAL, PARAMETER :: Lmax=2000. !soft limit - REAL :: dzt, zup, beta, zup_inf, bbb, tl, zdo, zdo_sup, zzz + real(kind_phys), DIMENSION(kts:kte) :: dlu,dld + real(kind_phys), PARAMETER :: Lmax=2000. !soft limit + real(kind_phys):: dzt, zup, beta, zup_inf, bbb, tl, zdo, zdo_sup, zzz !print*,"IN MYNN-BouLac",kts, kte @@ -2619,39 +2627,38 @@ SUBROUTINE mym_turbulence ( & # define kte HARDCODE_VERTICAL #endif - INTEGER, INTENT(IN) :: bl_mynn_mixlength,tke_budget - REAL(kind=kind_phys), INTENT(IN) :: closure - REAL, DIMENSION(kts:kte), INTENT(in) :: dz - REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw - REAL, INTENT(in) :: rmo,flt,fltv,flq,Psig_bl,Psig_shcu,xland - REAL(kind=kind_phys), INTENT(IN) :: dx,zi - REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,thetav,qw, & - &ql,vt,vq,qke,tsq,qsq,cov,cldfra_bl1D,edmf_w1,edmf_a1, & + INTEGER, INTENT(IN) :: bl_mynn_mixlength,tke_budget + real(kind_phys), INTENT(IN) :: closure + real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: dz + real(kind_phys), DIMENSION(kts:kte+1), INTENT(in) :: zw + real(kind_phys), INTENT(in) :: rmo,flt,fltv,flq, & + &Psig_bl,Psig_shcu,xland,dx,zi + real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: u,v,thl,thetav,qw, & + &ql,vt,vq,qke,tsq,qsq,cov,cldfra_bl1D,edmf_w1,edmf_a1, & &TKEprodTD - REAL, DIMENSION(kts:kte), INTENT(out) :: dfm,dfh,dfq, & + real(kind_phys), DIMENSION(kts:kte), INTENT(out) :: dfm,dfh,dfq, & &pdk,pdt,pdq,pdc,tcd,qcd,el - REAL, DIMENSION(kts:kte), INTENT(inout) :: & + real(kind_phys), DIMENSION(kts:kte), INTENT(inout) :: & qWT1D,qSHEAR1D,qBUOY1D,qDISS1D - REAL :: q3sq_old,dlsq1,qWTP_old,qWTP_new - REAL :: dudz,dvdz,dTdz, & - upwp,vpwp,Tpwp + real(kind_phys):: q3sq_old,dlsq1,qWTP_old,qWTP_new + real(kind_phys):: dudz,dvdz,dTdz,upwp,vpwp,Tpwp - REAL, DIMENSION(kts:kte) :: qkw,dtl,dqw,dtv,gm,gh,sm,sh + real(kind_phys), DIMENSION(kts:kte) :: qkw,dtl,dqw,dtv,gm,gh,sm,sh INTEGER :: k -! REAL :: cc2,cc3,e1c,e2c,e3c,e4c,e5c - REAL :: e6c,dzk,afk,abk,vtt,vqq, & +! real(kind_phys):: cc2,cc3,e1c,e2c,e3c,e4c,e5c + real(kind_phys):: e6c,dzk,afk,abk,vtt,vqq, & &cw25,clow,cupp,gamt,gamq,smd,gamv,elq,elh - REAL :: cldavg - REAL, DIMENSION(kts:kte), INTENT(in) :: theta + real(kind_phys):: cldavg + real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: theta - REAL :: a2fac, duz, ri !JOE-Canuto/Kitamura mod + real(kind_phys):: a2fac, duz, ri !JOE-Canuto/Kitamura mod - REAL:: auh,aum,adh,adm,aeh,aem,Req,Rsl,Rsl2, & - gmelq,sm20,sh20,sm25max,sh25max,sm25min,sh25min, & + real:: auh,aum,adh,adm,aeh,aem,Req,Rsl,Rsl2, & + gmelq,sm20,sh20,sm25max,sh25max,sm25min,sh25min, & sm_pbl,sh_pbl,zi2,wt,slht,wtpr DOUBLE PRECISION q2sq, t2sq, r2sq, c2sq, elsq, gmel, ghel @@ -2659,11 +2666,10 @@ SUBROUTINE mym_turbulence ( & DOUBLE PRECISION e1, e2, e3, e4, enum, eden, wden ! Stochastic - INTEGER, INTENT(IN) :: spp_pbl - REAL, DIMENSION(KTS:KTE) :: rstoch_col - REAL :: Prnum, shb - REAL, PARAMETER :: Prlimit = 5.0 - + INTEGER, INTENT(IN) :: spp_pbl + real(kind_phys), DIMENSION(KTS:KTE) :: rstoch_col + real(kind_phys):: Prnum, shb + real(kind_phys), PARAMETER :: Prlimit = 5.0 ! ! tv0 = 0.61*tref @@ -3191,29 +3197,29 @@ SUBROUTINE mym_predict (kts,kte, & # define kte HARDCODE_VERTICAL #endif - REAL(kind=kind_phys), INTENT(IN) :: closure + real(kind_phys), INTENT(IN) :: closure INTEGER, INTENT(IN) :: bl_mynn_edmf_tke,tke_budget - REAL, DIMENSION(kts:kte), INTENT(IN) :: dz, dfq, el, rho - REAL, DIMENSION(kts:kte), INTENT(INOUT) :: pdk, pdt, pdq, pdc - REAL, INTENT(IN) :: flt, flq, pmz, phh - REAL(kind=kind_phys), INTENT(IN) :: ust, delt - REAL, DIMENSION(kts:kte), INTENT(INOUT) :: qke,tsq, qsq, cov + real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: dz, dfq, el, rho + real(kind_phys), DIMENSION(kts:kte), INTENT(INOUT) :: pdk, pdt, pdq, pdc + real(kind_phys), INTENT(IN) :: flt, flq, pmz, phh + real(kind_phys), INTENT(IN) :: ust, delt + real(kind_phys), DIMENSION(kts:kte), INTENT(INOUT) :: qke,tsq, qsq, cov ! WA 8/3/15 - REAL, DIMENSION(kts:kte+1), INTENT(INOUT) :: s_awqke,s_aw + real(kind_phys), DIMENSION(kts:kte+1), INTENT(INOUT) :: s_awqke,s_aw !! TKE budget (Puhales, 2020, WRF 4.2.1) << EOB - REAL, DIMENSION(kts:kte), INTENT(OUT) :: qWT1D, qDISS1D - REAL, DIMENSION(kts:kte) :: tke_up,dzinv + real(kind_phys), DIMENSION(kts:kte), INTENT(OUT) :: qWT1D, qDISS1D + real(kind_phys), DIMENSION(kts:kte) :: tke_up,dzinv !! >> EOB INTEGER :: k - REAL, DIMENSION(kts:kte) :: qkw, bp, rp, df3q - REAL :: vkz,pdk1,phm,pdt1,pdq1,pdc1,b1l,b2l,onoff - REAL, DIMENSION(kts:kte) :: dtz - REAL, DIMENSION(kts:kte) :: a,b,c,d,x + real(kind_phys), DIMENSION(kts:kte) :: qkw, bp, rp, df3q + real(kind_phys):: vkz,pdk1,phm,pdt1,pdq1,pdc1,b1l,b2l,onoff + real(kind_phys), DIMENSION(kts:kte) :: dtz + real(kind_phys), DIMENSION(kts:kte) :: a,b,c,d,x - REAL, DIMENSION(kts:kte) :: rhoinv - REAL, DIMENSION(kts:kte+1) :: rhoz,kqdz,kmdz + real(kind_phys), DIMENSION(kts:kte) :: rhoinv + real(kind_phys), DIMENSION(kts:kte+1) :: rhoz,kqdz,kmdz ! REGULATE THE MOMENTUM MIXING FROM THE MASS-FLUX SCHEME (on or off) IF (bl_mynn_edmf_tke == 0) THEN @@ -3599,45 +3605,45 @@ SUBROUTINE mym_condensation (kts,kte, & # define kte HARDCODE_VERTICAL #endif - REAL, INTENT(IN) :: HFX1,rmo,xland - REAL(kind=kind_phys), INTENT(IN) :: dx,pblh1 - REAL, DIMENSION(kts:kte), INTENT(IN) :: dz - REAL, DIMENSION(kts:kte+1), INTENT(IN) :: zw - REAL, DIMENSION(kts:kte), INTENT(IN) :: p,exner,thl,qw,qv,qc,qi,qs, & - &tsq, qsq, cov, th + real(kind_phys), INTENT(IN) :: HFX1,rmo,xland + real(kind_phys), INTENT(IN) :: dx,pblh1 + real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: dz + real(kind_phys), DIMENSION(kts:kte+1), INTENT(IN) :: zw + real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: p,exner,thl,qw, & + &qv,qc,qi,qs,tsq,qsq,cov,th - REAL, DIMENSION(kts:kte), INTENT(INOUT) :: vt,vq,sgm + real(kind_phys), DIMENSION(kts:kte), INTENT(INOUT) :: vt,vq,sgm - REAL, DIMENSION(kts:kte) :: alp,a,bet,b,ql,q1,RH - REAL, DIMENSION(kts:kte), INTENT(OUT) :: qc_bl1D,qi_bl1D, & - cldfra_bl1D + real(kind_phys), DIMENSION(kts:kte) :: alp,a,bet,b,ql,q1,RH + real(kind_phys), DIMENSION(kts:kte), INTENT(OUT) :: qc_bl1D,qi_bl1D, & + &cldfra_bl1D DOUBLE PRECISION :: t3sq, r3sq, c3sq - REAL :: qsl,esat,qsat,dqsl,cld0,q1k,qlk,eq1,qll,& - &q2p,pt,rac,qt,t,xl,rsl,cpm,Fng,qww,alpha,beta,bb,& - &ls,wt,cld_factor,fac_damp,liq_frac,ql_ice,ql_water,& + real(kind_phys):: qsl,esat,qsat,dqsl,cld0,q1k,qlk,eq1,qll, & + &q2p,pt,rac,qt,t,xl,rsl,cpm,Fng,qww,alpha,beta,bb, & + &ls,wt,cld_factor,fac_damp,liq_frac,ql_ice,ql_water, & &qmq,qsat_tk,q1_rh,rh_hack - REAL, PARAMETER :: rhcrit=0.83 !for hom pdf min sigma + real(kind_phys), PARAMETER :: rhcrit=0.83 !for hom pdf min sigma INTEGER :: i,j,k - REAL :: erf + real(kind_phys):: erf !VARIABLES FOR ALTERNATIVE SIGMA - REAL::dth,dtl,dqw,dzk,els - REAL, DIMENSION(kts:kte), INTENT(IN) :: Sh,el + real:: dth,dtl,dqw,dzk,els + real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: Sh,el !variables for SGS BL clouds - REAL :: zagl,damp,PBLH2 - REAL :: cfmax + real(kind_phys) :: zagl,damp,PBLH2 + real(kind_phys) :: cfmax !JAYMES: variables for tropopause-height estimation - REAL :: theta1, theta2, ht1, ht2 - INTEGER :: k_tropo + real(kind_phys) :: theta1, theta2, ht1, ht2 + INTEGER :: k_tropo ! Stochastic - INTEGER, INTENT(IN) :: spp_pbl - REAL, DIMENSION(KTS:KTE) :: rstoch_col - REAL :: qw_pert + INTEGER, INTENT(IN) :: spp_pbl + real(kind_phys), DIMENSION(KTS:KTE) :: rstoch_col + real(kind_phys) :: qw_pert ! First, obtain an estimate for the tropopause height (k), using the method employed in the ! Thompson subgrid-cloud scheme. This height will be a consideration later when determining @@ -4035,46 +4041,47 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & ! flq - surface flux of qw ! mass-flux plumes - REAL, DIMENSION(kts:kte+1), INTENT(in) :: s_aw,s_awthl,s_awqt, & - &s_awqnc,s_awqni,s_awqv,s_awqc,s_awu,s_awv, & + real(kind_phys), DIMENSION(kts:kte+1), INTENT(in) :: s_aw, & + &s_awthl,s_awqt,s_awqnc,s_awqni,s_awqv,s_awqc,s_awu,s_awv, & &s_awqnwfa,s_awqnifa,s_awqnbca, & &sd_aw,sd_awthl,sd_awqt,sd_awqv,sd_awqc,sd_awu,sd_awv ! tendencies from mass-flux environmental subsidence and detrainment - REAL, DIMENSION(kts:kte), INTENT(in) :: sub_thl,sub_sqv, & + real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: sub_thl,sub_sqv, & &sub_u,sub_v,det_thl,det_sqv,det_sqc,det_u,det_v - REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,th,tk,qv,qc,qi,qs,qni,qnc,& - &rho,p,exner,dfq,dz,tsq,qsq,cov,tcd,qcd,cldfra_bl1d,diss_heat - REAL, DIMENSION(kts:kte), INTENT(inout) :: thl,sqw,sqv,sqc,sqi,sqs, & - &qnwfa,qnifa,qnbca,ozone,dfm,dfh - REAL, DIMENSION(kts:kte), INTENT(inout) :: du,dv,dth,dqv,dqc,dqi,dqs, & - &dqni,dqnc,dqnwfa,dqnifa,dqnbca,dozone - REAL, INTENT(IN) :: flt,flq,flqv,flqc,uoce,voce - REAL(kind=kind_phys), INTENT(IN) :: ust,delt,psfc,wspd + real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: u,v,th,tk,qv,qc,qi,& + &qs,qni,qnc,rho,p,exner,dfq,dz,tsq,qsq,cov,tcd,qcd, & + &cldfra_bl1d,diss_heat + real(kind_phys), DIMENSION(kts:kte), INTENT(inout) :: thl,sqw,sqv,sqc,& + &sqi,sqs,qnwfa,qnifa,qnbca,ozone,dfm,dfh + real(kind_phys), DIMENSION(kts:kte), INTENT(inout) :: du,dv,dth,dqv, & + &dqc,dqi,dqs,dqni,dqnc,dqnwfa,dqnifa,dqnbca,dozone + real(kind_phys), INTENT(IN) :: flt,flq,flqv,flqc,uoce,voce + real(kind_phys), INTENT(IN) :: ust,delt,psfc,wspd !debugging - REAL ::wsp,wsp2,tk2,th2 + real(kind_phys):: wsp,wsp2,tk2,th2 LOGICAL :: problem integer :: kproblem -! REAL, INTENT(IN) :: gradu_top,gradv_top,gradth_top,gradqv_top +! real(kind_phys), INTENT(IN) :: gradu_top,gradv_top,gradth_top,gradqv_top !local vars - REAL, DIMENSION(kts:kte) :: dtz,dfhc,dfmc,delp - REAL, DIMENSION(kts:kte) :: sqv2,sqc2,sqi2,sqs2,sqw2,qni2,qnc2, & !AFTER MIXING - qnwfa2,qnifa2,qnbca2,ozone2 - REAL, DIMENSION(kts:kte) :: zfac,plumeKh,rhoinv - REAL, DIMENSION(kts:kte) :: a,b,c,d,x - REAL, DIMENSION(kts:kte+1) :: rhoz, & !rho on model interface - & khdz, kmdz - REAL :: rhs,gfluxm,gfluxp,dztop,maxdfh,mindfh,maxcf,maxKh,zw - REAL :: t,esat,qsl,onoff,kh,km,dzk,rhosfc - REAL :: ustdrag,ustdiff,qvflux - REAL :: th_new,portion_qc,portion_qi,condensate,qsat + real(kind_phys), DIMENSION(kts:kte) :: dtz,dfhc,dfmc,delp + real(kind_phys), DIMENSION(kts:kte) :: sqv2,sqc2,sqi2,sqs2,sqw2, & + &qni2,qnc2,qnwfa2,qnifa2,qnbca2,ozone2 + real(kind_phys), DIMENSION(kts:kte) :: zfac,plumeKh,rhoinv + real(kind_phys), DIMENSION(kts:kte) :: a,b,c,d,x + real(kind_phys), DIMENSION(kts:kte+1) :: rhoz, & !rho on model interface + &khdz,kmdz + real(kind_phys):: rhs,gfluxm,gfluxp,dztop,maxdfh,mindfh,maxcf,maxKh,zw + real(kind_phys):: t,esat,qsl,onoff,kh,km,dzk,rhosfc + real(kind_phys):: ustdrag,ustdiff,qvflux + real(kind_phys):: th_new,portion_qc,portion_qi,condensate,qsat INTEGER :: k,kk !Activate nonlocal mixing from the mass-flux scheme for !number concentrations and aerosols (0.0 = no; 1.0 = yes) - REAL, PARAMETER :: nonloc = 1.0 + real(kind_phys), PARAMETER :: nonloc = 1.0 dztop=.5*(dz(kte)+dz(kte-1)) @@ -5095,8 +5102,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & END SUBROUTINE mynn_tendencies ! ================================================================== - SUBROUTINE moisture_check(kte, delt, dp, exner, & - qv, qc, qi, qs, th, & + SUBROUTINE moisture_check(kte, delt, dp, exner, & + qv, qc, qi, qs, th, & dqv, dqc, dqi, dqs, dth ) ! This subroutine was adopted from the CAM-UW ShCu scheme and @@ -5113,16 +5120,16 @@ SUBROUTINE moisture_check(kte, delt, dp, exner, & ! applying corresponding input tendencies and corrective tendencies. implicit none - integer, intent(in) :: kte - real(kind=kind_phys), intent(in) :: delt - real, dimension(kte), intent(in) :: dp, exner - real, dimension(kte), intent(inout) :: qv, qc, qi, qs, th - real, dimension(kte), intent(inout) :: dqv, dqc, dqi, dqs, dth + integer, intent(in) :: kte + real(kind_phys), intent(in) :: delt + real(kind_phys), dimension(kte), intent(in) :: dp, exner + real(kind_phys), dimension(kte), intent(inout) :: qv, qc, qi, qs, th + real(kind_phys), dimension(kte), intent(inout) :: dqv, dqc, dqi, dqs, dth integer k - real :: dqc2, dqi2, dqs2, dqv2, sum, aa, dum - real, parameter :: qvmin = 1e-20, & - qcmin = 0.0, & - qimin = 0.0 + real(kind_phys):: dqc2, dqi2, dqs2, dqv2, sum, aa, dum + real(kind_phys), parameter :: qvmin = 1e-20, & + qcmin = 0.0, & + qimin = 0.0 do k = kte, 1, -1 ! From the top to the surface dqc2 = max(0.0, qcmin-qc(k)) !qc deficit (>=0) @@ -5199,35 +5206,35 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, & !------------------------------------------------------------------- INTEGER, INTENT(in) :: kts,kte,i - REAL, DIMENSION(kts:kte), INTENT(IN) :: dfh,dz,tcd,qcd - REAL, DIMENSION(kts:kte), INTENT(INOUT) :: rho - REAL, INTENT(IN) :: flt - REAL(kind=kind_phys), INTENT(IN) :: delt,pblh + real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: dfh,dz,tcd,qcd + real(kind_phys), DIMENSION(kts:kte), INTENT(INOUT) :: rho + real(kind_phys), INTENT(IN) :: flt + real(kind_phys), INTENT(IN) :: delt,pblh INTEGER, INTENT(IN) :: nchem, kdvel, ndvel - REAL, DIMENSION( kts:kte+1), INTENT(IN) :: s_aw - REAL, DIMENSION( kts:kte, nchem ), INTENT(INOUT) :: chem1 - REAL, DIMENSION( kts:kte+1,nchem), INTENT(IN) :: s_awchem - REAL, DIMENSION( ndvel ), INTENT(IN) :: vd1 - REAL(kind=kind_phys), INTENT(IN) :: emis_ant_no,frp + real(kind_phys), DIMENSION( kts:kte+1), INTENT(IN) :: s_aw + real(kind_phys), DIMENSION( kts:kte, nchem ), INTENT(INOUT) :: chem1 + real(kind_phys), DIMENSION( kts:kte+1,nchem), INTENT(IN) :: s_awchem + real(kind_phys), DIMENSION( ndvel ), INTENT(IN) :: vd1 + real(kind_phys), INTENT(IN) :: emis_ant_no,frp LOGICAL, INTENT(IN) :: rrfs_sd,enh_mix,smoke_dbg !local vars - REAL, DIMENSION(kts:kte) :: dtz - REAL, DIMENSION(kts:kte) :: a,b,c,d,x - REAL :: rhs,dztop - REAL :: t,dzk - REAL :: hght - REAL :: khdz_old, khdz_back + real(kind_phys), DIMENSION(kts:kte) :: dtz + real(kind_phys), DIMENSION(kts:kte) :: a,b,c,d,x + real(kind_phys):: rhs,dztop + real(kind_phys):: t,dzk + real(kind_phys):: hght + real(kind_phys):: khdz_old, khdz_back INTEGER :: k,kk,kmaxfire ! JLS 12/21/21 INTEGER :: ic ! Chemical array loop index INTEGER, SAVE :: icall - REAL, DIMENSION(kts:kte) :: rhoinv - REAL, DIMENSION(kts:kte+1) :: rhoz,khdz - REAL, PARAMETER :: NO_threshold = 10.0 ! For anthropogenic sources - REAL, PARAMETER :: frp_threshold = 10.0 ! RAR 02/11/22: I increased the frp threshold to enhance mixing over big fires - REAL, PARAMETER :: pblh_threshold = 100.0 + real(kind_phys), DIMENSION(kts:kte) :: rhoinv + real(kind_phys), DIMENSION(kts:kte+1) :: rhoz,khdz + real(kind_phys), PARAMETER :: NO_threshold = 10.0 ! For anthropogenic sources + real(kind_phys), PARAMETER :: frp_threshold = 10.0 ! RAR 02/11/22: I increased the frp threshold to enhance mixing over big fires + real(kind_phys), PARAMETER :: pblh_threshold = 100.0 dztop=.5*(dz(kte)+dz(kte-1)) @@ -5328,13 +5335,13 @@ SUBROUTINE retrieve_exchange_coeffs(kts,kte,& INTEGER , INTENT(in) :: kts,kte - REAL, DIMENSION(KtS:KtE), INTENT(in) :: dz,dfm,dfh + real(kind_phys), DIMENSION(KtS:KtE), INTENT(in) :: dz,dfm,dfh - REAL, DIMENSION(KtS:KtE), INTENT(out) :: K_m, K_h + real(kind_phys), DIMENSION(KtS:KtE), INTENT(out) :: K_m, K_h INTEGER :: k - REAL :: dzk + real(kind_phys):: dzk K_m(kts)=0. K_h(kts)=0. @@ -5360,12 +5367,12 @@ SUBROUTINE tridiag(n,a,b,c,d) !------------------------------------------------------------------- INTEGER, INTENT(in):: n - REAL, DIMENSION(n), INTENT(in) :: a,b - REAL, DIMENSION(n), INTENT(inout) :: c,d + real(kind_phys), DIMENSION(n), INTENT(in) :: a,b + real(kind_phys), DIMENSION(n), INTENT(inout) :: c,d INTEGER :: i - REAL :: p - REAL, DIMENSION(n) :: q + real(kind_phys):: p + real(kind_phys), DIMENSION(n) :: q c(n)=0. q(1)=-c(1)/b(1) @@ -5395,10 +5402,10 @@ subroutine tridiag2(n,a,b,c,d,x) ! n - number of unknowns (levels) integer,intent(in) :: n - real, dimension(n),intent(in) :: a,b,c,d - real ,dimension(n),intent(out) :: x - real ,dimension(n) :: cp,dp - real :: m + real(kind_phys), dimension(n), intent(in) :: a,b,c,d + real(kind_phys), dimension(n), intent(out):: x + real(kind_phys), dimension(n) :: cp,dp + real(kind_phys):: m integer :: i ! initialize c-prime and d-prime @@ -5437,12 +5444,12 @@ subroutine tridiag3(kte,a,b,c,d,x) implicit none integer,intent(in) :: kte integer, parameter :: kts=1 - real, dimension(kte) :: a,b,c,d - real ,dimension(kte),intent(out) :: x + real(kind_phys), dimension(kte) :: a,b,c,d + real(kind_phys), dimension(kte), intent(out) :: x integer :: in ! integer kms,kme,kts,kte,in -! real a(kms:kme,3),c(kms:kme),x(kms:kme) +! real(kind_phys)a(kms:kme,3),c(kms:kme),x(kms:kme) do in=kte-1,kts,-1 d(in)=d(in)-c(in)*d(in+1)/b(in+1) @@ -5506,15 +5513,15 @@ SUBROUTINE GET_PBLH(KTS,KTE,zi,thetav1D,qke1D,zw1D,dz1D,landsea,kzi) # define kte HARDCODE_VERTICAL #endif - REAL(kind=kind_phys), INTENT(OUT) :: zi - REAL, INTENT(IN) :: landsea - REAL, DIMENSION(KTS:KTE), INTENT(IN) :: thetav1D, qke1D, dz1D - REAL, DIMENSION(KTS:KTE+1), INTENT(IN) :: zw1D + real(kind_phys), INTENT(OUT) :: zi + real(kind_phys), INTENT(IN) :: landsea + real(kind_phys), DIMENSION(KTS:KTE), INTENT(IN) :: thetav1D, qke1D, dz1D + real(kind_phys), DIMENSION(KTS:KTE+1), INTENT(IN) :: zw1D !LOCAL VARS - REAL :: PBLH_TKE,qtke,qtkem1,wt,maxqke,TKEeps,minthv - REAL :: delt_thv !delta theta-v; dependent on land/sea point - REAL, PARAMETER :: sbl_lim = 200. !upper limit of stable BL height (m). - REAL, PARAMETER :: sbl_damp = 400. !transition length for blending (m). + real(kind_phys):: PBLH_TKE,qtke,qtkem1,wt,maxqke,TKEeps,minthv + real(kind_phys):: delt_thv !delta theta-v; dependent on land/sea point + real(kind_phys), PARAMETER :: sbl_lim = 200. !upper limit of stable BL height (m). + real(kind_phys), PARAMETER :: sbl_damp = 400. !transition length for blending (m). INTEGER :: I,J,K,kthv,ktke,kzi !Initialize KPBL (kzi) @@ -5693,141 +5700,134 @@ SUBROUTINE DMP_mf( & #endif ! Stochastic - INTEGER, INTENT(IN) :: spp_pbl - REAL, DIMENSION(KTS:KTE) :: rstoch_col - - REAL,DIMENSION(KTS:KTE), INTENT(IN) :: U,V,W,TH,THL,TK,QT,QV,QC, & - exner,dz,THV,P,rho,qke,qnc,qni,qnwfa,qnifa,qnbca - REAL,DIMENSION(KTS:KTE+1), INTENT(IN) :: zw !height at full-sigma - REAL, INTENT(IN) :: flt,fltv,flq,flqv,Psig_shcu,landsea,ts - REAL(kind=kind_phys), INTENT(IN) :: dx,dt,ust,pblh + INTEGER, INTENT(IN) :: spp_pbl + real(kind_phys), DIMENSION(KTS:KTE) :: rstoch_col + + real(kind_phys),DIMENSION(KTS:KTE), INTENT(IN) :: & + &U,V,W,TH,THL,TK,QT,QV,QC, & + &exner,dz,THV,P,rho,qke,qnc,qni,qnwfa,qnifa,qnbca + real(kind_phys),DIMENSION(KTS:KTE+1), INTENT(IN) :: zw !height at full-sigma + real(kind_phys), INTENT(IN) :: flt,fltv,flq,flqv,Psig_shcu, & + &landsea,ts,dx,dt,ust,pblh LOGICAL, OPTIONAL :: F_QC,F_QI,F_QNC,F_QNI,F_QNWFA,F_QNIFA,F_QNBCA ! outputs - updraft properties - REAL,DIMENSION(KTS:KTE), INTENT(OUT) :: edmf_a,edmf_w, & + real(kind_phys),DIMENSION(KTS:KTE), INTENT(OUT) :: edmf_a,edmf_w, & & edmf_qt,edmf_thl,edmf_ent,edmf_qc !add one local edmf variable: - REAL,DIMENSION(KTS:KTE) :: edmf_th + real(kind_phys),DIMENSION(KTS:KTE) :: edmf_th ! output INTEGER, INTENT(OUT) :: nup2,ktop - REAL(kind=kind_phys), INTENT(OUT) :: maxmf - REAL, INTENT(OUT) :: ztop + real(kind_phys), INTENT(OUT) :: maxmf + real(kind_phys), INTENT(OUT) :: ztop ! outputs - variables needed for solver - REAL,DIMENSION(KTS:KTE+1) :: s_aw, & !sum ai*rho*wis_awphi - s_awthl, & !sum ai*rho*wi*phii - s_awqt, & - s_awqv, & - s_awqc, & - s_awqnc, & - s_awqni, & - s_awqnwfa, & - s_awqnifa, & - s_awqnbca, & - s_awu, & - s_awv, & - s_awqke, s_aw2 - - REAL,DIMENSION(KTS:KTE), INTENT(INOUT) :: qc_bl1d,cldfra_bl1d, & - qc_bl1d_old,cldfra_bl1d_old + real(kind_phys),DIMENSION(KTS:KTE+1) :: s_aw, & !sum ai*rho*wis_awphi + &s_awthl,s_awqt,s_awqv,s_awqc,s_awqnc,s_awqni, & + &s_awqnwfa,s_awqnifa,s_awqnbca,s_awu,s_awv, & + &s_awqke,s_aw2 + + real(kind_phys),DIMENSION(KTS:KTE), INTENT(INOUT) :: & + &qc_bl1d,cldfra_bl1d,qc_bl1d_old,cldfra_bl1d_old INTEGER, PARAMETER :: nup=10, debug_mf=0 !------------- local variables ------------------- ! updraft properties defined on interfaces (k=1 is the top of the ! first model layer - REAL,DIMENSION(KTS:KTE+1,1:NUP) :: UPW,UPTHL,UPQT,UPQC,UPQV, & - UPA,UPU,UPV,UPTHV,UPQKE,UPQNC, & - UPQNI,UPQNWFA,UPQNIFA,UPQNBCA + real(kind_phys),DIMENSION(KTS:KTE+1,1:NUP) :: & + &UPW,UPTHL,UPQT,UPQC,UPQV, & + &UPA,UPU,UPV,UPTHV,UPQKE,UPQNC, & + &UPQNI,UPQNWFA,UPQNIFA,UPQNBCA ! entrainment variables - REAL,DIMENSION(KTS:KTE,1:NUP) :: ENT,ENTf - INTEGER,DIMENSION(KTS:KTE,1:NUP) :: ENTi + real(kind_phys),DIMENSION(KTS:KTE,1:NUP) :: ENT,ENTf + INTEGER,DIMENSION(KTS:KTE,1:NUP) :: ENTi ! internal variables INTEGER :: K,I,k50 - REAL :: fltv2,wstar,qstar,thstar,sigmaW,sigmaQT,sigmaTH,z0, & - pwmin,pwmax,wmin,wmax,wlv,Psig_w,maxw,maxqc,wpbl - REAL :: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,QNCn,QNIn, & + real(kind_phys):: fltv2,wstar,qstar,thstar,sigmaW,sigmaQT, & + &sigmaTH,z0,pwmin,pwmax,wmin,wmax,wlv,Psig_w,maxw,maxqc,wpbl + real(kind_phys):: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,QNCn,QNIn, & QNWFAn,QNIFAn,QNBCAn, & Wn2,Wn,EntEXP,EntEXM,EntW,BCOEFF,THVkm1,THVk,Pk,rho_int ! w parameters - REAL,PARAMETER :: & - &Wa=2./3., & - &Wb=0.002, & + real(kind_phys), PARAMETER :: & + &Wa=2./3., & + &Wb=0.002, & &Wc=1.5 ! Lateral entrainment parameters ( L0=100 and ENT0=0.1) were taken from ! Suselj et al (2013, jas). Note that Suselj et al (2014,waf) use L0=200 and ENT0=0.2. - REAL,PARAMETER :: & + real(kind_phys),PARAMETER :: & & L0=100., & & ENT0=0.1 ! Implement ideas from Neggers (2016, JAMES): - REAL, PARAMETER :: Atot = 0.10 ! Maximum total fractional area of all updrafts - REAL, PARAMETER :: lmax = 1000.! diameter of largest plume - REAL, PARAMETER :: dl = 100. ! diff size of each plume - the differential multiplied by the integrand - REAL, PARAMETER :: dcut = 1.2 ! max diameter of plume to parameterize relative to dx (km) - REAL :: d != -2.3 to -1.7 ;=-1.9 in Neggers paper; power law exponent for number density (N=Cl^d). + real(kind_phys), PARAMETER :: Atot = 0.10 ! Maximum total fractional area of all updrafts + real(kind_phys), PARAMETER :: lmax = 1000.! diameter of largest plume + real(kind_phys), PARAMETER :: dl = 100. ! diff size of each plume - the differential multiplied by the integrand + real(kind_phys), PARAMETER :: dcut = 1.2 ! max diameter of plume to parameterize relative to dx (km) + real(kind_phys):: d != -2.3 to -1.7 ;=-1.9 in Neggers paper; power law exponent for number density (N=Cl^d). ! Note that changing d to -2.0 makes each size plume equally contribute to the total coverage of all plumes. ! Note that changing d to -1.7 doubles the area coverage of the largest plumes relative to the smallest plumes. - REAL :: cn,c,l,n,an2,hux,maxwidth,wspd_pbl,cloud_base,width_flx + real(kind_phys):: cn,c,l,n,an2,hux,maxwidth,wspd_pbl,cloud_base,width_flx ! chem/smoke INTEGER, INTENT(IN) :: nchem - REAL,DIMENSION(:, :) :: chem1 - REAL,DIMENSION(kts:kte+1, nchem) :: s_awchem - REAL,DIMENSION(nchem) :: chemn - REAL,DIMENSION(KTS:KTE+1,1:NUP, nchem) :: UPCHEM + real(kind_phys),DIMENSION(:, :) :: chem1 + real(kind_phys),DIMENSION(kts:kte+1, nchem) :: s_awchem + real(kind_phys),DIMENSION(nchem) :: chemn + real(kind_phys),DIMENSION(KTS:KTE+1,1:NUP, nchem) :: UPCHEM INTEGER :: ic - REAL,DIMENSION(KTS:KTE+1, nchem) :: edmf_chem + real(kind_phys),DIMENSION(KTS:KTE+1, nchem) :: edmf_chem LOGICAL, INTENT(IN) :: mix_chem !JOE: add declaration of ERF - REAL :: ERF + real(kind_phys):: ERF LOGICAL :: superadiabatic ! VARIABLES FOR CHABOUREAU-BECHTOLD CLOUD FRACTION - REAL,DIMENSION(KTS:KTE), INTENT(INOUT) :: vt, vq, sgm - REAL :: sigq,xl,rsl,cpm,a,qmq,mf_cf,Aup,Q1,diffqt,qsat_tk,& - Fng,qww,alpha,beta,bb,f,pt,t,q2p,b9,satvp,rhgrid, & + real(kind_phys),DIMENSION(KTS:KTE), INTENT(INOUT) :: vt, vq, sgm + real(kind_phys):: sigq,xl,rsl,cpm,a,qmq,mf_cf,Aup,Q1,diffqt,qsat_tk,& + Fng,qww,alpha,beta,bb,f,pt,t,q2p,b9,satvp,rhgrid, & Ac_mf,Ac_strat,qc_mf - REAL, PARAMETER :: cf_thresh = 0.5 ! only overwrite stratus CF less than this value + real(kind_phys), PARAMETER :: cf_thresh = 0.5 ! only overwrite stratus CF less than this value ! Variables for plume interpolation/saturation check - REAL,DIMENSION(KTS:KTE) :: exneri,dzi - REAL :: THp, QTp, QCp, QCs, esat, qsl - REAL :: csigma,acfac,ac_wsp,ac_cld + real(kind_phys),DIMENSION(KTS:KTE) :: exneri,dzi + real(kind_phys):: THp, QTp, QCp, QCs, esat, qsl + real(kind_phys):: csigma,acfac,ac_wsp,ac_cld !plume overshoot INTEGER :: overshoot - REAL :: bvf, Frz, dzp + real(kind_phys):: bvf, Frz, dzp !Flux limiter: not let mass-flux of heat between k=1&2 exceed (fluxportion)*(surface heat flux). !This limiter makes adjustments to the entire column. - REAL :: adjustment, flx1 - REAL, PARAMETER :: fluxportion=0.75 ! set liberally, so has minimal impact. 0.5 starts to have a noticeable impact + real(kind_phys):: adjustment, flx1 + real(kind_phys), PARAMETER :: fluxportion=0.75 ! set liberally, so has minimal impact. 0.5 starts to have a noticeable impact ! over land (decrease maxMF by 10-20%), but no impact over water. !Subsidence - REAL,DIMENSION(KTS:KTE) :: sub_thl,sub_sqv,sub_u,sub_v, & !tendencies due to subsidence - det_thl,det_sqv,det_sqc,det_u,det_v, & !tendencied due to detrainment - envm_a,envm_w,envm_thl,envm_sqv,envm_sqc, & + real(kind_phys),DIMENSION(KTS:KTE) :: sub_thl,sub_sqv,sub_u,sub_v, & !tendencies due to subsidence + det_thl,det_sqv,det_sqc,det_u,det_v, & !tendencied due to detrainment + envm_a,envm_w,envm_thl,envm_sqv,envm_sqc, & envm_u,envm_v !environmental variables defined at middle of layer - REAL,DIMENSION(KTS:KTE+1) :: envi_a,envi_w !environmental variables defined at model interface - REAL :: temp,sublim,qc_ent,qv_ent,qt_ent,thl_ent,detrate, & - detrateUV,oow,exc_fac,aratio,detturb,qc_grid,qc_sgs,& + real(kind_phys),DIMENSION(KTS:KTE+1) :: envi_a,envi_w !environmental variables defined at model interface + real(kind_phys):: temp,sublim,qc_ent,qv_ent,qt_ent,thl_ent,detrate, & + detrateUV,oow,exc_fac,aratio,detturb,qc_grid,qc_sgs, & qc_plume,exc_heat,exc_moist,tk_int - REAL, PARAMETER :: Cdet = 1./45. - REAL, PARAMETER :: dzpmax = 300. !limit dz used in detrainment - can be excessing in thick layers + real(kind_phys), PARAMETER :: Cdet = 1./45. + real(kind_phys), PARAMETER :: dzpmax = 300. !limit dz used in detrainment - can be excessing in thick layers !parameter "Csub" determines the propotion of upward vertical velocity that contributes to !environmenatal subsidence. Some portion is expected to be compensated by downdrafts instead of !gentle environmental subsidence. 1.0 assumes all upward vertical velocity in the mass-flux scheme !is compensated by "gentle" environmental subsidence. - REAL, PARAMETER :: Csub=0.25 + real(kind_phys), PARAMETER :: Csub=0.25 !Factor for the pressure gradient effects on momentum transport - REAL, PARAMETER :: pgfac = 0.00 ! Zhang and Wu showed 0.4 is more appropriate for lower troposphere - REAL :: Uk,Ukm1,Vk,Vkm1,dxsa + real(kind_phys), PARAMETER :: pgfac = 0.00 ! Zhang and Wu showed 0.4 is more appropriate for lower troposphere + real(kind_phys):: Uk,Ukm1,Vk,Vkm1,dxsa ! check the inputs ! print *,'dt',dt @@ -6080,7 +6080,7 @@ SUBROUTINE DMP_mf( & wlv=wmin+(wmax-wmin)/NUP2*(i-1) !SURFACE UPDRAFT VERTICAL VELOCITY - UPW(1,I)=wmin + REAL(i)/REAL(NUP)*(wmax-wmin) + UPW(1,I)=wmin + real(i)/real(NUP)*(wmax-wmin) !IF (UPW(1,I) > 0.5*ZW(2)/dt) UPW(1,I) = 0.5*ZW(2)/dt UPU(1,I)=(U(KTS)*DZ(KTS+1)+U(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) @@ -6814,12 +6814,12 @@ subroutine condensation_edmf(QT,THL,P,zagl,THV,QC) ! ! zero or one condensation for edmf: calculates THV and QC ! -real,intent(in) :: QT,THL,P,zagl -real,intent(out) :: THV -real,intent(inout):: QC +real(kind_phys),intent(in) :: QT,THL,P,zagl +real(kind_phys),intent(out) :: THV +real(kind_phys),intent(inout):: QC integer :: niter,i -real :: diff,exn,t,th,qs,qcold +real(kind_phys):: diff,exn,t,th,qs,qcold ! constants used from module_model_constants.F ! p1000mb @@ -6876,11 +6876,11 @@ subroutine condensation_edmf_r(QT,THL,P,zagl,THV,QC) ! zero or one condensation for edmf: calculates THL and QC ! similar to condensation_edmf but with different inputs ! -real,intent(in) :: QT,THV,P,zagl -real,intent(out) :: THL, QC +real(kind_phys),intent(in) :: QT,THV,P,zagl +real(kind_phys),intent(out) :: THL, QC integer :: niter,i -real :: diff,exn,t,th,qs,qcold +real(kind_phys):: diff,exn,t,th,qs,qcold ! number of iterations niter=50 @@ -6926,58 +6926,58 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & &rthraten ) INTEGER, INTENT(IN) :: KTS,KTE,KPBL - REAL,DIMENSION(KTS:KTE), INTENT(IN) :: U,V,TH,THL,TK,QT,QV,QC,& + real(kind_phys),DIMENSION(KTS:KTE), INTENT(IN) :: U,V,TH,THL,TK,QT,QV,QC,& THV,P,rho,exner,dz - REAL(kind=kind_phys),DIMENSION(KTS:KTE), INTENT(IN) :: rthraten + real(kind_phys),DIMENSION(KTS:KTE), INTENT(IN) :: rthraten ! zw .. heights of the downdraft levels (edges of boxes) - REAL,DIMENSION(KTS:KTE+1), INTENT(IN) :: ZW - REAL, INTENT(IN) :: WTHL,WQT - REAL(kind=kind_phys), INTENT(IN) :: dt,ust,pblh + real(kind_phys),DIMENSION(KTS:KTE+1), INTENT(IN) :: ZW + real(kind_phys), INTENT(IN) :: WTHL,WQT + real(kind_phys), INTENT(IN) :: dt,ust,pblh ! outputs - downdraft properties - REAL,DIMENSION(KTS:KTE), INTENT(OUT) :: edmf_a_dd,edmf_w_dd, & + real(kind_phys),DIMENSION(KTS:KTE), INTENT(OUT) :: edmf_a_dd,edmf_w_dd, & & edmf_qt_dd,edmf_thl_dd, edmf_ent_dd,edmf_qc_dd ! outputs - variables needed for solver (sd_aw - sum ai*wi, sd_awphi - sum ai*wi*phii) - REAL,DIMENSION(KTS:KTE+1) :: sd_aw, sd_awthl, sd_awqt, sd_awu, & + real(kind_phys),DIMENSION(KTS:KTE+1) :: sd_aw, sd_awthl, sd_awqt, sd_awu, & sd_awv, sd_awqc, sd_awqv, sd_awqke, sd_aw2 - REAL,DIMENSION(KTS:KTE), INTENT(IN) :: qc_bl1d, cldfra_bl1d + real(kind_phys),DIMENSION(KTS:KTE), INTENT(IN) :: qc_bl1d, cldfra_bl1d INTEGER, PARAMETER :: NDOWN=5, debug_mf=0 !fixing number of plumes to 5 ! draw downdraft starting height randomly between cloud base and cloud top INTEGER, DIMENSION(1:NDOWN) :: DD_initK - REAL , DIMENSION(1:NDOWN) :: randNum + real(kind_phys) , DIMENSION(1:NDOWN) :: randNum ! downdraft properties - REAL,DIMENSION(KTS:KTE+1,1:NDOWN) :: DOWNW,DOWNTHL,DOWNQT,& + real(kind_phys),DIMENSION(KTS:KTE+1,1:NDOWN) :: DOWNW,DOWNTHL,DOWNQT,& DOWNQC,DOWNA,DOWNU,DOWNV,DOWNTHV ! entrainment variables - REAl,DIMENSION(KTS+1:KTE+1,1:NDOWN) :: ENT,ENTf + Real(Kind_phys),DIMENSION(KTS+1:KTE+1,1:NDOWN) :: ENT,ENTf INTEGER,DIMENSION(KTS+1:KTE+1,1:NDOWN) :: ENTi ! internal variables INTEGER :: K,I,ki, kminrad, qlTop, p700_ind, qlBase - REAL :: wthv,wstar,qstar,thstar,sigmaW,sigmaQT,sigmaTH,z0, & + real(kind_phys):: wthv,wstar,qstar,thstar,sigmaW,sigmaQT,sigmaTH,z0, & pwmin,pwmax,wmin,wmax,wlv,wtv,went,mindownw - REAL :: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,Wn2,Wn,THVk,Pk, & + real(kind_phys):: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,Wn2,Wn,THVk,Pk, & EntEXP,EntW, Beta_dm, EntExp_M, rho_int - REAL :: jump_thetav, jump_qt, jump_thetal, & + real(kind_phys):: jump_thetav, jump_qt, jump_thetal, & refTHL, refTHV, refQT ! DD specific internal variables - REAL :: minrad,zminrad, radflux, F0, wst_rad, wst_dd + real(kind_phys):: minrad,zminrad, radflux, F0, wst_rad, wst_dd logical :: cloudflg - REAL :: sigq,xl,rsl,cpm,a,mf_cf,diffqt,& + real(kind_phys):: sigq,xl,rsl,cpm,a,mf_cf,diffqt,& Fng,qww,alpha,beta,bb,f,pt,t,q2p,b9,satvp,rhgrid ! w parameters - REAL,PARAMETER :: & + real(kind_phys),PARAMETER :: & &Wa=1., & &Wb=1.5,& &Z00=100.,& &BCOEFF=0.2 ! entrainment parameters - REAL,PARAMETER :: & + real(kind_phys),PARAMETER :: & & L0=80,& & ENT0=0.2 @@ -7039,7 +7039,7 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & do i=1,NDOWN ! downdraft starts somewhere between cloud base to cloud top ! the probability is equally distributed - DD_initK(i) = qlTop ! nint(randNum(i)*REAL(qlTop-qlBase)) + qlBase + DD_initK(i) = qlTop ! nint(randNum(i)*real(qlTop-qlBase)) + qlBase enddo ! LOOP RADFLUX @@ -7109,13 +7109,13 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & do I=1,NDOWN !downdraft now starts at different height ki = DD_initK(I) - wlv=wmin+(wmax-wmin)/REAL(NDOWN)*(i-1) - wtv=wmin+(wmax-wmin)/REAL(NDOWN)*i + wlv=wmin+(wmax-wmin)/real(NDOWN)*(i-1) + wtv=wmin+(wmax-wmin)/real(NDOWN)*i !DOWNW(ki,I)=0.5*(wlv+wtv) DOWNW(ki,I)=wlv !DOWNA(ki,I)=0.5*ERF(wtv/(sqrt(2.)*sigmaW))-0.5*ERF(wlv/(sqrt(2.)*sigmaW)) - DOWNA(ki,I)=.1/REAL(NDOWN) + DOWNA(ki,I)=.1/real(NDOWN) DOWNU(ki,I)=(u(ki-1)*DZ(ki) + u(ki)*DZ(ki-1)) /(DZ(ki)+DZ(ki-1)) DOWNV(ki,I)=(v(ki-1)*DZ(ki) + v(ki)*DZ(ki-1)) /(DZ(ki)+DZ(ki-1)) @@ -7285,9 +7285,9 @@ SUBROUTINE SCALE_AWARE(dx,PBL1,Psig_bl,Psig_shcu) ! Psig_bl tapers local mixing ! Psig_shcu tapers nonlocal mixing - REAL(kind=kind_phys), INTENT(IN) :: dx,pbl1 - REAL, INTENT(OUT) :: Psig_bl,Psig_shcu - REAL :: dxdh + real(kind_phys), INTENT(IN) :: dx,pbl1 + real(kind_phys), INTENT(OUT) :: Psig_bl,Psig_shcu + real(kind_phys) :: dxdh Psig_bl=1.0 Psig_shcu=1.0 @@ -7359,28 +7359,28 @@ FUNCTION esat_blend(t) IMPLICIT NONE - REAL, INTENT(IN):: t - REAL :: esat_blend,XC,ESL,ESI,chi + real(kind_phys), INTENT(IN):: t + real(kind_phys):: esat_blend,XC,ESL,ESI,chi !liquid - REAL, PARAMETER:: J0= .611583699E03 - REAL, PARAMETER:: J1= .444606896E02 - REAL, PARAMETER:: J2= .143177157E01 - REAL, PARAMETER:: J3= .264224321E-1 - REAL, PARAMETER:: J4= .299291081E-3 - REAL, PARAMETER:: J5= .203154182E-5 - REAL, PARAMETER:: J6= .702620698E-8 - REAL, PARAMETER:: J7= .379534310E-11 - REAL, PARAMETER:: J8=-.321582393E-13 + real(kind_phys), PARAMETER:: J0= .611583699E03 + real(kind_phys), PARAMETER:: J1= .444606896E02 + real(kind_phys), PARAMETER:: J2= .143177157E01 + real(kind_phys), PARAMETER:: J3= .264224321E-1 + real(kind_phys), PARAMETER:: J4= .299291081E-3 + real(kind_phys), PARAMETER:: J5= .203154182E-5 + real(kind_phys), PARAMETER:: J6= .702620698E-8 + real(kind_phys), PARAMETER:: J7= .379534310E-11 + real(kind_phys), PARAMETER:: J8=-.321582393E-13 !ice - REAL, PARAMETER:: K0= .609868993E03 - REAL, PARAMETER:: K1= .499320233E02 - REAL, PARAMETER:: K2= .184672631E01 - REAL, PARAMETER:: K3= .402737184E-1 - REAL, PARAMETER:: K4= .565392987E-3 - REAL, PARAMETER:: K5= .521693933E-5 - REAL, PARAMETER:: K6= .307839583E-7 - REAL, PARAMETER:: K7= .105785160E-9 - REAL, PARAMETER:: K8= .161444444E-12 + real(kind_phys), PARAMETER:: K0= .609868993E03 + real(kind_phys), PARAMETER:: K1= .499320233E02 + real(kind_phys), PARAMETER:: K2= .184672631E01 + real(kind_phys), PARAMETER:: K3= .402737184E-1 + real(kind_phys), PARAMETER:: K4= .565392987E-3 + real(kind_phys), PARAMETER:: K5= .521693933E-5 + real(kind_phys), PARAMETER:: K6= .307839583E-7 + real(kind_phys), PARAMETER:: K7= .105785160E-9 + real(kind_phys), PARAMETER:: K8= .161444444E-12 XC=MAX(-80.,t - t0c) !note t0c = 273.15, tice is set in module mynn_common to 240 @@ -7410,28 +7410,28 @@ FUNCTION qsat_blend(t, P) IMPLICIT NONE - REAL, INTENT(IN):: t, P - REAL :: qsat_blend,XC,ESL,ESI,RSLF,RSIF,chi + real(kind_phys), INTENT(IN):: t, P + real(kind_phys):: qsat_blend,XC,ESL,ESI,RSLF,RSIF,chi !liquid - REAL, PARAMETER:: J0= .611583699E03 - REAL, PARAMETER:: J1= .444606896E02 - REAL, PARAMETER:: J2= .143177157E01 - REAL, PARAMETER:: J3= .264224321E-1 - REAL, PARAMETER:: J4= .299291081E-3 - REAL, PARAMETER:: J5= .203154182E-5 - REAL, PARAMETER:: J6= .702620698E-8 - REAL, PARAMETER:: J7= .379534310E-11 - REAL, PARAMETER:: J8=-.321582393E-13 + real(kind_phys), PARAMETER:: J0= .611583699E03 + real(kind_phys), PARAMETER:: J1= .444606896E02 + real(kind_phys), PARAMETER:: J2= .143177157E01 + real(kind_phys), PARAMETER:: J3= .264224321E-1 + real(kind_phys), PARAMETER:: J4= .299291081E-3 + real(kind_phys), PARAMETER:: J5= .203154182E-5 + real(kind_phys), PARAMETER:: J6= .702620698E-8 + real(kind_phys), PARAMETER:: J7= .379534310E-11 + real(kind_phys), PARAMETER:: J8=-.321582393E-13 !ice - REAL, PARAMETER:: K0= .609868993E03 - REAL, PARAMETER:: K1= .499320233E02 - REAL, PARAMETER:: K2= .184672631E01 - REAL, PARAMETER:: K3= .402737184E-1 - REAL, PARAMETER:: K4= .565392987E-3 - REAL, PARAMETER:: K5= .521693933E-5 - REAL, PARAMETER:: K6= .307839583E-7 - REAL, PARAMETER:: K7= .105785160E-9 - REAL, PARAMETER:: K8= .161444444E-12 + real(kind_phys), PARAMETER:: K0= .609868993E03 + real(kind_phys), PARAMETER:: K1= .499320233E02 + real(kind_phys), PARAMETER:: K2= .184672631E01 + real(kind_phys), PARAMETER:: K3= .402737184E-1 + real(kind_phys), PARAMETER:: K4= .565392987E-3 + real(kind_phys), PARAMETER:: K5= .521693933E-5 + real(kind_phys), PARAMETER:: K6= .307839583E-7 + real(kind_phys), PARAMETER:: K7= .105785160E-9 + real(kind_phys), PARAMETER:: K8= .161444444E-12 XC=MAX(-80.,t - t0c) @@ -7468,8 +7468,8 @@ FUNCTION xl_blend(t) IMPLICIT NONE - REAL, INTENT(IN):: t - REAL :: xl_blend,xlvt,xlst,chi + real(kind_phys), INTENT(IN):: t + real(kind_phys):: xl_blend,xlvt,xlst,chi !note: t0c = 273.15, tice is set in mynn_common IF (t .GE. t0c) THEN @@ -7497,12 +7497,12 @@ FUNCTION phim(zet) ! stable conditions [z/L ~ O(10)]. IMPLICIT NONE - REAL, INTENT(IN):: zet - REAL :: dummy_0,dummy_1,dummy_11,dummy_2,dummy_22,dummy_3,dummy_33,dummy_4,dummy_44,dummy_psi - REAL, PARAMETER :: am_st=6.1, bm_st=2.5, rbm_st=1./bm_st - REAL, PARAMETER :: ah_st=5.3, bh_st=1.1, rbh_st=1./bh_st - REAL, PARAMETER :: am_unst=10., ah_unst=34. - REAL :: phi_m,phim + real(kind_phys), INTENT(IN):: zet + real(kind_phys):: dummy_0,dummy_1,dummy_11,dummy_2,dummy_22,dummy_3,dummy_33,dummy_4,dummy_44,dummy_psi + real(kind_phys), PARAMETER :: am_st=6.1, bm_st=2.5, rbm_st=1./bm_st + real(kind_phys), PARAMETER :: ah_st=5.3, bh_st=1.1, rbh_st=1./bh_st + real(kind_phys), PARAMETER :: am_unst=10., ah_unst=34. + real(kind_phys):: phi_m,phim if ( zet >= 0.0 ) then dummy_0=1+zet**bm_st @@ -7549,12 +7549,12 @@ FUNCTION phih(zet) ! stable conditions [z/L ~ O(10)]. IMPLICIT NONE - REAL, INTENT(IN):: zet - REAL :: dummy_0,dummy_1,dummy_11,dummy_2,dummy_22,dummy_3,dummy_33,dummy_4,dummy_44,dummy_psi - REAL, PARAMETER :: am_st=6.1, bm_st=2.5, rbm_st=1./bm_st - REAL, PARAMETER :: ah_st=5.3, bh_st=1.1, rbh_st=1./bh_st - REAL, PARAMETER :: am_unst=10., ah_unst=34. - REAL :: phh,phih + real(kind_phys), INTENT(IN):: zet + real(kind_phys):: dummy_0,dummy_1,dummy_11,dummy_2,dummy_22,dummy_3,dummy_33,dummy_4,dummy_44,dummy_psi + real(kind_phys), PARAMETER :: am_st=6.1, bm_st=2.5, rbm_st=1./bm_st + real(kind_phys), PARAMETER :: ah_st=5.3, bh_st=1.1, rbh_st=1./bh_st + real(kind_phys), PARAMETER :: am_unst=10., ah_unst=34. + real(kind_phys):: phh,phih if ( zet >= 0.0 ) then dummy_0=1+zet**bh_st @@ -7594,23 +7594,23 @@ SUBROUTINE topdown_cloudrad(kts,kte,dz1,zw,xland,kpbl,PBLH, & &maxKHtopdown,KHtopdown,TKEprodTD ) !input - integer, intent(in) :: kte,kts - real, dimension(kts:kte), intent(in) :: dz1,sqc,sqi,sqw,& + integer, intent(in) :: kte,kts + real(kind_phys), dimension(kts:kte), intent(in) :: dz1,sqc,sqi,sqw,& thl,th1,ex1,p1,rho1,thetav,cldfra_bl1D - real(kind=kind_phys), dimension(kts:kte), intent(in) :: rthraten - real, dimension(kts:kte+1), intent(in) :: zw - real(kind=kind_phys), intent(in) :: pblh - real, intent(in) :: xland - integer,intent(in) :: kpbl + real(kind_phys), dimension(kts:kte), intent(in) :: rthraten + real(kind_phys), dimension(kts:kte+1), intent(in) :: zw + real(kind_phys), intent(in) :: pblh + real(kind_phys), intent(in) :: xland + integer , intent(in) :: kpbl !output - real, intent(out) :: maxKHtopdown - real, dimension(kts:kte), intent(out) :: KHtopdown,TKEprodTD + real(kind_phys), intent(out) :: maxKHtopdown + real(kind_phys), dimension(kts:kte), intent(out) :: KHtopdown,TKEprodTD !local - real, dimension(kts:kte) :: zfac,wscalek2,zfacent - real :: bfx0,sflux,wm2,wm3,h1,h2,bfxpbl,dthvx,tmp1 - real :: temps,templ,zl1,wstar3_2 - real :: ent_eff,radsum,radflux,we,rcldb,rvls,minrad,zminrad - real, parameter :: pfac =2.0, zfmin = 0.01, phifac=8.0 + real(kind_phys), dimension(kts:kte) :: zfac,wscalek2,zfacent + real(kind_phys) :: bfx0,sflux,wm2,wm3,h1,h2,bfxpbl,dthvx,tmp1 + real(kind_phys) :: temps,templ,zl1,wstar3_2 + real(kind_phys) :: ent_eff,radsum,radflux,we,rcldb,rvls,minrad,zminrad + real(kind_phys), parameter :: pfac =2.0, zfmin = 0.01, phifac=8.0 integer :: k,kk,kminrad logical :: cloudflg diff --git a/physics/mynnedmf_wrapper.F90 b/physics/mynnedmf_wrapper.F90 index ca0b9f141..9aa9e8c5a 100644 --- a/physics/mynnedmf_wrapper.F90 +++ b/physics/mynnedmf_wrapper.F90 @@ -25,25 +25,25 @@ subroutine mynnedmf_wrapper_init ( & implicit none - logical, intent(in) :: do_mynnedmf - logical, intent(in) :: lheatstrg - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - real(kind=kind_phys),intent(in) :: con_xlv - real(kind=kind_phys),intent(in) :: con_xlf - real(kind=kind_phys),intent(in) :: con_rv - real(kind=kind_phys),intent(in) :: con_rd - real(kind=kind_phys),intent(in) :: con_ep2 - real(kind=kind_phys),intent(in) :: con_grav - real(kind=kind_phys),intent(in) :: con_cp - real(kind=kind_phys),intent(in) :: con_cpv - real(kind=kind_phys),intent(in) :: con_rcp - real(kind=kind_phys),intent(in) :: con_p608 - real(kind=kind_phys),intent(in) :: con_cliq - real(kind=kind_phys),intent(in) :: con_cice - real(kind=kind_phys),intent(in) :: con_karman - real(kind=kind_phys),intent(in) :: con_t0c + logical, intent(in) :: do_mynnedmf + logical, intent(in) :: lheatstrg + character(len=*),intent(out):: errmsg + integer, intent(out) :: errflg + + real(kind_phys),intent(in) :: con_xlv + real(kind_phys),intent(in) :: con_xlf + real(kind_phys),intent(in) :: con_rv + real(kind_phys),intent(in) :: con_rd + real(kind_phys),intent(in) :: con_ep2 + real(kind_phys),intent(in) :: con_grav + real(kind_phys),intent(in) :: con_cp + real(kind_phys),intent(in) :: con_cpv + real(kind_phys),intent(in) :: con_rcp + real(kind_phys),intent(in) :: con_p608 + real(kind_phys),intent(in) :: con_cliq + real(kind_phys),intent(in) :: con_cice + real(kind_phys),intent(in) :: con_karman + real(kind_phys),intent(in) :: con_t0c ! Initialize CCPP error handling variables errmsg = '' @@ -172,7 +172,7 @@ SUBROUTINE mynnedmf_wrapper_run( & implicit none !------------------------------------------------------------------- - real(kind=kind_phys) :: huge + real(kind_phys) :: huge character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -207,11 +207,11 @@ SUBROUTINE mynnedmf_wrapper_run( & & imp_physics_nssl, imp_physics_fa, & & spp_pbl, & & tke_budget - real(kind=kind_phys), intent(in) :: & + real(kind_phys), intent(in) :: & & bl_mynn_closure !TENDENCY DIAGNOSTICS - real(kind=kind_phys), intent(inout), optional :: dtend(:,:,:) + real(kind_phys), intent(inout), optional :: dtend(:,:,:) integer, intent(in) :: dtidx(:,:) integer, intent(in) :: index_of_temperature, index_of_x_wind integer, intent(in) :: index_of_y_wind, index_of_process_pbl @@ -228,7 +228,7 @@ SUBROUTINE mynnedmf_wrapper_run( & LOGICAL, PARAMETER :: cycling = .false. !MYNN-1D - REAL(kind=kind_phys), intent(in) :: delt, dtf + REAL(kind_phys), intent(in) :: delt, dtf INTEGER, intent(in) :: im, levs LOGICAL, intent(in) :: flag_init, flag_restart INTEGER :: initflag, k, i @@ -236,31 +236,31 @@ SUBROUTINE mynnedmf_wrapper_run( & & IMS,IME,JMS,JME,KMS,KME, & & ITS,ITE,JTS,JTE,KTS,KTE - REAL(kind=kind_phys) :: tem + REAL(kind_phys) :: tem !MYNN-3D - real(kind=kind_phys), dimension(:,:), intent(in) :: phii - real(kind=kind_phys), dimension(:,:), intent(inout) :: & + real(kind_phys), dimension(:,:), intent(in) :: phii + real(kind_phys), dimension(:,:), intent(inout) :: & & dtdt, dudt, dvdt, & & dqdt_water_vapor, dqdt_liquid_cloud, dqdt_ice_cloud, & & dqdt_snow_cloud, & & dqdt_cloud_droplet_num_conc, dqdt_ice_num_conc, & & dqdt_ozone, dqdt_water_aer_num_conc, dqdt_ice_aer_num_conc - real(kind=kind_phys), dimension(:,:), intent(inout) ::dqdt_cccn - real(kind=kind_phys), dimension(:,:), intent(inout) :: & + real(kind_phys), dimension(:,:), intent(inout) ::dqdt_cccn + real(kind_phys), dimension(:,:), intent(inout) :: & & qke, qke_adv, EL_PBL, Sh3D, Sm3D, & & qc_bl, qi_bl, cldfra_bl !These 10 arrays are only allocated when bl_mynn_output > 0 - real(kind=kind_phys), dimension(:,:), intent(inout) :: & + real(kind_phys), dimension(:,:), intent(inout) :: & & edmf_a,edmf_w,edmf_qt, & & edmf_thl,edmf_ent,edmf_qc, & & sub_thl,sub_sqv,det_thl,det_sqv - real(kind=kind_phys), dimension(:,:), intent(inout) :: & + real(kind_phys), dimension(:,:), intent(inout) :: & & dqke,qWT,qSHEAR,qBUOY,qDISS - real(kind=kind_phys), dimension(:,:), intent(inout) :: & + real(kind_phys), dimension(:,:), intent(inout) :: & & t3d,qgrs_water_vapor,qgrs_liquid_cloud,qgrs_ice_cloud, & & qgrs_snow_cloud - real(kind=kind_phys), dimension(:,:), intent(in) :: & + real(kind_phys), dimension(:,:), intent(in) :: & & u,v,omega, & & exner,prsl,prsi, & & qgrs_cloud_droplet_num_conc, & @@ -268,37 +268,37 @@ SUBROUTINE mynnedmf_wrapper_run( & & qgrs_ozone, & & qgrs_water_aer_num_conc, & & qgrs_ice_aer_num_conc - real(kind=kind_phys), dimension(:,:), intent(in) ::qgrs_cccn - real(kind=kind_phys), dimension(:,:), intent(out) :: & + real(kind_phys), dimension(:,:), intent(in) ::qgrs_cccn + real(kind_phys), dimension(:,:), intent(out) :: & & Tsq, Qsq, Cov, exch_h, exch_m - real(kind=kind_phys), dimension(:), intent(in) :: xmu - real(kind=kind_phys), dimension(:,:), intent(in) :: htrsw, htrlw + real(kind_phys), dimension(:), intent(in) :: xmu + real(kind_phys), dimension(:,:), intent(in) :: htrsw, htrlw ! spp_wts_pbl only allocated if spp_pbl == 1 - real(kind=kind_phys), dimension(:,:), intent(in) :: spp_wts_pbl + real(kind_phys), dimension(:,:), intent(in) :: spp_wts_pbl !LOCAL - real(kind=kind_phys), dimension(im,levs) :: & + real(kind_phys), dimension(im,levs) :: & & sqv,sqc,sqi,sqs,qnc,qni,ozone,qnwfa,qnifa,qnbca, & & dz, w, p, rho, th, qv, delp, & & RUBLTEN, RVBLTEN, RTHBLTEN, RQVBLTEN, & & RQCBLTEN, RQNCBLTEN, RQIBLTEN, RQNIBLTEN, RQSBLTEN, & & RQNWFABLTEN, RQNIFABLTEN, RQNBCABLTEN - real(kind=kind_phys), allocatable :: old_ozone(:,:) + real(kind_phys), allocatable :: old_ozone(:,:) !smoke/chem arrays - real(kind=kind_phys), dimension(:), intent(inout) :: frp + real(kind_phys), dimension(:), intent(inout) :: frp logical, intent(in) :: mix_chem, enh_mix, rrfs_sd logical, parameter :: smoke_dbg = .false. !set temporarily - real(kind=kind_phys), dimension(:,:,:), intent(inout) :: chem3d - real(kind=kind_phys), dimension(im) :: emis_ant_no - real(kind=kind_phys), dimension(im,ndvel) :: vdep + real(kind_phys), dimension(:,:,:), intent(inout) :: chem3d + real(kind_phys), dimension(im) :: emis_ant_no + real(kind_phys), dimension(im,ndvel) :: vdep !MYNN-2D - real(kind=kind_phys), dimension(:), intent(in) :: & + real(kind_phys), dimension(:), intent(in) :: & & dx,zorl,slmsk,tsurf,qsfc,ps, & & hflx,qflx,ust,wspd,rb,recmol - real(kind=kind_phys), dimension(:), intent(in) :: & + real(kind_phys), dimension(:), intent(in) :: & & dusfc_cice,dvsfc_cice,dtsfc_cice,dqsfc_cice, & & stress_wat,hflx_wat,qflx_wat, & & oceanfrac,fice @@ -306,26 +306,26 @@ SUBROUTINE mynnedmf_wrapper_run( & logical, dimension(:), intent(in) :: & & wet, dry, icy - real(kind=kind_phys), dimension(:), intent(inout) :: & + real(kind_phys), dimension(:), intent(inout) :: & & pblh,dusfc_diag,dvsfc_diag,dtsfc_diag,dqsfc_diag - real(kind=kind_phys), dimension(:), intent(out) :: & + real(kind_phys), dimension(:), intent(out) :: & & ch,dtsfc1,dqsfc1,dusfc1,dvsfc1, & & dtsfci_diag,dqsfci_diag,dusfci_diag,dvsfci_diag, & & maxMF integer, dimension(:), intent(inout) :: & & kpbl,nupdraft,ktop_plume - real(kind=kind_phys), dimension(:), intent(inout) :: & + real(kind_phys), dimension(:), intent(inout) :: & & dusfc_cpl,dvsfc_cpl,dtsfc_cpl,dqsfc_cpl - real(kind=kind_phys), dimension(:), intent(inout) :: & + real(kind_phys), dimension(:), intent(inout) :: & & dusfci_cpl,dvsfci_cpl,dtsfci_cpl,dqsfci_cpl !LOCAL - real, dimension(im) :: & + real(kind_phys), dimension(im) :: & & hfx,qfx,rmol,xland,uoce,voce,znt,ts integer :: idtend - real, dimension(im) :: dusfci1,dvsfci1,dtsfci1,dqsfci1 - real(kind=kind_phys), allocatable :: save_qke_adv(:,:) + real(kind_phys), dimension(im) :: dusfci1,dvsfci1,dtsfci1,dqsfci1 + real(kind_phys), allocatable :: save_qke_adv(:,:) ! Initialize CCPP error handling variables errmsg = '' @@ -1024,8 +1024,8 @@ SUBROUTINE mynnedmf_wrapper_run( & CONTAINS SUBROUTINE dtend_helper(itracer,field,mult) - real(kind=kind_phys), intent(in) :: field(im,levs) - real(kind=kind_phys), intent(in), optional :: mult(im,levs) + real(kind_phys), intent(in) :: field(im,levs) + real(kind_phys), intent(in), optional :: mult(im,levs) integer, intent(in) :: itracer integer :: idtend @@ -1055,9 +1055,9 @@ SUBROUTINE moisture_check2(kte, delt, dp, exner, & implicit none integer, intent(in) :: kte - real(kind=kind_phys), intent(in) :: delt - real(kind=kind_phys), dimension(kte), intent(in) :: dp, exner - real(kind=kind_phys), dimension(kte), intent(inout) :: qv, qc, qi, qs, th + real(kind_phys), intent(in) :: delt + real(kind_phys), dimension(kte), intent(in) :: dp, exner + real(kind_phys), dimension(kte), intent(inout) :: qv, qc, qi, qs, th integer k real :: dqc2, dqi2, dqs2, dqv2, sum, aa, dum real, parameter :: qvmin1= 1e-8, & !min at k=1 From 466ed779b1da0d00ed489c077d5ef0ae0c89264e Mon Sep 17 00:00:00 2001 From: Jili Dong Date: Tue, 7 Mar 2023 14:21:14 +0000 Subject: [PATCH 139/380] update the standard name for hail/graupel collection efficiency --- physics/mp_nssl.meta | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/mp_nssl.meta b/physics/mp_nssl.meta index d4420c47b..626c5b4cf 100644 --- a/physics/mp_nssl.meta +++ b/physics/mp_nssl.meta @@ -174,7 +174,7 @@ kind = kind_phys intent = in [nssl_ehw0_in] - standard_name = nssl_hw_collec_eff + standard_name = nssl_graupel_collection_efficiency long_name = graupel droplet collection efficiency in NSSL micro units = none dimensions = () @@ -182,8 +182,8 @@ kind = kind_phys intent = in [nssl_ehlw0_in] - standard_name = nssl_hlw_collec_eff - long_name = graupel droplet collection efficiency in NSSL micro + standard_name = nssl_hail_collection_efficiency + long_name = hail droplet collection efficiency in NSSL micro units = none dimensions = () type = real From 229c9231ee4c5467e2aca8f5ef1557995fda5c0a Mon Sep 17 00:00:00 2001 From: Jili Dong Date: Tue, 7 Mar 2023 14:55:38 +0000 Subject: [PATCH 140/380] update the long names for parameters related to NSSL microphysics --- physics/mp_nssl.meta | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/physics/mp_nssl.meta b/physics/mp_nssl.meta index 626c5b4cf..c7e398f0a 100644 --- a/physics/mp_nssl.meta +++ b/physics/mp_nssl.meta @@ -151,7 +151,7 @@ intent = in [nssl_alphah] standard_name = nssl_alpha_graupel - long_name = graupel PSD shape parameter in NSSL micro + long_name = graupel particle size distribution(PSD) shape parameter in NSSL microphysics scheme units = none dimensions = () type = real @@ -159,7 +159,7 @@ intent = in [nssl_alphahl] standard_name = nssl_alpha_hail - long_name = hail PSD shape parameter in NSSL micro + long_name = hail particle size distribution(PSD) shape parameter in NSSL microphysics scheme units = none dimensions = () type = real @@ -167,7 +167,7 @@ intent = in [nssl_alphar] standard_name = nssl_alpha_rain - long_name = rain PSD shape parameter in NSSL micro + long_name = rain particle size distribution(PSD) shape parameter in NSSL microphysics scheme units = none dimensions = () type = real @@ -175,7 +175,7 @@ intent = in [nssl_ehw0_in] standard_name = nssl_graupel_collection_efficiency - long_name = graupel droplet collection efficiency in NSSL micro + long_name = graupel droplet collection efficiency in NSSL microphysics scheme units = none dimensions = () type = real @@ -183,7 +183,7 @@ intent = in [nssl_ehlw0_in] standard_name = nssl_hail_collection_efficiency - long_name = hail droplet collection efficiency in NSSL micro + long_name = hail droplet collection efficiency in NSSL microphysics scheme units = none dimensions = () type = real @@ -191,21 +191,21 @@ intent = in [nssl_ccn_on] standard_name = nssl_ccn_on - long_name = CCN activation flag in NSSL micro + long_name = CCN activation flag in NSSL microphysics scheme units = flag dimensions = () type = logical intent = in [nssl_hail_on] standard_name = nssl_hail_on - long_name = hail activation flag in NSSL micro + long_name = hail activation flag in NSSL microphysics scheme units = flag dimensions = () type = logical intent = in [nssl_invertccn] standard_name = nssl_invertccn - long_name = flag to invert CCN in NSSL micro + long_name = flag to invert CCN in NSSL microphysics scheme units = flag dimensions = () type = logical @@ -595,21 +595,21 @@ intent = in [nssl_ccn_on] standard_name = nssl_ccn_on - long_name = CCN activation flag in NSSL micro + long_name = CCN activation flag in NSSL microphysics scheme units = flag dimensions = () type = logical intent = in [nssl_hail_on] standard_name = nssl_hail_on - long_name = hail activation flag in NSSL micro + long_name = hail activation flag in NSSL microphysics scheme units = flag dimensions = () type = logical intent = in [nssl_invertccn] standard_name = nssl_invertccn - long_name = flag to invert CCN in NSSL micro + long_name = flag to invert CCN in NSSL microphysics scheme units = flag dimensions = () type = logical From 92e33b286f8ab8bdd1132d63c0db5fac98c109b5 Mon Sep 17 00:00:00 2001 From: drnimbusrain Date: Wed, 8 Mar 2023 18:59:52 +0000 Subject: [PATCH 141/380] Added "do_canopy" flag for eddy effects in TKE-EDMF --- physics/satmedmfvdifq.F | 15 ++++++++++----- physics/satmedmfvdifq.meta | 7 +++++++ 2 files changed, 17 insertions(+), 5 deletions(-) diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index 61f040cff..ae5e33882 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -86,7 +86,7 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & & dspheat,dusfc,dvsfc,dtsfc,dqsfc,hpbl,dkt,dku, & & kinver,xkzm_m,xkzm_h,xkzm_s,dspfac,bl_upfr,bl_dnfr, & & rlmx,elmx,sfc_rlm,tc_pbl, & - & vegtype, lai, & + & do_canopy, vegtype, lai, & & ntqv,dtend,dtidx,index_of_temperature,index_of_x_wind, & & index_of_y_wind,index_of_process_pbl,gen_tend,ldiag3d, & & errmsg,errflg) @@ -111,6 +111,7 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & real(kind=kind_phys), intent(in) :: dspfac, bl_upfr, bl_dnfr real(kind=kind_phys), intent(in) :: rlmx, elmx !PCC_CANOPY------------------------------------ + logical, intent(in) :: do_canopy integer, intent(in) :: vegtype(:) real(kind=kind_phys), intent(in) :: lai(:) !---------------------------------------------- @@ -307,10 +308,12 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & !---------------------------------------------- !PCC_CANOPY------------------------------------ - if(.not.allocated(EDDYVESTX)) - & allocate( EDDYVESTX ( MAXCAN ) ) - if(.not.allocated(ZCANX)) - & allocate( ZCANX ( MAXCAN ) ) + if (do_canopy) then + if(.not.allocated(EDDYVESTX)) + & allocate( EDDYVESTX ( MAXCAN ) ) + if(.not.allocated(ZCANX)) + & allocate( ZCANX ( MAXCAN ) ) + endif !---------------------------------------------- if (tc_pbl == 0) then @@ -1312,6 +1315,7 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & enddo enddo !PCC_CANOPY------------------------------------ + if (do_canopy) then do k = 1, km1 do i = 1, im FCH = hvt_table(vegtype(i)) !top of canopy @@ -1410,6 +1414,7 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & END IF ! first model layer scaled canopy enddo !i enddo !k + endif !do_canopy !> ## Compute TKE. !! - Compute a minimum TKE deduced from background diffusivity for momentum. ! diff --git a/physics/satmedmfvdifq.meta b/physics/satmedmfvdifq.meta index 6c74c19a5..8e67160d2 100644 --- a/physics/satmedmfvdifq.meta +++ b/physics/satmedmfvdifq.meta @@ -581,6 +581,13 @@ type = real kind = kind_phys intent = in +[do_canopy] + standard_name = flag_for_canopy_option + long_name = flag for in-canopy eddy diffusivity adjustment option + units = flag + dimensions = () + type = logical + intent = in [vegtype] standard_name = vegetation_type_classification long_name = vegetation type at each grid cell From fab541616e776489e306721445cd3f82abdceb82 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Wed, 8 Mar 2023 21:02:53 +0000 Subject: [PATCH 142/380] Merged latestest version of RUC LSM into community develop. --- physics/lsm_ruc.F90 | 557 ++++++------ physics/lsm_ruc.meta | 103 ++- physics/module_sf_ruclsm.F90 | 1356 ++++++++++++++++++++---------- physics/namelist_soilveg_ruc.F90 | 3 + physics/set_soilveg_ruc.F90 | 39 +- 5 files changed, 1355 insertions(+), 703 deletions(-) diff --git a/physics/lsm_ruc.F90 b/physics/lsm_ruc.F90 index 9a1f2ca21..9215a0ae1 100644 --- a/physics/lsm_ruc.F90 +++ b/physics/lsm_ruc.F90 @@ -300,15 +300,15 @@ end subroutine lsm_ruc_finalize ! sncovr1 - real, snow cover over land (fractional) im ! ! qsurf - real, specific humidity at sfc im ! ! gflux - real, soil heat flux (w/m**2) im ! -! drain - real, subsurface runoff (m/s) im ! +! drain - real, subsurface runoff (mm/s) im ! ! evap - real, latent heat flux in kg kg-1 m s-1 im ! -! runof - real, surface runoff (m/s) im ! -! evbs - real, direct soil evaporation (m/s) im ! -! evcw - real, canopy water evaporation (m/s) im ! -! sbsno - real, sublimation/deposit from snopack (m/s) im ! +! runof - real, surface runoff (mm/s) im ! +! evbs - real, direct soil evaporation (W m-2) im ! +! evcw - real, canopy water evaporation (W m-2) im ! +! sbsno - real, sublimation/deposit from snopack (W m-2) im ! ! stm - real, total soil column moisture content (m) im ! -! trans - real, total plant transpiration (m/s) im ! -! zorl - real, surface roughness im ! +! trans - real, total plant transpiration (W m-2) im ! +! zorl - real, surface roughness (cm) im ! ! wetness - real, normalized soil wetness im ! ! ! ! ==================== end of description ===================== ! @@ -323,18 +323,20 @@ end subroutine lsm_ruc_finalize subroutine lsm_ruc_run & ! inputs & ( iter, me, master, delt, kdt, im, nlev, lsm_ruc, lsm, & & imp_physics, imp_physics_gfdl, imp_physics_thompson, & - & imp_physics_nssl, do_mynnsfclay, exticeden, & - & lsoil_ruc, lsoil, rdlai, xlat_d, xlon_d, zs, & - & t1, q1, qc, stype, vtype, sigmaf, laixy, & + & imp_physics_nssl, do_mynnsfclay, & + & exticeden, lsoil_ruc, lsoil, nlcat, nscat, & + & rdlai, xlat_d, xlon_d, & + & oro, sigma, zs, t1, q1, qc, stype, vtype, vegtype_frac, & + & soiltype_frac, sigmaf, laixy, & & dlwflx, dswsfc, tg3, coszen, land, icy, use_lake, & - & rainnc, rainc, ice, snow, graupel, & - & prsl1, zf, wind, shdmin, shdmax, & + & rainnc, rainc, ice, snow, graupel, prsl1, zf, & + & wind, shdmin, shdmax, & & srflag, sfalb_lnd_bck, snoalb, & & isot, ivegsrc, fice, smcwlt2, smcref2, & & min_lakeice, min_seaice, oceanfrac, rhonewsn1, & ! --- constants & con_cp, con_rd, con_rv, con_g, con_pi, con_hvap, & - & con_fvirt, & + & con_hfus, con_fvirt, & ! --- in/outs for ice and land & semisbase, semis_lnd, semis_ice, sfalb_lnd, sfalb_ice, & & sncovr1_lnd, weasd_lnd, snwdph_lnd, tskin_lnd, & @@ -346,13 +348,13 @@ subroutine lsm_ruc_run & ! inputs & qsurf_lnd, gflux_lnd, evap_lnd, hflx_lnd, & & runof, runoff, srunoff, drain, & & cm_lnd, ch_lnd, evbs, evcw, stm, wetness, & - & snowfallac_lnd, & + & snowfallac_lnd, acsnow_lnd, snowmt_lnd, snohf, & & albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, & ! for ice & sfcqc_ice, sfcqv_ice, & & tsurf_ice, tsnow_ice, z0rl_ice, & & qsurf_ice, gflux_ice, evap_ice, ep1d_ice, hflx_ice, & - & cm_ice, ch_ice, snowfallac_ice, & + & cm_ice, ch_ice, snowfallac_ice, acsnow_ice, snowmt_ice, & & albdvis_ice, albdnir_ice, albivis_ice, albinir_ice, & ! --- out & rhosnf, sbsno, & @@ -371,10 +373,12 @@ subroutine lsm_ruc_run & ! inputs ! --- input: integer, intent(in) :: me, master integer, intent(in) :: im, nlev, iter, lsoil_ruc, lsoil, kdt, isot, ivegsrc + integer, intent(in) :: nlcat, nscat integer, intent(in) :: lsm_ruc, lsm integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, & imp_physics_nssl real (kind=kind_phys), dimension(:), intent(in) :: xlat_d, xlon_d + real (kind=kind_phys), dimension(:), intent(in) :: oro, sigma real (kind=kind_phys), dimension(:), intent(in) :: & & t1, sigmaf, laixy, dlwflx, dswsfc, tg3, & @@ -390,7 +394,7 @@ subroutine lsm_ruc_run & ! inputs real (kind=kind_phys), intent(in) :: delt, min_seaice, min_lakeice real (kind=kind_phys), intent(in) :: con_cp, con_rv, con_g, & con_pi, con_rd, & - con_hvap, con_fvirt + con_hvap, con_hfus, con_fvirt logical, dimension(:), intent(in) :: flag_iter, flag_guess logical, dimension(:), intent(in) :: land, icy, use_lake @@ -404,6 +408,10 @@ subroutine lsm_ruc_run & ! inputs ! --- in/out: integer, dimension(:), intent(inout) :: stype integer, dimension(:), intent(in) :: vtype + + real (kind=kind_phys), dimension(:,:), intent(in) :: vegtype_frac + real (kind=kind_phys), dimension(:,:), intent(in) :: soiltype_frac + real (kind=kind_phys), dimension(:), intent(in) :: zs real (kind=kind_phys), dimension(:), intent(in) :: srflag real (kind=kind_phys), dimension(:), intent(inout) :: & @@ -433,10 +441,11 @@ subroutine lsm_ruc_run & ! inputs ! for land & sncovr1_lnd, qsurf_lnd, gflux_lnd, evap_lnd, & & cmm_lnd, chh_lnd, hflx_lnd, sbsno, & - & snowfallac_lnd, & + & snowfallac_lnd, acsnow_lnd, snowmt_lnd, snohf, & ! for ice & sncovr1_ice, qsurf_ice, gflux_ice, evap_ice, ep1d_ice, & - & cmm_ice, chh_ice, hflx_ice, snowfallac_ice + & cmm_ice, chh_ice, hflx_ice, & + & snowfallac_ice, acsnow_ice, snowmt_ice real (kind=kind_phys), dimension(:), intent( out) :: & & albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, & @@ -451,19 +460,19 @@ subroutine lsm_ruc_run & ! inputs real(kind=kind_phys), dimension(im,nlev) :: pattern_spp ! --- locals: - real (kind=kind_phys), dimension(im) :: rho, & - & q0, qs1, albbcksol, & + real (kind=kind_phys), dimension(im) :: rho, rhonewsn_ex, & + & q0, qs1, albbcksol, srunoff_old, runoff_old, & & tprcp_old, srflag_old, sr_old, canopy_old, wetness_old, & ! for land & weasd_lnd_old, snwdph_lnd_old, tskin_lnd_old, & - & tsnow_lnd_old, snowfallac_lnd_old, & + & tsnow_lnd_old, snowfallac_lnd_old, acsnow_lnd_old, & & sfcqv_lnd_old, sfcqc_lnd_old, z0rl_lnd_old, & - & sncovr1_lnd_old, & + & sncovr1_lnd_old,snowmt_lnd_old, & ! for ice & weasd_ice_old, snwdph_ice_old, tskin_ice_old, & - & tsnow_ice_old, snowfallac_ice_old, & + & tsnow_ice_old, snowfallac_ice_old, acsnow_ice_old, & & sfcqv_ice_old, sfcqc_ice_old, z0rl_ice_old, & - & sncovr1_ice_old + & sncovr1_ice_old,snowmt_ice_old !-- local spp pattern array real (kind=kind_phys), dimension(im,lsoil_ruc,1) :: pattern_spp_lsm @@ -479,8 +488,12 @@ subroutine lsm_ruc_run & ! inputs & tsice_old, tslb_old, sh2o_old, & & keepfr_old, smfrkeep_old + real (kind=kind_phys), dimension(im,nlcat,1) :: landusef + real (kind=kind_phys), dimension(im,nscat,1) :: soilctop + real (kind=kind_phys),dimension (im,1,1) :: & & conflx2, sfcprs, sfctmp, q2, qcatm, rho2 + real (kind=kind_phys),dimension (im,1) :: orog, stdev real (kind=kind_phys),dimension (im,1) :: & & albbck_lnd, alb_lnd, chs_lnd, flhc_lnd, flqc_lnd, & & wet, wet_ice, smmax, cmc, drip, ec, edir, ett, & @@ -494,9 +507,8 @@ subroutine lsm_ruc_run & ! inputs & snomlt_lnd, sncovr_lnd, soilw, soilm, ssoil_lnd, & & soilt_lnd, tbot, & & xlai, swdn, z0_lnd, znt_lnd, rhosnfr, infiltr, & - & precipfr, snfallac_lnd, acsn, & - & qsfc_lnd, qsg_lnd, qvg_lnd, qcg_lnd, soilt1_lnd, chklowq, & - & rhonewsn + & precipfr, snfallac_lnd, acsn_lnd, & + & qsfc_lnd, qsg_lnd, qvg_lnd, qcg_lnd, soilt1_lnd, chklowq ! ice real (kind=kind_phys),dimension (im,1) :: & & albbck_ice, alb_ice, chs_ice, flhc_ice, flqc_ice, & @@ -504,7 +516,7 @@ subroutine lsm_ruc_run & ! inputs & solnet_ice, sfcems_ice, hfx_ice, & & sneqv_ice, snoalb1d_ice, snowh_ice, snoh_ice, tsnav_ice, & & snomlt_ice, sncovr_ice, ssoil_ice, soilt_ice, & - & z0_ice, znt_ice, snfallac_ice, & + & z0_ice, znt_ice, snfallac_ice, acsn_ice, & & qsfc_ice, qsg_ice, qvg_ice, qcg_ice, soilt1_ice @@ -515,10 +527,6 @@ subroutine lsm_ruc_run & ! inputs !! "USGS" (USGS 24/27 category dataset) and !! "MODIFIED_IGBP_MODIS_NOAH" (MODIS 20-category dataset) - integer :: nscat, nlcat - real (kind=kind_phys), dimension(:,:,:), allocatable :: landusef !< fractional landuse - real (kind=kind_phys), dimension(:,:,:), allocatable :: soilctop !< fractional soil type - integer :: nsoil, iswater, isice integer, dimension (1:im,1:1) :: stype_wat, vtype_wat integer, dimension (1:im,1:1) :: stype_lnd, vtype_lnd @@ -543,8 +551,8 @@ subroutine lsm_ruc_run & ! inputs ipr = 10 !-- - testptlat = 74.12 !29.5 - testptlon = 164.0 !283.0 + testptlat = 68.6 !41.02 !42.05 !39.0 !74.12 !29.5 + testptlon = 298.6 !284.50 !286.75 !280.6 !164.0 !283.0 !-- debug_print=.false. @@ -573,20 +581,6 @@ subroutine lsm_ruc_run & ! inputs flag(i) = land(i) .or. flag_ice_uncoupled(i) enddo - if (isot == 1) then - nscat = 19 ! stasgo - else - nscat = 9 ! zobler - endif - allocate(soilctop(im,nscat,1)) - - if(ivegsrc == 1) then - nlcat = 20 ! IGBP - "MODI-RUC" - else - nlcat = 13 - endif - allocate(landusef(im,nlcat,1)) - if(debug_print) then write (0,*)'RUC LSM run' write (0,*)'stype=',ipr,stype(ipr) @@ -615,8 +609,6 @@ subroutine lsm_ruc_run & ! inputs ! for now set fractions of differnet landuse and soil types ! in the grid cell to zero - landusef (:,:,:) = 0.0 - soilctop (:,:,:) = 0.0 !-- spp spp_lsm = 0 ! so far (10May2021) @@ -634,7 +626,7 @@ subroutine lsm_ruc_run & ! inputs if(ivegsrc == 1) then llanduse = 'MODI-RUC' ! IGBP iswater = 17 - isice = 15 + isice = glacier else write(errmsg, '(a,i0)') 'Logic error in sfc_drv_ruc_run: iswater/isice not configured for ivegsrc=', ivegsrc errflg = 1 @@ -671,27 +663,32 @@ subroutine lsm_ruc_run & ! inputs wetness_old(i) = wetness(i) canopy_old(i) = canopy(i) !srflag_old(i) = srflag(i) - !acsnow_old(i) = acsnow(i) ! for land weasd_lnd_old(i) = weasd_lnd(i) snwdph_lnd_old(i) = snwdph_lnd(i) tskin_lnd_old(i) = tskin_lnd(i) tsnow_lnd_old(i) = tsnow_lnd(i) - snowfallac_lnd_old(i) = snowfallac_lnd(i) sfcqv_lnd_old(i) = sfcqv_lnd(i) sfcqc_lnd_old(i) = sfcqc_lnd(i) z0rl_lnd_old(i) = z0rl_lnd(i) sncovr1_lnd_old(i) = sncovr1_lnd(i) + snowmt_lnd_old(i) = snowmt_lnd(i) + acsnow_lnd_old(i) = acsnow_lnd(i) + snowfallac_lnd_old(i) = snowfallac_lnd(i) + srunoff_old(i) = srunoff(i) + runoff_old(i) = runoff(i) ! for ice weasd_ice_old(i) = weasd_ice(i) snwdph_ice_old(i) = snwdph_ice(i) tskin_ice_old(i) = tskin_ice(i) tsnow_ice_old(i) = tsnow_ice(i) - snowfallac_ice_old(i) = snowfallac_ice(i) sfcqv_ice_old(i) = sfcqv_ice(i) sfcqc_ice_old(i) = sfcqc_ice(i) z0rl_ice_old(i) = z0rl_ice(i) sncovr1_ice_old(i) = sncovr1_ice(i) + snowmt_ice_old(i) = snowmt_ice(i) + acsnow_ice_old(i) = acsnow_ice(i) + snowfallac_ice_old(i) = snowfallac_ice(i) do k = 1, lsoil_ruc smois_old(i,k) = smois(i,k) @@ -725,6 +722,8 @@ subroutine lsm_ruc_run & ! inputs sbsno(i) = 0.0 !local i,j arrays + snoh_lnd(i,j) = 0.0 + snoh_ice(i,j) = 0.0 dew_lnd(i,j) = 0.0 dew_ice(i,j) = 0.0 soilm(i,j) = 0.0 @@ -735,22 +734,26 @@ subroutine lsm_ruc_run & ! inputs qfx_ice(i,j) = 0.0 lh_lnd(i,j) = 0.0 lh_ice(i,j) = 0.0 - acsn(i,j) = 0.0 + esnow_lnd(i,j) = 0.0 + esnow_ice(i,j) = 0.0 sfcexc(i,j) = 0.0 acceta(i,j) = 0.0 ssoil_lnd(i,j) = 0.0 ssoil_ice(i,j) = 0.0 - snomlt_lnd(i,j) = 0.0 - snomlt_ice(i,j) = 0.0 infiltr(i,j) = 0.0 + precipfr(i,j) = 0.0 + rhosnfr(i,j) = -1.e3 runoff1(i,j) = 0.0 runoff2(i,j) = 0.0 - acrunoff(i,j) = 0.0 - snfallac_lnd(i,j) = 0.0 - snfallac_ice(i,j) = 0.0 - rhosnfr(i,j) = -1.e3 - precipfr(i,j) = 0.0 - + if(kdt == 1) then + acrunoff(i,j) = 0.0 + snfallac_lnd(i,j) = 0.0 + acsn_lnd(i,j) = 0.0 + snfallac_ice(i,j) = 0.0 + acsn_ice(i,j) = 0.0 + snomlt_lnd(i,j) = 0.0 + snomlt_ice(i,j) = 0.0 + endif endif enddo ! i=1,im enddo @@ -787,6 +790,19 @@ subroutine lsm_ruc_run & ! inputs frpcpn = .false. endif + do j = 1, 1 ! 1:1 + do i = 1, im ! i - horizontal loop + orog(i,j) = oro(i) !topography + stdev(i,j) = sigma(i) ! st. deviation (m) + do k=1,nlcat + landusef(i,k,j) = vegtype_frac(i,k) + enddo + do k=1,nscat + soilctop(i,k,j) = soiltype_frac(i,k) + enddo + enddo + enddo + do j = 1, 1 ! 1:1 do i = 1, im ! i - horizontal loop xice(i,j) = 0. @@ -810,9 +826,9 @@ subroutine lsm_ruc_run & ! inputs !> - 2. forcing data (f): !!\n \a sfcprs - pressure at height zf above ground (pascals) !!\n \a sfctmp - air temperature (\f$K\f$) at height zf above ground -!!\n \a q2 - pressure at height zf above ground (pascals) -!!\n \a qcatm - cloud water mising ration at height zf above ground (\f$kg !kg^{-1}\f$) -!!\n \a rho2 - air density at height zf above ground (pascals) +!!\n \a q2 - water vapor mix. ratio at height zf above ground (\f$kg kg^{-1}\f$) +!!\n \a qcatm - cloud water mixing ratio at height zf above ground (\f$kg kg^{-1}\f$) +!!\n \a rho2 - air density at height zf above ground ((\f$kg m^{-3}\f$)) sfcprs(i,1,j) = prsl1(i) sfctmp(i,1,j) = t1(i) @@ -827,7 +843,7 @@ subroutine lsm_ruc_run & ! inputs !!\n \a rainncv - time-step non-convective precip (\f$kg m^{-2} \f$) !!\n \a graupelncv - time-step graupel (\f$kg m^{-2} \f$) !!\n \a snowncv - time-step snow (\f$kg m^{-2} \f$) -!!\n \a precipfr - time-step precipitation in solod form (\f$kg m^{-2} \f$) +!!\n \a precipfr - time-step precipitation in solid form (\f$kg m^{-2} \f$) !!\n \a shdfac - areal fractional coverage of green vegetation (0.0-1.0) !!\n \a shdmin - minimum areal fractional coverage of green vegetation -> !shdmin1d !!\n \a shdmax - maximum areal fractional coverage of green vegetation -> !shdmax1d @@ -842,17 +858,17 @@ subroutine lsm_ruc_run & ! inputs !rainncv(i,j) = rhoh2o * max(rain(i)-rainc(i),0.0) ! total time-step explicit precip !graupelncv(i,j) = rhoh2o * graupel(i) !snowncv(i,j) = rhoh2o * snow(i) - prcp(i,j) = rhoh2o * (rainc(i)+rainnc(i)) ! tprcp in [m] - convective plus explicit - raincv(i,j) = rhoh2o * rainc(i) ! total time-step convective precip - rainncv(i,j) = rhoh2o * rainnc(i) ! total time-step explicit precip + prcp(i,j) = rhoh2o * (rainc(i)+rainnc(i)) ! total time-step convective plus explicit [mm] + raincv(i,j) = rhoh2o * rainc(i) ! total time-step convective precip [mm] + rainncv(i,j) = rhoh2o * rainnc(i) ! total time-step explicit precip [mm] graupelncv(i,j) = rhoh2o * graupel(i) snowncv(i,j) = rhoh2o * snow(i) - rhonewsn(i,j) = rhonewsn1(i) + rhonewsn_ex(i) = rhonewsn1(i) if (debug_print) then !-- diagnostics for a test point with known lat/lon - if (abs(xlat_d(i)-testptlat).lt.2.5 .and. & - abs(xlon_d(i)-testptlon).lt.6.5)then - if(weasd_lnd(i) > 0.) & + if (abs(xlat_d(i)-testptlat).lt.0.2 .and. & + abs(xlon_d(i)-testptlon).lt.0.2)then + !if(weasd_lnd(i) > 0.) & print 100,'(ruc_lsm_drv) i=',i, & ' lat,lon=',xlat_d(i),xlon_d(i), & 'rainc',rainc(i),'rainnc',rainnc(i), & @@ -861,11 +877,12 @@ subroutine lsm_ruc_run & ! inputs 'sncovr1_lnd',sncovr1_lnd(i),'sfalb_lnd_bck',sfalb_lnd_bck(i),& 'prsl1',prsl1(i),'t1',t1(i), & !'snow',snow(i), 'snowncv',snowncv(i,j), & - 'srflag',srflag(i),'weasd_lnd',weasd_lnd(i), & + 'srflag',srflag(i),'weasd mm ',weasd_lnd(i), & + 'tsnow_lnd',tsnow_lnd(i),'snwdph mm',snwdph_lnd(i), & 'tsurf_lnd',tsurf_lnd(i),'tslb(i,1)',tslb(i,1) endif endif - 100 format (";;; ",a,i4,a,2f9.2/(4(a10,'='es9.2))) + 100 format (";;; ",a,i4,a,2f14.7/(4(a10,'='es9.2))) !-- ! ice precipitation is not used @@ -873,8 +890,6 @@ subroutine lsm_ruc_run & ! inputs ! ice not used ! precipfr(i,j) = rainncv(i,j) * ffrozp(i,j) - !acsn(i,j) = acsnow(i) - acsn(i,j) = 0.0 tbot(i,j) = tg3(i) @@ -969,7 +984,7 @@ subroutine lsm_ruc_run & ! inputs endif ! coszen > 0. snoalb1d_lnd(i,j) = snoalb(i) - albbck_lnd(i,j) = albbcksol(i) !sfalb_lnd_bck(i) + albbck_lnd(i,j) = min(0.9,albbcksol(i)) !sfalb_lnd_bck(i) !-- spp_lsm @@ -995,14 +1010,14 @@ subroutine lsm_ruc_run & ! inputs solnet_lnd(i,j) = dswsfc(i)*(1.-alb_lnd(i,j)) !..net sw rad flx (dn-up) at sfc in w/m2 cmc(i,j) = canopy(i) ! [mm] - soilt_lnd(i,j) = tsurf_lnd(i) ! clu_q2m_iter + soilt_lnd(i,j) = tsurf_lnd(i) ! sanity check for snow temperature tsnow - if (tsnow_lnd(i) > 0. .and. tsnow_lnd(i) < 273.15) then + if (tsnow_lnd(i) > 200. .and. tsnow_lnd(i) < 273.15) then soilt1_lnd(i,j) = tsnow_lnd(i) else soilt1_lnd(i,j) = tsurf_lnd(i) endif - tsnav_lnd(i,j) = 0.5*(soilt_lnd(i,j) + soilt1_lnd(i,j)) - 273.15 + tsnav_lnd(i,j) = min(0.,0.5*(soilt_lnd(i,j) + soilt1_lnd(i,j)) - 273.15) do k = 1, lsoil_ruc smsoil (i,k,j) = smois(i,k) slsoil (i,k,j) = sh2o(i,k) @@ -1018,27 +1033,79 @@ subroutine lsm_ruc_run & ! inputs endif chs_lnd (i,j) = ch_lnd(i) * wind(i) ! compute conductance - flhc_lnd(i,j) = chs_lnd(i,j) * rho(i) * con_cp ! * (1. + 0.84*q2(i,1,j)) + flhc_lnd(i,j) = chs_lnd(i,j) * rho(i) * con_cp * (1.+0.84*q2(i,1,j)) flqc_lnd(i,j) = chs_lnd(i,j) * rho(i) * wet(i,j) + ! for output cmm_lnd(i) = cm_lnd(i) * wind(i) chh_lnd(i) = chs_lnd(i,j) * rho(i) ! - snowh_lnd(i,j) = snwdph_lnd(i) * 0.001 ! convert from mm to m - sneqv_lnd(i,j) = weasd_lnd(i) ! [mm] - snfallac_lnd(i,j) = snowfallac_lnd(i) - !> -- sanity checks on sneqv and snowh - if (sneqv_lnd(i,j) /= 0.0 .and. snowh_lnd(i,j) == 0.0) then - snowh_lnd(i,j) = 0.003 * sneqv_lnd(i,j) ! snow density ~300 kg m-3 + sneqv_lnd(i,j) = weasd_lnd(i) + snowh_lnd(i,j) = snwdph_lnd(i) * 0.001 ! convert from mm to m + + if(kdt > 1) then + !-- run-total accumulation + snfallac_lnd(i,j) = snowfallac_lnd(i) + acsn_lnd(i,j) = acsnow_lnd(i) + snomlt_lnd(i,j) = snowmt_lnd(i) endif - if (snowh_lnd(i,j) /= 0.0 .and. sneqv_lnd(i,j) == 0.0) then - sneqv_lnd(i,j) = 300. * snowh_lnd(i,j) ! snow density ~300 kg m-3 - endif - - if (sneqv_lnd(i,j) > 0. .and. snowh_lnd(i,j) > 0.) then - if(sneqv_lnd(i,j)/snowh_lnd(i,j) > 950.) then - sneqv_lnd(i,j) = 300. * snowh_lnd(i,j) + !> -- sanity checks on sneqv and snowh + if (sneqv_lnd(i,j) /= 0.0d0 .and. snowh_lnd(i,j) == 0.0d0) then + if (debug_print) print *,'bad sneqv_lnd',kdt,i,j,sneqv_lnd(i,j),snowh_lnd(i,j),xlat_d(i),xlon_d(i) + if(sneqv_lnd(i,j) < 1.e-7.or.soilt_lnd(i,j)>273.15d0) then + sneqv_lnd(i,j) = 0.d0 + snowh_lnd(i,j) = 0.d0 + else + sneqv_lnd(i,j) = 300.d0 * snowh_lnd(i,j) ! snow density ~300 kg m-3 + endif + if (debug_print) print *,'fixed sneqv_lnd',kdt,i,j,sneqv_lnd(i,j),snowh_lnd(i,j) + elseif (snowh_lnd(i,j) /= 0.0d0 .and. sneqv_lnd(i,j) == 0.0d0) then + if (debug_print) print *,'bad snowh_lnd',kdt,i,j,sneqv_lnd(i,j),snowh_lnd(i,j),xlat_d(i),xlon_d(i) + if(snowh_lnd(i,j) < 3.d-10.or.soilt_lnd(i,j)>273.15d0) then + snowh_lnd(i,j) = 0.d0 + sneqv_lnd(i,j) = 0.d0 + else + snowh_lnd(i,j) = 0.003d0 * sneqv_lnd(i,j) ! snow density ~300 kg m-3 + endif + if (debug_print) print *,'fixed snowh_lnd',kdt,i,j,sneqv_lnd(i,j),snowh_lnd(i,j) + elseif (sneqv_lnd(i,j) > 0.d0 .and. snowh_lnd(i,j) > 0.d0) then + if (debug_print .and. abs(xlat_d(i)-testptlat).lt.2.5 .and. & + abs(xlon_d(i)-testptlon).lt.2.5)then + print *,'sneqv_lnd(i,j)/snowh_lnd(i,j)',kdt,i,j,sneqv_lnd(i,j)/snowh_lnd(i,j),sneqv_lnd(i,j),snowh_lnd(i,j) + endif + if(sneqv_lnd(i,j)/snowh_lnd(i,j) > 500.d0) then + if (debug_print .and. abs(xlat_d(i)-testptlat).lt.0.5 .and. & + abs(xlon_d(i)-testptlon).lt.0.5)then + print *,'large snow density',kdt,i,j,sneqv_lnd(i,j)/snowh_lnd(i,j),sneqv_lnd(i,j),snowh_lnd(i,j) + print *,'large snow density lat/lon',kdt,i,j,xlat_d(i),xlon_d(i) + endif + if(soilt_lnd(i,j)>273.15d0) then + snowh_lnd(i,j) = 0.d0 + sneqv_lnd(i,j) = 0.d0 + else + snowh_lnd(i,j) = 0.002d0 * sneqv_lnd(i,j) + endif + if (debug_print .and. abs(xlat_d(i)-testptlat).lt.0.5 .and. & + abs(xlon_d(i)-testptlon).lt.0.5)then + print *,'fixed large snow density',kdt,i,j,sneqv_lnd(i,j)/snowh_lnd(i,j),sneqv_lnd(i,j),snowh_lnd(i,j) + endif + elseif(sneqv_lnd(i,j)/snowh_lnd(i,j) < 58.d0) then + if (debug_print .and. abs(xlat_d(i)-testptlat).lt.0.5 .and. & + abs(xlon_d(i)-testptlon).lt.0.5)then + print *,'small snow density',kdt,i,j,sneqv_lnd(i,j)/snowh_lnd(i,j),sneqv_lnd(i,j),snowh_lnd(i,j) + print *,'small snow density lat/lon',kdt,i,j,xlat_d(i),xlon_d(i) + endif + if(soilt_lnd(i,j)>273.15d0) then + snowh_lnd(i,j) = 0.d0 + sneqv_lnd(i,j) = 0.d0 + else + sneqv_lnd(i,j) = 58.d0 * snowh_lnd(i,j) + endif + if (debug_print .and. abs(xlat_d(i)-testptlat).lt.0.5 .and. & + abs(xlon_d(i)-testptlon).lt.0.5)then + print *,'fixed small snow density',kdt,i,j,sneqv_lnd(i,j)/snowh_lnd(i,j),sneqv_lnd(i,j),snowh_lnd(i,j) + endif endif endif @@ -1060,64 +1127,35 @@ subroutine lsm_ruc_run & ! inputs sneqv_lnd(i,j)=0 endif - if(debug_print) then - if(me==0 ) then - write (0,*)'before LSMRUC for land' - write (0,*)'sfcems(i,j) =',i,j,sfcems_lnd(i,j) - write (0,*)'chklowq(i,j) =',i,j,chklowq(i,j) - write (0,*)'chs(i,j) =',i,j,chs_lnd(i,j) - write (0,*)'flqc(i,j) =',i,j,flqc_lnd(i,j) - write (0,*)'flhc(i,j) =',i,j,flhc_lnd(i,j) - write (0,*)'wet(i,j) =',i,j,wet(i,j) - write (0,*)'cmc(i,j) =',i,j,cmc(i,j) - write (0,*)'shdfac(i,j) =',i,j,shdfac(i,j) - write (0,*)'alb(i,j) =',i,j,alb_lnd(i,j) - write (0,*)'znt(i,j) =',i,j,znt_lnd(i,j) - write (0,*)'z0(i,j) =',i,j,z0_lnd(i,j) - write (0,*)'snoalb1d(i,j) =',i,j,snoalb1d_lnd(i,j) - write (0,*)'landusef(i,:,j) =',i,j,landusef(i,:,j) - write (0,*)'soilctop(i,:,j) =',i,j,soilctop(i,:,j) - write (0,*)'nlcat=',nlcat - write (0,*)'nscat=',nscat - write (0,*)'qsfc(i,j) =',i,j,qsfc_lnd(i,j) - write (0,*)'qvg(i,j) =',i,j,qvg_lnd(i,j) - write (0,*)'qsg(i,j) =',i,j,qsg_lnd(i,j) - write (0,*)'qcg(i,j) =',i,j,qcg_lnd(i,j) - write (0,*)'dew(i,j) =',i,j,dew_lnd(i,j) - write (0,*)'soilt(i,j) =',i,j,soilt_lnd(i,j) - write (0,*)'tskin(i) =',i,j,tskin_lnd(i) - write (0,*)'soilt1(i,j) =',i,j,soilt1_lnd(i,j) - write (0,*)'tsnav(i,j) =',i,j,tsnav_lnd(i,j) - write (0,*)'tbot(i,j) =',i,j,tbot(i,j) - write (0,*)'vtype(i,j) =',i,j,vtype_lnd(i,j) - write (0,*)'stype(i,j) =',i,j,stype_lnd(i,j) - write (0,*)'xland(i,j) =',i,j,xland(i,j) - write (0,*)'xice(i,j) =',i,j,xice(i,j) - write (0,*)'iswater=',iswater - write (0,*)'isice=',isice - write (0,*)'xice_threshold=',xice_threshold - write (0,*)'con_cp=',con_cp - write (0,*)'con_rv=',con_rv - write (0,*)'con_rd=',con_rd - write (0,*)'con_g=',con_g - write (0,*)'con_pi=',con_pi - write (0,*)'con_hvap=',con_hvap - write (0,*)'stbolt=',stbolt - write (0,*)'smsoil(i,:,j)=',i,j,smsoil(i,:,j) - write (0,*)'slsoil(i,:,j)=',i,j,slsoil(i,:,j) - write (0,*)'stsoil(i,:,j)=',i,j,stsoil(i,:,j) - write (0,*)'smfrsoil(i,:,j)=',i,j,smfrsoil(i,:,j) - write (0,*)'keepfrsoil(i,:,j)=',i,j,keepfrsoil(i,:,j) - write (0,*)'acrunoff(i,j) =',i,j,acrunoff(i,j) - write (0,*)'acsn(i,j) =',i,j,acsn(i,j) - write (0,*)'shdmin1d(i,j) =',i,j,shdmin1d(i,j) - write (0,*)'shdmax1d(i,j) =',i,j,shdmax1d(i,j) - write (0,*)'rdlai2d =',rdlai2d - endif + !if (debug_print) then + !-- diagnostics for a land test point with known lat/lon + if (kdt < 10) then + if (abs(xlat_d(i)-testptlat).lt.0.5 .and. & + abs(xlon_d(i)-testptlon).lt.0.5)then + !if(weasd_lnd(i) > 0.) & + print 100,'(ruc_lsm_drv before RUC land call) i=',i, & + ' lat,lon=',xlat_d(i),xlon_d(i), & + 'rainc',rainc(i),'rainnc',rainnc(i),'prcp',prcp(i,j), & + 'graupel',graupel(i),'qc',qc(i),'sfcqv_lnd',sfcqv_lnd(i),& + !'snow',snow(i), 'snowncv',snowncv(i,j), & + 'dlwflx',dlwflx(i),'dswsfc',dswsfc(i), & + 'sncovr1_lnd',sncovr1_lnd(i),'sfalb_lnd_bck',sfalb_lnd_bck(i),& + 'albbcksol',albbcksol(i),'alb_lnd',alb_lnd(i,j), & + 'solnet_lnd',solnet_lnd(i,j),'t1',t1(i), & + 'sfcems_lnd',sfcems_lnd(i,j),'flhc_lnd',flhc_lnd(i,j), & + 'flqc_lnd',flqc_lnd(i,j),'wet',wet(i,j),'cmc',cmc(i,j),& + 'qcg_lnd',qcg_lnd(i,j),'dew',dew_lnd(i,j), & + 'znt_lnd',znt_lnd(i,j),'shdfac',shdfac(i,j), & + 'srflag',srflag(i),'weasd_lnd',weasd_lnd(i), & + 'smsoil1',smsoil(i,1,j),'slsoil',slsoil(i,1,j), & + 'keepfrsoil',keepfrsoil(i,1,j), & + 'tsurf_lnd',tsurf_lnd(i),'tslb(i,1)',tslb(i,1) endif + endif ! debug_print + !-- !> - Call RUC LSM lsmruc() for land. - call lsmruc( & + call lsmruc(xlat_d(i),xlon_d(i), & & delt, flag_init, lsm_cold_start, kdt, iter, nsoil, & & graupelncv(i,j), snowncv(i,j), rainncv(i,j), raincv(i,j), & & zs, prcp(i,j), sneqv_lnd(i,j), snowh_lnd(i,j), & @@ -1125,16 +1163,15 @@ subroutine lsm_ruc_run & ! inputs & ffrozp(i,j), frpcpn, & & rhosnfr(i,j), precipfr(i,j), exticeden, & ! --- inputs: + & orog(i,j), stdev(i,j), & & conflx2(i,1,j), sfcprs(i,1,j), sfctmp(i,1,j), q2(i,1,j), & & qcatm(i,1,j), rho2(i,1,j), semis_bck(i,j), lwdn(i,j), & & swdn(i,j), solnet_lnd(i,j), sfcems_lnd(i,j), chklowq(i,j), & - & chs_lnd(i,j), flqc_lnd(i,j), flhc_lnd(i,j), rhonewsn(i,j), & + & chs_lnd(i,j), flqc_lnd(i,j), flhc_lnd(i,j), rhonewsn_ex(i), & ! --- input/outputs: & wet(i,j), cmc(i,j), shdfac(i,j), alb_lnd(i,j), znt_lnd(i,j), & & z0_lnd(i,j), snoalb1d_lnd(i,j), albbck_lnd(i,j), & & xlai(i,j), landusef(i,:,j), nlcat, & -! --- mosaic_lu and mosaic_soil are moved to the namelist -! & mosaic_lu, mosaic_soil, & & soilctop(i,:,j), nscat, & & qsfc_lnd(i,j), qsg_lnd(i,j), qvg_lnd(i,j), qcg_lnd(i,j), & & dew_lnd(i,j), soilt1_lnd(i,j), & @@ -1145,51 +1182,54 @@ subroutine lsm_ruc_run & ! inputs ! --- input/outputs: & smsoil(i,:,j), slsoil(i,:,j), soilm(i,j), smmax(i,j), & & stsoil(i,:,j), soilt_lnd(i,j), & + & edir(i,j), ec(i,j), ett(i,j), esnow_lnd(i,j), snoh_lnd(i,j), & & hfx_lnd(i,j), qfx_lnd(i,j), lh_lnd(i,j), & & infiltr(i,j), runoff1(i,j), runoff2(i,j), acrunoff(i,j), & & sfcexc(i,j), acceta(i,j), ssoil_lnd(i,j), & - & snfallac_lnd(i,j), acsn(i,j), snomlt_lnd(i,j), & + & snfallac_lnd(i,j), acsn_lnd(i,j), snomlt_lnd(i,j), & & smfrsoil(i,:,j),keepfrsoil(i,:,j), .false., & & shdmin1d(i,j), shdmax1d(i,j), rdlai2d, & & ims,ime, jms,jme, kms,kme, & - & its,ite, jts,jte, kts,kte, & - & errmsg, errflg) - if(debug_print) then - write (0,*)'after LSMRUC for land' - write (0,*)'after sneqv(i,j) =',i,j,sneqv_lnd(i,j) - write (0,*)'after snowh(i,j) =',i,j,snowh_lnd(i,j) - write (0,*)'after sncovr(i,j) =',i,j,sncovr_lnd(i,j) - write (0,*)'after vtype(i,j) =',i,j,vtype_lnd(i,j) - write (0,*)'after stype(i,j) =',i,j,stype_lnd(i,j) - write (0,*)'after wet(i,j) =',i,j,wet(i,j) - write (0,*)'after cmc(i,j) =',i,j,cmc(i,j) - write (0,*)'after qsfc(i,j) =',i,j,qsfc_lnd(i,j) - write (0,*)'after qvg(i,j) =',i,j,qvg_lnd(i,j) - write (0,*)'after qsg(i,j) =',i,j,qsg_lnd(i,j) - write (0,*)'after qcg(i,j) =',i,j,qcg_lnd(i,j) - write (0,*)'after dew(i,j) =',i,j,dew_lnd(i,j) - write (0,*)'after soilt(i,j) =',i,j,soilt_lnd(i,j) - write (0,*)'after tskin(i) =',i,j,tskin_lnd(i) - write (0,*)'after soilt1(i,j) =',i,j,soilt1_lnd(i,j) - write (0,*)'after tsnav(i,j) =',i,j,tsnav_lnd(i,j) - write (0,*)'after smsoil(i,:,j)=',i,j,smsoil(i,:,j) - write (0,*)'after slsoil(i,:,j)=',i,j,slsoil(i,:,j) - write (0,*)'after stsoil(i,:,j)=',i,j,stsoil(i,:,j) - write (0,*)'after smfrsoil(i,:,j)=',i,j,smfrsoil(i,:,j) - write (0,*)'after keepfrsoil(i,:,j)=',i,j,keepfrsoil(i,:,j) - write (0,*)'after soilm(i,j) =',i,j,soilm(i,j) - write (0,*)'after smmax(i,j) =',i,j,smmax(i,j) - write (0,*)'after hfx(i,j) =',i,j,hfx_lnd(i,j) - write (0,*)'after qfx(i,j) =',i,j,qfx_lnd(i,j) - write (0,*)'after lh(i,j) =',i,j,lh_lnd(i,j) - write (0,*)'after infiltr(i,j) =',i,j,infiltr(i,j) - write (0,*)'after runoff1(i,j) =',i,j,runoff1(i,j) - write (0,*)'after runoff2(i,j) =',i,j,runoff2(i,j) - write (0,*)'after ssoil(i,j) =',i,j,ssoil_lnd(i,j) - write (0,*)'after snfallac(i,j) =',i,j,snfallac_lnd(i,j) - write (0,*)'after acsn(i,j) =',i,j,acsn(i,j) - write (0,*)'after snomlt(i,j) =',i,j,snomlt_lnd(i,j) - endif + & its,ite, jts,jte, kts,kte, errmsg, errflg ) + if(debug_print) then + if (abs(xlat_d(i)-testptlat).lt.0.5 .and. & + abs(xlon_d(i)-testptlon).lt.0.5)then + print 100,'(ruc_lsm_drv after RUC land call) i=',i, & + ' lat,lon=',xlat_d(i),xlon_d(i), & + 'sneqv(i,j) =',sneqv_lnd(i,j), & + 'snowh(i,j) =',snowh_lnd(i,j), & + 'sncovr(i,j) =',sncovr_lnd(i,j), & + 'vtype(i,j) =',vtype_lnd(i,j), & + 'stype(i,j) =',stype_lnd(i,j), & + 'wet(i,j) =',wet(i,j), & + 'cmc(i,j) =',cmc(i,j), & + 'qsfc(i,j) =',qsfc_lnd(i,j), & + 'qvg(i,j) =',qvg_lnd(i,j), & + 'qsg(i,j) =',qsg_lnd(i,j), & + 'qcg(i,j) =',qcg_lnd(i,j), & + 'dew(i,j) =',dew_lnd(i,j), & + 'soilt(i,j) =',soilt_lnd(i,j), & + 'tskin(i) =',tskin_lnd(i), & + 'soilt1(i,j) =',soilt1_lnd(i,j), & + 'tsnav(i,j) =',tsnav_lnd(i,j), & + 'smsoil(i,:,j)=',smsoil(i,:,j), & + 'slsoil(i,:,j)=',slsoil(i,:,j), & + 'stsoil(i,:,j)=',stsoil(i,:,j), & + 'smfrsoil(i,:,j)=',smfrsoil(i,:,j), & + 'keepfrsoil(i,:,j)=',keepfrsoil(i,:,j), & + 'soilm(i,j) =',soilm(i,j), & + 'smmax(i,j) =',smmax(i,j), & + 'hfx(i,j) =',hfx_lnd(i,j), & + 'lh(i,j) =',lh_lnd(i,j), & + 'infiltr(i,j) =',infiltr(i,j), & + 'runoff1(i,j) =',runoff1(i,j), & + 'runoff2(i,j) =',runoff2(i,j), & + 'ssoil(i,j) =',ssoil_lnd(i,j), & + 'snfallac(i,j) =',snfallac_lnd(i,j), & + 'acsn_lnd(i,j) =',acsn_lnd(i,j), & + 'snomlt(i,j) =',snomlt_lnd(i,j) + endif + endif !> - RUC LSM: prepare variables for return to parent model and unit conversion. @@ -1199,23 +1239,22 @@ subroutine lsm_ruc_run & ! inputs !!\n \a ssoil - soil heat flux (\f$W m^{-2}\f$: negative if downward from surface) !!\n \a runoff1 - surface runoff (\f$m s^{-1}\f$), not infiltrating the surface !!\n \a runoff2 - subsurface runoff (\f$m s^{-1}\f$), drainage out bottom -!!\n \a snoh - phase-change heat flux from snowmelt (w m-2) -!!\n \a lh - actual latent heat flux (\f$W m^{-2}\f$: positive, if upward from sfc) -!!\n \a hfx - sensible heat flux (\f$W m^{-2}\f$: positive, if upward from sfc) -!!\n \a ssoil - soil heat flux (\f$W m^{-2}\f$: negative if downward from surface) -!!\n \a runoff1 - surface runoff (\f$m s^{-1}\f$), not infiltrating the surface -!!\n \a runoff2 - subsurface runoff (\f$m s^{-1}\f$), drainage out bottom -!!\n \a snoh - phase-change heat flux from snowmelt (w m-2) +!!\n \a snoh - phase-change heat flux from snowmelt (\f$W m^{-2}\f$) ! -! --- ... do not return the following output fields to parent model -! ec - canopy water evaporation (m s-1) -! edir - direct soil evaporation (m s-1) +! --- ... units [m/s] = [g m-2 s-1] +! evcw (W m-2) - canopy water evaporation flux +! evbs (W m-2) - direct soil evaporation flux +! trans (W m-2) - total plant transpiration +! edir, ec, ett - direct evaporation, evaporation of +! canopy water and transpiration (kg m-2 s-1) ! et(nsoil)-plant transpiration from a particular root layer (m s-1) -! ett - total plant transpiration (m s-1) -! esnow - sublimation from (or deposition to if <0) snowpack (m s-1) +! esnow - sublimation from (or deposition to if <0) snowpack (kg m-2 s-1) +! sbsno - sublimation from (or deposition to if <0) snowpack (W m-2) +! hfx - upward heat flux at the surface (W/m^2) +! qfx - upward moisture flux at the surface (kg kg-1 kg m-2 s-1) ! drip - through-fall of precip and/or dew in excess of canopy ! water-holding capacity (m) -! snomlt - snow melt (m) (water equivalent) +! snomlt - snow melt (kg m-2) (water equivalent) ! xlai - leaf area index (dimensionless) ! soilw - available soil moisture in root zone (unitless fraction ! between smcwlt and smcmax) @@ -1223,40 +1262,39 @@ subroutine lsm_ruc_run & ! inputs ! nroot - number of root layers, a function of veg type, determined ! in subroutine redprm. - - !evbs(i) = edir(i,j) - !evcw(i) = ec(i,j) - !trans(i) = ett(i,j) - !sbsno(i) = esnow(i,j) - !snohf(i) = snoh(i,j) + evbs(i) = edir(i,j) * rhoh2o * con_hvap + evcw(i) = ec(i,j) * rhoh2o * con_hvap + trans(i) = ett(i,j) * rhoh2o * con_hvap + sbsno(i) = esnow_lnd(i,j) * con_hfus + snohf(i) = snoh_lnd(i,j) ! Interstitial - evap_lnd(i) = qfx_lnd(i,j) / rho(i) ! kinematic - hflx_lnd(i) = hfx_lnd(i,j) / (con_cp*rho(i)) ! kinematic + evap_lnd(i) = qfx_lnd(i,j) / rho(i) ! kg kg-1 m s-1 kinematic + hflx_lnd(i) = hfx_lnd(i,j) / (con_cp*rho(i)) ! K m s-1 kinematic gflux_lnd(i) = ssoil_lnd(i,j) qsurf_lnd(i) = qsfc_lnd(i,j) tsurf_lnd(i) = soilt_lnd(i,j) tsnow_lnd(i) = soilt1_lnd(i,j) stm(i) = soilm(i,j) * 1.e-3 ! convert to [m] - runof (i) = runoff1(i,j) - drain (i) = runoff2(i,j) + runof (i) = runoff1(i,j) * rhoh2o ! surface kg m-2 s-1 + drain (i) = runoff2(i,j) * rhoh2o ! kg m-2 s-1 wetness(i) = wet(i,j) - - ! tsnow(i) = soilt1(i,j) sfcqv_lnd(i) = qvg_lnd(i,j) sfcqc_lnd(i) = qcg_lnd(i,j) - ! --- ... units [m/s] = [g m-2 s-1] - rhosnf(i) = rhosnfr(i,j) - !acsnow(i) = acsn(i,j) ! kg m-2 + + rhosnf(i) = rhosnfr(i,j) ! kg m-3 + acsnow_lnd(i) = acsn_lnd(i,j) ! accum kg m-2 + snowmt_lnd(i) = snomlt_lnd(i,j) ! accum kg m-2 ! --- ... accumulated total runoff and surface runoff - runoff(i) = runoff(i) + (drain(i)+runof(i)) * delt * 0.001 ! kg m-2 - srunoff(i) = srunoff(i) + runof(i) * delt * 0.001 ! kg m-2 + runoff(i) = runoff(i) + (drain(i)+runof(i)) * delt ! accum total kg m-2 + !srunoff(i) = srunoff(i) + runof(i) * delt ! accum surface kg m-2 + srunoff(i) = acrunoff(i,j) ! accum surface kg m-2 ! --- ... accumulated frozen precipitation (accumulation in lsmruc) - snowfallac_lnd(i) = snfallac_lnd(i,j) ! kg m-2 + snowfallac_lnd(i) = snfallac_lnd(i,j) ! accum kg m-2 ! --- ... unit conversion (from m to mm) snwdph_lnd(i) = snowh_lnd(i,j) * 1000.0 @@ -1275,7 +1313,7 @@ subroutine lsm_ruc_run & ! inputs !-- fill in albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, albdvis_lnd(i) = sfalb_lnd(i) albdnir_lnd(i) = sfalb_lnd(i) - albinir_lnd(i) = sfalb_lnd(i) + albivis_lnd(i) = sfalb_lnd(i) albinir_lnd(i) = sfalb_lnd(i) do k = 1, lsoil_ruc @@ -1296,23 +1334,26 @@ subroutine lsm_ruc_run & ! inputs !-- ice point if (debug_print) then - if (abs(xlat_d(i)-testptlat).lt.2.5 .and. & - abs(xlon_d(i)-testptlon).lt.6.5)then - if(weasd_lnd(i) > 0.) & - print 101,'(ruc_lsm_drv ice) i=',i, & - ' lat,lon=',xlat_d(i),xlon_d(i),'flag_ice',flag_ice(i),& + if (abs(xlat_d(i)-testptlat).lt.0.1 .and. & + abs(xlon_d(i)-testptlon).lt.0.1)then + !if(weasd_ice(i) > 0.) & + print 101,'(ruc_lsm_drv_ice) i=',i, & + ' lat,lon=',xlat_d(i),xlon_d(i), & !'rainc',rainc(i),'rainnc',rainnc(i), & 'sfcqv_ice',sfcqv_ice(i),& !'dlwflx',dlwflx(i),'dswsfc',dswsfc(i), & 'sncovr1_ice',sncovr1_ice(i),'sfalb_ice',sfalb_ice(i),& 'sfcqc_ice',sfcqc_ice(i),'tsnow_ice',tsnow_ice(i), & - 'prsl1',prsl1(i),'t1',t1(i), & - !'snow',snow(i), 'snowncv',snowncv(i,j), & + 'prsl1',prsl1(i),'t1',t1(i),'snwdph_ice ',snwdph_ice(i), & 'srflag',srflag(i),'weasd_ice',weasd_ice(i), & 'tsurf_ice',tsurf_ice(i),'tslb(i,1)',tslb(i,1) endif endif - 101 format (";;; ",a,i4,a,2f9.2/(4(a10,'='es9.2))) + 101 format (";;; ",a,i4,a,2f14.7/(4(a10,'='es9.2))) + + edir (i,j) = 0.0 + ec (i,j) = 0.0 + ett (i,j) = 0.0 sncovr_ice(i,j) = sncovr1_ice(i) !-- alb_ice* is computed in setalb called from rrtmg_sw_pre. @@ -1331,13 +1372,13 @@ subroutine lsm_ruc_run & ! inputs sfcems_ice(i,j) = semis_ice(i) endif cmc(i,j) = canopy(i) ! [mm] - soilt_ice(i,j) = tsurf_ice(i) ! clu_q2m_iter - if (tsnow_ice(i) > 0. .and. tsnow_ice(i) < 273.15) then + soilt_ice(i,j) = tsurf_ice(i) + if (tsnow_ice(i) > 150. .and. tsnow_ice(i) < 273.15) then soilt1_ice(i,j) = tsnow_ice(i) else soilt1_ice(i,j) = tsurf_ice(i) endif - tsnav_ice(i,j) = 0.5*(soilt_ice(i,j) + soilt1_ice(i,j)) - 273.15 + tsnav_ice(i,j) = min(0.,0.5*(soilt_ice(i,j) + soilt1_ice(i,j)) - 273.15) do k = 1, lsoil_ruc stsice (i,k,j) = tsice(i,k) smice (i,k,j) = 1. @@ -1349,8 +1390,9 @@ subroutine lsm_ruc_run & ! inputs wet_ice(i,j) = 1. chs_ice (i,j) = ch_ice(i) * wind(i) ! compute conductance - flhc_ice(i,j) = chs_ice(i,j) * rho(i) * con_cp ! * (1. + 0.84*q2(i,1,j)) + flhc_ice(i,j) = chs_ice(i,j) * rho(i) * con_cp * (1. + 0.84*q2(i,1,j)) flqc_ice(i,j) = chs_ice(i,j) * rho(i) * wet_ice(i,j) + ! for output cmm_ice(i) = cm_ice (i) * wind(i) chh_ice(i) = chs_ice(i,j) * rho(i) @@ -1358,7 +1400,11 @@ subroutine lsm_ruc_run & ! inputs snowh_ice(i,j) = snwdph_ice(i) * 0.001 ! convert from mm to m sneqv_ice(i,j) = weasd_ice(i) ! [mm] - snfallac_ice(i,j) = snowfallac_ice(i) + if(kdt > 1) then + snfallac_ice(i,j) = snowfallac_ice(i) + acsn_ice(i,j) = acsnow_ice(i) + snomlt_ice(i,j) = snowmt_ice(i) + endif !> -- sanity checks on sneqv and snowh if (sneqv_ice(i,j) /= 0.0 .and. snowh_ice(i,j) == 0.0) then @@ -1378,6 +1424,9 @@ subroutine lsm_ruc_run & ! inputs z0_ice(i,j) = z0rl_ice(i)/100. znt_ice(i,j) = z0rl_ice(i)/100. + runoff1(i,j) = 0. + runoff2(i,j) = 0. + ! Workaround needed for subnormal numbers. This should be ! done after all other sanity checks, in case a sanity check ! results in subnormal numbers. @@ -1392,7 +1441,7 @@ subroutine lsm_ruc_run & ! inputs endif !> - Call RUC LSM lsmruc() for ice. - call lsmruc( & + call lsmruc(xlat_d(i),xlon_d(i), & & delt, flag_init, lsm_cold_start, kdt, iter, nsoil, & & graupelncv(i,j), snowncv(i,j), rainncv(i,j), raincv(i,j), & & zs, prcp(i,j), sneqv_ice(i,j), snowh_ice(i,j), & @@ -1400,16 +1449,15 @@ subroutine lsm_ruc_run & ! inputs & ffrozp(i,j), frpcpn, & & rhosnfr(i,j), precipfr(i,j), exticeden, & ! --- inputs: + & orog(i,j), stdev(i,j), & & conflx2(i,1,j), sfcprs(i,1,j), sfctmp(i,1,j), q2(i,1,j), & & qcatm(i,1,j), rho2(i,1,j), semis_bck(i,j), lwdn(i,j), & & swdn(i,j), solnet_ice(i,j), sfcems_ice(i,j), chklowq(i,j), & - & chs_ice(i,j), flqc_ice(i,j), flhc_ice(i,j), rhonewsn(i,j), & + & chs_ice(i,j), flqc_ice(i,j), flhc_ice(i,j), rhonewsn_ex(i), & ! --- input/outputs: & wet_ice(i,j), cmc(i,j), shdfac(i,j), alb_ice(i,j), & & znt_ice(i,j), z0_ice(i,j), snoalb1d_ice(i,j), & & albbck_ice(i,j), xlai(i,j),landusef(i,:,j), nlcat, & -! --- mosaic_lu and mosaic_soil are moved to the namelist -! & mosaic_lu, mosaic_soil, & & soilctop(i,:,j), nscat, & & qsfc_ice(i,j), qsg_ice(i,j), qvg_ice(i,j), qcg_ice(i,j), & & dew_ice(i,j), soilt1_ice(i,j), & @@ -1420,10 +1468,11 @@ subroutine lsm_ruc_run & ! inputs ! --- input/outputs: & smice(i,:,j), slice(i,:,j), soilm(i,j), smmax(i,j), & & stsice(i,:,j), soilt_ice(i,j), & + & edir(i,j), ec(i,j), ett(i,j), esnow_ice(i,j), snoh_ice(i,j), & & hfx_ice(i,j), qfx_ice(i,j), lh_ice(i,j), & & infiltr(i,j), runoff1(i,j), runoff2(i,j), acrunoff(i,j), & & sfcexc(i,j), acceta(i,j), ssoil_ice(i,j), & - & snfallac_ice(i,j), acsn(i,j), snomlt_ice(i,j), & + & snfallac_ice(i,j), acsn_ice(i,j), snomlt_ice(i,j), & & smfrice(i,:,j),keepfrice(i,:,j), .false., & & shdmin1d(i,j), shdmax1d(i,j), rdlai2d, & & ims,ime, jms,jme, kms,kme, & @@ -1443,19 +1492,23 @@ subroutine lsm_ruc_run & ! inputs sfcqv_ice(i) = qvg_ice(i,j) sfcqc_ice(i) = qcg_ice(i,j) + rhosnf(i) = rhosnfr(i,j) ! kg m-3 snowfallac_ice(i) = snfallac_ice(i,j) ! kg m-2 + acsnow_ice(i) = acsn_ice(i,j) ! kg m-2 + snowmt_ice(i) = snomlt_ice(i,j) ! kg m-2 ! --- ... unit conversion (from m to mm) - snwdph_ice(i) = snowh_ice(i,j) * 1000.0 - weasd_ice(i) = sneqv_ice(i,j) ! mm + snwdph_ice(i) = snowh_ice(i,j) * rhoh2o + weasd_ice(i) = sneqv_ice(i,j) ! kg m-2 sncovr1_ice(i) = sncovr_ice(i,j) - z0rl_ice(i) = znt_ice(i,j)*100. + z0rl_ice(i) = znt_ice(i,j)*100. ! cm !-- semis_ice is with snow effect semis_ice(i) = sfcems_ice(i,j) !-- sfalb_ice is with snow effect sfalb_ice(i) = alb_ice(i,j) + !-- albdvis_ice,albdnir_ice,albivis_ice,albinir_ice albdvis_ice(i) = sfalb_ice(i) albdnir_ice(i) = sfalb_ice(i) - albinir_ice(i) = sfalb_ice(i) + albivis_ice(i) = sfalb_ice(i) albinir_ice(i) = sfalb_ice(i) @@ -1497,22 +1550,27 @@ subroutine lsm_ruc_run & ! inputs !srflag(i) = srflag_old(i) tsnow_lnd(i) = tsnow_lnd_old(i) snowfallac_lnd(i) = snowfallac_lnd_old(i) - !acsnow(i) = acsnow_old(i) + acsnow_lnd(i) = acsnow_lnd_old(i) sfcqv_lnd(i) = sfcqv_lnd_old(i) sfcqc_lnd(i) = sfcqc_lnd_old(i) wetness(i) = wetness_old(i) z0rl_lnd(i) = z0rl_lnd_old(i) sncovr1_lnd(i) = sncovr1_lnd_old(i) + snowmt_lnd(i) = snowmt_lnd_old(i) !ice weasd_ice(i) = weasd_ice_old(i) snwdph_ice(i) = snwdph_ice_old(i) tskin_ice(i) = tskin_ice_old(i) tsnow_ice(i) = tsnow_ice_old(i) snowfallac_ice(i) = snowfallac_ice_old(i) + acsnow_ice(i) = acsnow_ice_old(i) sfcqv_ice(i) = sfcqv_ice_old(i) sfcqc_ice(i) = sfcqc_ice_old(i) z0rl_ice(i) = z0rl_ice_old(i) sncovr1_ice(i) = sncovr1_ice_old(i) + snowmt_ice(i) = snowmt_ice_old(i) + srunoff(i) = srunoff_old(i) + runoff(i) = runoff_old(i) do k = 1, lsoil_ruc smois(i,k) = smois_old(i,k) @@ -1530,9 +1588,6 @@ subroutine lsm_ruc_run & ! inputs endif ! flag enddo ! i enddo ! j -! - deallocate(soilctop) - deallocate(landusef) ! return !................................... diff --git a/physics/lsm_ruc.meta b/physics/lsm_ruc.meta index 0d22f8d4a..3ff016f85 100644 --- a/physics/lsm_ruc.meta +++ b/physics/lsm_ruc.meta @@ -655,6 +655,20 @@ dimensions = () type = integer intent = in +[nlcat] + standard_name = number_of_vegetation_categories + long_name = number of vegetation categories + units = count + dimensions = () + type = integer + intent = in +[nscat] + standard_name = number_of_soil_categories + long_name = number of soil categories + units = count + dimensions = () + type = integer + intent = in [rdlai] standard_name = flag_for_reading_leaf_area_index_from_input long_name = flag for reading leaf area index from initial conditions for RUC LSM @@ -678,6 +692,22 @@ type = real kind = kind_phys intent = in +[oro] + standard_name = height_above_mean_sea_level + long_name = height_above_mean_sea_level + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[sigma] + standard_name = standard_deviation_of_subgrid_orography + long_name = standard deviation of subgrid height_above_mean_sea_level + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [zs] standard_name = depth_of_soil_layers long_name = depth of soil levels for land surface model @@ -724,6 +754,22 @@ dimensions = (horizontal_loop_extent) type = integer intent = in +[vegtype_frac] + standard_name = fraction_of_vegetation_category + long_name = fraction of horizontal grid area occupied by given vegetation category + units = frac + dimensions = (horizontal_loop_extent,number_of_vegetation_categories) + type = real + kind = kind_phys + intent = in +[soiltype_frac] + standard_name = fraction_of_soil_category + long_name = fraction of horizontal grid area occupied by given soil category + units = frac + dimensions = (horizontal_loop_extent,number_of_soil_categories) + type = real + kind = kind_phys + intent = in [sigmaf] standard_name = vegetation_area_fraction long_name = areal fractional cover of green vegetation @@ -1015,6 +1061,14 @@ type = real kind = kind_phys intent = in +[con_hfus] + standard_name = latent_heat_of_fusion_of_water_at_0C + long_name = latent heat of fusion + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in [con_fvirt] standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one long_name = rv/rd - 1 (rv = ideal gas constant for water vapor) @@ -1344,13 +1398,37 @@ kind = kind_phys intent = inout [snowfallac_lnd] - standard_name = surface_snow_amount_over_land - long_name = run-total snow accumulation on the ground over land + standard_name = surface_snow_amount_vardens_over_land + long_name = run-total snow accumulation on the ground with variable snow density over land + units = kg m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[acsnow_lnd] + standard_name = surface_snow_lwe_thickness_amount_over_land + long_name = run-total snowfall water equivalent over land units = kg m-2 dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout +[snowmt_lnd] + standard_name = surface_snow_melt_over_land + long_name = snow melt during timestep over land + units = kg m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[snohf] + standard_name = snow_freezing_rain_upward_latent_heat_flux + long_name = latent heat flux due to snow and frz rain + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout [albdvis_lnd] standard_name = surface_albedo_direct_visible_over_land long_name = direct surface albedo visible band over land @@ -1480,8 +1558,24 @@ kind = kind_phys intent = in [snowfallac_ice] - standard_name = surface_snow_amount_over_ice - long_name = run-total snow accumulation on the ground over ice + standard_name = surface_snow_amount_vardens_over_ice + long_name = run-total snow accumulation on the ground with variable snow density over ice + units = kg m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[acsnow_ice] + standard_name = surface_snow_lwe_thickness_amount_over_ice + long_name = run-total snowfall water equivalent over ice + units = kg m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[snowmt_ice] + standard_name = surface_snow_melt_over_ice + long_name = snow melt during timestep over ice units = kg m-2 dimensions = (horizontal_loop_extent) type = real @@ -1527,6 +1621,7 @@ type = real kind = kind_phys intent = inout + active = (control_for_land_surface_scheme == identifier_for_ruc_land_surface_scheme) [sbsno] standard_name = snow_deposition_sublimation_upward_latent_heat_flux long_name = latent heat flux from snow depo/subl diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 3090c0c11..744e321ef 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -19,28 +19,53 @@ MODULE module_sf_ruclsm public :: lsmruc, ruclsminit, rslf !> CONSTANT PARAMETERS +!! @{ real (kind=kind_phys), parameter :: P1000mb = 100000. real (kind=kind_phys), parameter :: xls = 2.85E6 real (kind=kind_phys), parameter :: rhowater= 1000. real (kind=kind_phys), parameter :: piconst = 3.1415926535897931 real (kind=kind_phys), parameter :: r_v = 4.6150e+2 + !-- options for snow conductivity: 1 - constant, 2 - Sturm et al.,1997 + integer, parameter :: isncond_opt = 2 + + !-- Snow fraction options + !-- option 1: original formulation using threshold snow depth to compute snow fraction + !integer, parameter :: isncovr_opt = 1 + !-- option 2: the tanh formulation from Niu,G.-Y.,and Yang,Z.-L., 2007,JGR,DOI:10.1029/2007JD008674. + !integer, parameter :: isncovr_opt = 2 + !-- option 3: the tanh formulation from Niu,G.-Y.,and Yang,Z with + ! vegetation-dependent parameters from Noah MP (personal communication with + ! Mike Barlage) + integer, parameter :: isncovr_opt = 3 + + !-- Mosaic_lu and mosaic_soil are defined in set_soilveg_ruc.F90 and + ! passes to RUC LSM via namelist_soilveg_ruc.F90. + +!! @} + !> VEGETATION PARAMETERS +!! @{ INTEGER :: LUCATS integer, PARAMETER :: NLUS=50 CHARACTER*8 LUTYPE +!! @} !> SOIL PARAMETERS +!! @{ INTEGER :: SLCATS INTEGER, PARAMETER :: NSLTYPE=30 CHARACTER*8 SLTYPE +!! @} !> LSM GENERAL PARAMETERS +!! @{ INTEGER :: SLPCATS INTEGER, PARAMETER :: NSLOPE=30 REAL :: SBETA_DATA,FXEXP_DATA,CSOIL_DATA,SALP_DATA,REFDK_DATA, & REFKDT_DATA,FRZK_DATA,ZBOT_DATA, SMLOW_DATA,SMHIGH_DATA, & CZIL_DATA +!! @} CONTAINS @@ -49,24 +74,25 @@ MODULE module_sf_ruclsm !>\ingroup lsm_ruc_group !> The RUN LSM model is described in Smirnova et al.(1997) !! \cite Smirnova_1997 and Smirnova et al.(2000) \cite Smirnova_2000 -!>\section gen_lsmruc_ga RUC LSM General Algorithm - SUBROUTINE LSMRUC( & +!>\section gen_lsmruc GSD RUC LSM General Algorithm +!! @{ + SUBROUTINE LSMRUC(xlat,xlon, & DT,init,lsm_cold_start,KTAU,iter,NSL, & graupelncv,snowncv,rainncv,raincv, & ZS,RAINBL,SNOW,SNOWH,SNOWC,FRZFRAC,frpcpn, & - rhosnf,precipfr,exticeden, & + rhosnf,precipfr,exticeden, hgt,stdev, & Z3D,P8W,T3D,QV3D,QC3D,RHO3D,EMISBCK, & GLW,GSWdn,GSW,EMISS,CHKLOWQ, CHS, & FLQC,FLHC,rhonewsn_ex,MAVAIL,CANWAT,VEGFRA, & - ALB, ZNT,Z0,SNOALB,ALBBCK,LAI, & - landusef, nlcat, & ! mosaic_lu, mosaic_soil, & - soilctop, nscat, & + ALB,ZNT,Z0,SNOALB,ALBBCK,LAI, & + landusef, nlcat, soilctop, nscat, & QSFC,QSG,QVG,QCG,DEW,SOILT1,TSNAV, & TBOT,IVGTYP,ISLTYP,XLAND, & ISWATER,ISICE,XICE,XICE_THRESHOLD, & CP,RV,RD,G0,PI,LV,STBOLT, & SOILMOIS,SH2O,SMAVAIL,SMMAX, & - TSO,SOILT,HFX,QFX,LH,INFILTR, & + TSO,SOILT,EDIR,EC,ETT,SUBLIM,SNOH, & + HFX,QFX,LH,INFILTR, & RUNOFF1,RUNOFF2,ACRUNOFF,SFCEXC, & SFCEVP,GRDFLX,SNOWFALLAC,ACSNOW,SNOM, & SMFR3D,KEEPFR3DFLAG, & @@ -125,7 +151,7 @@ SUBROUTINE LSMRUC( & !-- XLAND land mask (1 for land, 2 for water) !-- CP heat capacity at constant pressure for dry air (J/kg/K) !-- G0 acceleration due to gravity (m/s^2) -!-- LV latent heat of melting (J/kg) +!-- LV latent heat of evaporation (J/kg) !-- STBOLT Stefan-Boltzmann constant (W/m^2/K^4) ! SOILMOIS - soil moisture content (volumetric fraction) ! TSO - soil temp (K) @@ -136,9 +162,9 @@ SUBROUTINE LSMRUC( & ! SFCRUNOFF - ground surface runoff [mm] ! UDRUNOFF - underground runoff [mm] ! ACRUNOFF - run-total surface runoff [mm] -! SFCEVP - total evaporation in [kg/m^2] +! SFCEVP - total time-step evaporation in [kg/m^2] ! GRDFLX - soil heat flux (W/m^2: negative, if downward from surface) -! SNOWFALLAC - run-total snowfall accumulation [m] +! SNOWFALLAC - run-total snowfall accumulation [mm] ! ACSNOW - run-toral SWE of snowfall [mm] !-- CHKLOWQ - is either 0 or 1 (so far set equal to 1). !-- used only in MYJPBL. @@ -157,9 +183,10 @@ SUBROUTINE LSMRUC( & ! INTEGER, PARAMETER :: nzss=5 ! INTEGER, PARAMETER :: nddzs=2*(nzss-2) + REAL, INTENT(IN ) :: xlat,xlon REAL, INTENT(IN ) :: DT LOGICAL, INTENT(IN ) :: myj,frpcpn,init,lsm_cold_start,exticeden - INTEGER, INTENT(IN ) :: NLCAT, NSCAT ! , mosaic_lu, mosaic_soil + INTEGER, INTENT(IN ) :: NLCAT, NSCAT INTEGER, INTENT(IN ) :: ktau, iter, nsl, isice, iswater, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte @@ -192,14 +219,13 @@ SUBROUTINE LSMRUC( & INTENT(IN ) :: GRAUPELNCV, & SNOWNCV, & RAINCV, & - RAINNCV, & - RHONEWSN_ex !externally-calculated srf frz precip density -! REAL, DIMENSION( ims:ime , jms:jme ), & -! INTENT(IN ) :: lakemask -! INTEGER, INTENT(IN ) :: LakeModel + RAINNCV + REAL, DIMENSION( ims:ime), INTENT(IN ) :: RHONEWSN_ex !externally-calculated srf frz precip density REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: SHDMAX REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: SHDMIN + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: hgt + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: stdev LOGICAL, intent(in) :: rdlai2d REAL, DIMENSION( 1:nsl), INTENT(IN ) :: ZS @@ -241,6 +267,11 @@ SUBROUTINE LSMRUC( & HFX, & QFX, & LH, & + EDIR, & + EC, & + ETT, & + SUBLIM, & + SNOH, & SFCEVP, & RUNOFF1, & RUNOFF2, & @@ -266,15 +297,12 @@ SUBROUTINE LSMRUC( & SFCRUNOFF, & UDRUNOFF, & EMISSL, & + MSNF, & + FACSNF, & ZNTL, & LMAVAIL, & SMELT, & - SNOH, & SNFLX, & - EDIR, & - EC, & - ETT, & - SUBLIM, & sflx, & smf, & EVAPL, & @@ -327,6 +355,7 @@ SUBROUTINE LSMRUC( & KICE, & KWT + REAL, DIMENSION(1:NSL) :: ZSMAIN, & ZSHALF, & DTDZS2 @@ -382,8 +411,13 @@ SUBROUTINE LSMRUC( & INTEGER :: I,J,K,NZS,NZS1,NDDZS INTEGER :: k1,k2 logical :: debug_print - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg + + !-- diagnostic point + real (kind=kind_phys) :: testptlat, testptlon + + character(len=*),intent(out) :: errmsg + integer, intent(out) :: errflg + !----------------------------------------------------------------- ! ! Initialize error-handling @@ -397,6 +431,12 @@ SUBROUTINE LSMRUC( & NZS=NSL NDDZS=2*(nzs-2) + !-- + testptlat = 48.7074 !39.958 !42.05 !39.0 !74.12 !29.5 + testptlon = 289.03 !271.622 !286.75 !280.6 !164.0 !283.0 + !-- + + !> - Table TBQ is for resolution of balance equation in vilka() CQ=173.15-.05 R273=1./273.15 @@ -420,44 +460,50 @@ SUBROUTINE LSMRUC( & !> - Initialize soil/vegetation parameters !--- This is temporary until SI is added to mass coordinate ---!!!!! - if(init .and. (lsm_cold_start) .and. iter == 1) then - DO J=jts,jte + if(init .and. iter == 1) then + + if( lsm_cold_start ) then + !-- beginning of cold-start + DO J=jts,jte DO i=its,ite -! do k=1,nsl -! keepfr3dflag(i,k,j)=0. -! enddo -!> - Initializing snow fraction, thereshold = 32 mm of snow water -!! or ~100 mm of snow height ! -! snowc(i,j) = min(1.,snow(i,j)/32.) -! soilt1(i,j)=soilt(i,j) -! if(snow(i,j).le.32.) soilt1(i,j)=tso(i,1,j) -!> - Initializing inside snow temp if it is not defined - IF((soilt1(i,j) .LT. 170.) .or. (soilt1(i,j) .GT.400.)) THEN - IF(snow(i,j).gt.32.) THEN - soilt1(i,j)=0.5*(soilt(i,j)+tso(i,1,j)) - IF (debug_print ) THEN - print *, & - 'Temperature inside snow is initialized in RUCLSM ', soilt1(i,j),i,j - ENDIF - ELSE - soilt1(i,j) = tso(i,1,j) - ENDIF - ENDIF - tsnav(i,j) =0.5*(soilt(i,j)+tso(i,1,j))-273.15 - qcg (i,j) =0. +!> - Initializing inside-snow temp if it is not defined + IF((soilt1(i,j) .LT. 170.) .or. (soilt1(i,j) .GT.400.)) THEN + IF(snowc(i,j).gt.0.) THEN + soilt1(i,j)=min(273.15,0.5*(soilt(i,j)+tso(i,1,j)) ) + IF (debug_print ) THEN + print *, & + 'Temperature inside snow is initialized in RUCLSM ', soilt1(i,j),i,xlat,xlon + ENDIF + ELSE + soilt1(i,j) = tso(i,1,j) + ENDIF + ENDIF + tsnav(i,j) =min(0.,0.5*(soilt(i,j)+tso(i,1,j))-273.15) + !- 10feb22 - limit snow albedo at high elevations + !- based on Roesch et al., Climate Dynamics (2001),17:933-946 + if(hgt(i,j) > 2500.) then + snoalb(i,j) = min(0.65,snoalb(i,j)) + endif + patmb=P8w(i,kms,j)*1.e-2 QSG (i,j) = QSN(SOILT(i,j),TBQ)/PATMB - IF((qvg(i,j) .LE. 0.) .or. (qvg(i,j) .GT.0.1)) THEN - !17sept19 - bad approximation with very low mavail. - !qvg(i,j) = QSG(i,j)*mavail(i,j) - qvg (i,j) = qv3d(i,1,j) - IF (debug_print ) THEN - print *, & - 'QVG is initialized in RUCLSM ', qvg(i,j),mavail(i,j),qsg(i,j),i,j - ENDIF - ENDIF -! qsfc(i,j) = qvg(i,j)/(1.+qvg(i,j)) + + if((qcg(i,j) < 0.) .or. (qcg(i,j) > 0.1)) then + qcg (i,j) = qc3d(i,1,j) + if (debug_print ) then + print *, 'QCG is initialized in RUCLSM ', qcg(i,j),qc3d(i,1,j),i,xlat,xlon + endif + endif + + if((qvg(i,j) .LE. 0.) .or. (qvg(i,j) .GT.0.1)) then + qvg (i,j) = qv3d(i,1,j) + if (debug_print ) then + print *, 'QVG is initialized in RUCLSM ', qvg(i,j),mavail(i,j),qsg(i,j),i,xlat,xlon + endif + endif + qsfc(i,j) = qvg(i,j)/(1.+qvg(i,j)) + SMELT(i,j) = 0. SNOM (i,j) = 0. ACSNOW(i,j) = 0. @@ -474,14 +520,14 @@ SUBROUTINE LSMRUC( & UDRUNOFF(i,j) = 0. ACRUNOFF(i,j) = 0. emissl (i,j) = 0. + msnf (i,j) = 0. + facsnf (i,j) = 0. budget(i,j) = 0. acbudget(i,j) = 0. waterbudget(i,j) = 0. acwaterbudget(i,j) = 0. smtotold(i,j)=0. canwatold(i,j)=0. -! Temporarily!!! -! canwat(i,j)=0. !> - For RUC LSM CHKLOWQ needed for MYJPBL should !! 1 because is actual specific humidity at the surface, and @@ -498,20 +544,14 @@ SUBROUTINE LSMRUC( & evapl (i,j) = 0. prcpl (i,j) = 0. ENDDO - ENDDO - - infiltrp = 0. - do k=1,nsl - soilice(k)=0. - soiliqw(k)=0. - enddo - else ! .not. init==true. - DO J=jts,jte - DO i=its,ite - SFCRUNOFF(i,j) = 0. - UDRUNOFF(i,j) = 0. - ENDDO ENDDO + + infiltrp = 0. + do k=1,nsl + soilice(k)=0. + soiliqw(k)=0. + enddo + endif ! cold start endif ! init==.true. !----------------------------------------------------------------- @@ -528,22 +568,16 @@ SUBROUTINE LSMRUC( & DO i=its,ite IF (debug_print ) THEN -! if(j==10) then - print *,' IN LSMRUC ','ims,ime,jms,jme,its,ite,jts,jte,nzs', & - ims,ime,jms,jme,its,ite,jts,jte,nzs - print *,' IVGTYP, ISLTYP ', ivgtyp(i,j),isltyp(i,j) - print *,' MAVAIL ', mavail(i,j) - print *,' SOILT,QVG,P8w',soilt(i,j),qvg(i,j),p8w(i,1,j) - print *, 'LSMRUC, I,J,xland, QFX,HFX from SFCLAY',i,j,xland(i,j), & - qfx(i,j),hfx(i,j) - print *, ' GSW, GLW =',gsw(i,j),glw(i,j) - print *, 'SOILT, TSO start of time step =',soilt(i,j),(tso(i,k,j),k=1,nsl) - print *, 'SOILMOIS start of time step =',(soilmois(i,k,j),k=1,nsl) - print *, 'SMFROZEN start of time step =',(smfr3d(i,k,j),k=1,nsl) - print *, ' I,J=, after SFCLAY CHS,FLHC ',i,j,chs(i,j),flhc(i,j) - print *, 'LSMRUC, IVGTYP,ISLTYP,ALB = ', ivgtyp(i,j),isltyp(i,j),alb(i,j),i,j - print *, 'LSMRUC I,J,DT,RAINBL =',I,J,dt,RAINBL(i,j) - print *, 'XLAND ---->, ivgtype,isoiltyp,i,j',xland(i,j),ivgtyp(i,j),isltyp(i,j),i,j + if (abs(xlat-testptlat).lt.0.2 .and. & + abs(xlon-testptlon).lt.0.2)then + print 100,'(RUC start) i=',i,' lat,lon=',xlat,xlon, & + 'mavail ', mavail(i,j),' soilt',soilt(i,j),'qvg ',qvg(i,j),& + 'p8w',p8w(i,1,j),'sflay qfx',qfx(i,j),'sflay hfx',hfx(i,j),& + 'gsw ',gsw(i,j),'glw ',glw(i,j),'soilt ',soilt(i,j), & + 'chs ',chs(i,j),'flqc ',flhc(i,j),'alb ',alb(i,j), & + 'rainbl ',rainbl(i,j),'dt ',dt + print *,'nzs',nzs, 'ivgtyp ',ivgtyp(i,j),'isltyp ',isltyp(i,j) + endif ENDIF @@ -652,7 +686,10 @@ SUBROUTINE LSMRUC( & NZS1=NZS-1 !----- IF (debug_print ) THEN - print *,' DT,NZS1, ZSMAIN, ZSHALF --->', dt,nzs1,zsmain,zshalf + if (abs(xlat-testptlat).lt.0.2 .and. & + abs(xlon-testptlon).lt.0.2)then + print *,' DT,NZS1, ZSMAIN, ZSHALF --->', dt,nzs1,zsmain,zshalf + endif ENDIF DO K=2,NZS1 @@ -691,7 +728,7 @@ SUBROUTINE LSMRUC( & ! ! rooting depth RHONEWSN = 200. - if(SNOW(i,j).gt.0. .and. SNOWH(i,j).gt.0.) then + if(SNOW(i,j).gt.0. .and. SNOWH(i,j).gt.0.02) then RHOSN = SNOW(i,j)/SNOWH(i,j) else RHOSN = 300. @@ -699,38 +736,42 @@ SUBROUTINE LSMRUC( & IF (debug_print ) THEN if(init) then - print *,'before SOILVEGIN - z0,znt(195,254)',z0(i,j),znt(i,j) - print *,'ILAND, ISOIL =',i,j,iland,isoil + if (abs(xlat-testptlat).lt.0.2 .and. & + abs(xlon-testptlon).lt.0.2)then + print *,'before SOILVEGIN - z0,znt',i,z0(i,j),znt(i,j) + print *,'ILAND, ISOIL =',i,iland,isoil + endif endif ENDIF !> - Call soilvegin() to initialize soil and surface properties !-- land or ice CALL SOILVEGIN ( debug_print, & - soilfrac,nscat,shdmin(i,j),shdmax(i,j),mosaic_lu, mosaic_soil,& + soilfrac,nscat,shdmin(i,j),shdmax(i,j), & NLCAT,ILAND,ISOIL,iswater,MYJ,IFOREST,lufrac,VEGFRA(I,J), & - EMISSL(I,J),PC(I,J),ZNT(I,J),LAI(I,J),RDLAI2D, & + EMISSL(I,J),PC(I,J),MSNF(I,J),FACSNF(I,J), & + ZNT(I,J),LAI(I,J),RDLAI2D, & QWRTZ,RHOCS,BCLH,DQM,KSAT,PSIS,QMIN,REF,WILT,i,j,errmsg, errflg) !-- update background emissivity for land points, can have vegetation mosaic effect EMISBCK(I,J) = EMISSL(I,J) IF (debug_print ) THEN - if(init) & - print *,'after SOILVEGIN - z0,znt(1,26),lai(1,26)',z0(i,j),znt(i,j),lai(i,j) - if(init)then + if (abs(xlat-testptlat).lt.0.2 .and. & + abs(xlon-testptlon).lt.0.2)then + print *,'after SOILVEGIN - z0,znt,lai',i,z0(i,j),znt(i,j),lai(i,j) print *,'NLCAT,iland,EMISSL(I,J),PC(I,J),ZNT(I,J),LAI(I,J)', & NLCAT,iland,EMISSL(I,J),PC(I,J),ZNT(I,J),LAI(I,J),i,j print *,'NSCAT,QWRTZ,RHOCS,BCLH,DQM,KSAT,PSIS,QMIN,REF,WILT',& NSCAT,QWRTZ,RHOCS,BCLH,DQM,KSAT,PSIS,QMIN,REF,WILT,i,j + endif endif ENDIF CN=CFACTR_DATA ! exponent ! SAT=max(1.e-5,(min(5.e-4,(CMCMAX_DATA * (1.-exp(-0.5*lai(i,j))) * 0.01*VEGFRA(I,J))))) ! canopy water saturated SAT = 5.e-4 ! units [m] -! if(i==666.and.j==282) print *,'second 666,282 - sat',sat !-- definition of number of soil levels in the rooting zone ! IF(iforest(ivgtyp(i,j)).ne.1) THEN @@ -774,14 +815,6 @@ SUBROUTINE LSMRUC( & print *,'NROOT, meltfactor, iforest, ivgtyp, i,j ', nroot,meltfactor,iforest,ivgtyp(I,J),I,J ENDIF -!!*** SET ZERO-VALUE FOR SOME OUTPUT DIAGNOSTIC ARRAYS -! if(i.eq.397.and.j.eq.562) then -! print *,'RUC LSM - xland(i,j),xice(i,j),snow(i,j)',i,j,xland(i,j),xice(i,j),snow(i,j) -! endif - -! if(lakemodel==1 .and. lakemask(i,j)==1.) goto 2999 -!Lakes - IF((XLAND(I,J)-1.5).GE.0.)THEN !-- Water SMAVAIL(I,J)=1.0 @@ -817,7 +850,6 @@ SUBROUTINE LSMRUC( & ! LAND POINT OR SEA ICE if(xice(i,j).ge.xice_threshold) then -! if(IVGTYP(i,j).eq.isice) then SEAICE(i,j)=1. else SEAICE(i,j)=0. @@ -879,36 +911,48 @@ SUBROUTINE LSMRUC( & LMAVAIL(I,J)=max(0.00001,min(1.,soilm1d(1)/(ref-qmin))) IF (debug_print ) THEN - print *,'LAND, i,j,tso1d,soilm1d,PATM,TABS,QVATM,QCATM,RHO', & - i,j,tso1d,soilm1d,PATM,TABS,QVATM,QCATM,RHO - print *,'CONFLX =',CONFLX - print *,'SMFRKEEP,KEEPFR ',SMFRKEEP,KEEPFR + if (abs(xlat-testptlat).lt.0.2 .and. & + abs(xlon-testptlon).lt.0.2)then + print *,'LAND, i,j,tso1d,soilm1d,PATM,TABS,QVATM,QCATM,RHO', & + i,j,tso1d,soilm1d,PATM,TABS,QVATM,QCATM,RHO + print *,'CONFLX =',CONFLX + print *,'SMFRKEEP,KEEPFR ',SMFRKEEP,KEEPFR + endif ENDIF smtotold(i,j)=0. - do k=1,nzs-1 + + !do k=1,nzs-1 + do k=1,nroot smtotold(i,j)=smtotold(i,j)+(qmin+soilm1d(k))* & (zshalf(k+1)-zshalf(k)) enddo - smtotold(i,j)=smtotold(i,j)+(qmin+soilm1d(nzs))* & - (zsmain(nzs)-zshalf(nzs)) + !smtotold(i,j)=smtotold(i,j)+(qmin+soilm1d(nzs))* & + ! (zsmain(nzs)-zshalf(nzs)) + if (debug_print .and. abs(xlat-testptlat).lt.0.2 & + .and. abs(xlon-testptlon).lt.0.2) then + print *,'Old soilm1d ',i,soilm1d + endif canwatold(i,j) = canwatr !----------------------------------------------------------------- CALL SFCTMP (debug_print, dt,ktau,conflx,i,j, & + xlat, xlon, testptlat, testptlon, & !--- input variables nzs,nddzs,nroot,meltfactor, & !added meltfactor iland,isoil,ivgtyp(i,j),isltyp(i,j), & PRCPMS, NEWSNMS,SNWE,SNHEI,SNOWFRAC, & - exticeden,RHOSN,RHONEWSN_ex(I,J),RHONEWSN, & + exticeden,RHOSN,RHONEWSN_ex(I),RHONEWSN, & RHOSNFALL,snowrat,grauprat,icerat,curat, & PATM,TABS,QVATM,QCATM,RHO, & GLW(I,J),GSWdn(i,j),GSW(I,J), & EMISSL(I,J),EMISBCK(I,J), & + msnf(i,j), facsnf(i,j), & QKMS,TKMS,PC(I,J),LMAVAIL(I,J), & canwatr,vegfra(I,J),alb(I,J),znt(I,J), & - snoalb(i,j),albbck(i,j),lai(i,j), & !new + snoalb(i,j),albbck(i,j),lai(i,j), & + hgt(i,j),stdev(i,j), & !new myj,seaice(i,j),isice, & !--- soil fixed fields QWRTZ, & @@ -937,7 +981,6 @@ SUBROUTINE LSMRUC( & ! This change violates LSM moisture budget, but ! can be considered as a compensation for irrigation not included into LSM. - if(1==2) then !tgs - turn off "irrigation" while there is no fractional landuse and LAI !climatology. IF (lufrac(crop) > 0 .and. lai(i,j) > 1.1) THEN @@ -975,7 +1018,6 @@ SUBROUTINE LSMRUC( & endif enddo ENDIF - endif ! 1==2 !*** DIAGNOSTICS !--- available and maximum soil moisture content in the soil @@ -984,25 +1026,38 @@ SUBROUTINE LSMRUC( & smavail(i,j) = 0. smmax (i,j) = 0. - do k=1,nzs-1 + !do k=1,nzs-1 + !-- root-zone soil moisture + do k=1,nroot smavail(i,j)=smavail(i,j)+(qmin+soilm1d(k))* & (zshalf(k+1)-zshalf(k)) smmax (i,j) =smmax (i,j)+(qmin+dqm)* & (zshalf(k+1)-zshalf(k)) enddo - smavail(i,j)=smavail(i,j)+(qmin+soilm1d(nzs))* & - (zsmain(nzs)-zshalf(nzs)) - smmax (i,j) =smmax (i,j)+(qmin+dqm)* & - (zsmain(nzs)-zshalf(nzs)) + !smavail(i,j)=smavail(i,j)+(qmin+soilm1d(nzs))* & + ! (zsmain(nzs)-zshalf(nzs)) + !smmax (i,j) =smmax (i,j)+(qmin+dqm)* & + ! (zsmain(nzs)-zshalf(nzs)) + if (debug_print) then + if (abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2)then + print 100,'(RUC runoff) i=',i,' lat,lon=',xlat,xlon, & + 'RUNOFF1', RUNOFF1(I,J), 'RUNOFF2 ',RUNOFF2(I,J), & + 'edir ',edir(I,J),'ec ',ec(I,J),'ett ',ett(I,J) + endif + endif !--- Convert the water unit into mm - SFCRUNOFF(I,J) = SFCRUNOFF(I,J)+RUNOFF1(I,J)*DT*1000.0 - UDRUNOFF (I,J) = UDRUNOFF(I,J)+RUNOFF2(I,J)*DT*1000.0 - ACRUNOFF(I,J) = ACRUNOFF(I,J)+(RUNOFF1(I,J)+RUNOFF2(I,J))*DT*1000.0 - SMAVAIL (I,J) = SMAVAIL(I,J) * 1000. + !-- three lines below are commented because accumulation + ! happens in sfc_drv_ruc + !SFCRUNOFF(I,J) = SFCRUNOFF(I,J)+RUNOFF1(I,J)*DT*1000.0 + !UDRUNOFF (I,J) = UDRUNOFF(I,J)+RUNOFF2(I,J)*DT*1000.0 + !ACRUNOFF (I,J) = ACRUNOFF(i,j)+UDRUNOFF(I,J)+RUNOFF2(I,J)*DT*1000.0 + ACRUNOFF(I,J) = (RUNOFF1(I,J)+RUNOFF2(I,J))*DT*1000.0 + !ACRUNOFF(I,J) = ACRUNOFF(i,j)+RUNOFF1(I,J)*DT*1000.0 ! acc surface runoff + SMAVAIL (I,J) = SMAVAIL(I,J) * 1000. ! mm SMMAX (I,J) = SMMAX(I,J) * 1000. - smtotold (I,J) = smtotold(I,J) * 1000. + smtotold (I,J) = smtotold(I,J) * 1000. ! mm do k=1,nzs @@ -1022,7 +1077,7 @@ SUBROUTINE LSMRUC( & !tgs add together dew and cloud at the ground surface !30july13 qcg(i,j)=qcg(i,j)+dew(i,j)/qkms - Z0 (I,J) = ZNT (I,J) + !Z0 (I,J) = ZNT (I,J) SFCEXC (I,J) = TKMS patmb=P8w(i,1,j)*1.e-2 Q2SAT=QSN(TABS,TBQ)/PATMB @@ -1039,13 +1094,6 @@ SUBROUTINE LSMRUC( & ! CHKLOWQ(I,J)=1. ! endif - IF (debug_print ) THEN - if(CHKLOWQ(I,J).eq.0.) then - print *,'i,j,CHKLOWQ', & - i,j,CHKLOWQ(I,J) - endif - ENDIF - if(snow(i,j)==0.) EMISSL(i,j) = EMISBCK(i,j) EMISS (I,J) = EMISSL(I,J) ! SNOW is in [mm], SNWE is in [m]; CANWAT is in mm, CANWATR is in m @@ -1053,14 +1101,18 @@ SUBROUTINE LSMRUC( & SNOWH (I,J) = SNHEI CANWAT (I,J) = CANWATR*1000. -if (debug_print) then - print *,'snow(i,j),soilt(i,j),xice(i,j),tso(i,:,j)',snow(i,j),soilt(i,j),xice(i,j),tso(i,:,j) -endif + if (debug_print) then + if (abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2)then + print *,'snow(i,j),soilt(i,j),xice(i,j),tso(i,:,j)',snow(i,j),soilt(i,j),xice(i,j),tso(i,:,j) + endif + endif INFILTR(I,J) = INFILTRP MAVAIL (i,j) = LMAVAIL(I,J) IF (debug_print ) THEN - print *,' LAND, I=,J=, QFX, HFX after SFCTMP', i,j,lh(i,j),hfx(i,j) + if (abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2)then + print *,' LAND, I=,J=, QFX, HFX after SFCTMP', i,j,lh(i,j),hfx(i,j) + endif ENDIF !!! QFX (I,J) = LH(I,J)/LV SFCEVP (I,J) = SFCEVP (I,J) + QFX (I,J) * DT @@ -1074,9 +1126,9 @@ SUBROUTINE LSMRUC( & ! endif !--- SNOWC snow cover flag - if(snowfrac > 0. .and. xice(i,j).ge.xice_threshold ) then - SNOWFRAC = SNOWFRAC*XICE(I,J) - endif + !if(snowfrac > 0. .and. xice(i,j).ge.xice_threshold ) then + ! SNOWFRAC = SNOWFRAC*XICE(I,J) + !endif SNOWC(I,J)=SNOWFRAC @@ -1098,20 +1150,34 @@ SUBROUTINE LSMRUC( & ! endif ! budget(i,j)=budget(i,j)-smf(i,j) + if (debug_print ) then + if (abs(xlat-testptlat).lt.0.2 .and. & + abs(xlon-testptlon).lt.0.2)then + !-- compute budget for a test point ac=0. as=0. + wb=0. - ac=max(0.,canwat(i,j)-canwatold(i,j)*1.e3) - as=max(0.,snwe-snowold(i,j)) - wb =rainbl(i,j)+smelt(i,j)*dt*1.e3 & ! source - -qfx(i,j)*dt & - -runoff1(i,j)*dt*1.e3-runoff2(i,j)*dt*1.e3 & - -ac-as - (smavail(i,j)-smtotold(i,j)) - + ac=canwat(i,j)-canwatold(i,j)*1.e3 ! canopy water change + as=snwe-snowold(i,j) ! SWE change + wb = smavail(i,j)-smtotold(i,j) waterbudget(i,j)=rainbl(i,j)+smelt(i,j)*dt*1.e3 & ! source -qfx(i,j)*dt & -runoff1(i,j)*dt*1.e3-runoff2(i,j)*dt*1.e3 & - -ac-as - (smavail(i,j)-smtotold(i,j)) + -ac-as ! - (smavail(i,j)-smtotold(i,j)) + + print *,'soilm1d ',i,soilm1d + print 100,'(RUC budgets) i=',i,' lat,lon=',xlat,xlon, & + 'budget ',budget(i,j),'waterbudget',waterbudget(i,j), & + 'rainbl ',rainbl(i,j),'runoff1 ',runoff1(i,j), & + 'smelt ',smelt(i,j)*dt*1.e3,'smc change ',wb, & + 'snwe change ',as,'canw change ',ac,'runoff2 ',runoff2(i,j), & + 'qfx*dt ',qfx(i,j)*dt,'smavail ',smavail(i,j),'smcold',smtotold(i,j) + endif + endif + 100 format (";;; ",a,i4,a,2f14.7/(4(a10,'='es14.7))) + !-- + ! waterbudget(i,j)=rainbl(i,j)-qfx(i,j)*dt-(smavail(i,j)-smtotold(i,j)) & @@ -1121,27 +1187,29 @@ SUBROUTINE LSMRUC( & !!!!TEST use LH to check water budget ! GRDFLX (I,J) = waterbudget(i,j) - IF (debug_print ) THEN - print *,'Smf=',smf(i,j),i,j - print *,'Budget',budget(i,j),i,j - print *,'RUNOFF2= ', i,j,runoff2(i,j) - print *,'Water budget ', i,j,waterbudget(i,j),'wb=',wb - print *,'rainbl,qfx*dt,runoff1,smelt*dt*1.e3,smchange', & - i,j,rainbl(i,j),qfx(i,j)*dt,runoff1(i,j)*dt*1.e3, & - smelt(i,j)*dt*1.e3, & - (smavail(i,j)-smtotold(i,j)) - - print *,'SNOW,SNOWold',i,j,snwe,snowold(i,j) - print *,'SNOW-SNOWold',i,j,max(0.,snwe-snowold(i,j)) - print *,'CANWATold, canwat ',i,j,canwatold(i,j),canwat(i,j) - print *,'canwat(i,j)-canwatold(i,j)',max(0.,canwat(i,j)-canwatold(i,j)) - ENDIF +! print *,'Smf=',smf(i,j),i,j +! print *,'Budget',budget(i,j),i,j +! print *,'RUNOFF2= ', i,j,runoff2(i,j) +! print *,'Water budget ', i,j,waterbudget(i,j),'wb=',wb +! print *,'rainbl,qfx*dt,runoff1,smelt*dt*1.e3,smchange', & +! i,j,rainbl(i,j),qfx(i,j)*dt,runoff1(i,j)*dt*1.e3, & +! smelt(i,j)*dt*1.e3, & +! (smavail(i,j)-smtotold(i,j)) +! +! print *,'SNOW,SNOWold',i,j,snwe,snowold(i,j) +! print *,'SNOW-SNOWold',i,j,max(0.,snwe-snowold(i,j)) +! print *,'CANWATold, canwat ',i,j,canwatold(i,j),canwat(i,j) +! print *,'canwat(i,j)-canwatold(i,j)',max(0.,canwat(i,j)-canwatold(i,j)) +! ENDIF IF (debug_print ) THEN - print *,'LAND, i,j,tso1d,soilm1d,soilt - end of time step', & + if (abs(xlat-testptlat).lt.0.2 .and. & + abs(xlon-testptlon).lt.0.2)then + print *,'LAND, i,j,tso1d,soilm1d,soilt - end of time step', & i,j,tso1d,soilm1d,soilt(i,j) - print *,'LAND, QFX, HFX after SFCTMP', i,j,lh(i,j),hfx(i,j) + print *,'LAND, QFX, HFX after SFCTMP', i,j,lh(i,j),hfx(i,j) + endif ENDIF !--- end of a land or sea ice point @@ -1153,6 +1221,7 @@ SUBROUTINE LSMRUC( & !----------------------------------------------------------------- END SUBROUTINE LSMRUC +!! @} !----------------------------------------------------------------- !>\ingroup lsm_ruc_group @@ -1165,15 +1234,16 @@ END SUBROUTINE LSMRUC !! the snow "mosaic" approach is turned on. !! - Updates emissivity and albedo for patch snow. SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input variables + xlat,xlon,testptlat,testptlon, & nzs,nddzs,nroot,meltfactor, & ILAND,ISOIL,IVGTYP,ISLTYP,PRCPMS, & NEWSNMS,SNWE,SNHEI,SNOWFRAC, & exticeden,RHOSN,RHONEWSN_ex,RHONEWSN,RHOSNFALL, & snowrat,grauprat,icerat,curat, & PATM,TABS,QVATM,QCATM,rho, & - GLW,GSWdn,GSW,EMISS,EMISBCK,QKMS,TKMS,PC, & - MAVAIL,CST,VEGFRA,ALB,ZNT, & - ALB_SNOW,ALB_SNOW_FREE,lai, & + GLW,GSWdn,GSW,EMISS,EMISBCK,msnf,facsnf, & + QKMS,TKMS,PC,MAVAIL,CST,VEGFRA,ALB,ZNT, & + ALB_SNOW,ALB_SNOW_FREE,lai,hgt,stdev, & MYJ,SEAICE,ISICE, & QWRTZ,rhocs,dqm,qmin,ref,wilt,psis,bclh,ksat, & !--- soil fixed fields sat,cn,zsmain,zshalf,DTDZS,DTDZS2,tbq, & @@ -1195,9 +1265,10 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia INTEGER, INTENT(IN ) :: isice,i,j,nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) - REAL, INTENT(IN ) :: DELT,CONFLX,meltfactor + REAL, INTENT(IN ) :: DELT,CONFLX,meltfactor,xlat,xlon + REAL, INTENT(IN ) :: testptlat,testptlon REAL, INTENT(IN ) :: C1SN,C2SN,RHONEWSN_ex - LOGICAL, INTENT(IN ) :: myj, debug_print, exticeden + LOGICAL, INTENT(IN ) :: myj, debug_print, exticeden !--- 3-D Atmospheric variables REAL , & INTENT(IN ) :: PATM, & @@ -1209,9 +1280,11 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia GSW, & GSWdn, & PC, & + msnf,facsnf, & VEGFRA, & ALB_SNOW_FREE, & lai, & + hgt,stdev, & SEAICE, & RHO, & QKMS, & @@ -1289,7 +1362,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia INFILTR, & RHOSN, & RHONEWSN, & - rhosnfall, & + rhosnfall, & snowrat, & grauprat, & icerat, & @@ -1365,7 +1438,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia REAL :: BSN, XSN , & RAINF, SNTH, NEWSN, PRCPMS, NEWSNMS , & - T3, UPFLUX, XINET + T3, UPFLUX, XINET, snowfrac2, m REAL :: snhei_crit, snhei_crit_newsn, keep_snow_albedo, SNOWFRACnewsn REAL :: newsnowratio, dd1 @@ -1384,11 +1457,25 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia SNWE,RHOSN,SNOM,SMELT,TS1D ENDIF + !-- Snow fraction options + !-- option 1: original formulation using critical snow depth to compute + !-- snow fraction + !-- option 2: the tanh formulation from Niu,G.-Y.,and Yang,Z.-L. 2007,JGR,DOI:10.1029/2007JD008674. + !-- option 3: the tanh formulation from Niu,G.-Y.,and Yang,Z.-L. 2007,JGR,DOI:10.1029/2007JD008674. + ! with vegetation dependent parameters from Noah MP (personal + ! communication with Mike Barlage) + !-- SNHEI_CRIT is a threshold for fractional snow in isncovr_opt=1 + snhei_crit=0.01601*1.e3/rhosn + snhei_crit_newsn=0.0005*1.e3/rhosn + !-- + zntsn = z0tbl(isice) snow_mosaic=0. snfr = 1. NEWSN=0. newsnowratio = 0. snowfracnewsn=0. + snowfrac2=0. + rhonewsn = 100. if(snhei == 0.) snowfrac=0. smelt = 0. RAINF = 0. @@ -1460,23 +1547,18 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia if(bsn*snwe*100..lt.1.e-4) goto 777 XSN=rhosn*(exp(bsn*snwe*100.)-1.)/(bsn*snwe*100.) rhosn=MIN(MAX(58.8,XSN),500.) -!13mar18 rhosn=MIN(MAX(76.9,XSN),500.) -! rhosn=MIN(MAX(62.5,XSN),890.) -! rhosn=MIN(MAX(100.,XSN),400.) -! rhosn=MIN(MAX(50.,XSN),400.) 777 continue - -! else -! rhosn =200. -! rhonewsn =200. endif + !-- snow_mosaic from the previous time step + if(snowfrac < 0.75) snow_mosaic = 1. + !if(snowfrac < 0.9) snow_mosaic = 1. + newsn=newsnms*delt !---- ACSNOW - run-total snowfall water [mm] acsnow=acsnow+newsn*1.e3 IF(NEWSN.GT.0.) THEN -! IF(NEWSN.GE.1.E-8) THEN IF (debug_print ) THEN print *, 'THERE IS NEW SNOW, newsn', newsn @@ -1484,18 +1566,12 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia newsnowratio = min(1.,newsn/(snwe+newsn)) -!*** Calculate fresh snow density (t > -15C, else MIN value) -!*** Eq. 10 from Koren et al. (1999) -!--- old formulation from Koren (1999) -! if(tabs.lt.258.15) then -! rhonewsn=50. -! rhonewsn=100. -! rhonewsn=62.5 - -! else -! rhonewsn=MIN(rhonewsn,400.) -! endif -!--- end of old formulation + !if(isncovr_opt == 2) then + !-- update snow fraction for fresh snowfall (Swenson&Lawrence,JGR,2012) + ! time-step snowfall [mm H2O], 0.1 - accumulation constant (unitless) + ! snowfrac = snowfrac + tanh(0.1*newsn*1.e3)*(1.-snowfrac) ! eq. 8.1 from CLM5 + ! if(debug_print) print *,'2 - snowfrac newsn', i,j,ktau,snowfrac + !endif !--- 27 Feb 2014 - empirical formulations from John M. Brown ! rhonewsn=min(250.,rhowater/max(4.179,(13.*tanh((274.15-Tabs)*0.3333)))) @@ -1506,13 +1582,21 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia rhonewsn=min(125.,1000.0/max(8.,(17.*tanh((276.65-Tabs)*0.15)))) rhonewgr=min(500.,rhowater/max(2.,(3.5*tanh((274.15-Tabs)*0.3333)))) rhonewice=rhonewsn + !--- compute density of "snowfall" from weighted contribution ! of snow, graupel and ice fractions - rhosnfall = min(500.,max(58.8,(rhonewsn*snowrat + & + rhosnfall = min(500.,max(58.8,(rhonewsn*snowrat + & !13mar18 rhosnfall = min(500.,max(76.9,(rhonewsn*snowrat + & rhonewgr*grauprat + rhonewice*icerat + rhonewgr*curat))) + if (debug_print) then + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,' xlat, xlon', xlat, xlon + print *,'snow_mosaic = ',snow_mosaic + print *,'new snow,newsnowratio,rhosnfall =',newsn,newsnowratio,rhosnfall + print *,'snowrat,grauprat,icerat,curat,rhonewgr,rhonewsn,rhonewice',snowrat,grauprat,icerat,curat,rhonewgr,rhonewsn,rhonewice + endif ! from now on rhonewsn is the density of falling frozen precipitation rhonewsn=rhosnfall end if @@ -1523,15 +1607,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia xsn=(rhosn*snwe+rhonewsn*newsn)/ & (snwe+newsn) rhosn=MIN(MAX(58.8,XSN),500.) -!13mar18 rhosn=MIN(MAX(76.9,XSN),500.) -! rhosn=MIN(MAX(100.,XSN),500.) -! rhosn=MIN(MAX(50.,XSN),400.) - -!Update snow on the ground -! snwe=snwe+newsn -! newsnowratio = min(1.,newsn/snwe) -! snhei=snwe*rhowater/rhosn -! NEWSN=NEWSN*rhowater/rhonewsn ENDIF ! end NEWSN > 0. IF(PRCPMS.NE.0.) THEN @@ -1552,9 +1627,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! J. of Hydrometeorology, 2006, CLM. interw=0.25*DELT*PRCPMS*(1.-exp(-0.5*lai))*vegfrac intersn=0.25*NEWSN*(1.-exp(-0.5*lai))*vegfrac -!original - next 2 lines -! interw=DELT*PRCPMS*vegfrac -! intersn=NEWSN*vegfrac infwater=PRCPMS - interw/delt if((interw+intersn) > 0.) then intwratio=interw/(interw+intersn) @@ -1563,7 +1635,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! Update water/snow intercepted by the canopy dd1=CST + interw + intersn CST=DD1 -! if(i==666.and.j==282) print *,'666,282 - cst,sat,interw,intersn',cst,sat,interw,intersn IF(CST.GT.SAT) THEN CST=SAT DRIP=DD1-SAT @@ -1576,12 +1647,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia infwater=PRCPMS endif ! vegfrac > 0.01 -! SNHEI_CRIT is a threshold for fractional snow - SNHEI_CRIT=0.01601*1.e3/rhosn - SNHEI_CRIT_newsn=0.0005*1.e3/rhosn -! snowfrac from the previous time step - SNOWFRAC=MIN(1.,SNHEI/(2.*SNHEI_CRIT)) - if(snowfrac < 0.75) snow_mosaic = 1. IF(NEWSN.GT.0.) THEN !Update snow on the ground @@ -1606,7 +1671,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia IF(SNHEI.GT.0.0) THEN !-- SNOW on the ground !--- Land-use category should be changed to snow/ice for grid points with snow>0 - ILAND=ISICE + ILAND=ISICE !24nov15 - based on field exp on Pleasant View soccer fields ! if(meltfactor > 1.5) then ! all veg. types, except forests ! SNHEI_CRIT=0.01601*1.e3/rhosn @@ -1618,9 +1683,38 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! SNHEI_CRIT_newsn=0.001*1.e3/rhosn ! endif - SNOWFRAC=MIN(1.,SNHEI/(2.*SNHEI_CRIT)) -!24nov15 - SNOWFRAC for urban category < 0.75 - if(ivgtyp == urban) snowfrac=min(0.75,snowfrac) + !-- update snow cover with accounting for fresh snow + m = 1.0 ! m=1.6 in Niu&Yang, m=1 in CLM + if(isncovr_opt == 1) then + snowfrac=min(1.,snhei/(2.*snhei_crit)) + elseif(isncovr_opt == 2) then + snowfrac=min(1.,snhei/(2.*snhei_crit)) + if(ivgtyp == glacier .or. ivgtyp == bare) then + !-- sparsely vegetated or land ice + snowfrac2 = tanh( snhei/(2.5 * 0.2 *(rhosn/rhonewsn)**m)) + !- TEST - replace rhonewsn with 100 in Niu&Yang + !snowfrac2 = tanh( snhei/(2.5 * znt *(rhosn*1.e-2)**m)) + else + !-- Niu&Yang: znt=0.01 m for 1 degree (100km) resolution tests + ! on 3-km scale use actual roughness, but not higher than 0.2 m. + ! The factor is 20 for forests (~100/dx = 33.) + snowfrac2 = tanh( snhei/(2.5 *min(0.2,znt) *(rhosn/rhonewsn)**m)) + !- TEST - replace rhonewsn with 100 in Niu&Yang + !snowfrac2 = tanh( snhei/(2.5 *min(0.2,znt) *(rhosn*1.e-2)**m)) + endif + !-- snow fraction is average between method 1 and 2 + snowfrac = 0.5*(snowfrac+snowfrac2) + else + !-- isncovr_opt=3 + !m = msnf ! vegetation dependent facsnf/msnf from Noah MP + !-- for RRFS a factor 10. was added to 'facsnf' to get reasonal values of + ! snow cover fractions on the 3-km scale. + ! This factor is scale dependent. + snowfrac = tanh( snhei/(10. * facsnf *(rhosn/rhonewsn)**m)) + !- TEST - replace rhonewsn with 100 in Niu&Yang + !snowfrac = tanh( snhei/(10. * facsnf *(rhosn*1.e-2)**m)) + endif + ! if(meltfactor > 1.5) then ! if(isltyp > 9 .and. isltyp < 13) then !24nov15 clay soil types - SNOFRAC < 0.9 @@ -1631,19 +1725,25 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! snowfrac=min(0.85,snowfrac) ! endif -! SNOWFRAC=MIN(1.,SNHEI/(2.*SNHEI_CRIT)) -! elseif(snowfrac < 0.3 .and. tabs > 275.) then -! if(snowfrac < 0.3.and. tabs > 275.) snow_mosaic = 1. + if(newsn > 0. ) then + SNOWFRACnewsn=MIN(1.,SNHEI/SNHEI_CRIT_newsn) + endif + + !-- due to steep slopes and blown snow, limit snow fraction in the + !-- mountains to 0.85 (based on Swiss weather model over the Alps) + if(hgt > 2500. .and. ivgtyp == glacier) snowfrac=min(0.85,snowfrac) - if(snowfrac < 0.75) snow_mosaic = 1. + !24nov15 - SNOWFRAC for urban category < 0.75 + if(ivgtyp == urban) snowfrac=min(0.75,snowfrac) - if(newsn > 0. ) SNOWFRACnewsn=MIN(1.,SNHEI/SNHEI_CRIT_newsn) + if(snowfrac < 0.75) snow_mosaic = 1. + !if(snowfrac < 0.9) snow_mosaic = 1. - KEEP_SNOW_ALBEDO = 0. - IF (NEWSN > 0. .and. snowfracnewsn > 0.99) THEN + KEEP_SNOW_ALBEDO = 0. + IF (NEWSN > 0. .and. snowfracnewsn > 0.99 .and. rhosnfall < 450.) THEN ! new snow KEEP_SNOW_ALBEDO = 1. - snow_mosaic=0. ! ??? + !snow_mosaic=0. ! ??? ENDIF !7Mar18 - turn off snow mosaic for T<271K to prevent from too warm @@ -1659,14 +1759,14 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia !-- Set znt for snow from VEGPARM table (snow/ice landuse), except for !-- land-use types with higher roughness (forests, urban). -!5mar12 IF(znt.lt.0.2 .and. snowfrac.gt.0.99) znt=z0tbl(iland) -! IF(newsn==0. .and. znt.lt.0.2 .and. snowfrac.gt.0.99) znt=z0tbl(iland) IF(newsn.eq.0. .and. znt.le.0.2 .and. IVGTYP.ne.isice) then if( snhei .le. 2.*ZNT)then + ! shallow snow znt=0.55*znt+0.45*z0tbl(iland) elseif( snhei .gt. 2.*ZNT .and. snhei .le. 4.*ZNT)then znt=0.2*znt+0.8*z0tbl(iland) elseif(snhei > 4.*ZNT) then + ! deep snow znt=z0tbl(iland) endif ENDIF @@ -1685,19 +1785,36 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia if( snow_mosaic == 1.) then ALBsn=alb_snow ! ALBsn=max(0.4,alb_snow) + if(newsn > 0. .and. KEEP_SNOW_ALBEDO > 0.9 .and. albsn < 0.4) then + !-- Albedo correction with fresh snow and deep snow pack + !-- will reduce warm bias in western Canada + !-- and US West coast, where max snow albedo is low (0.3-0.5). + !print *,'ALB increase to 0.7',alb_snow,snhei,snhei_crit,albsn,i,j + !!!!ALBsn = 0.7 + endif + Emiss= emissn else ALBsn = MAX(keep_snow_albedo*alb_snow, & MIN((alb_snow_free + & (alb_snow - alb_snow_free) * snowfrac), alb_snow)) + if(newsn > 0. .and. KEEP_SNOW_ALBEDO > 0.9 .and. albsn < 0.4) then + !-- Albedo correction with fresh snow and deep snow pack + !-- will reduce warm bias in western Canada + !-- and US West coast, where max snow albedo is low (0.3-0.5). + !print *,'ALB increase to 0.7',alb_snow,snhei,snhei_crit,albsn,i,j + !!!!ALBsn = 0.7 + !print *,'NO mosaic ALB increase to 0.7',alb_snow,snhei,snhei_crit,alb,i,j + endif Emiss = MAX(keep_snow_albedo*emissn, & MIN((emiss_snowfree + & (emissn - emiss_snowfree) * snowfrac), emissn)) - endif + endif ! snow_mosaic + IF (debug_print ) THEN -! if(i.eq.279.and.j.eq.263) then - print *,'Snow on soil ALBsn,emiss,snow_mosaic',i,j,ALBsn,emiss,snow_mosaic + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'Snow on soil ALBsn,emiss,snow_mosaic',i,j,ALBsn,emiss,snow_mosaic ENDIF !28mar11 if canopy is covered with snow to 95% of its capacity and snow depth is ! higher than patchy snow treshold - then snow albedo is not less than 0.55 @@ -1765,7 +1882,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia XINET = EMISS_snowfree*(GLW-UPFLUX) RNET = GSWnew + XINET IF (debug_print ) THEN -! if(i.eq.442.and.j.eq.260) then print *,'Fractional snow - snowfrac=',snowfrac print *,'Snowfrac<1 GSWin,GSWnew -',GSWin,GSWnew,'SOILT, RNET',soilt,rnet ENDIF @@ -1789,7 +1905,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ilands = ivgtyp - CALL SOIL(debug_print, & + CALL SOIL(debug_print,xlat,xlon, & !--- input variables i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew,gswin, & @@ -1820,7 +1936,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia XINET = EMISS_snowfree*(GLW-UPFLUX) RNET = GSWnew + XINET IF (debug_print ) THEN -! if(i.eq.442.and.j.eq.260) then print *,'Fractional snow - snowfrac=',snowfrac print *,'Snowfrac<1 GSWin,GSWnew -',GSWin,GSWnew,'SOILT, RNET',soilt,rnet ENDIF @@ -1835,7 +1950,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia runoff1s=0. runoff2s=0. - CALL SICE(debug_print, & + CALL SICE(debug_print,xlat,xlon, & !--- input variables i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew, & @@ -1866,34 +1981,22 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia enddo endif ! seaice < 0.5 -!return gswnew to incoming solar - IF (debug_print ) THEN -! if(i.eq.442.and.j.eq.260) then - print *,'gswnew,alb_snow_free,alb',gswnew,alb_snow_free,alb - ENDIF -! gswnew=gswnew/(1.-alb_snow_free) - - IF (debug_print ) THEN -! if(i.eq.442.and.j.eq.260) then - print *,'Incoming GSWnew snowfrac<1 -',gswnew - ENDIF endif ! snow_mosaic=1. !--- recompute absorbed solar radiation and net radiation !--- for updated value of snow albedo - ALB gswnew=GSWin*(1.-alb) -! print *,'SNOW fraction GSWnew',gswnew,'alb=',alb !-------------- T3 = STBOLT*SOILT*SOILT*SOILT UPFLUX = T3 *SOILT XINET = EMISS*(GLW-UPFLUX) RNET = GSWnew + XINET IF (debug_print ) THEN -! if(i.eq.442.and.j.eq.260) then -! if(i.eq.271.and.j.eq.242) then + !if (abs(xlat-testptlat).lt.0.1 .and. abs(xlon-testptlon).lt.0.1)then print *,'RNET=',rnet print *,'SNOW - I,J,newsn,snwe,snhei,GSW,GSWnew,GLW,UPFLUX,ALB',& i,j,newsn,snwe,snhei,GSW,GSWnew,GLW,UPFLUX,ALB + print *,'GSWnew',gswnew,'alb=',alb ENDIF if (SEAICE .LT. 0.5) then @@ -1903,7 +2006,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia else snfr=snowfrac endif - CALL SNOWSOIL (debug_print, & !--- input variables + CALL SNOWSOIL (debug_print,xlat,xlon,testptlat,testptlon, & !--- input variables i,j,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & meltfactor,rhonewsn,SNHEI_CRIT, & ! new ILAND,PRCPMS,RAINF,NEWSN,snhei,SNWE,snfr, & @@ -1933,7 +2036,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia snfr=snowfrac endif - CALL SNOWSEAICE (debug_print, & + CALL SNOWSEAICE (debug_print,xlat,xlon, & i,j,isoil,delt,ktau,conflx,nzs,nddzs, & meltfactor,rhonewsn,SNHEI_CRIT, & ! new ILAND,PRCPMS,RAINF,NEWSN,snhei,SNWE,snfr, & @@ -1970,27 +2073,24 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia endif - if(snhei.eq.0.) then -!--- all snow is melted - alb=alb_snow_free - iland=ivgtyp - endif - if (snow_mosaic==1.) then ! May 2014 - now combine snow covered and snow-free land fluxes, soil temp, moist, ! etc. if(SEAICE .LT. 0.5) then ! LAND IF (debug_print ) THEN -! if(i.eq.442.and.j.eq.260) then - print *,'SOILT snow on land', ktau, i,j,soilt - print *,'SOILT on snow-free land', i,j,soilts - print *,'ts1d,ts1ds',i,j,ts1d,ts1ds + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,' xlat, xlon', xlat, xlon + print *,' snowfrac = ',snowfrac + print *,' SOILT snow on land', ktau, i,j,soilt + print *,' SOILT on snow-free land', i,j,soilts + print *,' ts1d,ts1ds',i,j,ts1d,ts1ds print *,' SNOW flux',i,j, snflx print *,' Ground flux on snow-covered land',i,j, s print *,' Ground flux on snow-free land', i,j,ss print *,' CSTS, CST', i,j,csts,cst ENDIF + do k=1,nzs soilm1d(k) = soilm1ds(k)*(1.-snowfrac) + soilm1d(k)*snowfrac ts1d(k) = ts1ds(k)*(1.-snowfrac) + ts1d(k)*snowfrac @@ -2044,9 +2144,10 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia infiltr = infiltrs*(1.-snowfrac) + infiltr*snowfrac IF (debug_print ) THEN - print *,' Ground flux combined', i,j, s - print *,'SOILT combined on land', soilt - print *,'TS combined on land', ts1d + !if (abs(xlat-33.35).lt.0.2 .and. & abs(xlon-272.55).lt.0.2)then + print *,' Ground flux combined', xlat,xlon, s + print *,' SOILT combined on land', soilt + print *,' TS combined on land', ts1d ENDIF else ! SEA ICE @@ -2062,23 +2163,18 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia qvg = qvgs*(1.-snowfrac) + qvg*snowfrac qsg = qsgs*(1.-snowfrac) + qsg*snowfrac qcg = qcgs*(1.-snowfrac) + qcg*snowfrac + sublim = eeta*snowfrac eeta = eetas*(1.-snowfrac) + eeta*snowfrac qfx = qfxs*(1.-snowfrac) + qfx*snowfrac hfx = hfxs*(1.-snowfrac) + hfx*snowfrac s = ss*(1.-snowfrac) + s*snowfrac - sublim = eeta prcpl = prcpls*(1.-snowfrac) + prcpl*snowfrac fltot = fltots*(1.-snowfrac) + fltot*snowfrac -!alb ALB = MAX(keep_snow_albedo*alb, & MIN((albice + (alb - alb_snow_free) * snowfrac), alb)) - Emiss = MAX(keep_snow_albedo*emissn, & MIN((emiss_snowfree + & (emissn - emiss_snowfree) * snowfrac), emissn)) - -! alb=alb_snow_free*(1.-snowfrac) + alb*snowfrac -! emiss=1.*(1.-snowfrac) + emissn*snowfrac runoff1 = runoff1s*(1.-snowfrac) + runoff1*snowfrac runoff2 = runoff2s*(1.-snowfrac) + runoff2*snowfrac smelt = smelt * snowfrac @@ -2091,9 +2187,104 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia endif endif ! snow_mosaic = 1. -! run-total accumulated snow based on snowfall and snowmelt in [m] + !-- 13 jan 2022 + ! update snow fraction after melting (Swenson, S.C. and Lawrence, 2012, + ! JGR, DOI:10.1029/2012MS000165 + ! + !if (snwe > 0.) then + ! if(smelt > 0.) then + !update snow fraction after melting + !n_melt = 200./max(10.,topo_std) + ! snowfrac = max(0.,snowfrac - (acos(min(1.,(2.*(smelt*delt/snwe) - + ! 1.)))/piconst)**10) + !snowfrac = 1. - (acos(min(1.,(2.*(smelt*delt/snwe) - + !1.)))/piconst)**10. + ! if(i==744.and.j==514 .or. i==924.and.j==568)then + !print *,'smr,n_melt,topo_std', smr,n_melt,topo_std + ! print *,'3 - snowfrac end', i,j,ktau,snowfrac,smelt*delt, snwe, + ! piconst + ! endif + ! endif + !else + ! snowfrac = 0. + !endif + ! + !-- The NY07 parameterization gives more realistic snow cover fraction + ! than SL12 + !-- 13 Jan 2022 + !-- update snow fraction after metlting (Niu, G.-Y., and Yang, Z.-L. 2007, + !JGR, + ! DOI:10.1029/2007JD008674) + ! Limit on znt (<0.25) is needed to avoid very small snow fractions in the + ! forested areas with large roughness + + IF(snhei == 0.) then + !--- all snow is melted + iland=ivgtyp + snowfrac = 0. + alb = alb_snow_free + emiss = emiss_snowfree + ELSE + !-- update snow cover after possible melting + m = 1.0 ! m=1.6 in Niu&Yang, m=1 in CLM + if(isncovr_opt == 1) then + snowfrac=min(1.,snhei/(2.*snhei_crit)) + elseif(isncovr_opt == 2) then + !-- isncovr_opt=2 + snowfrac=min(1.,snhei/(2.*snhei_crit)) + if(ivgtyp == glacier .or. ivgtyp == bare) then + !-- sparsely vegetated or land ice + snowfrac2 = tanh( snhei/(2.5 * 0.2 *(rhosn/rhonewsn)**m)) + !- TEST - replace rhonewsn with 100 in Niu&Yang + !snowfrac2 = tanh( snhei/(2.5 * znt *(rhosn*1.e-2)**m)) + else + !-- Niu&Yang: znt=0.01 m for 1 degree (100km) resolution tests + ! on 3-km scale use actual roughness, but not higher than 0.2 m. + ! The factor is 20 for forests (~100/dx = 33.) + snowfrac2 = tanh( snhei/(2.5 *min(0.2,znt) *(rhosn/rhonewsn)**m)) + !- TEST - replace rhonewsn with 100 in Niu&Yang + !snowfrac2 = tanh( snhei/(2.5 *min(0.15,znt) *(rhosn*1.e-2)**m)) + endif + !-- snow fraction is average between method 1 and 2 + snowfrac = 0.5*(snowfrac+snowfrac2) + else + !-- isncovr_opt=3 + !m = msnf ! vegetation dependent facsnf/msnf from Noah MP + !-- for RRFS a factor 10. was added to 'facsnf' to get reasonal values of + ! snow cover fractions on the 3-km scale. + ! This factor is scale dependent. + snowfrac = tanh( snhei/(10. * facsnf *(rhosn/rhonewsn)**m)) + !- TEST - replace rhonewsn with 100 in Niu&Yang + !snowfrac = tanh( snhei/(2.5* min(0.2,znt) *(rhosn*1.e-2)**m)) + endif - snowfallac = snowfallac + max(0.,(newsn - rhowater/rhonewsn*smelt*delt*newsnowratio)) + !-- due to steep slopes and blown snow, limit snow fraction in the + !-- mountains ( Swiss weather model) + if(hgt > 2500. .and. ivgtyp == glacier) snowfrac=min(0.85,snowfrac) + + if(ivgtyp == urban) snowfrac=min(0.75,snowfrac) + +! run-total accumulated snow based on snowfall and snowmelt in [mm] + + IF (debug_print ) then + !if (abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2)then + print *,'Snowfallac xlat, xlon',xlat,xlon + print *,'newsn,rhonewsn,newsnowratio=',newsn,rhonewsn,newsnowratio + print *,'Time-step newsn depth [m], swe [m]',newsn,newsn*rhonewsn + print *,'Time-step smelt: swe [m]' ,smelt*delt + print *,'Time-step sublim: swe,[kg m-2]',sublim*delt + endif + + !snowfallac = snowfallac + max(0.,(newsn - rhowater/rhonewsn*smelt*delt*newsnowratio))*1.e3 + snowfallac = snowfallac + max(0.,(newsn*rhonewsn - & ! source of snow (swe) [m] + (smelt+sublim*1.e-3)*delt*newsnowratio) & ! sink: melting and sublimation, (swe) [m] + /rhonewsn)*1.e3 ! snow accumulation in snow depth [mm] + + IF (debug_print ) THEN + !if (abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2)then + print *,'snowfallac,snhei,snwe',snowfallac,snhei,snwe + endif + ENDIF ELSE !--- no snow @@ -2112,7 +2303,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia if(SEAICE .LT. 0.5) then ! LAND - CALL SOIL(debug_print, & + CALL SOIL(debug_print,xlat,xlon, & !--- input variables i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew,GSWin, & @@ -2139,7 +2330,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia alb=albice RNET = GSWnew + XINET - CALL SICE(debug_print, & + CALL SICE(debug_print,xlat,xlon, & !--- input variables i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew, & @@ -2210,7 +2401,7 @@ END FUNCTION QSN !>\ingroup lsm_ruc_group !> This subroutine calculates energy and moisture budget for vegetated surfaces !! without snow, heat diffusion and Richards eqns in soil. - SUBROUTINE SOIL (debug_print, & + SUBROUTINE SOIL (debug_print,xlat,xlon, & i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot,& !--- input variables PRCPMS,RAINF,PATM,QVATM,QCATM, & GLW,GSW,GSWin,EMISS,RNET, & @@ -2292,7 +2483,7 @@ SUBROUTINE SOIL (debug_print, & INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,iland,isoil - REAL, INTENT(IN ) :: DELT,CONFLX + REAL, INTENT(IN ) :: DELT,CONFLX,xlat,xlon LOGICAL, INTENT(IN ) :: myj !--- 3-D Atmospheric variables REAL, & @@ -2547,7 +2738,7 @@ SUBROUTINE SOIL (debug_print, & !--- water, and DRYCAN is the fraction of vegetated area where !--- transpiration may take place. - WETCAN=min(0.25,(CST/SAT)**CN) + WETCAN=min(0.25,max(0.,(CST/SAT))**CN) ! if(lai > 1.) wetcan=wetcan/lai DRYCAN=1.-WETCAN @@ -2580,6 +2771,21 @@ SUBROUTINE SOIL (debug_print, & ! print *,'alfa=',alfa, exp(G0_P*psit/r_v/SOILT) ! endif alfa=1. +! field capacity +! 20jun18 - beta in Eq. (5) is called soilres in the code - it limits soil evaporation +! when soil moisture is below field capacity. [Lee and Pielke, 1992] +! This formulation agrees with observations when top layer is < 2 cm thick. +! Soilres = 1 for snow, glaciers and wetland. +! fc=ref - suggested in the paper +! fc=max(qmin,ref*0.5) ! used prior to 20jun18 change +! Switch from ref*0.5 to ref*0.25 will reduce soil resistance, increase direct +! evaporation, effects sparsely vegetated areas--> cooler during the day +! fc=max(qmin,ref*0.25) ! +! For now we'll go back to ref*0.5 +! 3feb21 - in RRFS testing (fv3-based), ref*0.5 gives too much direct +! evaporation. Therefore , it is replaced with ref*0.7. + !fc=max(qmin,ref*0.5) + !fc=max(qmin,ref*0.7) fc=ref fex_fc=1. if((soilmois(1)+qmin) > fc .or. (qvatm-qvg) > 0.) then @@ -2598,27 +2804,8 @@ SUBROUTINE SOIL (debug_print, & !************************************************************** ! SOILTEMP soilves heat budget and diffusion eqn. in soil !************************************************************** - if(1==2) then - print *,'i,j,iland,isoil ', i,j,iland,isoil - print *,'delt,ktau,conflx,nzs,nddzs,nroot ',delt,ktau,conflx,nzs,nddzs,nroot - print *,'PRCPMS,RAINF ',PRCPMS,RAINF - print *,'PATM,TABS,QVATM,QCATM,EMISS,RNET ',PATM,TABS,QVATM,QCATM,EMISS,RNET - print *,'QKMS,TKMS,PC,rho,vegfrac, lai ',QKMS,TKMS,PC,rho,vegfrac, lai - print *,'thdif ',thdif - print *,'cap ',cap - print *,'drycan,wetcan ',drycan,wetcan - print *,'transum,dew,soilres,alfa ',transum,dew,soilres,alfa - print *,'mavail ',mavail - print *,'dqm,qmin,bclh,zsmain,zshalf,DTDZS',dqm,qmin,bclh,zsmain,zshalf,DTDZS - print *,'xlv,CP,G0_P,cvw,stbolt ',xlv,CP,G0_P,cvw,stbolt - print *,'tso=',tso - print *,'soilt=',soilt - print *,'qvg=',qvg - print *,'qsg=',qsg - print *,'qcg=',qcg - endif ! 1==2 - - CALL SOILTEMP(debug_print, & + + CALL SOILTEMP(debug_print,xlat,xlon, & !--- input variables i,j,iland,isoil, & delt,ktau,conflx,nzs,nddzs,nroot, & @@ -2634,15 +2821,6 @@ SUBROUTINE SOIL (debug_print, & !--- output variables tso,soilt,qvg,qsg,qcg,x) -if(1==2) then - print *,'after tso=',tso - print *,'after soilt=',soilt - print *,'after qvg=',qvg - print *,'after qsg=',qsg - print *,'after qcg=',qcg - print *,'after x=',x -endif - !************************************************************************ !--- CALCULATION OF DEW USING NEW VALUE OF QSG OR TRANSP IF NO DEW @@ -2850,7 +3028,7 @@ END SUBROUTINE SOIL !! on its surface. it solves heat diffusion inside ice and energy !! budget at the surface of ice. It computes skin temperature and !! temerature inside sea ice. - SUBROUTINE SICE ( debug_print, & + SUBROUTINE SICE ( debug_print,xlat,xlon, & i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & !--- input variables PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSW, & EMISS,RNET,QKMS,TKMS,rho,myj, & @@ -2874,7 +3052,7 @@ SUBROUTINE SICE ( debug_print, & INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,iland,isoil - REAL, INTENT(IN ) :: DELT,CONFLX + REAL, INTENT(IN ) :: DELT,CONFLX,xlat,xlon LOGICAL, INTENT(IN ) :: myj, debug_print !--- 3-D Atmospheric variables REAL, & @@ -3022,7 +3200,7 @@ SUBROUTINE SICE ( debug_print, & tn,aa1,bb,pp,fkq,r210 ENDIF QGOLD=QSG - CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil) + CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil,xlat,xlon) !--- it is saturation over sea ice QVG=QS1 QSG=QS1 @@ -3118,7 +3296,8 @@ END SUBROUTINE SICE !! solves energy and moisture budgets on the surface of snow, and !! on the interface of snow and soil. It computes skin temperature, !! snow temperature, snow depth and snow melt. - SUBROUTINE SNOWSOIL ( debug_print, & + SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & + testptlat,testptlon, & i,j,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & !--- input variables meltfactor,rhonewsn,SNHEI_CRIT, & ! new ILAND,PRCPMS,RAINF,NEWSNOW,snhei,SNWE,SNOWFRAC, & @@ -3218,7 +3397,8 @@ SUBROUTINE SNOWSOIL ( debug_print, & REAL, INTENT(IN ) :: DELT,CONFLX,PRCPMS , & RAINF,NEWSNOW,RHONEWSN, & - SNHEI_CRIT,meltfactor + testptlat,testptlon, & + SNHEI_CRIT,meltfactor,xlat,xlon LOGICAL, INTENT(IN ) :: myj @@ -3530,7 +3710,7 @@ SUBROUTINE SNOWSOIL ( debug_print, & SMELT=0. ! DD1=0. - H=1. + H=MAVAIL ! =1. if snowfrac=1 FQ=QKMS @@ -3546,18 +3726,18 @@ SUBROUTINE SNOWSOIL ( debug_print, & print *,'SNWE after subtracting intercepted snow - snwe=',snwe,vegfrac,cst ENDIF -! SNHEI=SNWE*1.e3/RHOSN +!-- Save SNWE from the previous time step SNWEPR=SNWE ! check if all snow can evaporate during DT BETA=1. - EPDT = EPOT * RAS *DELT*UMVEG + EPDT = EPOT * RAS *DELT IF(EPDT.gt.0. .and. SNWEPR.LE.EPDT) THEN - BETA=SNWEPR/max(1.e-8,EPDT) + BETA=SNWEPR/EPDT SNWE=0. ENDIF - WETCAN=min(0.25,(CST/SAT)**CN) + WETCAN=min(0.25,max(0.,(CST/SAT))**CN) ! if(lai > 1.) wetcan=wetcan/lai DRYCAN=1.-WETCAN @@ -3585,11 +3765,11 @@ SUBROUTINE SNOWSOIL ( debug_print, & IF (debug_print ) THEN print *, 'TSO before calling SNOWTEMP: ', tso ENDIF - CALL SNOWTEMP(debug_print, & + CALL SNOWTEMP(debug_print,xlat,xlon,testptlat,testptlon,& !--- input variables i,j,iland,isoil, & delt,ktau,conflx,nzs,nddzs,nroot, & - snwe,snwepr,snhei,newsnow,snowfrac, & + snwe,snwepr,snhei,newsnow,snowfrac,snhei_crit, & beta,deltsn,snth,rhosn,rhonewsn,meltfactor, & ! add meltfactor PRCPMS,RAINF, & PATM,TABS,QVATM,QCATM, & @@ -3781,8 +3961,8 @@ SUBROUTINE SNOWSOIL ( debug_print, & EETA = (EDIR1 + EC1 + ETT1)*1.E3 ENDIF S=SNFLX -! sublim=eeta - sublim=EDIR1*1.E3 + !sublim=EDIR1*1.E3 + sublim=Q1*1.E3 !kg m-2 s-1 ! Energy budget FLTOT=RNET-HFT-XLVm*EETA-S-SNOH-x IF (debug_print ) THEN @@ -3807,7 +3987,7 @@ END SUBROUTINE SNOWSOIL !! its surface. It solves energy budget on the snow interface with !! atmosphere and snow interface with ice. It calculates skin !! temperature, snow and ice temperatures, snow depth and snow melt. - SUBROUTINE SNOWSEAICE( debug_print, & + SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & i,j,isoil,delt,ktau,conflx,nzs,nddzs, & meltfactor,rhonewsn,SNHEI_CRIT, & ! new ILAND,PRCPMS,RAINF,NEWSNOW,snhei,SNWE,snowfrac, & @@ -3840,7 +4020,7 @@ SUBROUTINE SNOWSEAICE( debug_print, & REAL, INTENT(IN ) :: DELT,CONFLX,PRCPMS , & RAINF,NEWSNOW,RHONEWSN, & - meltfactor, snhei_crit + meltfactor,snhei_crit,xlat,xlon real :: rhonewcsn LOGICAL, INTENT(IN ) :: myj @@ -3944,6 +4124,7 @@ SUBROUTINE SNOWSEAICE( debug_print, & REAL :: RNET,rsmfrac,soiltfrac,hsn,icemelt,rr integer :: nmelt + REAL :: keff, fact !----------------------------------------------------------------- XLMELT=3.35E+5 @@ -3951,6 +4132,12 @@ SUBROUTINE SNOWSEAICE( debug_print, & XLVm=XLV+XLMELT ! STBOLT=5.670151E-8 + !-- options for snow conductivity: + !-- 1 - constant + !-- opt 2 - Sturm et al., 1997 + !isncond_opt = 2 + keff = 0.265 + !--- SNOW flag -- ISICE ! ILAND=isice @@ -3990,7 +4177,45 @@ SUBROUTINE SNOWSEAICE( debug_print, & RHOCSN=2090.* RHOSN !18apr08 - add rhonewcsn RHOnewCSN=2090.* RHOnewSN - THDIFSN = 0.265/RHOCSN + + if(isncond_opt == 1) then + !if(newsnow <= 0. .and. snhei > 5.0*SNHEI_crit) then + if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then + !-- some areas with large snow depth have unrealistically + !-- low snow density (in the Rockie's with snow depth > 1 m). + !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. + !-- In future a better compaction scheme is needed for these areas. + thdifsn = 2.5e-6 + else + !-- old version thdifsn = 0.265/RHOCSN + THDIFSN = 0.265/RHOCSN + endif + else + !-- 07Jun19 - thermal conductivity (K_eff) from Sturm et al.(1997) + !-- keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652) + fact = 1. + if(rhosn < 156. .or. (newsnow > 0. .and. rhonewsn < 156.)) then + keff = 0.023 + 0.234 * rhosn * 1.e-3 + !-- fact is added by tgs based on 4 Jan 2017 testing + fact = 5. + else + keff = 0.138 - 1.01 * rhosn*1.e-3 + 3.233 * rhosn**2 * 1.e-6 + fact = 2. + endif + !fact = 1. + + !if(newsnow <= 0. .and. snhei > 5.0*SNHEI_crit) then + if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then + !-- some areas with large snow depth have unrealistically + !-- low snow density (in the Rockie's with snow depth > 1 m). + !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. + !-- In future a better compaction scheme is needed for these areas. + thdifsn = 2.5e-6 + else + thdifsn = keff/rhocsn * fact + endif + endif + RAS=RHO*1.E-3 SOILTFRAC=SOILT @@ -4215,14 +4440,17 @@ SUBROUTINE SNOWSEAICE( debug_print, & print *,'TABS,QVATM,TN,QVG=',TABS,QVATM,TN,QVG ENDIF - CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil) + CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil,xlat,xlon) !--- it is saturation over snow QVG=QS1 QSG=QS1 QCG=0. -!--- SOILT - skin temperature +!--- SOILT - skin temperature of snow on ice SOILT=TS1 + if(nmelt==1 .and. snowfrac==1) then + soilt = min(273.15,soilt) + endif IF (debug_print ) THEN print *,' AFTER VILKA-SNOW on SEAICE' @@ -4280,10 +4508,10 @@ SUBROUTINE SNOWSEAICE( debug_print, & !--- IF SOILT > 273.15 F then melting of snow can happen ! IF(SOILT.GT.273.15.AND.SNWE.GT.0.) THEN ! if all snow can evaporate, then there is nothing to melt - IF(SOILT.GT.273.15.AND.SNWEPR-BETA*EPOT*RAS*DELT.GT.0..AND.SNHEI.GT.0.) THEN + !IF(SOILT.GT.273.15.AND.SNWEPR-BETA*EPOT*RAS*DELT.GT.0..AND.SNHEI.GT.0.) THEN + IF(SOILT.GT.273.15.AND.BETA.EQ.1..AND.SNHEI.GT.0.) THEN ! nmelt = 1 -! soiltfrac=273.15 soiltfrac=snowfrac*273.15+(1.-snowfrac)*min(271.4,SOILT) QSG= QSN(soiltfrac,TBQ)/PP @@ -4392,11 +4620,13 @@ SUBROUTINE SNOWSEAICE( debug_print, & !--- If there is no snow melting then just evaporation !--- or condensation changes SNWE ELSE - if(snhei.ne.0.) then + if(snhei.ne.0..and. beta == 1.) then EPOT=-QKMS*(QVATM-QSG) SNWE = AMAX1(0.,(SNWEPR- & BETA*EPOT*RAS*DELT)) ! BETA*EPOT*RAS*DELT*snowfrac)) + else + snwe = 0. endif ENDIF @@ -4424,7 +4654,44 @@ SUBROUTINE SNOWSEAICE( debug_print, & !13mar18 rhosn=MIN(MAX(76.9,XSN),500.) RHOCSN=2090.* RHOSN - thdifsn = 0.265/RHOCSN + if(isncond_opt == 1) then + ! if(newsnow <= 0. .and. snhei > 5.0*SNHEI_crit) then + if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then + !-- some areas with large snow depth have unrealistically + !-- low snow density (in the Rockie's with snow depth > 1 m). + !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. + !-- In future a better compaction scheme is needed for these areas. + thdifsn = 2.5e-6 + else + !-- old version thdifsn = 0.265/RHOCSN + THDIFSN = 0.265/RHOCSN + endif + else + !-- 07Jun19 - thermal conductivity (K_eff) from Sturm et al.(1997) + !-- keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652) + fact = 1. + if(rhosn < 156. .or. (newsn > 0. .and. rhonewsn < 156.)) then + keff = 0.023 + 0.234 * rhosn * 1.e-3 + !-- fact is added by tgs based on 4 Jan 2017 testing + fact = 5. + else + keff = 0.138 - 1.01 * rhosn*1.e-3 + 3.233 * rhosn**2 * 1.e-6 + fact = 2. + endif + !fact = 1. + + !if(newsn <= 0. .and. snhei > 5.0*SNHEI_crit) then + if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then + !-- some areas with large snow depth have unrealistically + !-- low snow density (in the Rockie's with snow depth > 1 m). + !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. + !-- In future a better compaction scheme is needed for these areas. + thdifsn = 2.5e-6 + else + thdifsn = keff/rhocsn * fact + endif + endif + endif endif @@ -4562,7 +4829,7 @@ END SUBROUTINE SNOWSEAICE !>\ingroup lsm_ruc_group !> This subroutine solves energy budget equation and heat diffusion !! equation. - SUBROUTINE SOILTEMP( debug_print, & + SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & i,j,iland,isoil, & !--- input variables delt,ktau,conflx,nzs,nddzs,nroot, & PRCPMS,RAINF,PATM,TABS,QVATM,QCATM, & @@ -4632,7 +4899,7 @@ SUBROUTINE SOILTEMP( debug_print, & INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,iland,isoil - REAL, INTENT(IN ) :: DELT,CONFLX,PRCPMS, RAINF + REAL, INTENT(IN ) :: DELT,CONFLX,PRCPMS, RAINF,xlat,xlon REAL, INTENT(INOUT) :: DRYCAN,WETCAN,TRANSUM !--- 3-D Atmospheric variables REAL, & @@ -4787,7 +5054,7 @@ SUBROUTINE SOILTEMP( debug_print, & ! AA1=AA*alfa+CC PP=PATM*1.E3 AA1=AA1/PP - CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil) + CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil,xlat,xlon) TQ2=QVATM TX2=TQ2*(1.-H) Q1=TX2+H*QS1 @@ -4810,7 +5077,7 @@ SUBROUTINE SOILTEMP( debug_print, & 100 BB=BB-AA*TX2 AA=(AA*H+CC)/PP - CALL VILKA(TN,AA,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil) + CALL VILKA(TN,AA,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil,xlat,xlon) Q1=TX2+H*QS1 IF (debug_print ) THEN ! if(i.eq.279.and.j.eq.263) then @@ -4885,10 +5152,10 @@ END SUBROUTINE SOILTEMP !>\ingroup lsm_ruc_group !> This subroutine solves energy bugdget equation and heat diffusion !! equation to obtain snow and soil temperatures. - SUBROUTINE SNOWTEMP( debug_print, & - i,j,iland,isoil, & !--- input variables + SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & + testptlat,testptlon,i,j,iland,isoil, & !--- input variables delt,ktau,conflx,nzs,nddzs,nroot, & - snwe,snwepr,snhei,newsnow,snowfrac, & + snwe,snwepr,snhei,newsnow,snowfrac,snhei_crit, & beta,deltsn,snth,rhosn,rhonewsn,meltfactor, & ! add meltfactor PRCPMS,RAINF, & PATM,TABS,QVATM,QCATM, & @@ -4963,7 +5230,8 @@ SUBROUTINE SNOWTEMP( debug_print, & REAL, INTENT(IN ) :: DELT,CONFLX,PRCPMS , & RAINF,NEWSNOW,DELTSN,SNTH , & TABS,TRANSUM,SNWEPR , & - rhonewsn,meltfactor + testptlat,testptlon , & + rhonewsn,meltfactor,xlat,xlon,snhei_crit real :: rhonewcsn !--- 3-D Atmospheric variables @@ -5071,13 +5339,19 @@ SUBROUTINE SNOWTEMP( debug_print, & qfx, & hfx - REAL :: RNET,rsmfrac,soiltfrac,hsn,rr - integer :: nmelt, iter + REAL :: RNET,rsmfrac,soiltfrac,hsn,rr,keff,fact + integer :: nmelt, iter !----------------------------------------------------------------- iter = 0 + !-- options for snow conductivity: + !-- 1 - constant + !-- opt 2 - Sturm et al., 1997 + !isncond_opt = 1 + keff = 0.265 + do k=1,nzs transp (k)=0. cotso (k)=0. @@ -5091,7 +5365,57 @@ SUBROUTINE SNOWTEMP( debug_print, & RHOCSN=2090.* RHOSN !18apr08 - add rhonewcsn RHOnewCSN=2090.* RHOnewSN - THDIFSN = 0.265/RHOCSN + if(isncond_opt == 1) then + ! if(newsnow <= 0. .and. snhei > 5.0*SNHEI_crit) then + if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then + !-- some areas with large snow depth have unrealistically + !-- low snow density (in the Rockie's with snow depth > 1 m). + !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. + !-- In future a better compaction scheme is needed for these areas. + thdifsn = 2.5e-6 + else + !-- old version thdifsn = 0.265/RHOCSN + THDIFSN = 0.265/RHOCSN + endif + else + !-- 07Jun19 - thermal conductivity (K_eff) from Sturm et al.(1997) + !-- keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652) + fact = 1. + if(rhosn < 156. .or. (newsnow > 0. .and. rhonewsn < 156.)) then + keff = 0.023 + 0.234 * rhosn * 1.e-3 + !-- fact is added by tgs based on 4 Jan 2017 testing + fact = 5. + else + keff = 0.138 - 1.01 * rhosn*1.e-3 + 3.233 * rhosn**2 * 1.e-6 + fact = 2. + if(debug_print) then + print *,'SnowTemp xlat,xlon,rhosn,keff', xlat,xlon,rhosn,keff,keff/rhocsn*fact + print *,'SNOWTEMP - 0.265/rhocsn',0.265/rhocsn + endif + endif + if ( debug_print .and. abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2) then + print *,'SNOWTEMP - xlat,xlon,newsnow,rhonewsn,rhosn,fact,keff',xlat,xlon,newsnow, rhonewsn,rhosn,fact,keff + endif + + !fact = 1. + + ! if(newsnow <= 0. .and. snhei > 5.0*SNHEI_crit) then + if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then + !-- some areas with large snow depth have unrealistically + !-- low snow density (in the Rockie's with snow depth > 1 m). + !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. + !-- In future a better compaction scheme is needed for these areas. + thdifsn = 2.5e-6 + else + thdifsn = keff/rhocsn * fact + endif + if (debug_print .and. abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2) then + print *,'SNOWTEMP - thdifsn',xlat,xlon,thdifsn + print *,'SNOWTEMP - 0.265/rhocsn',0.265/rhocsn + endif + + endif + RAS=RHO*1.E-3 SOILTFRAC=SOILT @@ -5159,8 +5483,8 @@ SUBROUTINE SNOWTEMP( debug_print, & cotsn=cotso(NZS) rhtsn=rhtso(NZS) !*** Average temperature of snow pack (C) - tsnav=0.5*(soilt+tso(1)) & - -273.15 + tsnav=min(0.,0.5*(soilt+tso(1)) & + -273.15) else !-- 2 layers in snow, SOILT1 is temperasture at DELTSN depth @@ -5188,9 +5512,9 @@ SUBROUTINE SNOWTEMP( debug_print, & cotsn=x1sn/denomsn rhtsn=(ftsnow+X1SN1*rhtso(NZS))/denomsn !*** Average temperature of snow pack (C) - tsnav=0.5/snhei*((soilt+soilt1)*deltsn & + tsnav=min(0.,0.5/snhei*((soilt+soilt1)*deltsn & +(soilt1+tso(1))*(SNHEI-DELTSN)) & - -273.15 + -273.15) endif ENDIF IF(SNHEI.LT.SNTH.AND.SNHEI.GT.0.) then @@ -5211,8 +5535,8 @@ SUBROUTINE SNOWTEMP( debug_print, & denom = 1. + x1sn + x2 - x2*cotso(nzs-2) cotso(nzs1) = x1sn/denom rhtso(nzs1)=(FT+X2*rhtso(NZS-2))/denom - tsnav=0.5*(soilt+tso(1)) & - -273.15 + tsnav=min(0.,0.5*(soilt+tso(1)) & + -273.15) cotso(NZS)=cotso(nzs1) rhtso(NZS)=rhtso(nzs1) cotsn=cotso(NZS) @@ -5229,7 +5553,7 @@ SUBROUTINE SNOWTEMP( debug_print, & ETT1=0. EPOT=-QKMS*(QVATM-QGOLD) RHCS=CAP(1) - H=1. + H=MAVAIL !1. TRANS=TRANSUM*DRYCAN/ZSHALF(NROOT+1) CAN=WETCAN+TRANS UMVEG=1.-VEGFRAC @@ -5318,12 +5642,19 @@ SUBROUTINE SNOWTEMP( debug_print, & AA1=AA1/PP BB=BB-SNOH/TDENOM - CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil) + IF (debug_print ) THEN + if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'1-', i,rnet,tabs,tn,aa1,bb,pp,ktau,newsnow,snwepr,snwe,snhei,snowfrac,soilt,soilt1,tso,rhosn + print *,'2-', i,tdenom,fkq,vegfrac,can,R210,D10,R21,D9sn,D1sn,R22sn,R7,prcpms + endif + ENDIF + CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil,xlat,xlon) TQ2=QVATM TX2=TQ2*(1.-H) Q1=TX2+H*QS1 IF (debug_print ) THEN - print *,'VILKA1 - TS1,QS1,TQ2,H,TX2,Q1',TS1,QS1,TQ2,H,TX2,Q1 + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'VILKA1 - TS1,QS1,TQ2,H,TX2,Q1',TS1,QS1,TQ2,H,TX2,Q1,xlat,xlon ENDIF IF(Q1.LT.QS1) GOTO 100 !--- if no saturation - goto 100 @@ -5337,9 +5668,10 @@ SUBROUTINE SNOWTEMP( debug_print, & GOTO 200 100 BB=BB-AA*TX2 AA=(AA*H+CC)/PP - CALL VILKA(TN,AA,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil) + CALL VILKA(TN,AA,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil,xlat,xlon) Q1=TX2+H*QS1 IF (debug_print ) THEN + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then print *,'VILKA2 - TS1,QS1,H,TX2,Q1',TS1,QS1,TQ2,H,TX2,Q1 ENDIF IF(Q1.GT.QS1) GOTO 90 @@ -5364,26 +5696,37 @@ SUBROUTINE SNOWTEMP( debug_print, & iter=1 ! goto 2211 endif -endif ! 1==2 IF (debug_print ) THEN if(iter==1) then print *,'SNOW - QVATM,QVG,QSG,QCG,TS1',QVATM,QVG,QSG,QCG,TS1 endif ENDIF +endif ! 1==2 !--- SOILT - skin temperature SOILT=TS1 + if(nmelt==1 .and. snowfrac==1 .and. snwe > 0. .and. SOILT > 273.15) then + !--7feb22 on the second iteration when SNOH is known and snwe > 0. after melting, + !-- check if the snow skin temperature is =<273.15K + !-- when a grid cell is fully covered with snow (snowfrac=1) + !-- or with partial snow cover and snow_mosaic=1 (snowfrac=1). + if (debug_print ) then + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'soilt is too high =',soilt,xlat,xlon + soilt = min(273.15,soilt) + endif + endif + IF (debug_print ) THEN -! IF(i.eq.266.and.j.eq.447) then - print *,'snwe,snhei,soilt,soilt1,tso',i,j,snwe,snhei,soilt,soilt1,tso -! endif + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'snwe,snwepr,snhei,snowfr,soilt,soilt1,tso',i,j,snwe,snwepr,snhei,snowfrac,soilt,soilt1,tso ENDIF ! Solution for temperature at 7.5 cm depth and snow-soil interface IF(SNHEI.GE.SNTH) THEN if(snhei.gt.DELTSN+SNTH) then !-- 2-layer snow model - SOILT1=min(273.15,rhtsn+cotsn*SOILT) + SOILT1=rhtsn+cotsn*SOILT TSO(1)=rhtso(NZS)+cotso(NZS)*SOILT1 tsob=soilt1 else @@ -5406,6 +5749,12 @@ SUBROUTINE SNOWTEMP( debug_print, & tsob=TSO(1) !new tsob=tso(2) ENDIF + if(nmelt==1.and.snowfrac==1) then + !-- second iteration with full snow cover + SOILT1= min(273.15,SOILT1) + TSO(1)= min(273.15,TSO(1)) + tsob = min(273.15,tsob) + endif !---- Final solution for TSO IF (SNHEI > 0. .and. SNHEI < SNTH) THEN @@ -5432,16 +5781,18 @@ SUBROUTINE SNOWTEMP( debug_print, & IF (debug_print ) THEN -! IF(i.eq.266.and.j.eq.447) then - print *,'SOILT,SOILT1,tso,TSOB,QSG',i,j,SOILT,SOILT1,tso,TSOB,QSG,'nmelt=',nmelt + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'Final SOILT,SOILT1,tso,TSOB,QSG',xlat,xlon,SOILT,SOILT1,tso,TSOB,QSG,'nmelt=',nmelt + print *,'SNWEPR-BETA*EPOT*RAS*DELT',SNWEPR-BETA*EPOT*RAS*DELT,beta,snwepr,epot ENDIF if(nmelt.eq.1) go to 220 !--- IF SOILT > 273.15 F then melting of snow can happen ! IF(SOILT.GT.273.15.AND.SNHEI.GT.0.) THEN -! if all snow can evaporate, then there is nothing to melt - IF(SOILT.GT.273.15.AND.SNWEPR-BETA*EPOT*RAS*DELT.GT.0.AND.SNHEI.GT.0.) THEN +! if all snow can evaporate (beta<1), then there is nothing to melt + IF(SOILT.GT.273.15.AND.BETA.EQ.1.AND.SNHEI.GT.0.) THEN + !-- snow sublimation and melting nmelt = 1 soiltfrac=snowfrac*273.15+(1.-snowfrac)*SOILT QSG=min(QSG, QSN(soiltfrac,TBQ)/PP) @@ -5453,6 +5804,7 @@ SUBROUTINE SNOWTEMP( debug_print, & EPOT = -QKMS*(QVATM-QSG) Q1=EPOT*RAS + IF (Q1.LE.0..or.iter==1) THEN ! --- condensation DEW=-EPOT @@ -5495,7 +5847,7 @@ SUBROUTINE SNOWTEMP( debug_print, & ENDIF ! - X= (R21+D9SN*R22SN)*(soiltfrac-TN) + & + X= (R21+D9SN*R22SN)*(soiltfrac-TN) + & XLVM*R210*(QVG-QGOLD) IF (debug_print ) THEN print *,'SNOWTEMP storage ',i,j,x @@ -5511,69 +5863,110 @@ SUBROUTINE SNOWTEMP( debug_print, & !-- SMELT is speed of melting in M/S SMELT= SNOH /XLMELT*1.E-3 IF (debug_print ) THEN - print *,'1- SMELT',i,j,smelt - ENDIF - SMELT=AMIN1(SMELT,SNWEPR/DELT-BETA*EPOT*RAS) - IF (debug_print ) THEN - print *,'2- SMELT',i,j,smelt + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'1- SMELT',smelt,snoh,xlat,xlon ENDIF - SMELT=AMAX1(0.,SMELT) + + IF(EPOT.gt.0. .and. SNWEPR.LE.EPOT*RAS*DELT) THEN +!-- all snow can evaporate + BETA=SNWEPR/(EPOT*RAS*DELT) + SMELT=AMAX1(0.,AMIN1(SMELT,SNWEPR/DELT-BETA*EPOT*RAS)) + SNWE=0. + IF (debug_print ) THEN + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'2- SMELT',xlat,xlon,snwe,smelt,rhonewsn,xlat,xlon + ENDIF + goto 88 + ENDIF !18apr08 - Egglston limit -! SMELT= amin1 (smelt, 5.6E-7*meltfactor*max(1.,(soilt-273.15))) + !-- 22apr22 Do not limit snow melting for hail (rhonewsn > 450), or dense snow + !-- (rhosn > 350.) with very warm surface temperatures (>10C) + if( (rhosn < 350. .or. (newsnow > 0. .and. rhonewsn < 450.)) .and. soilt < 283. ) then SMELT= amin1 (smelt, delt/60.*5.6E-8*meltfactor*max(1.,(soilt-273.15))) -! SMELT= amin1 (smelt, delt/60.*5.6E-8*meltfactor*min(2.,max(0.001,(tabs-273.15))) ! SnowMIP - IF (debug_print ) THEN - print *,'3- SMELT',i,j,smelt - ENDIF +! SMELT= amin1 (smelt, delt/60.*5.6E-8*meltfactor*min(2.,max(0.001,(tabs-273.15))) ! SnowMIP + IF (debug_print ) THEN + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'3- SMELT',xlat,xlon,smelt,rhosn,rhonewsn,xlat,xlon + ENDIF + endif ! rr - potential melting rr=max(0.,SNWEPR/delt-BETA*EPOT*RAS) - SMELT=min(SMELT,rr) - IF (debug_print ) THEN - print *,'4- SMELT i,j,smelt,rr',i,j,smelt,rr - ENDIF + if(smelt > rr) then + SMELT = min(SMELT,rr) + SNWE = 0. + IF (debug_print ) THEN + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'4- SMELT i,j,smelt,rr',xlat,xlon,smelt,rr + ENDIF + endif + 88 continue SNOHGNEW=SMELT*XLMELT*1.E3 SNODIF=AMAX1(0.,(SNOH-SNOHGNEW)) SNOH=SNOHGNEW - IF (debug_print ) THEN - print *,'SNOH,SNODIF',SNOH,SNODIF - ENDIF + IF (debug_print ) THEN + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'SNOH,SNODIF',SNOH,SNODIF + print *,' xlat, xlon', xlat, xlon + ENDIF + IF( smelt > 0.) then !*** From Koren et al. (1999) 13% of snow melt stays in the snow pack rsmfrac=min(0.18,(max(0.08,snwepr/0.10*0.13))) - if(snhei > 0.01) then + if(snhei > 0.01 .and. rhosn < 350.) then rsm=min(snwe,rsmfrac*smelt*delt) else -! do not keep melted water if snow depth is less that 1 cm + ! do not keep melted water if snow depth is less that 1 cm + ! or if snow is dense rsm=0. endif !18apr08 rsm is part of melted water that stays in snow as liquid - SMELT=max(0.,SMELT-rsm/delt) - IF (debug_print ) THEN - print *,'5- SMELT i,j,smelt,rsm,snwepr,rsmfrac', & + if(rsm > 0.) then + SMELT=max(0.,SMELT-rsm/delt) + IF (debug_print ) THEN + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'5- SMELT i,j,smelt,rsm,snwepr,rsmfrac', & i,j,smelt,rsm,snwepr,rsmfrac - ENDIF + print *,' xlat, xlon', xlat, xlon + ENDIF + endif ! rsm + + ENDIF ! smelt > 0 !-- update of liquid equivalent of snow depth !-- due to evaporation and snow melt - SNWE = AMAX1(0.,(SNWEPR- & - (SMELT+BETA*EPOT*RAS)*DELT & -! (SMELT+BETA*EPOT*RAS)*DELT*snowfrac & -! (SMELT+BETA*EPOT*RAS*UMVEG)*DELT & + if(snwe > 0.) then + SNWE = AMAX1(0.,(SNWEPR- & + (SMELT+BETA*EPOT*RAS)*DELT & ) ) -!--- If there is no snow melting then just evaporation -!--- or condensation cxhanges SNWE + IF (debug_print ) THEN + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,' Snow is melting and sublimating, snwe', xlat, xlon, SNWE + endif + else + !-- all snow is sublimated or melted + IF (debug_print ) THEN + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,' all snwe is sublimated or melted', xlat, xlon, SNWE + endif + endif ELSE - if(snhei.ne.0.) then + !-- NO MELTING, only sublimation + !--- If there is no snow melting then just evaporation + !--- or condensation changes SNWE + if(snhei.ne.0..and. beta == 1.) then EPOT=-QKMS*(QVATM-QSG) SNWE = AMAX1(0.,(SNWEPR- & BETA*EPOT*RAS*DELT)) -! BETA*EPOT*RAS*DELT*snowfrac)) + else + !-- all snow is sublibated + snwe = 0. endif ENDIF + !18apr08 - if snow melt occurred then go into iteration for energy budget ! solution if(nmelt.eq.1) goto 212 ! second interation @@ -5596,7 +5989,57 @@ SUBROUTINE SNOWTEMP( debug_print, & ! rhosn=MIN(MAX(76.9,XSN),500.) RHOCSN=2090.* RHOSN - thdifsn = 0.265/RHOCSN + if(isncond_opt == 1) then + !if(newsnow<= 0. .and. snhei > 5.0*SNHEI_crit) then + if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then + !-- some areas with large snow depth have unrealistically + !-- low snow density (in the Rockie's with snow depth > 1 m). + !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. + !-- In future a better compaction scheme is needed for these areas. + thdifsn = 2.5e-6 + else + !-- old version thdifsn = 0.265/RHOCSN + THDIFSN = 0.265/RHOCSN + endif + else + !-- 07Jun19 - thermal conductivity (K_eff) from Sturm et al.(1997) + !-- keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652) + fact = 1. + if(rhosn < 156. .or. (newsnow > 0. .and. rhonewsn < 156.)) then + keff = 0.023 + 0.234 * rhosn * 1.e-3 + !-- fact is added by tgs based on 4 Jan 2017 testing + fact = 5. + else + keff = 0.138 - 1.01 * rhosn*1.e-3 + 3.233 * rhosn**2 * 1.e-6 + fact = 2. + if(debug_print) then + print *,'End SNOWTEMP - xlat,xlon,rhosn,keff',xlat,xlon,rhosn,keff + print *,'End SNOWTEMP - 0.265/rhocsn',0.265/rhocsn + endif + endif + if (debug_print .and. abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2) then + print *,'END SNOWTEMP - newsnow, rhonewsn,rhosn,fact,keff', & + xlat,xlon,newsnow, rhonewsn,rhosn,fact,keff,keff/rhocsn*fact + endif + + !fact = 1. + + ! if(newsnow <= 0. .and. snhei > 5.0*SNHEI_crit) then + if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then + !-- some areas with large snow depth have unrealistically + !-- low snow density (in the Rockie's with snow depth > 1 m). + !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. + !-- In future a better compaction scheme is needed for these areas. + thdifsn = 2.5e-6 + else + thdifsn = keff/rhocsn * fact + endif + + endif + if (debug_print .and. abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2) then + print *,'END SNOWTEMP - thdifsn',xlat,xlon,thdifsn + print *,'END SNOWTEMP - 0.265/rhocsn',0.265/rhocsn + endif endif endif @@ -5616,33 +6059,48 @@ SUBROUTINE SNOWTEMP( debug_print, & S=D9*(tso(1)-tso(2)) ENDIF + !-- Update snow depth after melting at the interface with the atmosphere SNHEI=SNWE *1.E3 / RHOSN + !-- If ground surface temperature -!-- is above freezing snow can melt from the bottom. The following +!-- is above freezing snow can melt from the bottom at the interface with soild. The following !-- piece of code will check if bottom melting is possible. + IF (debug_print ) THEN + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'snhei,snwe,rhosn,snowfr',snhei,snwe,rhosn,snowfrac,xlat,xlon + endif + IF(TSO(1).GT.273.15 .and. snhei > 0.) THEN +!-- melting at the soil/snow interface if (snhei.GT.deltsn+snth) then hsn = snhei - deltsn - IF (debug_print ) THEN - print*,'2 layer snow - snhei,hsn',snhei,hsn - ENDIF + IF (debug_print ) THEN + print*,'2 layer snow - snhei,hsn',snhei,hsn + ENDIF else - IF (debug_print ) THEN - print*,'1 layer snow or blended - snhei',snhei - ENDIF + IF (debug_print ) THEN + print*,'1 layer snow or blended - snhei',snhei + ENDIF hsn = snhei endif soiltfrac=snowfrac*273.15+(1.-snowfrac)*TSO(1) - SNOHG=(TSO(1)-soiltfrac)*(cap(1)*zshalf(2)+ & + SNOHG=(TSO(1)-soiltfrac)*(cap(1)*zshalf(2)+ & RHOCSN*0.5*hsn) / DELT - SNOHG=AMAX1(0.,SNOHG) - SNODIF=0. - SMELTG=SNOHG/XLMELT*1.E-3 + SNOHG=AMAX1(0.,SNOHG) + SNODIF=0. + SMELTG=SNOHG/XLMELT*1.E-3 + IF (debug_print ) THEN + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,' SMELTG =',smeltg,xlat,xlon + endif ! Egglston - empirical limit on snow melt from the bottom of snow pack - SMELTG=AMIN1(SMELTG, 5.8e-9) + !9jun22-- the next line excludeis cases of summer hail from snowmelt limiting + if( (rhosn < 350. .or. (newsnow > 0. .and. rhonewsn < 450.)) .and. soilt < 283. ) then + SMELT=AMIN1(SMELTG, 5.8e-9) + endif ! rr - potential melting rr=SNWE/delt @@ -5651,41 +6109,42 @@ SUBROUTINE SNOWTEMP( debug_print, & SNOHGNEW=SMELTG*XLMELT*1.e3 SNODIF=AMAX1(0.,(SNOHG-SNOHGNEW)) IF (debug_print ) THEN -! if(i.eq.266.and.j.eq.447) then - print *,'TSO(1),soiltfrac,smeltg,SNODIF',TSO(1),soiltfrac,smeltg,SNODIF + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'TSO(1),soiltfrac,snowfrac,smeltg,SNODIF',TSO(1),soiltfrac,snowfrac,smeltg,SNODIF + print *,' xlat, xlon', xlat, xlon ENDIF -! snwe=max(0.,snwe-smeltg*delt*snowfrac) snwe=max(0.,snwe-smeltg*delt) SNHEI=SNWE *1.E3 / RHOSN + !-- add up all snow melt + SMELT = SMELT + SMELTG if(snhei > 0.) TSO(1) = soiltfrac + IF (debug_print ) THEN -! if(i.eq.266.and.j.eq.447) then + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then print *,'Melt from the bottom snwe,snhei',snwe,snhei + print *,' xlat, xlon', xlat, xlon + print *,'TSO(1),soiltfrac,snowfrac,smeltg,SNODIF',TSO(1),soiltfrac,snowfrac,smeltg,SNODIF + print *,'Melt from the bottom snwe,snhei,snoh',snwe,snhei,snoh + print *,' Final TSO ',tso if (snhei==0.) & print *,'Snow is all melted on the warm ground' ENDIF - ENDIF - IF (debug_print ) THEN - print *,'SNHEI,SNOH',i,j,SNHEI,SNOH - ENDIF -! & + ENDIF ! melt on snow/soil interface + snweprint=snwe snheiprint=snweprint*1.E3 / RHOSN - IF (debug_print ) THEN -print *, 'snweprint : ',snweprint -print *, 'D9SN,SOILT,TSOB : ', D9SN,SOILT,TSOB - ENDIF - - X= (R21+D9SN*R22SN)*(soilt-TN) + & + X= (R21+D9SN*R22SN)*(soilt-TN) + & XLVM*R210*(QSG-QGOLD) IF (debug_print ) THEN - print *,'SNOWTEMP storage ',i,j,x + !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then + print *,'end SNOWTEMP storage ',xlat,xlon,x print *,'R21,D9sn,r22sn,soiltfrac,soilt,tn,qsg,qgold,snprim', & R21,D9sn,r22sn,soiltfrac,soilt,tn,qsg,qgold,snprim + print *,'snwe, snhei ',snwe,snhei ENDIF X=X & @@ -5700,14 +6159,14 @@ SUBROUTINE SNOWTEMP( debug_print, & IF(SNHEI.GT.0.) THEN if(ilnb.gt.1) then - tsnav=0.5/snhei*((soilt+soilt1)*deltsn & - +(soilt1+tso(1))*(SNHEI-DELTSN)) & - -273.15 + tsnav=min(0.,0.5/snhei*((soilt+soilt1)*deltsn & + +(soilt1+tso(1))*(SNHEI-DELTSN)) & + -273.15) else - tsnav=0.5*(soilt+tso(1)) - 273.15 + tsnav=min(0.,0.5*(soilt+tso(1)) - 273.15) endif ELSE - tsnav= soilt - 273.15 + tsnav= min(0.,soilt - 273.15) ENDIF !------------------------------------------------------------------------ @@ -5913,7 +6372,7 @@ SUBROUTINE SOILMOIST ( debug_print, & ! TOTLIQ=UMVEG*PRCP-DRIP/DELT-UMVEG*DEW*RAS-SMELT - TOTLIQ=PRCP-DRIP/DELT-UMVEG*DEW*RAS-SMELT + TOTLIQ=PRCP-DRIP/DELT-(1.-VEGFRAC)*DEW*RAS-SMELT IF (debug_print ) THEN print *,'UMVEG*PRCP,DRIP/DELT,UMVEG*DEW*RAS,SMELT', & UMVEG*PRCP,DRIP/DELT,UMVEG*DEW*RAS,SMELT @@ -6506,13 +6965,13 @@ END SUBROUTINE TRANSF !> This subroutine finds the solution of energy budget at the surface !! from the pre-computed table of saturated water vapor mixing ratio !! and estimated surface temperature. - SUBROUTINE VILKA(TN,D1,D2,PP,QS,TS,TT,NSTEP,ii,j,iland,isoil) + SUBROUTINE VILKA(TN,D1,D2,PP,QS,TS,TT,NSTEP,ii,j,iland,isoil,xlat,xlon) !-------------------------------------------------------------- !--- VILKA finds the solution of energy budget at the surface !--- using table T,QS computed from Clausius-Klapeiron !-------------------------------------------------------------- REAL, DIMENSION(1:5001), INTENT(IN ) :: TT - REAL, INTENT(IN ) :: TN,D1,D2,PP + REAL, INTENT(IN ) :: TN,D1,D2,PP,xlat,xlon INTEGER, INTENT(IN ) :: NSTEP,ii,j,iland,isoil REAL, INTENT(OUT ) :: QS, TS @@ -6535,12 +6994,12 @@ SUBROUTINE VILKA(TN,D1,D2,PP,QS,TS,TT,NSTEP,ii,j,iland,isoil) IF(I1.NE.I) GOTO 10 TS=T1-.05*RN QS=(TT(I)+(TT(I)-TT(I+1))*RN)/PP -! print *,'in VILKA - TS,QS',ts,qs GOTO 20 ! 1 PRINT *,'Crash in surface energy budget - STOP' 1 PRINT *,' AVOST IN VILKA Table index= ',I ! PRINT *,TN,D1,D2,PP,NSTEP,I,TT(i),ii,j,iland,isoil print *,'I,J=',ii,j,'LU_index = ',iland, 'Psfc[hPa] = ',pp, 'Tsfc = ',tn + print *,'AVOST point at xlat/xlon=',xlat,xlon ! CALL wrf_error_fatal (' Crash in surface energy budget ' ) 20 CONTINUE !----------------------------------------------------------------------- @@ -6551,12 +7010,12 @@ END SUBROUTINE VILKA !! This subroutine computes effective land and soil parameters in the !! grid cell from the weighted contribution of soil and land categories !! represented in the grid cell. - SUBROUTINE SOILVEGIN ( debug_print, & - soilfrac,nscat,shdmin, shdmax, & - mosaic_lu, mosaic_soil, & - NLCAT,IVGTYP,ISLTYP,iswater,MYJ, & - IFOREST,lufrac,vegfrac,EMISS,PC,ZNT,LAI,RDLAI2D,& - QWRTZ,RHOCS,BCLH,DQM,KSAT,PSIS,QMIN,REF,WILT,I,J,& + SUBROUTINE SOILVEGIN ( debug_print, & + soilfrac,nscat,shdmin, shdmax, & + NLCAT,IVGTYP,ISLTYP,iswater,MYJ, & + IFOREST,lufrac,vegfrac,EMISS,PC, & + MSNF,FACSNF,ZNT,LAI,RDLAI2D, & + QWRTZ,RHOCS,BCLH,DQM,KSAT,PSIS,QMIN,REF,WILT,I,J, & errmsg, errflg) !************************************************************************ @@ -6790,7 +7249,6 @@ SUBROUTINE SOILVEGIN ( debug_print, & INTEGER :: & IVGTYP, & ISLTYP - INTEGER, INTENT(IN ) :: mosaic_lu, mosaic_soil LOGICAL, INTENT(IN ) :: myj REAL, INTENT(IN ) :: SHDMAX @@ -6800,7 +7258,9 @@ SUBROUTINE SOILVEGIN ( debug_print, & REAL, DIMENSION( 1:NSCAT ), INTENT(IN):: SOILFRAC REAL , & - INTENT ( OUT) :: pc + INTENT ( OUT) :: pc, & + msnf, & + facsnf REAL , & INTENT (INOUT ) :: emiss, & @@ -6898,6 +7358,8 @@ SUBROUTINE SOILVEGIN ( debug_print, & ZNT = 0. ZNT1 = 0. PC = 0. + MSNF = 0. + FACSNF= 0. if(.not.rdlai2d) LAI = 0. AREA = 0. !-- mosaic approach to landuse in the grid box @@ -6914,6 +7376,8 @@ SUBROUTINE SOILVEGIN ( debug_print, & ZNT1 = ZNT1 + lufrac(k)*ZNTtoday(K) if(.not.rdlai2d) LAI = LAI + LAItoday(K)*lufrac(k) PC = PC + PCTBL(K)*lufrac(k) + MSNF = MSNF + MFSNO(K)*lufrac(k) + FACSNF= FACSNF + SNCOVFAC(K)*lufrac(k) enddo if (area.gt.1.) area=1. @@ -6933,6 +7397,8 @@ SUBROUTINE SOILVEGIN ( debug_print, & ZNT = LB/EXP(SQRT(1./ZNT)) if(.not.rdlai2d) LAI = LAI/AREA PC = PC /AREA + MSNF = MSNF /AREA + FACSNF= FACSNF /AREA IF (debug_print ) THEN print *,'mosaic=',j,ivgtyp,nlcat,(lufrac(k),k=1,nlcat),EMISS,ZNT,ZNT1,LAI,PC @@ -6943,17 +7409,19 @@ SUBROUTINE SOILVEGIN ( debug_print, & EMISS = LEMITBL(IVGTYP) ZNT = ZNTtoday(IVGTYP) PC = PCTBL(IVGTYP) + MSNF = MFSNO(IVGTYP) + FACSNF= SNCOVFAC(IVGTYP) if(.not.rdlai2d) LAI = LAItoday(IVGTYP) endif ! parameters from SOILPARM.TBL RHOCS = 0. BCLH = 0. - DQM = 1. + DQM = 0. KSAT = 0. PSIS = 0. QMIN = 0. - REF = 1. + REF = 0. WILT = 0. QWRTZ = 0. AREA = 0. @@ -7301,6 +7769,8 @@ SUBROUTINE RUCLSM_SOILVEGPARM( debug_print,MMINLURUC, MMINSL) READ (19,*) READ (19,*)BARE READ (19,*) + READ (19,*)GLACIER + READ (19,*) READ (19,*)NATURAL READ (19,*) READ (19,*)CROP diff --git a/physics/namelist_soilveg_ruc.F90 b/physics/namelist_soilveg_ruc.F90 index 1e05122c4..2270d35eb 100644 --- a/physics/namelist_soilveg_ruc.F90 +++ b/physics/namelist_soilveg_ruc.F90 @@ -26,12 +26,15 @@ module namelist_soilveg_ruc REAL SNUPTBL(MAX_VEGTYP) REAL LAITBL(MAX_VEGTYP) REAL MAXALB(MAX_VEGTYP) + REAL MFSNO(MAX_VEGTYP) + REAL SNCOVFAC(MAX_VEGTYP) LOGICAL LPARAM REAL TOPT_DATA REAL CMCMAX_DATA REAL CFACTR_DATA REAL RSMAX_DATA INTEGER BARE + INTEGER GLACIER INTEGER NATURAL INTEGER CROP INTEGER URBAN diff --git a/physics/set_soilveg_ruc.F90 b/physics/set_soilveg_ruc.F90 index c03e6fc5f..77e4f9ac5 100644 --- a/physics/set_soilveg_ruc.F90 +++ b/physics/set_soilveg_ruc.F90 @@ -30,8 +30,9 @@ subroutine set_soilveg_ruc(me,isot,ivet,nlunit,errmsg,errflg) NAMELIST /SOIL_VEG_RUC/ SLOPE_DATA, ALBTBL, Z0TBL, LEMITBL, & & PCTBL, SHDTBL, & & IFORTBL, RSTBL, RGLTBL, HSTBL, SNUPTBL, LAITBL, MAXALB, & + & MFSNO, SNCOVFAC, & & LPARAM, TOPT_DATA, CMCMAX_DATA, CFACTR_DATA, & - & RSMAX_DATA, BARE, NATURAL, CROP, URBAN, & + & RSMAX_DATA, BARE, GLACIER, NATURAL, CROP, URBAN, & & DEFINED_VEG, DEFINED_SOIL, DEFINED_SLOPE, & & BB, DRYSMC, HC, MAXSMC, REFSMC, SATPSI, SATDK, SATDW, & & WLTSMC, QTZ, mosaic_soil, mosaic_lu, & @@ -200,15 +201,41 @@ subroutine set_soilveg_ruc(me,isot,ivet,nlunit,errmsg,errflg) & 70., 55., 60., 75., 70., 0., 0., 0., & & 0., 0., 0., 0., 0., 0./) + mfsno = & !< modified for RRFS Noah_MP snowmelt curve parameter () + & (/ 1.00, 1.00, 1.00, 1.00, 2.00, 2.00, & + & 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, & + & 3.00, 3.00, 2.00, 2.00, 2.00, 2.00, & + & 2.00, 2.00, 0.00, 0.00, 0.00, 0.00, & +! & 3.00, 3.00, 2.00, 3.00, 3.00, 3.00, & +! & 3.00, 3.00, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 /) + +!-- Noah MP snowmelt curve values +! & (/ 1.00, 1.00, 1.00, 1.00, 1.00, 2.00, & +! & 2.00, 2.00, 2.00, 2.00, 3.00, 3.00, & +! & 4.00, 4.00, 2.50, 3.00, 3.00, 3.50, & +! & 3.50, 3.50, 0.00, 0.00, 0.00, 0.00, & +! & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 /) + + sncovfac = & !< Noah_MP snow cover factor (m), first 5 categories are modified for RRFS + & (/ 0.030, 0.030, 0.030, 0.030, 0.030, & + !& (/ 0.008, 0.008, 0.008, 0.008, 0.008, & + & 0.016, 0.016, 0.020, 0.020, 0.020, & + & 0.020, 0.014, 0.042, 0.026, 0.030, & + & 0.016, 0.030, 0.030, 0.030, 0.030, & + & 0.000, 0.000, 0.000, 0.000, 0.000, & + & 0.000, 0.000, 0.000, 0.000, 0.000 /) + natural = 10 - bare = 16 crop = 12 urban = 13 + glacier = 15 + bare = 16 endif ! end if veg table ! - set mosaic_lu=1 when info for fractional landuse is available - mosaic_lu = 0 + mosaic_lu = 1 topt_data =298.0 cmcmax_data =0.2e-3 @@ -338,12 +365,14 @@ subroutine set_soilveg_ruc(me,isot,ivet,nlunit,errmsg,errflg) & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/) REFSMC =(/0.174, 0.179, 0.249, 0.369, 0.369, 0.314, & + !-- test to reduce moist bias + !REFSMC =(/0.220, 0.205, 0.312, 0.375, 0.369, 0.339, & & 0.299, 0.357, 0.391, 0.316, 0.409, 0.400, & & 0.314, 1.000, 0.100, 0.249, 0.454, 0.170, & & 0.236, 0.000, 0.000, 0.000, 0.000, 0.000, & & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/) - SATPSI =(/0.121, 0.090, 0.218, 0.786, 0.786, 0.478, & + SATPSI =(/0.121, 0.150, 0.218, 0.786, 0.786, 0.478, & & 0.299, 0.356, 0.630, 0.153, 0.490, 0.405, & & 0.478, 0.000, 0.121, 0.218, 0.468, 0.069, & & 0.069, 0.00, 0.00, 0.00, 0.00, 0.00, & @@ -413,7 +442,7 @@ subroutine set_soilveg_ruc(me,isot,ivet,nlunit,errmsg,errflg) END DO ! - set mosaic_soil=1 when info for fractional landuse is available - mosaic_soil = 0 + mosaic_soil = 1 ! PT 5/18/2015 - changed to FALSE to match atm_namelist setting ! PT LPARAM is not used anywhere From d9d6465d03c556986d0530919f1a6369dadcfbda Mon Sep 17 00:00:00 2001 From: drnimbusrain Date: Wed, 8 Mar 2023 21:50:36 +0000 Subject: [PATCH 143/380] Fixed bug in syntax --- physics/satmedmfvdifq.F | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index ae5e33882..3f10ffd41 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -310,9 +310,9 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & !PCC_CANOPY------------------------------------ if (do_canopy) then if(.not.allocated(EDDYVESTX)) - & allocate( EDDYVESTX ( MAXCAN ) ) + & allocate( EDDYVESTX ( MAXCAN ) ) if(.not.allocated(ZCANX)) - & allocate( ZCANX ( MAXCAN ) ) + & allocate( ZCANX ( MAXCAN ) ) endif !---------------------------------------------- From b6c327bd8748463c97a50c2d8407bbfad98409c5 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Wed, 8 Mar 2023 21:51:55 +0000 Subject: [PATCH 144/380] Update parameters for RUC LSM. --- physics/set_soilveg_ruc.F90 | 35 +++-------------------------------- 1 file changed, 3 insertions(+), 32 deletions(-) diff --git a/physics/set_soilveg_ruc.F90 b/physics/set_soilveg_ruc.F90 index 77e4f9ac5..f29726645 100644 --- a/physics/set_soilveg_ruc.F90 +++ b/physics/set_soilveg_ruc.F90 @@ -30,9 +30,8 @@ subroutine set_soilveg_ruc(me,isot,ivet,nlunit,errmsg,errflg) NAMELIST /SOIL_VEG_RUC/ SLOPE_DATA, ALBTBL, Z0TBL, LEMITBL, & & PCTBL, SHDTBL, & & IFORTBL, RSTBL, RGLTBL, HSTBL, SNUPTBL, LAITBL, MAXALB, & - & MFSNO, SNCOVFAC, & & LPARAM, TOPT_DATA, CMCMAX_DATA, CFACTR_DATA, & - & RSMAX_DATA, BARE, GLACIER, NATURAL, CROP, URBAN, & + & RSMAX_DATA, BARE, NATURAL, CROP, URBAN, & & DEFINED_VEG, DEFINED_SOIL, DEFINED_SLOPE, & & BB, DRYSMC, HC, MAXSMC, REFSMC, SATPSI, SATDK, SATDW, & & WLTSMC, QTZ, mosaic_soil, mosaic_lu, & @@ -201,36 +200,10 @@ subroutine set_soilveg_ruc(me,isot,ivet,nlunit,errmsg,errflg) & 70., 55., 60., 75., 70., 0., 0., 0., & & 0., 0., 0., 0., 0., 0./) - mfsno = & !< modified for RRFS Noah_MP snowmelt curve parameter () - & (/ 1.00, 1.00, 1.00, 1.00, 2.00, 2.00, & - & 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, & - & 3.00, 3.00, 2.00, 2.00, 2.00, 2.00, & - & 2.00, 2.00, 0.00, 0.00, 0.00, 0.00, & -! & 3.00, 3.00, 2.00, 3.00, 3.00, 3.00, & -! & 3.00, 3.00, 0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 /) - -!-- Noah MP snowmelt curve values -! & (/ 1.00, 1.00, 1.00, 1.00, 1.00, 2.00, & -! & 2.00, 2.00, 2.00, 2.00, 3.00, 3.00, & -! & 4.00, 4.00, 2.50, 3.00, 3.00, 3.50, & -! & 3.50, 3.50, 0.00, 0.00, 0.00, 0.00, & -! & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 /) - - sncovfac = & !< Noah_MP snow cover factor (m), first 5 categories are modified for RRFS - & (/ 0.030, 0.030, 0.030, 0.030, 0.030, & - !& (/ 0.008, 0.008, 0.008, 0.008, 0.008, & - & 0.016, 0.016, 0.020, 0.020, 0.020, & - & 0.020, 0.014, 0.042, 0.026, 0.030, & - & 0.016, 0.030, 0.030, 0.030, 0.030, & - & 0.000, 0.000, 0.000, 0.000, 0.000, & - & 0.000, 0.000, 0.000, 0.000, 0.000 /) - natural = 10 + bare = 16 crop = 12 urban = 13 - glacier = 15 - bare = 16 endif ! end if veg table @@ -365,14 +338,12 @@ subroutine set_soilveg_ruc(me,isot,ivet,nlunit,errmsg,errflg) & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/) REFSMC =(/0.174, 0.179, 0.249, 0.369, 0.369, 0.314, & - !-- test to reduce moist bias - !REFSMC =(/0.220, 0.205, 0.312, 0.375, 0.369, 0.339, & & 0.299, 0.357, 0.391, 0.316, 0.409, 0.400, & & 0.314, 1.000, 0.100, 0.249, 0.454, 0.170, & & 0.236, 0.000, 0.000, 0.000, 0.000, 0.000, & & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/) - SATPSI =(/0.121, 0.150, 0.218, 0.786, 0.786, 0.478, & + SATPSI =(/0.121, 0.090, 0.218, 0.786, 0.786, 0.478, & & 0.299, 0.356, 0.630, 0.153, 0.490, 0.405, & & 0.478, 0.000, 0.121, 0.218, 0.468, 0.069, & & 0.069, 0.00, 0.00, 0.00, 0.00, 0.00, & From 52f820a3de64e55560db7b298beb6f8f1619962c Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 9 Mar 2023 00:59:11 +0000 Subject: [PATCH 145/380] clm lake: loops use ints & return if there is nothing to do --- physics/clm_lake.f90 | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90 index 75c7eab13..b5a39b557 100644 --- a/physics/clm_lake.f90 +++ b/physics/clm_lake.f90 @@ -236,7 +236,7 @@ SUBROUTINE clm_lake_run( & ! Configuration and initialization: iopt_lake, iopt_lake_clm, min_lakeice, lakedepth_default, use_lakedepth, & - dtp, use_lake_model, clm_lake_initialized, frac_grid, frac_ice, & + dtp, use_lake_model, clm_lake_initialized, frac_grid, frac_ice, lkm, & ! Atmospheric model state inputs: tg3, pgr, zlvl, gt0, prsi, phii, qvcurr, gu0, gv0, xlat_d, xlon_d, & @@ -276,6 +276,7 @@ SUBROUTINE clm_lake_run( & INTEGER , INTENT (IN) :: im,km,me,master INTEGER, INTENT(IN) :: IDATE(4), kdt REAL(KIND_PHYS), INTENT(IN) :: fhour + INTEGER, INTENT(IN) :: lkm ! ! Configuration and initialization: @@ -470,6 +471,11 @@ SUBROUTINE clm_lake_run( & errmsg = ' ' errflg = 0 + + if(iopt_lake/=iopt_lake_clm .or. lkm==0) then + return ! nothing to do + endif + dtime=dtp if(LAKEDEBUG) then @@ -5741,7 +5747,7 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, endif end if - do k = 0, snl2d(i)+1, -1 + do k = 0, nint(snl2d(i)+1), -1 z3d(i,k) = zi3d(i,k) - 0.5_kind_lake*dz3d(i,k) zi3d(i,k-1) = zi3d(i,k) - dz3d(i,k) end do @@ -5775,7 +5781,7 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, enddo if (snl2d(i) < 0) then - do k = snl2d(i)+1, 0 + do k = nint(snl2d(i)+1), 0 ! Be careful because there may be new snow layers with bad temperatures like 0 even if ! coming from init. con. file. if(t_soisno3d(i,k) > 300 .or. t_soisno3d(i,k) < 200) t_soisno3d(i,k) = min(tfrz,tsfc(i)) From a97690a2563a96576a4cb9adfb44f1ef89fc1d8f Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 9 Mar 2023 00:59:32 +0000 Subject: [PATCH 146/380] clm lake meta: need lkm --- physics/clm_lake.meta | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/physics/clm_lake.meta b/physics/clm_lake.meta index 4149fd8ef..035787aff 100644 --- a/physics/clm_lake.meta +++ b/physics/clm_lake.meta @@ -131,6 +131,13 @@ dimensions = () type = logical intent = in +[lkm] + standard_name = control_for_lake_model_execution_method + long_name = control for lake model execution: 0=no lake, 1=lake, 2=lake+nsst + units = flag + dimensions = () + type = integer + intent = in [tg3] standard_name = deep_soil_temperature long_name = deep soil temperature From 0e20bda6e517cf39ea29efbe0c70b1eaae291152 Mon Sep 17 00:00:00 2001 From: joeolson42 Date: Thu, 9 Mar 2023 19:33:09 +0000 Subject: [PATCH 147/380] fixes for Grants comments and suggestions --- physics/module_bl_mynn.F90 | 12 ++++-- physics/mynnedmf_wrapper.F90 | 70 +++++++++++++++++------------------ physics/mynnedmf_wrapper.meta | 15 ++------ physics/sgscloud_radpre.F90 | 3 -- 4 files changed, 47 insertions(+), 53 deletions(-) diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index dab09871c..51a906faf 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -486,7 +486,7 @@ SUBROUTINE mynn_bl_driver( & real(kind_phys), DIMENSION(:,:), INTENT(inout) :: el_pbl - real(kind_phys), DIMENSION(:,:), INTENT(out) :: & + real(kind_phys), DIMENSION(:,:), INTENT(inout) :: & &qWT,qSHEAR,qBUOY,qDISS,dqke ! 3D budget arrays are not allocated when tke_budget == 0 ! 1D (local) budget arrays are used for passing between subroutines. @@ -736,7 +736,7 @@ SUBROUTINE mynn_bl_driver( & rho1(k)=rho(i,k) sqc(k)=sqc3D(i,k) !/(1.+qv(i,k)) sqv(k)=sqv3D(i,k) !/(1.+qv(i,k)) - thetav(k)=th(i,k)*(1.+0.608*sqv(k)) + thetav(k)=th(i,k)*(1.+p608*sqv(k)) !keep snow out for now - increases ceiling bias sqw(k)=sqv(k)+sqc(k)+sqi(k)!+sqs(k) thl(k)=th1(k) - xlvcp/ex1(k)*sqc(k) & @@ -995,7 +995,7 @@ SUBROUTINE mynn_bl_driver( & !suggested min temperature to improve accuracy. !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) & ! & - xlscp/MAX(tk1(k),TKmin)*sqi(k)) - thetav(k)=th1(k)*(1.+0.608*sqv(k)) + thetav(k)=th1(k)*(1.+p608*sqv(k)) enddo ! end k zw(kte+1)=zw(kte)+dz(i,kte) @@ -3867,7 +3867,11 @@ SUBROUTINE mym_condensation (kts,kte, & ! JAYMES- this option added 8 May 2015 ! The cloud water formulations are taken from CB02, Eq. 8. IF (q1k < 0.) THEN !unsaturated +#ifdef SINGLE_PREC + ql_water = sgm(k)*EXP(1.2*q1k-1.) +#else ql_water = sgm(k)*EXP(1.2*q1k-1.) +#endif ql_ice = sgm(k)*EXP(1.2*q1k-1.) ELSE IF (q1k > 2.) THEN !supersaturated ql_water = sgm(k)*q1k @@ -6861,7 +6865,7 @@ subroutine condensation_edmf(QT,THL,P,zagl,THV,QC) !THIS BASICALLY GIVE THE SAME RESULT AS THE PREVIOUS LINE !TH = THL + xlv/cp/EXN*QC - !THV= TH*(1. + 0.608*QT) + !THV= TH*(1. + p608*QT) !print *,'t,p,qt,qs,qc' !print *,t,p,qt,qs,qc diff --git a/physics/mynnedmf_wrapper.F90 b/physics/mynnedmf_wrapper.F90 index 9aa9e8c5a..d2ca9f3cc 100644 --- a/physics/mynnedmf_wrapper.F90 +++ b/physics/mynnedmf_wrapper.F90 @@ -17,16 +17,15 @@ subroutine mynnedmf_wrapper_init ( & & con_cpv, con_cliq, con_cice, con_rcp, & & con_XLV, con_XLF, con_p608, con_ep2, & & con_karman, con_t0c, & - & do_mynnedmf, lheatstrg, & + & do_mynnedmf, & & errmsg, errflg ) use machine, only : kind_phys use bl_mynn_common implicit none - + logical, intent(in) :: do_mynnedmf - logical, intent(in) :: lheatstrg character(len=*),intent(out):: errmsg integer, intent(out) :: errflg @@ -98,8 +97,8 @@ SUBROUTINE mynnedmf_wrapper_run( & & phii,u,v,omega,t3d, & & qgrs_water_vapor, & & qgrs_liquid_cloud, & - & qgrs_ice_cloud, & - & qgrs_snow_cloud, & + & qgrs_ice, & + & qgrs_snow, & & qgrs_cloud_droplet_num_conc, & & qgrs_cloud_ice_num_conc, & & qgrs_ozone, & @@ -135,7 +134,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & nupdraft,maxMF,ktop_plume, & & dudt, dvdt, dtdt, & & dqdt_water_vapor, dqdt_liquid_cloud, & ! <=== ntqv, ntcw - & dqdt_ice_cloud, dqdt_snow_cloud, & ! <=== ntiw, ntsw + & dqdt_ice, dqdt_snow, & ! <=== ntiw, ntsw & dqdt_ozone, & ! <=== ntoz & dqdt_cloud_droplet_num_conc, dqdt_ice_num_conc, & ! <=== ntlnc, ntinc & dqdt_water_aer_num_conc, dqdt_ice_aer_num_conc,& ! <=== ntwa, ntia @@ -242,8 +241,8 @@ SUBROUTINE mynnedmf_wrapper_run( & real(kind_phys), dimension(:,:), intent(in) :: phii real(kind_phys), dimension(:,:), intent(inout) :: & & dtdt, dudt, dvdt, & - & dqdt_water_vapor, dqdt_liquid_cloud, dqdt_ice_cloud, & - & dqdt_snow_cloud, & + & dqdt_water_vapor, dqdt_liquid_cloud, dqdt_ice, & + & dqdt_snow, & & dqdt_cloud_droplet_num_conc, dqdt_ice_num_conc, & & dqdt_ozone, dqdt_water_aer_num_conc, dqdt_ice_aer_num_conc real(kind_phys), dimension(:,:), intent(inout) ::dqdt_cccn @@ -258,8 +257,8 @@ SUBROUTINE mynnedmf_wrapper_run( & real(kind_phys), dimension(:,:), intent(inout) :: & & dqke,qWT,qSHEAR,qBUOY,qDISS real(kind_phys), dimension(:,:), intent(inout) :: & - & t3d,qgrs_water_vapor,qgrs_liquid_cloud,qgrs_ice_cloud, & - & qgrs_snow_cloud + & t3d,qgrs_water_vapor,qgrs_liquid_cloud,qgrs_ice, & + & qgrs_snow real(kind_phys), dimension(:,:), intent(in) :: & & u,v,omega, & & exner,prsl,prsi, & @@ -377,7 +376,7 @@ SUBROUTINE mynnedmf_wrapper_run( & do i=1,im sqv(i,k) = qgrs_water_vapor(i,k) sqc(i,k) = qgrs_liquid_cloud(i,k) - sqi(i,k) = qgrs_ice_cloud(i,k) + sqi(i,k) = qgrs_ice(i,k) sqs(i,k) = 0. ozone(i,k) = qgrs_ozone(i,k) qnc(i,k) = 0. @@ -401,7 +400,7 @@ SUBROUTINE mynnedmf_wrapper_run( & do i=1,im sqv(i,k) = qgrs_water_vapor(i,k) sqc(i,k) = qgrs_liquid_cloud(i,k) - sqi(i,k) = qgrs_ice_cloud(i,k) + sqi(i,k) = qgrs_ice(i,k) sqs(i,k) = 0. ozone(i,k) = qgrs_ozone(i,k) qnc(i,k) = qgrs_cloud_droplet_num_conc(i,k) @@ -429,8 +428,8 @@ SUBROUTINE mynnedmf_wrapper_run( & do i=1,im sqv(i,k) = qgrs_water_vapor(i,k) sqc(i,k) = qgrs_liquid_cloud(i,k) - sqi(i,k) = qgrs_ice_cloud(i,k) - sqs(i,k) = qgrs_snow_cloud(i,k) + sqi(i,k) = qgrs_ice(i,k) + sqs(i,k) = qgrs_snow(i,k) qnc(i,k) = qgrs_cloud_droplet_num_conc(i,k) qni(i,k) = qgrs_cloud_ice_num_conc(i,k) ozone(i,k) = qgrs_ozone(i,k) @@ -452,8 +451,8 @@ SUBROUTINE mynnedmf_wrapper_run( & do i=1,im sqv(i,k) = qgrs_water_vapor(i,k) sqc(i,k) = qgrs_liquid_cloud(i,k) - sqi(i,k) = qgrs_ice_cloud(i,k) - sqs(i,k) = qgrs_snow_cloud(i,k) + sqi(i,k) = qgrs_ice(i,k) + sqs(i,k) = qgrs_snow(i,k) qnc(i,k) = qgrs_cloud_droplet_num_conc(i,k) qni(i,k) = qgrs_cloud_ice_num_conc(i,k) ozone(i,k) = qgrs_ozone(i,k) @@ -475,8 +474,8 @@ SUBROUTINE mynnedmf_wrapper_run( & do i=1,im sqv(i,k) = qgrs_water_vapor(i,k) sqc(i,k) = qgrs_liquid_cloud(i,k) - sqi(i,k) = qgrs_ice_cloud(i,k) - sqs(i,k) = qgrs_snow_cloud(i,k) + sqi(i,k) = qgrs_ice(i,k) + sqs(i,k) = qgrs_snow(i,k) qnc(i,k) = 0. qni(i,k) = qgrs_cloud_ice_num_conc(i,k) ozone(i,k) = qgrs_ozone(i,k) @@ -500,7 +499,7 @@ SUBROUTINE mynnedmf_wrapper_run( & do i=1,im sqv(i,k) = qgrs_water_vapor(i,k) sqc(i,k) = qgrs_liquid_cloud(i,k) - sqi(i,k) = qgrs_ice_cloud(i,k) + sqi(i,k) = qgrs_ice(i,k) qnc(i,k) = 0. qni(i,k) = 0. sqs(i,k) = 0. @@ -807,8 +806,8 @@ SUBROUTINE mynnedmf_wrapper_run( & do i=1,im dqdt_water_vapor(i,k) = RQVBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_liquid_cloud(i,k) = RQCBLTEN(i,k) !/(1.0 + qv(i,k)) - dqdt_ice_cloud(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) - dqdt_snow_cloud(i,k) = RQSBLTEN(i,k) !/(1.0 + qv(i,k)) + dqdt_ice(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) + dqdt_snow(i,k) = RQSBLTEN(i,k) !/(1.0 + qv(i,k)) !dqdt_ozone(i,k) = 0.0 enddo enddo @@ -822,7 +821,7 @@ SUBROUTINE mynnedmf_wrapper_run( & ! do i=1,im ! qgrs_water_vapor(i,k) = qgrs_water_vapor(i,k) + (RQVBLTEN(i,k)/(1.0+RQVBLTEN(i,k)))*delt ! qgrs_liquid_cloud(i,k) = qgrs_liquid_cloud(i,k) + RQCBLTEN(i,k)*delt - ! qgrs_ice_cloud(i,k) = qgrs_ice_cloud(i,k) + RQIBLTEN(i,k)*delt + ! qgrs_ice(i,k) = qgrs_ice(i,k) + RQIBLTEN(i,k)*delt ! !dqdt_ozone(i,k) = 0.0 ! enddo !enddo @@ -834,9 +833,9 @@ SUBROUTINE mynnedmf_wrapper_run( & dqdt_water_vapor(i,k) = RQVBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_liquid_cloud(i,k) = RQCBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_cloud_droplet_num_conc(i,k) = RQNCBLTEN(i,k) - dqdt_ice_cloud(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) + dqdt_ice(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_ice_num_conc(i,k) = RQNIBLTEN(i,k) - dqdt_snow_cloud(i,k) = RQSBLTEN(i,k) !/(1.0 + qv(i,k)) + dqdt_snow(i,k) = RQSBLTEN(i,k) !/(1.0 + qv(i,k)) !dqdt_ozone(i,k) = 0.0 dqdt_water_aer_num_conc(i,k) = RQNWFABLTEN(i,k) dqdt_ice_aer_num_conc(i,k) = RQNIFABLTEN(i,k) @@ -855,7 +854,7 @@ SUBROUTINE mynnedmf_wrapper_run( & ! do i=1,im ! qgrs_water_vapor(i,k) = qgrs_water_vapor(i,k) + (RQVBLTEN(i,k)/(1.0+RQVBLTEN(i,k)))*delt ! qgrs_liquid_cloud(i,k) = qgrs_liquid_cloud(i,k) + RQCBLTEN(i,k)*delt - ! qgrs_ice_cloud(i,k) = qgrs_ice_cloud(i,k) + RQIBLTEN(i,k)*delt + ! qgrs_ice(i,k) = qgrs_ice(i,k) + RQIBLTEN(i,k)*delt ! qgrs_cloud_droplet_num_conc(i,k) = qgrs_cloud_droplet_num_conc(i,k) + RQNCBLTEN(i,k)*delt ! qgrs_cloud_ice_num_conc(i,k) = qgrs_cloud_ice_num_conc(i,k) + RQNIBLTEN(i,k)*delt ! !dqdt_ozone(i,k) = 0.0 @@ -869,9 +868,9 @@ SUBROUTINE mynnedmf_wrapper_run( & dqdt_water_vapor(i,k) = RQVBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_liquid_cloud(i,k) = RQCBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_cloud_droplet_num_conc(i,k) = RQNCBLTEN(i,k) - dqdt_ice_cloud(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) + dqdt_ice(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_ice_num_conc(i,k) = RQNIBLTEN(i,k) - dqdt_snow_cloud(i,k) = RQSBLTEN(i,k) !/(1.0 + qv(i,k)) + dqdt_snow(i,k) = RQSBLTEN(i,k) !/(1.0 + qv(i,k)) enddo enddo if(ldiag3d .and. .not. flag_for_pbl_generic_tend) then @@ -887,8 +886,9 @@ SUBROUTINE mynnedmf_wrapper_run( & do i=1,im dqdt_water_vapor(i,k) = RQVBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_liquid_cloud(i,k) = RQCBLTEN(i,k) !/(1.0 + qv(i,k)) - dqdt_ice_cloud(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) + dqdt_ice(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_ice_num_conc(i,k) = RQNIBLTEN(i,k) + dqdt_snow(i,k) = RQSBLTEN(i,k) !/(1.0 + qv(i,k)) !dqdt_ozone(i,k) = 0.0 enddo enddo @@ -896,14 +896,14 @@ SUBROUTINE mynnedmf_wrapper_run( & call dtend_helper(100+ntqv,RQVBLTEN) call dtend_helper(100+ntcw,RQCBLTEN) call dtend_helper(100+ntiw,RQIBLTEN) - call dtend_helper(100+ntsw,RQSBLTEN) call dtend_helper(100+ntinc,RQNIBLTEN) + call dtend_helper(100+ntsw,RQSBLTEN) endif !do k=1,levs ! do i=1,im ! qgrs_water_vapor(i,k) = qgrs_water_vapor(i,k) + (RQVBLTEN(i,k)/(1.0+RQVBLTEN(i,k)))*delt ! qgrs_liquid_cloud(i,k) = qgrs_liquid_cloud(i,k) + RQCBLTEN(i,k)*delt - ! qgrs_ice_cloud(i,k) = qgrs_ice_cloud(i,k) + RQIBLTEN(i,k)*delt + ! qgrs_ice(i,k) = qgrs_ice(i,k) + RQIBLTEN(i,k)*delt ! qgrs_cloud_ice_num_conc(i,k) = qgrs_cloud_ice_num_conc(i,k) + RQNIBLTEN(i,k)*delt ! !dqdt_ozone(i,k) = 0.0 ! enddo @@ -916,9 +916,9 @@ SUBROUTINE mynnedmf_wrapper_run( & dqdt_water_vapor(i,k) = RQVBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_liquid_cloud(i,k) = RQCBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_cloud_droplet_num_conc(i,k) = RQNCBLTEN(i,k) - dqdt_ice_cloud(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) + dqdt_ice(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_ice_num_conc(i,k) = RQNIBLTEN(i,k) - dqdt_snow_cloud(i,k) = RQSBLTEN(i,k) !/(1.0 + qv(i,k)) + dqdt_snow(i,k) = RQSBLTEN(i,k) !/(1.0 + qv(i,k)) IF ( nssl_ccn_on ) THEN ! dqdt_cccn(i,k) = RQNWFABLTEN(i,k) ENDIF @@ -931,7 +931,7 @@ SUBROUTINE mynnedmf_wrapper_run( & do i=1,im dqdt_water_vapor(i,k) = RQVBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_liquid_cloud(i,k) = RQCBLTEN(i,k) !/(1.0 + qv(i,k)) - dqdt_ice_cloud(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) + dqdt_ice(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) !dqdt_rain(i,k) = 0.0 !dqdt_snow(i,k) = 0.0 !dqdt_graupel(i,k) = 0.0 @@ -947,7 +947,7 @@ SUBROUTINE mynnedmf_wrapper_run( & ! do i=1,im ! qgrs_water_vapor(i,k) = qgrs_water_vapor(i,k) + (RQVBLTEN(i,k)/(1.0+RQVBLTEN(i,k)))*delt ! qgrs_liquid_cloud(i,k) = qgrs_liquid_cloud(i,k) + RQCBLTEN(i,k)*delt - ! qgrs_ice_cloud(i,k) = qgrs_ice_cloud(i,k) + RQIBLTEN(i,k)*delt + ! qgrs_ice(i,k) = qgrs_ice(i,k) + RQIBLTEN(i,k)*delt ! !dqdt_ozone(i,k) = 0.0 ! enddo !enddo @@ -957,7 +957,7 @@ SUBROUTINE mynnedmf_wrapper_run( & do i=1,im dqdt_water_vapor(i,k) = RQVBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_liquid_cloud(i,k) = RQCBLTEN(i,k) !/(1.0 + qv(i,k)) - dqdt_ice_cloud(i,k) = 0.0 + dqdt_ice(i,k) = 0.0 !dqdt_rain(i,k) = 0.0 !dqdt_snow(i,k) = 0.0 !dqdt_graupel(i,k) = 0.0 diff --git a/physics/mynnedmf_wrapper.meta b/physics/mynnedmf_wrapper.meta index 1703699bb..1928f1c37 100644 --- a/physics/mynnedmf_wrapper.meta +++ b/physics/mynnedmf_wrapper.meta @@ -125,13 +125,6 @@ dimensions = () type = logical intent = in -[lheatstrg] - standard_name = flag_for_canopy_heat_storage_in_land_surface_scheme - long_name = flag for canopy heat storage parameterization - units = flag - dimensions = () - type = logical - intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -303,7 +296,7 @@ type = real kind = kind_phys intent = inout -[qgrs_ice_cloud] +[qgrs_ice] standard_name = cloud_ice_mixing_ratio long_name = ratio of mass of ice water to mass of dry air plus vapor (without condensates) units = kg kg-1 @@ -311,7 +304,7 @@ type = real kind = kind_phys intent = inout -[qgrs_snow_cloud] +[qgrs_snow] standard_name = snow_mixing_ratio long_name = ratio of mass of snow water to mass of dry air plus vapor (without condensates) units = kg kg-1 @@ -1033,7 +1026,7 @@ type = real kind = kind_phys intent = inout -[dqdt_ice_cloud] +[dqdt_ice] standard_name = process_split_cumulative_tendency_of_cloud_ice_mixing_ratio long_name = cloud condensed water mixing ratio tendency due to model physics units = kg kg-1 s-1 @@ -1041,7 +1034,7 @@ type = real kind = kind_phys intent = inout -[dqdt_snow_cloud] +[dqdt_snow] standard_name = process_split_cumulative_tendency_of_snow_mixing_ratio long_name = ratio of mass of snow water tendency to mass of dry air plus vapor (without condensates) due to model physics units = kg kg-1 s-1 diff --git a/physics/sgscloud_radpre.F90 b/physics/sgscloud_radpre.F90 index 87054128c..05ca1af2a 100644 --- a/physics/sgscloud_radpre.F90 +++ b/physics/sgscloud_radpre.F90 @@ -44,8 +44,6 @@ subroutine sgscloud_radpre_run( & qc, qi, qv, T3D, P3D, exner, & qr, qs, qg, & qci_conv,qlc,qli,ud_mf, & -! qci_conv_timeave, & -! ud_mf_timeave, & imfdeepcnv, imfdeepcnv_gf, & imfdeepcnv_sas, & qc_save, qi_save, qs_save, & @@ -84,7 +82,6 @@ subroutine sgscloud_radpre_run( & real(kind=kind_phys), dimension(:,:), intent(inout) :: qci_conv real(kind=kind_phys), dimension(:,:), intent(inout) :: qlc, qli !for SAS real(kind=kind_phys), dimension(:,:), intent(in) :: ud_mf - !real(kind=kind_phys), dimension(:,:), intent(in) :: ud_mf_timeave, qci_conv_timeave real(kind=kind_phys), dimension(:,:), intent(in) :: T3D,delp real(kind=kind_phys), dimension(:,:), intent(in) :: qv,P3D,exner real(kind=kind_phys), dimension(:,:), intent(inout) :: & From c9c973ae40b89b27159d87699065242bad8f194d Mon Sep 17 00:00:00 2001 From: "Haiqin.Li" Date: Fri, 10 Mar 2023 00:13:33 +0000 Subject: [PATCH 148/380] "merge RRFS-SD from the GSL repository to the community repository" --- physics/GFS_rrtmg_pre.F90 | 37 +- physics/GFS_rrtmg_pre.meta | 52 +- physics/cu_gf_deep.F90 | 4 +- physics/module_bl_mynn.F90 | 1048 +++++++++-------- physics/mynnedmf_wrapper.F90 | 100 +- physics/mynnedmf_wrapper.meta | 28 +- physics/radiation_aerosols.f | 10 +- physics/smoke_dust/coarsepm_settling_mod.F90 | 274 +++++ physics/smoke_dust/dep_dry_mod.F90 | 69 ++ .../smoke_dust}/dust_data_mod.F90 | 5 +- physics/smoke_dust/dust_fengsha_mod.F90 | 585 +++++++++ .../smoke_dust}/module_add_emiss_burn.F90 | 32 +- .../smoke_dust}/module_plumerise1.F90 | 30 +- .../smoke_dust}/module_smoke_plumerise.F90 | 62 +- physics/smoke_dust/module_wetdep_ls.F90 | 79 ++ .../smoke_dust}/module_zero_plumegen_coms.F90 | 24 +- .../smoke_dust}/plume_data_mod.F90 | 0 .../smoke_dust}/rrfs_smoke_config.F90 | 46 +- .../smoke_dust}/rrfs_smoke_postpbl.F90 | 22 +- .../smoke_dust}/rrfs_smoke_postpbl.meta | 22 +- .../smoke_dust}/rrfs_smoke_wrapper.F90 | 430 ++++--- .../smoke_dust}/rrfs_smoke_wrapper.meta | 110 +- .../smoke_dust}/seas_data_mod.F90 | 0 {smoke => physics/smoke_dust}/seas_mod.F90 | 21 +- .../smoke_dust}/seas_ngac_mod.F90 | 0 smoke/dep_dry_gocart_mod.F90 | 302 ----- smoke/dep_dry_mod.F90 | 303 ----- smoke/dep_simple_mod.F90 | 766 ------------ smoke/dep_vertmx_mod.F90 | 212 ---- smoke/dep_wet_ls_mod.F90 | 562 --------- smoke/dust_fengsha_mod.F90 | 601 ---------- smoke/rrfs_smoke_data.F90 | 651 ---------- smoke/rrfs_smoke_lsdep_wrapper.F90 | 323 ----- smoke/rrfs_smoke_lsdep_wrapper.meta | 208 ---- 34 files changed, 2089 insertions(+), 4929 deletions(-) create mode 100755 physics/smoke_dust/coarsepm_settling_mod.F90 create mode 100755 physics/smoke_dust/dep_dry_mod.F90 rename {smoke => physics/smoke_dust}/dust_data_mod.F90 (97%) create mode 100755 physics/smoke_dust/dust_fengsha_mod.F90 rename {smoke => physics/smoke_dust}/module_add_emiss_burn.F90 (90%) rename {smoke => physics/smoke_dust}/module_plumerise1.F90 (91%) rename {smoke => physics/smoke_dust}/module_smoke_plumerise.F90 (98%) create mode 100755 physics/smoke_dust/module_wetdep_ls.F90 rename {smoke => physics/smoke_dust}/module_zero_plumegen_coms.F90 (88%) rename {smoke => physics/smoke_dust}/plume_data_mod.F90 (100%) rename {smoke => physics/smoke_dust}/rrfs_smoke_config.F90 (66%) rename {smoke => physics/smoke_dust}/rrfs_smoke_postpbl.F90 (68%) rename {smoke => physics/smoke_dust}/rrfs_smoke_postpbl.meta (70%) rename {smoke => physics/smoke_dust}/rrfs_smoke_wrapper.F90 (66%) rename {smoke => physics/smoke_dust}/rrfs_smoke_wrapper.meta (85%) rename {smoke => physics/smoke_dust}/seas_data_mod.F90 (100%) rename {smoke => physics/smoke_dust}/seas_mod.F90 (96%) rename {smoke => physics/smoke_dust}/seas_ngac_mod.F90 (100%) delete mode 100755 smoke/dep_dry_gocart_mod.F90 delete mode 100755 smoke/dep_dry_mod.F90 delete mode 100755 smoke/dep_simple_mod.F90 delete mode 100755 smoke/dep_vertmx_mod.F90 delete mode 100755 smoke/dep_wet_ls_mod.F90 delete mode 100755 smoke/dust_fengsha_mod.F90 delete mode 100755 smoke/rrfs_smoke_data.F90 delete mode 100644 smoke/rrfs_smoke_lsdep_wrapper.F90 delete mode 100755 smoke/rrfs_smoke_lsdep_wrapper.meta diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index c8ed0339e..d43e182db 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -20,7 +20,7 @@ module GFS_rrtmg_pre subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& ltp, imfdeepcnv, imfdeepcnv_gf, me, ncnd, ntrac, num_p3d, npdf3d, & ncnvcld3d,ntqv, ntcw,ntiw, ntlnc, ntinc, ntrnc, ntsnc, ntccn, top_at_1,& - ntrw, ntsw, ntgl, nthl, ntwa, ntoz, & + ntrw, ntsw, ntgl, nthl, ntwa, ntoz, ntsmoke, ntdust, ntcoarsepm, & ntclamt, nleffr, nieffr, nseffr, lndp_type, kdt, & ntdu1, ntdu2, ntdu3, ntdu4, ntdu5, ntss1, ntss2, & ntss3, ntss4, ntss5, ntsu, ntbcb, ntbcl, ntocb, ntocl, ntchm, & @@ -41,11 +41,10 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& kd, kt, kb, mtopa, mbota, raddt, tsfg, tsfa, de_lgth, alb1d, delp, dz, & !output from here and below plvl, plyr, tlvl, tlyr, qlyr, olyr, gasvmr_co2, gasvmr_n2o, gasvmr_ch4,& gasvmr_o2, gasvmr_co, gasvmr_cfc11, gasvmr_cfc12, gasvmr_cfc22, & - gasvmr_ccl4, gasvmr_cfc113, aerodp, clouds6, clouds7, clouds8, & + gasvmr_ccl4, gasvmr_cfc113, aerodp,ext550, clouds6, clouds7, clouds8, & clouds9, cldsa, cldfra, cldfra2d, lwp_ex,iwp_ex, lwp_fc,iwp_fc, & faersw1, faersw2, faersw3, faerlw1, faerlw2, faerlw3, alpha, & - aero_dir_fdb, smoke_ext, dust_ext, & - spp_wts_rad, spp_rad, rrfs_smoke_band, ico2, errmsg, errflg) + aero_dir_fdb, spp_wts_rad, spp_rad, ico2, errmsg, errflg) use machine, only: kind_phys @@ -89,6 +88,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& ntcw, ntiw, ntlnc, ntinc, & ntrnc, ntsnc,ntccn, & ntrw, ntsw, ntgl, nthl, ntwa, ntoz, & + ntsmoke, ntdust, ntcoarsepm, & ntclamt, nleffr, nieffr, nseffr, & lndp_type, & kdt, imp_physics, & @@ -113,7 +113,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& idcor, & idcor_hogan, & idcor_oreopoulos, & - rrfs_smoke_band, & ! Band number for rrfs-smoke dust and smoke ico2 ! Flag for co2 source used in radiation integer, intent(in) :: ntdu1, ntdu2, ntdu3, ntdu4, ntdu5, ntss1, ntss2, ntss3, & @@ -126,7 +125,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& lmfshal, lmfdeep2, pert_clds, lcrick,& lcnorm, top_at_1, lextop, mraerosol logical, intent(in) :: aero_dir_fdb - real(kind=kind_phys), dimension(:,:), intent(in) :: smoke_ext, dust_ext logical, intent(in) :: nssl_ccn_on, nssl_invertccn integer, intent(in) :: spp_rad @@ -187,6 +185,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& gasvmr_ccl4,& gasvmr_cfc113 real(kind=kind_phys), dimension(:,:), intent(out) :: aerodp + real(kind=kind_phys), dimension(:,:), intent(out) :: ext550 real(kind=kind_phys), dimension(:,:), intent(out) :: clouds6, & clouds7, & clouds8, & @@ -637,13 +636,27 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& enddo endif +!>--- add smoke and dust --- + if (aero_dir_fdb) then + do k=1,lmk + do i=1,im + aer_nm(i,k,1 )=aer_nm(i,k,1 )+qgrs(i,k,ntdust)*0.33*1.e-9 ! dust bin1 + aer_nm(i,k,2 )=aer_nm(i,k,2 )+(qgrs(i,k,ntdust)*0.67+qgrs(i,k,ntcoarsepm)*0.02)*1.e-9 + aer_nm(i,k,3 )=aer_nm(i,k,3 )+qgrs(i,k,ntcoarsepm)*0.13*1.e-9 ! dust bin3 + aer_nm(i,k,4 )=aer_nm(i,k,4 )+qgrs(i,k,ntcoarsepm)*0.85*1.e-9 ! dust bin4 + aer_nm(i,k,12)=aer_nm(i,k,12)+qgrs(i,k,ntsmoke)*1.e-9*0.05 !Smoke BC + aer_nm(i,k,14)=aer_nm(i,k,14)+qgrs(i,k,ntsmoke)*1.e-9*0.95 !Smoke OA, we may need to revise later for OA vs. OC + enddo + enddo + endif + !> - Call module_radiation_aerosols::setaer() to setup aerosols !! property profile for radiation. call setaer (plvl, plyr, prslk1, tvly, rhly, slmsk, & ! --- inputs tracer1, aer_nm, xlon, xlat, IM, LMK, LMP,& lsswr, lslwr, iaermdl, iaerflg, top_at_1, con_pi, & - con_rd, con_g, faersw, faerlw, aerodp, errflg, errmsg) ! --- outputs + con_rd, con_g, faersw, faerlw, aerodp, ext550, errflg, errmsg) ! --- outputs ! CCPP do j = 1,NBDSW @@ -657,16 +670,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& enddo enddo - !> - Add aerosol direct feedback effect by smoke and dust - if(aero_dir_fdb) then ! add smoke/dust extinctions - do k = 1, LMK - do i = 1, IM - ! 550nm (~18000/cm) - faersw1(i,k,rrfs_smoke_band) = faersw1(i,k,rrfs_smoke_band) + MIN(4.,smoke_ext(i,k) + dust_ext(i,k)) - enddo - enddo - endif - do j = 1,NBDLW do k = 1, LMK do i = 1, IM diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 53f05225b..782868be6 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -219,6 +219,27 @@ dimensions = () type = integer intent = in +[ntsmoke] + standard_name = index_for_smoke_in_tracer_concentration_array + long_name = tracer index for smoke + units = index + dimensions = () + type = integer + intent = in +[ntdust] + standard_name = index_for_dust_in_tracer_concentration_array + long_name = tracer index for dust + units = index + dimensions = () + type = integer + intent = in +[ntcoarsepm] + standard_name = index_for_coarse_pm_in_tracer_concentration_array + long_name = tracer index for coarse pm + units = index + dimensions = () + type = integer + intent = in [iaermdl] standard_name = control_for_aerosol_radiation_scheme long_name = control of aerosol scheme in radiation @@ -1264,6 +1285,14 @@ type = real kind = kind_phys intent = out +[ext550] + standard_name = atmosphere_optical_thickness_3d + long_name = 3d optical extinction for total aerosol species + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out [clouds6] standard_name = cloud_rain_water_path long_name = cloud rain water path @@ -1437,22 +1466,6 @@ dimensions = () type = logical intent = in -[smoke_ext] - standard_name = extinction_coefficient_in_air_due_to_smoke - long_name = extinction coefficient in air due to smoke - units = various - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[dust_ext] - standard_name = extinction_coefficient_in_air_due_to_dust - long_name = extinction coefficient in air due to dust - units = various - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in [spp_wts_rad] standard_name = spp_weights_for_radiation_scheme long_name = spp weights for radiation scheme @@ -1468,13 +1481,6 @@ dimensions = () type = integer intent = in -[rrfs_smoke_band] - standard_name = index_of_shortwave_band_affected_by_smoke - long_name = rrtmg band number that smoke and dust should affect - units = count - dimensions = () - type = integer - intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/cu_gf_deep.F90 b/physics/cu_gf_deep.F90 index e1976d55c..5abb990de 100644 --- a/physics/cu_gf_deep.F90 +++ b/physics/cu_gf_deep.F90 @@ -25,8 +25,8 @@ module cu_gf_deep real(kind=kind_phys), parameter :: pgcd = 0.1 ! !> aerosol awareness, do not use yet! - integer, parameter :: autoconv=2 - integer, parameter :: aeroevap=3 + integer, parameter :: autoconv=1 !2 + integer, parameter :: aeroevap=1 !3 real(kind=kind_phys), parameter :: scav_factor = 0.5 !> still 16 ensembles for clousres integer, parameter:: maxens3=16 diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index ffb4b5696..d1fae478d 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -248,7 +248,7 @@ MODULE module_bl_mynn xlvcp , tv0 , tv1 , tref , & zero , half , one , two , & onethird , twothirds , tkmin , t0c , & - tice + tice , kind_phys IMPLICIT NONE @@ -301,6 +301,7 @@ MODULE module_bl_mynn ! &cns=3.5, alp1=0.23, alp2=0.3, alp3=3.0, alp4=10.0, alp5=0.2 REAL, PARAMETER :: gpw=5./3., qcgmin=1.e-8, qkemin=1.e-12 + REAL, PARAMETER :: tliq = 269. !all hydrometeors are liquid when T > tliq ! Constants for cloud PDF (mym_condensation) REAL, PARAMETER :: rr2=0.7071068, rrp=0.3989423 @@ -373,7 +374,7 @@ MODULE module_bl_mynn CONTAINS ! ================================================================== -!>\ingroup gp_mynnedmf +!>\ingroup gsd_mynn_edmf !! This subroutine is the GSD MYNN-EDNF PBL driver routine,which !! encompassed the majority of the subroutines that comprise the !! procedures that ultimately solve for tendencies of @@ -383,32 +384,30 @@ MODULE module_bl_mynn SUBROUTINE mynn_bl_driver( & &initflag,restart,cycling, & &delt,dz,dx,znt, & - &u,v,w,th,sqv3D,sqc3D,sqi3D, & + &u,v,w,th,sqv3d,sqc3d,sqi3d, & &qnc,qni, & &qnwfa,qnifa,ozone, & - &p,exner,rho,T3D, & + &p,exner,rho,t3d, & &xland,ts,qsfc,ps, & &ust,ch,hfx,qfx,rmol,wspd, & &uoce,voce, & !ocean current &vdfg, & !Katata-added for fog dep - &Qke,qke_adv, & + &qke,qke_adv, & &sh3d,sm3d, & - &nchem,kdvel,ndvel, & !Smoke/Chem variables - &chem3d, vdep, & - &frp,EMIS_ANT_NO, & ! JLS/RAR to adjust exchange coeffs - &mix_chem,fire_turb,rrfs_smoke, & ! end smoke/chem variables - - &Tsq,Qsq,Cov, & - &RUBLTEN,RVBLTEN,RTHBLTEN, & - &RQVBLTEN,RQCBLTEN,RQIBLTEN, & - &RQNCBLTEN,RQNIBLTEN, & - &RQNWFABLTEN,RQNIFABLTEN, & - &DOZONE, & + &chem3d,vdep,smoke_dbg, & + &frp,emis_ant_no, & ! JLS/RAR to adjust exchange coeffs + &mix_chem,enh_mix,rrfs_sd, & ! end smoke/chem variables + &tsq,qsq,cov, & + &rublten,rvblten,rthblten, & + &rqvblten,rqcblten,rqiblten, & + &rqncblten,rqniblten, & + &rqnwfablten,rqnifablten, & + &dozone, & &exch_h,exch_m, & - &Pblh,kpbl, & + &pblh,kpbl, & &el_pbl, & - &dqke,qWT,qSHEAR,qBUOY,qDISS, & + &dqke,qwt,qshear,qbuoy,qdiss, & &qc_bl,qi_bl,cldfra_bl, & &bl_mynn_tkeadvect, & &bl_mynn_tkebudget, & @@ -428,7 +427,7 @@ SUBROUTINE mynn_bl_driver( & &det_thl3D,det_sqv3D, & &nupdraft,maxMF,ktop_plume, & &spp_pbl,pattern_spp_pbl, & - &RTHRATEN, & + &rthraten, & &FLAG_QC,FLAG_QI,FLAG_QNC, & &FLAG_QNI,FLAG_QNWFA,FLAG_QNIFA, & &FLAG_OZONE & @@ -453,12 +452,12 @@ SUBROUTINE mynn_bl_driver( & INTEGER, INTENT(in) :: bl_mynn_cloudmix INTEGER, INTENT(in) :: bl_mynn_mixqt INTEGER, INTENT(in) :: icloud_bl - REAL, INTENT(in) :: closure + REAL(kind=kind_phys), INTENT(in) :: closure LOGICAL, INTENT(in) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC,& FLAG_QNWFA,FLAG_QNIFA,FLAG_OZONE - LOGICAL, INTENT(IN) :: mix_chem,fire_turb,rrfs_smoke + LOGICAL, INTENT(IN) :: mix_chem,enh_mix,rrfs_sd,smoke_dbg INTEGER, INTENT(in) :: & & IDS,IDE,JDS,JDE,KDS,KDE & @@ -480,71 +479,68 @@ SUBROUTINE mynn_bl_driver( & ! to prevent a crash on Cheyenne. Do not change it back without testing if the code runs ! on Cheyenne with the GNU compiler. - REAL, INTENT(in) :: delt - REAL, DIMENSION(:), INTENT(in) :: dx - REAL, DIMENSION(:,:), INTENT(in) :: dz, & + REAL(kind=kind_phys), INTENT(in) :: delt + REAL(kind=kind_phys), DIMENSION(:), INTENT(in) :: dx + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(in) :: dz, & &u,v,w,th,sqv3D,p,exner,rho,T3D - REAL, DIMENSION(:,:), INTENT(in):: & + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(in) :: & &sqc3D,sqi3D,qni,qnc,qnwfa,qnifa - REAL, DIMENSION(:,:), INTENT(in):: ozone - REAL, DIMENSION(:), INTENT(in) :: xland,ust, & - &ch,ts,qsfc,ps,hfx,qfx,wspd,uoce,voce,vdfg,znt - - REAL, DIMENSION(:,:), INTENT(inout) :: & + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(in):: ozone + REAL(kind=kind_phys), DIMENSION(:), INTENT(in):: ust, & + &ch,qsfc,ps,wspd + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(inout) :: & &Qke,Tsq,Qsq,Cov,qke_adv + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(inout) :: & + &rublten,rvblten,rthblten,rqvblten,rqcblten, & + &rqiblten,rqniblten,rqncblten, & + &rqnwfablten,rqnifablten + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(inout) :: dozone + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(in) :: rthraten - REAL, DIMENSION(:,:), INTENT(inout) :: & - &RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN,RQCBLTEN, & - &RQIBLTEN,RQNIBLTEN,RQNCBLTEN, & - &RQNWFABLTEN,RQNIFABLTEN - REAL, DIMENSION(:,:), INTENT(inout) :: DOZONE - - REAL, DIMENSION(:,:), INTENT(in) :: RTHRATEN - - REAL, DIMENSION(:,:), INTENT(out) :: & - &exch_h,exch_m + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(out) :: exch_h,exch_m + REAL, DIMENSION(:), INTENT(in) :: xland,ts,znt,hfx,qfx, & + &uoce,voce !These 10 arrays are only allocated when bl_mynn_output > 0 - REAL, DIMENSION(:,:), INTENT(inout) :: & - & edmf_a,edmf_w,edmf_qt,edmf_thl,edmf_ent,edmf_qc, & + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(inout) :: & + & edmf_a,edmf_w,edmf_qt,edmf_thl,edmf_ent,edmf_qc, & & sub_thl3D,sub_sqv3D,det_thl3D,det_sqv3D ! REAL, DIMENSION(IMS:IME,KMS:KME) :: & ! & edmf_a_dd,edmf_w_dd,edmf_qt_dd,edmf_thl_dd,edmf_ent_dd,edmf_qc_dd - REAL, DIMENSION(:), INTENT(inout) :: Pblh,rmol + REAL(kind=kind_phys), DIMENSION(:), INTENT(inout) :: Pblh + REAL, DIMENSION(:), INTENT(inout) :: rmol REAL, DIMENSION(IMS:IME) :: Psig_bl,Psig_shcu - INTEGER,DIMENSION(:),INTENT(INOUT) :: & + INTEGER,DIMENSION(:),INTENT(INOUT) :: & &KPBL,nupdraft,ktop_plume - REAL, DIMENSION(:), INTENT(OUT) :: & - &maxmf + REAL(kind=kind_phys), DIMENSION(:), INTENT(out) :: maxmf - REAL, DIMENSION(:,:), INTENT(inout) :: & - &el_pbl + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(inout) :: el_pbl - REAL, DIMENSION(:,:), INTENT(out) :: & + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(out) :: & &qWT,qSHEAR,qBUOY,qDISS,dqke ! 3D budget arrays are not allocated when bl_mynn_tkebudget == .false. ! 1D (local) budget arrays are used for passing between subroutines. REAL, DIMENSION(kts:kte) :: qWT1,qSHEAR1,qBUOY1,qDISS1,dqke1,diss_heat - REAL, DIMENSION(:,:), intent(out) :: Sh3D,Sm3D + REAL(kind=kind_phys), DIMENSION(:,:), intent(out) :: Sh3D,Sm3D - REAL, DIMENSION(:,:), INTENT(inout) :: & + REAL(kind=kind_phys), DIMENSION(:,:), INTENT(inout) :: & &qc_bl,qi_bl,cldfra_bl - REAL, DIMENSION(KTS:KTE) :: qc_bl1D,qi_bl1D,cldfra_bl1D,& + REAL, DIMENSION(KTS:KTE) :: qc_bl1D,qi_bl1D,cldfra_bl1D, & qc_bl1D_old,qi_bl1D_old,cldfra_bl1D_old ! smoke/chemical arrays INTEGER, INTENT(IN ) :: nchem, kdvel, ndvel ! REAL, DIMENSION( ims:ime, kms:kme, nchem ), INTENT(INOUT), optional :: chem3d ! REAL, DIMENSION( ims:ime, kdvel, ndvel ), INTENT(IN), optional :: vdep - REAL, DIMENSION(:, :, :), INTENT(INOUT) :: chem3d - REAL, DIMENSION(:, :), INTENT(IN) :: vdep - REAL, DIMENSION(:), INTENT(IN) :: frp,EMIS_ANT_NO + REAL(kind=kind_phys), DIMENSION(:, :, :), INTENT(INOUT) :: chem3d + REAL(kind=kind_phys), DIMENSION(:, :), INTENT(IN) :: vdep + REAL(kind=kind_phys), DIMENSION(:), INTENT(IN) :: frp,EMIS_ANT_NO !local REAL, DIMENSION(kts:kte ,nchem) :: chem1 REAL, DIMENSION(kts:kte+1,nchem) :: s_awchem1 @@ -553,68 +549,82 @@ SUBROUTINE mynn_bl_driver( & !local vars INTEGER :: ITF,JTF,KTF, IMD,JMD - INTEGER :: i,j,k - REAL, DIMENSION(KTS:KTE) :: thl,thvl,tl,qv1,qc1,qi1,sqw,& - &El, Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc, & - &Vt, Vq, sgm, thlsg, sqwsg - REAL, DIMENSION(KTS:KTE) :: thetav,sh,sm,u1,v1,w1,p1, & - &ex1,dz1,th1,tk1,rho1,qke1,tsq1,qsq1,cov1, & - &sqv,sqi,sqc,du1,dv1,dth1,dqv1,dqc1,dqi1,ozone1, & - &k_m1,k_h1,qni1,dqni1,qnc1,dqnc1,qnwfa1,qnifa1, & + INTEGER :: i,j,k,kproblem + REAL, DIMENSION(KTS:KTE) :: thl,thvl,tl,qv1,qc1,qi1,sqw, & + &El, Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc, & + &Vt, Vq, sgm, thlsg, sqwsg, vdfg + REAL, DIMENSION(KTS:KTE) :: thetav,sh,sm,u1,v1,w1,p1, & + &ex1,dz1,th1,tk1,rho1,qke1,tsq1,qsq1,cov1, & + &sqv,sqi,sqc,du1,dv1,dth1,dqv1,dqc1,dqi1,ozone1, & + &k_m1,k_h1,qni1,dqni1,qnc1,dqnc1,qnwfa1,qnifa1, & &dqnwfa1,dqnifa1,dozone1 !mass-flux variables REAL, DIMENSION(KTS:KTE) :: dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf - REAL, DIMENSION(KTS:KTE) :: edmf_a1,edmf_w1,edmf_qt1, & + REAL, DIMENSION(KTS:KTE) :: edmf_a1,edmf_w1,edmf_qt1, & &edmf_thl1,edmf_ent1,edmf_qc1 - REAL, DIMENSION(KTS:KTE) :: edmf_a_dd1,edmf_w_dd1, & - &edmf_qt_dd1,edmf_thl_dd1, & + REAL, DIMENSION(KTS:KTE) :: edmf_a_dd1,edmf_w_dd1, & + &edmf_qt_dd1,edmf_thl_dd1, & &edmf_ent_dd1,edmf_qc_dd1 - REAL, DIMENSION(KTS:KTE) :: sub_thl,sub_sqv,sub_u,sub_v,& + REAL, DIMENSION(KTS:KTE) :: sub_thl,sub_sqv,sub_u,sub_v, & det_thl,det_sqv,det_sqc,det_u,det_v - REAL,DIMENSION(KTS:KTE+1) :: s_aw1,s_awthl1,s_awqt1, & - s_awqv1,s_awqc1,s_awu1,s_awv1,s_awqke1, & + REAL,DIMENSION(KTS:KTE+1) :: s_aw1,s_awthl1,s_awqt1, & + s_awqv1,s_awqc1,s_awu1,s_awv1,s_awqke1, & s_awqnc1,s_awqni1,s_awqnwfa1,s_awqnifa1 - REAL,DIMENSION(KTS:KTE+1) :: sd_aw1,sd_awthl1,sd_awqt1, & + REAL,DIMENSION(KTS:KTE+1) :: sd_aw1,sd_awthl1,sd_awqt1, & sd_awqv1,sd_awqc1,sd_awu1,sd_awv1,sd_awqke1 REAL, DIMENSION(KTS:KTE+1) :: zw REAL :: cpm,sqcg,flt,fltv,flq,flqv,flqc,pmz,phh,exnerg,zet,phi_m,& & afk,abk,ts_decay, qc_bl2, qi_bl2, & - & th_sfc,ztop_plume,sqc9,sqi9 + & th_sfc,ztop_plume,sqc9,sqi9,wsp !top-down diffusion REAL, DIMENSION(ITS:ITE) :: maxKHtopdown REAL,DIMENSION(KTS:KTE) :: KHtopdown,TKEprodTD - LOGICAL :: INITIALIZE_QKE + LOGICAL :: INITIALIZE_QKE,problem ! Stochastic fields - INTEGER, INTENT(IN) ::spp_pbl - REAL, DIMENSION( :, :), INTENT(IN) ::pattern_spp_pbl - REAL, DIMENSION(KTS:KTE) ::rstoch_col + INTEGER, INTENT(IN) :: spp_pbl + REAL(kind=kind_phys), DIMENSION( :, :), INTENT(IN) :: pattern_spp_pbl + REAL, DIMENSION(KTS:KTE) :: rstoch_col ! Substepping TKE INTEGER :: nsub - real :: delt2 - - IF ( debug_code ) THEN - if (idbg .lt. ime) then - print*,'in MYNN driver; at beginning' - print*," th(1:5)=",th(idbg,1:5) - print*," u(1:5)=",u(idbg,1:5) - print*," v(1:5)=",v(idbg,1:5) - print*," w(1:5)=",w(idbg,1:5) - print*," sqv(1:5)=",sqv3D(idbg,1:5) - print*," p(1:5)=",p(idbg,1:5) - print*," rho(1:5)=",rho(idbg,1:5) - print*," xland=",xland(idbg)," u*=",ust(idbg), & - &" ts=",ts(idbg)," qsfc=",qsfc(idbg), & - &" z/L=",0.5*dz(idbg,1)*rmol(idbg)," ps=",ps(idbg),& - &" hfx=",hfx(idbg)," qfx=",qfx(idbg), & - &" wspd=",wspd(idbg)," znt=",znt(idbg) - endif - ENDIF + real(kind=kind_phys) :: delt2 + + + if (debug_code) then !check incoming values + do i=its,ite + problem = .false. + do k=kts,kte + wsp = sqrt(u(i,k)**2 + v(i,k)**2) + if (abs(hfx(i)) > 1200. .or. abs(qfx(i)) > 0.001 .or. & + wsp > 200. .or. t3d(i,k) > 360. .or. t3d(i,k) < 160. .or. & + sqv3d(i,k)< 0.0 .or. sqc3d(i,k)< 0.0 ) then + kproblem = k + problem = .true. + print*,"Incoming problem at: i=",i," k=1" + print*," QFX=",qfx(i)," HFX=",hfx(i) + print*," wsp=",wsp," T=",t3d(i,k) + print*," qv=",sqv3d(i,k)," qc=",sqc3d(i,k) + print*," u*=",ust(i)," wspd=",wspd(i) + print*," xland=",xland(i)," ts=",ts(i) + print*," z/L=",0.5*dz(i,1)*rmol(i)," ps=",ps(i) + print*," znt=",znt(i)," dx=",dx(i) + endif + enddo + if (problem) then + print*,"===tk:",t3d(i,max(kproblem-3,1):min(kproblem+3,kte)) + print*,"===qv:",sqv3d(i,max(kproblem-3,1):min(kproblem+3,kte)) + print*,"===qc:",sqc3d(i,max(kproblem-3,1):min(kproblem+3,kte)) + print*,"===qi:",sqi3d(i,max(kproblem-3,1):min(kproblem+3,kte)) + print*,"====u:",u(i,max(kproblem-3,1):min(kproblem+3,kte)) + print*,"====v:",v(i,max(kproblem-3,1):min(kproblem+3,kte)) + endif + enddo + endif !*** Begin debugging IMD=(IMS+IME)/2 @@ -1052,9 +1062,9 @@ SUBROUTINE mynn_bl_driver( & ENDDO ! end k !initialize smoke/chem arrays (if used): - IF ( rrfs_smoke .and. mix_chem ) then + IF ( mix_chem ) then do ic = 1,ndvel - vd1(ic) = vdep(i,ic) !is this correct???? + vd1(ic) = vdep(i,ic) ! dry deposition velocity chem1(kts,ic) = chem3d(i,kts,ic) s_awchem1(kts,ic)=0. enddo @@ -1066,7 +1076,7 @@ SUBROUTINE mynn_bl_driver( & enddo ELSE do ic = 1,ndvel - vd1(ic) = 0. !is this correct??? (ite) or (ndvel) + vd1(ic) = 0. ! dry deposition velocity chem1(kts,ic) = 0. s_awchem1(kts,ic)=0. enddo @@ -1178,7 +1188,8 @@ SUBROUTINE mynn_bl_driver( & !! selected by use of the namelist parameter \p bl_mynn_cloudpdf. CALL mym_condensation ( kts,kte, & - &dx(i),dz1,zw,thl,sqw,sqv,sqc,sqi,& + &dx(i),dz1,zw,u1,v1,xland(i), & + &thl,sqw,sqv,sqc,sqi, & &p1,ex1,tsq1,qsq1,cov1, & &Sh,el,bl_mynn_cloudpdf, & &qc_bl1D,qi_bl1D,cldfra_bl1D, & @@ -1193,7 +1204,7 @@ SUBROUTINE mynn_bl_driver( & CALL topdown_cloudrad(kts,kte,dz1,zw, & &xland(i),kpbl(i),PBLH(i), & &sqc,sqi,sqw,thl,th1,ex1,p1,rho1,thetav, & - &cldfra_bl1D,rthraten, & + &cldfra_bl1D,rthraten(i,:), & &maxKHtopdown(i),KHtopdown,TKEprodTD ) ELSE maxKHtopdown(i) = 0.0 @@ -1311,7 +1322,6 @@ SUBROUTINE mynn_bl_driver( & !> - Call mynn_tendencies() to solve for tendencies of !! \f$U, V, \theta, q_{v}, q_{c}, and q_{i}\f$. CALL mynn_tendencies(kts,kte,i, & - &closure, & &delt, dz1, rho1, & &u1, v1, th1, tk1, qv1, & &qc1, qi1, qnc1, qni1, & @@ -1326,7 +1336,7 @@ SUBROUTINE mynn_bl_driver( & &Du1, Dv1, Dth1, Dqv1, & &Dqc1, Dqi1, Dqnc1, Dqni1, & &Dqnwfa1, Dqnifa1, Dozone1, & - &vdfg(i), diss_heat, & + &diss_heat, & ! mass flux components &s_aw1,s_awthl1,s_awqt1, & &s_awqv1,s_awqc1,s_awu1,s_awv1, & @@ -1349,7 +1359,8 @@ SUBROUTINE mynn_bl_driver( & &bl_mynn_mixscalars ) - IF ( rrfs_smoke .and. mix_chem ) THEN + IF ( mix_chem ) THEN + IF ( rrfs_sd ) THEN CALL mynn_mix_chem(kts,kte,i, & &delt, dz1, pblh(i), & &nchem, kdvel, ndvel, & @@ -1359,12 +1370,24 @@ SUBROUTINE mynn_bl_driver( & &dfh, & &s_aw1,s_awchem1, & &emis_ant_no(i), & - &frp(i), & - &fire_turb ) - + &frp(i), rrfs_sd, & + &enh_mix, smoke_dbg ) + ELSE + CALL mynn_mix_chem(kts,kte,i, & + &delt, dz1, pblh(i), & + &nchem, kdvel, ndvel, & + &chem1, vd1, & + &rho1,flt, & + &tcd, qcd, & + &dfh, & + &s_aw1,s_awchem1, & + &zero, & + &zero, rrfs_sd, & + &enh_mix, smoke_dbg ) + ENDIF DO ic = 1,nchem DO k = kts,kte - chem3d(i,k,ic) = chem1(k,ic) + chem3d(i,k,ic) = max(1.e-12, chem1(k,ic)) ENDDO ENDDO ENDIF @@ -1373,58 +1396,38 @@ SUBROUTINE mynn_bl_driver( & &dfm, dfh, dz1, K_m1, K_h1) !UPDATE 3D ARRAYS - DO k=KTS,KTE !KTF + do k=kts,kte exch_m(i,k)=K_m1(k) exch_h(i,k)=K_h1(k) - RUBLTEN(i,k)=du1(k) - RVBLTEN(i,k)=dv1(k) - RTHBLTEN(i,k)=dth1(k) - RQVBLTEN(i,k)=dqv1(k) - IF(bl_mynn_cloudmix > 0)THEN - IF (FLAG_QC) RQCBLTEN(i,k)=dqc1(k) - IF (FLAG_QI) RQIBLTEN(i,k)=dqi1(k) - ELSE - IF (FLAG_QC) RQCBLTEN(i,k)=0. - IF (FLAG_QI) RQIBLTEN(i,k)=0. - ENDIF - IF(bl_mynn_cloudmix > 0 .AND. bl_mynn_mixscalars > 0)THEN - IF (FLAG_QNC) RQNCBLTEN(i,k)=dqnc1(k) - IF (FLAG_QNI) RQNIBLTEN(i,k)=dqni1(k) - IF (FLAG_QNWFA) RQNWFABLTEN(i,k)=dqnwfa1(k) - IF (FLAG_QNIFA) RQNIFABLTEN(i,k)=dqnifa1(k) - ELSE - IF (FLAG_QNC) RQNCBLTEN(i,k)=0. - IF (FLAG_QNI) RQNIBLTEN(i,k)=0. - IF (FLAG_QNWFA) RQNWFABLTEN(i,k)=0. - IF (FLAG_QNIFA) RQNIFABLTEN(i,k)=0. - ENDIF - DOZONE(i,k)=DOZONE1(k) - - IF(icloud_bl > 0)THEN - !DIAGNOSTIC-DECAY FOR SUBGRID-SCALE CLOUDS - IF (CLDFRA_BL1D(k) < cldfra_bl1D_old(k)) THEN - !DECAY TIMESCALE FOR CALM CONDITION IS THE EDDY TURNOVER - !TIMESCALE, BUT FOR WINDY CONDITIONS, IT IS THE ADVECTIVE - !TIMESCALE. USE THE MINIMUM OF THE TWO. - ts_decay = MIN( 1800., 2.*dx(i)/MAX(SQRT(u1(k)**2 + v1(k)**2),1.0) ) - cldfra_bl(i,k)= MAX(cldfra_bl1D(k),cldfra_bl1D_old(k)-(0.25*delt/ts_decay)) - ! qc_bl2 and qi_bl2 are linked to decay rates - qc_bl2 = MAX(qc_bl1D(k),qc_bl1D_old(k)) - qi_bl2 = MAX(qi_bl1D(k),qi_bl1D_old(k)) - qc_bl(i,k) = MAX(qc_bl1D(k),qc_bl1D_old(k)-(MIN(qc_bl2,1.0E-5) * delt/ts_decay)) - qi_bl(i,k) = MAX(qi_bl1D(k),qi_bl1D_old(k)-(MIN(qi_bl2,1.0E-6) * delt/ts_decay)) - IF (cldfra_bl(i,k) < 0.005 .OR. & - (qc_bl(i,k) + qi_bl(i,k)) < 1E-9) THEN - CLDFRA_BL(i,k)= 0. - QC_BL(i,k) = 0. - QI_BL(i,k) = 0. - ENDIF - ELSE - qc_bl(i,k)=qc_bl1D(k) - qi_bl(i,k)=qi_bl1D(k) - cldfra_bl(i,k)=cldfra_bl1D(k) - ENDIF - ENDIF + rublten(i,k)=du1(k) + rvblten(i,k)=dv1(k) + rthblten(i,k)=dth1(k) + rqvblten(i,k)=dqv1(k) + if (bl_mynn_cloudmix > 0) then + if (FLAG_QC) rqcblten(i,k)=dqc1(k) + if (FLAG_QI) rqiblten(i,k)=dqi1(k) + else + if (FLAG_QC) rqcblten(i,k)=0. + if (FLAG_QI) rqiblten(i,k)=0. + endif + if (bl_mynn_cloudmix > 0 .and. bl_mynn_mixscalars > 0) then + if (FLAG_QNC) rqncblten(i,k)=dqnc1(k) + if (FLAG_QNI) rqniblten(i,k)=dqni1(k) + if (FLAG_QNWFA) rqnwfablten(i,k)=dqnwfa1(k) + if (FLAG_QNIFA) rqnifablten(i,k)=dqnifa1(k) + else + if (FLAG_QNC) rqncblten(i,k)=0. + if (FLAG_QNI) rqniblten(i,k)=0. + if (FLAG_QNWFA) rqnwfablten(i,k)=0. + if (FLAG_QNIFA) rqnifablten(i,k)=0. + endif + dozone(i,k)=dozone1(k) + + if (icloud_bl > 0) then + qc_bl(i,k)=qc_bl1D(k) + qi_bl(i,k)=qi_bl1D(k) + cldfra_bl(i,k)=cldfra_bl1D(k) + endif el_pbl(i,k)=el(k) qke(i,k)=qke1(k) @@ -1433,22 +1436,22 @@ SUBROUTINE mynn_bl_driver( & cov(i,k)=cov1(k) sh3d(i,k)=sh(k) sm3d(i,k)=sm(k) - ENDDO !end-k + enddo !end-k - IF ( bl_mynn_tkebudget ) THEN + if ( bl_mynn_tkebudget ) then !! TKE budget is now given in m**2/s**-3 (Puhales, 2020) !! Lower boundary condtions (using similarity relationships such as the prognostic equation for Qke) k=kts qSHEAR1(k)=4.*(ust(i)**3*phi_m/(karman*dz(i,k)))-qSHEAR1(k+1) !! staggered qBUOY1(k)=4.*(-ust(i)**3*zet/(karman*dz(i,k)))-qBUOY1(k+1) !! staggered !! unstaggering SHEAR and BUOY and trasfering all TKE budget to 3D array - DO k = kts,kte-1 + do k = kts,kte-1 qSHEAR(i,k)=0.5*(qSHEAR1(k)+qSHEAR1(k+1)) !!! unstaggering in z qBUOY(i,k)=0.5*(qBUOY1(k)+qBUOY1(k+1)) !!! unstaggering in z qWT(i,k)=qWT1(k) qDISS(i,k)=qDISS1(k) dqke(i,k)=(qke1(k)-dqke(i,k))*0.5/delt - ENDDO + enddo !! Upper boundary conditions k=kte qSHEAR(i,k)=0. @@ -1456,7 +1459,7 @@ SUBROUTINE mynn_bl_driver( & qWT(i,k)=0. qDISS(i,k)=0. dqke(i,k)=0. - ENDIF + endif !update updraft/downdraft properties if (bl_mynn_output > 0) THEN !research mode == 1 @@ -1495,9 +1498,9 @@ SUBROUTINE mynn_bl_driver( & DO k = kts,kte IF ( sh(k) < 0. .OR. sh(k)> 200.)print*,& "SUSPICIOUS VALUES AT: i,k=",i,k," sh=",sh(k) - IF ( ABS(vt(k)) > 0.9 )print*,& + IF ( ABS(vt(k)) > 2.0 )print*,& "SUSPICIOUS VALUES AT: i,k=",i,k," vt=",vt(k) - IF ( ABS(vq(k)) > 6000.)print*,& + IF ( ABS(vq(k)) > 7000.)print*,& "SUSPICIOUS VALUES AT: i,k=",i,k," vq=",vq(k) IF ( qke(i,k) < -1. .OR. qke(i,k)> 200.)print*,& "SUSPICIOUS VALUES AT: i,k=",i,k," qke=",qke(i,k) @@ -1549,13 +1552,7 @@ END SUBROUTINE mynn_bl_driver !> @} !======================================================================= -!> This subroutine gives the closure constants and initializes the -!! turbulent qantities. ! SUBROUTINE mym_initialize: -! ================================================================== -! This subroutine computes the length scales up and down -! and then computes the min, average of the up/down length scales, and also -! considers the distance to the surface. ! ! Input variables: ! iniflag : <>0; turbulent quantities will be initialized @@ -1607,7 +1604,7 @@ END SUBROUTINE mynn_bl_driver ! !------------------------------------------------------------------- -!>\ingroup gp_mynnedmf +!>\ingroup gsd_mynn_edmf !! This subroutine initializes the mixing length, TKE, \f$\theta^{'2}\f$, !! \f$q^{'2}\f$, and \f$\theta^{'}q^{'}\f$. !!\section gen_mym_ini GSD MYNN-EDMF mym_initialize General Algorithm @@ -1632,22 +1629,20 @@ SUBROUTINE mym_initialize ( & INTEGER, INTENT(IN) :: bl_mynn_mixlength,bl_mynn_edmf LOGICAL, INTENT(IN) :: INITIALIZE_QKE ! REAL, INTENT(IN) :: ust, rmo, pmz, phh, flt, flq - REAL, INTENT(IN) :: ust, rmo, Psig_bl, dx + REAL, INTENT(IN) :: rmo, Psig_bl + REAL(kind=kind_phys), INTENT(IN) :: dx, ust, zi REAL, DIMENSION(kts:kte), INTENT(in) :: dz REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,qw,cldfra_bl1D,& edmf_w1,edmf_a1,edmf_qc1 REAL, DIMENSION(kts:kte), INTENT(out) :: tsq,qsq,cov REAL, DIMENSION(kts:kte), INTENT(inout) :: el,qke - REAL, DIMENSION(kts:kte) :: & &ql,pdk,pdt,pdq,pdc,dtl,dqw,dtv,& &gm,gh,sm,sh,qkw,vt,vq INTEGER :: k,l,lmax REAL :: phm,vkz,elq,elv,b1l,b2l,pmz=1.,phh=1.,flt=0.,flq=0.,tmpq - REAL :: zi - REAL, DIMENSION(kts:kte) :: theta,thetav,thlsg,qwsg - + REAL, DIMENSION(kts:kte) :: theta,thetav,thlsg,qwsg REAL, DIMENSION(kts:kte) :: rstoch_col INTEGER ::spp_pbl @@ -1795,7 +1790,7 @@ END SUBROUTINE mym_initialize ! These are defined on the walls of the grid boxes. ! -!>\ingroup gp_mynnedmf +!>\ingroup gsd_mynn_edmf !! This subroutine calculates the level 2, non-dimensional wind shear !! \f$G_M\f$ and vertical temperature gradient \f$G_H\f$ as well as !! the level 2 stability funcitons \f$S_h\f$ and \f$S_m\f$. @@ -1951,7 +1946,7 @@ END SUBROUTINE mym_level2 ! NOTE: the mixing lengths are meant to be calculated at the full- ! sigmal levels (or interfaces beween the model layers). ! -!>\ingroup gp_mynnedmf +!>\ingroup gsd_mynn_edmf !! This subroutine calculates the mixing lengths. SUBROUTINE mym_length ( & & kts,kte, & @@ -1964,6 +1959,7 @@ SUBROUTINE mym_length ( & & zi,theta, & & qkw,Psig_bl,cldfra_bl1D,bl_mynn_mixlength,& & edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf) + !------------------------------------------------------------------- INTEGER, INTENT(IN) :: kts,kte @@ -1976,7 +1972,8 @@ SUBROUTINE mym_length ( & INTEGER, INTENT(IN) :: bl_mynn_mixlength,bl_mynn_edmf REAL, DIMENSION(kts:kte), INTENT(in) :: dz REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw - REAL, INTENT(in) :: rmo,flt,flq,Psig_bl,dx + REAL, INTENT(in) :: rmo,flt,flq,Psig_bl + REAL(kind=kind_phys), INTENT(IN) :: dx,zi REAL, DIMENSION(kts:kte), INTENT(IN) :: u1,v1,qke,vt,vq,cldfra_bl1D,& edmf_w1,edmf_a1,edmf_qc1 REAL, DIMENSION(kts:kte), INTENT(out) :: qkw, el @@ -1986,7 +1983,7 @@ SUBROUTINE mym_length ( & REAL, DIMENSION(kts:kte), INTENT(IN) :: theta REAL, DIMENSION(kts:kte) :: qtke,elBLmin,elBLavg,thetaw - REAL :: wt,wt2,zi,zi2,h1,h2,hs,elBLmin0,elBLavg0,cldavg + REAL :: wt,wt2,zi2,h1,h2,hs,elBLmin0,elBLavg0,cldavg ! THE FOLLOWING CONSTANTS ARE IMPORTANT FOR REGULATING THE ! MIXING LENGTHS: @@ -2028,7 +2025,7 @@ SUBROUTINE mym_length ( & CASE (0) ! ORIGINAL MYNN MIXING LENGTH + BouLac cns = 2.7 - alp1 = 0.21 + alp1 = 0.23 alp2 = 1.0 alp3 = 5.0 alp4 = 100. @@ -2110,9 +2107,9 @@ SUBROUTINE mym_length ( & CASE (1) !NONLOCAL (using BouLac) FORM OF MIXING LENGTH cns = 3.5 - alp1 = 0.21 + alp1 = 0.22 !0.21 alp2 = 0.3 - alp3 = 1.5 + alp3 = 2.0 !1.5 alp4 = 5.0 alp5 = 0.3 alp6 = 50. @@ -2143,7 +2140,7 @@ SUBROUTINE mym_length ( & zwk = zw(k) DO WHILE (zwk .LE. zi2+h1) dzk = 0.5*( dz(k)+dz(k-1) ) - qdz = MAX( qkw(k)-qmin, 0.03 )*dzk + qdz = min(max( qkw(k)-qmin, 0.03 ), 30.0)*dzk elt = elt +qdz*zwk vsc = vsc +qdz k = k+1 @@ -2166,17 +2163,17 @@ SUBROUTINE mym_length ( & ! ** Length scale limited by the buoyancy effect ** IF ( dtv(k) .GT. 0.0 ) THEN - alp2 = 0.3 + 0.15*0.5*(cldfra_bl1D(k)+cldfra_bl1D(k-1)) - bv = SQRT( gtr*dtv(k) ) + alp2 = 0.3 !test+ 0.15*0.5*(cldfra_bl1D(k)+cldfra_bl1D(k-1)) + bv = max( sqrt( gtr*dtv(k) ), 0.001) !elb = alp2*qkw(k) / bv & ! formulation, ! & *( 1.0 + alp3/alp2*& ! except keep ! &SQRT( vsc/( bv*elt ) ) ) ! elb bounded by zwk - elb = MAX(alp2*qkw(k), & - & alp6*edmf_a1(k)*edmf_w1(k)) / bv & + elb = MAX(alp2*qkw(k), & + & alp6*edmf_a1(k-1)*edmf_w1(k-1)) / bv & & *( 1.0 + alp3*SQRT( vsc/(bv*elt) ) ) elb = MIN(elb, zwk) elf = 0.65 * qkw(k)/bv - !elBLavg(k) = MAX(elBLavg(k), alp6*edmf_a1(k)*edmf_w1(k)/bv) + elBLavg(k) = MAX(elBLavg(k), alp6*edmf_a1(k-1)*edmf_w1(k-1)/bv) ELSE elb = 1.0e10 elf = elb @@ -2215,9 +2212,9 @@ SUBROUTINE mym_length ( & Uonset = 3.5 + dz(kts)*0.1 Ugrid = sqrt(u1(kts)**2 + v1(kts)**2) cns = 3.5 !JOE-test * (1.0 - MIN(MAX(Ugrid - Uonset, 0.0)/10.0, 1.0)) - alp1 = 0.21 + alp1 = 0.22 !0.21 alp2 = 0.30 - alp3 = 1.5 + alp3 = 2.0 !1.5 alp4 = 5.0 alp5 = alp2 !like alp2, but for free atmosphere alp6 = 50.0 !used for MF mixing length @@ -2250,7 +2247,7 @@ SUBROUTINE mym_length ( & zwk = zw(k) DO WHILE (zwk .LE. PBLH_PLUS_ENT) dzk = 0.5*( dz(k)+dz(k-1) ) - qdz = MAX( qkw(k)-qmin, 0.03 )*dzk + qdz = min(max( qkw(k)-qmin, 0.03 ), 30.0)*dzk elt = elt +qdz*zwk vsc = vsc +qdz k = k+1 @@ -2276,7 +2273,7 @@ SUBROUTINE mym_length ( & bv = MAX( SQRT( gtr*dtv(k) ), 0.001) !elb_mf = alp2*qkw(k) / bv & elb_mf = MAX(alp2*qkw(k), & - & alp6*edmf_a1(k)*edmf_w1(k)) / bv & + & alp6*edmf_a1(k-1)*edmf_w1(k-1)) / bv & & *( 1.0 + alp3*SQRT( vsc/( bv*elt ) ) ) elb = MIN(MAX(alp5*qkw(k), alp6*edmf_a1(k)*edmf_w1(k))/bv, zwk) @@ -2363,7 +2360,7 @@ SUBROUTINE mym_length ( & END SUBROUTINE mym_length ! ================================================================== -!>\ingroup gp_mynnedmf +!>\ingroup gsd_mynn_edmf !! This subroutine was taken from the BouLac scheme in WRF-ARW and modified for !! integration into the MYNN PBL scheme. WHILE loops were added to reduce the !! computational expense. This subroutine computes the length scales up and down @@ -2526,7 +2523,7 @@ SUBROUTINE boulac_length0(k,kts,kte,zw,dz,qtke,theta,lb1,lb2) END SUBROUTINE boulac_length0 ! ================================================================== -!>\ingroup gp_mynnedmf +!>\ingroup gsd_mynn_edmf !! This subroutine was taken from the BouLac scheme in WRF-ARW !! and modified for integration into the MYNN PBL scheme. !! WHILE loops were added to reduce the computational expense. @@ -2717,7 +2714,7 @@ END SUBROUTINE boulac_length ! # dtl, dqw, dtv, gm and gh are allowed to share storage units with ! dfm, dfh, dfq, tcd and qcd, respectively, for saving memory. ! -!>\ingroup gp_mynnedmf +!>\ingroup gsd_mynn_edmf !! This subroutine calculates the vertical diffusivity coefficients and the !! production terms for the turbulent quantities. !>\section gen_mym_turbulence GSD mym_turbulence General Algorithm @@ -2754,6 +2751,7 @@ SUBROUTINE mym_turbulence ( & & edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf, & & TKEprodTD, & & spp_pbl,rstoch_col) + !------------------------------------------------------------------- ! INTEGER, INTENT(IN) :: kts,kte @@ -2764,10 +2762,11 @@ SUBROUTINE mym_turbulence ( & #endif INTEGER, INTENT(IN) :: bl_mynn_mixlength,bl_mynn_edmf - REAL, INTENT(IN) :: closure - REAL, DIMENSION(kts:kte), INTENT(in) :: dz + REAL(kind=kind_phys), INTENT(IN) :: closure + REAL, DIMENSION(kts:kte), INTENT(in) :: dz REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw - REAL, INTENT(in) :: rmo,flt,flq,Psig_bl,Psig_shcu,dx + REAL, INTENT(in) :: rmo,flt,flq,Psig_bl,Psig_shcu + REAL(kind=kind_phys), INTENT(IN) :: dx,zi REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,thetav,qw,& &ql,vt,vq,qke,tsq,qsq,cov,cldfra_bl1D,edmf_w1,edmf_a1,edmf_qc1,& &TKEprodTD,thlsg,qwsg @@ -2789,7 +2788,7 @@ SUBROUTINE mym_turbulence ( & REAL :: e6c,dzk,afk,abk,vtt,vqq,& &cw25,clow,cupp,gamt,gamq,smd,gamv,elq,elh - REAL :: zi, cldavg + REAL :: cldavg REAL, DIMENSION(kts:kte), INTENT(in) :: theta REAL :: a2fac, duz, ri !JOE-Canuto/Kitamura mod @@ -3313,7 +3312,7 @@ END SUBROUTINE mym_turbulence ! scheme (program). ! !------------------------------------------------------------------- -!>\ingroup gp_mynnedmf +!>\ingroup gsd_mynn_edmf !! This subroutine predicts the turbulent quantities at the next step. SUBROUTINE mym_predict (kts,kte, & & closure, & @@ -3325,6 +3324,7 @@ SUBROUTINE mym_predict (kts,kte, & & qke, tsq, qsq, cov, & & s_aw,s_awqke,bl_mynn_edmf_tke, & & qWT1D, qDISS1D,bl_mynn_tkebudget) !! TKE budget (Puhales, 2020) + !------------------------------------------------------------------- INTEGER, INTENT(IN) :: kts,kte @@ -3333,12 +3333,12 @@ SUBROUTINE mym_predict (kts,kte, & # define kte HARDCODE_VERTICAL #endif - REAL, INTENT(IN) :: closure + REAL(kind=kind_phys), INTENT(IN) :: closure INTEGER, INTENT(IN) :: bl_mynn_edmf_tke - REAL, INTENT(IN) :: delt REAL, DIMENSION(kts:kte), INTENT(IN) :: dz, dfq, el, rho REAL, DIMENSION(kts:kte), INTENT(INOUT) :: pdk, pdt, pdq, pdc - REAL, INTENT(IN) :: flt, flq, ust, pmz, phh + REAL, INTENT(IN) :: flt, flq, pmz, phh + REAL(kind=kind_phys), INTENT(IN) :: ust, delt REAL, DIMENSION(kts:kte), INTENT(INOUT) :: qke,tsq, qsq, cov ! WA 8/3/15 REAL, DIMENSION(kts:kte+1), INTENT(INOUT) :: s_awqke,s_aw @@ -3716,22 +3716,22 @@ END SUBROUTINE mym_predict ! Set these values to those adopted by you. ! !------------------------------------------------------------------- -!>\ingroup gp_mynnedmf +!>\ingroup gsd_mynn_edmf !! This subroutine calculates the nonconvective component of the !! subgrid cloud fraction and mixing ratio as well as the functions used to !! calculate the buoyancy flux. Different cloud PDFs can be selected by !! use of the namelist parameter \p bl_mynn_cloudpdf . - SUBROUTINE mym_condensation (kts,kte, & - & dx, dz, zw, & - & thl, qw, qv, qc, qi, & - & p,exner, & - & tsq, qsq, cov, & - & Sh, el, bl_mynn_cloudpdf,& - & qc_bl1D, qi_bl1D, & - & cldfra_bl1D, & - & PBLH1,HFX1, & - & Vt, Vq, th, sgm, rmo, & - & spp_pbl,rstoch_col ) + SUBROUTINE mym_condensation (kts,kte, & + & dx, dz, zw, u1, v1, xland,& + & thl, qw, qv, qc, qi, & + & p,exner, & + & tsq, qsq, cov, & + & Sh, el, bl_mynn_cloudpdf, & + & qc_bl1D, qi_bl1D, & + & cldfra_bl1D, & + & PBLH1,HFX1, & + & Vt, Vq, th, sgm, rmo, & + & spp_pbl,rstoch_col ) !------------------------------------------------------------------- @@ -3742,11 +3742,12 @@ SUBROUTINE mym_condensation (kts,kte, & # define kte HARDCODE_VERTICAL #endif - REAL, INTENT(IN) :: dx,PBLH1,HFX1,rmo + REAL, INTENT(IN) :: HFX1,rmo,xland + REAL(kind=kind_phys), INTENT(IN) :: dx,pblh1 REAL, DIMENSION(kts:kte), INTENT(IN) :: dz REAL, DIMENSION(kts:kte+1), INTENT(IN) :: zw REAL, DIMENSION(kts:kte), INTENT(IN) :: p,exner,thl,qw,qv,qc,qi, & - &tsq, qsq, cov, th + &tsq, qsq, cov, th, u1, v1 REAL, DIMENSION(kts:kte), INTENT(INOUT) :: vt,vq,sgm @@ -3758,7 +3759,7 @@ SUBROUTINE mym_condensation (kts,kte, & REAL :: qsl,esat,qsat,dqsl,cld0,q1k,qlk,eq1,qll,& &q2p,pt,rac,qt,t,xl,rsl,cpm,Fng,qww,alpha,beta,bb,& &ls,wt,cld_factor,fac_damp,liq_frac,ql_ice,ql_water,& - &qmq,qsat_tk + &qmq,qsat_tk,wsp,wspfac INTEGER :: i,j,k REAL :: erf @@ -3769,7 +3770,8 @@ SUBROUTINE mym_condensation (kts,kte, & !variables for SGS BL clouds REAL :: zagl,damp,PBLH2 - REAL :: lfac + REAL :: cfmax + INTEGER, PARAMETER :: buoy_opt=1 ! 0: traditional SD77, 1: CB02,CB05 !JAYMES: variables for tropopause-height estimation REAL :: theta1, theta2, ht1, ht2 @@ -3971,80 +3973,69 @@ SUBROUTINE mym_condensation (kts,kte, & sgm(k) = SQRT( r3sq ) !Set limits on sigma relative to saturation water vapor sgm(k) = MIN( sgm(k), qsat_tk*0.666 ) !500 ) - sgm(k) = MAX( sgm(k), qsat_tk*0.040 ) !Note: 0.02 results in SWDOWN similar + sgm(k) = MAX( sgm(k), qsat_tk*0.035 ) !Note: 0.02 results in SWDOWN similar !to the first-order version of sigma q1(k) = qmq / sgm(k) ! Q1, the normalized saturation - - !Original C-B cloud fraction, allows cloud fractions out to q1 = -3.5 - cldfra_bl1D(K) = MAX(0., MIN(1., 0.5+0.36*ATAN(1.55*q1(k)))) ! Eq. 7 in CB02 - !This form only allows cloud fractions out to q1 = -1.8 - !cldfra_bl1D(K) = MAX(0., MIN(1., 0.5+0.41*ATAN(1.55*q1(k)))) - !This form only allows cloud fractions out to q1 = -1 - !cldfra_bl1D(K) = MAX(0., MIN(1., 0.5+0.50*ATAN(1.55*q1(k)))) - - END DO - - ! Specify hydrometeors - ! JAYMES- this option added 8 May 2015 - ! The cloud water formulations are taken from CB02, Eq. 8. - ! "fng" represents the non-Gaussian contribution to the liquid - ! water flux; these formulations are from Cuijpers and Bechtold - ! (1995), Eq. 7. CB95 also draws from Bechtold et al. 1995, - ! hereafter BCMT95 - zagl = 0. - DO k = kts,kte-1 - t = th(k)*exner(k) - q1k = q1(k) - zagl = zagl + dz(k) - - !CLOUD WATER AND ICE + q1k = q1(k) ! backup Q1 for later modification + + ! Specify cloud fraction + !Original C-B cloud fraction, allows cloud fractions out to q1 = -3.5 + !cldfra_bl1D(K) = max(0., min(1., 0.5+0.36*atan(1.55*q1(k)))) ! Eq. 7 in CB02 + !wayne's - over-diffuse, when limits removed from vt & vq & fng + !cldfra_bl1D(K) = max(0., min(1., 0.5+0.36*atan(1.2*(q1(k)+0.4)))) + !effort to reduce rh-dependency + !cldfra_bl1D(K) = max(0., min(1., 0.5+0.36*atan(2.9*(q1(k)+0.4)))) + cldfra_bl1D(K) = max(0., min(1., 0.5+0.36*atan(1.8*(q1(k)+0.4)))) + !moderate - best compromise?? + !cldfra_bl1D(K) = max(0., min(1., 0.5+0.36*atan(1.55*(q1(k)+0.2)))) + !closer to original for Q1 < -1, best for holding onto stratus, not good flowers + !cldfra_bl1D(K) = max(0., min(1., 0.5+0.36*atan(1.9*(q1(k)+0.4)))) + + + ! Specify hydrometeors + ! JAYMES- this option added 8 May 2015 + ! The cloud water formulations are taken from CB02, Eq. 8. IF (q1k < 0.) THEN !unsaturated -#ifdef SINGLE_PREC - ql_water = sgm(k)*EXP(1.2*q1k-1.) -#else ql_water = sgm(k)*EXP(1.2*q1k-1) -#endif ql_ice = sgm(k)*EXP(1.2*q1k-1.) ELSE IF (q1k > 2.) THEN !supersaturated ql_water = sgm(k)*q1k ql_ice = sgm(k)*q1k - !ql_ice = MIN(80.*qv(k),0.1)*sgm(k)*q1k ELSE !slightly saturated (0 > q1 < 2) ql_water = sgm(k)*(EXP(-1.) + 0.66*q1k + 0.086*q1k**2) ql_ice = sgm(k)*(EXP(-1.) + 0.66*q1k + 0.086*q1k**2) - !ql_ice = MIN(80.*qv(k),0.1)*sgm(k)*(EXP(-1.) + 0.66*q1k + 0.086*q1k**2) ENDIF - !In saturated grid cells, use average of current estimate and prev time step - IF ( qc(k) > 1.e-7 ) ql_water = 0.5 * ( ql_water + qc(k) ) - IF ( qi(k) > 1.e-9 ) ql_ice = 0.5 * ( ql_ice + qi(k) ) + !In saturated grid cells, use average of SGS and resolved values + if ( qc(k) > 1.e-7 ) ql_water = 0.5 * ( ql_water + qc(k) ) + if ( qi(k) > 1.e-9 ) ql_ice = 0.5 * ( ql_ice + qi(k) ) - IF (cldfra_bl1D(k) < 0.01) THEN + if (cldfra_bl1D(k) < 0.01) then ql_ice = 0.0 ql_water = 0.0 cldfra_bl1D(k) = 0.0 - ENDIF + endif !PHASE PARTITIONING: Make some inferences about the relative amounts of !subgrid cloud water vs. ice based on collocated explicit clouds. Otherise, !use a simple temperature-dependent partitioning. -! IF ( qc(k) + qi(k) > 0.0 ) THEN ! explicit condensate exists, retain its phase partitioning -! IF ( qi(k) == 0.0 ) THEN ! explicit contains no ice; assume subgrid liquid -! liq_frac = 1.0 -! ELSE IF ( qc(k) == 0.0 ) THEN ! explicit contains no liquid; assume subgrid ice -! liq_frac = 0.0 -! ELSE IF ( (qc(k) >= 1.E-10) .AND. (qi(k) >= 1.E-10) ) THEN ! explicit contains mixed phase of workably -! ! large amounts; assume subgrid follows -! ! same partioning -! liq_frac = qc(k) / ( qc(k) + qi(k) ) -! ELSE -! liq_frac = MIN(1.0, MAX(0.0, (t-tice)/(t0c-tice))) ! explicit contains mixed phase, but at least one -! ! species is very small, so make a temperature- -! ! depedent guess -! ENDIF -! ELSE ! no explicit condensate, so make a temperature-dependent guess - liq_frac = MIN(1.0, MAX(0.0, (t-tice)/(t0c-tice))) -! ENDIF + ! IF ( qc(k) + qi(k) > 0.0 ) THEN ! explicit condensate exists, retain its phase partitioning + ! IF ( qi(k) == 0.0 ) THEN ! explicit contains no ice; assume subgrid liquid + ! liq_frac = 1.0 + ! ELSE IF ( qc(k) == 0.0 ) THEN ! explicit contains no liquid; assume subgrid ice + ! liq_frac = 0.0 + ! ELSE IF ( (qc(k) >= 1.E-10) .AND. (qi(k) >= 1.E-10) ) THEN ! explicit contains mixed phase of workably + ! ! large amounts; assume subgrid follows + ! ! same partioning + ! liq_frac = qc(k) / ( qc(k) + qi(k) ) + ! ELSE + ! liq_frac = MIN(1.0, MAX(0.0, (t-tice)/(t0c-tice))) ! explicit contains mixed phase, but at least one + ! ! species is very small, so make a temperature- + ! ! depedent guess + ! ENDIF + ! ELSE ! no explicit condensate, so make a temperature-dependent guess + liq_frac = MIN(1.0, MAX(0.0, (t-tice)/(tliq-tice))) + ! ENDIF qc_bl1D(k) = liq_frac*ql_water ! apply liq_frac to ql_water and ql_ice qi_bl1D(k) = (1.0-liq_frac)*ql_ice @@ -4052,15 +4043,17 @@ SUBROUTINE mym_condensation (kts,kte, & !Above tropopause: eliminate subgrid clouds from CB scheme if (k .ge. k_tropo-1) then cldfra_bl1D(K) = 0. - qc_bl1D(k) = 0. - qi_bl1D(k) = 0. + qc_bl1D(k) = 0. + qi_bl1D(k) = 0. endif - ENDDO - - !Buoyancy-flux-related calculations follow... - DO k = kts,kte-1 - t = th(k)*exner(k) + !Buoyancy-flux-related calculations follow... + !limiting Q1 to avoid too much diffusion in cloud layers + if ((xland-1.5).GE.0) then ! water + q1k=max(Q1(k),-2.5) + else ! land + q1k=max(Q1(k),-2.0) + endif ! "Fng" represents the non-Gaussian transport factor ! (non-dimensional) from Bechtold et al. 1995 ! (hereafter BCMT95), section 3(c). Their suggested @@ -4072,8 +4065,7 @@ SUBROUTINE mym_condensation (kts,kte, & !ELSE ! Fng = 1.-1.5*q1k !ENDIF - !limiting to avoid mixing away stratus, was -5 - q1k=MAX(Q1(k),-1.0) + ! Use the form of "Fng" from Bechtold and Siebesma (1998, JAS) IF (q1k .GE. 1.0) THEN Fng = 1.0 ELSEIF (q1k .GE. -1.7 .AND. q1k .LT. 1.0) THEN @@ -4083,42 +4075,70 @@ SUBROUTINE mym_condensation (kts,kte, & ELSE Fng = MIN(23.9 + EXP(-1.6*(q1k+2.5)), 60.) ENDIF - Fng = MIN(Fng, 20.) - - xl = xl_blend(t) - bb = b(k)*t/th(k) ! bb is "b" in BCMT95. Their "b" differs from - ! "b" in CB02 (i.e., b(k) above) by a factor - ! of T/theta. Strictly, b(k) above is formulated in - ! terms of sat. mixing ratio, but bb in BCMT95 is - ! cast in terms of sat. specific humidity. The - ! conversion is neglected here. - qww = 1.+0.61*qw(k) - alpha = 0.61*th(k) - beta = (th(k)/t)*(xl/cp) - 1.61*th(k) - vt(k) = qww - MIN(cldfra_bl1D(K),0.5)*beta*bb*Fng - 1. - vq(k) = alpha + MIN(cldfra_bl1D(K),0.5)*beta*a(k)*Fng - tv0 - ! vt and vq correspond to beta-theta and beta-q, respectively, - ! in NN09, Eq. B8. They also correspond to the bracketed - ! expressions in BCMT95, Eq. 15, since (s*ql/sigma^2) = cldfra*Fng - ! The "-1" and "-tv0" terms are included for consistency with - ! the legacy vt and vq formulations (above). + + if (buoy_opt .eq. 1) then + cfmax= min(cldfra_bl1D(K), 0.6) + bb = b(k)*t/th(k) ! bb is "b" in BCMT95. Their "b" differs from + ! "b" in CB02 (i.e., b(k) above) by a factor + ! of T/theta. Strictly, b(k) above is formulated in + ! terms of sat. mixing ratio, but bb in BCMT95 is + ! cast in terms of sat. specific humidity. The + ! conversion is neglected here. + qww = 1.+0.61*qw(k) + alpha = 0.61*th(k) + beta = (th(k)/t)*(xl/cp) - 1.61*th(k) + vt(k) = qww - cfmax*beta*bb*Fng - 1. + vq(k) = alpha + cfmax*beta*a(k)*Fng - tv0 + ! vt and vq correspond to beta-theta and beta-q, respectively, + ! in NN09, Eq. B8. They also correspond to the bracketed + ! expressions in BCMT95, Eq. 15, since (s*ql/sigma^2) = cldfra*Fng + ! The "-1" and "-tv0" terms are included for consistency with + ! the legacy vt and vq formulations (above). + else + + !original buoyancy flux functions from SD77 + eq1 = rrp*exp( -0.5*q1k*q1k ) + qll = max( cldfra_bl1D(k)*q1k + eq1, 0.0 ) + q2p = xl/cp/exner(k) + + !qt is a THETA-V CONVERSION FOR TOTAL WATER + cfmax= min(cldfra_bl1D(K), 0.6) + qt = 1.0 +p608*qw(k) -(1.+p608)*(qc_bl1D(k)+qi_bl1D(k))*cfmax + rac = alp(k)*( cfmax-qll*eq1 )*( q2p*qt-(1.+p608)*th(k) ) + + !BUOYANCY FACTORS: wherever vt and vq are used, there is a + !"+1" and "+tv0", respectively, so these are subtracted out here. + !vt is unitless and vq has units of K. + vt(k) = qt-1.0 -rac*bet(k) + vq(k) = p608*th(k)-tv0 +rac + endif ! dampen the amplification factor (cld_factor) with height in order ! to limit excessively large cloud fractions aloft !fac_damp = 1.! -MIN(MAX( zagl-(PBLH2+1000.),0.0)/ & ! MAX((zw(k_tropo)-(PBLH2+1000.)),500.), 1.) - fac_damp = min(zagl * 0.01, 1.0) + !fac_damp = min(zagl * 0.01, 1.0) + wsp =sqrt(u1(k)**2 + v1(k)**2) + wspfac = 1.0 - min(max(0.,wsp-15),10.)/10. ! reduce as winds go from 15 to 25 m/s. + fac_damp = min(zagl * 0.0025, 1.0)*wspfac !cld_factor = 1.0 + fac_damp*MAX(0.0, ( RH(k) - 0.5 ) / 0.51 )**3.3 !cld_factor = 1.0 + fac_damp*MAX(0.0, ( RH(k) - 0.75 ) / 0.26 )**1.9 !HRRRv4 !cld_factor = 1.0 + fac_damp*(MAX(0.0, ( RH(k) - 0.80 )) / 0.22 )**2 - cld_factor = 1.0 + fac_damp*(MAX(0.0, ( RH(k) - 0.90 )) / 0.11 )**2 - !cld_factor = 1.0 + !cld_factor = 1.0 + fac_damp*(MAX(0.0, ( RH(k) - 0.90 )) / 0.11 )**2 + !cld_factor = 1.0 + fac_damp*1.8*(max(0.0, q1k + 0.2 ))**2 !too low of albedo + !cld_factor = 1.0 + fac_damp*1.8*(max(0.0, q1k + 0.2 ))**2 + !make this enhancement over water only? + !if ((xland-1.5).GE.0) then ! water + cld_factor = 1.0 + fac_damp*min((max(0.0, ( RH(k) - 0.92 )) / 0.25 )**2, 0.3) + !else + ! cld_factor = 1.0 + !endif cldfra_bl1D(K) = MIN( 1., cld_factor*cldfra_bl1D(K) ) - ENDDO + enddo END SELECT !end cloudPDF option - !FOR TESTING PURPOSES ONLY, ISOLATE ON THE MASS-CLOUDS. + !For testing purposes only, option for isolating on the mass-flux clouds. IF (bl_mynn_cloudpdf .LT. 0) THEN DO k = kts,kte-1 cldfra_bl1D(k) = 0.0 @@ -4143,11 +4163,10 @@ SUBROUTINE mym_condensation (kts,kte, & END SUBROUTINE mym_condensation ! ================================================================== -!>\ingroup gp_mynnedmf +!>\ingroup gsd_mynn_edmf !! This subroutine solves for tendencies of U, V, \f$\theta\f$, qv, !! qc, and qi SUBROUTINE mynn_tendencies(kts,kte,i, & - &closure, & &delt,dz,rho, & &u,v,th,tk,qv,qc,qi,qnc,qni, & &psfc,p,exner, & @@ -4160,7 +4179,7 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & &dfm,dfh,dfq, & &Du,Dv,Dth,Dqv,Dqc,Dqi,Dqnc,Dqni, & &Dqnwfa,Dqnifa,Dozone, & - &vdfg1,diss_heat, & + &diss_heat, & &s_aw,s_awthl,s_awqt,s_awqv,s_awqc, & &s_awu,s_awv, & &s_awqnc,s_awqni, & @@ -4188,7 +4207,6 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & # define kte HARDCODE_VERTICAL #endif - REAL, INTENT(in) :: closure INTEGER, INTENT(in) :: bl_mynn_cloudmix,bl_mynn_mixqt,& bl_mynn_edmf,bl_mynn_edmf_mom, & bl_mynn_mixscalars @@ -4215,10 +4233,10 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & &qnwfa,qnifa,ozone,dfm,dfh REAL, DIMENSION(kts:kte), INTENT(inout) :: du,dv,dth,dqv,dqc,dqi,& &dqni,dqnc,dqnwfa,dqnifa,dozone - REAL, INTENT(IN) :: delt,ust,flt,flq,flqv,flqc,wspd,uoce,voce,& - &psfc + REAL, INTENT(IN) :: flt,flq,flqv,flqc,uoce,voce + REAL(kind=kind_phys), INTENT(IN) :: ust,delt,psfc,wspd !debugging - REAL ::wsp,wsp2 + REAL ::wsp,wsp2,tk2,th2 LOGICAL :: problem integer :: kproblem @@ -4234,7 +4252,6 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & REAL, DIMENSION(kts:kte+1) :: rhoz, & !rho on model interface & khdz, kmdz REAL :: rhs,gfluxm,gfluxp,dztop,maxdfh,mindfh,maxcf,maxKh,zw - REAL :: vdfg1 !Katata-fogdes REAL :: t,esat,qsl,onoff,kh,km,dzk,rhosfc REAL :: ustdrag,ustdiff,qvflux REAL :: th_new,portion_qc,portion_qi,condensate,qsat @@ -4352,7 +4369,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=u(kte) ! CALL tridiag(kte,a,b,c,d) - CALL tridiag3(kte,a,b,c,d,x) + CALL tridiag2(kte,a,b,c,d,x) +! CALL tridiag3(kte,a,b,c,d,x) DO k=kts,kte ! du(k)=(d(k-kts+1)-u(k))/delt @@ -4416,7 +4434,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=v(kte) ! CALL tridiag(kte,a,b,c,d) - CALL tridiag3(kte,a,b,c,d,x) + CALL tridiag2(kte,a,b,c,d,x) +! CALL tridiag3(kte,a,b,c,d,x) DO k=kts,kte ! dv(k)=(d(k-kts+1)-v(k))/delt @@ -4483,8 +4502,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=thl(kte) ! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,x) - CALL tridiag3(kte,a,b,c,d,x) + CALL tridiag2(kte,a,b,c,d,x) +! CALL tridiag3(kte,a,b,c,d,x) DO k=kts,kte !thl(k)=d(k-kts+1) @@ -4546,8 +4565,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=sqw(kte) ! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,sqw2) - CALL tridiag3(kte,a,b,c,d,sqw2) + CALL tridiag2(kte,a,b,c,d,sqw2) +! CALL tridiag3(kte,a,b,c,d,sqw2) ! DO k=kts,kte ! sqw2(k)=d(k-kts+1) @@ -4603,8 +4622,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=sqc(kte) ! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,sqc2) - CALL tridiag3(kte,a,b,c,d,sqc2) + CALL tridiag2(kte,a,b,c,d,sqc2) +! CALL tridiag3(kte,a,b,c,d,sqc2) ! DO k=kts,kte ! sqc2(k)=d(k-kts+1) @@ -4681,8 +4700,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=sqv(kte) ! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,sqv2) - CALL tridiag3(kte,a,b,c,d,sqv2) + CALL tridiag2(kte,a,b,c,d,sqv2) +! CALL tridiag3(kte,a,b,c,d,sqv2) ! DO k=kts,kte ! sqv2(k)=d(k-kts+1) @@ -4743,8 +4762,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=sqi(kte) ! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,sqi2) - CALL tridiag3(kte,a,b,c,d,sqi2) + CALL tridiag2(kte,a,b,c,d,sqi2) +! CALL tridiag3(kte,a,b,c,d,sqi2) ! DO k=kts,kte ! sqi2(k)=d(k-kts+1) @@ -4781,8 +4800,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=qni(kte) ! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,x) - CALL tridiag3(kte,a,b,c,d,x) + CALL tridiag2(kte,a,b,c,d,x) +! CALL tridiag3(kte,a,b,c,d,x) DO k=kts,kte !qni2(k)=d(k-kts+1) @@ -4799,6 +4818,7 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & !!============================================ IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNC .AND. & bl_mynn_mixscalars > 0) THEN + k=kts a(k)= -dtz(k)*khdz(k)*rhoinv(k) @@ -4821,8 +4841,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=qnc(kte) ! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,x) - CALL tridiag3(kte,a,b,c,d,x) + CALL tridiag2(kte,a,b,c,d,x) +! CALL tridiag3(kte,a,b,c,d,x) DO k=kts,kte !qnc2(k)=d(k-kts+1) @@ -4862,8 +4882,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=qnwfa(kte) ! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,x) - CALL tridiag3(kte,a,b,c,d,x) + CALL tridiag2(kte,a,b,c,d,x) +! CALL tridiag3(kte,a,b,c,d,x) DO k=kts,kte !qnwfa2(k)=d(k) @@ -4904,8 +4924,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=qnifa(kte) ! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,x) - CALL tridiag3(kte,a,b,c,d,x) + CALL tridiag2(kte,a,b,c,d,x) +! CALL tridiag3(kte,a,b,c,d,x) DO k=kts,kte !qnifa2(k)=d(k-kts+1) @@ -4943,8 +4963,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & d(kte)=ozone(kte) ! CALL tridiag(kte,a,b,c,d) -! CALL tridiag2(kte,a,b,c,d,x) - CALL tridiag3(kte,a,b,c,d,x) + CALL tridiag2(kte,a,b,c,d,x) +! CALL tridiag3(kte,a,b,c,d,x) DO k=kts,kte !ozone2(k)=d(k-kts+1) @@ -5136,21 +5156,28 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & do k=kts,kte wsp = sqrt(u(k)**2 + v(k)**2) wsp2 = sqrt((u(k)+du(k)*delt)**2 + (v(k)+du(k)*delt)**2) - if (wsp2 > 200.) then + th2 = th(k) + Dth(k)*delt + tk2 = th2*exner(k) + if (wsp2 > 200. .or. tk2 > 360. .or. tk2 < 160.) then problem = .true. - print*,"Huge wind speed: i=",i," k=",k," wsp=",wsp2 - print*," du=",du(k)*delt," dv=",dv(k)*delt + print*,"Outgoing problem at: i=",i," k=",k + print*," incoming wsp=",wsp," outgoing wsp=",wsp2 + print*," incoming T=",th(k)*exner(k),"outgoing T:",tk2 + print*," du=",du(k)*delt," dv=",dv(k)*delt," dth=",dth(k)*delt print*," km=",kmdz(k)*dz(k)," kh=",khdz(k)*dz(k) print*," u*=",ust," wspd=",wspd,"rhosfc=",rhosfc + print*," LH=",flq*rhosfc*1004.," HFX=",flt*rhosfc*1004. print*," drag term=",ust**2/wspd*dtz(k)*rhosfc/rho(kts) kproblem = k endif enddo if (problem) then - print*,"=temp:",thl(max(kproblem-5,1):min(kproblem+5,kte)) - print*,"===qv:",sqv(max(kproblem-5,1):min(kproblem+5,kte)) - print*,"====u:",u(max(kproblem-5,1):min(kproblem+5,kte)) - print*,"====v:",v(max(kproblem-5,1):min(kproblem+5,kte)) + print*,"==thl:",thl(max(kproblem-3,1):min(kproblem+3,kte)) + print*,"===qv:",sqv2(max(kproblem-3,1):min(kproblem+3,kte)) + print*,"===qc:",sqc2(max(kproblem-3,1):min(kproblem+3,kte)) + print*,"===qi:",sqi2(max(kproblem-3,1):min(kproblem+3,kte)) + print*,"====u:",u(max(kproblem-3,1):min(kproblem+3,kte)) + print*,"====v:",v(max(kproblem-3,1):min(kproblem+3,kte)) endif endif @@ -5162,8 +5189,6 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & END SUBROUTINE mynn_tendencies ! ================================================================== -!>\ingroup gp_mynnedmf -!!ensure non-negative moist species. SUBROUTINE moisture_check(kte, delt, dp, exner, & qv, qc, qi, th, & dqv, dqc, dqi, dth ) @@ -5183,7 +5208,7 @@ SUBROUTINE moisture_check(kte, delt, dp, exner, & implicit none integer, intent(in) :: kte - real, intent(in) :: delt + real(kind=kind_phys), intent(in) :: delt real, dimension(kte), intent(in) :: dp, exner real, dimension(kte), intent(inout) :: qv, qc, qi, th real, dimension(kte), intent(inout) :: dqv, dqc, dqi, dth @@ -5251,8 +5276,6 @@ END SUBROUTINE moisture_check ! ================================================================== -!>\ingroup gp_mynnedmf -!! SUBROUTINE mynn_mix_chem(kts,kte,i, & delt,dz,pblh, & nchem, kdvel, ndvel, & @@ -5261,26 +5284,27 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, & flt, tcd, qcd, & dfh, & s_aw, s_awchem, & - emis_ant_no,frp, & - fire_turb ) + emis_ant_no, frp, rrfs_sd, & + enh_mix, smoke_dbg ) !------------------------------------------------------------------- INTEGER, INTENT(in) :: kts,kte,i REAL, DIMENSION(kts:kte), INTENT(IN) :: dfh,dz,tcd,qcd REAL, DIMENSION(kts:kte), INTENT(INOUT) :: rho - REAL, INTENT(IN) :: delt,flt + REAL, INTENT(IN) :: flt + REAL(kind=kind_phys), INTENT(IN) :: delt,pblh INTEGER, INTENT(IN) :: nchem, kdvel, ndvel REAL, DIMENSION( kts:kte+1), INTENT(IN) :: s_aw REAL, DIMENSION( kts:kte, nchem ), INTENT(INOUT) :: chem1 REAL, DIMENSION( kts:kte+1,nchem), INTENT(IN) :: s_awchem REAL, DIMENSION( ndvel ), INTENT(IN) :: vd1 - REAL, INTENT(IN) :: emis_ant_no,frp,pblh - LOGICAL, INTENT(IN) :: fire_turb + REAL(kind=kind_phys), INTENT(IN) :: emis_ant_no,frp + LOGICAL, INTENT(IN) :: rrfs_sd,enh_mix,smoke_dbg !local vars REAL, DIMENSION(kts:kte) :: dtz - REAL, DIMENSION(1:kte-kts+1) :: a,b,c,d,x + REAL, DIMENSION(kts:kte) :: a,b,c,d,x REAL :: rhs,dztop REAL :: t,dzk REAL :: hght @@ -5292,8 +5316,8 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, & REAL, DIMENSION(kts:kte) :: rhoinv REAL, DIMENSION(kts:kte+1) :: rhoz,khdz - REAL, PARAMETER :: no_threshold = 0.1 - REAL, PARAMETER :: frp_threshold = 10.0 ! RAR 02/11/22: I increased the frp threshold to enhance mixing + REAL, PARAMETER :: NO_threshold = 0.1 ! For anthropogenic sources + REAL, PARAMETER :: frp_threshold = 10.0 ! RAR 02/11/22: I increased the frp threshold to enhance mixing over big fires REAL, PARAMETER :: pblh_threshold = 250.0 dztop=.5*(dz(kte)+dz(kte-1)) @@ -5324,18 +5348,19 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, & khdz(k) = MAX(khdz(k), -0.5*(s_aw(k)-s_aw(k+1))) ENDDO - !Enhance diffusion over fires - IF ( fire_turb ) THEN + !Enhanced mixing over fires + IF ( rrfs_sd .and. enh_mix ) THEN DO k=kts+1,kte-1 khdz_old = khdz(k) khdz_back = pblh * 0.15 / dz(k) !Modify based on anthropogenic emissions of NO and FRP IF ( pblh < pblh_threshold ) THEN - IF ( emis_ant_no > no_threshold ) THEN - khdz(k) = MAX(1.1*khdz(k),sqrt((emis_ant_no / no_threshold)) / dz(k) * rhoz(k)) ! JLS 12/21/21 + IF ( emis_ant_no > NO_threshold ) THEN + khdz(k) = MAX(1.1*khdz(k),sqrt((emis_ant_no / NO_threshold)) / dz(k) * rhoz(k)) ! JLS 12/21/21 ! khdz(k) = MAX(khdz(k),khdz_back) ENDIF IF ( frp > frp_threshold ) THEN + kmaxfire = ceiling(log(frp)) khdz(k) = MAX(1.1*khdz(k), (1. - k/(kmaxfire*2.)) * ((log(frp))**2.- 2.*log(frp)) / dz(k)*rhoz(k)) ! JLS 12/21/21 ! khdz(k) = MAX(khdz(k),khdz_back) ENDIF @@ -5354,7 +5379,7 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, & b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) d(k)=chem1(k,ic) & !dtz(k)*flt !neglecting surface sources - & + dtz(k) * -vd1(ic)*chem1(1,ic) & + & - dtz(k)*vd1(ic)*chem1(k,ic) & & - dtz(k)*rhoinv(k)*s_awchem(k+1,ic) DO k=kts+1,kte-1 @@ -5371,11 +5396,14 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, & c(kte)=0. d(kte)=chem1(kte,ic) - !CALL tridiag(kte,a,b,c,d) CALL tridiag3(kte,a,b,c,d,x) + IF ( smoke_dbg ) THEN + print*,'aerosol mixing ic,chem1,chem2(k,ic)',ic,(chem1(kts:kts+10,ic)),(x(kts:kts+10)) + print*,'aerosol PBL mixing ic,vd1(ic)',ic,vd1(ic) + END IF + DO k=kts,kte - !chem_new(k,ic)=d(k) chem1(k,ic)=x(k) ENDDO ENDDO @@ -5383,7 +5411,7 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, & END SUBROUTINE mynn_mix_chem ! ================================================================== -!>\ingroup gp_mynnedmf +!>\ingroup gsd_mynn_edmf SUBROUTINE retrieve_exchange_coeffs(kts,kte,& &dfm,dfh,dz,K_m,K_h) @@ -5411,7 +5439,7 @@ SUBROUTINE retrieve_exchange_coeffs(kts,kte,& END SUBROUTINE retrieve_exchange_coeffs ! ================================================================== -!>\ingroup gp_mynnedmf +!>\ingroup gsd_mynn_edmf SUBROUTINE tridiag(n,a,b,c,d) !! to solve system of linear eqs on tridiagonal matrix n times n @@ -5447,7 +5475,7 @@ SUBROUTINE tridiag(n,a,b,c,d) END SUBROUTINE tridiag ! ================================================================== -!>\ingroup gp_mynnedmf +!>\ingroup gsd_mynn_edmf subroutine tridiag2(n,a,b,c,d,x) implicit none ! a - sub-diagonal (means it is the diagonal below the main diagonal) @@ -5482,7 +5510,7 @@ subroutine tridiag2(n,a,b,c,d,x) end subroutine tridiag2 ! ================================================================== -!>\ingroup gp_mynnedmf +!>\ingroup gsd_mynn_edmf subroutine tridiag3(kte,a,b,c,d,x) !ccccccccccccccccccccccccccccccc @@ -5525,8 +5553,7 @@ end subroutine tridiag3 ! ================================================================== -!>\ingroup gp_mynnedmf -!! +!>\ingroup gsd_mynn_edmf SUBROUTINE mynn_bl_init_driver( & &RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN, & &RQCBLTEN,RQIBLTEN & !,RQNIBLTEN,RQNCBLTEN & @@ -5582,7 +5609,7 @@ SUBROUTINE mynn_bl_init_driver( & END SUBROUTINE mynn_bl_init_driver ! ================================================================== -!>\ingroup gp_mynnedmf +!>\ingroup gsd_mynn_edmf !! This subroutine calculates hybrid diagnotic boundary-layer height (PBLH). !! !! NOTES ON THE PBLH FORMULATION: The 1.5-theta-increase method defines @@ -5627,7 +5654,7 @@ SUBROUTINE GET_PBLH(KTS,KTE,zi,thetav1D,qke1D,zw1D,dz1D,landsea,kzi) # define kte HARDCODE_VERTICAL #endif - REAL, INTENT(OUT) :: zi + REAL(kind=kind_phys), INTENT(OUT) :: zi REAL, INTENT(IN) :: landsea REAL, DIMENSION(KTS:KTE), INTENT(IN) :: thetav1D, qke1D, dz1D REAL, DIMENSION(KTS:KTE+1), INTENT(IN) :: zw1D @@ -5744,7 +5771,8 @@ SUBROUTINE GET_PBLH(KTS,KTE,zi,thetav1D,qke1D,zw1D,dz1D,landsea,kzi) END SUBROUTINE GET_PBLH !> @} -!>\ingroup gp_mynnedmf +! ================================================================== +!>\ingroup gsd_mynn_edmf !! This subroutine is the Dynamic Multi-Plume (DMP) Mass-Flux Scheme. !! !! dmp_mf() calculates the nonlocal turbulent transport from the dynamic @@ -5818,8 +5846,9 @@ SUBROUTINE DMP_mf( & REAL,DIMENSION(KTS:KTE), INTENT(IN) :: U,V,W,TH,THL,TK,QT,QV,QC,& exner,dz,THV,P,rho,qke,qnc,qni,qnwfa,qnifa REAL,DIMENSION(KTS:KTE+1), INTENT(IN) :: ZW !height at full-sigma - REAL, INTENT(IN) :: DT,UST,FLT,FLTV,FLQ,FLQV,PBLH,& - DX,Psig_shcu,landsea,ts + REAL, INTENT(IN) :: FLT,FLTV,FLQ,FLQV,& + Psig_shcu,landsea,ts + REAL(kind=kind_phys), INTENT(IN) :: dx,dt,ust,pblh LOGICAL, OPTIONAL :: F_QC,F_QI,F_QNC,F_QNI,F_QNWFA,F_QNIFA ! outputs - updraft properties @@ -5829,7 +5858,8 @@ SUBROUTINE DMP_mf( & REAL,DIMENSION(KTS:KTE) :: edmf_th ! output INTEGER, INTENT(OUT) :: nup2,ktop - REAL, INTENT(OUT) :: maxmf,ztop + REAL(kind=kind_phys), INTENT(OUT) :: maxmf + REAL, INTENT(OUT) :: ztop ! outputs - variables needed for solver REAL,DIMENSION(KTS:KTE+1) :: s_aw, & !sum ai*rho*wis_awphi s_awthl, & !sum ai*rho*wi*phii @@ -5847,7 +5877,7 @@ SUBROUTINE DMP_mf( & REAL,DIMENSION(KTS:KTE), INTENT(INOUT) :: qc_bl1d,cldfra_bl1d, & qc_bl1d_old,cldfra_bl1d_old - INTEGER, PARAMETER :: NUP=10, debug_mf=0 + INTEGER, PARAMETER :: nup=10, debug_mf=0 !------------- local variables ------------------- ! updraft properties defined on interfaces (k=1 is the top of the @@ -5863,7 +5893,7 @@ SUBROUTINE DMP_mf( & REAL :: fltv2,wstar,qstar,thstar,sigmaW,sigmaQT,sigmaTH,z0, & pwmin,pwmax,wmin,wmax,wlv,Psig_w,maxw,maxqc,wpbl REAL :: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,QNCn,QNIn,QNWFAn,QNIFAn, & - Wn2,Wn,EntEXP,EntEXM,EntW,BCOEFF,THVkm1,THVk,Pk,rho_int + Wn2,Wn,EntEXP,EntEXM,EntW,BCOEFF,THVkm1,THVk,Pk,qtk,rho_int ! w parameters REAL,PARAMETER :: & @@ -5904,13 +5934,14 @@ SUBROUTINE DMP_mf( & ! VARIABLES FOR CHABOUREAU-BECHTOLD CLOUD FRACTION REAL,DIMENSION(KTS:KTE), INTENT(INOUT) :: vt, vq, sgm - REAL :: sigq,xl,rsl,cpm,a,qmq,mf_cf,Q1,diffqt,qsat_tk,& + REAL :: sigq,xl,rsl,cpm,a,qmq,mf_cf,Aup,Q1,diffqt,qsat_tk,& Fng,qww,alpha,beta,bb,f,pt,t,q2p,b9,satvp,rhgrid, & Ac_mf,Ac_strat,qc_mf + REAL, PARAMETER :: cf_thresh = 0.5 ! only overwrite stratus CF less than this value ! Variables for plume interpolation/saturation check REAL,DIMENSION(KTS:KTE) :: exneri,dzi - REAL :: THp, QTp, QCp, QCs, esat, qsl + REAL :: THp, QTp, QCp, QCs, esat, qsl REAL :: csigma,acfac,ac_wsp,ac_cld !plume overshoot @@ -5931,7 +5962,7 @@ SUBROUTINE DMP_mf( & REAL,DIMENSION(KTS:KTE+1) :: envi_a,envi_w !environmental variables defined at model interface REAL :: temp,sublim,qc_ent,qv_ent,qt_ent,thl_ent,detrate, & detrateUV,oow,exc_fac,aratio,detturb,qc_grid,qc_sgs,& - qc_plume + qc_plume,exc_heat,exc_moist,tk_int REAL, PARAMETER :: Cdet = 1./45. REAL, PARAMETER :: dzpmax = 300. !limit dz used in detrainment - can be excessing in thick layers !parameter "Csub" determines the propotion of upward vertical velocity that contributes to @@ -6200,13 +6231,28 @@ SUBROUTINE DMP_mf( & UPV(1,I)=(V(KTS)*DZ(KTS+1)+V(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) UPQC(1,I)=0.0 !UPQC(1,I)=(QC(KTS)*DZ(KTS+1)+QC(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) - UPQT(1,I)=(QT(KTS)*DZ(KTS+1)+QT(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))& - & +exc_fac*UPW(1,I)*sigmaQT/sigmaW + + exc_heat = exc_fac*UPW(1,I)*sigmaTH/sigmaW UPTHV(1,I)=(THV(KTS)*DZ(KTS+1)+THV(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) & - & +exc_fac*UPW(1,I)*sigmaTH/sigmaW + & + exc_heat !was UPTHL(1,I)= UPTHV(1,I)/(1.+svp1*UPQT(1,I)) !assume no saturated parcel at surface UPTHL(1,I)=(THL(KTS)*DZ(KTS+1)+THL(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) & - & +exc_fac*UPW(1,I)*sigmaTH/sigmaW + & + exc_heat + + !calculate exc_moist by use of surface fluxes + exc_moist=exc_fac*UPW(1,I)*sigmaQT/sigmaW + !calculate exc_moist by conserving rh: +! tk_int =(tk(kts)*dz(kts+1)+tk(kts+1)*dz(kts))/(dz(kts+1)+dz(kts)) +! pk =(p(kts)*dz(kts+1)+p(kts+1)*dz(kts))/(dz(kts+1)+dz(kts)) +! qtk =(qt(kts)*dz(kts+1)+qt(kts+1)*dz(kts))/(dz(kts)+dz(kts+1)) +! qsat_tk = qsat_blend(tk_int, pk) ! saturation water vapor mixing ratio at tk and p +! rhgrid =MAX(MIN(1.0,qtk/MAX(1.E-8,qsat_tk)),0.001) +! tk_int = tk_int + exc_heat +! qsat_tk = qsat_blend(tk_int, pk) +! exc_moist= max(rhgrid*qsat_tk - qtk, 0.0) + UPQT(1,I)=(QT(KTS)*DZ(KTS+1)+QT(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))& + & +exc_moist + UPQKE(1,I)=(QKE(KTS)*DZ(KTS+1)+QKE(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) UPQNC(1,I)=(QNC(KTS)*DZ(KTS+1)+QNC(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) UPQNI(1,I)=(QNI(KTS)*DZ(KTS+1)+QNI(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) @@ -6299,14 +6345,14 @@ SUBROUTINE DMP_mf( & !Vn =V(K) *(1-EntExp)+UPV(K-1,I)*EntExp !QKEn=QKE(k)*(1-EntExp)+UPQKE(K-1,I)*EntExp - IF ( mix_chem ) THEN + if ( mix_chem ) then do ic = 1,nchem ! Exponential Entrainment: !chemn(ic) = chem(k,ic)*(1-EntExp)+UPCHEM(K-1,I,ic)*EntExp ! Linear entrainment: chemn(ic)=UPCHEM(k-1,i,ic)*(1.-EntExp) + chem1(k,ic)*EntExp enddo - ENDIF + endif ! Define pressure at model interface Pk =(P(k)*DZ(k+1)+P(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) @@ -6479,7 +6525,7 @@ SUBROUTINE DMP_mf( & s_awthl(k+1)= s_awthl(k+1) + rho_int*UPA(K,i)*UPW(K,i)*UPTHL(K,i)*Psig_w s_awqt(k+1) = s_awqt(k+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQT(K,i)*Psig_w !to conform to grid mean properties, move qc to qv in grid mean - !saturated layers, so total water fluxes are preserve but + !saturated layers, so total water fluxes are preserved but !negative qc fluxes in unsaturated layers is reduced. IF (qc(k) > 1e-12 .OR. qc(k+1) > 1e-12) then qc_plume = UPQC(K,i) @@ -6697,22 +6743,22 @@ SUBROUTINE DMP_mf( & ! mym_condensation. Here, a shallow-cu component is added, but no cumulus ! clouds can be added at k=1 (start loop at k=2). DO K=KTS+1,KTE-2 - IF(k > KTOP) exit - IF(0.5*(edmf_qc(k)+edmf_qc(k-1))>0.0)THEN - - !interpolate plume thl, th, and qt to mass levels + IF(k > KTOP) exit + IF(0.5*(edmf_qc(k)+edmf_qc(k-1))>0.0)THEN + !interpolate plume quantities to mass levels + Aup = (edmf_a(k)*dzi(k-1)+edmf_a(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) THp = (edmf_th(k)*dzi(k-1)+edmf_th(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) QTp = (edmf_qt(k)*dzi(k-1)+edmf_qt(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) !convert TH to T - t = THp*exner(k) +! t = THp*exner(k) !SATURATED VAPOR PRESSURE - esat = esat_blend(t) + esat = esat_blend(tk(k)) !SATURATED SPECIFIC HUMIDITY - qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) + qsl=ep_2*esat/max(1.e-7,(p(k)-ep_3*esat)) !condensed liquid in the plume on mass levels IF (edmf_qc(k)>0.0 .AND. edmf_qc(k-1)>0.0)THEN - QCp = 0.5*(edmf_qc(k)+edmf_qc(k-1)) + QCp = (edmf_qc(k)*dzi(k-1)+edmf_qc(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) ELSE QCp = MAX(edmf_qc(k),edmf_qc(k-1)) ENDIF @@ -6728,7 +6774,7 @@ SUBROUTINE DMP_mf( & b9 = a*rsl ! CB02 variable "b" q2p = xlvcp/exner(k) - pt = thl(k) +q2p*QCp*0.5*(edmf_a(k)+edmf_a(k-1)) ! potential temp (env + plume) + pt = thl(k) +q2p*QCp*Aup ! potential temp (env + plume) bb = b9*tk(k)/pt ! bb is "b9" in BCMT95. Their "b9" differs from ! "b9" in CB02 by a factor ! of T/theta. Strictly, b9 above is formulated in @@ -6748,17 +6794,32 @@ SUBROUTINE DMP_mf( & endif !CB form: - !sigq = 9.E-3 * 0.5*(edmf_a(k)+edmf_a(k-1)) * & - ! & 0.5*(edmf_w(k)+edmf_w(k-1)) * f ! convective component of sigma (CB2005) + sigq = 3.5E-3 * Aup * 0.5*(edmf_w(k)+edmf_w(k-1)) * f ! convective component of sigma (CB2005) !sigq = SQRT(sigq**2 + sgm(k)**2) ! combined conv + stratus components !Per S.DeRoode 2009? - sigq = 10. * edmf_a(k) * (edmf_qt(k)-qt(k)) - - sigq = MAX(sigq, 1.0E-6) + !sigq = 4. * Aup * (QTp - qt(k)) + !constrain sigq wrt saturation: + sigq = max(sigq, qsat_tk*0.02 ) + sigq = min(sigq, qsat_tk*0.25 ) qmq = a * (qt(k) - qsat_tk) ! saturation deficit/excess; - ! the numerator of Q1 - mf_cf= min(max(0.5 + 0.36 * atan(1.55*(qmq/sigq)),0.01),0.6) + Q1 = qmq/sigq ! the numerator of Q1 + + if ((landsea-1.5).GE.0) then ! WATER + mf_cf = min(max(0.5 + 0.36 * atan(1.20*(Q1+0.2)),0.01),0.6) + mf_cf = max(mf_cf, 1.2 * Aup) + else ! LAND + !mf_cf= min(max(0.5 + 0.36 * atan(1.55*(qmq/sigq)),0.01),0.6) + mf_cf = min(max(0.5 + 0.36 * atan(1.20*(Q1+0.4)),0.01),0.6) ! New WA fit + mf_cf = max(mf_cf, 1.75 * Aup) + endif + + ! WA TEST 4/15/22 use fit to Aup rather than CB + !IF (Aup > 0.1) THEN + ! mf_cf = 2.5 * Aup + !ELSE + ! mf_cf = 1.8 * Aup + !ENDIF !IF ( debug_code ) THEN ! print*,"In MYNN, StEM edmf" @@ -6769,61 +6830,64 @@ SUBROUTINE DMP_mf( & !ENDIF ! Update cloud fractions and specific humidities in grid cells - ! where the mass-flux scheme is active. Now, we also use the - ! stratus component of the SGS clouds as well. The stratus cloud - ! fractions (Ac_strat) are reduced slightly to give way to the - ! mass-flux SGS cloud fractions (Ac_mf). - IF (cldfra_bl1d(k) < 0.5) THEN - IF (mf_cf > 0.5*(edmf_a(k)+edmf_a(k-1))) THEN - !cldfra_bl1d(k) = mf_cf - !qc_bl1d(k) = QCp*0.5*(edmf_a(k)+edmf_a(k-1))/mf_cf - Ac_mf = mf_cf - Ac_strat = cldfra_bl1d(k)*(1.0-mf_cf) - cldfra_bl1d(k) = Ac_mf + Ac_strat - !dillute Qc from updraft area to larger cloud area - qc_mf = QCp*0.5*(edmf_a(k)+edmf_a(k-1))/mf_cf - !The mixing ratios from the stratus component are not well - !estimated in shallow-cumulus regimes. Ensure stratus clouds - !have mixing ratio similar to cumulus - QCs = MAX(qc_bl1d(k), 0.5*qc_mf) - qc_bl1d(k) = (qc_mf*Ac_mf + QCs*Ac_strat)/cldfra_bl1d(k) - ELSE - !cldfra_bl1d(k)=0.5*(edmf_a(k)+edmf_a(k-1)) - !qc_bl1d(k) = QCp - Ac_mf = 0.5*(edmf_a(k)+edmf_a(k-1)) - Ac_strat = cldfra_bl1d(k)*(1.0-Ac_mf) - cldfra_bl1d(k)=Ac_mf + Ac_strat - qc_mf = QCp - !Ensure stratus clouds have mixing ratio similar to cumulus - QCs = MAX(qc_bl1d(k), 0.5*qc_mf) - qc_bl1d(k) = (QCp*Ac_mf + QCs*Ac_strat)/cldfra_bl1d(k) - ENDIF - ELSE - Ac_mf = mf_cf - ENDIF + ! where the mass-flux scheme is active. The specific humidities + ! are converted to grid means (not in-cloud quantities). + + if ((landsea-1.5).GE.0) then ! water + !don't overwrite stratus CF & qc_bl - degrades marine stratus + if (cldfra_bl1d(k) < cf_thresh) then + if (QCp * Aup > 5e-5) then + qc_bl1d(k) = 1.86 * (QCp * Aup) - 2.2e-5 + else + qc_bl1d(k) = 1.18 * (QCp * Aup) + endif + if (mf_cf .ge. Aup) then + qc_bl1d(k) = qc_bl1d(k) / mf_cf + endif + cldfra_bl1d(k) = mf_cf + Ac_mf = mf_cf + endif + else ! land + if (QCp * Aup > 5e-5) then + qc_bl1d(k) = 1.86 * (QCp * Aup) - 2.2e-5 + else + qc_bl1d(k) = 1.18 * (QCp * Aup) + endif + if (mf_cf .ge. Aup) then + qc_bl1d(k) = qc_bl1d(k) / mf_cf + endif + cldfra_bl1d(k) = mf_cf + Ac_mf = mf_cf + endif !Now recalculate the terms for the buoyancy flux for mass-flux clouds: - !See mym_condensation for details on these formulations. The - !cloud-fraction bounding was added to improve cloud retention, - !following RAP and HRRR testing. - !Fng = 2.05 ! the non-Gaussian transport factor (assumed constant) - !Use Bechtold and Siebesma (1998) piecewise estimation of Fng: - Q1 = qmq/MAX(sigq,1E-6) - Q1=MAX(Q1,-5.0) - IF (Q1 .GE. 1.0) THEN - Fng = 1.0 - ELSEIF (Q1 .GE. -1.7 .AND. Q1 .LT. 1.0) THEN - Fng = EXP(-0.4*(Q1-1.0)) - ELSEIF (Q1 .GE. -2.5 .AND. Q1 .LT. -1.7) THEN - Fng = 3.0 + EXP(-3.8*(Q1+1.7)) - ELSE - Fng = MIN(23.9 + EXP(-1.6*(Q1+2.5)), 60.) - ENDIF + !See mym_condensation for details on these formulations. + !Use Bechtold and Siebesma (1998) piecewise estimation of Fng with + !limits ,since they really should be recalculated after all the other changes...: + !Only overwrite vt & vq in non-stratus condition + if (cldfra_bl1d(k) < cf_thresh) then + !if ((landsea-1.5).GE.0) then ! WATER + Q1=max(Q1,-2.25) + !else + ! Q1=max(Q1,-2.0) + !endif + + if (Q1 .ge. 1.0) then + Fng = 1.0 + elseif (Q1 .ge. -1.7 .and. Q1 .lt. 1.0) then + Fng = EXP(-0.4*(Q1-1.0)) + elseif (Q1 .ge. -2.5 .and. Q1 .lt. -1.7) then + Fng = 3.0 + EXP(-3.8*(Q1+1.7)) + else + Fng = min(23.9 + EXP(-1.6*(Q1+2.5)), 60.) + endif - vt(k) = qww - MIN(0.40,Ac_mf)*beta*bb*Fng - 1. - vq(k) = alpha + MIN(0.40,Ac_mf)*beta*a*Fng - tv0 - ENDIF - ENDDO + !link the buoyancy flux function to active clouds only (c*Aup): + vt(k) = qww - (1.5*Aup)*beta*bb*Fng - 1. + vq(k) = alpha + (1.5*Aup)*beta*a*Fng - tv0 + endif + endif + enddo !k-loop ENDIF !end nup2 > 0 @@ -6883,10 +6947,12 @@ SUBROUTINE DMP_mf( & END SUBROUTINE DMP_MF !================================================================= -!>\ingroup gp_mynnedmf -!! zero or one condensation for edmf: calculates THV and QC +!>\ingroup gsd_mynn_edmf +!! This subroutine subroutine condensation_edmf(QT,THL,P,zagl,THV,QC) ! +! zero or one condensation for edmf: calculates THV and QC +! real,intent(in) :: QT,THL,P,zagl real,intent(out) :: THV real,intent(inout):: QC @@ -6944,10 +7010,11 @@ end subroutine condensation_edmf !=============================================================== -!> zero or one condensation for edmf: calculates THL and QC -!! similar to condensation_edmf but with different inputs subroutine condensation_edmf_r(QT,THL,P,zagl,THV,QC) ! +! zero or one condensation for edmf: calculates THL and QC +! similar to condensation_edmf but with different inputs +! real,intent(in) :: QT,THV,P,zagl real,intent(out) :: THL, QC @@ -6979,10 +7046,12 @@ subroutine condensation_edmf_r(QT,THL,P,zagl,THV,QC) end subroutine condensation_edmf_r !=============================================================== -!> This is the downdraft mass flux scheme - analogus to edmf_JPL but -!! flipped updraft to downdraft. This scheme is currently only tested -!! for Stratocumulus cloud conditions. For a detailed desctiption of the -!! model, see paper. +! =================================================================== +! This is the downdraft mass flux scheme - analogus to edmf_JPL but +! flipped updraft to downdraft. This scheme is currently only tested +! for Stratocumulus cloud conditions. For a detailed desctiption of the +! model, see paper. + SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & &u,v,th,thl,thv,tk,qt,qv,qc, & &rho,exner, & @@ -6997,11 +7066,12 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & INTEGER, INTENT(IN) :: KTS,KTE,KPBL REAL,DIMENSION(KTS:KTE), INTENT(IN) :: U,V,TH,THL,TK,QT,QV,QC,& - THV,P,rho,exner,rthraten,dz + THV,P,rho,exner,dz + REAL(kind=kind_phys),DIMENSION(KTS:KTE), INTENT(IN) :: rthraten ! zw .. heights of the downdraft levels (edges of boxes) REAL,DIMENSION(KTS:KTE+1), INTENT(IN) :: ZW - REAL, INTENT(IN) :: DT,UST,WTHL,WQT,PBLH - + REAL, INTENT(IN) :: WTHL,WQT + REAL(kind=kind_phys), INTENT(IN) :: dt,ust,pblh ! outputs - downdraft properties REAL,DIMENSION(KTS:KTE), INTENT(OUT) :: edmf_a_dd,edmf_w_dd, & & edmf_qt_dd,edmf_thl_dd, edmf_ent_dd,edmf_qc_dd @@ -7342,17 +7412,19 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & END SUBROUTINE DDMF_JPL !=============================================================== -!> Add scale-aware factor (Psig) here, taken from Honnert et al. (2011) \cite Honnert_2011 -!! and/or from Shin and Hong (2013) \cite Shin_2013. + SUBROUTINE SCALE_AWARE(dx,PBL1,Psig_bl,Psig_shcu) !--------------------------------------------------------------- ! NOTES ON SCALE-AWARE FORMULATION ! + !JOE: add scale-aware factor (Psig) here, taken from Honnert et al. (2011, + ! JAS) and/or from Hyeyum Hailey Shin and Song-You Hong (2013, JAS) + ! ! Psig_bl tapers local mixing ! Psig_shcu tapers nonlocal mixing - REAL,INTENT(IN) :: dx,PBL1 + REAL(kind=kind_phys), INTENT(IN) :: dx,pbl1 REAL, INTENT(OUT) :: Psig_bl,Psig_shcu REAL :: dxdh @@ -7415,7 +7487,7 @@ SUBROUTINE SCALE_AWARE(dx,PBL1,Psig_bl,Psig_shcu) END SUBROUTINE SCALE_AWARE ! ===================================================================== -!>\ingroup gp_mynnedmf +!>\ingroup gsd_mynn_edmf !! \author JAYMES- added 22 Apr 2015 !! This function calculates saturation vapor pressure. Separate ice and liquid functions !! are used (identical to those in module_mp_thompson.F, v3.6). Then, the @@ -7449,7 +7521,7 @@ END FUNCTION esat_blend ! ==================================================================== -!>\ingroup gp_mynnedmf +!>\ingroup gsd_mynn_edmf !! This function extends function "esat" and returns a "blended" !! saturation mixing ratio. !!\author JAYMES @@ -7491,7 +7563,7 @@ END FUNCTION qsat_blend ! =================================================================== -!>\ingroup gp_mynnedmf +!>\ingroup gsd_mynn_edmf !! This function interpolates the latent heats of vaporization and sublimation into !! a single, temperature-dependent, "blended" value, following !! Chaboureau and Bechtold (2002) \cite Chaboureau_2002, Appendix. @@ -7519,13 +7591,14 @@ FUNCTION xl_blend(t) END FUNCTION xl_blend ! =================================================================== -!> New stability function parameters for momentum (Puhales, 2020, WRF 4.2.1) -!! The forms in unstable conditions (z/L < 0) use Grachev et al. (2000), which are a blend of -!! the classical (Kansas) forms (i.e., Paulson 1970, Dyer and Hicks 1970), valid for weakly -!! unstable conditions (-1 < z/L < 0). The stability functions for stable conditions use an -!! updated form taken from Cheng and Brutsaert (2005), which extends the validity into very -!! stable conditions [z/L ~ O(10)]. + FUNCTION phim(zet) + ! New stability function parameters for momentum (Puhales, 2020, WRF 4.2.1) + ! The forms in unstable conditions (z/L < 0) use Grachev et al. (2000), which are a blend of + ! the classical (Kansas) forms (i.e., Paulson 1970, Dyer and Hicks 1970), valid for weakly + ! unstable conditions (-1 < z/L < 0). The stability functions for stable conditions use an + ! updated form taken from Cheng and Brutsaert (2005), which extends the validity into very + ! stable conditions [z/L ~ O(10)]. IMPLICIT NONE REAL, INTENT(IN):: zet @@ -7569,14 +7642,15 @@ FUNCTION phim(zet) phim = phi_m END FUNCTION phim +! =================================================================== -!> New stability function parameters for heat (Puhales, 2020, WRF 4.2.1) -!! The forms in unstable conditions (z/L < 0) use Grachev et al. (2000), which are a blend of -!! the classical (Kansas) forms (i.e., Paulson 1970, Dyer and Hicks 1970), valid for weakly -!! unstable conditions (-1 < z/L < 0). The stability functions for stable conditions use an -!! updated form taken from Cheng and Brutsaert (2005), which extends the validity into very -!! stable conditions [z/L ~ O(10)]. FUNCTION phih(zet) + ! New stability function parameters for heat (Puhales, 2020, WRF 4.2.1) + ! The forms in unstable conditions (z/L < 0) use Grachev et al. (2000), which are a blend of + ! the classical (Kansas) forms (i.e., Paulson 1970, Dyer and Hicks 1970), valid for weakly + ! unstable conditions (-1 < z/L < 0). The stability functions for stable conditions use an + ! updated form taken from Cheng and Brutsaert (2005), which extends the validity into very + ! stable conditions [z/L ~ O(10)]. IMPLICIT NONE REAL, INTENT(IN):: zet @@ -7618,8 +7692,6 @@ FUNCTION phih(zet) END FUNCTION phih ! ================================================================== -!>\ingroup gp_mynnedmf -!! Calculate the buoyancy production of TKE from cloud-top cooling. SUBROUTINE topdown_cloudrad(kts,kte,dz1,zw,xland,kpbl,PBLH, & &sqc,sqi,sqw,thl,th1,ex1,p1,rho1,thetav, & &cldfra_bl1D,rthraten, & @@ -7628,9 +7700,11 @@ SUBROUTINE topdown_cloudrad(kts,kte,dz1,zw,xland,kpbl,PBLH, & !input integer, intent(in) :: kte,kts real, dimension(kts:kte), intent(in) :: dz1,sqc,sqi,sqw,& - thl,th1,ex1,p1,rho1,thetav,cldfra_bl1D,rthraten + thl,th1,ex1,p1,rho1,thetav,cldfra_bl1D + real(kind=kind_phys), dimension(kts:kte), intent(in) :: rthraten real, dimension(kts:kte+1), intent(in) :: zw - real, intent(in) :: pblh,xland + real(kind=kind_phys), intent(in) :: pblh + real, intent(in) :: xland integer,intent(in) :: kpbl !output real, intent(out) :: maxKHtopdown diff --git a/physics/mynnedmf_wrapper.F90 b/physics/mynnedmf_wrapper.F90 index 08a28f2bd..8ac6378bd 100644 --- a/physics/mynnedmf_wrapper.F90 +++ b/physics/mynnedmf_wrapper.F90 @@ -2,6 +2,7 @@ !! This file contains all of the code related to running the MYNN !! eddy-diffusivity mass-flux scheme. +!>\ingroup gsd_mynn_edmf !> The following references best describe the code within !! Olson et al. (2019, NOAA Technical Memorandum) !! Nakanishi and Niino (2009) \cite NAKANISHI_2009 @@ -82,16 +83,12 @@ subroutine mynnedmf_wrapper_init ( & return end if - if (lheatstrg) then - errmsg = 'Logic error: lheatstrg not implemented for MYNN PBL' - errflg = 1 - return - end if - end subroutine mynnedmf_wrapper_init -!>\defgroup gp_mynnedmf MYNN-EDMF PBL and Shallow Convection Module -!> This scheme (1) performs pre-mynnedmf work, (2) runs the mynnedmf, and (3) performs post-mynnedmf work + subroutine mynnedmf_wrapper_finalize () + end subroutine mynnedmf_wrapper_finalize + +! \brief This scheme (1) performs pre-mynnedmf work, (2) runs the mynnedmf, and (3) performs post-mynnedmf work !> \section arg_table_mynnedmf_wrapper_run Argument Table !! \htmlinclude mynnedmf_wrapper_run.html !! @@ -158,14 +155,15 @@ SUBROUTINE mynnedmf_wrapper_run( & & icloud_bl, do_mynnsfclay, & & imp_physics, imp_physics_gfdl, & & imp_physics_thompson, imp_physics_wsm6, & - & chem3d, frp, mix_chem, rrfs_smoke, fire_turb, nchem, ndvel, & + & rrfs_sd, chem3d, frp, mix_chem, enh_mix, & + & nchem, ndvel, vdep, smoke_dbg, & & imp_physics_nssl, nssl_ccn_on, & - & ltaerosol, mraerosol, spp_wts_pbl, spp_pbl, lprnt, huge, errmsg, errflg ) + & ltaerosol, spp_wts_pbl, spp_pbl, lprnt, huge, errmsg, errflg ) ! should be moved to inside the mynn: use machine, only: kind_phys use bl_mynn_common, only: cp, r_d, grav, g_inv, zero, & - xlv, xlvcp, xlscp + xlv, xlvcp, xlscp, p608 use module_bl_mynn, only: mynn_bl_driver !------------------------------------------------------------------- @@ -182,12 +180,13 @@ SUBROUTINE mynnedmf_wrapper_run( & !smoke/chem integer, intent(in) :: nchem, ndvel integer, parameter :: kdvel=1 + logical, intent(in) :: smoke_dbg ! NAMELIST OPTIONS (INPUT): logical, intent(in) :: & & bl_mynn_tkeadvect, & & bl_mynn_tkebudget, & - & ltaerosol, mraerosol, & + & ltaerosol, & & lprnt, & & do_mynnsfclay, & & flag_for_pbl_generic_tend, & @@ -206,7 +205,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & imp_physics_thompson, imp_physics_gfdl, & & imp_physics_nssl, & & spp_pbl - real, intent(in) :: & + real(kind=kind_phys), intent(in) :: & & bl_mynn_closure !TENDENCY DIAGNOSTICS @@ -274,7 +273,7 @@ SUBROUTINE mynnedmf_wrapper_run( & real(kind=kind_phys), dimension(:), intent(in) :: xmu real(kind=kind_phys), dimension(:,:), intent(in) :: htrsw, htrlw ! spp_wts_pbl only allocated if spp_pbl == 1 - real(kind_phys), dimension(:,:), intent(in) :: spp_wts_pbl + real(kind=kind_phys), dimension(:,:), intent(in) :: spp_wts_pbl !LOCAL real(kind=kind_phys), dimension(im,levs) :: & @@ -286,11 +285,11 @@ SUBROUTINE mynnedmf_wrapper_run( & real(kind=kind_phys), allocatable :: old_ozone(:,:) !smoke/chem arrays - real(kind_phys), dimension(:), intent(inout) :: frp - logical, intent(in) :: mix_chem, fire_turb, rrfs_smoke + real(kind=kind_phys), dimension(:), intent(inout) :: frp + logical, intent(in) :: mix_chem, enh_mix, rrfs_sd real(kind=kind_phys), dimension(:,:,:), intent(inout) :: chem3d + real(kind=kind_phys), dimension(:,: ), intent(inout) :: vdep real(kind=kind_phys), dimension(im) :: emis_ant_no - real(kind=kind_phys), dimension(im,ndvel) :: vdep !MYNN-2D real(kind=kind_phys), dimension(:), intent(in) :: & @@ -357,7 +356,6 @@ SUBROUTINE mynnedmf_wrapper_run( & !initialize arrays for test EMIS_ANT_NO = 0. - vdep = 0. ! hli for chem dry deposition, 0 temporarily ! Check incoming moist species to ensure non-negative values ! First, create height (dz) and pressure differences (delp) @@ -475,32 +473,6 @@ SUBROUTINE mynnedmf_wrapper_run( & qnifa(i,k) = qgrs_ice_aer_num_conc(i,k) enddo enddo - else if(mraerosol) then - FLAG_QI = .true. - FLAG_QNI= .true. - FLAG_QC = .true. - FLAG_QNC= .true. - FLAG_QNWFA= .false. - FLAG_QNIFA= .false. - p_qc = 2 - p_qr = 0 - p_qi = 2 - p_qs = 0 - p_qg = 0 - p_qnc= 0 - p_qni= 0 - do k=1,levs - do i=1,im - sqv(i,k) = qgrs_water_vapor(i,k) - sqc(i,k) = qgrs_liquid_cloud(i,k) - sqi(i,k) = qgrs_ice_cloud(i,k) - qnc(i,k) = qgrs_cloud_droplet_num_conc(i,k) - qni(i,k) = qgrs_cloud_ice_num_conc(i,k) - ozone(i,k) = qgrs_ozone(i,k) - qnwfa(i,k) = 0. - qnifa(i,k) = 0. - enddo - enddo else FLAG_QI = .true. FLAG_QNI= .true. @@ -594,11 +566,7 @@ SUBROUTINE mynnedmf_wrapper_run( & do i=1,im ! dz(i,k)=(phii(i,k+1) - phii(i,k))*g_inv th(i,k)=t3d(i,k)/exner(i,k) - ! keep as specific humidity - ! qv(i,k)=qvsh(i,k)/(1.0 - qvsh(i,k)) - ! qc(i,k)=qc(i,k)/(1.0 - qvsh(i,k)) - ! qi(i,k)=qi(i,k)/(1.0 - qvsh(i,k)) - rho(i,k)=prsl(i,k)/(r_d*t3d(i,k)) + rho(i,k)=prsl(i,k)/(r_d*t3d(i,k)*(1.+p608*max(sqv(i,k),1e-8))) w(i,k) = -omega(i,k)/(rho(i,k)*grav) enddo enddo @@ -616,6 +584,11 @@ SUBROUTINE mynnedmf_wrapper_run( & ch(i)=0.0 hfx(i)=hflx(i)*rho(i,1)*cp qfx(i)=qflx(i)*rho(i,1) + !filter bad incoming fluxes + if (hfx(i) > 1200.)hfx(i) = 1200. + if (hfx(i) < -500.)hfx(i) = -500. + if (qfx(i) > .0005)qfx(i) = 0.0005 + if (qfx(i) < -.0002)qfx(i) = -0.0002 dtsfc1(i) = hfx(i) dqsfc1(i) = qfx(i)*XLV @@ -742,10 +715,10 @@ SUBROUTINE mynnedmf_wrapper_run( & & sh3d=Sh3d,sm3d=Sm3d, & !chem/smoke & nchem=nchem,kdvel=kdvel,ndvel=ndvel, & - & Chem3d=chem3d,Vdep=vdep, & + & Chem3d=chem3d,Vdep=vdep,smoke_dbg=smoke_dbg, & & FRP=frp,EMIS_ANT_NO=emis_ant_no, & - & mix_chem=mix_chem,fire_turb=fire_turb, & - & rrfs_smoke=rrfs_smoke, & + & mix_chem=mix_chem,enh_mix=enh_mix, & + & rrfs_sd=rrfs_sd, & !----- & Tsq=tsq,Qsq=qsq,Cov=cov, & !output & RUBLTEN=RUBLTEN,RVBLTEN=RVBLTEN,RTHBLTEN=RTHBLTEN, & !output @@ -886,23 +859,6 @@ SUBROUTINE mynnedmf_wrapper_run( & ! !qgrs_ice_aer_num_conc(i,k) = qgrs_ice_aer_num_conc(i,k) + RQNIFABLTEN(i,k)*delt ! enddo !enddo - else if(mraerosol) then - do k=1,levs - do i=1,im - dqdt_water_vapor(i,k) = RQVBLTEN(i,k) !/(1.0 + qv(i,k)) - dqdt_liquid_cloud(i,k) = RQCBLTEN(i,k) !/(1.0 + qv(i,k)) - dqdt_cloud_droplet_num_conc(i,k) = RQNCBLTEN(i,k) - dqdt_ice_cloud(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) - dqdt_ice_num_conc(i,k) = RQNIBLTEN(i,k) - enddo - enddo - if(ldiag3d .and. .not. flag_for_pbl_generic_tend) then - call dtend_helper(100+ntqv,RQVBLTEN) - call dtend_helper(100+ntcw,RQCBLTEN) - call dtend_helper(100+ntlnc,RQNCBLTEN) - call dtend_helper(100+ntiw,RQIBLTEN) - call dtend_helper(100+ntinc,RQNIBLTEN) - endif else !Thompson (2008) do k=1,levs @@ -1076,9 +1032,9 @@ SUBROUTINE moisture_check2(kte, delt, dp, exner, & implicit none integer, intent(in) :: kte - real, intent(in) :: delt - real, dimension(kte), intent(in) :: dp, exner - real, dimension(kte), intent(inout) :: qv, qc, qi, th + real(kind=kind_phys), intent(in) :: delt + real(kind=kind_phys), dimension(kte), intent(in) :: dp, exner + real(kind=kind_phys), dimension(kte), intent(inout) :: qv, qc, qi, th integer k real :: dqc2, dqi2, dqv2, sum, aa, dum real, parameter :: qvmin1= 1e-8, & !min at k=1 diff --git a/physics/mynnedmf_wrapper.meta b/physics/mynnedmf_wrapper.meta index a44a13f1b..044162dbb 100644 --- a/physics/mynnedmf_wrapper.meta +++ b/physics/mynnedmf_wrapper.meta @@ -1347,7 +1347,7 @@ standard_name = chem3d_mynn_pbl_transport long_name = mynn pbl transport of smoke and dust units = various - dimensions = (horizontal_loop_extent,vertical_layer_dimension,2) + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_chemical_species_vertically_mixed) type = real kind = kind_phys intent = inout @@ -1359,9 +1359,9 @@ type = real kind = kind_phys intent = inout -[rrfs_smoke] +[rrfs_sd] standard_name = do_smoke_coupling - long_name = flag controlling rrfs_smoke collection (default off) + long_name = flag controlling rrfs_sd collection (default off) units = flag dimensions = () type = logical @@ -1373,7 +1373,7 @@ dimensions = () type = logical intent = in -[fire_turb] +[enh_mix] standard_name = do_planetary_boundary_layer_fire_enhancement long_name = flag for rrfs smoke mynn enh vermix units = flag @@ -1394,16 +1394,24 @@ dimensions = () type = integer intent = in -[ltaerosol] - standard_name = flag_for_aerosol_physics - long_name = flag for aerosol physics +[vdep] + standard_name = dry_deposition_velocity_mynn_pbl_transport + long_name = dry deposition velocity by mynn pbl transport + units = m s-1 + dimensions = (horizontal_loop_extent,number_of_chemical_species_deposited) + type = real + kind = kind_phys + intent = in +[smoke_dbg] + standard_name = do_smoke_debug + long_name = flag for rrfs smoke plumerise debug units = flag dimensions = () type = logical intent = in -[mraerosol] - standard_name = do_merra2_aerosol_awareness - long_name = flag for merra2 aerosol-aware physics for example the thompson microphysics +[ltaerosol] + standard_name = flag_for_aerosol_physics + long_name = flag for aerosol physics units = flag dimensions = () type = logical diff --git a/physics/radiation_aerosols.f b/physics/radiation_aerosols.f index 3cd5c64e1..bbd2f25cb 100644 --- a/physics/radiation_aerosols.f +++ b/physics/radiation_aerosols.f @@ -2179,7 +2179,7 @@ subroutine setaer & & ( prsi,prsl,prslk,tvly,rhlay,slmsk,tracer,aerfld,xlon,xlat, & ! --- inputs & IMAX,NLAY,NLP1, lsswr,lslwr,iaermdl,iaerflg,top_at_1, & & con_pi,con_rd,con_g,aerosw,aerolw, & ! --- outputs - & aerodp, errflg, errmsg & + & aerodp, ext550, errflg, errmsg & & ) ! ================================================================== ! @@ -2259,6 +2259,7 @@ subroutine setaer & & aerosw, aerolw real (kind=kind_phys), dimension(:,:) , intent(out) :: aerodp + real (kind=kind_phys), dimension(:,:) , intent(out) :: ext550 integer, intent(out) :: errflg character(len=*), intent(out) :: errmsg @@ -2314,6 +2315,7 @@ subroutine setaer & aerodp(i,k) = f_zero enddo enddo + ext550(:,:) = f_zero if ( .not. (lsswr .or. lslwr) ) then return @@ -2411,7 +2413,7 @@ subroutine setaer & & alon,alat,slmsk,laersw,laerlw,con_rd, & & IMAX,NLAY,NLP1, & ! --- outputs: - & aerosw,aerolw,aerodp,errflg,errmsg & + & aerosw,aerolw,aerodp,ext550,errflg,errmsg & & ) endif ! end if_iaerflg_block @@ -4334,7 +4336,7 @@ subroutine aer_property_gocart & & alon,alat,slmsk, laersw,laerlw,con_rd, & & imax,nlay,nlp1, & ! --- outputs: - & aerosw,aerolw,aerodp,errflg,errmsg & + & aerosw,aerolw,aerodp,ext550,errflg,errmsg & & ) ! ================================================================== ! @@ -4401,6 +4403,7 @@ subroutine aer_property_gocart & real (kind=kind_phys), dimension(:,:,:,:), intent(out) :: & & aerosw, aerolw real (kind=kind_phys), dimension(:,:) , intent(out) :: aerodp + real (kind=kind_phys), dimension(:,:) , intent(out) :: ext550 integer, intent(out) :: errflg character(len=*), intent(out) :: errmsg @@ -4485,6 +4488,7 @@ subroutine aer_property_gocart & ! --- update diagnostic aod arrays do k = 1, NLAY aerodp(i,1) = aerodp(i,1) + tauae_550(k,1) + ext550(i,k) = tauae_550(k,1) do m = 1, NSPC aerodp(i,m+1) = aerodp(i,m+1)+spcodp(k,m) enddo diff --git a/physics/smoke_dust/coarsepm_settling_mod.F90 b/physics/smoke_dust/coarsepm_settling_mod.F90 new file mode 100755 index 000000000..9061840c3 --- /dev/null +++ b/physics/smoke_dust/coarsepm_settling_mod.F90 @@ -0,0 +1,274 @@ +module coarsepm_settling_mod + + use machine , only : kind_phys + use dust_data_mod, only : dyn_visc !den_dust, reff_dust, dyn_visc + + implicit none + +CONTAINS + + +SUBROUTINE coarsepm_settling_driver(dt,t_phy,rel_hum, & + chem,rho_phy,dz8w,p8w,p_phy,sedim, & + area,g,num_chem, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: & + num_chem, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + REAL(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ),INTENT(INOUT ) :: chem + REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(IN ) :: t_phy,p_phy,dz8w,p8w,rho_phy,rel_hum + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ),INTENT(IN ) :: area + REAL(kind_phys), INTENT(IN ) :: dt,g + + REAL(kind_phys), DIMENSION( ims:ime, jms:jme, num_chem ), INTENT(OUT ) :: sedim + + integer :: nv,i,j,k,kk,lmx,idust + real(kind_phys), DIMENSION (1,1,kte-kts+1) :: tmp,airden,airmas,p_mid,delz,rh + real(kind_phys), DIMENSION (1,1,kte-kts+1,1) :: dust + real(kind_phys), DIMENSION (ime,jme,kme,num_chem) :: chem_before +! +! bstl is for budgets +! +! real(kind_phys), DIMENSION (5), PARAMETER :: den_dust(5)=(/2500.,2650.,2650.,2650.,2650./) +! real(kind_phys), DIMENSION (5), PARAMETER :: reff_dust(5)=(/0.73D-6,1.4D-6,2.4D-6,4.5D-6,8.0D-6/) + real(kind_phys), DIMENSION (1), PARAMETER :: den_dust (1)=(/2650. /) + real(kind_phys), DIMENSION (1), PARAMETER :: reff_dust(1)=(/2.4D-6/) + real(kind_phys), DIMENSION (1) :: bstl_dust + real(kind_phys) conver,converi + real(kind_phys),parameter::max_default=0. + + sedim = 0. + conver=1.e-9 + converi=1.e9 + lmx=kte-kts+1 +! + do j=jts,jte + do i=its,ite +! +! initialize some met stuff +! + kk=0 + bstl_dust(:)=0. + do k=kts,kte + kk=kk+1 + p_mid(1,1,kk)=.01*p_phy(i,kte-k+kts,j) + delz(1,1,kk)=dz8w(i,kte-k+kts,j) + airmas(1,1,kk)=-(p8w(i,k+1,j)-p8w(i,k,j))*area(i,j)/g + airden(1,1,kk)=rho_phy(i,k,j) + tmp(1,1,kk)=t_phy(i,k,j) + rh(1,1,kk) = rel_hum(i,k,j) ! hli + do nv = 1, num_chem + chem_before(i,j,k,nv) = chem(i,k,j,nv) + enddo + enddo +! +! max dust in column +! + idust=1 + kk=0 + do k=kts,kte + kk=kk+1 + dust(1,1,kk,1)=chem(i,k,j,1)*conver + enddo + + + call settling(1, 1, lmx, 1,g,dyn_visc, & + dust, tmp, p_mid, delz, airmas, & + den_dust, reff_dust, dt, bstl_dust, rh, idust, airden) + + kk = 0 + do k = kts,kte + kk = kk+1 + chem(i,k,j,1)=dust(1,1,kk,1)*converi ! coarse dust [ug/kg] + enddo +! +! +! + do nv = 1, num_chem + do k = kts,kte + sedim(i,j,nv) = sedim(i,j,nv)+(chem_before(i,j,k,nv) - chem(i,k,j,nv))*p8w(i,k,j)/g + enddo + sedim(i,j,nv) = sedim(i,j,nv) / dt !ug/m2/s + enddo +! +! +! + enddo + enddo +! +! +! +END SUBROUTINE coarsepm_settling_driver + + + subroutine settling(imx,jmx, lmx, nmx,g0,dyn_visc, & + tc, tmp, p_mid, delz, airmas, & + den, reff, dt, bstl, rh, idust, airden) +! **************************************************************************** +! * * +! * Calculate the loss by settling, using an implicit method * +! * * +! * Input variables: * +! * SIGE(k) - sigma coordinate of the vertical edges * +! * PS(i,j) - Surface pressure (mb) * +! * TMP(i,j,k) - Air temperature (K) * +! * CT(i,j) - Surface exchange coeff for moisture +! * * +! **************************************************************************** + + + IMPLICIT NONE + + INTEGER, INTENT(IN) :: imx, jmx, lmx, nmx,idust + INTEGER :: ntdt + REAL(kind_phys), INTENT(IN) :: dt,g0,dyn_visc + REAL(kind_phys), INTENT(IN) :: tmp(imx,jmx,lmx), delz(imx,jmx,lmx), & + airmas(imx,jmx,lmx), rh(imx,jmx,lmx), & + den(nmx), reff(nmx),p_mid(imx,jmx,lmx),& + airden(imx,jmx,lmx) + REAL(kind_phys), INTENT(INOUT) :: tc(imx,jmx,lmx,nmx) + REAL(kind_phys), INTENT(OUT) :: bstl(imx,jmx,nmx) + + REAL(kind_phys) :: tc1(imx,jmx,lmx,nmx), dt_settl(nmx), rcm(nmx), rho(nmx) + INTEGER :: ndt_settl(nmx) + REAL(kind_phys) :: dzmin, vsettl, dtmax, rhb, rwet(nmx), ratio_r(nmx) + REAL(kind_phys) :: c_stokes, free_path, c_cun, viscosity, growth_fac + REAL(kind_phys) :: vd_cor(lmx),vd_wk1 + INTEGER :: k, n, i, j, l, l2 + REAL(kind_phys) :: transfer_to_below_level,temp_tc + + ! for OMP: + REAL(kind_phys) :: rwet_priv(nmx), rho_priv(nmx) + + ! executable statements + + bstl = 0._kind_phys + + if(idust.ne.1.)return + +!!! WHERE (tc(:,:,:,:) < 0.0) tc(:,:,:,:) = 1.0E-32 + + dzmin = MINVAL(delz(:,:,:)) + IF (idust == 1) growth_fac = 1.0 + + DO k = 1,nmx + + ! Settling velocity (m/s) for each tracer (Stokes Law) + ! DEN density (kg/m3) + ! REFF effective radius (m) + ! dyn_visc dynamic viscosity (kg/m/s) + ! g0 gravity (m/s2) + ! 3.0 corresponds to a growth of a factor 3 of radius with 100% RH + ! 0.5 upper limit with temp correction + + tc1(:,:,:,k) = tc(:,:,:,k) + vsettl = 2.0/9.0 * g0 * den(k) * (growth_fac*reff(k))**2 / & + (0.5*dyn_visc) + + ! Determine the maximum time-step satisying the CFL condition: + ! dt <= (dz)_min / v_settl + ntdt=INT(dt) + dtmax = dzmin / vsettl + ndt_settl(k) = MAX( 1, INT( ntdt /dtmax) ) + ! limit maximum number of iterations + IF (ndt_settl(k) > 12) ndt_settl(k) = 12 + dt_settl(k) = REAL(ntdt) / REAL(ndt_settl(k)) + + ! Particles radius in centimeters + IF (idust.eq.1)then + rwet(k) = reff(k) + ratio_r(k) = 1.0 + rho(k) = den(k) + endif + END DO + + ! Solve the bidiagonal matrix (l,l) + +!$OMP PARALLEL DO & +!$OMP DEFAULT( SHARED ) & +!$OMP PRIVATE( i, j, l, l2, n, k, rhb, rwet_priv, ratio_r, c_stokes)& +!$OMP PRIVATE( free_path, c_cun, viscosity, rho_priv, vd_cor ) + + ! Loop over latitudes + DO j = 1,jmx + + DO k = 1,nmx + IF (idust.eq.1) THEN + rwet_priv(k) = rwet(k) + rho_priv(k) = rho(k) + END IF + + DO n = 1,ndt_settl(k) + + ! Solve each vertical layer successively (layer l) + transfer_to_below_level=0 + + DO l = lmx,1,-1 + l2 = lmx - l + 1 + +! DO j = 1,jmx + DO i = 1,imx + + ! Dynamic viscosity + c_stokes = 1.458E-6 * tmp(i,j,l)**1.5/(tmp(i,j,l) + 110.4) + + ! Mean free path as a function of pressure (mb) and + ! temperature (K) + ! order of p_mid is top->sfc + free_path = 1.1E-3/p_mid(i,j,l2)/SQRT(tmp(i,j,l)) +!!! free_path = 1.1E-3/p_edge(i,j,l2)/SQRT(tmp(i,j,l)) + + ! Slip Correction Factor + c_cun = 1.0+ free_path/rwet_priv(k)* & + (1.257 + 0.4*EXP(-1.1*rwet_priv(k)/free_path)) + + ! Corrected dynamic viscosity (kg/m/s) + viscosity = c_stokes / c_cun + + ! Settling velocity + + vd_cor(l) = 2.0/9.0*g0*rho_priv(k)*rwet_priv(k)**2/viscosity + + ! Update mixing ratio; order of delz: top->sfc + temp_tc=tc(i,j,l,k) !temp_tc - for temporal storage [ug/kg] + vd_wk1 = dt_settl(k)*vd_cor(l)/delz(i,j,l2) !fraction to leave level + + tc(i,j,l,k) = tc(i,j,l,k)*(1.- vd_wk1)+transfer_to_below_level ! [ug/kg] + + if (l.gt.1) transfer_to_below_level =(temp_tc*vd_wk1)*((delz(i,j,l2) & + *airden(i,j,l))/(delz(i,j,l2+1)*airden(i,j,l-1))) ! [ug/kg] + + END DO !i +! END DO !j + END DO !l + + END DO !n + END DO !k + + END DO !j +!$OMP END PARALLEL DO + + DO n = 1,nmx + DO i = 1,imx + DO j = 1,jmx + bstl(i,j,n) = 0._kind_phys + DO l = 1,lmx + IF (tc(i,j,l,n) < 0.0) tc(i,j,l,n) = 1.0D-32 + bstl(i,j,n) = bstl(i,j,n) + & + (tc(i,j,l,n) - tc1(i,j,l,n)) * airmas(i,j,l) + END DO + END DO + END DO + END DO + +END SUBROUTINE settling + +end module coarsepm_settling_mod diff --git a/physics/smoke_dust/dep_dry_mod.F90 b/physics/smoke_dust/dep_dry_mod.F90 new file mode 100755 index 000000000..ea7dd9963 --- /dev/null +++ b/physics/smoke_dust/dep_dry_mod.F90 @@ -0,0 +1,69 @@ +!>\file dep_dry_mod.F90 +!! This file is for the dry depostion driver. + +module dep_dry_mod + + use machine , only : kind_phys + + implicit none + + private + + public :: dry_dep_driver + +contains + + subroutine dry_dep_driver(rmol,ust,ndvel,ddvel,rel_hum, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +!---------------------------------------------------------------------- + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: ndvel, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ) , & + INTENT(INOUT) :: ust, rmol + REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(IN ) :: rel_hum + + REAL(kind_phys), PARAMETER :: kpart=500. + REAL(kind_phys) :: dvpart + +! +! Output array + REAL(kind_phys), DIMENSION( its:ite, jts:jte, ndvel ), INTENT(INOUT) :: ddvel + + + integer :: i,j,k,nv +! +! necessary for aerosols (module dependent) +! +! .. Intrinsic Functions .. + INTRINSIC max, min + +! compute dry deposition velocities = ddvel + + ddvel(:,:,:) = 0.0 + do nv = 1, ndvel + do j = jts, jte + do i = its, ite + dvpart = ust(i,j)/kpart + + IF (rmol(i,j)<0.) THEN ! UNSTABLE LAYERING CORRECTION + dvpart = dvpart*(1.+(-300.*rmol(i,j))**0.66667) + ENDIF + + IF (rel_hum(i,1,j)>0.8) THEN ! HIGH RELATIVE HUMIDITY CORRECTION + dvpart = dvpart*(1.+0.37*exp((rel_hum(i,1,j)-0.8)/0.2)) + END IF + ddvel(i,j,nv) = MIN(0.50,dvpart) ! m/s + enddo + enddo + enddo + +end subroutine dry_dep_driver + +end module dep_dry_mod diff --git a/smoke/dust_data_mod.F90 b/physics/smoke_dust/dust_data_mod.F90 similarity index 97% rename from smoke/dust_data_mod.F90 rename to physics/smoke_dust/dust_data_mod.F90 index 9e9713e22..a710701f1 100755 --- a/smoke/dust_data_mod.F90 +++ b/physics/smoke_dust/dust_data_mod.F90 @@ -3,7 +3,6 @@ module dust_data_mod - use rrfs_smoke_data use machine , only : kind_phys use rrfs_smoke_config, only : p_dust_1, p_dust_2, p_dust_3, p_dust_4, p_dust_5, & p_edust1, p_edust2, p_edust3, p_edust4, p_edust5 @@ -80,8 +79,8 @@ module dust_data_mod ! -- FENGSHA uses precalculated drag partition from ASCAT. See: Prigent et al. (2012,2015) integer, parameter :: dust_calcdrag = 1 - real(kind_phys), parameter :: dust_alpha = 2.2 - real(kind_phys), parameter :: dust_gamma = 1.0 + real(kind_phys) :: dust_alpha = 2.2 + real(kind_phys) :: dust_gamma = 1.0 ! -- sea salt parameters diff --git a/physics/smoke_dust/dust_fengsha_mod.F90 b/physics/smoke_dust/dust_fengsha_mod.F90 new file mode 100755 index 000000000..54a64239d --- /dev/null +++ b/physics/smoke_dust/dust_fengsha_mod.F90 @@ -0,0 +1,585 @@ +!>\file dust_fengsha_mod.F90 +!! This file contains the FENGSHA dust scheme. + +module dust_fengsha_mod +! +! This module developed by Barry Baker (NOAA ARL) +! For serious questions contact barry.baker@noaa.gov +! +! 07/16/2019 - Adapted for NUOPC/GOCART, R. Montuoro +! 02/01/2020 - Adapted for FV3/CCPP, Haiqin Li + + use machine , only : kind_phys + use dust_data_mod + + implicit none + + private + + public :: gocart_dust_fengsha_driver + +contains + + subroutine gocart_dust_fengsha_driver(dt, & + chem,rho_phy,smois,p8w,ssm, & + isltyp,vegfra,snowh,xland,area,g,emis_dust, & + ust,znt,clay,sand,rdrag,uthr, & + num_emis_dust,num_chem,num_soil_layers, & + 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, & + num_emis_dust,num_chem,num_soil_layers + + ! 2d input variables + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: ssm ! Sediment supply map + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: vegfra ! vegetative fraction (-) + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: snowh ! snow height (m) + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: xland ! dominant land use type + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: area ! area of grid cell + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: ust ! friction velocity + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: znt ! Surface Roughness length (m) + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: clay ! Clay Fraction (-) + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: sand ! Sand Fraction (-) + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: rdrag ! Drag Partition (-) + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: uthr ! Dry Threshold Velocity (m/s) + + INTEGER, DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: isltyp ! soil type + + ! 3d input variables + REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN) :: p8w + REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN) :: rho_phy + REAL(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), INTENT(INOUT) :: chem + REAL(kind_phys), DIMENSION( ims:ime, 1, jms:jme,num_emis_dust),OPTIONAL, INTENT(INOUT) :: emis_dust + REAL(kind_phys), DIMENSION( ims:ime, num_soil_layers, jms:jme ), INTENT(IN) :: smois + + !0d input variables + REAL(kind_phys), INTENT(IN) :: dt ! time step + REAL(kind_phys), INTENT(IN) :: g ! gravity (m/s**2) + + ! Local variables + integer :: nmx,i,j,k,imx,jmx,lmx + integer :: ilwi + real(kind_phys) :: airden ! air density + REAL(kind_phys) :: airmas ! dry air mass + real(kind_phys) :: dxy + real(kind_phys) :: conver,converi ! conversion values + real(kind_phys) :: R ! local drag partition + real(kind_phys) :: ustar + real(kind_phys), DIMENSION (num_emis_dust) :: tc + real(kind_phys), DIMENSION (num_emis_dust) :: bems + real(kind_phys), DIMENSION (num_emis_dust) :: distribution + real(kind_phys), dimension (3) :: massfrac + real(kind_phys) :: erodtot + + ! conversion values + conver=1.e-9 + converi=1.e9 + + ! Number of dust bins + + imx=1 + jmx=1 + lmx=1 + nmx=ndust + + k=kts + do j=jts,jte + do i=its,ite + + ! Don't do dust over water!!! + + ilwi=0 + if(xland(i,j).lt.1.5)then + ilwi=1 + + ! Total concentration at lowest model level. This is still hardcoded for 5 bins. + + ! if(config_flags%chem_opt == 2 .or. config_flags%chem_opt == 11 ) then + ! tc(:)=1.e-16*conver + ! else + tc(1)=chem(i,kts,j,p_dust_1)*conver + tc(2)=chem(i,kts,j,p_dust_2)*conver + tc(3)=chem(i,kts,j,p_dust_3)*conver + tc(4)=chem(i,kts,j,p_dust_4)*conver + tc(5)=chem(i,kts,j,p_dust_5)*conver + ! endif + + ! Air mass and density at lowest model level. + + airmas=-(p8w(i,kts+1,j)-p8w(i,kts,j))*area(i,j)/g + airden=rho_phy(i,kts,j) + ustar=ust(i,j) + dxy=area(i,j) + + ! Mass fractions of clay, silt, and sand. + massfrac(1)=clay(i,j) + massfrac(2)=1-(clay(i,j)+sand(i,j)) + massfrac(3)=sand(i,j) + + + ! Total erodibility. + + erodtot = ssm(i,j) ! SUM(erod(i,j,:)) + + ! Don't allow roughness lengths greater than 20 cm to be lofted. + ! This kludge accounts for land use types like urban areas and + ! forests which would otherwise show up as high dust emitters. + ! This is a placeholder for a more widely accepted kludge + ! factor in the literature, which reduces lofting for rough areas. + ! Forthcoming... + + IF (znt(i,j) .gt. 0.2) then + ilwi=0 + endif + + ! limit where there is lots of vegetation + if (vegfra(i,j) .gt. .17) then + ilwi = 0 + endif + + ! limit where there is snow on the ground + if (snowh(i,j) .gt. 0) then + ilwi = 0 + endif + + ! Do not allow areas with bedrock, lava, or land-ice to loft + + IF (isltyp(i,j) .eq. 15 .or. isltyp(i,j) .eq. 16. .or. & + isltyp(i,j) .eq. 18) then + ilwi=0 + ENDIF + IF (isltyp(i,j) .eq. 0)then + ilwi=0 + endif + if(ilwi == 0 ) cycle + + ! get drag partition + ! FENGSHA uses the drag partition correction of MacKinnon et al 2004 + ! doi:10.1016/j.geomorph.2004.03.009 + if (dust_calcdrag .ne. 1) then + call fengsha_drag(znt(i,j),R) + else + ! use the precalculated version derived from ASCAT; Prigent et al. (2012,2015) + ! doi:10.1109/TGRS.2014.2338913 & doi:10.5194/amt-5-2703-2012 + ! pick only valid values + if (rdrag(i,j) > 0.) then + R = real(rdrag(i,j), kind=kind_phys) + else + cycle + endif + endif + + ! Call dust emission routine. + + call source_dust(imx,jmx, lmx, nmx, dt, tc, ustar, massfrac, & + erodtot, dxy, smois(i,1,j), airden, airmas, bems, g, dust_alpha, dust_gamma, & + R, uthr(i,j)) + + ! convert back to concentration + + chem(i,kts,j,p_dust_1)=tc(1)*converi + chem(i,kts,j,p_dust_2)=tc(2)*converi + chem(i,kts,j,p_dust_3)=tc(3)*converi + chem(i,kts,j,p_dust_4)=tc(4)*converi + chem(i,kts,j,p_dust_5)=tc(5)*converi + + ! For output diagnostics + + emis_dust(i,1,j,p_edust1)=bems(1) + emis_dust(i,1,j,p_edust2)=bems(2) + emis_dust(i,1,j,p_edust3)=bems(3) + emis_dust(i,1,j,p_edust4)=bems(4) + emis_dust(i,1,j,p_edust5)=bems(5) + endif + enddo + enddo + ! + + end subroutine gocart_dust_fengsha_driver + + + subroutine source_dust(imx, jmx, lmx, nmx, dt1, tc, ustar, massfrac, & + erod, dxy, smois, airden, airmas, bems, g0, alpha, gamma, & + R, uthres) + + ! **************************************************************************** + ! * Evaluate the source of each dust particles size bin by soil emission + ! * + ! * Input: + ! * EROD Fraction of erodible grid cell (-) + ! * smois Volumetric soil moisture (m3/m3) + ! * ALPHA Constant to fudge the total emission of dust (1/m) + ! * GAMMA Tuning constant for erodibility (-) + ! * DXY Surface of each grid cell (m2) + ! * AIRMAS Mass of air for each grid box (kg) + ! * AIRDEN Density of air for each grid box (kg/m3) + ! * USTAR Friction velocity (m/s) + ! * DT1 Time step (s) + ! * NMX Number of dust bins (-) + ! * IMX Number of I points (-) + ! * JMX Number of J points (-) + ! * LMX Number of L points (-) + ! * R Drag Partition (-) + ! * UTHRES FENGSHA Dry Threshold Velocities (m/s) + ! * + ! * Data: + ! * MASSFRAC Fraction of mass in each of 3 soil classes (-) (clay silt sand) + ! * DEN_DUST Dust density (kg/m3) + ! * DEN_SALT Saltation particle density (kg/m3) + ! * REFF_SALT Reference saltation particle diameter (m) + ! * REFF_DUST Reference dust particle diameter (m) + ! * LO_DUST Lower diameter limits for dust bins (m) + ! * UP_DUST Upper diameter limits for dust bins (m) + ! * FRAC_SALT Soil class mass fraction for saltation bins (-) + ! * + ! * Parameters: + ! * CMB Constant of proportionality (-) + ! * MMD_DUST Mass median diameter of dust (m) + ! * GSD_DUST Geometric standard deviation of dust (-) + ! * LAMBDA Side crack propagation length (m) + ! * CV Normalization constant (-) + ! * G0 Gravitational acceleration (m/s2) + ! * + ! * Working: + ! * RHOA Density of air in cgs (g/cm3) + ! * DS_REL Saltation surface area distribution (-) + ! * DLNDP Dust bin width (-) + ! * EMIT Total vertical mass flux (kg/m2/s) + ! * EMIT_VOL Total vertical volume flux (m/s) + ! * DSRC Mass of emitted dust (kg/timestep/cell) + ! * + ! * Output: + ! * TC Total concentration of dust (kg/kg/timestep/cell) + ! * BEMS Source of each dust type (kg/timestep/cell) + ! * + ! **************************************************************************** + implicit none + + ! Input + INTEGER, INTENT(IN) :: imx,jmx,lmx,nmx + REAL(kind_phys), INTENT(IN) :: dt1 + REAL(kind_phys), INTENT(IN) :: ustar + REAL(kind_phys), INTENT(IN) :: massfrac(3) + REAL(kind_phys), INTENT(IN) :: erod + REAL(kind_phys), INTENT(IN) :: dxy + REAL(kind_phys), INTENT(IN) :: smois + REAL(kind_phys), INTENT(IN) :: airden + REAL(kind_phys), INTENT(IN) :: airmas + REAL(kind_phys), INTENT(IN) :: g0 + REAL(kind_phys), INTENT(IN) :: alpha + REAL(kind_phys), INTENT(IN) :: gamma + REAL(kind_phys), INTENT(IN) :: R + REAL(kind_phys), INTENT(IN) :: uthres + + ! Output + REAL(kind_phys), INTENT(INOUT) :: tc(nmx) + + ! Local Variables + REAL(kind_phys), INTENT(OUT) :: bems(nmx) + + REAL(kind_phys) :: dvol(nmx) + REAL(kind_phys) :: distr_dust(nmx) + REAL(kind_phys) :: dlndp(nmx) + REAL(kind_phys) :: dsrc + REAL(kind_phys) :: dvol_tot + REAL(kind_phys) :: emit + REAL(kind_phys) :: emit_vol + REAL(kind_phys) :: rhoa + INTEGER :: i, j, n + + ! Constant of proportionality from Marticorena et al, 1997 (unitless) + ! Arguably more ~consistent~ fudge than alpha, which has many walnuts + ! sprinkled throughout the literature. - GC + + REAL(kind_phys), PARAMETER :: cmb=1.0 + REAL(kind_phys), PARAMETER :: kvhmax=2.0e-4 + + ! Parameters used in Kok distribution function. Advise not to play with + ! these without the expressed written consent of someone who knows what + ! they're doing. - GC + + REAL(kind_phys), PARAMETER :: mmd_dust=3.4D-6 ! median mass diameter (m) + REAL(kind_phys), PARAMETER :: gsd_dust=3.0 ! geom. std deviation + REAL(kind_phys), PARAMETER :: lambda=12.0D-6 ! crack propagation length (m) + REAL(kind_phys), PARAMETER :: cv=12.62D-6 ! normalization constant + REAL(kind_phys), PARAMETER :: RHOSOIL=2650. + + + ! calculate the total vertical dust flux + + emit = 0.0 + + call DustEmissionFENGSHA(smois,massfrac(1),massfrac(3), massfrac(2), & + erod, R, airden, ustar, uthres, alpha, gamma, kvhmax, & + g0, RHOSOIL, emit) + + ! Now that we have the total dust emission, distribute into dust bins using + ! lognormal distribution (Dr. Jasper Kok, in press), and + ! calculate total mass emitted over the grid box over the timestep. + ! + ! In calculating the Kok distribution, we assume upper and lower limits to each bin. + ! For reff_dust=(/0.73D-6,1.4D-6,2.4D-6,4.5D-6,8.0D-6/) (default), + ! lower limits were ASSUMED at lo_dust=(/0.1D-6,1.0D-6,1.8D-6,3.0D-6,6.0D-6/) + ! upper limits were ASSUMED at up_dust=(/1.0D-6,1.8D-6,3.0D-6,6.0D-6,10.0D-6/) + ! These may be changed within module_data_gocart_dust.F, but make sure it is + ! consistent with reff_dust values. These values were taken from the original + ! GOCART bin configuration. We use them here to calculate dust bin width, dlndp. + ! dVol is the volume distribution. You know...if you were wondering. GC + + dvol_tot=0. + DO n=1,nmx + dlndp(n)=LOG(up_dust(n)/lo_dust(n)) + dvol(n)=(2.0*reff_dust(n)/cv)*(1.+ERF(LOG(2.0*reff_dust(n)/mmd_dust)/(SQRT(2.)*LOG(gsd_dust))))*& + EXP(-(2.0*reff_dust(n)/lambda)**3.0)*dlndp(n) + dvol_tot=dvol_tot+dvol(n) + ! Convert mass flux to volume flux + !emit_vol=emit/den_dust(n) ! (m s^-1) + END DO + DO n=1,nmx + distr_dust(n)=dvol(n)/dvol_tot + !print *,"distr_dust(",n,")=",distr_dust(n) + END DO + + ! Now distribute total vertical emission into dust bins and update concentration. + + DO n=1,nmx + ! Calculate total mass emitted + dsrc = emit*distr_dust(n)*dxy*dt1 ! (kg) + IF (dsrc < 0.0) dsrc = 0.0 + + ! Update dust mixing ratio at first model level. + tc(n) = tc(n) + dsrc / airmas ! (kg/kg) + ! bems(i,j,n) = dsrc ! diagnostic + !bems(i,j,n) = 1000.*dsrc/(dxy(j)*dt1) ! diagnostic (g/m2/s) + bems(n) = 1.e+9*dsrc/(dxy*dt1) ! diagnostic (ug/m2/s) !lzhang + + END DO + tc(1)=tc(1)+0.286*tc(2) ! This is just for RRFS-SD. DO NOT use in other models!!! + tc(5)=0.714*tc(2)+tc(3)+tc(4) ! This is just for RRFS-SD. DO NOT use in other models!!! + + END SUBROUTINE source_dust + + + subroutine fengsha_drag(z0,R) + implicit none + + real(kind_phys), intent(in) :: z0 + real(kind_phys), intent(out) :: R + real(kind_phys), parameter :: z0s = 1.0e-04 !Surface roughness for ideal bare surface [m] + ! ------------------------------------------------------------------------ + ! Function: Calculates the MacKinnon et al. 2004 Drag Partition Correction + ! + ! R = 1.0 - log(z0 / z0s) / log( 0.7 * (12255./z0s) ** 0.8) + ! + !-------------------------------------------------------------------------- + ! Drag partition correction. See MacKinnon et al. (2004), + ! doi:10.1016/j.geomorph.2004.03.009 + R = 1.0 - log(z0 / z0s) / log( 0.7 * (12255./z0s) ** 0.8) + + ! Drag partition correction. See Marticorena et al. (1997), + ! doi:10.1029/96JD02964 + !R = 1.0 - log(z0 / z0s) / log( 0.7 * (10./z0s) ** 0.8) + + return + end subroutine fengsha_drag + + subroutine DustEmissionFENGSHA(slc, clay, sand, silt, & + ssm, rdrag, airdens, ustar, uthrs, alpha, gamma, & + kvhmax, grav, rhop, emissions) + + ! !USES: + implicit NONE + +! !INPUT PARAMETERS: + REAL(kind_phys), intent(in) :: slc ! liquid water content of soil layer, volumetric fraction [1] + REAL(kind_phys), intent(in) :: clay ! fractional clay content [1] + REAL(kind_phys), intent(in) :: sand ! fractional sand content [1] + REAL(kind_phys), intent(in) :: silt ! fractional silt content [1] + REAL(kind_phys), intent(in) :: ssm ! erosion map [1] + REAL(kind_phys), intent(in) :: rdrag ! drag partition [1/m] + REAL(kind_phys), intent(in) :: airdens ! air density at lowest level [kg/m^3] + REAL(kind_phys), intent(in) :: ustar ! friction velocity [m/sec] + REAL(kind_phys), intent(in) :: uthrs ! threshold velocity [m/2] + REAL(kind_phys), intent(in) :: alpha ! scaling factor [1] + REAL(kind_phys), intent(in) :: gamma ! scaling factor [1] + REAL(kind_phys), intent(in) :: kvhmax ! max. vertical to horizontal mass flux ratio [1] + REAL(kind_phys), intent(in) :: grav ! gravity [m/sec^2] + REAL(kind_phys), intent(in) :: rhop ! soil class density [kg/m^3] + + ! !OUTPUT PARAMETERS: + REAL(kind_phys), intent(inout) :: emissions ! binned surface emissions [kg/(m^2 sec)] + + ! !DESCRIPTION: Compute dust emissions using NOAA/ARL FENGSHA model + ! + ! !REVISION HISTORY: + ! + ! 22Feb2020 B.Baker/NOAA - Original implementation + ! 29Mar2021 R.Montuoro/NOAA - Refactored for process library + ! 09Aug2022 B.Baker/NOAA - Adapted for CCPP-Physics + + ! !Local Variables + real(kind_phys) :: alpha_grav + real(kind_phys) :: h + real(kind_phys) :: kvh + real(kind_phys) :: q + real(kind_phys) :: rustar + real(kind_phys) :: total_emissions + real(kind_phys) :: u_sum, u_thresh + +!EOP +!------------------------------------------------------------------------- +! Begin + +! Initialize emissions +! -------------------- + emissions = 0. + +! Prepare scaling factor +! ---------------------- + alpha_grav = alpha / grav + + ! Compute vertical-to-horizontal mass flux ratio + ! ---------------------------------------------- + kvh = DustFluxV2HRatioMB95(clay, kvhmax) + + ! Compute total emissions + ! ----------------------- + emissions = alpha_grav * (ssm ** gamma) * airdens * kvh + + ! Compute threshold wind friction velocity using drag partition + ! ------------------------------------------------------------- + rustar = rdrag * ustar + + ! Now compute size-dependent total emission flux + ! ---------------------------------------------- + ! Fecan moisture correction + ! ------------------------- + h = moistureCorrectionFecan(slc, sand, clay, rhop) + + ! Adjust threshold + ! ---------------- + u_thresh = uthrs * h + + u_sum = rustar + u_thresh + + ! Compute Horizontal Saltation Flux according to Eq (9) in Webb et al. (2020) + ! --------------------------------------------------------------------------- + q = max(0., rustar - u_thresh) * u_sum * u_sum + + ! Distribute emissions to bins and convert to mass flux (kg s-1) + ! -------------------------------------------------------------- + emissions = emissions * q + + + end subroutine DustEmissionFENGSHA +!----------------------------------------------------------------- + real function soilMoistureConvertVol2Grav(vsoil, sandfrac, rhop) + +! !USES: + implicit NONE + +! !INPUT PARAMETERS: + REAL(kind_phys), intent(in) :: vsoil ! volumetric soil moisture fraction [1] + REAL(kind_phys), intent(in) :: sandfrac ! fractional sand content [1] + REAL(kind_phys), intent(in) :: rhop ! dry dust density [kg m-3] + +! !DESCRIPTION: Convert soil moisture fraction from volumetric to gravimetric. +! +! !REVISION HISTORY: +! +! 02Apr2020, B.Baker/NOAA - Original implementation +! 01Apr2020, R.Montuoro/NOAA - Adapted for GOCART process library + +! !Local Variables + real :: vsat + +! !CONSTANTS: + REAL(kind_phys), parameter :: rhow = 1000. ! density of water [kg m-3] + +!EOP +!------------------------------------------------------------------------- +! Begin... + +! Saturated volumetric water content (sand-dependent) ! [m3 m-3] + vsat = 0.489 - 0.00126 * ( 100. * sandfrac ) + +! Gravimetric soil content + soilMoistureConvertVol2Grav = vsoil * rhow / (rhop * (1. - vsat)) + + end function soilMoistureConvertVol2Grav +!---------------------------------------------------------------- + real function moistureCorrectionFecan(slc, sand, clay, rhop) + +! !USES: + implicit NONE + +! !INPUT PARAMETERS: + REAL(kind_phys), intent(in) :: slc ! liquid water content of top soil layer, volumetric fraction [1] + REAL(kind_phys), intent(in) :: sand ! fractional sand content [1] + REAL(kind_phys), intent(in) :: clay ! fractional clay content [1] + REAL(kind_phys), intent(in) :: rhop ! dry dust density [kg m-3] + +! !DESCRIPTION: Compute correction factor to account for Fecal soil moisture +! +! !REVISION HISTORY: +! +! 02Apr2020, B.Baker/NOAA - Original implementation +! 01Apr2020, R.Montuoro/NOAA - Adapted for GOCART process library + +! !Local Variables + real :: grvsoilm + real :: drylimit + +!EOP +!--------------------------------------------------------------- +! Begin... + +! Convert soil moisture from volumetric to gravimetric + grvsoilm = soilMoistureConvertVol2Grav(slc, sand, 2650.) + +! Compute fecan dry limit + drylimit = clay * (14.0 * clay + 17.0) + +! Compute soil moisture correction + moistureCorrectionFecan = sqrt(1.0 + 1.21 * max(0., grvsoilm - drylimit)**0.68) + + end function moistureCorrectionFecan +!--------------------------------------------------------------- + real function DustFluxV2HRatioMB95(clay, kvhmax) + +! !USES: + implicit NONE + +! !INPUT PARAMETERS: + REAL(kind_phys), intent(in) :: clay ! fractional clay content [1] + REAL(kind_phys), intent(in) :: kvhmax ! maximum flux ratio [1] + +! !CONSTANTS: + REAL(kind_phys), parameter :: clay_thresh = 0.2 ! clay fraction above which the maximum flux ratio is returned + +! !DESCRIPTION: Computes the vertical-to-horizontal dust flux ratio according to +! B.Marticorena, G.Bergametti, J.Geophys.Res., 100(D8), 164! doi:10.1029/95JD00690 +! +! !REVISION HISTORY: +! +! 22Feb2020 B.Baker/NOAA - Original implementation +! 01Apr2021 R.Montuoro/NOAA - Adapted for GOCART process library +! +!EOP +!------------------------------------------------------------------------- +! Begin... + + if (clay > clay_thresh) then + DustFluxV2HRatioMB95 = kvhmax + else + DustFluxV2HRatioMB95 = 10.0**(13.4*clay-6.0) + end if + + end function DustFluxV2HRatioMB95 + +end module dust_fengsha_mod diff --git a/smoke/module_add_emiss_burn.F90 b/physics/smoke_dust/module_add_emiss_burn.F90 similarity index 90% rename from smoke/module_add_emiss_burn.F90 rename to physics/smoke_dust/module_add_emiss_burn.F90 index da35535f7..6cdd2e071 100755 --- a/smoke/module_add_emiss_burn.F90 +++ b/physics/smoke_dust/module_add_emiss_burn.F90 @@ -4,15 +4,14 @@ module module_add_emiss_burn !RAR: significantly modified for the new BB emissions use machine , only : kind_phys - use rrfs_smoke_data use rrfs_smoke_config CONTAINS - subroutine add_emis_burn(data,dtstep,ktau,dz8w,rho_phy,rel_hum, & + subroutine add_emis_burn(dtstep,dz8w,rho_phy,rel_hum, & chem,julday,gmt,xlat,xlong, & !luf_igbp,lu_fire1, & vegtype,vfrac,peak_hr, & time_int,ebu, & ! RAR - r_q,fhist,aod3d_smoke,aod3d_dust, & + r_q,fhist,ext3d_smoke,ext3d_dust, & ! nwfa,nifa, & rainc,rainnc, swdown,smoke_forecast, & ids,ide, jds,jde, kds,kde, & @@ -22,11 +21,10 @@ subroutine add_emis_burn(data,dtstep,ktau,dz8w,rho_phy,rel_hum, & ! USE module_configure, only: grid_config_rec_type ! USE module_state_description IMPLICIT NONE - type(smoke_data), intent(inout) :: data ! TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN ) :: ktau, julday, & + INTEGER, INTENT(IN ) :: julday, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte @@ -40,7 +38,7 @@ subroutine add_emis_burn(data,dtstep,ktau,dz8w,rho_phy,rel_hum, & real(kind_phys), DIMENSION(ims:ime,jms:jme), INTENT(IN) :: xlat,xlong, rainc,rainnc,swdown, peak_hr, vfrac real(kind_phys), DIMENSION(ims:ime,jms:jme), INTENT(OUT) :: r_q ! RAR: real(kind_phys), DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: fhist ! RAR: - real(kind_phys), DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(OUT) :: aod3d_smoke, aod3d_dust ! RAR: + real(kind_phys), DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(OUT) :: ext3d_smoke, ext3d_dust ! RAR: integer, DIMENSION(ims:ime,jms:jme), INTENT(IN) :: vegtype real(kind_phys), DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(IN) :: dz8w,rho_phy,rel_hum @@ -51,14 +49,14 @@ subroutine add_emis_burn(data,dtstep,ktau,dz8w,rho_phy,rel_hum, & real(kind_phys), INTENT(IN) :: dtstep, gmt real(kind_phys), INTENT(IN) :: time_int ! RAR: time in seconds since start of simulation - logical, INTENT(IN) :: smoke_forecast + integer, INTENT(IN) :: smoke_forecast integer :: i,j,k,n,m real(kind_phys) :: conv_rho, conv, ext2, dm_smoke, daero_num_wfa, daero_num_ifa !, lu_sum1_5, lu_sum12_14 !real(kind_phys) :: ebumax ! CHARACTER (LEN=80) :: message - INTEGER, PARAMETER :: kfire_max=35 ! max vertical level for BB plume rise + INTEGER, PARAMETER :: kfire_max=51 ! max vertical level for BB plume rise ! Diameters and standard deviations for emissions ! the diameters are the volume (mass) geometric mean diameters, following MADE_SORGAM real(kind_phys), PARAMETER :: dgvem_i= 0.08E-6 !0.03E-6 ! [ m ] @@ -148,7 +146,7 @@ subroutine add_emis_burn(data,dtstep,ktau,dz8w,rho_phy,rel_hum, & ! r_q(i,j)= fhist(i,j) ! no diurnal cycle !END IF - !IF (.NOT. smoke_forecast) THEN + !IF (smoke_forecast == 0) THEN r_q(i,j)= 1. !END IF @@ -174,21 +172,19 @@ subroutine add_emis_burn(data,dtstep,ktau,dz8w,rho_phy,rel_hum, & chem(i,k,j,p_smoke) = chem(i,k,j,p_smoke) + dm_smoke chem(i,k,j,p_smoke) = MIN(chem(i,k,j,p_smoke),5.e+3) - if (ktau<1000 .and. dbg_opt) then ! if ( k==kts ) then - ! WRITE(6,*) 'add_emiss_burn: ktau,gmt,dtstep,time_int ',ktau,gmt,dtstep,time_int + ! WRITE(6,*) 'add_emiss_burn: gmt,dtstep,time_int ',gmt,dtstep,time_int ! WRITE(*,*) 'add_emiss_burn: i,j,xlat(i,j),xlong(i,j) ',i,j,xlat(i,j),xlong(i,j) !WRITE(*,*) 'add_emiss_burn: luf_igbp(i,:,j) ',luf_igbp(i,:,j) !WRITE(*,*) 'add_emiss_burn: lu_fire1(i,j) ',lu_fire1(i,j) ! WRITE(6,*) 'add_emiss_burn: timeq,peak_hr(i,j),fhist(i,j),r_q(i,j) ',timeq,peak_hr(i,j),fhist(i,j),r_q(i,j) ! WRITE(*,*) 'add_emiss_burn: rainc(i,j),rainnc(i,j) ', rainc(i,j),rainnc(i,j) ! endif - if ( k==kts .OR. k==kfire_max ) then + if ( dbg_opt .and. (k==kts .OR. k==kfire_max) ) then WRITE(6,*) 'add_emiss_burn: i,j,k ',i,j,k WRITE(6,*) 'add_emiss_burn: rho_phy(i,k,j),dz8w(i,k,j),conv ',rho_phy(i,k,j),dz8w(i,k,j),conv WRITE(6,*) 'add_emiss_burn: ebu(i,k,j),dm_smoke ', ebu(i,k,j),dm_smoke endif - endif enddo enddo @@ -204,17 +200,17 @@ subroutine add_emis_burn(data,dtstep,ktau,dz8w,rho_phy,rel_hum, & chem(i,k,j,p_smoke)=1.e-16 END IF - aod3d_smoke(i,k,j)= 1.e-6* ext2* chem(i,k,j,p_smoke )*rho_phy(i,k,j)*dz8w(i,k,j) - aod3d_dust (i,k,j)= 1.e-6* ext2* chem(i,k,j,p_dust_1)*rho_phy(i,k,j)*dz8w(i,k,j) + ext3d_smoke(i,k,j)= 1.e-6* ext2* chem(i,k,j,p_smoke )*rho_phy(i,k,j)*dz8w(i,k,j) + ext3d_dust (i,k,j)= 1.e-6* ext2* chem(i,k,j,p_dust_1)*rho_phy(i,k,j)*dz8w(i,k,j) enddo enddo enddo - IF ( ktau<2000 .and. dbg_opt ) then + IF ( dbg_opt ) then WRITE(*,*) 'add_emis_burn: i,j,k,ext2 ',i,j,k,ext2 WRITE(*,*) 'add_emis_burn: rel_hum(its,kts,jts),rel_hum(ite,kfire_max,jte) ',rel_hum(its,kts,jts),rel_hum(ite,kfire_max,jte) - WRITE(*,*) 'add_emis_burn: aod3d_smoke(its,kts,jts),aod3d_smoke(ite,kfire_max,jte) ',aod3d_smoke(its,kts,jts),aod3d_smoke(ite,kfire_max,jte) - WRITE(*,*) 'add_emis_burn: aod3d_dust(its,kts,jts),aod3d_dust(ite,kfire_max,jte) ',aod3d_dust(its,kts,jts),aod3d_dust(ite,kfire_max,jte) + WRITE(*,*) 'add_emis_burn: ext3d_smoke(its,kts,jts),ext3d_smoke(ite,kfire_max,jte) ',ext3d_smoke(its,kts,jts),ext3d_smoke(ite,kfire_max,jte) + WRITE(*,*) 'add_emis_burn: ext3d_dust(its,kts,jts),ext3d_dust(ite,kfire_max,jte) ',ext3d_dust(its,kts,jts),ext3d_dust(ite,kfire_max,jte) END IF ! CASE DEFAULT diff --git a/smoke/module_plumerise1.F90 b/physics/smoke_dust/module_plumerise1.F90 similarity index 91% rename from smoke/module_plumerise1.F90 rename to physics/smoke_dust/module_plumerise1.F90 index 47bb4e74a..3c23faa6a 100755 --- a/smoke/module_plumerise1.F90 +++ b/physics/smoke_dust/module_plumerise1.F90 @@ -3,7 +3,6 @@ module module_plumerise1 - use rrfs_smoke_data use machine , only : kind_phys real(kind=kind_phys),parameter :: p1000mb = 100000. ! p at 1000mb (pascals) !- Implementing the fire radiative power (FRP) methodology for biomass burning @@ -35,10 +34,10 @@ module module_plumerise1 ! 'aggr' /) ! grassland CONTAINS -subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & +subroutine ebu_driver ( flam_frac,ebb_smoke,ebu, & t_phy,q_vap, & ! RAR: moist is replaced with q_vap rho_phy,vvel,u_phy,v_phy,p_phy, & - z_at_w,z,ktau,g,con_cp,con_rd, & ! scale_fire_emiss is part of config_flags + z_at_w,z,g,con_cp,con_rd, & ! scale_fire_emiss is part of config_flags plume_frp, k_min, k_max, & ! RAR: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -49,7 +48,6 @@ subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & USE module_zero_plumegen_coms USE module_smoke_plumerise IMPLICIT NONE - type(smoke_data), intent(inout) :: data REAL(kind_phys), PARAMETER :: frp_threshold= 1.e+7 ! Minimum FRP (Watts) to have plume rise @@ -58,8 +56,7 @@ subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & ! TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags character(*), intent(inout) :: errmsg integer, intent(inout) :: errflg - INTEGER, INTENT(IN ) :: ktau, & - ids,ide, jds,jde, kds,kde, & + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ! real(kind=kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & @@ -98,7 +95,6 @@ subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & ! write(0,*)'plumerise' ! RAR: -! if (config_flags%biomass_burn_opt == BIOMASSB_SMOKE) then ! do j=jts,jte: ! do i=its,ite ! ebu(i,kts,j,p_ebu_smoke)= ebb_smoke(i,j) @@ -115,12 +111,12 @@ subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & cpor =con_cp/con_rd con_rocp=con_rd/con_cp - IF ( dbg_opt .and. ktau<2000) then + IF ( dbg_opt ) then WRITE(*,*) 'module_plumerise1: its,ite,jts,jte ', its,ite,jts,jte WRITE(*,*) 'module_plumerise1: ims,ime,jms,jme ', ims,ime,jms,jme !WRITE(*,*) 'module_plumerise1: p_ebu_smoke,num_ebu: ', p_ebu_smoke,num_ebu WRITE(*,*) 'module_plumerise1: maxval(ebu(:,kts,:)) ', maxval(ebu(:,kts,:)) - END IF + END IF !endif ! RAR: setting to zero the ebu emissions at the levels k>1, this is necessary when the plumerise is called, so the emissions at k>1 are updated @@ -136,7 +132,6 @@ subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & ! For now the flammable fraction is constant, based on the namelist. The next ! step to use LU index and meteorology to parameterize it -! IF (ktau==2) THEN do j=jts,jte do i=its,ite flam_frac(i,j)= 0. @@ -145,13 +140,12 @@ subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & end if enddo enddo - ! ENDIF ! RAR: new FRP based approach !check_pl: IF (config_flags%plumerise_flag == 2 ) THEN ! if the namelist option is set for plumerise ! Haiqin: plumerise_flag is added to the namelist options -!check_pl: IF (do_plumerise) THEN ! if the namelist option is set for plumerise +check_pl: IF (do_plumerise) THEN ! if the namelist option is set for plumerise do j=jts,jte do i=its,ite ! k_min(i,j)=0 @@ -175,7 +169,7 @@ subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & !theta_in(k)= t_phy(i,k,j)/pi_in(k)*cp enddo - IF (dbg_opt .and. ktau<2000) then + IF (dbg_opt) then WRITE(*,*) 'module_plumerise1: i,j ',i,j WRITE(*,*) 'module_plumerise1: plume_frp(i,j,:) ',plume_frp(i,j,:) WRITE(*,*) 'module_plumerise1: ebu(i,kts,j) ',ebu(i,kts,j) @@ -185,15 +179,15 @@ subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & END IF ! RAR: the plume rise calculation step: - CALL plumerise(data,kte,1,1,1,1,1,1, & + CALL plumerise(kte,1,1,1,1,1,1, & !firesize,mean_fct, & !num_ebu, eburn_in, eburn_out, & u_in, v_in, w_in, theta_in ,pi_in, & rho_phyin, qv_in, zmid, z_lev, & plume_frp(i,j,1), k_min(i,j), & - k_max(i,j), ktau, dbg_opt, g, con_cp, & + k_max(i,j), dbg_opt, g, con_cp, & con_rd, cpor, errmsg, errflg ) - !k_max(i,j), ktau, config_flags%debug_chem ) + !k_max(i,j), config_flags%debug_chem ) if(errflg/=0) return kp1= k_min(i,j) @@ -205,7 +199,7 @@ subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & enddo ebu(i,kts,j)= (1.-flam_frac(i,j))* ebb_smoke(i,j) - IF ( dbg_opt .and. ktau<2000) then + IF ( dbg_opt ) then WRITE(*,*) 'module_plumerise1: i,j ',i,j WRITE(*,*) 'module_plumerise1: k_min(i,j), k_max(i,j) ',k_min(i,j), k_max(i,j) END IF @@ -213,7 +207,7 @@ subroutine ebu_driver ( data,flam_frac,ebb_smoke,ebu, & enddo enddo -! ENDIF check_pl + ENDIF check_pl end subroutine ebu_driver diff --git a/smoke/module_smoke_plumerise.F90 b/physics/smoke_dust/module_smoke_plumerise.F90 similarity index 98% rename from smoke/module_smoke_plumerise.F90 rename to physics/smoke_dust/module_smoke_plumerise.F90 index 247b09f92..5a1a2319d 100755 --- a/smoke/module_smoke_plumerise.F90 +++ b/physics/smoke_dust/module_smoke_plumerise.F90 @@ -14,8 +14,6 @@ module module_smoke_plumerise use machine , only : kind_phys - use rrfs_smoke_data - use rrfs_smoke_config, only : FIRE_OPT_GBBEPx, FIRE_OPT_MODIS use plume_data_mod, only : num_frp_plume, p_frp_hr, p_frp_std, & !tropical_forest, boreal_forest, savannah, grassland, & wind_eff @@ -26,15 +24,14 @@ module module_smoke_plumerise CONTAINS ! RAR: - subroutine plumerise(data,m1,m2,m3,ia,iz,ja,jz, & + subroutine plumerise(m1,m2,m3,ia,iz,ja,jz, & ! firesize,mean_fct, & ! nspecies,eburn_in,eburn_out, & up,vp,wp,theta,pp,dn0,rv,zt_rams,zm_rams, & - frp_inst,k1,k2, ktau, dbg_opt, g, cp, rgas, & + frp_inst,k1,k2, dbg_opt, g, cp, rgas, & cpor, errmsg, errflg ) implicit none - type(smoke_data), intent(inout) :: data LOGICAL, INTENT (IN) :: dbg_opt @@ -46,7 +43,6 @@ subroutine plumerise(data,m1,m2,m3,ia,iz,ja,jz, & integer :: ng,m1,m2,m3,ia,iz,ja,jz,ibcon,mynum,i,j,k,imm,ixx,ispc !,nspecies - INTEGER, INTENT (IN) :: ktau INTEGER, INTENT (OUT) :: k1,k2 character(*), intent(inout) :: errmsg integer, intent(inout) :: errflg @@ -106,9 +102,6 @@ subroutine plumerise(data,m1,m2,m3,ia,iz,ja,jz, & !---------------------------------------------------------------------- ! print *,' Plumerise_scalar 1',ncall coms => get_thread_coms() - if (ktau==2) then - call coms%set_to_zero() - endif IF (frp_inst=k1+1 @@ -208,7 +199,7 @@ subroutine plumerise(data,m1,m2,m3,ia,iz,ja,jz, & ! enddo !enddo - IF (dbg_opt .AND. ktau<2000) then + IF (dbg_opt) then WRITE(*,*) 'plumerise after set_flam_vert: nkp,k1,k2, ', nkp,k1,k2 WRITE(*,*) 'plumerise after set_flam_vert: dzi ', dzi !WRITE(*,*) 'plumerise after set_flam_vert: eburn_in(2) ', eburn_in(2) @@ -220,7 +211,7 @@ subroutine plumerise(data,m1,m2,m3,ia,iz,ja,jz, & end subroutine plumerise !------------------------------------------------------------------------- -subroutine get_env_condition(coms,k1,k2,kmt,wind_eff,ktau,g,cp,rgas,cpor,errmsg,errflg) +subroutine get_env_condition(coms,k1,k2,kmt,wind_eff,g,cp,rgas,cpor,errmsg,errflg) !se module_zero_plumegen_coms !use rconstants @@ -232,11 +223,11 @@ subroutine get_env_condition(coms,k1,k2,kmt,wind_eff,ktau,g,cp,rgas,cpor,errmsg, real(kind=kind_phys),parameter :: p00=p1000mb real(kind=kind_phys) :: znz,themax,tlll,plll,rlll,zlll,dzdd,dzlll,tlcl,plcl,dzlcl,dummy !integer :: n_setgrid = 0 -integer :: wind_eff,ktau +integer :: wind_eff character(*), intent(inout) :: errmsg integer, intent(inout) :: errflg -if(ktau==2) then +if(.not.coms%initialized) then ! n_setgrid = 1 call set_grid(coms) ! define vertical grid of plume model ! coms%zt(k) = thermo and water levels @@ -348,6 +339,8 @@ subroutine set_grid(coms) coms%dzt(k) = 1. / (coms%zm(k) - coms%zm(k-1)) enddo coms%dzt(1) = coms%dzt(2) * coms%dzt(2) / coms%dzt(3) + +coms%initialized = .true. ! coms%dzm(1) = 0.5/coms%dz ! coms%dzm(2:mzp) = 1./coms%dz @@ -447,23 +440,24 @@ subroutine get_fire_properties(coms,imm,iveg_ag,burnt_area,FRP,errmsg,errflg) type(plumegen_coms), pointer :: coms integer :: moist, i, icount,imm,iveg_ag !,plumerise_flag real(kind=kind_phys):: bfract, effload, heat, hinc ,burnt_area,heat_fluxW,FRP -real(kind=kind_phys), dimension(2,4) :: heat_flux +!real(kind=kind_phys), dimension(2,4) :: heat_flux integer, intent(inout) :: errflg character(*), intent(inout) :: errmsg -INTEGER, parameter :: use_last = 0 +INTEGER, parameter :: use_last = 1 ! RAR 10/31/2022: I set to one, checking with Saulo + !real(kind=kind_phys), parameter :: beta = 5.0 !ref.: Wooster et al., 2005 REAL(kind=kind_phys), parameter :: beta = 0.88 !ref.: Paugam et al., 2015 -data heat_flux/ & +!data heat_flux/ & RAR: not used !--------------------------------------------------------------------- ! heat flux !IGBP Land Cover ! ! min ! max !Legend and ! reference ! kW/m^2 !description ! !-------------------------------------------------------------------- -30.0, 80.0, &! Tropical Forest ! igbp 2 & 4 -30.0, 80.0, &! Boreal(kind=kind_phys) forest ! igbp 1 & 3 -4.4, 23.0, &! cerrado/woody savanna | igbp 5 thru 9 -3.3, 3.3 /! Grassland/cropland ! igbp 10 thru 17 +!30.0, 80.0, &! Tropical Forest ! igbp 2 & 4 +!30.0, 80.0, &! Boreal(kind=kind_phys) forest ! igbp 1 & 3 +!4.4, 23.0, &! cerrado/woody savanna | igbp 5 thru 9 +!3.3, 3.3 /! Grassland/cropland ! igbp 10 thru 17 !-------------------------------------------------------------------- !-- fire at surface ! @@ -556,7 +550,7 @@ subroutine get_fire_properties(coms,imm,iveg_ag,burnt_area,FRP,errmsg,errflg) COMS%HEATING (ICOUNT) = heat_fluxW * 0.55 ! W/m**2 (0.55 converte para energia convectiva) ICOUNT = ICOUNT + 1 ENDDO -! ramp for 5 minutes +! ramp for 5 minutes, RAR: in the current version this is inactive IF(use_last /= 1) THEN HINC = COMS%HEATING (1) / 4. @@ -565,15 +559,17 @@ subroutine get_fire_properties(coms,imm,iveg_ag,burnt_area,FRP,errmsg,errflg) COMS%HEATING (3) = 2. * HINC COMS%HEATING (4) = 3. * HINC ELSE + HINC = COMS%HEATING (1) / 4. ! RAR: this needs to be revised later IF(imm==1) THEN - HINC = COMS%HEATING (1) / 4. + !HINC = COMS%HEATING (1) / 4. COMS%HEATING (1) = 0.1 COMS%HEATING (2) = HINC COMS%HEATING (3) = 2. * HINC COMS%HEATING (4) = 3. * HINC ELSE - HINC = (COMS%HEATING (1) - heat_flux(imm-1,iveg_ag) * 1000. *0.55)/ 4. - COMS%HEATING (1) = heat_flux(imm-1,iveg_ag) * 1000. *0.55 + 0.1 + ! RAR: I've commented out so we don't use the look-up table for heat flux + ! HINC = (COMS%HEATING (1) - heat_flux(imm-1,iveg_ag) * 1000. *0.55)/ 4. + ! COMS%HEATING (1) = heat_flux(imm-1,iveg_ag) * 1000. *0.55 + 0.1 COMS%HEATING (2) = COMS%HEATING (1)+ HINC COMS%HEATING (3) = COMS%HEATING (2)+ HINC COMS%HEATING (4) = COMS%HEATING (3)+ HINC diff --git a/physics/smoke_dust/module_wetdep_ls.F90 b/physics/smoke_dust/module_wetdep_ls.F90 new file mode 100755 index 000000000..87212920b --- /dev/null +++ b/physics/smoke_dust/module_wetdep_ls.F90 @@ -0,0 +1,79 @@ +!>\file module_wetdep_ls.F90 +!! This file contains aerosol wet deposition module. + +module module_wetdep_ls + use machine , only : kind_phys + use rrfs_smoke_config, only : p_qc, alpha => wetdep_ls_alpha + +contains +subroutine wetdep_ls(dt,var,rain,moist, & + rho,nchem,num_moist,dz8w,vvel, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + implicit none + + integer, intent(in) :: nchem, num_moist, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + real(kind_phys), intent(in) :: dt + real(kind_phys), dimension( ims:ime, kms:kme, jms:jme, num_moist),intent(in) :: moist + real(kind_phys), dimension( ims:ime, kms:kme, jms:jme),intent(in) :: rho,dz8w,vvel + real(kind_phys), dimension( ims:ime, kms:kme, jms:jme,1:nchem),intent(inout) :: var + real(kind_phys), dimension( ims:ime, jms:jme),intent(in) :: rain + real(kind_phys), dimension( its:ite, jts:jte) :: var_sum,var_rmv + real(kind_phys), dimension( its:ite, kts:kte, jts:jte) :: var_rmvl + real(kind_phys), dimension( its:ite, jts:jte) :: frc,var_sum_clw,rain_clw + real(kind_phys) :: dvar,factor,clsum + integer :: nv,i,j,k,km,kb,kbeg + !real(kind_phys), parameter :: alpha = .5 ! scavenging factor + + + do nv=1,nchem + do i=its,ite + do j=jts,jte + var_sum_clw(i,j)=0. + var_sum(i,j)=0. + var_rmvl(i,:,j)=0. + frc(i,j)=0. + rain_clw(i,j)=0. + if(rain(i,j).gt.1.e-10)then +! convert rain back to rate +! + rain_clw(i,j)=rain(i,j)/dt +! total cloud water +! + do k=1,kte-1 + dvar=max(0.,moist(i,k,j,p_qc)*rho(i,k,j)*vvel(i,k,j)*dz8w(i,k,j)) + var_sum_clw(i,j)=var_sum_clw(i,j)+dvar + var_sum(i,j)=var_sum(i,j)+var(i,k,j,nv)*rho(i,k,j) + enddo + if(var_sum(i,j).gt.1.e-10 .and. var_sum_clw(i,j).gt.1.e-10 ) then +! assuming that frc is onstant, it is my conversion factor +! (just like in convec. parameterization) + frc(i,j)=rain_clw(i,j)/var_sum_clw(i,j) + frc(i,j)=max(1.e-6,min(frc(i,j),.005)) + endif + endif + enddo + enddo +! +! get rid of it +! + do i=its,ite + do j=jts,jte + if(rain(i,j).gt.1.e-10 .and. var_sum(i,j).gt.1.e-10 .and. var_sum_clw(i,j).gt.1.e-10)then + do k=kts,kte-2 + if(var(i,k,j,nv).gt.1.e-16 .and. moist(i,k,j,p_qc).gt.0.)then + factor = max(0.,frc(i,j)*rho(i,k,j)*dz8w(i,k,j)*vvel(i,k,j)) + dvar=alpha*factor/(1+factor)*var(i,k,j,nv) + var(i,k,j,nv)=max(1.e-16,var(i,k,j,nv)-dvar) + endif + enddo + endif + enddo + enddo + enddo ! nv +end subroutine wetdep_ls +end module module_wetdep_ls diff --git a/smoke/module_zero_plumegen_coms.F90 b/physics/smoke_dust/module_zero_plumegen_coms.F90 similarity index 88% rename from smoke/module_zero_plumegen_coms.F90 rename to physics/smoke_dust/module_zero_plumegen_coms.F90 index 622d6a813..92b9ca2dc 100755 --- a/smoke/module_zero_plumegen_coms.F90 +++ b/physics/smoke_dust/module_zero_plumegen_coms.F90 @@ -9,6 +9,8 @@ module module_zero_plumegen_coms integer, parameter :: nkp = 200, ntime = 200 type plumegen_coms + logical :: initialized = .false. + real(kind=kind_phys),dimension(nkp) :: w,t,qv,qc,qh,qi,sc, & ! blob vth,vti,rho,txs, & est,qsat! never used: ,qpas,qtotal @@ -55,38 +57,28 @@ module module_zero_plumegen_coms procedure :: set_to_zero => plumegen_coms_zero end type plumegen_coms - interface plumegen_coms - procedure :: plumegen_coms_constructor - end interface plumegen_coms - - type(plumegen_coms), private, target :: private_thread_coms - logical, private :: mzpc_initialized = .false. + type(plumegen_coms), private, pointer :: private_thread_coms !$OMP THREADPRIVATE(private_thread_coms) -!$OMP THREADPRIVATE(mzpc_initialized) contains function get_thread_coms() result(coms) implicit none class(plumegen_coms), pointer :: coms - if(.not.mzpc_initialized) then - private_thread_coms = plumegen_coms() - mzpc_initialized = .true. + if(.not.associated(private_thread_coms)) then + allocate(private_thread_coms) + call plumegen_coms_zero(private_thread_coms) endif coms => private_thread_coms end function get_thread_coms - type(plumegen_coms) function plumegen_coms_constructor() result(this) - implicit none - call plumegen_coms_zero(this) - this%testval=3314 - end function plumegen_coms_constructor - subroutine plumegen_coms_zero(this) implicit none class(plumegen_coms) :: this + this%initialized = .false. + this%w=0.0 this%t=0.0 this%qv=0.0 diff --git a/smoke/plume_data_mod.F90 b/physics/smoke_dust/plume_data_mod.F90 similarity index 100% rename from smoke/plume_data_mod.F90 rename to physics/smoke_dust/plume_data_mod.F90 diff --git a/smoke/rrfs_smoke_config.F90 b/physics/smoke_dust/rrfs_smoke_config.F90 similarity index 66% rename from smoke/rrfs_smoke_config.F90 rename to physics/smoke_dust/rrfs_smoke_config.F90 index 43b3aee14..58d4c5846 100755 --- a/smoke/rrfs_smoke_config.F90 +++ b/physics/smoke_dust/rrfs_smoke_config.F90 @@ -16,59 +16,30 @@ module rrfs_smoke_config !-- constant paramters real(kind=kind_phys), parameter :: epsilc = 1.e-12 - !-- chemistyr module configurations + !-- aerosol module configurations integer :: chem_opt = 1 integer :: kemit = 1 integer :: dust_opt = 5 - integer :: dmsemis_opt = 1 integer :: seas_opt = 2 - integer :: biomass_burn_opt=1 logical :: do_plumerise = .true. integer :: addsmoke_flag = 1 - integer :: plumerisefire_frq=60 ! Let's add to the namelist - integer :: chem_conv_tr = 0 - integer :: aer_ra_feedback=1 !0 - integer :: aer_ra_frq = 60 + integer :: plumerisefire_frq=60 integer :: wetdep_ls_opt = 1 integer :: drydep_opt = 1 + integer :: coarsepm_settling = 1 logical :: bb_dcycle = .false. - logical :: smoke_forecast = .false. logical :: aero_ind_fdb = .false. logical :: dbg_opt = .true. - - real(kind=kind_phys), parameter :: depo_fact=0. - integer, parameter :: CHEM_OPT_GOCART= 1 - INTEGER, PARAMETER :: gocartracm_kpp = 301 - integer, parameter :: chem_tune_tracers = 20 - integer, parameter :: DUST_OPT_NONE = 0 - integer, parameter :: SEAS_OPT_NONE = 0 - ! -- DMS emissions - integer, parameter :: DMSE_OPT_NONE = 0 - integer, parameter :: DMSE_OPT_ENABLE = 1 - ! -- subgrid convective transport - integer, parameter :: CTRA_OPT_NONE = 0 - integer, parameter :: CTRA_OPT_GRELL = 2 - ! -- large scale wet deposition - integer, parameter :: WDLS_OPT_NONE = 0 - integer, parameter :: WDLS_OPT_GSD = 1 - integer, parameter :: WDLS_OPT_NGAC = 2 + integer :: smoke_forecast = 0 ! 0 read in ebb_smoke(i,24) + real(kind_phys) :: wetdep_ls_alpha = .5 ! scavenging factor ! -- + integer, parameter :: CHEM_OPT_GOCART= 1 integer, parameter :: call_chemistry = 1 integer, parameter :: num_moist=3, num_chem=20, num_emis_seas=5, num_emis_dust=5 - integer, parameter :: num_emis_ant = 7 - integer, parameter :: SEAS_OPT_DEFAULT = 1 - - integer, parameter :: DUST_OPT_GOCART = 1 - integer, parameter :: DUST_OPT_AFWA = 3 integer, parameter :: DUST_OPT_FENGSHA = 5 - ! -- biomass burning emissions - integer, parameter :: BURN_OPT_ENABLE = 1 - integer, parameter :: FIRE_OPT_MODIS = 1 - integer, parameter :: FIRE_OPT_GBBEPx = 2 - ! -- hydrometeors integer, parameter :: p_qv=1 integer, parameter :: p_qc=2 @@ -77,12 +48,9 @@ module rrfs_smoke_config ! -- FV3 GFDL microphysics integer, parameter :: p_atm_shum = 1 integer, parameter :: p_atm_cldq = 2 - integer, parameter :: p_atm_o3mr = 7 integer :: numgas = 0 - real(kind=kind_phys) :: wetdep_ls_alpha(chem_tune_tracers)=-999. - !-- tracers integer, parameter :: p_so2=1 integer, parameter :: p_sulf=2 @@ -97,7 +65,7 @@ module rrfs_smoke_config integer, parameter :: p_dust_2=11 integer, parameter :: p_dust_3=12 integer, parameter :: p_dust_4=13 - integer, parameter :: p_dust_5=14 + integer, parameter :: p_dust_5=14, p_coarse_pm=14 integer, parameter :: p_seas_1=15 integer, parameter :: p_seas_2=16 integer, parameter :: p_seas_3=17 diff --git a/smoke/rrfs_smoke_postpbl.F90 b/physics/smoke_dust/rrfs_smoke_postpbl.F90 similarity index 68% rename from smoke/rrfs_smoke_postpbl.F90 rename to physics/smoke_dust/rrfs_smoke_postpbl.F90 index f83aaf795..8fbfa7a51 100755 --- a/smoke/rrfs_smoke_postpbl.F90 +++ b/physics/smoke_dust/rrfs_smoke_postpbl.F90 @@ -15,26 +15,22 @@ module rrfs_smoke_postpbl contains -!>\defgroup rrfs_smoke_postpbl GSD Chem emission driver Module -!> \ingroup gsd_chem_group -!! This is the GSD Chem emission driver Module -!! \section arg_table_rrfs_smoke_postpbl_run Argument Table +!> \section arg_table_rrfs_smoke_postpbl_run Argument Table !! \htmlinclude rrfs_smoke_postpbl_run.html !! -!>\section rrfs_smoke_postpbl GSD Chemistry Scheme General Algorithm -!> @{ - subroutine rrfs_smoke_postpbl_run(ite, kte, ntsmoke, ntdust, ntrac, & - qgrs, chem3d, errmsg, errflg) + subroutine rrfs_smoke_postpbl_run(ite, kte, ntsmoke, ntdust, ntcoarsepm, ntrac, & + qgrs, chem3d, rrfs_sd, errmsg, errflg) implicit none - integer, intent(in) :: ite,kte,ntsmoke,ntdust,ntrac + integer, intent(in) :: ite,kte,ntsmoke,ntdust,ntcoarsepm,ntrac integer, parameter :: its=1,kts=1 real(kind_phys), dimension(:,:,:), intent(inout) :: qgrs real(kind_phys), dimension(:,:,:), intent(inout) :: chem3d + logical, intent(in) :: rrfs_sd character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -44,16 +40,20 @@ subroutine rrfs_smoke_postpbl_run(ite, kte, ntsmoke, ntdust, ntrac, & errmsg = '' errflg = 0 + if (.not. rrfs_sd) return + !--- put smoke stuff back into tracer array do k=kts,kte do i=its,ite qgrs(i,k,ntsmoke)= chem3d(i,k,1) qgrs(i,k,ntdust )= chem3d(i,k,2) + qgrs(i,k,ntcoarsepm)= chem3d(i,k,3) enddo enddo - end subroutine rrfs_smoke_postpbl_run + return + + end subroutine rrfs_smoke_postpbl_run -!> @} end module rrfs_smoke_postpbl diff --git a/smoke/rrfs_smoke_postpbl.meta b/physics/smoke_dust/rrfs_smoke_postpbl.meta similarity index 70% rename from smoke/rrfs_smoke_postpbl.meta rename to physics/smoke_dust/rrfs_smoke_postpbl.meta index 99aae69f2..dab56cddc 100755 --- a/smoke/rrfs_smoke_postpbl.meta +++ b/physics/smoke_dust/rrfs_smoke_postpbl.meta @@ -1,11 +1,11 @@ [ccpp-table-properties] - name = rrfs_smoke_wrapper + name = rrfs_smoke_postpbl type = scheme - dependencies = dep_dry_gocart_mod.F90,dep_dry_mod.F90,dep_simple_mod.F90,dep_vertmx_mod.F90,dep_wet_ls_mod.F90,dust_data_mod.F90,dust_fengsha_mod.F90,module_add_emiss_burn.F90,module_plumerise1.F90,module_smoke_plumerise.F90,module_zero_plumegen_coms.F90,plume_data_mod.F90,rrfs_smoke_config.F90,rrfs_smoke_data.F90,seas_data_mod.F90,seas_mod.F90,seas_ngac_mod.F90 + dependencies = dep_dry_mod.F90,module_wetdep_ls.F90,dust_data_mod.F90,dust_fengsha_mod.F90,module_add_emiss_burn.F90,module_plumerise1.F90,module_smoke_plumerise.F90,module_zero_plumegen_coms.F90,plume_data_mod.F90,rrfs_smoke_config.F90,seas_data_mod.F90,seas_mod.F90,seas_ngac_mod.F90 ######################################################################## [ccpp-arg-table] - name = rrfs_smoke_wrapper_run + name = rrfs_smoke_postpbl_run type = scheme [ite] standard_name = horizontal_loop_extent @@ -35,6 +35,13 @@ dimensions = () type = integer intent = in +[ntcoarsepm] + standard_name = index_for_coarse_pm_in_tracer_concentration_array + long_name = tracer index for coarse pm + units = index + dimensions = () + type = integer + intent = in [ntrac] standard_name = number_of_tracers long_name = number of tracers @@ -54,10 +61,17 @@ standard_name = chem3d_mynn_pbl_transport long_name = mynn pbl transport of smoke and dust units = various - dimensions = (horizontal_loop_extent,vertical_layer_dimension,2) + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_chemical_species_vertically_mixed) type = real kind = kind_phys intent = inout +[rrfs_sd] + standard_name = do_smoke_coupling + long_name = flag controlling rrfs_sd collection (default off) + units = flag + dimensions = () + type = logical + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/smoke/rrfs_smoke_wrapper.F90 b/physics/smoke_dust/rrfs_smoke_wrapper.F90 similarity index 66% rename from smoke/rrfs_smoke_wrapper.F90 rename to physics/smoke_dust/rrfs_smoke_wrapper.F90 index ac32e1ad4..530d875db 100755 --- a/smoke/rrfs_smoke_wrapper.F90 +++ b/physics/smoke_dust/rrfs_smoke_wrapper.F90 @@ -1,5 +1,5 @@ !>\file rrfs_smoke_wrapper.F90 -!! This file is CCPP RRFS smoke driver +!! This file is CCPP driver of RRFS Smoke and Dust !! Haiqin.Li@noaa.gov 02/2021 module rrfs_smoke_wrapper @@ -12,8 +12,9 @@ module rrfs_smoke_wrapper use plume_data_mod use module_plumerise1 !plume_rise_mod use module_add_emiss_burn + use coarsepm_settling_mod use dep_dry_mod - use rrfs_smoke_data + use module_wetdep_ls implicit none @@ -23,36 +24,39 @@ module rrfs_smoke_wrapper contains -!>\defgroup rrfs_smoke_wrapper GSD Chem emission driver Module +!>\defgroup rrfs_smoke_wrapper rrfs-sd emission driver Module !> \ingroup gsd_chem_group -!! This is the GSD Chem emission driver Module +!! This is the rrfs-sd emission driver Module !! \section arg_table_rrfs_smoke_wrapper_run Argument Table !! \htmlinclude rrfs_smoke_wrapper_run.html !! -!>\section rrfs_smoke_wrapper GSD Chemistry Scheme General Algorithm +!>\section rrfs_smoke_wrapper rrfs-sd Scheme General Algorithm !> @{ - subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, & - u10m, v10m, ustar, rlat, rlon, tskin, pb2d, t2m, dpt2m, & - pr3d, ph3d,phl3d, prl3d, tk3d, us3d, vs3d, spechum, w, & - nsoil, smc, vegtype, soiltyp, sigmaf, dswsfc, zorl,snow, & + subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, & + u10m, v10m, ustar, rlat, rlon, tskin, pb2d, t2m, dpt2m, & + pr3d, ph3d,phl3d, prl3d, tk3d, us3d, vs3d, spechum, w, & + nsoil, smc, vegtype, soiltyp, sigmaf, dswsfc, zorl,snow, & julian, idat, rain_cpl, rainc_cpl, exch, hf2d, g, pi, con_cp, con_rd, & - dust12m_in, emi_in, smoke_GBBEPx, ntrac, qgrs, gq0, chem3d, tile_num, & - ntsmoke, ntdust, imp_physics, imp_physics_thompson, & - nwfa, nifa, emanoc, & - emdust, emseas, ebb_smoke_hr, frp_hr, frp_std_hr, & - coef_bb, ebu_smoke,fhist, min_fplume, max_fplume, hwp, & - smoke_ext, dust_ext, & - seas_opt_in, dust_opt_in, biomass_burn_opt_in, drydep_opt_in, & - do_plumerise_in, plumerisefire_frq_in, addsmoke_flag_in, & + dust12m_in, emi_in, smoke_RRFS, ntrac, qgrs, gq0, chem3d, tile_num, & + ntsmoke, ntdust, ntcoarsepm, imp_physics, imp_physics_thompson, & + nwfa, nifa, emanoc, emdust, emseas, & + ebb_smoke_hr, frp_hr, frp_std_hr, & + coef_bb, ebu_smoke,fhist, min_fplume, max_fplume, hwp, wetness, & + smoke_ext, dust_ext, ndvel, ddvel_inout,rrfs_sd, & + dust_alpha_in, dust_gamma_in, fire_in, & + seas_opt_in, dust_opt_in, drydep_opt_in, coarsepm_settling_in, & + do_plumerise_in, plumerisefire_frq_in, addsmoke_flag_in, & + wetdep_ls_opt_in,wetdep_ls_alpha_in, & smoke_forecast_in, aero_ind_fdb_in,dbg_opt_in,errmsg,errflg) implicit none integer, intent(in) :: im,kte,kme,ktau,nsoil,tile_num,jdate(8),idat(8) - integer, intent(in) :: ntrac, ntsmoke, ntdust + integer, intent(in) :: ntrac, ntsmoke, ntdust, ntcoarsepm, ndvel real(kind_phys),intent(in) :: dt, julian, g, pi, con_cp, con_rd - logical, intent(in) :: smoke_forecast_in,aero_ind_fdb_in,dbg_opt_in + logical, intent(in) :: aero_ind_fdb_in,dbg_opt_in + integer, intent(in) :: smoke_forecast_in integer, parameter :: ids=1,jds=1,jde=1, kds=1 integer, parameter :: ims=1,jms=1,jme=1, kms=1 @@ -61,10 +65,10 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, integer, dimension(:), intent(in) :: land, vegtype, soiltyp real(kind_phys), dimension(:,:), intent(in) :: smc real(kind_phys), dimension(:,:,:), intent(in) :: dust12m_in - real(kind_phys), dimension(:,:,:), intent(in) :: smoke_GBBEPx + real(kind_phys), dimension(:,:,:), intent(in) :: smoke_RRFS real(kind_phys), dimension(:,:), intent(in) :: emi_in - real(kind_phys), dimension(:), intent(in) :: u10m, v10m, ustar, dswsfc, & - garea, rlat,rlon, tskin, pb2d, sigmaf, zorl, snow, & + real(kind_phys), dimension(:), intent(in) :: u10m, v10m, ustar, dswsfc, & + garea, rlat,rlon, tskin, pb2d, sigmaf, zorl, snow, & rain_cpl, rainc_cpl, hf2d, t2m, dpt2m real(kind_phys), dimension(:,:), intent(in) :: ph3d, pr3d real(kind_phys), dimension(:,:), intent(in) :: phl3d, prl3d, tk3d, & @@ -75,14 +79,19 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, real(kind_phys), dimension(:), intent(inout) :: ebb_smoke_hr, frp_hr, frp_std_hr real(kind_phys), dimension(:), intent(inout) :: coef_bb, fhist real(kind_phys), dimension(:,:), intent(inout) :: ebu_smoke + real(kind_phys), dimension(:,:), intent(inout) :: fire_in real(kind_phys), dimension(:), intent(inout) :: max_fplume, min_fplume real(kind_phys), dimension(:), intent( out) :: hwp real(kind_phys), dimension(:,:), intent(out) :: smoke_ext, dust_ext real(kind_phys), dimension(:,:), intent(inout) :: nwfa, nifa + real(kind_phys), dimension(:,:), intent(inout) :: ddvel_inout + real (kind=kind_phys), dimension(:), intent(in) :: wetness integer, intent(in ) :: imp_physics, imp_physics_thompson - integer, intent(in) :: seas_opt_in, dust_opt_in, biomass_burn_opt_in, & - drydep_opt_in, plumerisefire_frq_in, addsmoke_flag_in - logical, intent(in ) :: do_plumerise_in + real (kind=kind_phys), intent(in) :: dust_alpha_in, dust_gamma_in, wetdep_ls_alpha_in + integer, intent(in) :: seas_opt_in, dust_opt_in, drydep_opt_in, & + coarsepm_settling_in, plumerisefire_frq_in, & + addsmoke_flag_in, wetdep_ls_opt_in + logical, intent(in ) :: do_plumerise_in, rrfs_sd character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -97,7 +106,6 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, real(kind_phys), dimension(ims:im, kms:kme, jms:jme, 1:num_moist) :: moist real(kind_phys), dimension(ims:im, kms:kme, jms:jme, 1:num_chem ) :: chem real(kind_phys), dimension(ims:im, 1, jms:jme, 1:num_emis_seas ) :: emis_seas - real(kind_phys), dimension(ims:im, jms:jme, 1:num_chem ) :: dry_fall real(kind_phys), dimension(ims:im, jms:jme) :: seashelp integer :: ide, ime, ite, kde, julday @@ -115,22 +123,18 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, real(kind_phys), dimension(ims:im, jms:jme, num_frp_plume ) :: plume_frp real(kind_phys), dimension(ims:im, jms:jme ) :: coef_bb_dc, flam_frac, & fire_hist, peak_hr - real(kind_phys), dimension(ims:im,kms:kme,jms:jme ) :: aod3d_smoke, aod3d_dust + real(kind_phys), dimension(ims:im,kms:kme,jms:jme ) :: ext3d_smoke, ext3d_dust integer, dimension(ims:im, jms:jme ) :: min_fplume2, max_fplume2 - real(kind_phys) :: dtstep - logical :: call_plume, scale_fire_emiss + logical :: call_fire !>- optical variables real(kind_phys), dimension(ims:im, kms:kme, jms:jme) :: rel_hum + real(kind_phys), dimension(ims:im, jms:jme, ndvel) :: ddvel !>-- anthropogentic variables -! real(kind_phys), dimension(ims:im, kms:kemit, jms:jme, 1:num_emis_ant) :: emis_ant real(kind_phys), dimension(ims:im) :: emis_anoc - - real(kind_phys), dimension(ims:im, kms:kme, jms:jme) :: ac3, ahno3, anh3, asulf, cor3, h2oai, h2oaj, nu3 - real(kind_phys), dimension(ims:im, jms:jme) :: dep_vel_o3, e_co + real(kind_phys), dimension(ims:im, jms:jme, 1) :: sedim real(kind_phys) :: gmt - real(kind_phys), dimension(1:num_chem) :: ppm2ugkg !> -- parameter to caluclate wfa&ifa (m) real(kind_phys), parameter :: mean_diameter1= 4.E-8, sigma1=1.8 @@ -142,26 +146,23 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, real(kind_phys), parameter :: density_dust= 2.6e+3, density_sulfate=1.8e+3 real(kind_phys), parameter :: density_oc = 1.4e+3, density_seasalt=2.2e+3 - real(kind_phys) :: daero_emis_wfa, daero_emis_ifa + real(kind_phys), dimension(im) :: daero_emis_wfa, daero_emis_ifa !>-- local variables real(kind_phys), dimension(im) :: wdgust, snoweq - integer :: current_month, current_hour + integer :: current_month, current_hour, hour_int real(kind_phys) :: curr_secs real(kind_phys) :: factor, factor2, factor3 - integer :: nbegin, nv, nvv - integer :: i, j, jp, k, kp, n - - type(smoke_data), pointer :: data - - data => get_thread_smoke_data() + integer :: nbegin, nv + integer :: i, j, k, kp, n errmsg = '' errflg = 0 + if (.not. rrfs_sd) return + !>-- options to turn on/off sea-salt, dust, plume-rising seas_opt = seas_opt_in dust_opt = dust_opt_in - biomass_burn_opt = biomass_burn_opt_in drydep_opt = drydep_opt_in do_plumerise = do_plumerise_in plumerisefire_frq = plumerisefire_frq_in @@ -169,46 +170,42 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, smoke_forecast = smoke_forecast_in aero_ind_fdb = aero_ind_fdb_in dbg_opt = dbg_opt_in + wetdep_ls_opt = wetdep_ls_opt_in + wetdep_ls_alpha = wetdep_ls_alpha_in + coarsepm_settling = coarsepm_settling_in - !print*,'hli ktau',ktau ! -- set domain ide=im ime=im ite=im kde=kte - h2oai = 0. - h2oaj = 0. - nu3 = 0. - ac3 = 0. - cor3 = 0. - asulf = 0. - ahno3 = 0. - anh3 = 0. - e_co = 0. - dep_vel_o3 = 0. - min_fplume2 = 0 max_fplume2 = 0 emis_seas = 0. emis_dust = 0. peak_hr = 0. flam_frac = 0. - aod3d_smoke = 0. - aod3d_dust = 0. + ext3d_smoke = 0. + ext3d_dust = 0. + daero_emis_wfa = 0. + daero_emis_ifa = 0. rcav = 0. rnav = 0. curr_secs = ktau * dt - current_month=jdate(2) - current_hour =jdate(5)+1 - gmt = real(idat(5)) + current_month=jdate(2) ! needed for the dust input data + current_hour =jdate(5)+1 ! =1 at 00Z + hour_int=ktau*dt/3600. ! hours since the simulation start + gmt = real(mod(idat(5)+hour_int,24)) julday = int(julian) - ! -- volume to mass fraction conversion table (ppm -> ug/kg) - ppm2ugkg = 1._kind_phys - ppm2ugkg(p_sulf) = 1.e+03_kind_phys * mw_so4_aer / mwdry + do nv=1,ndvel + do i=its,ite + ddvel(i,1,nv)=ddvel_inout(i,nv) + enddo + enddo ! -- compute incremental convective and large-scale rainfall do i=its,ite @@ -220,35 +217,24 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, ! plumerise frequency in minutes set up by the namelist input - call_plume = (biomass_burn_opt == BURN_OPT_ENABLE) .and. (plumerisefire_frq > 0) - if (call_plume) & - call_plume = (mod(int(curr_secs), max(1, 60*plumerisefire_frq)) == 0) & - .or. (ktau == 2) + call_fire = (do_plumerise .and. (plumerisefire_frq > 0)) + if (call_fire) call_fire = (mod(int(curr_secs), max(1, 60*plumerisefire_frq)) == 0) .or. (ktau == 2) - !scale_fire_emiss = .false. - - ! -- compute accumulated large-scale and convective rainfall since last call - if (ktau > 1) then - dtstep = call_chemistry * dt - else - dtstep = dt - end if - !>- get ready for chemistry run call rrfs_smoke_prep( & - ktau, current_month, current_hour, & + current_month, current_hour, gmt, & u10m,v10m,ustar,land,garea,rlat,rlon,tskin, & pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,exch,w, & nsoil,smc,vegtype,soiltyp,sigmaf,dswsfc,zorl, & - snow,dust12m_in,emi_in,smoke_GBBEPx, & - hf2d, pb2d, g, pi, & + snow,dust12m_in,emi_in,smoke_RRFS, & + hf2d, pb2d, g, pi, hour_int, & u10,v10,ust,tsk,xland,xlat,xlong,dxy, & rri,t_phy,u_phy,v_phy,p_phy,rho_phy,dz8w,p8w, & t8w,exch_h, & z_at_w,vvel,zmid, & ntrac,gq0, & - num_chem, num_moist, ppm2ugkg, & - ntsmoke, ntdust, & + num_chem,num_moist, & + ntsmoke, ntdust,ntcoarsepm, & moist,chem,plume_frp,ebu_in, & ebb_smoke_hr, frp_hr, frp_std_hr, emis_anoc, & smois,ivgtyp,isltyp,vegfrac,rmol,swdown,znt,hfx,pbl, & @@ -259,25 +245,32 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, ! Make this global, calculate at 1st time step only !>-- for plumerise -- -!IF (ktau==1) THEN + do j=jts,jte do i=its,ite - if (xlong(i,j)<-130.) then + peak_hr(i,j)= fire_in(i,10) + enddo + enddo + + IF (ktau==1) THEN + do j=jts,jte + do i=its,ite + if (xlong(i,j)<230.) then peak_hr(i,j)= 0.0* 3600. ! peak at 24 UTC, fires in Alaska - elseif(xlong(i,j)<-115.) then + elseif(xlong(i,j)<245.) then peak_hr(i,j)= 23.0* 3600. - elseif (xlong(i,j)<-100.) then + elseif (xlong(i,j)<260.) then peak_hr(i,j)= 22.0* 3600. ! peak at 22 UTC, fires in the western US - elseif (xlong(i,j)<-85.) then + elseif (xlong(i,j)<275.) then peak_hr(i,j)= 21.0* 3600. - elseif (xlong(i,j)<-70.) then ! peak at 20 UTC, fires in the eastern US + elseif (xlong(i,j)<290.) then ! peak at 20 UTC, fires in the eastern US peak_hr(i,j)= 20.0* 3600. else peak_hr(i,j)= 19.0* 3600. endif enddo enddo -!END IF + ENDIF IF (ktau==1) THEN ebu = 0. @@ -299,29 +292,30 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, !>- compute sea-salt - ! -- compute sea salt - if (seas_opt >= SEAS_OPT_DEFAULT) then - call gocart_seasalt_driver(ktau,dt,rri,t_phy,moist, & + ! -- compute sea salt (opt=2) + if (seas_opt == 2) then + call gocart_seasalt_driver(dt,rri,t_phy, & u_phy,v_phy,chem,rho_phy,dz8w,u10,v10,ust,p8w,tsk, & xland,xlat,xlong,dxy,g,emis_seas,pi, & - seashelp,num_emis_seas,num_moist,num_chem,seas_opt, & + seashelp,num_emis_seas,num_chem,seas_opt, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte) endif - !-- compute dust - select case (dust_opt) - case (DUST_OPT_FENGSHA) + !-- compute dust (opt=5) + if (dust_opt==DUST_OPT_FENGSHA) then ! Set at compile time in dust_data_mod: - call gocart_dust_fengsha_driver(data,dt,chem,rho_phy,smois,p8w,ssm, & + dust_alpha = dust_alpha_in + dust_gamma = dust_gamma_in + call gocart_dust_fengsha_driver(dt,chem,rho_phy,smois,p8w,ssm, & isltyp,vegfrac,snowh,xland,dxy,g,emis_dust,ust,znt, & clayf,sandf,rdrag,uthr, & - num_emis_dust,num_moist,num_chem,nsoil, & + num_emis_dust,num_chem,nsoil, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte) - end select + end if ! compute wild-fire plumes !-- to add a namelist option to turn on/off plume raising @@ -329,13 +323,12 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, !-- /scratch2/BMC/ap-fc/Ravan/rapid-refresh/WRFV3.9/smoke ! Every hour (per namelist) the ebu_driver is called to calculate ebu, but ! the plumerise is controlled by the namelist option of plumerise_flag - if (call_plume) then -! WRITE(*,*) 'plumerise is called at ktau= ',ktau + if (call_fire) then call ebu_driver ( & - data,flam_frac,ebu_in,ebu, & + flam_frac,ebu_in,ebu, & t_phy,moist(:,:,:,p_qv), & rho_phy,vvel,u_phy,v_phy,p_phy, & - z_at_w,zmid,ktau,g,con_cp,con_rd, & + z_at_w,zmid,g,con_cp,con_rd, & plume_frp, min_fplume2, max_fplume2, & ! new approach ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -345,34 +338,52 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, ! -- add biomass burning emissions at every timestep if (addsmoke_flag == 1) then - call add_emis_burn(data,dtstep,ktau,dz8w,rho_phy,rel_hum,chem, & + call add_emis_burn(dt,dz8w,rho_phy,rel_hum,chem, & julday,gmt,xlat,xlong, & ivgtyp, vegfrac, peak_hr, & ! RAR curr_secs,ebu, & - coef_bb_dc,fire_hist,aod3d_smoke,aod3d_dust, & - ! scalar(ims,kms,jms,P_QNWFA),scalar(ims,kms,jms,P_QNIFA), ! & + coef_bb_dc,fire_hist,ext3d_smoke,ext3d_dust, & rcav, rnav,swdown,smoke_forecast, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) endif -! WRITE(*,*) 'after add_emis_burn at ktau= ',ktau + !>-- compute coarsepm setting + if (coarsepm_settling == 1) then + call coarsepm_settling_driver(dt,t_phy,rel_hum, & + chem(:,:,:,p_coarse_pm), & + rho_phy,dz8w,p8w,p_phy,sedim, & + dxy,g,1, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + endif !>-- compute dry deposition if (drydep_opt == 1) then - call dry_dep_driver(data,ktau,dt,julday,current_month,t_phy,p_phy, & - moist,p8w,rmol,rri,gmt,t8w,rcav, & - chem,rho_phy,dz8w,exch_h,hfx, & - ivgtyp,tsk,swdown,vegfrac,pbl,ust,znt,zmid,z_at_w, & - xland,xlat,xlong,h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3, & - anh3,dry_fall,dep_vel_o3,g, & - e_co,kemit,snowh,numgas, & - num_chem,num_moist, & + + call dry_dep_driver(rmol,ust,ndvel,ddvel,rel_hum, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte) + + do nv=1,ndvel + do i=its,ite + ddvel_inout(i,nv)=ddvel(i,1,nv) + enddo + enddo + else + ddvel_inout(:,:)=0. + endif + +!>- large-scale wet deposition + if (wetdep_ls_opt == 1) then + call wetdep_ls(dt,chem,rnav,moist, & + rho_phy,num_chem,num_moist,dz8w,vvel, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) endif -! WRITE(*,*) 'dry depostion is done at ktau= ',ktau do k=kts,kte do i=its,ite @@ -384,95 +395,100 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, !---- diagnostic output of hourly wildfire potential (07/2021) hwp = 0. do i=its,ite - wdgust(i)=1.68*sqrt(us3d(i,1)**2+vs3d(i,1)**2) - snoweq(i)=max((25.-snow(i)*1000.)/25.,0.) - !hwp(i)=44.09*wdgust(i)**1.82*max(0.,t2m(i)-dpt2m(i))**0.61*max(0.,1.-smc(i,1))**14.0*snoweq(i)*sigmaf(i) - hwp(i)=44.09*wdgust(i)**1.82*(t2m(i)-dpt2m(i))**0.61*(1.-smc(i,1))**14.0*snoweq(i)*sigmaf(i) + wdgust(i)=max(1.68*sqrt(us3d(i,1)**2+vs3d(i,1)**2),3.) + snoweq(i)=max((25.-snow(i))/25.,0.) + hwp(i)=0.237*wdgust(i)**1.11*max(t2m(i)-dpt2m(i),15.)**0.92*((1.-wetness(i))**6.95)*snoweq(i) ! Eric 08/2022 enddo !---- diagnostic output of smoke & dust optical extinction (12/2021) do k=kts,kte do i=its,ite - smoke_ext(i,k) = aod3d_smoke(i,k,1) - dust_ext (i,k) = aod3d_dust (i,k,1) + smoke_ext(i,k) = ext3d_smoke(i,k,1) + dust_ext (i,k) = ext3d_dust (i,k,1) enddo enddo !------------------------------------- !---- put smoke stuff back into tracer array do k=kts,kte do i=its,ite - gq0(i,k,ntsmoke )=ppm2ugkg(p_smoke ) * max(epsilc,chem(i,k,1,p_smoke)) ! - gq0(i,k,ntdust )=ppm2ugkg(p_dust_1) * max(epsilc,chem(i,k,1,p_dust_1)) + gq0(i,k,ntsmoke ) = min(5000.,max(epsilc,chem(i,k,1,p_smoke ))) + gq0(i,k,ntdust ) = min(100.,max(epsilc,chem(i,k,1,p_dust_1))) + gq0(i,k,ntcoarsepm)= min(1000.,max(epsilc,chem(i,k,1,p_coarse_pm))) enddo enddo do k=kts,kte do i=its,ite - qgrs(i,k,ntsmoke )= gq0(i,k,ntsmoke ) - qgrs(i,k,ntdust )= gq0(i,k,ntdust ) - chem3d(i,k,1 )= gq0(i,k,ntsmoke ) - chem3d(i,k,2 )= gq0(i,k,ntdust ) + qgrs(i,k,ntsmoke )= gq0(i,k,ntsmoke ) + qgrs(i,k,ntdust )= gq0(i,k,ntdust ) + qgrs(i,k,ntcoarsepm)= gq0(i,k,ntcoarsepm) + chem3d(i,k,1 )= gq0(i,k,ntsmoke ) + chem3d(i,k,2 )= gq0(i,k,ntdust ) + chem3d(i,k,3 )= gq0(i,k,ntcoarsepm) enddo enddo !------------------------------------- !-- to output for diagnostics -! WRITE(*,*) 'rrfs nwfa/nifa 1 at ktau= ',ktau do i = 1, im - emseas (i) = emis_seas (i,1,1,1)*1.e+9 ! size bin 1 sea salt emission: ug/m2/s - emdust (i) = emis_dust (i,1,1,1) ! size bin 1 dust emission : ug/m2/s - emanoc (i) = emis_anoc (i) ! anthropogenic organic carbon: ug/m2/s - coef_bb (i) = coef_bb_dc (i,1) - fhist (i) = fire_hist (i,1) + emseas (i) = emis_seas(i,1,1,1)*1.e+9 ! size bin 1 sea salt emission: ug/m2/s + emdust (i) = emis_dust(i,1,1,1) + emis_dust(i,1,1,2) + & + emis_dust(i,1,1,3) + emis_dust(i,1,1,4) ! dust emission: ug/m2/s + emanoc (i) = emis_anoc (i) ! anthropogenic organic carbon: ug/m2/s + coef_bb (i) = coef_bb_dc(i,1) + fhist (i) = fire_hist (i,1) min_fplume (i) = real(min_fplume2(i,1)) max_fplume (i) = real(max_fplume2(i,1)) + emseas (i) = sandf(i,1) ! sand for dust + emanoc (i) = uthr (i,1) ! u threshold for dust + enddo + + do i = 1, im + fire_in(i,10) = peak_hr(i,1) enddo -! WRITE(*,*) 'rrfs nwfa/nifa 2 at ktau= ',ktau !-- to provide real aerosol emission for Thompson MP if (imp_physics == imp_physics_thompson .and. aero_ind_fdb) then fact_wfa = 1.e-9*6.0/pi*exp(4.5*log(sigma1)**2)/mean_diameter1**3 fact_ifa = 1.e-9*6.0/pi*exp(4.5*log(sigma2)**2)/mean_diameter2**3 - do i = its, ite - do k = kts, kte - if (k==1)then - daero_emis_wfa =(emanoc(i)+ebu_smoke(i,k))/density_oc + emseas(i)/density_seasalt - else - daero_emis_wfa = ebu_smoke(i,k)/density_oc - endif - daero_emis_wfa = kappa_oc* daero_emis_wfa*fact_wfa*rri(i,k,1)/dz8w(i,k,1) ! consider using dust tracer + do i = 1, im + daero_emis_wfa(i) =(emanoc(i)+ebu_smoke(i,kemit))/density_oc + emseas(i)/density_seasalt + daero_emis_ifa(i) = emdust(i)/density_dust + + daero_emis_wfa(i) = daero_emis_wfa(i)*fact_wfa*rri(i,kemit,1)/dz8w(i,kemit,1) + daero_emis_ifa(i) = daero_emis_ifa(i)*fact_ifa*rri(i,kemit,1)/dz8w(i,kemit,1) - nwfa(i,k) = nwfa(i,k) + daero_emis_wfa*dt - nifa(i,k) = gq0(i,k,ntdust)/density_dust*fact_ifa*kappa_dust ! Check the formula + nwfa(i,kemit) = nwfa(i,kemit) + daero_emis_wfa(i)*dt + nifa(i,kemit) = nifa(i,kemit) + daero_emis_ifa(i)*dt if(land(i).eq.1)then - nwfa(i,k) = nwfa(i,k)*(1 - 0.10*dt/86400.) !-- mimicking dry deposition + nwfa(i,kemit) = nwfa(i,kemit)*(1. - 0.10*dt/86400.) !-- mimicking dry deposition + nifa(i,kemit) = nifa(i,kemit)*(1. - 0.10*dt/86400.) !-- mimicking dry deposition else - nwfa(i,k) = nwfa(i,k)*(1 - 0.05*dt/86400.) !-- mimicking dry deposition + nwfa(i,kemit) = nwfa(i,kemit)*(1. - 0.05*dt/86400.) !-- mimicking dry deposition + nifa(i,kemit) = nifa(i,kemit)*(1. - 0.05*dt/86400.) !-- mimicking dry deposition endif - enddo + nwfa(i,kemit) = MIN(2.E10,nwfa(i,kemit)) + nifa(i,kemit) = MIN(9999.E6,nifa(i,kemit)) enddo endif -! WRITE(*,*) 'rrfs smoke wrapper is done at ktau= ',ktau end subroutine rrfs_smoke_wrapper_run subroutine rrfs_smoke_prep( & - ktau,current_month,current_hour, & + current_month,current_hour,gmt, & u10m,v10m,ustar,land,garea,rlat,rlon,ts2d, & pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,exch,w, & nsoil,smc,vegtype,soiltyp,sigmaf,dswsfc,zorl, & - snow_cpl,dust12m_in,emi_in,smoke_GBBEPx, & - hf2d, pb2d, g, pi, & + snow_cpl,dust12m_in,emi_in,smoke_RRFS, & + hf2d, pb2d, g, pi, hour_int, & u10,v10,ust,tsk,xland,xlat,xlong,dxy, & rri,t_phy,u_phy,v_phy,p_phy,rho_phy,dz8w,p8w, & t8w,exch_h, & z_at_w,vvel,zmid, & ntrac,gq0, & - num_chem, num_moist, ppm2ugkg, & - ntsmoke, ntdust, & - !num_emis_ant, & - !emis_ant, & + num_chem, num_moist, & + ntsmoke, ntdust, ntcoarsepm, & moist,chem,plume_frp,ebu_in, & ebb_smoke_hr, frp_hr, frp_std_hr, emis_anoc, & smois,ivgtyp,isltyp,vegfrac,rmol,swdown,znt,hfx,pbl, & @@ -482,19 +498,19 @@ subroutine rrfs_smoke_prep( & its,ite, jts,jte, kts,kte) !Chem input configuration - integer, intent(in) :: ktau, current_month, current_hour + integer, intent(in) :: current_month, current_hour, hour_int !FV3 input variables integer, intent(in) :: nsoil integer, dimension(ims:ime), intent(in) :: land, vegtype, soiltyp integer, intent(in) :: ntrac - real(kind=kind_phys), intent(in) :: g, pi + real(kind=kind_phys), intent(in) :: g, pi, gmt real(kind=kind_phys), dimension(ims:ime), intent(in) :: & u10m, v10m, ustar, garea, rlat, rlon, ts2d, sigmaf, dswsfc, & zorl, snow_cpl, pb2d, hf2d real(kind=kind_phys), dimension(ims:ime, nsoil), intent(in) :: smc real(kind=kind_phys), dimension(ims:ime, 12, 5), intent(in) :: dust12m_in - real(kind=kind_phys), dimension(ims:ime, 24, 3), intent(in) :: smoke_GBBEPx + real(kind=kind_phys), dimension(ims:ime, 24, 3), intent(in) :: smoke_RRFS real(kind=kind_phys), dimension(ims:ime, 1), intent(in) :: emi_in real(kind=kind_phys), dimension(ims:ime, kms:kme), intent(in) :: pr3d,ph3d real(kind=kind_phys), dimension(ims:ime, kts:kte), intent(in) :: & @@ -502,16 +518,13 @@ subroutine rrfs_smoke_prep( & real(kind=kind_phys), dimension(ims:ime, kts:kte,ntrac), intent(in) :: gq0 - !GSD Chem variables - !integer,intent(in) :: num_emis_ant - integer,intent(in) :: num_chem, num_moist, ntsmoke, ntdust + !rrfs-sd variables + integer,intent(in) :: num_chem, num_moist, ntsmoke, ntdust, ntcoarsepm integer,intent(in) :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte - !real(kind_phys), dimension(ims:ime, kms:kemit, jms:jme, num_emis_ant), intent(inout) :: emis_ant - real(kind_phys), dimension(num_chem), intent(in) :: ppm2ugkg real(kind_phys), dimension(ims:ime, jms:jme),intent(out) :: ebu_in real(kind_phys), dimension(ims:ime, jms:jme, num_frp_plume), intent(out) :: plume_frp @@ -534,7 +547,7 @@ subroutine rrfs_smoke_prep( & real(kind_phys), parameter :: frpc = 1._kind_phys ! FRP conversion factor (Regional) ! -- local variables - integer i,ip,j,jp,k,kp,kk,kkp,nv,l,ll,n + integer i,ip,j,k,kp,kk,kkp,nv,l,ll,n ! -- initialize fire emissions !plume = 0._kind_phys @@ -542,6 +555,8 @@ subroutine rrfs_smoke_prep( & ebu_in = 0._kind_phys ebb_smoke_hr = 0._kind_phys emis_anoc = 0._kind_phys + frp_hr = 0._kind_phys + frp_std_hr = 0._kind_phys ! -- initialize output arrays isltyp = 0._kind_phys @@ -617,75 +632,60 @@ subroutine rrfs_smoke_prep( & enddo enddo - !if (ktau <= 1) then - ! emis_ant = 0. - ! !emis_vol = 0. - !end if - do j=jts,jte - jp = j - jts + 1 - do i=its,ite - ip = i - its + 1 - z_at_w(i,kts,j)=max(0.,ph3d(ip,1)/g) - enddo + do i=its,ite + z_at_w(i,kts,j)=max(0.,ph3d(i,1)/g) + enddo enddo do j=jts,jte - jp = j - jts + 1 - do k=kts,kte - kp = k - kts + 1 - do i=its,ite - ip = i - its + 1 - dz8w(i,k,j)=abs(ph3d(ip,kp+1)-ph3d(ip,kp))/g - z_at_w(i,k+1,j)=z_at_w(i,k,j)+dz8w(i,k,j) - enddo + do k=kts,kte + do i=its,ite + dz8w(i,k,j)=abs(ph3d(i,k+1)-ph3d(i,k))/g + z_at_w(i,k+1,j)=z_at_w(i,k,j)+dz8w(i,k,j) enddo + enddo enddo do j=jts,jte - jp = j - jts + 1 - do k=kts,kte+1 - kp = k - kts + 1 - do i=its,ite - ip = i - its + 1 - p8w(i,k,j)=pr3d(ip,kp) - enddo + do k=kts,kte+1 + do i=its,ite + p8w(i,k,j)=pr3d(i,k) enddo + enddo enddo do j=jts,jte - jp = j - jts + 1 do k=kts,kte+1 kk=min(k,kte) kkp = kk - kts + 1 do i=its,ite - ip = i - its + 1 dz8w(i,k,j)=z_at_w(i,kk+1,j)-z_at_w(i,kk,j) - t_phy(i,k,j)=tk3d(ip,kkp) - p_phy(i,k,j)=prl3d(ip,kkp) - u_phy(i,k,j)=us3d(ip,kkp) - v_phy(i,k,j)=vs3d(ip,kkp) - rho_phy(i,k,j)=p_phy(i,k,j)/(287.04*t_phy(i,k,j)*(1.+.608*spechum(ip,kkp))) + t_phy(i,k,j)=tk3d(i,kkp) + p_phy(i,k,j)=prl3d(i,kkp) + u_phy(i,k,j)=us3d(i,kkp) + v_phy(i,k,j)=vs3d(i,kkp) + rho_phy(i,k,j)=p_phy(i,k,j)/(287.04*t_phy(i,k,j)*(1.+.608*spechum(i,kkp))) rri(i,k,j)=1./rho_phy(i,k,j) - vvel(i,k,j)=-w(ip,kkp)*rri(i,k,j)/g + vvel(i,k,j)=-w(i,kkp)*rri(i,k,j)/g moist(i,k,j,:)=0. - moist(i,k,j,1)=gq0(ip,kkp,p_atm_shum) + moist(i,k,j,1)=gq0(i,kkp,p_atm_shum) if (t_phy(i,k,j) > 265.) then - moist(i,k,j,2)=gq0(ip,kkp,p_atm_cldq) + moist(i,k,j,2)=gq0(i,kkp,p_atm_cldq) moist(i,k,j,3)=0. if (moist(i,k,j,2) < 1.e-8) moist(i,k,j,2)=0. else moist(i,k,j,2)=0. - moist(i,k,j,3)=gq0(ip,kkp,p_atm_cldq) + moist(i,k,j,3)=gq0(i,kkp,p_atm_cldq) if(moist(i,k,j,3) < 1.e-8)moist(i,k,j,3)=0. endif - rel_hum(i,k,j) = .95 - rel_hum(i,k,j) = MIN( .95, moist(i,k,j,1) / & + !rel_hum(i,k,j) = min(0.95,spechum(i,kkp)) + rel_hum(i,k,j) = min(0.95, moist(i,k,j,1) / & (3.80*exp(17.27*(t_phy(i,k,j)-273.)/ & (t_phy(i,k,j)-36.))/(.01*p_phy(i,k,j)))) - rel_hum(i,k,j)=max(0.1,rel_hum(i,k,j)) + rel_hum(i,k,j) = max(0.1,rel_hum(i,k,j)) !-- - zmid(i,k,j)=phl3d(ip,kkp)/g + zmid(i,k,j)=phl3d(i,kkp)/g enddo enddo enddo @@ -705,7 +705,6 @@ subroutine rrfs_smoke_prep( & enddo enddo - ! -- only used in phtolysis.... do j=jts,jte do i=its,ite t8w(i,1,j)=t_phy(i,1,j) @@ -718,27 +717,26 @@ subroutine rrfs_smoke_prep( & emis_anoc(i) = emi_in(i,1) enddo - ! select case (plumerise_flag) - ! case (FIRE_OPT_GBBEPx) + if (hour_int<24) then do j=jts,jte do i=its,ite - ebb_smoke_hr(i) = smoke_GBBEPx(i,current_hour,1) ! smoke - frp_hr (i) = smoke_GBBEPx(i,current_hour,2) ! frp - frp_std_hr (i) = smoke_GBBEPx(i,current_hour,3) ! std frp + ebb_smoke_hr(i) = smoke_RRFS(i,hour_int+1,1) ! smoke + frp_hr (i) = smoke_RRFS(i,hour_int+1,2) ! frp + frp_std_hr (i) = smoke_RRFS(i,hour_int+1,3) ! std frp ebu_in (i,j) = ebb_smoke_hr(i) - plume_frp(i,j,p_frp_hr ) = conv_frp* frp_hr (i) - plume_frp(i,j,p_frp_std ) = conv_frp* frp_std_hr (i) + plume_frp(i,j,p_frp_hr ) = conv_frp* frp_hr (i) + plume_frp(i,j,p_frp_std) = conv_frp* frp_std_hr (i) enddo enddo - ! case default - ! end select + endif ! We will add a namelist variable, real :: flam_frac_global do k=kms,kte do i=ims,ime - chem(i,k,jts,p_smoke )=max(epsilc,gq0(i,k,ntsmoke )/ppm2ugkg(p_smoke)) - chem(i,k,jts,p_dust_1)=max(epsilc,gq0(i,k,ntdust )/ppm2ugkg(p_dust_1)) + chem(i,k,jts,p_smoke )=max(epsilc,gq0(i,k,ntsmoke )) + chem(i,k,jts,p_dust_1 )=max(epsilc,gq0(i,k,ntdust )) + chem(i,k,jts,p_coarse_pm)=max(epsilc,gq0(i,k,ntcoarsepm)) enddo enddo diff --git a/smoke/rrfs_smoke_wrapper.meta b/physics/smoke_dust/rrfs_smoke_wrapper.meta similarity index 85% rename from smoke/rrfs_smoke_wrapper.meta rename to physics/smoke_dust/rrfs_smoke_wrapper.meta index ef46b04ea..2b2be03b6 100755 --- a/smoke/rrfs_smoke_wrapper.meta +++ b/physics/smoke_dust/rrfs_smoke_wrapper.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = rrfs_smoke_wrapper type = scheme - dependencies = dep_dry_gocart_mod.F90,dep_dry_mod.F90,dep_simple_mod.F90,dep_vertmx_mod.F90,dep_wet_ls_mod.F90,dust_data_mod.F90,dust_fengsha_mod.F90,module_add_emiss_burn.F90,module_plumerise1.F90,module_smoke_plumerise.F90,module_zero_plumegen_coms.F90,plume_data_mod.F90,rrfs_smoke_config.F90,rrfs_smoke_data.F90,seas_data_mod.F90,seas_mod.F90,seas_ngac_mod.F90 + dependencies = dep_dry_mod.F90,module_wetdep_ls.F90,dust_data_mod.F90,dust_fengsha_mod.F90,module_add_emiss_burn.F90,module_plumerise1.F90,module_smoke_plumerise.F90,module_zero_plumegen_coms.F90,plume_data_mod.F90,rrfs_smoke_config.F90,seas_data_mod.F90,seas_mod.F90,seas_ngac_mod.F90,coarsepm_settling_mod.F90 ######################################################################## [ccpp-arg-table] @@ -263,9 +263,9 @@ kind = kind_phys intent = in [snow] - standard_name = lwe_thickness_of_snow_amount - long_name = snow fall on physics timestep - units = m + standard_name = lwe_surface_snow + long_name = water equivalent snow depth + units = mm dimensions = (horizontal_loop_extent) type = real kind = kind_phys @@ -365,9 +365,9 @@ type = real kind = kind_phys intent = in -[smoke_GBBEPx] - standard_name = emission_smoke_GBBEPx - long_name = emission fire GBBEPx +[smoke_RRFS] + standard_name = emission_smoke_RRFS + long_name = emission fire RRFS units = various dimensions = (horizontal_loop_extent,24,3) type = real @@ -400,7 +400,7 @@ standard_name = chem3d_mynn_pbl_transport long_name = mynn pbl transport of smoke and dust units = various - dimensions = (horizontal_loop_extent,vertical_layer_dimension,2) + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_chemical_species_vertically_mixed) type = real kind = kind_phys intent = inout @@ -425,6 +425,13 @@ dimensions = () type = integer intent = in +[ntcoarsepm] + standard_name = index_for_coarse_pm_in_tracer_concentration_array + long_name = tracer index for coarse pm + units = index + dimensions = () + type = integer + intent = in [imp_physics] standard_name = control_for_microphysics_scheme long_name = choice of microphysics scheme @@ -551,6 +558,14 @@ type = real kind = kind_phys intent = out +[wetness] + standard_name = normalized_soil_wetness_for_land_surface_model + long_name = normalized soil wetness + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [smoke_ext] standard_name = extinction_coefficient_in_air_due_to_smoke long_name = extinction coefficient in air due to smoke @@ -567,6 +582,52 @@ type = real kind = kind_phys intent = out +[ndvel] + standard_name = number_of_chemical_species_deposited + long_name = number of chemical pbl deposited + units = count + dimensions = () + type = integer + intent = in +[ddvel_inout] + standard_name = dry_deposition_velocity_mynn_pbl_transport + long_name = dry deposition velocity by mynn pbl transport + units = m s-1 + dimensions = (horizontal_loop_extent,number_of_chemical_species_deposited) + type = real + kind = kind_phys + intent = inout +[rrfs_sd] + standard_name = do_smoke_coupling + long_name = flag controlling rrfs_sd collection (default off) + units = flag + dimensions = () + type = logical + intent = in +[dust_alpha_in] + standard_name = alpha_fengsha_dust_scheme + long_name = alpha paramter for fengsha dust scheme + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[dust_gamma_in] + standard_name = gamma_fengsha_dust_scheme + long_name = gamma paramter for fengsha dust scheme + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[fire_in] + standard_name = smoke_fire_auxiliary_input + long_name = smoke fire auxiliary input variables + units = various + dimensions = (horizontal_loop_extent,fire_auxiliary_data_extent) + type = real + kind = kind_phys + intent = inout [seas_opt_in] standard_name = control_for_smoke_sea_salt long_name = rrfs smoke sea salt emission option @@ -581,20 +642,35 @@ dimensions = () type = integer intent = in -[biomass_burn_opt_in] - standard_name = control_for_smoke_biomass_burn - long_name = rrfs smoke biomass burning option +[drydep_opt_in] + standard_name = control_for_smoke_dry_deposition + long_name = rrfs smoke dry deposition option units = index dimensions = () type = integer intent = in -[drydep_opt_in] - standard_name = control_for_smoke_dry_deposition - long_name = rrfs smoke dry deposition option +[coarsepm_settling_in] + standard_name = control_for_smoke_coarsepm_settling + long_name = rrfs smoke coarsepm settling option units = index dimensions = () type = integer intent = in +[wetdep_ls_opt_in] + standard_name = control_for_smoke_wet_deposition + long_name = rrfs smoke large scale wet deposition option + units = index + dimensions = () + type = integer + intent = in +[wetdep_ls_alpha_in] + standard_name = alpha_for_ls_wet_depoistion + long_name = alpha paramter for ls wet deposition + units = none + dimensions = () + type = real + kind = kind_phys + intent = in [do_plumerise_in] standard_name = do_smoke_plumerise long_name = rrfs smoke plumerise option @@ -618,10 +694,10 @@ intent = in [smoke_forecast_in] standard_name = do_smoke_forecast - long_name = flag for rrfs smoke forecast - units = flag + long_name = index for rrfs smoke forecast + units = index dimensions = () - type = logical + type = integer intent = in [aero_ind_fdb_in] standard_name = do_smoke_aerosol_indirect_feedback diff --git a/smoke/seas_data_mod.F90 b/physics/smoke_dust/seas_data_mod.F90 similarity index 100% rename from smoke/seas_data_mod.F90 rename to physics/smoke_dust/seas_data_mod.F90 diff --git a/smoke/seas_mod.F90 b/physics/smoke_dust/seas_mod.F90 similarity index 96% rename from smoke/seas_mod.F90 rename to physics/smoke_dust/seas_mod.F90 index 85c861156..1d18046ad 100755 --- a/smoke/seas_mod.F90 +++ b/physics/smoke_dust/seas_mod.F90 @@ -13,7 +13,6 @@ module seas_mod implicit none - integer, parameter :: SEAS_OPT_DEFAULT = 1 integer, parameter :: CHEM_OPT_GOCART = 300 integer, parameter :: chem_opt = 300 @@ -22,26 +21,24 @@ module seas_mod private - public :: SEAS_OPT_DEFAULT - public :: gocart_seasalt_driver CONTAINS - subroutine gocart_seasalt_driver(ktau,dt,alt,t_phy,moist,u_phy, & + subroutine gocart_seasalt_driver(dt,alt,t_phy,u_phy, & v_phy,chem,rho_phy,dz8w,u10,v10,ustar,p8w,tsk, & - xland,xlat,xlong,area,g,emis_seas,pi, & - seashelp,num_emis_seas,num_moist,num_chem,seas_opt, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) + xland,xlat,xlong,area,g,emis_seas,pi, & + seashelp,num_emis_seas,num_chem,seas_opt, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) - INTEGER, INTENT(IN ) :: ktau,num_emis_seas,num_moist,num_chem, & + INTEGER, INTENT(IN ) :: num_emis_seas,num_chem, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte,seas_opt - REAL(kind=kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & - INTENT(IN ) :: moist +! REAL(kind=kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & +! INTENT(IN ) :: moist REAL(kind=kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & INTENT(INOUT ) :: chem REAL(kind=kind_phys), DIMENSION( ims:ime, 1, jms:jme,num_emis_seas), & diff --git a/smoke/seas_ngac_mod.F90 b/physics/smoke_dust/seas_ngac_mod.F90 similarity index 100% rename from smoke/seas_ngac_mod.F90 rename to physics/smoke_dust/seas_ngac_mod.F90 diff --git a/smoke/dep_dry_gocart_mod.F90 b/smoke/dep_dry_gocart_mod.F90 deleted file mode 100755 index 9fb5edfd1..000000000 --- a/smoke/dep_dry_gocart_mod.F90 +++ /dev/null @@ -1,302 +0,0 @@ -!>\file dep_dry_gocart_mod.F90 -!! This file is GOCART dry deposition module to calculate the dry deposition -!! velocities of smoke and dust. - -module dep_dry_gocart_mod - - use machine , only : kind_phys - use rrfs_smoke_data - - implicit none - - private - - public :: gocart_drydep_driver - -CONTAINS - -subroutine gocart_drydep_driver(numgas, & - moist,p8w,chem,rho_phy,dz8w,ddvel,xland,hfx, & - ivgtyp,tsk,pbl,ust,znt,g, & - num_moist,num_chem, & - 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, & - num_moist,num_chem, & - its,ite, jts,jte, kts,kte,numgas - REAL(kind_phys), INTENT(IN ) :: g - REAL(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ),& - INTENT(IN ) :: moist - REAL(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ) ,& - INTENT(INOUT) :: chem - REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ) ,& - INTENT(IN ) :: dz8w, p8w,rho_phy - INTEGER, DIMENSION( ims:ime , jms:jme ) ,& - INTENT(IN ) :: ivgtyp - REAL(kind_phys), DIMENSION( ims:ime , jms:jme ) ,& - INTENT(INOUT) :: tsk, & - pbl, & - ust, & - xland,znt,hfx - -!! .. Local Scalars .. - - INTEGER :: iland, iprt, iseason, jce, jcs, & - n, nr, ipr, jpr, nvr, & - idrydep_onoff,imx,jmx,lmx - integer :: ii,jj,kk,i,j,k,nv - integer, dimension (1,1) :: ilwi - real(kind_phys), DIMENSION (5) :: tc,bems - real(kind_phys), dimension (1,1) :: z0,w10m,gwet,airden,airmas,& - delz_sfc,hflux,ts,pblz,ustar,& - ps,dvel,drydf - REAL(kind_phys), DIMENSION( its:ite, jts:jte, num_chem ) :: ddvel - - do nv=1,num_chem - do j=jts,jte - do i=its,ite - ddvel(i,j,nv)=0. - enddo - enddo - enddo - imx=1 - jmx=1 - lmx=1 - do j=jts,jte - do i=its,ite - dvel(1,1)=0. - ilwi(1,1)=0 - if(xland(i,j).gt.1.5)ilwi=1 -! for aerosols, ii=1 or ii=2 - ii=1 - if(ivgtyp(i,j).eq.19.or.ivgtyp(i,j).eq.23)ii=1 - airden(1,1)=rho_phy(i,kts,j) - delz_sfc(1,1)=dz8w(i,kts,j) - ustar(1,1)=ust(i,j) - hflux(1,1)=hfx(i,j) - pblz(1,1)=pbl(i,j) - ps(1,1)=p8w(i,kts,j)*.01 - z0(1,1)=znt(i,j) - ts(1,1)=tsk(i,j) - - call depvel_gocart(ii,imx,jmx,lmx,& - airden, delz_sfc, pblz, ts, ustar, hflux, ilwi, & - ps, z0, dvel, drydf,g) - do nv=1,num_chem - ddvel(i,j,nv)=dvel(1,1) - enddo - enddo - enddo -end subroutine gocart_drydep_driver - - - -SUBROUTINE depvel_gocart( & - ii,imx,jmx,lmx,& - airden, delz_sfc, pblz, ts, ustar, hflux, ilwi, & - ps, z0, dvel, drydf,g0) - -! **************************************************************************** -! * * -! * Calculate dry deposition velocity. * -! * * -! * Input variables: * -! * AEROSOL(k) - Logical, T = aerosol species, F = gas species * -! * IREG(i,j) - # of landtypes in grid square * -! * ILAND(i,j,ldt) - Land type ID for element ldt =1,IREG(i,j) * -! * IUSE(i,j,ldt) - Fraction of gridbox area occupied by land type * -! * element ldt * -! * USTAR(i,j) - Friction velocity (m s-1) * -! * DELZ_SFC(i,j) - Thickness of layer above surface * -! * PBLZ(i,j) - Mixing depth (m) * -! * Z0(i,j) - Roughness height (m) * -! * * -! * Determined in this subroutine (local): * -! * OBK - Monin-Obukhov length (m): set to 1.E5 m under * -! * neutral conditions * -! * Rs(ldt) - Bulk surface resistance(s m-1) for species k to * -! * surface ldt * -! * Ra - Aerodynamic resistance. * -! * Rb - Sublayer resistance. * -! * Rs - Surface resistance. * -! * Rttl - Total deposition resistance (s m-1) for species k * -! * Rttl(k) = Ra + Rb + Rs. * -! * * -! * Returned: * -! * DVEL(i,j,k) - Deposition velocity (m s-1) of species k * -! * DRYDf(i,j,k) - Deposition frequency (s-1) of species k, * -! * = DVEL / DELZ_SFC * -! * * -! **************************************************************************** - - - IMPLICIT NONE - INTEGER, INTENT(IN) :: imx,jmx,lmx - REAL(kind_phys), INTENT(IN) :: airden(imx,jmx), delz_sfc(imx,jmx) - REAL(kind_phys), INTENT(IN) :: hflux(imx,jmx), ts(imx,jmx) - REAL(kind_phys), INTENT(IN) :: ustar(imx,jmx), pblz(imx,jmx) - REAL(kind_phys), INTENT(IN) :: ps(imx,jmx) - INTEGER, INTENT(IN) :: ilwi(imx,jmx) - REAL(kind_phys), INTENT(IN) :: z0(imx,jmx) - REAL(kind=kind_phys), INTENT(IN) :: g0 - REAL(kind_phys), INTENT(OUT) :: dvel(imx,jmx), drydf(imx,jmx) - - REAL(kind_phys) :: obk, vds, czh, rttl, frac, logmfrac, psi_h, cz, eps - REAL(kind_phys) :: vd, ra, rb, rs - INTEGER :: i, j, k, ldt, iolson, ii - CHARACTER(LEN=50) :: msg - REAL(kind_phys) :: prss, tempk, tempc, xnu, ckustr, reyno, aird, diam, xm, z - REAL(kind_phys) :: frpath, speed, dg, dw, rt - REAL(kind_phys) :: rad0, rix, gfact, gfaci, rdc, rixx, rluxx, rgsx, rclx - REAL(kind_phys) :: dtmp1, dtmp2, dtmp3, dtmp4 - REAL(kind_phys) :: biofit,vk - - psi_h=0.0 - ! executable statements - j_loop: DO j = 1,jmx - i_loop: DO i = 1,imx - vk=.4 - vd = 0.0 - ra = 0.0 - rb = 0.0 ! only required for gases (SO2) - rs = 0.0 - -! **************************************************************************** -! * Compute the the Monin-Obhukov length. * -! * The direct computation of the Monin-Obhukov length is: * -! * * -! * - Air density * Cp * T(surface air) * Ustar^3 * -! * OBK = ---------------------------------------------- * -! * vK * g * Sensible Heat flux * -! * * -! * Cp = 1000 J/kg/K = specific heat at constant pressure * -! * vK = 0.4 = von Karman's constant * -! **************************************************************************** - - IF (hflux(i,j) == 0.0) THEN - obk = 1.0E5 - ELSE - ! MINVAL(hflux), MINVAL(airden), MINVAL(ustar) =?? - obk = -airden(i,j) * 1000.0 * ts(i,j) * (ustar(i,j))**3 & - / (vk * g0 * hflux(i,j)) -! -- debug: - IF ( obk == 0.0 ) WRITE(*,211) obk, i, j -211 FORMAT(1X,'OBK=', E11.2, 1X,' i,j = ', 2I4) - - END IF - - cz = delz_sfc(i,j) / 2.0 ! center of the grid box above surface - -! **************************************************************************** -! * (1) Aerosodynamic resistance Ra and sublayer resistance Rb. * -! * * -! * The Reynolds number REYNO diagnoses whether a surface is * -! * aerodynamically rough (REYNO > 10) or smooth. Surface is * -! * rough in all cases except over water with low wind speeds. * -! * * -! * For gas species over land and ice (REYNO >= 10) and for aerosol * -! * species for all surfaces: * -! * * -! * Ra = 1./VT (VT from GEOS Kzz at L=1, m/s). * -! * * -! * The following equations are from Walcek et al, 1986: * -! * * -! * For gas species when REYNO < 10 (smooth), Ra and Rb are combined * -! * as Ra: * -! * * -! * Ra = { ln(ku* z1/Dg) - Sh } / ku* eq.(13) * -! * * -! * where z1 is the altitude at the center of the lowest model layer * -! * (CZ); * -! * Sh is a stability correction function; * -! * k is the von Karman constant (0.4, vK); * -! * u* is the friction velocity (USTAR). * -! * * -! * Sh is computed as a function of z1 and L eq ( 4) and (5)): * -! * * -! * 0 < z1/L <= 1: Sh = -5 * z1/L * -! * z1/L < 0: Sh = exp{ 0.598 + 0.39*ln(E) - 0.09(ln(E))^2 } * -! * where E = min(1,-z1/L) (Balkanski, thesis). * -! * * -! * For gas species when REYNO >= 10, * -! * * -! * Rb = 2/ku* (Dair/Dg)**(2/3) eq.(12) * -! * where Dg is the gas diffusivity, and * -! * Dair is the air diffusivity. * -! * * -! * For aerosol species, Rb is combined with surface resistance as Rs. * -! * * -! **************************************************************************** - - frac = cz / obk - IF (frac > 1.0) frac = 1.0 - IF (frac > 0.0 .AND. frac <= 1.0) THEN - psi_h = -5.0*frac - ELSE IF (frac < 0.0) THEN - eps = MIN(1.0D0, -frac) - logmfrac = LOG(eps) - psi_h = EXP( 0.598 + 0.39 * logmfrac - 0.09 * (logmfrac)**2 ) - END IF - !-------------------------------------------------------------- - ! Aerosol species, Rs here is the combination of Rb and Rs. - - ra = (LOG(cz/z0(i,j)) - psi_h) / (vk*ustar(i,j)) - - vds = 0.002*ustar(i,j) - IF (obk < 0.0) & - vds = vds * (1.0+(-300.0/obk)**0.6667) - - czh = pblz(i,j)/obk - IF (czh < -30.0) vds = 0.0009*ustar(i,j)*(-czh)**0.6667 - - ! --Set Vds to be less than VDSMAX (entry in input file divided -- - ! by 1.E4). VDSMAX is taken from Table 2 of Walcek et al. [1986]. - ! Invert to get corresponding R - if(ii.eq.1)then - rs=1.0/MIN(vds,2.0D-2) - else - rs=1.0/MIN(vds,2.0D-3) - endif - - - ! ------ Set max and min values for bulk surface resistances ------ - - rs= MAX(1.0D0, MIN(rs, 9.9990D+3)) - -! **************************************************************************** -! * * -! * Compute dry deposition velocity. * -! * * -! * IUSE is the fraction of the grid square occupied by surface ldt in * -! * units of per mil (IUSE=500 -> 50% of the grid square). Add the * -! * contribution of surface type ldt to the deposition velocity; this is * -! * a loop over all surface types in the gridbox. * -! * * -! * Total resistance = Ra + Rb + Rs. -! * * -! **************************************************************************** - - rttl = ra + rb + rs - vd = vd + 1./rttl - - ! ------ Load array DVEL ------ - dvel(i,j) = vd * 1.2 - - ! -- Set a minimum value for DVEL - ! MIN(VdSO2) = 2.0e-3 m/s over ice - ! = 3.0e-3 m/s over land - ! MIN(vd_aerosol) = 1.0e-4 m/s - - IF (dvel(i,j) < 1.0E-4) dvel(i,j) = 1.0E-4 - drydf(i,j) = dvel(i,j) / delz_sfc(i,j) - - END DO i_loop - END DO j_loop - -END SUBROUTINE depvel_gocart - -end module dep_dry_gocart_mod diff --git a/smoke/dep_dry_mod.F90 b/smoke/dep_dry_mod.F90 deleted file mode 100755 index 9520d2897..000000000 --- a/smoke/dep_dry_mod.F90 +++ /dev/null @@ -1,303 +0,0 @@ -!>\file dep_dry_mod.F90 -!! This file is for the dry depostion driver. - -module dep_dry_mod - - use machine , only : kind_phys - use rrfs_smoke_config, only : epsilc, GOCART_SIMPLE => CHEM_OPT_GOCART, CTRA_OPT_NONE -! use chem_tracers_mod, only : p_o3,p_dust_1,p_vash_1,p_vash_4,p_vash_10,p_dms, -! & -! config_flags => chem_config - use dep_dry_gocart_mod - use dep_simple_mod - use dep_vertmx_mod -! use aero_soa_vbs_mod, only : soa_vbs_depdriver - - implicit none - - - private - - public :: dry_dep_driver - -contains - - subroutine dry_dep_driver(data,ktau,dtstep,julday,current_month,t_phy,p_phy, & - moist,p8w,rmol,alt,gmt,t8w,raincv, & - chem,rho_phy,dz8w,exch_h,hfx, & - ivgtyp,tsk,gsw,vegfra,pbl,ust,znt,z,z_at_w, & - xland,xlat,xlong,h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3, & - anh3,ddep,dep_vel_o3,g, & - e_co,kemit,snowh,numgas, & - num_chem,num_moist, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) -!---------------------------------------------------------------------- -! USE module_model_constants -! USE module_configure -! USE module_state_description -! USE module_dep_simple -! USE module_initial_chem_namelists,only:p_o3,p_dust_1,p_vash_1,p_vash_4,p_vash_10,p_dms -! USE module_vertmx_wrf -! USE module_chemvars,only:epsilc -! USE module_data_sorgam -! USE module_aerosols_sorgam -! USE module_gocart_settling -! use module_dep_simple -! USE module_gocart_drydep,only: gocart_drydep_driver -! USE module_aerosols_soa_vbs, only: soa_vbs_depdriver -! USE module_mosaic_drydep, only: mosaic_drydep_driver -! USE module_mixactivate_wrappers, only: mosaic_mixactivate, sorgam_mixactivate - IMPLICIT NONE - type(smoke_data), pointer, intent(inout) :: data - - INTEGER, INTENT(IN ) :: numgas, current_month, & - num_chem,num_moist, julday, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - INTEGER, INTENT(IN ) :: & - ktau - REAL(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & - INTENT(IN ) :: moist - REAL(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & - INTENT(INOUT ) :: chem - - INTEGER, INTENT(IN ) :: kemit - REAL(kind_phys), DIMENSION( ims:ime, kms:kemit, jms:jme ), & - INTENT(IN ) :: & - e_co - - - - - REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ) , & - INTENT(IN ) :: & - alt, & - t8w, & - dz8w, & - p8w,z_at_w , & - exch_h,rho_phy,z - REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ) , & - INTENT(INOUT) :: & - h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3 - INTEGER,DIMENSION( ims:ime , jms:jme ) , & - INTENT(IN ) :: & - ivgtyp - REAL(kind_phys), DIMENSION( ims:ime , jms:jme ) , & - INTENT(INOUT) :: & - tsk, & - gsw, & - vegfra, & - pbl, & - snowh, & - raincv, & - ust, & - hfx, & - xland, & - xlat, & - xlong, & - znt,rmol - REAL(kind_phys), DIMENSION( ims:ime, jms:jme, num_chem ), & - INTENT(OUT ) :: ddep - REAL(kind_phys), DIMENSION( ims:ime , jms:jme ) , & - INTENT(OUT) :: & - dep_vel_o3 - REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(IN ) :: & - p_phy, & - t_phy - - REAL(kind_phys), INTENT(IN ) :: & - dtstep,g,gmt - -!--- deposition and emissions stuff -! .. Parameters .. -! .. -! .. Local Scalars .. - - REAL(kind_phys) :: cdt, factor - - INTEGER :: idrydep_onoff - -! INTEGER :: chem_conv_tr, chem_opt - -! CHARACTER (4) :: luse_typ,mminlu_loc -! .. -! .. Local Arrays .. - REAL(kind_phys), DIMENSION( its:ite, jts:jte, num_chem ) :: ddvel - -! REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ) :: dryrho_phy - REAL(kind_phys), DIMENSION( kts:kte ) :: dryrho_1d - -! turbulent transport - real(kind_phys) :: pblst(kts:kte),ekmfull(kts:kte+1),zzfull(kts:kte+1),zz(kts:kte) - integer :: i,j,k,nv -! -! necessary for aerosols (module dependent) -! - REAL(kind_phys), DIMENSION( its:ite, jts:jte ) :: aer_res - REAL(kind_phys), DIMENSION( its:ite, jts:jte ) :: aer_res_def - REAL(kind_phys), DIMENSION( its:ite, jts:jte ) :: aer_res_zcen - -! .. -! .. Intrinsic Functions .. - INTRINSIC max, min - -! chem_opt = chem_opt -! chem_conv_tr = chem_conv_tr - -! -! compute dry deposition velocities = ddvel -! -! 28-jun-2005 rce - initialize ddvel=0; call aerosol drydep routine -! only when drydep_opt == WESELY -! the wesely_driver routine computes aer_res, and currently -! you cannot compute aerosol drydep without it !! -! 08-jul-2005 rce - pass idrydep_onoff to mixactivate routines -! -! write(6,*)'call dry dep driver' - dep_vel_o3(:,:)=0. - ddvel(:,:,:) = 0.0 - idrydep_onoff = 0 - -! drydep_select: SELECT CASE(drydep_opt) - -! CASE ( WESELY ) -! -! drydep_opt == WESELY means -! wesely for gases -! other (appropriate) routine for aerosols -! -! CALL wrf_debug(15,'DOING DRY DEP VELOCITIES WITH WESELY METHOD') - - IF( chem_opt /= GOCART_SIMPLE ) THEN - call wesely_driver(data,ktau,dtstep, & - current_month, & - gmt,julday,t_phy,moist,p8w,t8w,raincv, & - p_phy,chem,rho_phy,dz8w,ddvel,aer_res_def,aer_res_zcen, & - ivgtyp,tsk,gsw,vegfra,pbl,rmol,ust,znt,xlat,xlong,z,z_at_w,& - snowh,numgas, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - ENDIF - IF (( chem_opt == GOCART_SIMPLE ) .or. & - ( chem_opt == GOCARTRACM_KPP) .or. & - ( chem_opt == 316) .or. & - ( chem_opt == 317) .or. & -! ( chem_opt == 502) .or. & - (chem_opt == 304 )) then -! -! this does aerosol species (dust,seas, bc,oc) for gocart only -! this does aerosol species (dust,seas, bc,oc,sulf) for gocart only -!, - call gocart_drydep_driver(numgas, & - moist,p8w,chem,rho_phy,dz8w,ddvel,xland,hfx, & - ivgtyp,tsk,pbl,ust,znt,g, & - num_moist,num_chem, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - ELSE if (chem_opt == 501 ) then -! for caesium .1cm/s -! - ddvel(:,:,:)=.001 - ELSE if (chem_opt == 108 ) then -!! call soa_vbs_depdriver (ust,t_phy, & -!! moist,p8w,rmol,znt,pbl, & -!! alt,p_phy,chem,rho_phy,dz8w, & -!! h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3, & -!! aer_res,ddvel(:,:,numgas+1:num_chem), & -!! num_chem-numgas, & -!! ids,ide, jds,jde, kds,kde, & -!! ims,ime, jms,jme, kms,kme, & -!! its,ite, jts,jte, kts,kte ) -! limit aerosol ddvels to <= 0.5 m/s -! drydep routines occasionally produce unrealistically-large particle -! diameter leading to unrealistically-large sedimentation velocity - ddvel(:,:,numgas+1:num_chem) = min( 0.50, ddvel(:,:,numgas+1:num_chem)) - ELSE - !Set dry deposition velocity to zero when using the - !chemistry tracer mode. - ddvel(:,:,:) = 0. - END IF - idrydep_onoff = 1 - -! -! Compute dry deposition according to NGAC -! - cdt = real(dtstep, kind=kind_phys) - do nv = 1, num_chem - do j = jts, jte - do i = its, ite - factor = 1._kind_phys - exp(-ddvel(i,j,nv)*cdt/dz8w(i,kts,j)) - ddep(i,j,nv) = max(0.0, factor * chem(i,kts,j,nv)) & !ug/m2/s - * (p8w(i,kts,j)-p8w(i,kts+1,j))/g/dtstep - end do - end do - end do - - -! This will be called later from subgrd_transport_driver.F !!!!!!!! -! -! - do 100 j=jts,jte - do 100 i=its,ite - if(p_dust_1.gt.1)dep_vel_o3(i,j)=ddvel(i,j,p_dust_1) - pblst=0. -! -! -!-- start with vertical mixing -! - do k=kts,kte+1 - zzfull(k)=z_at_w(i,k,j)-z_at_w(i,kts,j) - enddo - - if (chem_conv_tr == CTRA_OPT_NONE) then - ekmfull = 0. - else - ekmfull(kts)=0. - do k=kts+1,kte - ekmfull(k)=max(1.e-6,exch_h(i,k,j)) - enddo - ekmfull(kte+1)=0. - end if - -!!$! UNCOMMENT THIS AND FINE TUNE LEVELS TO YOUR DOMAIN IF YOU WANT TO -!!$! FORCE MIXING TO A CERTAIN DEPTH: -!!$! -!!$! --- Mix the emissions up several layers -! - do k=kts,kte - zz(k)=z(i,k,j)-z_at_w(i,kts,j) - enddo -! vertical mixing routine (including deposition) -! need to be careful here with that dumm tracer in spot 1 -! do not need lho,lho2 -! (03-may-2006 rce - calc dryrho_1d and pass it to vertmx) -! -! if(p_o3.gt.1)dep_vel_o3(i,j)=ddvel(i,j,p_o3) - do nv=1,num_chem-0 - do k=kts,kte - pblst(k)=max(epsilc,chem(i,k,j,nv)) - dryrho_1d(k) = 1./alt(i,k,j) - enddo - - !mix_select: SELECT CASE(chem_opt) - !CASE DEFAULT - call vertmx(data,dtstep,pblst,ekmfull,dryrho_1d, & - zzfull,zz,ddvel(i,j,nv),kts,kte) - - !END SELECT mix_select - - do k=kts,kte - chem(i,k,j,nv)=max(epsilc,pblst(k)) - enddo - enddo -100 continue - -END SUBROUTINE dry_dep_driver - -end module dep_dry_mod diff --git a/smoke/dep_simple_mod.F90 b/smoke/dep_simple_mod.F90 deleted file mode 100755 index 37a8189b5..000000000 --- a/smoke/dep_simple_mod.F90 +++ /dev/null @@ -1,766 +0,0 @@ -!>\file dep_simple_mod.F90 -!! This file contains the Wesely dry deposition module. - -module dep_simple_mod - - use rrfs_smoke_data - use rrfs_smoke_config, GOCART_SIMPLE => CHEM_OPT_GOCART, chem_opt=>chem_opt -! use chem_tracers_mod, config_flags => chem_config - -! USE module_data_sorgam - - implicit none - -!-------------------------------------------------- -! .. Default Accessibility .. -!-------------------------------------------------- - PUBLIC - - - CONTAINS - -SUBROUTINE wesely_driver( data, ktau, dtstep, current_month, & - gmt, julday, t_phy,moist, p8w, t8w, raincv, & - p_phy, chem, rho_phy, dz8w, ddvel, aer_res_def, & - aer_res_zcen, ivgtyp, tsk, gsw, vegfra, pbl, & - rmol, ust, znt, xlat, xlong, & - z, z_at_w, snowh, numgas, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - implicit none -!-------------------------------------------------- -! Wesely dry dposition driver -!-------------------------------------------------- - -! USE module_model_constants -! USE module_wrf_control,only:num_moist,num_chem -! USE module_state_description -! USE module_initial_chem_namelists -! USE module_data_sorgam -! USE module_state_description, only: param_first_scalar - type(smoke_data), intent(inout), pointer :: data - INTEGER, INTENT(IN ) :: julday, & - numgas, current_month, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - INTEGER, INTENT(IN ) :: ktau - REAL(kind_phys), INTENT(IN ) :: dtstep,gmt - -!-------------------------------------------------- -! advected moisture variables -!-------------------------------------------------- - REAL(KIND_PHYS), DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), INTENT(IN ) :: & - moist -!-------------------------------------------------- -! advected chemical species -!-------------------------------------------------- - REAL(KIND_PHYS), DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), INTENT(INOUT ) :: & - chem -!-------------------------------------------------- -! deposition velocities -!-------------------------------------------------- - REAL(KIND_PHYS), DIMENSION( its:ite, jts:jte, num_chem ), INTENT(INOUT ) :: & - ddvel -!-------------------------------------------------- -! input from met model -!-------------------------------------------------- - REAL(KIND_PHYS), DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: & - t_phy, & - p_phy, & - dz8w, & - z, & - t8w, & - p8w, & - z_at_w, & - rho_phy - INTEGER,DIMENSION( ims:ime , jms:jme ), INTENT(IN ) :: & - ivgtyp - REAL(KIND_PHYS), DIMENSION( ims:ime , jms:jme ), INTENT(INOUT ) :: & - tsk, & - gsw, & - vegfra, & - pbl, & - rmol, & - ust, & - xlat, & - xlong, & - raincv, & - znt - REAL(KIND_PHYS), intent(inout) :: aer_res_def(its:ite,jts:jte) - REAL(KIND_PHYS), intent(inout) :: aer_res_zcen(its:ite,jts:jte) - REAL(KIND_PHYS), INTENT(IN) :: snowh(ims:ime,jms:jme) - -!-------------------------------------------------- -! .. Local Scalars -!-------------------------------------------------- - REAL(kind_phys) :: clwchem, dvfog, dvpart, pa, rad, dep_vap - REAL(KIND_PHYS) :: rhchem, ta, ustar, vegfrac, z1, zntt - INTEGER :: i, iland, iprt, iseason, j, jce, jcs, n, nr, ipr,jpr,nvr - LOGICAL :: highnh3, rainflag, vegflag, wetflag -!-------------------------------------------------- -! .. Local Arrays -!-------------------------------------------------- - REAL(KIND_PHYS) :: p(kts:kte) - REAL(KIND_PHYS) :: srfres(numgas) - REAL(KIND_PHYS) :: ddvel0d(numgas) - -!----------------------------------------------------------- -! necessary for aerosols (module dependent) -!----------------------------------------------------------- - real(kind_phys) :: rcx(numgas) - - -!----------------------------------------------------------- -! .. Intrinsic Functions -!----------------------------------------------------------- -! integer :: chem_opt - - INTRINSIC max, min - - data => get_thread_smoke_data() - -! chem_opt = chem_opt - - dep_vap = depo_fact - !print*,'hli simple chem_opt',chem_opt - -! CALL wrf_debug(15,'in dry_dep_wesely') - - if( julday < 90 .or. julday > 270 ) then - iseason = 2 -! CALL wrf_debug(15,'setting iseason to 2') - else - iseason = 1 - endif - - -tile_lat_loop : & - do j = jts,jte -tile_lon_loop : & - do i = its,ite - iprt = 0 - - iland = luse2usgs( ivgtyp(i,j) ) -!-- - - ta = tsk(i,j) - rad = gsw(i,j) - vegfrac = vegfra(i,j) - pa = .01*p_phy(i,kts,j) - clwchem = moist(i,kts,j,p_qc) - ustar = ust(i,j) - zntt = znt(i,j) - z1 = z_at_w(i,kts+1,j) - z_at_w(i,kts,j) -!----------------------------------------------------------- -! Set logical default values -!----------------------------------------------------------- - rainflag = .FALSE. - wetflag = .FALSE. - highnh3 = .FALSE. -! if(p_qr > 1) then -! if(moist(i,kts,j,p_qr) > 1.e-18 .or. raincv(i,j) > 0.) then -! rainflag = .true. -! endif -! endif - rhchem = MIN( 100.,100. * moist(i,kts,j,p_qv) / & - (3.80*exp(17.27*(t_phy(i,kts,j)-273.)/(t_phy(i,kts,j)-36.))/pa)) - rhchem = MAX(5.,RHCHEM) - if (rhchem >= 95.) wetflag = .true. - -!----------------------------------------------------------- -!--- deposition -!----------------------------------------------------------- -! if(snowc(i,j).gt.0.)iseason=4 - CALL rc( data, rcx, ta, rad, rhchem, iland, & - iseason, numgas, wetflag, rainflag, highnh3, & - iprt, moist(i,kts,j,p_qv), p8w(i,kts,j) ) - srfres(1:numgas-2) = rcx(1:numgas-2) - srfres(numgas-1:numgas) = 0. - CALL deppart( data, rmol(i,j), ustar, rhchem, clwchem, iland, dvpart, dvfog ) - ddvel0d(1:numgas) = 0. - aer_res_def(i,j) = 0. - aer_res_zcen(i,j) = 0. - CALL landusevg( data, ddvel0d, ustar, rmol(i,j), zntt, z1, dvpart, iland, & - numgas, srfres, aer_res_def(i,j), aer_res_zcen(i,j), p_sulf ) - -!----------------------------------------------------------- -!wig: CBMZ does not have HO and HO2 last so need to copy all species -! ddvel(i,j,1:numgas-2)=ddvel0d(1:numgas-2) -!----------------------------------------------------------- - ddvel(i,j,1:numgas) = ddvel0d(1:numgas) - end do tile_lon_loop - end do tile_lat_loop - -!----------------------------------------------------------- -! For the additional CBMZ species, assign similar RADM counter parts for -! now. Short lived species get a zero velocity since dry dep should be -! unimportant. **ALSO**, treat p_sulf as h2so4 vapor, not aerosol sulfate -!----------------------------------------------------------- -! - -!----------------------------------------------------------- -! For gocartsimple : need msa. On the other hand sulf comes from aerosol routine -!----------------------------------------------------------- - if (chem_opt == GOCART_SIMPLE ) then - do j=jts,jte - do i=its,ite - ddvel(i,j,p_msa) = ddvel(i,j,p_sulf) - ddvel(i,j,p_sulf) = 0. - ddvel(i,j,p_dms) = 0. - end do - end do - end if - -END SUBROUTINE wesely_driver - - SUBROUTINE rc( data, rcx, t, rad, rh, iland, & - iseason, numgas, wetflag, rainflag, highnh3, & - iprt, spec_hum, p_srf ) -!---------------------------------------------------------------------- -! THIS SUBROUTINE CALCULATES SURFACE RESISTENCES ACCORDING -! TO THE MODEL OF -! M. L. WESELY, -! ATMOSPHERIC ENVIRONMENT 23 (1989), 1293-1304 -! WITH SOME ADDITIONS ACCORDING TO -! J. W. ERISMAN, A. VAN PUL, AND P. WYERS, -! ATMOSPHERIC ENVIRONMENT 28 (1994), 2595-2607 -! WRITTEN BY WINFRIED SEIDL, APRIL 1997 -! MODYFIED BY WINFRIED SEIDL, MARCH 2000 -! FOR MM5 VERSION 3 -!---------------------------------------------------------------------- - -! USE module_state_description -! USE module_initial_chem_namelists - implicit none - type(smoke_data), pointer, intent(inout) :: data -!---------------------------------------------------------------------- -! ... dummy arguments -!---------------------------------------------------------------------- - INTEGER, intent(in) :: iland, iseason, numgas - INTEGER, intent(in) :: iprt - REAL(KIND_PHYS), intent(in) :: rad, rh - REAL(KIND_PHYS), intent(in) :: t ! surface temp (K) - REAL(KIND_PHYS), intent(in) :: p_srf ! surface pressure (Pa) - REAL(KIND_PHYS), intent(in) :: spec_hum ! surface specific humidity (kg/kg) - real(kind_phys), intent(out) :: rcx(numgas) - LOGICAL, intent(in) :: highnh3, rainflag, wetflag - -!---------------------------------------------------------------------- -! .. Local Scalars .. -!---------------------------------------------------------------------- - REAL(KIND_PHYS), parameter :: t0 = 298. - REAL(KIND_PHYS), parameter :: tmelt = 273.16 - INTEGER :: lt, n - INTEGER :: chem_opt - REAL(KIND_PHYS) :: rclx, rdc, resice, rgsx, rluo1, rluo2 - REAL(KIND_PHYS) :: rlux, rmx, rs, rsmx, rdtheta, z, wrk - REAL(KIND_PHYS) :: qs, es, ws, dewm, dv_pan, drat - REAL(KIND_PHYS) :: crs, tc - REAL(KIND_PHYS) :: rs_pan, tc_pan - LOGICAL :: has_dew -!---------------------------------------------------------------------- -! .. Local Arrays .. -!---------------------------------------------------------------------- - REAL(KIND_PHYS) :: hstary(numgas) - -!---------------------------------------------------------------------- -! .. Intrinsic Functions .. -!---------------------------------------------------------------------- - INTRINSIC exp - - chem_opt = chem_opt - - rcx(1:numgas) = 1. - - tc = t - 273.15 - rdtheta = 0. - - z = 200./(rad+0.1) - -!!! HARDWIRE VALUES FOR TESTING -! z=0.4727409 -! tc=22.76083 -! t=tc+273.15 -! rad = 412.8426 -! rainflag=.false. -! wetflag=.false. - - IF ( tc<=0. .OR. tc>=40. ) THEN - rs = 9999. - ELSE - rs = data%ri(iland,iseason)*(1+z*z)*(400./(tc*(40.-tc))) - END IF - rdc = 100.*(1. + 1000./(rad + 10.))/(1. + 1000.*rdtheta) - rluo1 = 1./(1./3000. + 3./data%rlu(iland,iseason)) - rluo2 = 1./(1./1000. + 3./data%rlu(iland,iseason)) - resice = 1000.*exp( -(tc + 4.) ) - wrk = (t0 - t)/(t0*t) - - - DO n = 1, numgas - IF( data%hstar(n) /= 0. ) then - hstary(n) = data%hstar(n)*exp( data%dhr(n)*wrk ) -!---------------------------------------------------------------------- -! SPECIAL TREATMENT FOR HNO3, HNO4, H2O2, PAA -!---------------------------------------------------------------------- - rmx = 1./(hstary(n)/3000. + 100.*data%f0(n)) - rsmx = rs*data%dratio(n) + rmx - rclx = 1./(1.e-5*hstary(n)/data%rcls(iland,iseason) & - + data%f0(n)/data%rclo(iland,iseason)) + resice - rgsx = 1./(1.e-5*hstary(n)/data%rgss(iland,iseason) & - + data%f0(n)/data%rgso(iland,iseason)) + resice - rlux = data%rlu(iland,iseason)/(1.e-5*hstary(n) + data%f0(n)) + resice - IF( wetflag ) THEN - rlux = 1./(1./(3.*data%rlu(iland,iseason)) + 1.e-7*hstary(n) + data%f0(n)/rluo1) - END IF - IF( rainflag ) THEN - rlux = 1./(1./(3.*data%rlu(iland,iseason)) + 1.e-7*hstary(n) + data%f0(n)/rluo2) - END IF - rcx(n) = 1./(1./rsmx + 1./rlux + 1./(rdc + rclx) + 1./(data%rac(iland,iseason) + rgsx)) - rcx(n) = max( 1.,rcx(n) ) - end IF - END DO - -!-------------------------------------------------- -! SPECIAL TREATMENT FOR OZONE -!-------------------------------------------------- -! SPECIAL TREATMENT FOR SO2 (Wesely) -! HSTARY(P_SO2)=DATA%HSTAR(P_SO2)*EXP(DATA%DHR(P_SO2)*(1./T-1./298.)) -! RMX=1./(HSTARY(P_SO2)/3000.+100.*DATA%F0(P_SO2)) -! RSMX=RS*DATA%DRATIO(P_SO2)+RMX -! RLUX=DATA%RLU(ILAND,ISEASON)/(1.E-5*HSTARY(P_SO2)+DATA%F0(P_SO2)) -! & +RESICE -! RCLX=DATA%RCLS(ILAND,ISEASON)+RESICE -! RGSX=DATA%RGSS(ILAND,ISEASON)+RESICE -! IF ((wetflag).OR.(RAINFLAG)) THEN -! IF (ILAND.EQ.1) THEN -! RLUX=50. -! ELSE -! RLUX=100. -! END IF -! END IF -! RCX(P_SO2)=1./(1./RSMX+1./RLUX+1./(RDC+RCLX) -! & +1./(DATA%RAC(ILAND,ISEASON)+RGSX)) -! IF (RCX(P_SO2).LT.1.) RCX(P_SO2)=1. - -!-------------------------------------------------- -! SO2 according to Erisman et al. 1994 -! R_STOM -!-------------------------------------------------- -is_so2 : & - if( p_so2 > 1 ) then - rsmx = rs*data%dratio(p_so2) -!-------------------------------------------------- -! R_EXT -!-------------------------------------------------- - IF (tc> -1. ) THEN - IF (rh<81.3) THEN - rlux = 25000.*exp(-0.0693*rh) - ELSE - rlux = 0.58E12*exp(-0.278*rh) - END IF - END IF - IF (((wetflag) .OR. (rainflag)) .AND. (tc> -1. )) THEN - rlux = 1. - END IF - IF ((tc>= -5. ) .AND. (tc<= -1. )) THEN - rlux = 200. - END IF - IF (tc< -5. ) THEN - rlux = 500. - END IF -!-------------------------------------------------- -! INSTEAD OF R_INC R_CL and R_DC of Wesely are used -!-------------------------------------------------- - rclx = data%rcls(iland,iseason) -!-------------------------------------------------- -! DRY SURFACE -!-------------------------------------------------- - rgsx = 1000. -!-------------------------------------------------- -! WET SURFACE -!-------------------------------------------------- - IF ((wetflag) .OR. (rainflag)) THEN - IF (highnh3) THEN - rgsx = 0. - ELSE - rgsx = 500. - END IF - END IF -!-------------------------------------------------- -! WATER -!-------------------------------------------------- - IF (iland==iswater_temp) THEN - rgsx = 0. - END IF -!-------------------------------------------------- -! SNOW -!-------------------------------------------------- - IF( iseason==4 .OR. iland==isice_temp ) THEN - IF( tc > 2. ) THEN - rgsx = 0. - else IF ( tc >= -1. .AND. tc <= 2. ) THEN - rgsx = 70.*(2. - tc) - else IF ( tc < -1. ) THEN - rgsx = 500. - END IF - END IF -!-------------------------------------------------- -! TOTAL SURFACE RESISTENCE -!-------------------------------------------------- - IF ((iseason/=4) .AND. (data%ixxxlu(iland)/=1) .AND. (iland/=iswater_temp) .AND. & - (iland/=isice_temp)) THEN - rcx(p_so2) = 1./(1./rsmx+1./rlux+1./(rclx+rdc+rgsx)) - ELSE - rcx(p_so2) = rgsx - END IF - rcx(p_so2) = max( 1.,rcx(p_so2) ) - end if is_so2 -!-------------------------------------------------- -! NH3 according to Erisman et al. 1994 -! R_STOM -!-------------------------------------------------- - END SUBROUTINE rc - - SUBROUTINE deppart( data, rmol, ustar, rh, clw, iland, & - dvpart, dvfog ) -!-------------------------------------------------- -! THIS SUBROUTINE CALCULATES SURFACE DEPOSITION VELOCITIES -! FOR FINE AEROSOL PARTICLES ACCORDING TO THE MODEL OF -! J. W. ERISMAN, A. VAN PUL, AND P. WYERS, -! ATMOSPHERIC ENVIRONMENT 28 (1994), 2595-2607 -! WRITTEN BY WINFRIED SEIDL, APRIL 1997 -! MODIFIED BY WINFRIED SEIDL, MARCH 2000 -! FOR MM5 VERSION 3 -!-------------------------------------------------- - implicit none - type(smoke_data), pointer, intent(inout) :: data - -!-------------------------------------------------- -! .. Scalar Arguments .. -!-------------------------------------------------- - INTEGER, intent(in) :: iland - REAL(KIND_PHYS), intent(in) :: clw, rh, rmol, ustar - REAL(KIND_PHYS), intent(out) :: dvfog, dvpart - -!-------------------------------------------------- -! .. Intrinsic Functions .. -!-------------------------------------------------- - INTRINSIC exp - - dvpart = ustar/data%kpart(iland) - IF (rmol<0.) THEN -!-------------------------------------------------- -! UNSTABLE LAYERING CORRECTION -!-------------------------------------------------- - dvpart = dvpart*(1.+(-300.*rmol)**0.66667) - END IF - IF (rh>80.) THEN -!-------------------------------------------------- -! HIGH RELATIVE HUMIDITY CORRECTION -! ACCORDING TO J. W. ERISMAN ET AL. -! ATMOSPHERIC ENVIRONMENT 31 (1997), 321-332 -!-------------------------------------------------- - dvpart = dvpart*(1.+0.37*exp((rh-80.)/20.)) - END IF - -!-------------------------------------------------- -! SEDIMENTATION VELOCITY OF FOG WATER ACCORDING TO -! R. FORKEL, W. SEIDL, R. DLUGI AND E. DEIGELE -! J. GEOPHYS. RES. 95D (1990), 18501-18515 -!-------------------------------------------------- - dvfog = 0.06*clw - IF (data%ixxxlu(iland)==5) THEN -!-------------------------------------------------- -! TURBULENT DEPOSITION OF FOG WATER IN CONIFEROUS FOREST ACCORDI -! A. T. VERMEULEN ET AL. -! ATMOSPHERIC ENVIRONMENT 31 (1997), 375-386 -!-------------------------------------------------- - dvfog = dvfog + 0.195*ustar*ustar - END IF - - END SUBROUTINE deppart - - SUBROUTINE landusevg( data, vgs, ustar, rmol, z0, zz, & - dvparx, iland, numgas, srfres, aer_res_def, & - aer_res_zcen, p_sulf ) -!-------------------------------------------------- -! This subroutine calculates the species specific deposition velocit -! as a function of the local meteorology and land use. The depositi -! Velocity is also landuse specific. -! Reference: Hsieh, C.M., Wesely, M.L. and Walcek, C.J. (1986) -! A Dry Deposition Module for Regional Acid Deposition -! EPA report under agreement DW89930060-01 -! Revised version by Darrell Winner (January 1991) -! Environmental Engineering Science 138-78 -! California Institute of Technology -! Pasadena, CA 91125 -! Modified by Winfried Seidl (August 1997) -! Fraunhofer-Institut fuer Atmosphaerische Umweltforschung -! Garmisch-Partenkirchen, D-82467 -! for use of Wesely and Erisman surface resistances -! Inputs: -! Ustar : The grid average friction velocity (m/s) -! Rmol : Reciprocal of the Monin-Obukhov length (1/m) -! Z0 : Surface roughness height for the grid square (m) -! SrfRes : Array of landuse/atmospheric/species resistances (s/m) -! Slist : Array of chemical species codes -! Dvparx : Array of surface deposition velocity of fine aerosol p -! Outputs: -! Vgs : Array of species and landuse specific deposition -! velocities (m/s) -! Vg : Cell-average deposition velocity by species (m/s) -! Variables used: -! SCPR23 : (Schmidt #/Prandtl #)**(2/3) Diffusion correction fac -! Zr : Reference Height (m) -! Iatmo : Parameter specifying the stabilty class (Function of -! Z0 : Surface roughness height (m) -! karman : Von Karman constant (from module_model_constants) -!-------------------------------------------------- - -! USE module_model_constants, only: karman - implicit none - - type(smoke_data), pointer, intent(inout) :: data - -!-------------------------------------------------- -! .. Scalar Arguments .. -!-------------------------------------------------- - INTEGER, intent(in) :: iland, numgas, p_sulf - REAL(KIND_PHYS), intent(in) :: dvparx, ustar, z0, zz - REAL(KIND_PHYS), intent(inout) :: rmol - REAL(KIND_PHYS), intent(inout) :: aer_res_def - REAL(KIND_PHYS), intent(inout) :: aer_res_zcen -!-------------------------------------------------- -! .. Array Arguments .. -!-------------------------------------------------- - REAL(KIND_PHYS), intent(in) :: srfres(numgas) - REAL(KIND_PHYS), intent(out) :: vgs(numgas) - -!-------------------------------------------------- -! .. Local Scalars .. -!-------------------------------------------------- - INTEGER :: jspec - REAL(KIND_PHYS) :: vgp, vgpart, zr - REAL(KIND_PHYS) :: rmol_tmp -!-------------------------------------------------- -! .. Local Arrays .. -!-------------------------------------------------- - REAL(KIND_PHYS) :: vgspec(numgas) - -!-------------------------------------------------- -! Calculate aerodynamic resistance for reference -! height = layer center -!-------------------------------------------------- - zr = zz*.5 - rmol_tmp = rmol - CALL depvel( data, numgas, rmol_tmp, zr, z0, ustar, & - vgspec, vgpart, aer_res_zcen ) -!-------------------------------------------------- -! Set the reference height (2.0 m) -!-------------------------------------------------- -! zr = 10.0 - zr = 2.0 - -!-------------------------------------------------- -! CALCULATE THE DEPOSITION VELOCITY without any surface -! resistance term, i.e. 1 / (ra + rb) -!-------------------------------------------------- - CALL depvel( data, numgas, rmol, zr, z0, ustar, & - vgspec, vgpart, aer_res_def ) - -!-------------------------------------------------- -! Calculate the deposition velocity for each species -! and grid cell by looping through all the possibile combinations -! of the two -!-------------------------------------------------- - vgp = 1.0/((1.0/vgpart)+(1.0/dvparx)) -!-------------------------------------------------- -! Loop through the various species -!-------------------------------------------------- - DO jspec = 1, numgas -!-------------------------------------------------- -! Add in the surface resistance term, rc (SrfRes) -!-------------------------------------------------- - vgs(jspec) = 1.0/(1.0/vgspec(jspec) + srfres(jspec)) - END DO - vgs(p_sulf) = vgp - - CALL cellvg( data, vgs, ustar, zz, zr, rmol, numgas ) - - END SUBROUTINE landusevg - - SUBROUTINE cellvg( data, vgtemp, ustar, dz, zr, rmol, nspec ) -!-------------------------------------------------- -! THIS PROGRAM HAS BEEN DESIGNED TO CALCULATE THE CELL AVERAGE -! DEPOSITION VELOCITY GIVEN THE VALUE OF VG AT SOME REFERENCE -! HEIGHT ZR WHICH IS MUCH SMALLER THAN THE CELL HEIGHT DZ. -! PROGRAM WRITTEN BY GREGORY J.MCRAE (NOVEMBER 1977) -! Modified by Darrell A. Winner (February 1991) -!.....PROGRAM VARIABLES... -! VgTemp - DEPOSITION VELOCITY AT THE REFERENCE HEIGHT -! USTAR - FRICTION VELOCITY -! RMOL - RECIPROCAL OF THE MONIN-OBUKHOV LENGTH -! ZR - REFERENCE HEIGHT -! DZ - CELL HEIGHT -! CELLVG - CELL AVERAGE DEPOSITION VELOCITY -! VK - VON KARMAN CONSTANT -!-------------------------------------------------- - -! USE module_model_constants, only: karman - implicit none - type(smoke_data), pointer, intent(inout) :: data - -!-------------------------------------------------- -! .. Scalar Arguments .. -!-------------------------------------------------- - INTEGER, intent(in) :: nspec - REAL(KIND_PHYS), intent(in) :: dz, rmol, ustar, zr -!-------------------------------------------------- -! .. Array Arguments .. -!-------------------------------------------------- - REAL(KIND_PHYS), intent(out) :: vgtemp(nspec) -!-------------------------------------------------- -! .. Local Scalars .. -!-------------------------------------------------- - INTEGER :: nss - REAL(KIND_PHYS) :: a, fac, pdz, pzr, vk -!-------------------------------------------------- -! .. Intrinsic Functions .. -!-------------------------------------------------- - INTRINSIC alog, sqrt - -!-------------------------------------------------- -! Set the von Karman constant -!-------------------------------------------------- - vk = karman - -!-------------------------------------------------- -! DETERMINE THE STABILITY BASED ON THE CONDITIONS -! 1/L < 0 UNSTABLE -! 1/L = 0 NEUTRAL -! 1/L > 0 STABLE -!-------------------------------------------------- - DO nss = 1, nspec - IF (rmol < 0.) THEN - pdz = sqrt(1.0 - 9.0*dz*rmol) - pzr = sqrt(1.0 - 9.0*zr*rmol) - fac = ((pdz - 1.0)/(pzr - 1.0))*((pzr + 1.0)/(pdz + 1.0)) - a = 0.74*dz*alog(fac) + (0.164/rmol)*(pdz-pzr) - ELSE IF (rmol == 0.) THEN - a = 0.74*(dz*alog(dz/zr) - dz + zr) - ELSE - a = 0.74*(dz*alog(dz/zr) - dz + zr) + (2.35*rmol)*(dz - zr)**2 - END IF -!-------------------------------------------------- -! CALCULATE THE DEPOSITION VELOCITIY -!-------------------------------------------------- - vgtemp(nss) = vgtemp(nss)/(1.0 + vgtemp(nss)*a/(vk*ustar*(dz - zr))) - END DO - - END SUBROUTINE cellvg - - SUBROUTINE depvel( data, numgas, rmol, zr, z0, ustar, & - depv, vgpart, aer_res ) -!-------------------------------------------------- -! THIS FUNCTION HAS BEEN DESIGNED TO EVALUATE AN UPPER LIMIT -! FOR THE POLLUTANT DEPOSITION VELOCITY AS A FUNCTION OF THE -! SURFACE ROUGHNESS AND METEOROLOGICAL CONDITIONS. -! PROGRAM WRITTEN BY GREGORY J.MCRAE (NOVEMBER 1977) -! Modified by Darrell A. Winner (Feb. 1991) -! by Winfried Seidl (Aug. 1997) -!.....PROGRAM VARIABLES... -! RMOL - RECIPROCAL OF THE MONIN-OBUKHOV LENGTH -! ZR - REFERENCE HEIGHT -! Z0 - SURFACE ROUGHNESS HEIGHT -! SCPR23 - (Schmidt #/Prandtl #)**(2/3) Diffusion correction fact -! UBAR - ABSOLUTE VALUE OF SURFACE WIND SPEED -! DEPVEL - POLLUTANT DEPOSITION VELOCITY -! Vk - VON KARMAN CONSTANT -! USTAR - FRICTION VELOCITY U* -! POLINT - POLLUTANT INTEGRAL -! AER_RES - AERODYNAMIC RESISTANCE -!.....REFERENCES... -! MCRAE, G.J. ET AL. (1983) MATHEMATICAL MODELING OF PHOTOCHEMICAL -! AIR POLLUTION, ENVIRONMENTAL QUALITY LABORATORY REPORT 18, -! CALIFORNIA INSTITUTE OF TECHNOLOGY, PASADENA, CALIFORNIA. -!.....RESTRICTIONS... -! 1. THE MODEL EDDY DIFFUSIVITIES ARE BASED ON MONIN-OBUKHOV -! SIMILARITY THEORY AND SO ARE ONLY APPLICABLE IN THE -! SURFACE LAYER, A HEIGHT OF O(30M). -! 2. ALL INPUT UNITS MUST BE CONSISTENT -! 3. THE PHI FUNCTIONS USED TO CALCULATE THE FRICTION -! VELOCITY U* AND THE POLLUTANT INTEGRALS ARE BASED -! ON THE WORK OF BUSINGER ET AL.(1971). -! 4. THE MOMENTUM AND POLLUTANT DIFFUSIVITIES ARE NOT -! THE SAME FOR THE CASES L<0 AND L>0. -!-------------------------------------------------- - -! USE module_model_constants, only: karman - implicit none - type(smoke_data), pointer, intent(inout) :: data - -!-------------------------------------------------- -! .. Scalar Arguments .. -!-------------------------------------------------- - INTEGER, intent(in) :: numgas - REAL(KIND_PHYS), intent(in) :: ustar, z0, zr - REAL(KIND_PHYS), intent(out) :: vgpart, aer_res - REAL(KIND_PHYS), intent(inout) :: rmol -!-------------------------------------------------- -! .. Array Arguments .. -!-------------------------------------------------- - REAL(KIND_PHYS), intent(out) :: depv(numgas) -!-------------------------------------------------- -! .. Local Scalars .. -!-------------------------------------------------- - INTEGER :: l - REAL(KIND_PHYS) :: ao, ar, polint, vk -!-------------------------------------------------- -! .. Intrinsic Functions .. -!-------------------------------------------------- - INTRINSIC alog -!-------------------------------------------------- -! Set the von Karman constant -!-------------------------------------------------- - vk = karman - -!-------------------------------------------------- -! Calculate the diffusion correction factor -! SCPR23 is calculated as (Sc/Pr)**(2/3) using Sc= 1.15 and Pr= 1.0 -! DATA%SCPR23 = 1.10 -!-------------------------------------------------- -! DETERMINE THE STABILITY BASED ON THE CONDITIONS -! 1/L < 0 UNSTABLE -! 1/L = 0 NEUTRAL -! 1/L > 0 STABLE -!-------------------------------------------------- - - if(abs(rmol) < 1.E-6 ) rmol = 0. - - IF (rmol<0) THEN - ar = ((1.0-9.0*zr*rmol)**(0.25)+0.001)**2 - ao = ((1.0-9.0*z0*rmol)**(0.25)+0.001)**2 - polint = 0.74*(alog((ar-1.0)/(ar+1.0))-alog((ao-1.0)/(ao+1.0))) - ELSE IF (rmol==0.) THEN - polint = 0.74*alog(zr/z0) - ELSE - polint = 0.74*alog(zr/z0) + 4.7*rmol*(zr-z0) - END IF - -!-------------------------------------------------- -! CALCULATE THE Maximum DEPOSITION VELOCITY -!-------------------------------------------------- - DO l = 1, numgas - depv(l) = ustar*vk/(2.0*data%scpr23(l)+polint) - END DO - vgpart = ustar*vk/polint - aer_res = polint/(karman*max(ustar,1.0e-4)) - - END SUBROUTINE depvel - - ! NOTE: dep_init is now in rrfs_smoke_data - -end module dep_simple_mod diff --git a/smoke/dep_vertmx_mod.F90 b/smoke/dep_vertmx_mod.F90 deleted file mode 100755 index d56b1b87e..000000000 --- a/smoke/dep_vertmx_mod.F90 +++ /dev/null @@ -1,212 +0,0 @@ -!>\file dep_vertmx_mod.F90 -!! This file calculates change in time of phi due to vertical mixing and dry deposition. - -MODULE dep_vertmx_mod - use rrfs_smoke_data - use machine , only : kind_phys - -CONTAINS - -!----------------------------------------------------------------------- - SUBROUTINE vertmx( data, dt, phi, kt_turb, dryrho, & - zsigma, zsigma_half, vd, kts, ktem1 ) -! !! purpose - calculate change in time of phi due to vertical mixing -! !! and dry deposition (for 1 species, 1 vertical column, 1 time step) -! !! Mariusz Pagowski, March 2001 -! !! conventions used: -! !! input is lower case -! !! output is upper case -! -! !! modifications by R Easter, May 2006 -! !! added dryrho so this routine conserves column mass burde -! !! when dry deposition velocity is zero -! !! changed "kte" to "ktem1" for consistency with the kte in WRF -! -! ARGUMENTS -! -! dt = time step (s) -! phi = initial/final (at input/output) species mixing ratios at "T" points -! kt_turb = turbulent exchange coefficients (m^2/s) at "W" points -! dryrho = dry air density (kg/m^3) at "T" points -! zsigma = heights (m) at "W" points -! zsigma_half = heights (m) at "T" points -! vd = dry deposition velocity (m/s) -! kts, ktem1 = vertical indices of bottom and top "T" points -! - IMPLICIT NONE - type(smoke_data), intent(inout) :: data - -! .. Scalar Arguments .. - INTEGER, INTENT(IN) :: kts,ktem1 - REAL(KIND=KIND_PHYS), INTENT(IN) :: dt, vd -! .. -! .. Array Arguments .. - REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts:ktem1+1) :: kt_turb, zsigma - REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts:ktem1) :: dryrho, zsigma_half - REAL(KIND=KIND_PHYS), INTENT(INOUT), DIMENSION (kts:ktem1) :: phi -! .. -! .. Local Scalars .. - INTEGER :: k -! .. -! .. Local Arrays .. - REAL(KIND=KIND_PHYS), DIMENSION (kts+1:ktem1) :: a_coeff - REAL(KIND=KIND_PHYS), DIMENSION (kts:ktem1) :: b_coeff, lhs1, lhs2, lhs3, rhs -! .. -! .. External Subroutines .. -! EXTERNAL coeffs, rlhside, tridiag -! .. - CALL coeffs( data, kts, ktem1, dryrho, zsigma, zsigma_half, a_coeff, b_coeff ) - - CALL rlhside( data, kts, ktem1, kt_turb, dryrho, a_coeff, b_coeff, & - phi, dt, vd, rhs, lhs1, lhs2, lhs3 ) - - CALL tridiag( data, kts, ktem1, lhs1, lhs2, lhs3, rhs ) - - DO k = kts,ktem1 - phi(k) = rhs(k) - END DO - - END SUBROUTINE vertmx - - -!----------------------------------------------------------------------- - SUBROUTINE rlhside( data, kts, ktem1, k_turb, dryrho, a_coeff, b_coeff, & - phi, dt, vd, rhs, lhs1, lhs2, lhs3 ) - !! to calculate right and left hand sides in diffusion equation - !! for the tridiagonal solver - !! Mariusz Pagowski, March 2001 - !! conventions used: - !! input is lower case - !! output is upper case - IMPLICIT NONE - type(smoke_data), intent(inout) :: data - -! .. Scalar Arguments .. - INTEGER, INTENT(IN) :: kts,ktem1 - REAL(KIND=KIND_PHYS), INTENT(IN) :: dt, vd -! .. -! .. Array Arguments .. - REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts:ktem1+1) :: k_turb - REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts+1:ktem1) :: a_coeff - REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts:ktem1) :: b_coeff, dryrho - REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts:ktem1) :: phi - REAL(KIND=KIND_PHYS), INTENT(OUT), DIMENSION (kts:ktem1) :: lhs1, lhs2, lhs3, rhs -! .. -! .. Local Scalars .. - !REAL(KIND_PHYS) :: a1, a2, alfa_explicit = .25, beta_implicit = .75 - REAL(KIND_PHYS) :: a1, a2, alfa_explicit = .0, beta_implicit = 1. - INTEGER :: i - -! .. - i = kts - a2 = a_coeff(i+1)*k_turb(i+1) - rhs(i) = (1./(dt*b_coeff(i)) - alfa_explicit*(vd*dryrho(i)+a2))*phi(i) + & - alfa_explicit*(a2*phi(i+1)) - lhs1(i) = 0. - lhs2(i) = 1./(dt*b_coeff(i)) + beta_implicit*(vd*dryrho(i)+a2) - lhs3(i) = -beta_implicit*a2 - - DO i = kts+1, ktem1-1 - a1 = a_coeff(i)*k_turb(i) - a2 = a_coeff(i+1)*k_turb(i+1) - - rhs(i) = (1./(dt*b_coeff(i)) - alfa_explicit*(a1+a2))*phi(i) + & - alfa_explicit*(a1*phi(i-1) + a2*phi(i+1)) - - lhs1(i) = -beta_implicit*a1 - lhs2(i) = 1./(dt*b_coeff(i)) + beta_implicit*(a1+a2) - lhs3(i) = -beta_implicit*a2 - END DO - - i = ktem1 - a1 = a_coeff(i)*k_turb(i) - rhs(i) = (1./(dt*b_coeff(i)) - alfa_explicit*(a1 ))*phi(i) + & - alfa_explicit*(a1*phi(i-1)) - lhs1(i) = -beta_implicit*a1 - lhs2(i) = 1./(dt*b_coeff(i)) + beta_implicit*(a1 ) - lhs3(i) = 0. - - END SUBROUTINE rlhside - - -!----------------------------------------------------------------------- - SUBROUTINE tridiag( data, kts, ktem1, a, b, c, f ) - !! to solve system of linear eqs on tridiagonal matrix n times n - !! after Peaceman and Rachford, 1955 - !! a,b,c,F - are vectors of order n - !! a,b,c - are coefficients on the LHS - !! F - is initially RHS on the output becomes a solution vector - !! Mariusz Pagowski, March 2001 - !! conventions used: - !! input is lower case - !! output is upper case - IMPLICIT NONE - type(smoke_data), intent(inout) :: data - -! .. Scalar Arguments .. - INTEGER, INTENT(IN) :: kts,ktem1 -! .. -! .. Array Arguments .. - REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts:ktem1) :: a, b, c - REAL(KIND=KIND_PHYS), INTENT(INOUT), DIMENSION (kts:ktem1) :: f -! .. -! .. Local Scalars .. - REAL(KIND_PHYS) :: p - INTEGER :: i -! .. -! .. Local Arrays .. - REAL(KIND=KIND_PHYS), DIMENSION (kts:ktem1) :: q -! .. - q(kts) = -c(kts)/b(kts) - f(kts) = f(kts)/b(kts) - - DO i = kts+1, ktem1 - p = 1./(b(i)+a(i)*q(i-1)) - q(i) = -c(i)*p - f(i) = (f(i)-a(i)*f(i-1))*p - END DO - - DO i = ktem1 - 1, kts, -1 - f(i) = f(i) + q(i)*f(i+1) - END DO - - END SUBROUTINE tridiag - - -!----------------------------------------------------------------------- - SUBROUTINE coeffs( data, kts, ktem1, dryrho, & - z_sigma, z_sigma_half, a_coeff, b_coeff ) -! !! to calculate coefficients in diffusion equation -! !! Mariusz Pagowski, March 2001 -! !! conventions used: -! !! input is lower case -! !! output is upper case -! .. Scalar Arguments .. - IMPLICIT NONE - type(smoke_data), intent(inout) :: data - - INTEGER, INTENT(IN) :: kts,ktem1 -! .. -! .. Array Arguments .. - REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts:ktem1+1) :: z_sigma - REAL(KIND=KIND_PHYS), INTENT(IN), DIMENSION (kts:ktem1) :: z_sigma_half, dryrho - REAL(KIND=KIND_PHYS), INTENT(OUT), DIMENSION (kts+1:ktem1) :: a_coeff - REAL(KIND=KIND_PHYS), INTENT(OUT), DIMENSION (kts:ktem1) :: b_coeff -! .. -! .. Local Scalars .. - INTEGER :: i - REAL(KIND=KIND_PHYS) :: dryrho_at_w -! .. - DO i = kts, ktem1 - b_coeff(i) = 1./(dryrho(i)*(z_sigma(i+1)-z_sigma(i))) - END DO - - DO i = kts+1, ktem1 - dryrho_at_w = 0.5*(dryrho(i)+dryrho(i-1)) - a_coeff(i) = dryrho_at_w/(z_sigma_half(i)-z_sigma_half(i-1)) - END DO - - END SUBROUTINE coeffs - -!----------------------------------------------------------------------- -END MODULE dep_vertmx_mod diff --git a/smoke/dep_wet_ls_mod.F90 b/smoke/dep_wet_ls_mod.F90 deleted file mode 100755 index 3a7a186ea..000000000 --- a/smoke/dep_wet_ls_mod.F90 +++ /dev/null @@ -1,562 +0,0 @@ -!>\file dep_wet_ls_mod.F90 -!! This file contains aerosol wet deposition module. - -module dep_wet_ls_mod - use rrfs_smoke_data - use machine , only : kind_phys - use rrfs_smoke_config -! use chem_tracers_mod -! use chem_rc_mod -! use chem_tracers_mod -! use chem_const_mod, only : grav => grvity - - implicit none - - ! -- large scale wet deposition scavenging factors - - private - - public :: dep_wet_ls_init - public :: wetdep_ls - public :: WetRemovalGOCART - -contains - -! subroutine dep_wet_ls_init(config, rc) - subroutine dep_wet_ls_init(data) - implicit none - type(smoke_data), intent(inout) :: data - - ! -- I/O arguments -! type(chem_config_type), intent(in) :: config -! integer, intent(out) :: rc - - ! -- local variables - integer :: ios, n - - ! -- begin - !rc = CHEM_RC_SUCCESS - - ! -- set aerosol wet scavenging coefficients - if (associated(data%alpha)) then - deallocate(data%alpha, stat=ios) - !if (chem_rc_test((ios /= 0), msg="Failed to deallocate memory", & - ! file=__FILE__, line=__LINE__, rc=rc)) return - end if - - allocate(data%alpha(num_chem), stat=ios) - !if (chem_rc_test((ios /= 0), msg="Failed to allocate memory", & - ! file=__FILE__, line=__LINE__, rc=rc)) return - - data%alpha = 0. - - select case (wetdep_ls_opt) - case (WDLS_OPT_GSD) - - select case (chem_opt) - case (CHEM_OPT_GOCART) - data%alpha = 1.0 - end select - - case (WDLS_OPT_NGAC) - - select case (chem_opt) - case (CHEM_OPT_GOCART) - data%alpha(p_so2 ) = 0. - data%alpha(p_sulf ) = 1.5 - data%alpha(p_dms ) = 0. - data%alpha(p_msa ) = 0. - data%alpha(p_p25 ) = 1. - data%alpha(p_bc1 ) = 0.7 - data%alpha(p_bc2 ) = 0.7 - data%alpha(p_oc1 ) = 1. - data%alpha(p_oc2 ) = 1. - data%alpha(p_dust_1) = 1. - data%alpha(p_dust_2) = 1. - data%alpha(p_dust_3) = 1. - data%alpha(p_dust_4) = 1. - data%alpha(p_dust_5) = 1. - data%alpha(p_seas_1) = 1. - data%alpha(p_seas_2) = 1. - data%alpha(p_seas_3) = 1. - data%alpha(p_seas_4) = 1. - data%alpha(p_seas_5) = 1. - data%alpha(p_p10 ) = 1. - case default - ! -- NGAC large scale wet deposition only works with GOCART - end select - - case default - end select - - ! -- replace first default wet scavenging coefficients with input values if - ! available - if (any(wetdep_ls_alpha > 0._kind_phys)) then - n = min(size(data%alpha), size(wetdep_ls_alpha)) - data%alpha(1:n) = real(wetdep_ls_alpha(1:n)) - end if - - end subroutine dep_wet_ls_init - - - - subroutine wetdep_ls(data,dt,var,rain,moist,rho,var_rmv, & - num_moist,num_chem,p_qc,p_qi,dz8w,vvel, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - IMPLICIT NONE - type(smoke_data), intent(inout) :: data - - INTEGER, INTENT(IN ) :: num_chem,num_moist,p_qc, p_qi, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - real(kind_phys), INTENT(IN ) :: dt - REAL(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & - INTENT(IN ) :: moist - REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(IN ) :: rho,dz8w,vvel - REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ,1:num_chem), & - INTENT(INOUT) :: var - REAL(kind_phys), DIMENSION( ims:ime, jms:jme ), & - INTENT(IN ) :: rain - REAL(kind_phys), DIMENSION( ims:ime , jms:jme,num_chem ), & - INTENT(INOUT ) :: var_rmv - REAL(kind_phys), DIMENSION( its:ite , jts:jte ) :: var_sum - REAL(kind_phys), DIMENSION( its:ite , kts:kte, jts:jte ) :: var_rmvl - REAL(kind_phys), DIMENSION( its:ite , jts:jte ) :: frc,var_sum_clw,rain_clw - real(kind_phys) :: dvar,factor,rho_water - integer :: nv,i,j,k - - rho_water = 1000. - var_rmv (:,:,:)=0. - - do nv=1,num_chem -! -! simple LS removal -! - -! -! proportionality constant -! - frc(:,:)=0.1 - do i=its,ite - do j=jts,jte - var_sum_clw(i,j)=0. - var_sum(i,j)=0. - var_rmvl(i,:,j)=0. - rain_clw(i,j)=0. - if(rain(i,j).gt.1.e-6)then -! convert rain back to rate -! - rain_clw(i,j)=rain(i,j)/dt -! total cloud water -! - do k=1,kte - dvar=max(0.,(moist(i,k,j,p_qc)+moist(i,k,j,p_qi))) - var_sum_clw(i,j)=var_sum_clw(i,j)+dvar - enddo - endif - enddo - enddo -! -! get rid of it -! - do i=its,ite - do j=jts,jte - if(rain(i,j).gt.1.e-6 .and. var_sum_clw(i,j).gt.1.e-10 ) then - do k=kts,kte - if(var(i,k,j,nv).gt.1.e-08 .and. (moist(i,k,j,p_qc)+moist(i,k,j,p_qi)).gt.1.e-8)then - factor = max(0.,frc(i,j)*rho(i,k,j)*dz8w(i,k,j)*vvel(i,k,j)) - dvar=max(0.,data%alpha(nv)*factor/(1+factor)*var(i,k,j,nv)) - dvar=min(dvar,var(i,k,j,nv)) - var_rmvl(i,k,j)=dvar - if((var(i,k,j,nv)-dvar).lt.1.e-16)then - dvar=var(i,k,j,nv)-1.e-16 - var_rmvl(i,k,j)=dvar !lzhang - var(i,k,j,nv)=var(i,k,j,nv)-dvar - else - var(i,k,j,nv)=var(i,k,j,nv)-dvar - endif - !var_rmv(i,j,nv)=var_rmv(i,j,nv)+var_rmvl(i,k,j) - !!convert wetdeposition into ug/m2/s - var_rmv(i,j,nv)=var_rmv(i,j,nv)+(var_rmvl(i,k,j)*rho(i,k,j)*dz8w(i,k,j)/dt) !lzhang - endif - enddo - var_rmv(i,j,nv)=max(0.,var_rmv(i,j,nv)) - endif - enddo - enddo - enddo - - end subroutine wetdep_ls - -!------------------------------------------------------------------------- -! NASA/GSFC, Global Modeling and Assimilation Office, Code 900.3 ! -!------------------------------------------------------------------------- -!BOP -! -! !IROUTINE: WetRemovalGOCART - Calculate aerosol wet removal due -! to large scale processes. -! -! !INTERFACE: -! - - subroutine WetRemovalGOCART ( data,i1, i2, j1, j2, k1, k2, n1, n2, cdt, & - num_chem, var_rmv, chem, ple, tmpu, & - rhoa, dqcond, precc, precl, grav, & - ims, ime, jms, jme, kms, kme) -! ims, ime, jms, jme, kms, kme, rc ) - -! !USES: - IMPLICIT NONE - type(smoke_data), intent(inout) :: data - -! !INPUT PARAMETERS: - integer, intent(in) :: i1, i2, j1, j2, k1, k2, n1, n2, num_chem, & - ims, ime, jms, jme, kms, kme - real(kind_phys), intent(in) :: cdt, grav - REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ,1:num_chem),& - INTENT(INOUT) :: chem - REAL(kind_phys), DIMENSION( ims:ime , jms:jme,num_chem ), & - INTENT(INOUT ) :: var_rmv !! tracer loss flux [kg m-2 s-1] - real(kind_phys), dimension(ims:ime, kms:kme, jms:jme),& - INTENT(IN) :: ple, tmpu, rhoa, dqcond - real(kind_phys), dimension(ims:ime , jms:jme) , & - INTENT(IN) :: precc, precl ! cv, ls precip [mm day-1] - -! !OUTPUT PARAMETERS: -! integer, intent(out) :: rc ! Error return code: - ! 0 - all is well - ! 1 - - -! !DESCRIPTION: Calculates the updated species concentration due to wet -! removal. As written, intended to function for large -! scale (not convective) wet removal processes - -! -! !REVISION HISTORY: -! -! 08Jan2010 - Colarco, based on GOCART implementation, does not -! include any size dependent term -! -!EOP -!------------------------------------------------------------------------- - -! !Local Variables - character(len=*), parameter :: myname = 'WetRemovalGOCART' - integer :: i, j, k, n, nbins, LH, kk, ios,nv - real(kind_phys) :: pdog(i1:i2,k1:k2,j1:j2) ! air mass factor dp/g [kg m-2] - real(kind_phys) :: pls, pcv, pac ! ls, cv, tot precip [mm day-1] - real(kind_phys) :: qls(k1:k2), qcv(k1:k2) ! ls, cv portion dqcond [kg m-3 s-1] - real(kind_phys) :: qmx, qd, A ! temporary variables on moisture - real(kind_phys) :: F, B, BT ! temporary variables on cloud, freq. - real(kind_phys), allocatable :: fd(:,:) ! flux across layers [kg m-2] - real(kind_phys), allocatable :: DC(:) ! scavenge change in mass mixing ratio -! Rain parameters from Liu et al. - real(kind_phys), parameter :: B0_ls = 1.0e-4 - real(kind_phys), parameter :: F0_ls = 1.0 - real(kind_phys), parameter :: XL_ls = 5.0e-4 - real(kind_phys), parameter :: B0_cv = 1.5e-3 - real(kind_phys), parameter :: F0_cv = 0.3 - real(kind_phys), parameter :: XL_cv = 2.0e-3 -! Duration of rain: ls = model timestep, cv = 1800 s (<= cdt) - real(kind_phys) :: Td_ls - real(kind_phys) :: Td_cv - - -! Efficiency of dust wet removal (since dust is really not too hygroscopic) -! Applied only to in-cloud scavenging - real(kind_phys) :: effRemoval -! real(kind_phys),dimension(20) ::fwet -! tracer: p_so2=1 p_sulf=2 p_dms=3 p_msa=4 p_p25=5 p_bc1=6 p_bc2=7 p_oc1=8 -! p_oc2=9 p_dust_1=10 p_dust_2=11 p_dust_3=12 p_dust_4=13 p_dust_5=14 -! p_seas_1=15 p_seas_2=16 p_seas_3=17 p_seas_4=18 p_seas_5=19 p_p10 =20 -! data fwet /0.,1.5,0.,0.,1.,0.7,0.7,0.4,0.4,1.,1.,1.,1.,1.,1.,1.,1.,1.,1.,1./ -! rc=0. - -! Initialize local variables -! -------------------------- -! rc = CHEM_RC_SUCCESS - - Td_ls = cdt - Td_cv = cdt - nbins = n2-n1+1 - var_rmv = 0.0 - -! Allocate the dynamic arrays - allocate(fd(k1:k2,nbins),stat=ios) -! if (chem_rc_test((ios .ne. 0), msg="Failed to allocate memory", & -! file=__FILE__, line=__LINE__, rc=rc)) return - allocate(dc(nbins),stat=ios) -! if (chem_rc_test((ios .ne. 0), msg="Failed to allocate memory", & -! file=__FILE__, line=__LINE__, rc=rc)) return - -! Accumulate the 3-dimensional arrays of rhoa and pdog - do j = j1, j2 - do i = i1, i2 - !pdog(i,k1:k2,j) = (ple(i,k1+1:k2+1,j)-ple(i,k1:k2,j)) / grav - pdog(i,k1:k2,j) = (ple(i,k1:k2,j)-ple(i,k1+1:k2+1,j)) / grav !lzhang - enddo - enddo - - do nv=1, num_chem -! Loop over spatial indices - do j = j1, j2 - big_i_loop: do i = i1, i2 - -! Check for total precipitation amount -! Assume no precip in column if precl+precc = 0 - pac = precl(i,j) + precc(i,j) - if(pac .le. 0.) cycle big_i_loop - pls = precl(i,j) - pcv = precc(i,j) - -! Initialize the precipitation fields - qls(:) = 0. - qcv(:) = 0. - fd(:,:) = 0. - -! Find the highest model layer experiencing rainout. Assumes no -! scavenging if T < 258 K - !LH = 0 - LH = k2+1 !lzhang - !do k = k1, k2 - do k = k2, k1,-1 !lzhang - if(dqcond(i,k,j) .lt. 0. .and. tmpu(i,k,j) .gt. 258.) then - LH = k - exit - endif - end do - if(LH .gt. k2) cycle big_i_loop !lzhang - -! convert dqcond from kg water/kg air/s to kg water/m3/s and reverse -! sign so that dqcond < 0. (positive precip) means qls and qcv > 0. - !do k = LH, k2 - do k = LH, k1, -1 !lzhang - qls(k) = -dqcond(i,k,j)*pls/pac*rhoa(i,k,j) - qcv(k) = -dqcond(i,k,j)*pcv/pac*rhoa(i,k,j) - end do - -! Loop over vertical to do the scavenging! - !do k = LH, k2 - do k = LH, k1, -1 !lzhang - -!----------------------------------------------------------------------------- -! (1) LARGE-SCALE RAINOUT: -! Tracer loss by rainout = TC0 * F * exp(-B*dt) -! where B = precipitation frequency, -! F = fraction of grid box covered by precipitating clouds. -! We assume that tracer scavenged by rain is falling down to the -! next level, where a fraction could be re-evaporated to gas phase -! if Qls is less then 0 in that level. -!----------------------------------------------------------------------------- - if (qls(k) .gt. 0.) then - F = F0_ls / (1. + F0_ls*B0_ls*XL_ls/(qls(k)*cdt/Td_ls)) - B = B0_ls/F0_ls +1./(F0_ls*XL_ls/qls(k)) - BT = B * Td_ls - if (BT.gt.10.) BT = 10. !< Avoid overflow > -! Adjust du level: - do n = 1, nbins - effRemoval = data%alpha(nv) - DC(n) = chem(i,k,j,nv) * F * effRemoval *(1.-exp(-BT)) - if (DC(n).lt.0.) DC(n) = 0. - chem(i,k,j,nv) = chem(i,k,j,nv)-DC(n) - if (chem(i,k,j,nv) .lt. 1.0E-32) chem(i,k,j,nv) = 1.0E-32 - end do -! Flux down: unit is kg m-2 -! Formulated in terms of production in the layer. In the revaporation step -! we consider possibly adding flux from above... - do n = 1, nbins - Fd(k,n) = DC(n)*pdog(i,k,j) - end do - - end if ! if Qls > 0 >>> - -!----------------------------------------------------------------------------- -! * (2) LARGE-SCALE WASHOUT: -! * Occurs when rain at this level is less than above. -!----------------------------------------------------------------------------- - !if(k .gt. LH .and. qls(k) .ge. 0.) then - if(k .lt. LH .and. qls(k) .ge. 0.) then !lzhang - !if(qls(k) .lt. qls(k-1)) then - if(qls(k) .lt. qls(k+1)) then !lzhang -! Find a maximum F overhead until the level where Qls<0. - Qmx = 0. - !do kk = k-1,LH,-1 - do kk = k+1,LH !lzhang - if (Qls(kk).gt.0.) then - Qmx = max(Qmx,Qls(kk)) - else - exit - end if - end do - - F = F0_ls / (1. + F0_ls*B0_ls*XL_ls/(Qmx*cdt/Td_ls)) - if (F.lt.0.01) F = 0.01 -!----------------------------------------------------------------------------- -! The following is to convert Q(k) from kgH2O/m3/sec to mm/sec in order -! to use the Harvard formula. Convert back to mixing ratio by multiplying -! by rhoa. Multiply by pdog gives kg/m2/s of precip. Divide by density -! of water (=1000 kg/m3) gives m/s of precip and multiply by 1000 gives -! units of mm/s (omit the multiply and divide by 1000). -!----------------------------------------------------------------------------- - - Qd = Qmx /rhoa(i,k,j)*pdog(i,k,j) - if (Qd.ge.50.) then - B = 0. - else - B = Qd * 0.1 - end if - BT = B * cdt - if (BT.gt.10.) BT = 10. - -! Adjust du level: - do n = 1, nbins - DC(n) = chem(i,k,j,nv) * F * (1.-exp(-BT)) - if (DC(n).lt.0.) DC(n) = 0. - chem(i,k,j,nv) = chem(i,k,j,nv)-DC(n) - if (chem(i,k,j,nv) .lt. 1.0E-32) & - chem(i,k,j,nv) = 1.0E-32 - var_rmv(i,j,nv) = var_rmv(i,j,nv)+DC(n)*pdog(i,k,j)/cdt !ug/m2/s - end do - - end if - end if ! if ls washout >>> -#if 0 -!----------------------------------------------------------------------------- -! (3) CONVECTIVE RAINOUT: -! Tracer loss by rainout = dd0 * F * exp(-B*dt) -! where B = precipitation frequency, -! F = fraction of grid box covered by precipitating clouds. -!----------------------------------------------------------------------------- - - if (qcv(k) .gt. 0.) then - F = F0_cv / (1. + F0_cv*B0_cv*XL_cv/(Qcv(k)*cdt/Td_cv)) - B = B0_cv - BT = B * Td_cv - if (BT.gt.10.) BT = 10. !< Avoid overflow > - -! Adjust du level: - do n = 1, nbins - effRemoval = data%alpha(nv) - DC(n) = chem(i,k,j,nv) * F * effRemoval * (1.-exp(-BT)) - if (DC(n).lt.0.) DC(n) = 0. - chem(i,k,j,nv) = chem(i,k,j,nv)-DC(n) - if (chem(i,k,j,nv) .lt. 1.0E-32) chem(i,k,j,nv) = 1.0E-32 - end do - -!------ Flux down: unit is kg. Including both ls and cv. - do n = 1, nbins - Fd(k,n) = Fd(k,n) + DC(n)*pdog(i,k,j) - end do - - end if ! if Qcv > 0 >>> - -!----------------------------------------------------------------------------- -! (4) CONVECTIVE WASHOUT: -! Occurs when rain at this level is less than above. -!----------------------------------------------------------------------------- - - !if (k.gt.LH .and. Qcv(k).ge.0.) then - if (k.lt.LH .and. Qcv(k).ge.0.) then !lzhang - !if (Qcv(k).lt.Qcv(k-1)) then - if (Qcv(k).lt.Qcv(k+1)) then !lzhang -!----- Find a maximum F overhead until the level where Qls<0. - Qmx = 0. - !do kk = k-1, LH, -1 - do kk = k+1, LH !lzhang - if (Qcv(kk).gt.0.) then - Qmx = max(Qmx,Qcv(kk)) - else - exit - end if - end do - - F = F0_cv / (1. + F0_cv*B0_cv*XL_cv/(Qmx*cdt/Td_cv)) - if (F.lt.0.01) F = 0.01 -!----------------------------------------------------------------------------- -! The following is to convert Q(k) from kgH2O/m3/sec to mm/sec in order -! to use the Harvard formula. Convert back to mixing ratio by multiplying -! by rhoa. Multiply by pdog gives kg/m2/s of precip. Divide by density -! of water (=1000 kg/m3) gives m/s of precip and multiply by 1000 gives -! units of mm/s (omit the multiply and divide by 1000). -!----------------------------------------------------------------------------- - - Qd = Qmx / rhoa(i,k,j)*pdog(i,k,j) - if (Qd.ge.50.) then - B = 0. - else - B = Qd * 0.1 - end if - BT = B * cdt - if (BT.gt.10.) BT = 10. - -! Adjust du level: - do n = 1, nbins - DC(n) = chem(i,k,j,nv) * F * (1.-exp(-BT)) - if (DC(n).lt.0.) DC(n) = 0. - chem(i,k,j,nv) = chem(i,k,j,nv)-DC(n) - if (chem(i,k,j,nv) .lt. 1.0E-32) & - chem(i,k,j,nv) = 1.0E-32 - var_rmv(i,j,nv) = var_rmv(i,j,nv)+DC(n)*pdog(i,k,j)/cdt !ug/m2/s - end do - - end if - end if ! if cv washout >>> -#endif -!----------------------------------------------------------------------------- -! (5) RE-EVAPORATION. Assume that SO2 is re-evaporated as SO4 since it -! has been oxidized by H2O2 at the level above. -!----------------------------------------------------------------------------- -! Add in the flux from above, which will be subtracted if reevaporation occurs - !if(k .gt. LH) then - if(k .lt. LH) then !lzhang - do n = 1, nbins - !Fd(k,n) = Fd(k,n) + Fd(k-1,n) - Fd(k,n) = Fd(k,n) + Fd(k+1,n) !lzhang - end do - -! Is there evaporation in the currect layer? - if (-dqcond(i,k,j) .lt. 0.) then -! Fraction evaporated = H2O(k)evap / H2O(next condensation level). - !if (-dqcond(i,k-1,j) .gt. 0.) then - if (-dqcond(i,k+1,j) .gt. 0.) then !lzhang - - A = abs( dqcond(i,k,j) * pdog(i,k,j) & - !/ ( dqcond(i,k-1,j) * pdog(i,k-1,j)) ) - / ( dqcond(i,k+1,j) * pdog(i,k+1,j)) ) !lzhang - if (A .gt. 1.) A = 1. - -! Adjust tracer in the level - do n = 1, nbins - !DC(n) = Fd(k-1,n) / pdog(i,k,j) * A - DC(n) = Fd(k+1,n) / pdog(i,k,j) * A !lzhang - chem(i,k,j,nv) = chem(i,k,j,nv) + DC(n) - chem(i,k,j,nv) = max(chem(i,k,j,nv),1.e-32) -! Adjust the flux out of the bottom of the layer - Fd(k,n) = Fd(k,n) - DC(n)*pdog(i,k,j) - end do - - endif - endif ! if -moistq < 0 - endif - end do ! k - - do n = 1, nbins - !var_rmv(i,j,nv) = var_rmv(i,j,nv)+Fd(k2,n)/cdt !lzhang - var_rmv(i,j,nv) = var_rmv(i,j,nv)+Fd(k1,n)/cdt ! ug/m2/s - end do - - end do big_i_loop ! i - end do ! j - end do !nv for num_chem - - deallocate(fd,DC,stat=ios) -! if (chem_rc_test((ios .ne. 0), msg="Failed to deallocate memory", & -! file=__FILE__, line=__LINE__, rc=rc)) return - - end subroutine WetRemovalGOCART - -end module dep_wet_ls_mod diff --git a/smoke/dust_fengsha_mod.F90 b/smoke/dust_fengsha_mod.F90 deleted file mode 100755 index fbf87aa56..000000000 --- a/smoke/dust_fengsha_mod.F90 +++ /dev/null @@ -1,601 +0,0 @@ -!>\file dust_fengsha_mod.F90 -!! This file contains the FENGSHA dust scheme. - -module dust_fengsha_mod -! -! This module developed by Barry Baker (NOAA ARL) -! For serious questions contact barry.baker@noaa.gov -! -! 07/16/2019 - Adapted for NUOPC/GOCART, R. Montuoro -! 02/01/2020 - Adapted for FV3/CCPP, Haiqin Li - - use rrfs_smoke_data - use machine , only : kind_phys - use dust_data_mod - - implicit none - - private - - public :: gocart_dust_fengsha_driver - -contains - - subroutine gocart_dust_fengsha_driver(data, dt, & - chem,rho_phy,smois,p8w,ssm, & - isltyp,vegfra,snowh,xland,area,g,emis_dust, & - ust,znt,clay,sand,rdrag,uthr, & - num_emis_dust,num_moist,num_chem,num_soil_layers, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) - IMPLICIT NONE - type(smoke_data), intent(inout) :: data - INTEGER, INTENT(IN ) :: & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte, & - num_emis_dust,num_moist,num_chem,num_soil_layers - INTEGER,DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: isltyp - REAL(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), INTENT(INOUT) :: chem - REAL(kind_phys), DIMENSION( ims:ime, 1, jms:jme,num_emis_dust),OPTIONAL, INTENT(INOUT) :: emis_dust - REAL(kind_phys), DIMENSION( ims:ime, num_soil_layers, jms:jme ), INTENT(IN) :: smois - REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: ssm - REAL(kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: vegfra, & - snowh, & - xland, & - area, & - ust, & - znt, & - clay, & - sand, & - rdrag, & - uthr - REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: & - p8w, & - rho_phy - REAL(kind_phys), INTENT(IN) :: dt,g - - ! Local variables - - integer :: nmx,smx,i,j,k,imx,jmx,lmx - integer,dimension (1,1) :: ilwi - real(kind_phys), DIMENSION (1,1) :: erodtot - REAL(kind_phys), DIMENSION (1,1) :: gravsm - REAL(kind_phys), DIMENSION (1,1) :: drylimit - real(kind_phys), DIMENSION (5) :: tc,bems - real(kind_phys), dimension (1,1) :: airden,airmas,ustar - real(kind_phys), dimension (1) :: dxy - real(kind_phys), dimension (3) :: massfrac - real(kind_phys) :: conver,converi - real(kind_phys) :: R - - ! threshold values - conver=1.e-9 - converi=1.e9 - - ! Number of dust bins - - imx=1 - jmx=1 - lmx=1 - nmx=ndust - smx=nsalt - - k=kts - do j=jts,jte - do i=its,ite - - ! Don't do dust over water!!! - - ilwi(1,1)=0 - if(xland(i,j).lt.1.5)then - ilwi(1,1)=1 - - ! Total concentration at lowest model level. This is still hardcoded for 5 bins. - - ! if(config_flags%chem_opt == 2 .or. config_flags%chem_opt == 11 ) then - ! tc(:)=1.e-16*conver - ! else - tc(1)=chem(i,kts,j,p_dust_1)*conver - tc(2)=chem(i,kts,j,p_dust_2)*conver - tc(3)=chem(i,kts,j,p_dust_3)*conver - tc(4)=chem(i,kts,j,p_dust_4)*conver - tc(5)=chem(i,kts,j,p_dust_5)*conver - ! endif - - ! Air mass and density at lowest model level. - - airmas(1,1)=-(p8w(i,kts+1,j)-p8w(i,kts,j))*area(i,j)/g - airden(1,1)=rho_phy(i,kts,j) - ustar(1,1)=ust(i,j) - dxy(1)=area(i,j) - - ! Mass fractions of clay, silt, and sand. - massfrac(1)=clay(i,j) - massfrac(2)=1-(clay(i,j)+sand(i,j)) - massfrac(3)=sand(i,j) - - - ! Total erodibility. - - erodtot(1,1) = ssm(i,j) ! SUM(erod(i,j,:)) - - ! Don't allow roughness lengths greater than 20 cm to be lofted. - ! This kludge accounts for land use types like urban areas and - ! forests which would otherwise show up as high dust emitters. - ! This is a placeholder for a more widely accepted kludge - ! factor in the literature, which reduces lofting for rough areas. - ! Forthcoming... - - IF (znt(i,j) .gt. 0.2) then - ilwi(1,1)=0 - endif - - ! limit where there is lots of vegetation - if (vegfra(i,j) .gt. .17) then - ilwi(1,1) = 0 - endif - - ! limit where there is snow on the ground - if (snowh(i,j) .gt. 0) then - ilwi(1,1) = 0 - endif - - ! Do not allow areas with bedrock, lava, or land-ice to loft - - IF (isltyp(i,j) .eq. 15 .or. isltyp(i,j) .eq. 16. .or. & - isltyp(i,j) .eq. 18) then - ilwi(1,1)=0 - ENDIF - IF (isltyp(i,j) .eq. 0)then - ilwi(1,1)=0 - endif - if(ilwi(1,1) == 0 ) cycle - - ! Calculate gravimetric soil moisture and drylimit. - gravsm(1,1)=100.*smois(i,1,j)/((1.-maxsmc(isltyp(i,j)))*(2.65*(1.-clay(i,j))+2.50*clay(i,j))) - drylimit(1,1)=14.0*clay(i,j)*clay(i,j)+17.0*clay(i,j) - - ! get drag partition - ! FENGSHA uses the drag partition correction of MacKinnon et al 2004 - ! doi:10.1016/j.geomorph.2004.03.009 - if (dust_calcdrag .ne. 1) then - call fengsha_drag(data,znt(i,j),R) - else - ! use the precalculated version derived from ASCAT; Prigent et al. (2012,2015) - ! doi:10.1109/TGRS.2014.2338913 & doi:10.5194/amt-5-2703-2012 - ! pick only valid values - if (rdrag(i,j) > 0.) then - R = real(rdrag(i,j), kind=kind_phys) - else - cycle - endif - endif - - ! Call dust emission routine. - call source_dust(data, imx, jmx, lmx, nmx, smx, dt, tc, ustar, massfrac, & - erodtot, dxy, gravsm, airden, airmas, & - bems, g, drylimit, dust_alpha, dust_gamma, R, uthr(i,j)) - - ! if(config_flags%chem_opt == 2 .or. config_flags%chem_opt == 11 ) then - ! dustin(i,j,1:5)=tc(1:5)*converi - ! else - chem(i,kts,j,p_dust_1)=tc(1)*converi - chem(i,kts,j,p_dust_2)=tc(2)*converi - chem(i,kts,j,p_dust_3)=tc(3)*converi - chem(i,kts,j,p_dust_4)=tc(4)*converi - chem(i,kts,j,p_dust_5)=tc(5)*converi - ! endif - - ! chem(i,kts,j,p_dust_1)=tc(1)*converi - ! chem(i,kts,j,p_dust_2)=tc(2)*converi - ! chem(i,kts,j,p_dust_3)=tc(3)*converi - ! chem(i,kts,j,p_dust_4)=tc(4)*converi - ! chem(i,kts,j,p_dust_5)=tc(5)*converi - - ! For output diagnostics - - emis_dust(i,1,j,p_edust1)=bems(1) - emis_dust(i,1,j,p_edust2)=bems(2) - emis_dust(i,1,j,p_edust3)=bems(3) - emis_dust(i,1,j,p_edust4)=bems(4) - emis_dust(i,1,j,p_edust5)=bems(5) - endif - enddo - enddo - ! - - end subroutine gocart_dust_fengsha_driver - - - SUBROUTINE source_dust(data, imx, jmx, lmx, nmx, smx, dt1, tc, ustar, massfrac, & - erod, dxy, gravsm, airden, airmas, bems, g0, drylimit, alpha, & - gamma, R, uthres) - - ! **************************************************************************** - ! * Evaluate the source of each dust particles size bin by soil emission - ! * - ! * Input: - ! * EROD Fraction of erodible grid cell (-) - ! * GRAVSM Gravimetric soil moisture (g/g) - ! * DRYLIMIT Upper GRAVSM limit for air-dry soil (g/g) - ! * ALPHA Constant to fudge the total emission of dust (1/m) - ! * GAMMA Tuning constant for erodibility (-) - ! * DXY Surface of each grid cell (m2) - ! * AIRMAS Mass of air for each grid box (kg) - ! * AIRDEN Density of air for each grid box (kg/m3) - ! * USTAR Friction velocity (m/s) - ! * DT1 Time step (s) - ! * NMX Number of dust bins (-) - ! * SMX Number of saltation bins (-) - ! * IMX Number of I points (-) - ! * JMX Number of J points (-) - ! * LMX Number of L points (-) - ! * R Drag Partition (-) - ! * UTHRES FENGSHA Dry Threshold Velocities (m/s) - ! * - ! * Data: - ! * MASSFRAC Fraction of mass in each of 3 soil classes (-) - ! * SPOINT Pointer to 3 soil classes (-) - ! * DEN_DUST Dust density (kg/m3) - ! * DEN_SALT Saltation particle density (kg/m3) - ! * REFF_SALT Reference saltation particle diameter (m) - ! * REFF_DUST Reference dust particle diameter (m) - ! * LO_DUST Lower diameter limits for dust bins (m) - ! * UP_DUST Upper diameter limits for dust bins (m) - ! * FRAC_SALT Soil class mass fraction for saltation bins (-) - ! * - ! * Parameters: - ! * CMB Constant of proportionality (-) - ! * MMD_DUST Mass median diameter of dust (m) - ! * GSD_DUST Geometric standard deviation of dust (-) - ! * LAMBDA Side crack propagation length (m) - ! * CV Normalization constant (-) - ! * G0 Gravitational acceleration (m/s2) - ! * G Gravitational acceleration in cgs (cm/s2) - ! * - ! * Working: - ! * U_TS0 "Dry" threshold friction velocity (m/s) - ! * U_TS Moisture-adjusted threshold friction velocity (m/s) - ! * RHOA Density of air in cgs (g/cm3) - ! * DEN Dust density in cgs (g/cm3) - ! * DIAM Dust diameter in cgs (cm) - ! * DMASS Saltation mass distribution (-) - ! * DSURFACE Saltation surface area per unit mass (m2/kg) - ! * DS_REL Saltation surface area distribution (-) - ! * SALT Saltation flux (kg/m/s) - ! * DLNDP Dust bin width (-) - ! * EMIT Total vertical mass flux (kg/m2/s) - ! * EMIT_VOL Total vertical volume flux (m/s) - ! * DSRC Mass of emitted dust (kg/timestep/cell) - ! * - ! * Output: - ! * TC Total concentration of dust (kg/kg/timestep/cell) - ! * BEMS Source of each dust type (kg/timestep/cell) - ! * - ! **************************************************************************** - implicit none - type(smoke_data), intent(inout) :: data - - INTEGER, INTENT(IN) :: imx,jmx,lmx,nmx,smx - REAL(kind_phys), INTENT(IN) :: dt1 - REAL(kind_phys), INTENT(INOUT) :: tc(imx,jmx,lmx,nmx) - REAL(kind_phys), INTENT(IN) :: ustar(imx,jmx) - REAL(kind_phys), INTENT(IN) :: massfrac(3) - REAL(kind_phys), INTENT(IN) :: erod(imx,jmx) - REAL(kind_phys), INTENT(IN) :: dxy(jmx) - REAL(kind_phys), INTENT(IN) :: gravsm(imx,jmx) - REAL(kind_phys), INTENT(IN) :: airden(imx,jmx,lmx) - REAL(kind_phys), INTENT(IN) :: airmas(imx,jmx,lmx) - REAL(kind_phys), INTENT(OUT) :: bems(imx,jmx,nmx) - REAL(kind_phys), INTENT(IN) :: g0 - REAL(kind_phys), INTENT(IN) :: drylimit(imx,jmx) - !! Sandblasting mass efficiency, aka "fudge factor" (based on Tegen et al, - !! 2006 and Hemold et al, 2007) - ! - ! REAL, PARAMETER :: alpha=1.8E-8 ! (m^-1) - REAL(kind_phys), INTENT(IN) :: alpha - ! Experimental optional exponential tuning constant for erodibility. - ! 0 < gamma < 1 -> more relative impact by low erodibility regions. - REAL(kind_phys), INTENT(IN) :: gamma - REAL(kind_phys), INTENT(IN) :: R - REAL(kind_phys), INTENT(IN) :: uthres - - REAL(kind_phys) :: den(smx), diam(smx) - REAL(kind_phys) :: dvol(nmx), distr_dust(nmx), dlndp(nmx) - REAL(kind_phys) :: dsurface(smx), ds_rel(smx) - REAL(kind_phys) :: u_ts0, u_ts, dsrc, dmass, dvol_tot - REAL(kind_phys) :: salt,emit, emit_vol, stotal - REAL(kind_phys) :: rhoa, g - INTEGER :: i, j, n - - ! Sandblasting mass efficiency, beta. - ! Beta maxes out for clay fractions above 0.2 = betamax. - - REAL(kind_phys), PARAMETER :: betamax=5.25E-4 - REAL(kind_phys) :: beta - integer :: styp - - ! Constant of proportionality from Marticorena et al, 1997 (unitless) - ! Arguably more ~consistent~ fudge than alpha, which has many walnuts - ! sprinkled throughout the literature. - GC - - REAL(kind_phys), PARAMETER :: cmb=1.0 - ! REAL, PARAMETER :: cmb=2.61 ! from White,1979 - - ! Parameters used in Kok distribution function. Advise not to play with - ! these without the expressed written consent of someone who knows what - ! they're doing. - GC - - REAL(kind_phys), PARAMETER :: mmd_dust=3.4D-6 ! median mass diameter (m) - REAL(kind_phys), PARAMETER :: gsd_dust=3.0 ! geom. std deviation - REAL(kind_phys), PARAMETER :: lambda=12.0D-6 ! crack propagation length (m) - REAL(kind_phys), PARAMETER :: cv=12.62D-6 ! normalization constant - - ! Calculate saltation surface area distribution from sand, silt, and clay - ! mass fractions and saltation bin fraction. This will later become a - ! modifier to the total saltation flux. The reasoning here is that the - ! size and availability of saltators affects saltation efficiency. Based - ! on Eqn. (32) in Marticorena & Bergametti, 1995 (hereon, MB95). - - DO n=1,smx - dmass=massfrac(spoint(n))*frac_salt(n) - dsurface(n)=0.75*dmass/(den_salt(n)*reff_salt(n)) - ENDDO - - ! The following equation yields relative surface area fraction. It will only - ! work if you are representing the "full range" of all three soil classes. - ! For this reason alone, we have incorporated particle sizes that encompass - ! the clay class, to account for the its relative area over the basal - ! surface, even though these smaller bins would be unlikely to play any large - ! role in the actual saltation process. - GC - - stotal=SUM(dsurface(:)) - DO n=1,smx - ds_rel(n)=dsurface(n)/stotal - ENDDO - - ! Calculate total dust emission due to saltation of sand sized particles. - ! Begin by calculating DRY threshold friction velocity (u_ts0). Next adjust - ! u_ts0 for moisture to get threshold friction velocity (u_ts). Then - ! calculate saltation flux (salt) where ustar has exceeded u_ts. Finally, - ! calculate total dust emission (tot_emit), taking into account erodibility. - - ! Set DRY threshold friction velocity to input value - u_ts0 = uthres - - g = g0*1.0E2 - emit=0.0 - - DO n = 1, smx - den(n) = den_salt(n)*1.0D-3 ! (g cm^-3) - diam(n) = 2.0*reff_salt(n)*1.0D2 ! (cm) - DO i = 1,imx - DO j = 1,jmx - rhoa = airden(i,j,1)*1.0D-3 ! (g cm^-3) - - ! FENGSHA uses the 13 category soil type from the USDA - ! call calc_fengsha_styp(massfrac(1),massfrac(3),massfrac(2),styp) - ! Fengsha uses threshold velocities based on dale gilletes data - ! call fengsha_utst(styp,uthres,u_ts0) - - ! Friction velocity threshold correction function based on physical - ! properties related to moisture tension. Soil moisture greater than - ! dry limit serves to increase threshold friction velocity (making - ! it more difficult to loft dust). When soil moisture has not reached - ! dry limit, treat as dry - - IF (gravsm(i,j) > drylimit(i,j)) THEN - u_ts = MAX(0.0D+0,u_ts0*(sqrt(1.0+1.21*(gravsm(i,j)-drylimit(i,j))**0.68)) / R) - ELSE - u_ts = u_ts0 / R - END IF - - ! Calculate total vertical mass flux (note beta has units of m^-1) - ! Beta acts to tone down dust in areas with so few dust-sized particles that the - ! lofting efficiency decreases. Otherwise, super sandy zones would be huge dust - ! producers, which is generally not the case. Equation derived from wind-tunnel - ! experiments (see MB95). - - beta=10**(13.6*massfrac(1)-6.0) ! (unitless) - if (massfrac(1) <= 0.2) then - beta=10**(13.4*massfrac(1)-6.0) - else - beta = 2.E-4 - endif - - !--------------------------------------------------------------------- - ! formula of Draxler & Gillette (2001) Atmos. Environ. - ! F = K A (r/g) U* ( U*^2 - Ut*^2 ) - ! - ! where: - ! F = vertical emission flux [g/m**2-s] - ! K = constant 2.0E-04 [1/m] - ! A = 0~3.5 mean = 2.8 (fudge factor) - ! U* = friction velocity [m/s] - ! Ut* = threshold friction velocity [m/s] - ! - !-------------------------------------------------------------------- - - IF (ustar(i,j) .gt. u_ts) then - call fengsha_hflux(data,ustar(i,j),u_ts,beta, salt) - salt = alpha * cmb * ds_rel(n) * airden(i,j,1) / g0 * salt * (erod(i,j)**gamma) * beta - else - salt = 0. - endif - ! EROD is taken into account above - emit = emit + salt - END DO - END DO - END DO - - ! Now that we have the total dust emission, distribute into dust bins using - ! lognormal distribution (Dr. Jasper Kok, in press), and - ! calculate total mass emitted over the grid box over the timestep. - ! - ! In calculating the Kok distribution, we assume upper and lower limits to each bin. - ! For reff_dust=(/0.73D-6,1.4D-6,2.4D-6,4.5D-6,8.0D-6/) (default), - ! lower limits were ASSUMED at lo_dust=(/0.1D-6,1.0D-6,1.8D-6,3.0D-6,6.0D-6/) - ! upper limits were ASSUMED at up_dust=(/1.0D-6,1.8D-6,3.0D-6,6.0D-6,10.0D-6/) - ! These may be changed within module_data_gocart_dust.F, but make sure it is - ! consistent with reff_dust values. These values were taken from the original - ! GOCART bin configuration. We use them here to calculate dust bin width, dlndp. - ! dVol is the volume distribution. You know...if you were wondering. GC - - dvol_tot=0. - DO n=1,nmx - dlndp(n)=LOG(up_dust(n)/lo_dust(n)) - dvol(n)=(2.0*reff_dust(n)/cv)*(1.+ERF(LOG(2.0*reff_dust(n)/mmd_dust)/(SQRT(2.)*LOG(gsd_dust))))*& - EXP(-(2.0*reff_dust(n)/lambda)**3.0)*dlndp(n) - dvol_tot=dvol_tot+dvol(n) - ! Convert mass flux to volume flux - !emit_vol=emit/den_dust(n) ! (m s^-1) - END DO - DO n=1,nmx - distr_dust(n)=dvol(n)/dvol_tot - !print *,"distr_dust(",n,")=",distr_dust(n) - END DO - - ! Now distribute total vertical emission into dust bins and update concentration. - - DO n=1,nmx - DO i=1,imx - DO j=1,jmx - ! Calculate total mass emitted - dsrc = emit*distr_dust(n)*dxy(j)*dt1 ! (kg) - IF (dsrc < 0.0) dsrc = 0.0 - - ! Update dust mixing ratio at first model level. - tc(i,j,1,n) = tc(i,j,1,n) + dsrc / airmas(i,j,1) ! (kg/kg) - ! bems(i,j,n) = dsrc ! diagnostic - !bems(i,j,n) = 1000.*dsrc/(dxy(j)*dt1) ! diagnostic (g/m2/s) - bems(i,j,n) = 1.e+9*dsrc/(dxy(j)*dt1) ! diagnostic (ug/m2/s) !lzhang - END DO - END DO - END DO - - END SUBROUTINE source_dust - - subroutine fengsha_utst(data,styp,uth, ut) - implicit none - type(smoke_data), intent(inout) :: data - - integer, intent(in) :: styp - real(kind_phys), dimension(fengsha_maxstypes), intent(in) :: uth - real(kind_phys), intent(out) :: ut - ut = uth(styp) -! real (kind_phys) :: uth(13) = & -! (/ 0.08, & ! Sand - 1 -! 0.20, & ! Loamy Sand - 2 -! 0.30, & ! Sandy Loam - 3 -! 0.30, & ! Silt Loam - 4 -! 0.35, & ! Silt - 5 -! 0.60, & ! Loam - 6 -! 0.30, & ! Sandy Clay Loam - 7 -! 0.35, & ! Silty Clay Loam - 8 -! 0.45, & ! Clay Loam - 9 -! 0.45, & ! Sandy Clay - 10 -! 0.45, & ! Silty Clay - 11 -! 0.60, & ! Clay - 12 -! 9.999 /) ! Other - 13 - return - end subroutine fengsha_utst - - subroutine calc_fengsha_styp(data, clay, sand, silt, type) - implicit none - type(smoke_data), intent(inout) :: data - - !--------------------------------------------------------------- - ! Function: calculate soil type based on USDA definition. - ! Source: USDA soil texture calculator - ! - ! Defintion of soil types: - ! - ! - ! NOAH 1 2 3 4 5 6 7 8 9 10 11 12 - ! PX 1 2 3 4 - 5 6 7 8 9 10 11 - ! Soil "Sand" "Loamy Sand" "Sandy Loam" "Silt Loam" "Silt" "Loam" "Sandy Clay Loam" "Silt Clay Loam" "Clay Loam" "Sandy Clay" "Silty Clay" "Clay" - !--------------------------------------------------------------- - REAL(kind_phys), intent(in) :: clay, sand, silt - integer, intent(out) :: type - real(kind_phys) :: cly, snd, slt - - type = 0 - - snd = sand * 100. - cly = clay * 100. - slt = silt * 100. - if (slt+1.5*cly .lt. 15) type = 1 ! snd - if (slt+1.5*cly .ge. 15 .and.slt+1.5*cly .lt. 30) type = 2 ! loamy snd - if (cly .ge. 7 .and. cly .lt. 20 .and. snd .gt. 52 .and. slt+2*cly .ge. 30) type = 3 ! sndy loam (cond 1) - if (cly .lt. 7 .and. slt .lt. 50 .and. slt+2*cly .ge. 30) type = 3 ! sndy loam (cond 2) - if (slt .ge. 50 .and. cly .ge. 12 .and.cly .lt. 27 ) type = 4 ! slt loam (cond 1) - if (slt .ge. 50 .and. slt .lt. 80 .and.cly .lt. 12) type = 4 ! slt loam (cond 2) - if (slt .ge. 80 .and. cly .lt. 12) type = 5 ! slt - if (cly .ge. 7 .and. cly .lt. 27 .and.slt .ge. 28 .and. slt .lt. 50 .and.snd .le. 52) type = 6 ! loam - if (cly .ge. 20 .and. cly .lt. 35 .and.slt .lt. 28 .and. snd .gt. 45) type = 7 ! sndy cly loam - if (cly .ge. 27 .and. cly .lt. 40 .and.snd .lt. 20) type = 8 ! slt cly loam - if (cly .ge. 27 .and. cly .lt. 40 .and.snd .ge. 20 .and. snd .le. 45) type = 9 ! cly loam - if (cly .ge. 35 .and. snd .gt. 45) type = 10 ! sndy cly - if (cly .ge. 40 .and. slt .ge. 40) type = 11 ! slty cly - if (cly .ge. 40 .and. snd .le. 45 .and.slt .lt. 40) type = 12 ! clay - return - end subroutine calc_fengsha_styp - - subroutine fengsha_drag(data,z0,R) - implicit none - type(smoke_data), intent(inout) :: data - - real(kind_phys), intent(in) :: z0 - real(kind_phys), intent(out) :: R - real(kind_phys), parameter :: z0s = 1.0e-04 !Surface roughness for ideal bare surface [m] - ! ------------------------------------------------------------------------ - ! Function: Calculates the MacKinnon et al. 2004 Drag Partition Correction - ! - ! R = 1.0 - log(z0 / z0s) / log( 0.7 * (12255./z0s) ** 0.8) - ! - !-------------------------------------------------------------------------- - ! Drag partition correction. See MacKinnon et al. (2004), - ! doi:10.1016/j.geomorph.2004.03.009 - R = 1.0 - log(z0 / z0s) / log( 0.7 * (12255./z0s) ** 0.8) - - ! Drag partition correction. See Marticorena et al. (1997), - ! doi:10.1029/96JD02964 - !R = 1.0 - log(z0 / z0s) / log( 0.7 * (10./z0s) ** 0.8) - - return - end subroutine fengsha_drag - - subroutine fengsha_hflux(data,ust,utst, kvh, salt) - !--------------------------------------------------------------------- - ! Function: Calculates the Horizontal Saltation Flux, Q, and then - ! calculates the vertical flux. - ! - ! formula of Draxler & Gillette (2001) Atmos. Environ. - ! F = K A (r/g) U* ( U*^2 - Ut*^2 ) - ! - ! where: - ! F = vertical emission flux [g/m**2-s] - ! K = constant 2.0E-04 [1/m] - ! A = 0~3.5 mean = 2.8 (fudge factor) - ! U* = friction velocity [m/s] - ! Ut* = threshold friction velocity [m/s] - ! - !-------------------------------------------------------------------- - implicit none - type(smoke_data), intent(inout) :: data - real(kind_phys), intent(in) :: ust, & ! friction velocity - utst, & ! threshold friction velocity - kvh ! vertical to horizontal mass flux ratio - - real(kind_phys), intent(out) :: salt - real(kind_phys) :: Q - Q = ust * (ust * ust - utst * utst) - salt = Q ! sdep * kvh * Q - - return - end subroutine fengsha_hflux - - -end module dust_fengsha_mod diff --git a/smoke/rrfs_smoke_data.F90 b/smoke/rrfs_smoke_data.F90 deleted file mode 100755 index cb9cc25e6..000000000 --- a/smoke/rrfs_smoke_data.F90 +++ /dev/null @@ -1,651 +0,0 @@ -!>\file rrfs_smoke_data.F90 -!! This file contains data for the RRFS-Smoke modules. - -module rrfs_smoke_data - use machine , only : kind_phys - implicit none - INTEGER, PARAMETER :: dep_seasons = 5 - INTEGER, PARAMETER :: nlu = 25 - - type wesely_pft - integer :: npft - integer :: months - INTEGER, pointer :: seasonal_wes(:,:,:,:) => NULL() - contains - final :: wesely_pft_destructor - end type wesely_pft - - interface wesely_pft - procedure :: wesely_pft_constructor - end interface wesely_pft - -!-------------------------------------------------- -! many of these parameters will depend on the RADM mechanism! -! if you change it, lets talk about it and get it done!!! -!-------------------------------------------------- - - REAL(kind_phys), parameter :: small_value = 1.e-36 - REAL(kind_phys), parameter :: large_value = 1.e36 - -!-------------------------------------------------- -! following currently hardwired to USGS -!-------------------------------------------------- - integer, parameter :: isice_temp = 24 - integer, parameter :: iswater_temp = 16 - integer, parameter :: wrf2mz_lt_map(nlu) = (/ 1, 2, 2, 2, 2, & - 4, 3, 3, 3, 3, & - 4, 5, 4, 5, 6, & - 7, 9, 6, 8, 9, & - 6, 6, 8, 0, 0 /) - real(kind_phys), parameter :: wh2o = 18.0153 - real(kind_phys), parameter :: wpan = 121.04793 - real(kind_phys), PARAMETER :: KARMAN=0.4 - INTEGER, parameter :: luse2usgs(21) = (/14,13,12,11,15,8,9,10,10,7, & - 17,4,1,5,24,19,16,21,22,23,16 /) - character(len=4), parameter :: mminlu = 'USGS' - - ! integer, parameter :: pan_seasons = 5 - ! integer, parameter :: pan_lands = 11 - - type smoke_data - ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! Taken from dep_simple_mod - INTEGER :: ixxxlu(nlu) - REAL(KIND_PHYS) :: kpart(nlu) - REAL(KIND_PHYS) :: rac(nlu,dep_seasons), rclo(nlu,dep_seasons), rcls(nlu,dep_seasons) - REAL(KIND_PHYS) :: rgso(nlu,dep_seasons), rgss(nlu,dep_seasons) - REAL(KIND_PHYS) :: ri(nlu,dep_seasons), rlu(nlu,dep_seasons) - ! REAL(KIND_PHYS) :: ri_pan(pan_seasons,pan_lands) - ! never used: real(kind_phys) :: c0_pan(pan_lands) - ! never used: real(kind_phys) :: k_pan (pan_lands) - - ! never used: integer :: month - REAL(KIND_PHYS) :: dratio(1000), hstar(1000), hstar4(1000) - REAL(KIND_PHYS) :: f0(1000), dhr(1000), scpr23(1000) - - ! Note: scpr23 is only read, never written - - ! never used: type(wesely_pft) :: seasonal_pft - - ! never used: logical, pointer :: is_aerosol(:) => NULL() - - ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! Taken from dep_wet_ls_mod - real(kind_phys), dimension(:), pointer :: alpha => NULL() - contains - final :: smoke_data_destructor - procedure :: dep_init - end type smoke_data - - interface smoke_data - procedure :: smoke_data_constructor - end interface smoke_data - - type(smoke_data), target, private :: private_thread_data - logical, private :: rrfs_smoke_data_initialized = .false. - - !$OMP THREADPRIVATE(private_thread_data) - !$OMP THREADPRIVATE(rrfs_smoke_data_initialized) - -contains - - function get_thread_smoke_data() result(data) - implicit none - class(smoke_data), pointer :: data - if(.not. rrfs_smoke_data_initialized) then - private_thread_data = smoke_data() - rrfs_smoke_data_initialized = .true. - endif - data => private_thread_data - end function get_thread_smoke_data - - subroutine wesely_pft_destructor(this) - implicit none - type(wesely_pft) :: this - if(associated(this%seasonal_wes)) then - deallocate(this%seasonal_wes) - nullify(this%seasonal_wes) - endif - end subroutine wesely_pft_destructor - - function wesely_pft_constructor() result(this) - implicit none - class(wesely_pft), pointer :: this - nullify(this%seasonal_wes) - end function wesely_pft_constructor - - function smoke_data_constructor() result(this) - implicit none - type(smoke_data) :: this - ! These are never used: - ! this%c0_pan = (/ 0.000, 0.006, 0.002, 0.009, 0.015, & - ! 0.006, 0.000, 0.000, 0.000, 0.002, 0.002 /) - ! this%k_pan = (/ 0.000, 0.010, 0.005, 0.004, 0.003, & - ! 0.005, 0.000, 0.000, 0.000, 0.075, 0.002 /) - ! this%month = 0 - ! this%seasonal_pft = wesely_pft() - ! nullify(this%is_aerosol) - nullify(this%alpha) - ! This is not called in the original non-thread-safe code: - ! call this%dep_init() - end function smoke_data_constructor - - subroutine smoke_data_destructor(this) - implicit none - type(smoke_data) :: this - if(associated(this%alpha)) then - deallocate(this%alpha) - nullify(this%alpha) - endif - ! Never used: - ! if(associated(this%is_aerosol)) then - ! deallocate(this%is_aerosol) - ! nullify(this%is_aerosolo) - ! endif - end subroutine smoke_data_destructor - - -! SUBROUTINE dep_init( id, numgas, mminlu_loc, & -! ips, ipe, jps, jpe, ide, jde ) - SUBROUTINE dep_init(this,errmsg,errflg) - ! Lifted out of dep_simple_mod, this initializes - ! member variables that were module variables in - ! that module. -!-- - implicit none - class(smoke_data) :: this - character(*), intent(inout) :: errmsg - integer, intent(inout) :: errflg - -!-------------------------------------------------- -! .. Scalar Arguments .. -!-------------------------------------------------- - ! Unused: - ! integer, intent(in) :: numgas - ! integer, intent(in) :: ips, ipe, jps, jpe - ! integer, intent(in) :: ide, jde - ! mmin_lu_loc had no definition, but is also unused - -!-------------------------------------------------- -! .. Local Scalars -!-------------------------------------------------- - INTEGER :: iland, iseason, l - integer :: iprt - integer :: astat - integer :: ncid - integer :: dimid - integer :: varid - integer :: cpos, slen - integer :: lon_e, lat_e - integer :: iend, jend - integer :: chem_opt - integer, allocatable :: input_wes_seasonal(:,:,:,:) - REAL(KIND_PHYS) :: sc - character(len=128) :: err_msg - character(len=128) :: filename - character(len=3) :: id_num -!-------------------------------------------------- -! .. Local Arrays -!-------------------------------------------------- - REAL(KIND_PHYS) :: dat1(nlu,dep_seasons), dat2(nlu,dep_seasons), & - dat3(nlu,dep_seasons), dat4(nlu,dep_seasons), & - dat5(nlu,dep_seasons), dat6(nlu,dep_seasons), & - dat7(nlu,dep_seasons) - ! REAL(KIND_PHYS) :: dat8(pan_seasons,pan_lands) - chem_opt = chem_opt - -!-------------------------------------------------- -! .. Data Statements .. -! THIS%RI for stomatal resistance -! data ((this%ri(ILAND,ISEASON),ILAND=1,nlu),ISEASON=1,dep_seasons)/0.10E+11, & - DATA ((dat1(iland,iseason),iland=1,nlu),iseason=1,dep_seasons)/0.10E+11, & - 0.60E+02, 0.60E+02, 0.60E+02, 0.60E+02, 0.70E+02, 0.12E+03, & - 0.12E+03, 0.12E+03, 0.12E+03, 0.70E+02, 0.13E+03, 0.70E+02, & - 0.13E+03, 0.10E+03, 0.10E+11, 0.80E+02, 0.10E+03, 0.10E+11, & - 0.80E+02, 0.10E+03, 0.10E+03, 0.10E+11, 0.10E+11, 0.10E+11, & - 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & - 0.10E+11, 0.10E+11, 0.10E+11, 0.12E+03, 0.10E+11, 0.10E+11, & - 0.70E+02, 0.25E+03, 0.50E+03, 0.10E+11, 0.10E+11, 0.50E+03, & - 0.10E+11, 0.10E+11, 0.50E+03, 0.50E+03, 0.10E+11, 0.10E+11, & - 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & - 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.12E+03, 0.10E+11, & - 0.10E+11, 0.70E+02, 0.25E+03, 0.50E+03, 0.10E+11, 0.10E+11, & - 0.50E+03, 0.10E+11, 0.10E+11, 0.50E+03, 0.50E+03, 0.10E+11, & - 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & - 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & - 0.10E+11, 0.10E+11, 0.70E+02, 0.40E+03, 0.80E+03, 0.10E+11, & - 0.10E+11, 0.80E+03, 0.10E+11, 0.10E+11, 0.80E+03, 0.80E+03, & - 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.12E+03, 0.12E+03, & - 0.12E+03, 0.12E+03, 0.14E+03, 0.24E+03, 0.24E+03, 0.24E+03, & - 0.12E+03, 0.14E+03, 0.25E+03, 0.70E+02, 0.25E+03, 0.19E+03, & - 0.10E+11, 0.16E+03, 0.19E+03, 0.10E+11, 0.16E+03, 0.19E+03, & - 0.19E+03, 0.10E+11, 0.10E+11, 0.10E+11/ -! .. - IF (nlu/=25) THEN - errmsg='number of land use classifications not correct ' - errflg=1 - return - END IF - IF (dep_seasons/=5) THEN - errmsg='number of dep_seasons not correct ' - errflg=1 - return - END IF - -! SURFACE RESISTANCE DATA FOR DEPOSITION MODEL OF -! M. L. WESELY, ATMOSPHERIC ENVIRONMENT 23 (1989) 1293-1304 - -! Seasonal categories: -! 1: midsummer with lush vegetation -! 2: autumn with unharvested cropland -! 3: late autumn with frost, no snow -! 4: winter, snow on ground and subfreezing -! 5: transitional spring with partially green short annuals - -! Land use types: -! USGS type Wesely type -! 1: Urban and built-up land 1 -! 2: Dryland cropland and pasture 2 -! 3: Irrigated cropland and pasture 2 -! 4: Mix. dry/irrg. cropland and pasture 2 -! 5: Cropland/grassland mosaic 2 -! 6: Cropland/woodland mosaic 4 -! 7: Grassland 3 -! 8: Shrubland 3 -! 9: Mixed shrubland/grassland 3 -! 10: Savanna 3, always summer -! 11: Deciduous broadleaf forest 4 -! 12: Deciduous needleleaf forest 5, autumn and winter modi -! 13: Evergreen broadleaf forest 4, always summer -! 14: Evergreen needleleaf forest 5 -! 15: Mixed Forest 6 -! 16: Water Bodies 7 -! 17: Herbaceous wetland 9 -! 18: Wooded wetland 6 -! 19: Barren or sparsely vegetated 8 -! 20: Herbaceous Tundra 9 -! 21: Wooded Tundra 6 -! 22: Mixed Tundra 6 -! 23: Bare Ground Tundra 8 -! 24: Snow or Ice -, always winter -! 25: No data 8 - - -! Order of data: -! | -! | seasonal category -! \|/ -! ---> landuse type -! 1 2 3 4 5 6 7 8 9 -! THIS%RLU for outer surfaces in the upper canopy - DO iseason = 1, dep_seasons - this%ri(1:nlu,iseason) = dat1(1:nlu,iseason) - END DO -! data ((this%rlu(ILAND,ISEASON),ILAND=1,25),ISEASON=1,5)/0.10E+11, & - DATA ((dat2(iland,iseason),iland=1,nlu),iseason=1,dep_seasons)/0.10E+11, & - 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, & - 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, & - 0.20E+04, 0.20E+04, 0.10E+11, 0.25E+04, 0.20E+04, 0.10E+11, & - 0.25E+04, 0.20E+04, 0.20E+04, 0.10E+11, 0.10E+11, 0.10E+11, & - 0.10E+11, 0.90E+04, 0.90E+04, 0.90E+04, 0.90E+04, 0.90E+04, & - 0.90E+04, 0.90E+04, 0.90E+04, 0.20E+04, 0.90E+04, 0.90E+04, & - 0.20E+04, 0.40E+04, 0.80E+04, 0.10E+11, 0.90E+04, 0.80E+04, & - 0.10E+11, 0.90E+04, 0.80E+04, 0.80E+04, 0.10E+11, 0.10E+11, & - 0.10E+11, 0.10E+11, 0.90E+04, 0.90E+04, 0.90E+04, 0.90E+04, & - 0.90E+04, 0.90E+04, 0.90E+04, 0.90E+04, 0.20E+04, 0.90E+04, & - 0.90E+04, 0.20E+04, 0.40E+04, 0.80E+04, 0.10E+11, 0.90E+04, & - 0.80E+04, 0.10E+11, 0.90E+04, 0.80E+04, 0.80E+04, 0.10E+11, & - 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & - 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & - 0.10E+11, 0.10E+11, 0.20E+04, 0.60E+04, 0.90E+04, 0.10E+11, & - 0.90E+04, 0.90E+04, 0.10E+11, 0.90E+04, 0.90E+04, 0.90E+04, & - 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.40E+04, 0.40E+04, & - 0.40E+04, 0.40E+04, 0.40E+04, 0.40E+04, 0.40E+04, 0.40E+04, & - 0.20E+04, 0.40E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.30E+04, & - 0.10E+11, 0.40E+04, 0.30E+04, 0.10E+11, 0.40E+04, 0.30E+04, & - 0.30E+04, 0.10E+11, 0.10E+11, 0.10E+11/ - DO iseason = 1, dep_seasons - this%rlu(1:nlu,iseason) = dat2(1:nlu,iseason) - END DO -! THIS%RAC for transfer that depends on canopy height and density -! data ((this%rac(ILAND,ISEASON),ILAND=1,25),ISEASON=1,5)/0.10E+03, & - DATA ((dat3(iland,iseason),iland=1,nlu),iseason=1,dep_seasons)/0.10E+03, & - 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+04, 0.10E+03, & - 0.10E+03, 0.10E+03, 0.10E+03, 0.20E+04, 0.20E+04, 0.20E+04, & - 0.20E+04, 0.20E+04, 0.00E+00, 0.30E+03, 0.20E+04, 0.00E+00, & - 0.30E+03, 0.20E+04, 0.20E+04, 0.00E+00, 0.00E+00, 0.00E+00, & - 0.10E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.15E+04, & - 0.10E+03, 0.10E+03, 0.10E+03, 0.10E+03, 0.15E+04, 0.20E+04, & - 0.20E+04, 0.20E+04, 0.17E+04, 0.00E+00, 0.20E+03, 0.17E+04, & - 0.00E+00, 0.20E+03, 0.17E+04, 0.17E+04, 0.00E+00, 0.00E+00, & - 0.00E+00, 0.10E+03, 0.10E+02, 0.10E+02, 0.10E+02, 0.10E+02, & - 0.10E+04, 0.10E+03, 0.10E+03, 0.10E+03, 0.10E+03, 0.10E+04, & - 0.20E+04, 0.20E+04, 0.20E+04, 0.15E+04, 0.00E+00, 0.10E+03, & - 0.15E+04, 0.00E+00, 0.10E+03, 0.15E+04, 0.15E+04, 0.00E+00, & - 0.00E+00, 0.00E+00, 0.10E+03, 0.10E+02, 0.10E+02, 0.10E+02, & - 0.10E+02, 0.10E+04, 0.10E+02, 0.10E+02, 0.10E+02, 0.10E+02, & - 0.10E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.15E+04, 0.00E+00, & - 0.50E+02, 0.15E+04, 0.00E+00, 0.50E+02, 0.15E+04, 0.15E+04, & - 0.00E+00, 0.00E+00, 0.00E+00, 0.10E+03, 0.50E+02, 0.50E+02, & - 0.50E+02, 0.50E+02, 0.12E+04, 0.80E+02, 0.80E+02, 0.80E+02, & - 0.10E+03, 0.12E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.15E+04, & - 0.00E+00, 0.20E+03, 0.15E+04, 0.00E+00, 0.20E+03, 0.15E+04, & - 0.15E+04, 0.00E+00, 0.00E+00, 0.00E+00/ - DO iseason = 1, dep_seasons - this%rac(1:nlu,iseason) = dat3(1:nlu,iseason) - END DO -! THIS%RGSS for ground surface SO2 -! data ((this%rgss(ILAND,ISEASON),ILAND=1,25),ISEASON=1,5)/0.40E+03, & - DATA ((dat4(iland,iseason),iland=1,nlu),iseason=1,dep_seasons)/0.40E+03, & - 0.15E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.50E+03, 0.35E+03, & - 0.35E+03, 0.35E+03, 0.35E+03, 0.50E+03, 0.50E+03, 0.50E+03, & - 0.50E+03, 0.10E+03, 0.10E+01, 0.10E+01, 0.10E+03, 0.10E+04, & - 0.10E+01, 0.10E+03, 0.10E+03, 0.10E+04, 0.10E+03, 0.10E+04, & - 0.40E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.50E+03, & - 0.35E+03, 0.35E+03, 0.35E+03, 0.35E+03, 0.50E+03, 0.50E+03, & - 0.50E+03, 0.50E+03, 0.10E+03, 0.10E+01, 0.10E+01, 0.10E+03, & - 0.10E+04, 0.10E+01, 0.10E+03, 0.10E+03, 0.10E+04, 0.10E+03, & - 0.10E+04, 0.40E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.15E+03, & - 0.50E+03, 0.35E+03, 0.35E+03, 0.35E+03, 0.35E+03, 0.50E+03, & - 0.50E+03, 0.50E+03, 0.50E+03, 0.20E+03, 0.10E+01, 0.10E+01, & - 0.20E+03, 0.10E+04, 0.10E+01, 0.20E+03, 0.20E+03, 0.10E+04, & - 0.10E+03, 0.10E+04, 0.10E+03, 0.10E+03, 0.10E+03, 0.10E+03, & - 0.10E+03, 0.10E+03, 0.10E+03, 0.10E+03, 0.10E+03, 0.10E+03, & - 0.10E+03, 0.10E+03, 0.50E+03, 0.10E+03, 0.10E+03, 0.10E+01, & - 0.10E+03, 0.10E+03, 0.10E+04, 0.10E+03, 0.10E+03, 0.10E+03, & - 0.10E+04, 0.10E+03, 0.10E+04, 0.50E+03, 0.15E+03, 0.15E+03, & - 0.15E+03, 0.15E+03, 0.50E+03, 0.35E+03, 0.35E+03, 0.35E+03, & - 0.35E+03, 0.50E+03, 0.50E+03, 0.50E+03, 0.50E+03, 0.20E+03, & - 0.10E+01, 0.10E+01, 0.20E+03, 0.10E+04, 0.10E+01, 0.20E+03, & - 0.20E+03, 0.10E+04, 0.10E+03, 0.10E+04/ - DO iseason = 1, dep_seasons - this%rgss(1:nlu,iseason) = dat4(1:nlu,iseason) - END DO -! THIS%RGSO for ground surface O3 -! data ((this%rgso(ILAND,ISEASON),ILAND=1,25),ISEASON=1,5)/0.30E+03, & - DATA ((dat5(iland,iseason),iland=1,nlu),iseason=1,dep_seasons)/0.30E+03, & - 0.15E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.20E+03, 0.20E+03, & - 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, & - 0.20E+03, 0.30E+03, 0.20E+04, 0.10E+04, 0.30E+03, 0.40E+03, & - 0.10E+04, 0.30E+03, 0.30E+03, 0.40E+03, 0.35E+04, 0.40E+03, & - 0.30E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.20E+03, & - 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, & - 0.20E+03, 0.20E+03, 0.30E+03, 0.20E+04, 0.80E+03, 0.30E+03, & - 0.40E+03, 0.80E+03, 0.30E+03, 0.30E+03, 0.40E+03, 0.35E+04, & - 0.40E+03, 0.30E+03, 0.15E+03, 0.15E+03, 0.15E+03, 0.15E+03, & - 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, & - 0.20E+03, 0.20E+03, 0.20E+03, 0.30E+03, 0.20E+04, 0.10E+04, & - 0.30E+03, 0.40E+03, 0.10E+04, 0.30E+03, 0.30E+03, 0.40E+03, & - 0.35E+04, 0.40E+03, 0.60E+03, 0.35E+04, 0.35E+04, 0.35E+04, & - 0.35E+04, 0.35E+04, 0.35E+04, 0.35E+04, 0.35E+04, 0.35E+04, & - 0.35E+04, 0.35E+04, 0.20E+03, 0.35E+04, 0.35E+04, 0.20E+04, & - 0.35E+04, 0.35E+04, 0.40E+03, 0.35E+04, 0.35E+04, 0.35E+04, & - 0.40E+03, 0.35E+04, 0.40E+03, 0.30E+03, 0.15E+03, 0.15E+03, & - 0.15E+03, 0.15E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, & - 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.20E+03, 0.30E+03, & - 0.20E+04, 0.10E+04, 0.30E+03, 0.40E+03, 0.10E+04, 0.30E+03, & - 0.30E+03, 0.40E+03, 0.35E+04, 0.40E+03/ - DO iseason = 1, dep_seasons - this%rgso(1:nlu,iseason) = dat5(1:nlu,iseason) - END DO -! THIS%RCLS for exposed surfaces in the lower canopy SO2 -! data ((this%rcls(ILAND,ISEASON),ILAND=1,25),ISEASON=1,5)/0.10E+11, & - DATA ((dat6(iland,iseason),iland=1,nlu),iseason=1,dep_seasons)/0.10E+11, & - 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, & - 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.20E+04, & - 0.20E+04, 0.20E+04, 0.10E+11, 0.25E+04, 0.20E+04, 0.10E+11, & - 0.25E+04, 0.20E+04, 0.20E+04, 0.10E+11, 0.10E+11, 0.10E+11, & - 0.10E+11, 0.90E+04, 0.90E+04, 0.90E+04, 0.90E+04, 0.90E+04, & - 0.90E+04, 0.90E+04, 0.90E+04, 0.20E+04, 0.90E+04, 0.90E+04, & - 0.20E+04, 0.20E+04, 0.40E+04, 0.10E+11, 0.90E+04, 0.40E+04, & - 0.10E+11, 0.90E+04, 0.40E+04, 0.40E+04, 0.10E+11, 0.10E+11, & - 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & - 0.90E+04, 0.90E+04, 0.90E+04, 0.90E+04, 0.20E+04, 0.90E+04, & - 0.90E+04, 0.20E+04, 0.30E+04, 0.60E+04, 0.10E+11, 0.90E+04, & - 0.60E+04, 0.10E+11, 0.90E+04, 0.60E+04, 0.60E+04, 0.10E+11, & - 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & - 0.10E+11, 0.90E+04, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, & - 0.90E+04, 0.90E+04, 0.20E+04, 0.20E+03, 0.40E+03, 0.10E+11, & - 0.90E+04, 0.40E+03, 0.10E+11, 0.90E+04, 0.40E+03, 0.40E+03, & - 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.40E+04, 0.40E+04, & - 0.40E+04, 0.40E+04, 0.40E+04, 0.40E+04, 0.40E+04, 0.40E+04, & - 0.20E+04, 0.40E+04, 0.20E+04, 0.20E+04, 0.20E+04, 0.30E+04, & - 0.10E+11, 0.40E+04, 0.30E+04, 0.10E+11, 0.40E+04, 0.30E+04, & - 0.30E+04, 0.10E+11, 0.10E+11, 0.10E+11/ - DO iseason = 1, dep_seasons - this%rcls(1:nlu,iseason) = dat6(1:nlu,iseason) - END DO -! THIS%RCLO for exposed surfaces in the lower canopy O3 -! data ((this%rclo(ILAND,ISEASON),ILAND=1,25),ISEASON=1,5)/0.10E+11, & - DATA ((dat7(iland,iseason),iland=1,nlu),iseason=1,dep_seasons)/0.10E+11, & - 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, & - 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, & - 0.10E+04, 0.10E+04, 0.10E+11, 0.10E+04, 0.10E+04, 0.10E+11, & - 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+11, 0.10E+11, 0.10E+11, & - 0.10E+11, 0.40E+03, 0.40E+03, 0.40E+03, 0.40E+03, 0.40E+03, & - 0.40E+03, 0.40E+03, 0.40E+03, 0.10E+04, 0.40E+03, 0.40E+03, & - 0.10E+04, 0.10E+04, 0.60E+03, 0.10E+11, 0.40E+03, 0.60E+03, & - 0.10E+11, 0.40E+03, 0.60E+03, 0.60E+03, 0.10E+11, 0.10E+11, & - 0.10E+11, 0.10E+11, 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, & - 0.40E+03, 0.40E+03, 0.40E+03, 0.40E+03, 0.10E+04, 0.40E+03, & - 0.40E+03, 0.10E+04, 0.10E+04, 0.60E+03, 0.10E+11, 0.80E+03, & - 0.60E+03, 0.10E+11, 0.80E+03, 0.60E+03, 0.60E+03, 0.10E+11, & - 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+04, 0.10E+04, 0.10E+04, & - 0.10E+04, 0.40E+03, 0.10E+04, 0.10E+04, 0.10E+04, 0.10E+04, & - 0.40E+03, 0.40E+03, 0.10E+04, 0.15E+04, 0.60E+03, 0.10E+11, & - 0.80E+03, 0.60E+03, 0.10E+11, 0.80E+03, 0.60E+03, 0.60E+03, & - 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+11, 0.10E+04, 0.10E+04, & - 0.10E+04, 0.10E+04, 0.50E+03, 0.50E+03, 0.50E+03, 0.50E+03, & - 0.10E+04, 0.50E+03, 0.15E+04, 0.10E+04, 0.15E+04, 0.70E+03, & - 0.10E+11, 0.60E+03, 0.70E+03, 0.10E+11, 0.60E+03, 0.70E+03, & - 0.70E+03, 0.10E+11, 0.10E+11, 0.10E+11/ - - DO iseason = 1, dep_seasons - this%rclo(1:nlu,iseason) = dat7(1:nlu,iseason) - END DO - - ! data ((dat8(iseason,iland),iseason=1,pan_seasons),iland=1,pan_lands) / & - ! 1.e36, 60., 120., 70., 130., 100.,1.e36,1.e36, 80., 100., 150., & - ! 1.e36,1.e36,1.e36,1.e36, 250., 500.,1.e36,1.e36,1.e36,1.e36,1.e36, & - ! 1.e36,1.e36,1.e36,1.e36, 250., 500.,1.e36,1.e36,1.e36,1.e36,1.e36, & - ! 1.e36,1.e36,1.e36,1.e36, 400., 800.,1.e36,1.e36,1.e36,1.e36,1.e36, & - ! 1.e36, 120., 240., 140., 250., 190.,1.e36,1.e36, 160., 200., 300. / - ! this%ri_pan(:,:) = dat8(:,:) - -!-------------------------------------------------- -! Initialize parameters -!-------------------------------------------------- - this%hstar = 0. - this%hstar4 = 0. - this%dhr = 0. - this%f0 = 0. - this%dratio = 1.0 ! FIXME: IS THIS RIGHT? - this%scpr23 = 1.0 ! FIXME: IS THIS RIGHT? - -!-------------------------------------------------- -! HENRY''S LAW COEFFICIENTS -! Effective Henry''s law coefficient at pH 7 -! [KH298]=mole/(l atm) -!-------------------------------------------------- - -! DATA FOR AEROSOL PARTICLE DEPOSITION FOR THE MODEL OF -! J. W. ERISMAN, A. VAN PUL AND P. WYERS -! ATMOSPHERIC ENVIRONMENT 28 (1994), 2595-2607 - -! vd = (u* / k) * CORRECTION FACTORS - -! CONSTANT K FOR LANDUSE TYPES: -! urban and built-up land - this%kpart(1) = 500. -! dryland cropland and pasture - this%kpart(2) = 500. -! irrigated cropland and pasture - this%kpart(3) = 500. -! mixed dryland/irrigated cropland and past - this%kpart(4) = 500. -! cropland/grassland mosaic - this%kpart(5) = 500. -! cropland/woodland mosaic - this%kpart(6) = 100. -! grassland - this%kpart(7) = 500. -! shrubland - this%kpart(8) = 500. -! mixed shrubland/grassland - this%kpart(9) = 500. -! savanna - this%kpart(10) = 500. -! deciduous broadleaf forest - this%kpart(11) = 100. -! deciduous needleleaf forest - this%kpart(12) = 100. -! evergreen broadleaf forest - this%kpart(13) = 100. -! evergreen needleleaf forest - this%kpart(14) = 100. -! mixed forest - this%kpart(15) = 100. -! water bodies - this%kpart(16) = 500. -! herbaceous wetland - this%kpart(17) = 500. -! wooded wetland - this%kpart(18) = 500. -! barren or sparsely vegetated - this%kpart(19) = 500. -! herbaceous tundra - this%kpart(20) = 500. -! wooded tundra - this%kpart(21) = 100. -! mixed tundra - this%kpart(22) = 500. -! bare ground tundra - this%kpart(23) = 500. -! snow or ice - this%kpart(24) = 500. -! Comments: - this%kpart(25) = 500. -! Erisman et al. (1994) give -! k = 500 for low vegetation and k = 100 for forests. - -! For desert k = 500 is taken according to measurements -! on bare soil by -! J. Fontan, A. Lopez, E. Lamaud and A. Druilhet (1997) -! Vertical Flux Measurements of the Submicronic Aerosol Particles -! and Parametrisation of the Dry Deposition Velocity -! in: Biosphere-Atmosphere Exchange of Pollutants -! and Trace Substances -! Editor: S. Slanina. Springer-Verlag Berlin, Heidelberg, 1997 -! pp. 381-390 - -! For coniferous forest the Erisman value of k = 100 is taken. -! Measurements of Erisman et al. (1997) in a coniferous forest -! in the Netherlands, lead to values of k between 20 and 38 -! (Atmospheric Environment 31 (1997), 321-332). -! However, these high values of vd may be reached during -! instable cases. The eddy correlation measurements -! of Gallagher et al. (1997) made during the same experiment -! show for stable cases (L>0) values of k between 200 and 250 -! at minimum (Atmospheric Environment 31 (1997), 359-373). -! Fontan et al. (1997) found k = 250 in a forest -! of maritime pine in southwestern France. - -! For gras, model calculations of Davidson et al. support -! the value of 500. -! C. I. Davidson, J. M. Miller and M. A. Pleskov -! The Influence of Surface Structure on Predicted Particles -! Dry Deposition to Natural Gras Canopies -! Water, Air, and Soil Pollution 18 (1982) 25-43 - -! Snow covered surface: The experiment of Ibrahim et al. (1983) -! gives k = 436 for 0.7 um diameter particles. -! The deposition velocity of Milford and Davidson (1987) -! gives k = 154 for continental sulfate aerosol. -! M. Ibrahim, L. A. Barrie and F. Fanaki -! Atmospheric Environment 17 (1983), 781-788 - -! J. B. Milford and C. I. Davidson -! The Sizes of Particulate Sulfate and Nitrate in the Atmosphere -! - A Review -! JAPCA 37 (1987), 125-134 -! no data -! WRITE (0,*) ' return from rcread ' -! ********************************************************* - -! Simplified landuse scheme for deposition and biogenic emission -! subroutines -! (ISWATER and ISICE are already defined elsewhere, -! therefore water and ice are not considered here) - -! 1 urban or bare soil -! 2 agricultural -! 3 grassland -! 4 deciduous forest -! 5 coniferous and mixed forest -! 6 other natural landuse categories - - - IF (mminlu=='OLD ') THEN - this%ixxxlu(1) = 1 - this%ixxxlu(2) = 2 - this%ixxxlu(3) = 3 - this%ixxxlu(4) = 4 - this%ixxxlu(5) = 5 - this%ixxxlu(6) = 5 - this%ixxxlu(7) = 0 - this%ixxxlu(8) = 6 - this%ixxxlu(9) = 1 - this%ixxxlu(10) = 6 - this%ixxxlu(11) = 0 - this%ixxxlu(12) = 4 - this%ixxxlu(13) = 6 - END IF - IF (mminlu=='USGS') THEN - this%ixxxlu(1) = 1 - this%ixxxlu(2) = 2 - this%ixxxlu(3) = 2 - this%ixxxlu(4) = 2 - this%ixxxlu(5) = 2 - this%ixxxlu(6) = 4 - this%ixxxlu(7) = 3 - this%ixxxlu(8) = 6 - this%ixxxlu(9) = 3 - this%ixxxlu(10) = 6 - this%ixxxlu(11) = 4 - this%ixxxlu(12) = 5 - this%ixxxlu(13) = 4 - this%ixxxlu(14) = 5 - this%ixxxlu(15) = 5 - this%ixxxlu(16) = 0 - this%ixxxlu(17) = 6 - this%ixxxlu(18) = 4 - this%ixxxlu(19) = 1 - this%ixxxlu(20) = 6 - this%ixxxlu(21) = 4 - this%ixxxlu(22) = 6 - this%ixxxlu(23) = 1 - this%ixxxlu(24) = 0 - this%ixxxlu(25) = 1 - END IF - IF (mminlu=='SiB ') THEN - this%ixxxlu(1) = 4 - this%ixxxlu(2) = 4 - this%ixxxlu(3) = 4 - this%ixxxlu(4) = 5 - this%ixxxlu(5) = 5 - this%ixxxlu(6) = 6 - this%ixxxlu(7) = 3 - this%ixxxlu(8) = 6 - this%ixxxlu(9) = 6 - this%ixxxlu(10) = 6 - this%ixxxlu(11) = 1 - this%ixxxlu(12) = 2 - this%ixxxlu(13) = 6 - this%ixxxlu(14) = 1 - this%ixxxlu(15) = 0 - this%ixxxlu(16) = 0 - this%ixxxlu(17) = 1 - END IF - - END SUBROUTINE dep_init -end module rrfs_smoke_data diff --git a/smoke/rrfs_smoke_lsdep_wrapper.F90 b/smoke/rrfs_smoke_lsdep_wrapper.F90 deleted file mode 100644 index 1fd7a2d3f..000000000 --- a/smoke/rrfs_smoke_lsdep_wrapper.F90 +++ /dev/null @@ -1,323 +0,0 @@ -!>\file rrfs_smoke_lsdep_wrapper.F90 -!! This file is RRFS-smoke large-scale wet deposition wrapper with CCPP -!! Haiqin.Li@noaa.gov 04/2021 - - module rrfs_smoke_lsdep_wrapper - - use machine , only : kind_phys - use rrfs_smoke_config - use dep_wet_ls_mod - use dust_data_mod - use rrfs_smoke_data - - implicit none - - private - - public :: rrfs_smoke_lsdep_wrapper_run - -contains - -!>\defgroup rrfs_smoke_lsdep_wrapper GSD Chem driver Module -!> \ingroup gsd_chem_group -!! This is the GSD Chem driver Module -!! \section arg_table_rrfs_smoke_lsdep_wrapper_run Argument Table -!! \htmlinclude rrfs_smoke_lsdep_wrapper_run.html -!! -!>\section rrfs_smoke_lsdep_wrapper GSD Chemistry Scheme General Algorithm -!> @{ - subroutine rrfs_smoke_lsdep_wrapper_run(im, kte, kme, ktau, dt, & - rain_cpl, rainc_cpl, g, & - pr3d, ph3d,phl3d, prl3d, tk3d, us3d, vs3d, spechum, & - w, dqdt, ntrac,ntsmoke,ntdust, & - gq0,qgrs,wetdep_ls_opt_in, & - errmsg,errflg) - - implicit none - - - integer, intent(in) :: im,kte,kme,ktau - integer, intent(in) :: ntrac,ntsmoke,ntdust - real(kind_phys),intent(in) :: dt,g - - integer, parameter :: ids=1,jds=1,jde=1, kds=1 - integer, parameter :: ims=1,jms=1,jme=1, kms=1 - integer, parameter :: its=1,jts=1,jte=1, kts=1 - - real(kind_phys), dimension(:), intent(in) :: rain_cpl, rainc_cpl - real(kind_phys), dimension(:,:), intent(in) :: ph3d, pr3d - real(kind_phys), dimension(:,:), intent(in) :: phl3d, prl3d, tk3d, & - us3d, vs3d, spechum, w, dqdt - real(kind_phys), dimension(:,:,:), intent(inout) :: gq0, qgrs - integer, intent(in) :: wetdep_ls_opt_in - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - real(kind_phys), dimension(1:im, 1:kme,jms:jme) :: rri, t_phy, u_phy, v_phy, & - p_phy, z_at_w, dz8w, p8w, t8w, rho_phy, vvel, dqdti - - real(kind_phys), dimension(ims:im, jms:jme) :: rcav, rnav - -!>- vapor & chemistry variables - real(kind_phys), dimension(ims:im, kms:kme, jms:jme, 1:num_moist) :: moist - real(kind_phys), dimension(ims:im, kms:kme, jms:jme, 1:num_chem ) :: chem - real(kind_phys), dimension(ims:im, jms:jme, 1:num_chem ) :: var_rmv - - integer :: ide, ime, ite, kde - - real(kind_phys) :: dtstep - real(kind_phys), dimension(1:num_chem) :: ppm2ugkg - - type(smoke_data), pointer :: data - -!>-- local variables - integer :: i, j, jp, k, kp, n - - data=>get_thread_smoke_data() - - errmsg = '' - errflg = 0 - - wetdep_ls_opt = wetdep_ls_opt_in - !print*,'hli wetdep_ls_opt',wetdep_ls_opt - - ! -- set domain - ide=im - ime=im - ite=im - kde=kte - - ! -- volume to mass fraction conversion table (ppm -> ug/kg) - ppm2ugkg = 1._kind_phys - !ppm2ugkg(p_so2 ) = 1.e+03_kind_phys * mw_so2_aer / mwdry - ppm2ugkg(p_sulf) = 1.e+03_kind_phys * mw_so4_aer / mwdry - - ! -- initialize large-sacle wet depostion - if (ktau==1) then - call dep_wet_ls_init(data) - endif - - ! -- set control flags - - ! -- compute accumulated large-scale and convective rainfall since last call - if (ktau > 1) then - dtstep = call_chemistry * dt - else - dtstep = dt - end if - - ! -- compute incremental convective and large-scale rainfall - do i=its,ite - rcav(i,1)=max(rainc_cpl(i)*1000. , 0.) ! meter to mm - rnav(i,1)=max((rain_cpl(i)-rainc_cpl(i))*1000., 0.) ! meter to mm - enddo - -!!! - -!>- get ready for chemistry run - call rrfs_smoke_prep_lsdep(data,ktau,dtstep, & - pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,w, dqdt, & - rri,t_phy,u_phy,v_phy,p_phy,rho_phy,dz8w,p8w, & - t8w,dqdti,z_at_w,vvel,g, & - ntsmoke,ntdust, & - ntrac,gq0,num_chem, num_moist, & - ppm2ugkg,moist,chem, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) - - ! -- ls wet deposition - select case (wetdep_ls_opt) - case (WDLS_OPT_GSD) - call wetdep_ls(data,dt,chem,rnav,moist,rho_phy,var_rmv, & - num_moist,num_chem,p_qc,p_qi,dz8w,vvel, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) - case (WDLS_OPT_NGAC) - call WetRemovalGOCART(data,its,ite, jts,jte, kts,kte, 1,1, dt, & - num_chem,var_rmv,chem,p_phy,t_phy, & - rho_phy,dqdti,rcav,rnav, g, & - ims,ime, jms,jme, kms,kme) - !if (chem_rc_check(localrc, msg="Failure in NGAC wet removal scheme", & - ! file=__FILE__, line=__LINE__, rc=rc)) return - case default - ! -- no further option implemented - end select - - - ! -- put chem stuff back into tracer array - do k=kts,kte - do i=its,ite - gq0(i,k,ntsmoke)=ppm2ugkg(p_oc1 ) * max(epsilc,chem(i,k,1,p_oc1)) - gq0(i,k,ntdust )=ppm2ugkg(p_dust_1) * max(epsilc,chem(i,k,1,p_dust_1)) - enddo - enddo - - do k=kts,kte - do i=its,ite - qgrs(i,k,ntsmoke)=gq0(i,k,ntsmoke) - qgrs(i,k,ntdust )=gq0(i,k,ntdust ) - enddo - enddo - - -! - end subroutine rrfs_smoke_lsdep_wrapper_run -!> @} - - subroutine rrfs_smoke_prep_lsdep(data,ktau,dtstep, & - pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,w,dqdt, & - rri,t_phy,u_phy,v_phy,p_phy,rho_phy,dz8w,p8w, & - t8w,dqdti,z_at_w,vvel,g, & - ntsmoke,ntdust, & - ntrac,gq0,num_chem, num_moist, & - ppm2ugkg,moist,chem, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) - implicit none - type(smoke_data), intent(inout) :: data - - !Chem input configuration - integer, intent(in) :: ktau - real(kind=kind_phys), intent(in) :: dtstep,g - - !FV3 input variables - integer, intent(in) :: ntrac,ntsmoke,ntdust - real(kind=kind_phys), dimension(ims:ime, kms:kme), intent(in) :: pr3d,ph3d - real(kind=kind_phys), dimension(ims:ime, kts:kte), intent(in) :: & - phl3d,tk3d,prl3d,us3d,vs3d,spechum,w,dqdt - real(kind=kind_phys), dimension(ims:ime, kts:kte,ntrac), intent(in) :: gq0 - - - !GSD Chem variables - integer,intent(in) :: num_chem, num_moist - integer,intent(in) :: ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - - real(kind_phys), dimension(num_chem), intent(in) :: ppm2ugkg - - real(kind_phys), dimension(ims:ime, kms:kme, jms:jme), intent(out) :: & - rri, t_phy, u_phy, v_phy, p_phy, rho_phy, dz8w, p8w, t8w, vvel, dqdti - real(kind_phys), dimension(ims:ime, kms:kme, jms:jme, num_moist), intent(out) :: moist - real(kind_phys), dimension(ims:ime, kms:kme, jms:jme, num_chem), intent(out) :: chem - - real(kind_phys), dimension(ims:ime, kms:kme, jms:jme), intent(out) :: z_at_w - - ! -- local variables -! real(kind=kind_phys), dimension(ims:ime, kms:kme, jms:jme) :: p_phy - real(kind_phys) :: factor,factor2,pu,pl,aln,pwant - real(kind_phys) :: xhour,xmin,xlonn,xtime,real_time - real(kind_phys), DIMENSION (1,1) :: sza,cosszax - integer i,ip,j,jp,k,kp,kk,kkp,nv,jmax,jmaxi,l,ll,n,ndystep,ixhour - - ! -- initialize output arrays - rri = 0._kind_phys - t_phy = 0._kind_phys - u_phy = 0._kind_phys - v_phy = 0._kind_phys - p_phy = 0._kind_phys - rho_phy = 0._kind_phys - dz8w = 0._kind_phys - p8w = 0._kind_phys - t8w = 0._kind_phys - vvel = 0._kind_phys - dqdti = 0._kind_phys - moist = 0._kind_phys - chem = 0._kind_phys - z_at_w = 0._kind_phys - - - do j=jts,jte - jp = j - jts + 1 - do i=its,ite - ip = i - its + 1 - z_at_w(i,kts,j)=max(0.,ph3d(ip,1)/g) - enddo - enddo - - do j=jts,jte - jp = j - jts + 1 - do k=kts,kte - kp = k - kts + 1 - do i=its,ite - ip = i - its + 1 - dz8w(i,k,j)=abs(ph3d(ip,kp+1)-ph3d(ip,kp))/g - z_at_w(i,k+1,j)=z_at_w(i,k,j)+dz8w(i,k,j) - enddo - enddo - enddo - - do j=jts,jte - jp = j - jts + 1 - do k=kts,kte+1 - kp = k - kts + 1 - do i=its,ite - ip = i - its + 1 - p8w(i,k,j)=pr3d(ip,kp) - enddo - enddo - enddo - - do j=jts,jte - jp = j - jts + 1 - do k=kts,kte+1 - kk=min(k,kte) - kkp = kk - kts + 1 - do i=its,ite - ip = i - its + 1 - dz8w(i,k,j)=z_at_w(i,kk+1,j)-z_at_w(i,kk,j) - t_phy(i,k,j)=tk3d(ip,kkp) - p_phy(i,k,j)=prl3d(ip,kkp) - u_phy(i,k,j)=us3d(ip,kkp) - dqdti(i,k,j)=dqdt(ip,kkp) - v_phy(i,k,j)=vs3d(ip,kkp) - rho_phy(i,k,j)=p_phy(i,k,j)/(287.04*t_phy(i,k,j)*(1.+.608*spechum(ip,kkp))) - rri(i,k,j)=1./rho_phy(i,k,j) - vvel(i,k,j)=-w(ip,kkp)*rri(i,k,j)/g - moist(i,k,j,:)=0. - moist(i,k,j,1)=gq0(ip,kkp,p_atm_shum) - if (t_phy(i,k,j) > 265.) then - moist(i,k,j,2)=gq0(ip,kkp,p_atm_cldq) - moist(i,k,j,3)=0. - if (moist(i,k,j,2) < 1.e-8) moist(i,k,j,2)=0. - else - moist(i,k,j,2)=0. - moist(i,k,j,3)=gq0(ip,kkp,p_atm_cldq) - if(moist(i,k,j,3) < 1.e-8)moist(i,k,j,3)=0. - endif - !-- - enddo - enddo - enddo - - do j=jts,jte - do k=2,kte - do i=its,ite - t8w(i,k,j)=.5*(t_phy(i,k,j)+t_phy(i,k-1,j)) - enddo - enddo - enddo - - ! -- only used in phtolysis.... - do j=jts,jte - do i=its,ite - t8w(i,1,j)=t_phy(i,1,j) - t8w(i,kte+1,j)=t_phy(i,kte,j) - enddo - enddo - - - do k=kms,kte - do i=ims,ime - chem(i,k,jts,p_oc1 )=max(epsilc,gq0(i,k,ntsmoke)/ppm2ugkg(p_oc1)) - chem(i,k,jts,p_dust_1)=max(epsilc,gq0(i,k,ntdust )/ppm2ugkg(p_dust_1)) - enddo - enddo - - - end subroutine rrfs_smoke_prep_lsdep -!> @} - end module rrfs_smoke_lsdep_wrapper diff --git a/smoke/rrfs_smoke_lsdep_wrapper.meta b/smoke/rrfs_smoke_lsdep_wrapper.meta deleted file mode 100755 index 23c71fce8..000000000 --- a/smoke/rrfs_smoke_lsdep_wrapper.meta +++ /dev/null @@ -1,208 +0,0 @@ -[ccpp-table-properties] - name = rrfs_smoke_lsdep_wrapper - type = scheme - dependencies = dep_dry_gocart_mod.F90,dep_dry_mod.F90,dep_simple_mod.F90,dep_vertmx_mod.F90,dep_wet_ls_mod.F90,dust_data_mod.F90,dust_fengsha_mod.F90,module_add_emiss_burn.F90,module_plumerise1.F90,module_smoke_plumerise.F90,module_zero_plumegen_coms.F90,plume_data_mod.F90,rrfs_smoke_config.F90,rrfs_smoke_data.F90,seas_data_mod.F90,seas_mod.F90,seas_ngac_mod.F90 - -######################################################################## -[ccpp-arg-table] - name = rrfs_smoke_lsdep_wrapper_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[kte] - standard_name = vertical_layer_dimension - long_name = number of vertical levels - units = count - dimensions = () - type = integer - intent = in -[kme] - standard_name = vertical_interface_dimension - long_name = number of vertical levels plus one - units = count - dimensions = () - type = integer - intent = in -[ktau] - standard_name = index_of_timestep - long_name = current forecast iteration - units = index - dimensions = () - type = integer - intent = in -[dt] - standard_name = timestep_for_physics - long_name = physics time step - units = s - dimensions = () - type = real - kind = kind_phys - intent = in -[rain_cpl] - standard_name = lwe_thickness_of_precipitation_amount_on_dynamics_timestep - long_name = total rain at this time step - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[rainc_cpl] - standard_name = lwe_thickness_of_convective_precipitation_amount_on_dynamics_timestep - long_name = convective rain at this time step - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[g] - standard_name = gravitational_acceleration - long_name = gravitational acceleration - units = m s-2 - dimensions = () - type = real - kind = kind_phys - intent = in -[pr3d] - standard_name = air_pressure_at_interface - long_name = air pressure at model layer interfaces - units = Pa - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = in -[ph3d] - standard_name = geopotential_at_interface - long_name = geopotential at model layer interfaces - units = m2 s-2 - dimensions = (horizontal_loop_extent,vertical_interface_dimension) - type = real - kind = kind_phys - intent = in -[phl3d] - standard_name = geopotential - long_name = geopotential at model layer centers - units = m2 s-2 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[prl3d] - standard_name = air_pressure - long_name = mean layer pressure - units = Pa - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[tk3d] - standard_name = air_temperature_of_new_state - long_name = updated temperature - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[us3d] - standard_name = x_wind_of_new_state - long_name = updated x-direction wind - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[vs3d] - standard_name = y_wind_of_new_state - long_name = updated y-direction wind - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[spechum] - standard_name = specific_humidity_of_new_state - long_name = water vapor specific humidity updated by physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[w] - standard_name = lagrangian_tendency_of_air_pressure - long_name = layer mean vertical velocity - units = Pa s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[dqdt] - standard_name = instantaneous_water_vapor_specific_humidity_tendency_due_to_convection - long_name = instantaneous moisture tendency due to convection - units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[ntrac] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in -[ntsmoke] - standard_name = index_for_smoke_in_tracer_concentration_array - long_name = tracer index for smoke - units = index - dimensions = () - type = integer - intent = in -[ntdust] - standard_name = index_for_dust_in_tracer_concentration_array - long_name = tracer index for dust - units = index - dimensions = () - type = integer - intent = in -[gq0] - standard_name = tracer_concentration_of_new_state - long_name = tracer concentration updated by physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = inout -[qgrs] - standard_name = tracer_concentration - long_name = model layer mean tracer concentration - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = inout -[wetdep_ls_opt_in] - standard_name = control_for_smoke_wet_deposition - long_name = rrfs smoke large scale wet deposition option - units = index - dimensions = () - type = integer - intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out From a9376a3745fa220ac7f38fbb3c5be82efcc382fc Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Fri, 10 Mar 2023 20:46:52 +0000 Subject: [PATCH 149/380] Switch to the default options in snow model --- physics/module_sf_ruclsm.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 744e321ef..d0c3db631 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -27,17 +27,17 @@ MODULE module_sf_ruclsm real (kind=kind_phys), parameter :: r_v = 4.6150e+2 !-- options for snow conductivity: 1 - constant, 2 - Sturm et al.,1997 - integer, parameter :: isncond_opt = 2 + integer, parameter :: isncond_opt = 1 !-- Snow fraction options !-- option 1: original formulation using threshold snow depth to compute snow fraction - !integer, parameter :: isncovr_opt = 1 + integer, parameter :: isncovr_opt = 1 !-- option 2: the tanh formulation from Niu,G.-Y.,and Yang,Z.-L., 2007,JGR,DOI:10.1029/2007JD008674. !integer, parameter :: isncovr_opt = 2 !-- option 3: the tanh formulation from Niu,G.-Y.,and Yang,Z with ! vegetation-dependent parameters from Noah MP (personal communication with ! Mike Barlage) - integer, parameter :: isncovr_opt = 3 + !integer, parameter :: isncovr_opt = 3 !-- Mosaic_lu and mosaic_soil are defined in set_soilveg_ruc.F90 and ! passes to RUC LSM via namelist_soilveg_ruc.F90. From c5c6c045fe30bff63c87ec4e5d874b65ca56de55 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Fri, 10 Mar 2023 21:19:26 +0000 Subject: [PATCH 150/380] Moved some variables from Interstitial to Sfcprop --- physics/GFS_debug.F90 | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 5387e6300..0414a553f 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -493,6 +493,8 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%oro_uf' , Sfcprop%oro_uf) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%hice' , Sfcprop%hice) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%weasd' , Sfcprop%weasd) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%weasdl' , Sfcprop%weasdl) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%%weasdi' , Sfcprop%weasdi) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%canopy' , Sfcprop%canopy) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%ffmm' , Sfcprop%ffmm) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%ffhh' , Sfcprop%ffhh) @@ -624,6 +626,9 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, ! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%fluxr_n ', Diag%fluxr(:,n)) !end do call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%srunoff ', Diag%srunoff) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%evbs ', Diag%evbs) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%evcw ', Diag%evcw) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%sbsno ', Diag%sbsno) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%evbsa ', Diag%evbsa) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%evcwa ', Diag%evcwa) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%snohfa ', Diag%snohfa) @@ -1204,8 +1209,6 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%evap_ice ', Interstitial%evap_ice ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%evap_land ', Interstitial%evap_land ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%evap_water ', Interstitial%evap_water ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%evbs ', Interstitial%evbs ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%evcw ', Interstitial%evcw ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ext_diag_thompson_reset', Interstitial%ext_diag_thompson_reset) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%faerlw ', Interstitial%faerlw ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%faersw ', Interstitial%faersw ) @@ -1285,7 +1288,7 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%qss_ice ', Interstitial%qss_ice ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%qss_land ', Interstitial%qss_land ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%qss_water ', Interstitial%qss_water ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%fullradar_diag ', Interstitial%fullradar_diag ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%radar_reset ', Interstitial%radar_reset ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%raddt ', Interstitial%raddt ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%raincd ', Interstitial%raincd ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%raincs ', Interstitial%raincs ) @@ -1302,7 +1305,6 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%save_tcp ', Interstitial%save_tcp ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%save_u ', Interstitial%save_u ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%save_v ', Interstitial%save_v ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%sbsno ', Interstitial%sbsno ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%scmpsw%uvbfc ', Interstitial%scmpsw%uvbfc ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%scmpsw%uvbf0 ', Interstitial%scmpsw%uvbf0 ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%scmpsw%nirbm ', Interstitial%scmpsw%nirbm ) @@ -1315,6 +1317,9 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%sigmafrac ', Interstitial%sigmafrac ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%sigmatot ', Interstitial%sigmatot ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowc ', Interstitial%snowc ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowd_ice ', Interstitial%snowd_ice ) +! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowd_land ', Interstitial%snowd_land ) +! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowd_water ', Interstitial%snowd_water ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snohf ', Interstitial%snohf ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowmt ', Interstitial%snowmt ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%stress ', Interstitial%stress ) @@ -1327,7 +1332,7 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tprcp_ice ', Interstitial%tprcp_ice ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tprcp_land ', Interstitial%tprcp_land ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tprcp_water ', Interstitial%tprcp_water ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%trans ', Interstitial%trans ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%trans ', Interstitial%trans ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tseal ', Interstitial%tseal ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tsfa ', Interstitial%tsfa ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tsfc_water ', Interstitial%tsfc_water ) @@ -1341,6 +1346,9 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%vdftra ', Interstitial%vdftra ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%vegf1d ', Interstitial%vegf1d ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%wcbmax ', Interstitial%wcbmax ) +! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%weasd_ice ', Interstitial%weasd_ice ) +! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%weasd_land ', Interstitial%weasd_land ) +! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%weasd_water ', Interstitial%weasd_water ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%wind ', Interstitial%wind ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%work1 ', Interstitial%work1 ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%work2 ', Interstitial%work2 ) From c9b9b5eff8e17bff8a3d4c871b837a38abcd8df4 Mon Sep 17 00:00:00 2001 From: Lisa Bengtsson Date: Mon, 13 Mar 2023 16:42:03 +0000 Subject: [PATCH 151/380] further development of unified scheme --- physics/cu_unified_deep.F90 | 357 ++++++++++++++++++++++++++++++--- physics/cu_unified_driver.F90 | 51 +++-- physics/cu_unified_driver.meta | 63 ++++++ physics/cu_unified_sh.F90 | 88 +++++++- physics/progsigma_calc.f90 | 31 +-- physics/samfdeepcnv.f | 51 ++--- physics/samfshalcnv.f | 45 +++-- 7 files changed, 568 insertions(+), 118 deletions(-) diff --git a/physics/cu_unified_deep.F90 b/physics/cu_unified_deep.F90 index 76526c741..2c0dfbedb 100644 --- a/physics/cu_unified_deep.F90 +++ b/physics/cu_unified_deep.F90 @@ -3,6 +3,7 @@ module cu_unified_deep use machine , only : kind_phys + real(kind=kind_phys), parameter::g=9.81 real(kind=kind_phys), parameter:: cp=1004. real(kind=kind_phys), parameter:: xlv=2.5e6 @@ -73,6 +74,9 @@ end function my_maxloc1d !! \section general_unified_deep Grell-Freitas Deep Convection General Algorithm subroutine cu_unified_deep_run( & itf,ktf,its,ite, kts,kte & + ,flag_init & + ,flag_restart & + ,fv,r_d & ! ratio of vapor to dry air gas constants minus one ,dicycle & ! diurnal cycle flag ,ichoice & ! choice of closure, use "0" for ensemble average ,ipr & ! this flag can be used for debugging prints @@ -83,10 +87,16 @@ subroutine cu_unified_deep_run( & ,kpbl & ! level of boundary layer height ,dhdt & ! boundary layer forcing (one closure for shallow) ,xland & ! land mask + ,delp & ! air pressure difference between midlayers ,zo & ! heights above surface ,forcing & ! only diagnostic ,t & ! t before forcing ,q & ! q before forcing + ,tmf & ! instantanious tendency from turbulence + ,qmicro & ! instantanious tendency from microphysics + ,forceqv_spechum & !instantanious tendency from dynamics + ,sigmain & ! input area fraction after advection + ,sigmaout & ! updated prognostic area fraction ,z1 & ! terrain ,tn & ! t including forcing ,qo & ! q including forcing @@ -99,6 +109,7 @@ subroutine cu_unified_deep_run( & ,qfx & ! w/m2, positive upward ,dx & ! dx is grid point dependent here ,do_ca & ! Flag to turn on cellular automata + ,progsigma & ! Flag to turn on prognostic closure (area fraction) ,ca_deep & ! cellular automaton for deep convection ,mconv & ! integrated vertical advection of moisture ,omeg & ! omega (pa/s) @@ -170,6 +181,9 @@ subroutine cu_unified_deep_run( & real(kind=kind_phys), dimension (its:ite) & ,intent (out ) :: & frh_out,rainevap + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + tmf, qmicro, sigmain, forceqv_spechum real(kind=kind_phys), dimension (its:ite) & ,intent (inout ) :: & pre,xmb_out @@ -193,7 +207,7 @@ subroutine cu_unified_deep_run( & ! real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (in ) :: & - dhdt,rho,t,po,us,vs,tn + dhdt,rho,t,po,us,vs,tn,delp !$acc declare copyin(dhdt,rho,t,po,us,vs,tn) real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (inout ) :: & @@ -202,7 +216,10 @@ subroutine cu_unified_deep_run( & real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (inout) :: & q,qo,zuo,zdo,zdm -!$acc declare copy(q,qo,zuo,zdo,zdm) +!$acc declare sigmaout + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (out) :: & + sigmaout real(kind=kind_phys), dimension (its:ite) & ,intent (in ) :: & dx,z1,psur,xland @@ -215,7 +232,7 @@ subroutine cu_unified_deep_run( & real(kind=kind_phys) & ,intent (in ) :: & - dtime,ccnclean + dtime,ccnclean,fv,r_d ! @@ -311,7 +328,9 @@ subroutine cu_unified_deep_run( & ! dellaqc = change of qc per unit mass flux of cloud ensemble cd,cdd,dellah,dellaq,dellat,dellaqc, & - u_cup,v_cup,uc,vc,ucd,vcd,dellu,dellv + u_cup,v_cup,uc,vc,ucd,vcd,dellu,dellv, & + ! variables needed for prognostic closure + wu2,omega_u,zeta,zdqca,dbyo1,del !$acc declare create( & !$acc entr_rate_2d,mentrd_rate_2d,he,hes,qes,z, heo,heso,qeso,zo, & !$acc xhe,xhes,xqes,xz,xt,xq,qes_cup,q_cup,he_cup,hes_cup,z_cup, & @@ -335,7 +354,7 @@ subroutine cu_unified_deep_run( & edt,edto,edtm,aa1,aa0,xaa0,hkb, & hkbo,xhkb, & xmb,pwavo,ccnloss, & - pwevo,bu,bud,cap_max, & + pwevo,bu,bud,cap_max,wc,omegac,sigmab, & cap_max_increment,closure_n,psum,psumh,sig,sigd real(kind=kind_phys), dimension (its:ite) :: & axx,edtmax,edtmin,entr_rate @@ -353,6 +372,8 @@ subroutine cu_unified_deep_run( & integer, dimension (its:ite), intent(inout) :: ierr integer, dimension (its:ite), intent(in) :: csum + logical, intent(in) :: do_ca, progsigma + logical, intent(in) :: flag_init, flag_restart !$acc declare copy(ierr) copyin(csum) integer :: & iloop,nens3,ki,kk,i,k @@ -368,8 +389,9 @@ subroutine cu_unified_deep_run( & !$acc declare create(lambau,flux_tun,zws,ztexec,zqexec) integer :: jprnt,jmini,start_k22 - logical :: keep_going,flg(its:ite) - logical :: do_ca + logical :: keep_going,flg(its:ite),cnvflg(its:ite) + logical :: flag_shallow + !$acc declare create(flg) character*50 :: ierrc(its:ite) @@ -392,7 +414,7 @@ subroutine cu_unified_deep_run( & real(kind=kind_phys), dimension (its:ite,kts:kte) :: tn_bl, qo_bl, qeso_bl, heo_bl, heso_bl & ,qeso_cup_bl,qo_cup_bl, heo_cup_bl,heso_cup_bl & ,gammao_cup_bl,tn_cup_bl,hco_bl,dbyo_bl - real(kind=kind_phys), dimension(its:ite) :: xf_dicycle + real(kind=kind_phys), dimension(its:ite) :: xf_dicycle,xf_progsigma !$acc declare create(aa1_bl,hkbo_bl,tau_bl,tau_ecmwf,wmean, & !$acc tn_bl, qo_bl, qeso_bl, heo_bl, heso_bl, & !$acc qeso_cup_bl,qo_cup_bl, heo_cup_bl,heso_cup_bl, & @@ -597,6 +619,7 @@ subroutine cu_unified_deep_run( & xz(i,k)=zo(i,k) cupclw(i,k)=0. cd(i,k)=.1*entr_rate(i) !1.e-9 ! 1.*entr_rate + dbyo1(i,k)=0. if(imid.eq.1)cd(i,k)=.5*entr_rate(i) cdd(i,k)=1.e-9 hcdo(i,k)=0. @@ -1120,7 +1143,7 @@ subroutine cu_unified_deep_run( & ! ,pwo,edto,pwdo,melting & ! ,itf,ktf,its,ite, kts,kte, cumulus ) !---meltglac------------------------------------------------- - + !$acc kernels do i=its,itf @@ -1480,8 +1503,20 @@ subroutine cu_unified_deep_run( & enddo !$acc end kernels ! + + do k=kts,ktf + do i=its,itf + if(ierr(i)==0)then + if(k > kbcon(i) .and. k < ktop(i)) then + dbyo1(i,k)=hco(i,k)-heso_cup(i,k) + endif + endif + enddo + enddo + + !> - Call cup_up_aa0() to calculate workfunctions for updrafts -! + call cup_up_aa0(aa0,z,zu,dby,gamma_cup,t_cup, & kbcon,ktop,ierr, & itf,ktf, & @@ -1501,10 +1536,15 @@ subroutine cu_unified_deep_run( & #endif endif enddo + !$acc end kernels -! -!--- diurnal cycle closure +!LB: insert calls to updraft vertical veloicity and prognostic area fraction here: + call calculate_updraft_velocity(its,itf,ktf,ite,kts,kte,ierr,progsigma, & + k22,kbcon,ktop,zo,entr_rate_2d,cd,fv,r_d,el2orc,qeso,tn,qo,po,dbyo, & + clw_all,qrco,delp,zu,wu2,omega_u,zeta,wc,omegac,zdqca) + +!--- diurnal cycle closure ! !--- aa1 from boundary layer (bl) processes only !$acc kernels @@ -2112,15 +2152,40 @@ subroutine cu_unified_deep_run( & mconv(i)=mconv(i)+omeg(i,k)*dq/g enddo enddo + +!> - From Bengtsson et al. (2022) \cite Bengtsson_2022 prognostic closure scheme, +! equation 8, call progsigma_calc() to compute updraft area fraction based on a moisture budget + + if(progsigma)then + flag_shallow = .false. + do k=kts,ktf + do i=its,itf + del(i,k) = delp(i,k)*0.001 + enddo + enddo + do i=its,itf + cnvflg(i)=.false. + enddo + do i=its,itf + if(ierr(i)==0)then + cnvflg(i)=.true. + endif + enddo + call progsigma_calc(itf,ktf,flag_init,flag_restart,flag_shallow, & + del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,xlv,dtime, & + forceqv_spechum,kbcon,ktop,cnvflg, & + sigmain,sigmaout,sigmab) + endif + !$acc end kernels call cup_forcing_ens_3d(closure_n,xland1,aa0,aa1,xaa0_ens,mbdt,dtime, & - ierr,ierr2,ierr3,xf_ens,axx,forcing, & + ierr,ierr2,ierr3,xf_ens,axx,forcing,progsigma, & maxens3,mconv,rand_clos, & po_cup,ktop,omeg,zdo,zdm,k22,zuo,pr_ens,edto,edtm,kbcon, & - ichoice, & + ichoice,omegac,sigmab, & imid,ipr,itf,ktf, & its,ite, kts,kte, & - dicycle,tau_ecmwf,aa1_bl,xf_dicycle) + dicycle,tau_ecmwf,aa1_bl,xf_dicycle,xf_progsigma) ! !$acc kernels do k=kts,ktf @@ -2168,13 +2233,13 @@ subroutine cu_unified_deep_run( & endif call cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat_ens,dellaq_ens, & dellaqc_ens,outt, & - outq,outqc,zuo,pre,pwo_ens,xmb,ktop, & + outq,outqc,zuo,pre,pwo_ens,xmb,ktop,progsigma, & edto,pwdo,'deep',ierr2,ierr3, & po_cup,pr_ens,maxens3, & sig,closure_n,xland1,xmbm_in,xmbs_in, & ichoice,imid,ipr,itf,ktf, & its,ite, kts,kte, & - dicycle,xf_dicycle ) + dicycle,xf_dicycle,xf_progsigma) !> - Call rain_evap_below_cloudbase() to calculate evaporation below cloud base @@ -3141,12 +3206,12 @@ end subroutine cup_env_clev !> Calculates an ensemble of closures and the resulting ensemble !! average to determine cloud base mass-flux. subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2,ierr3,& - xf_ens,axx,forcing,maxens3,mconv,rand_clos, & + xf_ens,axx,forcing,progsigma,maxens3,mconv,rand_clos, & p_cup,ktop,omeg,zd,zdm,k22,zu,pr_ens,edt,edtm,kbcon, & - ichoice, & + ichoice,omegac,sigmab, & imid,ipr,itf,ktf, & its,ite, kts,kte, & - dicycle,tau_ecmwf,aa1_bl,xf_dicycle ) + dicycle,tau_ecmwf,aa1_bl,xf_dicycle,xf_progsigma ) implicit none @@ -3198,7 +3263,7 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 rand_clos real(kind=kind_phys), dimension (its:ite) & ,intent (in ) :: & - aa1,edt,edtm + aa1,edt,edtm,omegac,sigmab real(kind=kind_phys), dimension (its:ite) & ,intent (in ) :: & mconv,axx @@ -3226,9 +3291,12 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 integer & ,intent (in ) :: & ichoice - integer, intent(in) :: dicycle + integer, intent(in) :: dicycle + logical, intent (in) :: progsigma + real(kind=kind_phys), intent(in) , dimension (its:ite) :: aa1_bl,tau_ecmwf real(kind=kind_phys), intent(inout), dimension (its:ite) :: xf_dicycle + real(kind=kind_phys), intent(out), dimension (its:ite) :: xf_progsigma real(kind=kind_phys), intent(inout), dimension (its:ite,10) :: forcing !$acc declare copyin(aa1_bl,tau_ecmwf) copy(xf_dicycle,forcing) !- local var @@ -3248,7 +3316,7 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 ! pcrit,acrit,acritt integer, dimension (its:ite) :: kloc real(kind=kind_phys) :: & - a1,a_ave,xff0,xomg!,aclim1,aclim2,aclim3,aclim4 + a1,a_ave,xff0,xomg,gravinv!,aclim1,aclim2,aclim3,aclim4 real(kind=kind_phys), dimension (its:ite) :: ens_adj !$acc declare create(kloc,ens_adj) @@ -3528,6 +3596,27 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 xf_dicycle(:) = 0. !$acc end kernels endif + + +if(progsigma)then +!Prognostic closure as in Bengtsson et al. 2022 +!$acc kernels + gravinv=1./g + do i=its,itf + xf_progsigma(i)=0 + enddo + do i=its,itf + if(ierr(i)==0)then + xf_progsigma(i)=sigmab(i)*((-1.0*omegac(i))*gravinv) + endif + enddo +else + do i=its,itf + xf_progsigma(i)=0 + enddo +endif + + !--------- @@ -4013,13 +4102,13 @@ end subroutine neg_check !! physical tendencies, precipitation, and mass-flux. subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & outtem,outq,outqc, & - zu,pre,pw,xmb,ktop, & + zu,pre,pw,xmb,ktop,progsigma, & edt,pwd,name,ierr2,ierr3,p_cup,pr_ens, & maxens3, & sig,closure_n,xland1,xmbm_in,xmbs_in, & ichoice,imid,ipr,itf,ktf, & its,ite, kts,kte, & - dicycle,xf_dicycle ) + dicycle,xf_dicycle,xf_progsigma) implicit none ! @@ -4027,6 +4116,7 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & ! ! only local wrf dimensions are need as of now in this routine + logical, intent (in) :: progsigma integer & ,intent (in ) :: & ichoice,imid,ipr,itf,ktf, & @@ -4078,7 +4168,7 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & ,intent (inout) :: & ierr,ierr2,ierr3 integer, intent(in) :: dicycle - real(kind=kind_phys), intent(in), dimension (its:ite) :: xf_dicycle + real(kind=kind_phys), intent(in), dimension (its:ite) :: xf_dicycle, xf_progsigma !$acc declare copyin(zu,pwd,p_cup,sig,xmbm_in,xmbs_in,edt,xff_mid,dellat,dellaqc,dellaq,pw,ktop,xland1,xf_dicycle) !$acc declare copy(xf_ens,pr_ens,outtem,outq,outqc,pre,xmb,closure_n,ierr,ierr2,ierr3) ! @@ -4122,7 +4212,18 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & ! !--- calculate ensemble average mass fluxes ! - + +!LB: Prognostic closure: + if(progsigma)then + + do i=its,itf + if(ierr(i).eq.0)then + xmb(i)=xf_progsigma(i) + write(*,*)'in deep xmb=',xmb(i) + endif + enddo + + else ! !-- now do feedback ! @@ -4204,6 +4305,8 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & !$acc end kernels endif ! imid=1 + endif !Progsigma + !$acc kernels do i=its,itf if(ierr(i).eq.0)then @@ -5735,6 +5838,206 @@ subroutine get_cloud_top(name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo,heso_cup,z_c enddo !$acc end parallel end subroutine get_cloud_top + + subroutine calculate_updraft_velocity(its,itf,ktf,ite,kts,kte,ierr,progsigma, & + k22,kbcon,ktcon,zo,entr_rate_2d,cd,fv,rd,el2orc,qeso,to,qo,po,dbyo, & + clw_all,qlk,delp,zu,wu2,omega_u,zeta,wc,omegac,zdqca) + + implicit none + logical, intent(in) :: progsigma + integer, intent(in) :: itf,its,ktf,ite,kts,kte + integer, dimension (its:ite), intent(inout) :: ierr + real(kind=kind_phys), dimension (its:ite,kts:kte),intent (in) :: zo,entr_rate_2d, & + cd,po,qeso,to,qo,dbyo,clw_all,qlk,delp,zu + integer, dimension (its:ite),intent(in) :: k22,kbcon,ktcon + real(kind=kind_phys), dimension (its:ite) :: sumx + real(kind=kind_phys) ,intent (in) :: fv,rd,el2orc + real(kind=kind_phys), dimension (its:ite,kts:kte) :: drag, buo, zi, del + real(kind=kind_phys), dimension (its:ite,kts:kte),intent (out) :: wu2,omega_u, & + zeta,zdqca + real(kind=kind_phys), dimension (its:ite),intent(out) :: wc,omegac + real(kind=kind_phys) :: rho,bb1,bb2,dz,dp,ptem,tem1,ptem1,tem,rfact,gamma,val + integer :: i,k + + + ! compute updraft velocity square(wu2) + !> - Calculate updraft velocity square(wu2) according to Han et al.'s (2017) \cite han_et_al_2017 equation 7. + !LB: This routine outputs updraft velocity square (m/s), updraft omega_u (Pa/s), and cloud average updraft + !velocity (m/s) and omega_u (Pa/s) in the case progsima is true. + + + do k = 1, ktf + do i = 1,itf + wu2(i,k)=0. + drag(i,k)=0. + buo(i,k)=0. + omega_u(i,k)=0. + zeta(i,k)=0. + zdqca(i,k)=0. + enddo + enddo + + do i=1,itf + wc(i)=0. + omegac(i)=0. + sumx(i)=0. + enddo + + do k = 1, ktf-1 + do i = 1,itf + zi(i,k) = 0.5*(zo(i,k)+zo(i,k+1)) + del(i,k) = delp(i,k)*0.001 + enddo + enddo + + do k = 2, ktf-1 + do i = 1, itf + if (ierr(i)==0) then + if(k >= kbcon(i) .and. k < ktcon(i))then + gamma = el2orc * qeso(i,k+1) / (to(i,k+1)**2) + if(k >= kbcon(i) .and. clw_all(i,k)>0.)then + buo(i,k) = buo(i,k) - g * qlk(i,k) + endif + rfact = 1. + fv * cp * gamma * to(i,k) / xlv + buo(i,k) = buo(i,k) + (g / (cp * to(i,k))) * dbyo(i,k) / (1. + gamma) * rfact + val = 0. + buo(i,k) = buo(i,k) + g * fv * max(val,(qeso(i,k) - qo(i,k))) + buo(i,k) = max(val,buo(i,k)) + drag(i,k) = max(entr_rate_2d(i,k),cd(i,k)) + endif + endif + enddo + enddo + + bb1 = 4.0 + bb2 = 0.8 + do k = 2, ktf-1 + do i = 1, itf + if (ierr(i)==0) then + if(k > kbcon(i) .and. k < ktcon(i)) then + dz = zi(i,k) - zi(i,k-1) + tem = 0.25 * bb1 * (drag(i,k)+drag(i,k-1)) * dz + tem1 = 0.5 * bb2 * (buo(i,k)+buo(i,k-1)) * dz + ptem = (1. - tem) * wu2(i,k-1) + ptem1 = 1. + tem + wu2(i,k) = (ptem + tem1) / ptem1 + wu2(i,k) = max(wu2(i,k), 0.) + endif + endif + enddo + enddo + + if(progsigma)then + do k = 2, ktf-1 + do i = 1, itf + if (ierr(i)==0) then + if(k > kbcon(i) .and. k < ktcon(i)) then + rho = po(i,k)*100. / (rd * to(i,k)) + omega_u(i,k)=-1.0*sqrt(wu2(i,k))*rho*g + omega_u(i,k)=MAX(omega_u(i,k),-80.) + endif + endif + enddo + enddo + endif + + ! compute updraft velocity average over the whole cumulus +!> - Calculate the mean updraft velocity within the cloud (wc). + + do i = 1, itf + wc(i) = 0. + sumx(i) = 0. + enddo + do k = 2, ktf-1 + do i = 1, itf + if (ierr(i)==0) then + if(k > kbcon(i) .and. k < ktcon(i)) then + dz = zi(i,k) - zi(i,k-1) + tem = 0.5 * (sqrt(wu2(i,k)) + sqrt(wu2(i,k-1))) + wc(i) = wc(i) + tem * dz + sumx(i) = sumx(i) + dz + endif + endif + enddo + enddo + do i = 1, itf + if(ierr(i)==0) then + if(sumx(i) == 0.) then + ierr(i)=1 + else + wc(i) = wc(i) / sumx(i) + endif + val = 1.e-4 + if (wc(i) < val) ierr(i)=1 + endif + enddo + + !> - For progsigma = T, calculate the mean updraft velocity within the cloud (omegac),cast in pressure coordinates. + + if(progsigma)then + do i = 1, itf + omegac(i) = 0. + sumx(i) = 0. + enddo + do k = 2, ktf-1 + do i = 1, itf + if (ierr(i)==0) then + if(k > kbcon(i) .and. k < ktcon(i)) then + dp = 1000. * del(i,k) + tem = 0.5 * (omega_u(i,k) + omega_u(i,k-1)) + omegac(i) = omegac(i) + tem * dp + sumx(i) = sumx(i) + dp + endif + endif + enddo + enddo + do i = 1, itf + if(ierr(i)==0) then + if(sumx(i) == 0.) then + ierr(i)=1 + else + omegac(i) = omegac(i) / sumx(i) + endif + val = -1.2 + if (omegac(i) > val) ierr(i)=1 + endif + enddo + + !> - For progsigma = T, calculate the xi term in Bengtsson et al. 2022 \cite Bengtsson_2022 (equation 8) + do k = 2, ktf-1 + do i = 1, itf + if (ierr(i)==0) then + if(k >= kbcon(i) .and. k < ktcon(i)) then + if(omega_u(i,k) .ne. 0.)then + zeta(i,k)=zu(i,k)*(omegac(i)/omega_u(i,k)) + else + zeta(i,k)=0. + endif + zeta(i,k)=MAX(0.,zeta(i,k)) + zeta(i,k)=MIN(1.,zeta(i,k)) + endif + endif + enddo + enddo + + endif + + !store term needed for "termC" in prognostic area fraction closure + if(progsigma)then + do k = 2, ktf-1 + do i = 1, itf + if (ierr(i)==0) then + if(k > kbcon(i) .and. k < ktcon(i)) then + zdqca(i,k)=clw_all(i,k)*zu(i,k) + endif + endif + enddo + enddo + endif + + + end subroutine calculate_updraft_velocity + !------------------------------------------------------------------------------------ !> @} end module cu_unified_deep diff --git a/physics/cu_unified_driver.F90 b/physics/cu_unified_driver.F90 index 478fd254a..3439a9a39 100644 --- a/physics/cu_unified_driver.F90 +++ b/physics/cu_unified_driver.F90 @@ -57,7 +57,8 @@ end subroutine cu_unified_driver_init !! !>\section gen_unified_driver Grell-Freitas Cumulus Scheme Driver General Algorithm subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& - do_ca,cactiv,cactiv_m,g,cp,xlv,r_v,forcet,forceqv_spechum,phil,raincv, & + do_ca,progsigma,cactiv,cactiv_m,g,cp,fv,r_d,xlv,r_v,forcet, & + forceqv_spechum,phil,delp,raincv,tmf,qmicro,sigmain, & qv_spechum,t,cld1d,us,vs,t2di,w,qv2di_spechum,p2di,psuri, & hbot,htop,kcnv,xland,hfx2,qfx2,aod_gf,cliw,clcw,ca_deep,rainevap,& pbl,ud_mf,dd_mf,dt_mf,cnvw_moist,cnvc,imfshalcnv, & @@ -66,7 +67,7 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& index_of_y_wind,index_of_process_scnv,index_of_process_dcnv, & fhour,fh_dfi_radar,ix_dfi_radar,num_dfi_radar,cap_suppress, & dfi_radar_max_intervals,ldiag3d,qci_conv,do_cap_suppress, & - errmsg,errflg) + sigmaout,errmsg,errflg) !------------------------------------------------------------- implicit none integer, parameter :: maxiens=1 @@ -92,8 +93,9 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& integer :: its,ite, jts,jte, kts,kte integer, intent(in ) :: im,km,ntracer logical, intent(in ) :: flag_init, flag_restart - logical, intent(in ) :: flag_for_scnv_generic_tend,flag_for_dcnv_generic_tend,do_ca - real (kind=kind_phys), intent(in) :: g,cp,xlv,r_v + logical, intent(in ) :: flag_for_scnv_generic_tend,flag_for_dcnv_generic_tend, & + do_ca,progsigma + real (kind=kind_phys), intent(in) :: g,cp,fv,r_d,xlv,r_v logical, intent(in ) :: ldiag3d real(kind=kind_phys), intent(inout) :: dtend(:,:,:) @@ -102,10 +104,12 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& index_of_x_wind, index_of_y_wind, index_of_temperature, & index_of_process_scnv, index_of_process_dcnv, ntqv, ntcw, ntiw !$acc declare copyin(dtidx) - real(kind=kind_phys), dimension( : , : ), intent(in ) :: forcet,forceqv_spechum,w,phil + real(kind=kind_phys), dimension( : , : ), intent(in ) :: forcet,forceqv_spechum,w,phil,delp + real(kind=kind_phys), dimension ( : , : ), intent(in ) :: sigmain,qmicro,tmf real(kind=kind_phys), dimension( : , : ), intent(inout ) :: t,us,vs real(kind=kind_phys), dimension( : , : ), intent(inout ) :: qci_conv real(kind=kind_phys), dimension( : , : ), intent(out ) :: cnvw_moist,cnvc + real(kind=kind_phys), dimension ( : , : ), intent(out ) :: sigmaout real(kind=kind_phys), dimension( : , : ), intent(inout ) :: cliw, clcw !$acc declare copyin(forcet,forceqv_spechum,w,phil) !$acc declare copy(t,us,vs,qci_conv,cliw, clcw) @@ -343,7 +347,7 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ! tscl_kf=dx/25000. !$acc end kernels - if (imfshalcnv == 3) then + if (imfshalcnv == 5) then ishallow_g3 = 1 else ishallow_g3 = 0 @@ -633,6 +637,9 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ! input variables. ierr should be initialized to zero or larger than zero for ! turning off shallow convection for grid points zus,xmbs,kbcons,ktops,k22s,ierrs,ierrcs, & +!Prog closure + flag_init, flag_restart,fv,r_d,delp,tmf,qmicro, & + forceqv_spechum,sigmain,sigmaout,progsigma, & ! output tendencies outts,outqs,outqcs,outus,outvs,cnvwt,prets,cupclws, & ! dimesnional variables @@ -653,9 +660,12 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& !> - Call cu_unified_deep_run() for middle GF convection if(imid_gf == 1)then call cu_unified_deep_run( & - itf,ktf,its,ite, kts,kte & - ,dicycle_m & - ,ichoicem & + itf,ktf,its,ite, kts,kte & + ,flag_init & + ,flag_restart & + ,fv,r_d & + ,dicycle_m & + ,ichoicem & ,ipr & ,ccn_m & ,ccnclean & @@ -664,11 +674,16 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,kpbli & ,dhdt & ,xlandi & - + ,delp & ,zo & ,forcing2 & ,t2d & ,q2d & + ,tmf & + ,qmicro & + ,forceqv_spechum & + ,sigmain & + ,sigmaout & ,ter11 & ,tshall & ,qshall & @@ -680,7 +695,8 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,hfx & ,qfx & ,dx & !hj dx(im) - ,do_ca & + ,do_ca & + ,progsigma & ,ca_deep & ,mconv & ,omeg & @@ -736,7 +752,9 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& if(ideep.eq.1)then call cu_unified_deep_run( & itf,ktf,its,ite, kts,kte & - + ,flag_init & + ,flag_restart & + ,fv,r_d & ,dicycle & ,ichoice & ,ipr & @@ -744,15 +762,19 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,ccnclean & ,dt & ,0 & - ,kpbli & ,dhdt & ,xlandi & - + ,delp & ,zo & ,forcing & ,t2d & ,q2d & + ,tmf & + ,qmicro & + ,forceqv_spechum & + ,sigmain & + ,sigmaout & ,ter11 & ,tn & ,qo & @@ -765,6 +787,7 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,qfx & ,dx & !hj replace dx(im) ,do_ca & + ,progsigma & ,ca_deep & ,mconv & ,omeg & diff --git a/physics/cu_unified_driver.meta b/physics/cu_unified_driver.meta index 67cd71203..1990ad59a 100644 --- a/physics/cu_unified_driver.meta +++ b/physics/cu_unified_driver.meta @@ -126,6 +126,13 @@ units = flag dimensions = () type = logical + intent = in +[progsigma] + standard_name = do_prognostic_updraft_area_fraction + long_name = flag for prognostic sigma in cumuls scheme + units = flag + dimensions = () + type = logical intent = in [cactiv] standard_name = counter_for_grell_freitas_convection @@ -157,6 +164,14 @@ type = real kind = kind_phys intent = in +[fv] + standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one + long_name = (rv/rd) - 1 (rv = ideal gas constant for water vapor) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in [xlv] standard_name = latent_heat_of_vaporization_of_water_at_0C long_name = latent heat of evaporation/sublimation @@ -173,6 +188,14 @@ type = real kind = kind_phys intent = in +[r_d] + standard_name = gas_constant_of_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in [forcet] standard_name = tendency_of_air_temperature_due_to_nonphysics long_name = temperature tendency due to dynamics only @@ -189,6 +212,38 @@ type = real kind = kind_phys intent = in +[tmf] + standard_name = instantaneous_tendency_of_specific_humidity_due_to_PBL + long_name = instantaneous_tendency_of_specific_humidity_due_to_PBL + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[qmicro] + standard_name = instantaneous_tendency_of_specific_humidity_due_to_microphysics + long_name = moisture tendency due to microphysics + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[sigmain] + standard_name = prognostic_updraft_area_fraction_in_convection + long_name = convective updraft area fraction + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[sigmaout] + standard_name = updraft_area_fraction_updated_by_physics + long_name = convective updraft area fraction updated by physics + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out [phil] standard_name = geopotential long_name = layer geopotential @@ -197,6 +252,14 @@ type = real kind = kind_phys intent = in +[delp] + standard_name = air_pressure_difference_between_midlayers + long_name = pres(k) - pres(k+1) + units = Pa + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in [raincv] standard_name = lwe_thickness_of_deep_convective_precipitation_amount long_name = deep convective rainfall amount on physics timestep diff --git a/physics/cu_unified_sh.F90 b/physics/cu_unified_sh.F90 index f0d0455f4..c3e2fb755 100644 --- a/physics/cu_unified_sh.F90 +++ b/physics/cu_unified_sh.F90 @@ -65,19 +65,24 @@ subroutine cu_unified_sh_run ( & us,vs,zo,t,q,z1,tn,qo,po,psur,dhdt,kpbl,rho, & ! input variables, must be supplied hfx,qfx,xland,ichoice,tcrit,dtime, & zuo,xmb_out,kbcon,ktop,k22,ierr,ierrc, & + flag_init, flag_restart,fv,r_d,delp,tmf,qmicro, & + forceqv_spechum,sigmain,sigmaout,progsigma, & outt,outq,outqc,outu,outv,cnvwt,pre,cupclw, & ! output tendencies itf,ktf,its,ite, kts,kte,ipr,tropics) ! dimesnional variables ! ! this module needs some subroutines from gf_deep ! use cu_unified_deep,only:cup_env,cup_env_clev,get_cloud_bc,cup_minimi, & - get_inversion_layers,rates_up_pdf,get_cloud_bc, & - cup_up_aa0,cup_kbcon,get_lateral_massflux + get_inversion_layers,rates_up_pdf,get_cloud_bc, & + cup_up_aa0,cup_kbcon,get_lateral_massflux, & + calculate_updraft_velocity + implicit none integer & ,intent (in ) :: & itf,ktf, & its,ite, kts,kte,ipr + logical, intent(in) :: flag_init, flag_restart, progsigma logical :: make_calc_for_xk = .true. integer, intent (in ) :: & ichoice @@ -92,6 +97,9 @@ subroutine cu_unified_sh_run ( & ,intent (inout ) :: & cnvwt,outt,outq,outqc,cupclw,zuo,outu,outv !$acc declare copy(cnvwt,outt,outq,outqc,cupclw,zuo,outu,outv) + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (in ) :: & + tmf, qmicro, sigmain, forceqv_spechum real(kind=kind_phys), dimension (its:ite) & ,intent (out ) :: & xmb_out @@ -111,7 +119,7 @@ subroutine cu_unified_sh_run ( & ! real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (in ) :: & - t,po,tn,dhdt,rho,us,vs + t,po,tn,dhdt,rho,us,vs,delp real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (inout) :: & q,qo @@ -121,7 +129,13 @@ subroutine cu_unified_sh_run ( & real(kind=kind_phys) & ,intent (in ) :: & - dtime,tcrit + dtime,tcrit,fv,r_d +!$acc declare sigmaout + real(kind=kind_phys), dimension (its:ite,kts:kte) & + ,intent (out) :: & + sigmaout + + !$acc declare copyin(t,po,tn,dhdt,rho,us,vs) copy(q,qo) copyin(xland,z1,psur,hfx,qfx) copyin(dtime,tcrit) ! !***************** the following are your basic environmental @@ -180,7 +194,8 @@ subroutine cu_unified_sh_run ( & ! dellaq = change of q per unit mass flux of cloud ensemble ! dellaqc = change of qc per unit mass flux of cloud ensemble - cd,dellah,dellaq,dellat,dellaqc,uc,vc,dellu,dellv,u_cup,v_cup + cd,dellah,dellaq,dellat,dellaqc,uc,vc,dellu,dellv,u_cup,v_cup, & + wu2,omega_u,zeta,zdqca,del,clw_all !$acc declare create( & !$acc entr_rate_2d,he,hes,qes,z, & @@ -205,7 +220,7 @@ subroutine cu_unified_sh_run ( & flux_tun,hkbo,xhkb, & rand_vmas,xmbmax,xmb, & cap_max,entr_rate, & - cap_max_increment,lambau + cap_max_increment,lambau,wc,omegac,sigmab integer, dimension (its:ite) :: & kstabi,xland1,kbmax,ktopx !$acc declare create( & @@ -216,11 +231,13 @@ subroutine cu_unified_sh_run ( & !$acc cap_max_increment,lambau, & !$acc kstabi,xland1,kbmax,ktopx) + logical :: flag_shallow + logical, dimension(its:ite) :: cnvflg integer :: & kstart,i,k,ki real(kind=kind_phys) :: & dz,mbdt,zkbmax, & - cap_maxs,trash,trash2,frh + cap_maxs,trash,trash2,frh,el2orc,gravinv real(kind=kind_phys) buo_flux,pgeoh,dp,entup,detup,totmas @@ -245,6 +262,8 @@ subroutine cu_unified_sh_run ( & c1d(:,:)=0. !$acc end kernels + el2orc=xlv*xlv/(r_v*cp) + !$acc kernels do i=its,itf xland1(i)=int(xland(i)+.001) ! 1. @@ -434,6 +453,7 @@ subroutine cu_unified_sh_run ( & do i=its,itf do k=kts,ktf dbyo(i,k)= 0. !hkbo(i)-heso_cup(i,k) + clw_all(i,k)=0. enddo enddo !$acc end kernels @@ -652,6 +672,7 @@ subroutine cu_unified_sh_run ( & c1d(i,k)=0. endif pwo(i,k)=c0_shal*dz*qrco(i,k)*zuo(i,k) + clw_all(i,k)=qco(i,k)-trash !LB total cloud before rain and detrain ! cloud water vapor qco (i,k)= trash+qrco(i,k) @@ -715,6 +736,13 @@ subroutine cu_unified_sh_run ( & enddo !$acc end kernels endif + +!LB: insert calls to updraft vertical veloicity and prognostic area fraction here: + call calculate_updraft_velocity(its,itf,ktf,ite,kts,kte,ierr,progsigma, & + k22,kbcon,ktop,zo,entr_rate_2d,cd,fv,r_d,el2orc,qeso,tn,qo,po,dbyo, & + clw_all,qrco,delp,zu,wu2,omega_u,zeta,wc,omegac,zdqca) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -921,7 +949,31 @@ subroutine cu_unified_sh_run ( & enddo !$acc end kernels -! + +!> - From Bengtsson et al. (2022) \cite Bengtsson_2022 prognostic closure scheme, +! equation 8, call progsigma_calc() to compute updraft area fraction based on a moisture budget + if(progsigma)then + flag_shallow = .true. + do k=kts,ktf + do i=its,itf + del(i,k) = delp(i,k)*0.001 + enddo + enddo + do i=its,itf + cnvflg(i)=.false. + enddo + do i=its,itf + if(ierr(i)==0)then + cnvflg(i)=.true. + endif + enddo + call progsigma_calc(itf,ktf,flag_init,flag_restart,flag_shallow, & + del,tmf,qmicro,dbyo,zdqca,omega_u,zeta,xlv,dtime, & + forceqv_spechum,kbcon,ktop,cnvflg, & + sigmain,sigmaout,sigmab) + + endif + !--- workfunctions for updraft ! call cup_up_aa0(xaa0,xz,xzu,xdby,gamma_cup,xt_cup, & @@ -936,8 +988,18 @@ subroutine cu_unified_sh_run ( & ! !$acc kernels !$acc loop private(xff_shal) - do i=its,itf - xmb(i)=0. + do i=its,itf + xmb(i)=0. + + if(progsigma)then + gravinv = 1./g + if(ierr(i)==0)then + xmb(i) = sigmab(i)*((-1.0*omegac(i))*gravinv) + write(*,*)'in shallow xmb=',xmb(i) + endif + + else + xff_shal(1:3)=0. if(ierr(i).eq.0)then xmbmax(i)=1.0 @@ -974,6 +1036,9 @@ subroutine cu_unified_sh_run ( & #endif endif endif + + endif !progsigma + if(ierr(i).ne.0)then k22 (i)=0 kbcon(i)=0 @@ -1008,7 +1073,8 @@ subroutine cu_unified_sh_run ( & enddo endif - enddo + + enddo ! ! since kinetic energy is being dissipated, add heating accordingly (from ecmwf) ! diff --git a/physics/progsigma_calc.f90 b/physics/progsigma_calc.f90 index eaa1d3fda..dda33d41c 100644 --- a/physics/progsigma_calc.f90 +++ b/physics/progsigma_calc.f90 @@ -13,8 +13,8 @@ !!\section gen_progsigma progsigma_calc General Algorithm subroutine progsigma_calc (im,km,flag_init,flag_restart, & flag_shallow,del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,hvap, & - delt,prevsq,q,kbcon1,ktcon,cnvflg,sigmain,sigmaout, & - sigmab,errmsg,errflg) + delt,qadv,kbcon1,ktcon,cnvflg,sigmain,sigmaout, & + sigmab) ! ! use machine, only : kind_phys @@ -25,7 +25,7 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & ! intent in integer, intent(in) :: im,km,kbcon1(im),ktcon(im) real(kind=kind_phys), intent(in) :: hvap,delt - real(kind=kind_phys), intent(in) :: prevsq(im,km), q(im,km),del(im,km), & + real(kind=kind_phys), intent(in) :: qadv(im,km),del(im,km), & qmicro(im,km),tmf(im,km),dbyo1(im,km),zdqca(im,km), & omega_u(im,km),zeta(im,km) logical, intent(in) :: flag_init,flag_restart,cnvflg(im),flag_shallow @@ -34,14 +34,13 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & ! intent out real(kind=kind_phys), intent(out) :: sigmaout(im,km) real(kind=kind_phys), intent(out) :: sigmab(im) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg + ! Local variables integer :: i,k,km1 real(kind=kind_phys) :: termA(im),termB(im),termC(im),termD(im) real(kind=kind_phys) :: mcons(im),fdqa(im),form(im,km), & - qadv(im,km),dp(im,km),inbu(im,km) + dp(im,km),inbu(im,km) real(kind=kind_phys) :: gcvalmx,epsilon,ZZ,cvg,mcon,buy2, & @@ -77,21 +76,6 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & mcons(i)=0. enddo - !Initial computations, dynamic q-tendency - if(flag_init .and. .not.flag_restart)then - do k = 1,km - do i = 1,im - qadv(i,k)=0. - enddo - enddo - else - do k = 1,km - do i = 1,im - qadv(i,k)=(q(i,k) - prevsq(i,k))*invdelt - enddo - enddo - endif - do k = 2,km1 do i = 1,im if(cnvflg(i))then @@ -133,7 +117,8 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & mcon = (hvap*(qadv(i,k)+tmf(i,k)+qmicro(i,k))*dp(i,k)) buy2 = termD(i)+mcon+mcons(i) ! Do the integral over buoyant layers with positive mcon acc from surface - if(k > kbcon1(i) .and. k < ktcon(i) .and. buy2 > 0.)then + !if(k > kbcon1(i) .and. k < ktcon(i) .and. buy2 > 0.)then + if(dbyo1(i,k)>0 .and. buy2 > 0.)then inbu(i,k)=1. endif inbu(i,k-1)=MAX(inbu(i,k-1),inbu(i,k)) @@ -215,6 +200,7 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & if(cnvflg(i)) then sigmab(i)=sigmab(i)/betascu sigmab(i)=MAX(0.03,sigmab(i)) + write(*,*)'sigmab shallow=',sigmab(i) endif enddo else @@ -222,6 +208,7 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & if(cnvflg(i)) then sigmab(i)=sigmab(i)/betadcu sigmab(i)=MAX(0.01,sigmab(i)) + write(*,*)'sigmab deep=',sigmab(i) endif enddo endif diff --git a/physics/samfdeepcnv.f b/physics/samfdeepcnv.f index 2a3c256a9..dc5236531 100644 --- a/physics/samfdeepcnv.f +++ b/physics/samfdeepcnv.f @@ -209,9 +209,9 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & & bb1, bb2, wucb ! ! parameters for prognostic sigma closure - real(kind=kind_phys) omega_u(im,km),zdqca(im,km),qlks(im,km), - & omegac(im),zeta(im,km),dbyo1(im,km),sigmab(im) - real(kind=kind_phys) gravinv + real(kind=kind_phys) omega_u(im,km),zdqca(im,km), + & omegac(im),zeta(im,km),dbyo1(im,km),sigmab(im),qadv(im,km) + real(kind=kind_phys) gravinv,invdelt logical flag_shallow c physical parameters ! parameter(grav=grav,asolfac=0.958) @@ -306,6 +306,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & errflg = 0 gravinv = 1./grav + invdelt = 1./delt elocp = hvap/cp el2orc = hvap*hvap/(rv*cp) @@ -585,7 +586,6 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & do i = 1, im dbyo1(i,k)=0. zdqca(i,k)=0. - qlks(i,k)=0. omega_u(i,k)=0. zeta(i,k)=1.0 enddo @@ -1515,7 +1515,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & pwavo(i) = pwavo(i) + pwo(i,k) ! cnvwt(i,k) = (etah*qlk + pwo(i,k)) * grav / dp cnvwt(i,k) = etah * qlk * grav / dp - qlks(i,k)=qlk + zdqca(i,k)=dq endif ! ! compute buoyancy and drag for updraft velocity @@ -1690,7 +1690,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & pwavo(i) = pwavo(i) + pwo(i,k) ! cnvwt(i,k) = (etah*qlk + pwo(i,k)) * grav / dp cnvwt(i,k) = etah * qlk * grav / dp - qlks(i,k)=qlk + zdqca(i,k)=dq endif endif endif @@ -1860,28 +1860,13 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & if(dq > 0.) then qlko_ktcon(i) = dq qcko(i,k) = qrch - qlks(i,k) = qlko_ktcon(i) + zdqca(i,k) = dq endif endif enddo endif c -c store term needed for "termC" in prognostic area fraction closure - if(progsigma)then - do k = 2, km1 - do i = 1, im - dp = 1000. * del(i,k) - if (cnvflg(i)) then - if(k > kbcon(i) .and. k < ktcon(i)) then - zdqca(i,k)=((qlks(i,k)-qlks(i,k-1)) + - & pwo(i,k)+dellal(i,k)) - endif - endif - enddo - enddo - endif - ccccc if(lat.==.latd.and.lon.==.lond.and.cnvflg(i)) then ccccc print *, ' aa1(i) before dwndrft =', aa1(i) ccccc endif @@ -2885,11 +2870,27 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & !> - From Bengtsson et al. (2022) \cite Bengtsson_2022 prognostic closure scheme, equation 8, call progsigma_calc() to compute updraft area fraction based on a moisture budget if(progsigma)then + +!Initial computations, dynamic q-tendency + if(first_time_step .and. .not.restart)then + do k = 1,km + do i = 1,im + qadv(i,k)=0. + enddo + enddo + else + do k = 1,km + do i = 1,im + qadv(i,k)=(q(i,k) - prevsq(i,k))*invdelt + enddo + enddo + endif + flag_shallow = .false. call progsigma_calc(im,km,first_time_step,restart,flag_shallow, & del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,hvap,delt, - & prevsq,q,kbcon1,ktcon,cnvflg, - & sigmain,sigmaout,sigmab,errmsg,errflg) + & qadv,kbcon1,ktcon,cnvflg, + & sigmain,sigmaout,sigmab) endif !> - From Han et al.'s (2017) \cite han_et_al_2017 equation 6, calculate cloud base mass flux as a function of the mean updraft velcoity for the grid sizes where the quasi-equilibrium assumption of Arakawa-Schubert is not valid any longer. @@ -2901,6 +2902,8 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & rho = po(i,k)*100. / (rd*to(i,k)) if(progsigma)then xmb(i) = advfac(i)*sigmab(i)*((-1.0*omegac(i))*gravinv) + write(*,*)'in samfdeep xmb=',sigmab(i)* + & ((-1.0*omegac(i))*gravinv) else xmb(i) = advfac(i)*betaw*rho*wc(i) endif diff --git a/physics/samfshalcnv.f b/physics/samfshalcnv.f index 645024536..7fec49d62 100644 --- a/physics/samfshalcnv.f +++ b/physics/samfshalcnv.f @@ -156,10 +156,10 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & cc ! parameters for prognostic sigma closure - real(kind=kind_phys) omega_u(im,km),zdqca(im,km),qlks(im,km), + real(kind=kind_phys) omega_u(im,km),zdqca(im,km), & omegac(im),zeta(im,km),dbyo1(im,km), - & sigmab(im) - real(kind=kind_phys) gravinv,dxcrtas + & sigmab(im),qadv(im,km) + real(kind=kind_phys) gravinv,dxcrtas,invdelt logical flag_shallow c physical parameters ! parameter(g=grav,asolfac=0.89) @@ -247,6 +247,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & errflg = 0 gravinv = 1./grav + invdelt = 1./delt elocp = hvap/cp el2orc = hvap*hvap/(rv*cp) @@ -524,7 +525,6 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & do i = 1, im dbyo1(i,k)=0. zdqca(i,k)=0. - qlks(i,k)=0. omega_u(i,k)=0. zeta(i,k)=1.0 enddo @@ -1270,7 +1270,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & qcko(i,k)= qlk + qrch pwo(i,k) = etah * c0t(i,k) * dz * qlk cnvwt(i,k) = etah * qlk * grav / dp - qlks(i,k)=qlk + zdqca(i,k)=dq endif ! ! compute buoyancy and drag for updraft velocity @@ -1435,7 +1435,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & qcko(i,k) = qlk + qrch pwo(i,k) = etah * c0t(i,k) * dz * qlk cnvwt(i,k) = etah * qlk * grav / dp - qlks(i,k)=qlk + zdqca(i,k)=dq endif endif endif @@ -1601,24 +1601,13 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & if(dq > 0.) then qlko_ktcon(i) = dq qcko(i,k) = qrch - qlks(i,k) = qlko_ktcon(i) + zdqca(i,k) = dq endif endif enddo endif c - do k = 2, km1 - do i = 1, im - if (cnvflg(i)) then - if(k > kbcon(i) .and. k < ktcon(i)) then - zdqca(i,k)=((qlks(i,k)-qlks(i,k-1)) + - & pwo(i,k)+dellal(i,k)) - endif - endif - enddo - enddo - c--- compute precipitation efficiency in terms of windshear c !! - Calculate the wind shear and precipitation efficiency according to equation 58 in Fritsch and Chappell (1980) \cite fritsch_and_chappell_1980 : @@ -1935,11 +1924,25 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & c !> - From Bengtsson et al. (2022) \cite Bengtsson_2022 prognostic closure scheme, equation 8, call progsigma_calc() to compute updraft area fraction based on a moisture budget if(progsigma)then +! Initial computations, dynamic q-tendency + if(first_time_step .and. .not.restart)then + do k = 1,km + do i = 1,im + qadv(i,k)=0. + enddo + enddo + else + do k = 1,km + do i = 1,im + qadv(i,k)=(q(i,k) - prevsq(i,k))*invdelt + enddo + enddo + endif flag_shallow = .true. call progsigma_calc(im,km,first_time_step,restart,flag_shallow, & del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,hvap,delt, - & prevsq,q,kbcon1,ktcon,cnvflg, - & sigmain,sigmaout,sigmab,errmsg,errflg) + & qadv,kbcon1,ktcon,cnvflg, + & sigmain,sigmaout,sigmab) endif !> - From Han et al.'s (2017) \cite han_et_al_2017 equation 6, calculate cloud base mass flux as a function of the mean updraft velcoity. @@ -1951,6 +1954,8 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & rho = po(i,k)*100. / (rd*to(i,k)) if(progsigma .and. gdx(i) < dxcrtas)then xmb(i) = advfac(i)*sigmab(i)*((-1.0*omegac(i))*gravinv) + write(*,*)'in samfsal xmb=',sigmab(i)* + & ((-1.0*omegac(i))*gravinv) else xmb(i) = advfac(i)*betaw*rho*wc(i) endif From 40f93615293f648b8473ffff101a372c4ad781f1 Mon Sep 17 00:00:00 2001 From: "Haiqin.Li" Date: Mon, 13 Mar 2023 17:20:01 +0000 Subject: [PATCH 152/380] "include the MYNN-EDMF update from PR #43" --- physics/module_bl_mynn.F90 | 3172 ++++++++++++++++----------------- physics/mynnedmf_wrapper.F90 | 424 ++--- physics/mynnedmf_wrapper.meta | 60 +- physics/sgscloud_radpre.F90 | 132 +- physics/sgscloud_radpre.meta | 38 + 5 files changed, 1965 insertions(+), 1861 deletions(-) diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index d1fae478d..51a906faf 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -121,7 +121,7 @@ ! Hybrid PBL height diagnostic, which blends a theta-v-based ! definition in neutral/convective BL and a TKE-based definition ! in stable conditions. -! TKE budget output option (bl_mynn_tkebudget) +! TKE budget output option ! v3.5.0: TKE advection option (bl_mynn_tkeadvect) ! v3.5.1: Fog deposition related changes. ! v3.6.0: Removed fog deposition from the calculation of tendencies @@ -216,14 +216,14 @@ ! Misc small-impact bugfixes: ! 1) dz was incorrectly indexed in mym_condensation ! 2) configurations with icloud_bl = 0 were using uninitialized arrays -! v4.4 / CCPP +! v4.5 / CCPP ! This version includes many modifications that proved valuable in the global ! framework and removes some key lingering bugs in the mixing of chemical species. ! TKE Budget output fixed (Puhales, 2020-12) ! New option for stability function: (Puhales, 2020-12) ! bl_mynn_stfunc = 0 (original, Kansas-type function, Paulson, 1970 ) ! bl_mynn_stfunc = 1 (expanded range, same as used for Jimenez et al (MWR) -! see the Technical Note for this implementation. +! see the Technical Note for this implementation (small impact). ! Improved conservation of momentum and higher-order moments. ! Important bug fixes for mixing of chemical species. ! Addition of pressure-gradient effects on updraft momentum transport. @@ -253,58 +253,48 @@ MODULE module_bl_mynn IMPLICIT NONE -!get rid - INTEGER , PARAMETER :: param_first_scalar = 1, & - & p_qc = 2, & - & p_qr = 0, & - & p_qi = 2, & - & p_qs = 0, & - & p_qg = 0, & - & p_qnc= 0, & - & p_qni= 0 - !=================================================================== ! From here on, these are MYNN-specific parameters: ! The parameters below depend on stability functions of module_sf_mynn. - REAL, PARAMETER :: cphm_st=5.0, cphm_unst=16.0, & - cphh_st=5.0, cphh_unst=16.0 + real(kind_phys), PARAMETER :: cphm_st=5.0, cphm_unst=16.0, & + cphh_st=5.0, cphh_unst=16.0 ! Closure constants - REAL, PARAMETER :: & - &pr = 0.74, & - &g1 = 0.235, & ! NN2009 = 0.235 - &b1 = 24.0, & - &b2 = 15.0, & ! CKmod NN2009 - &c2 = 0.729, & ! 0.729, & !0.75, & - &c3 = 0.340, & ! 0.340, & !0.352, & - &c4 = 0.0, & - &c5 = 0.2, & + real(kind_phys), PARAMETER :: & + &pr = 0.74, & + &g1 = 0.235, & ! NN2009 = 0.235 + &b1 = 24.0, & + &b2 = 15.0, & ! CKmod NN2009 + &c2 = 0.729, & ! 0.729, & !0.75, & + &c3 = 0.340, & ! 0.340, & !0.352, & + &c4 = 0.0, & + &c5 = 0.2, & &a1 = b1*( 1.0-3.0*g1 )/6.0, & ! &c1 = g1 -1.0/( 3.0*a1*b1**(1.0/3.0) ), & &c1 = g1 -1.0/( 3.0*a1*2.88449914061481660), & &a2 = a1*( g1-c1 )/( g1*pr ), & &g2 = b2/b1*( 1.0-c3 ) +2.0*a1/b1*( 3.0-2.0*c2 ) - REAL, PARAMETER :: & - &cc2 = 1.0-c2, & - &cc3 = 1.0-c3, & - &e1c = 3.0*a2*b2*cc3, & - &e2c = 9.0*a1*a2*cc2, & + real(kind_phys), PARAMETER :: & + &cc2 = 1.0-c2, & + &cc3 = 1.0-c3, & + &e1c = 3.0*a2*b2*cc3, & + &e2c = 9.0*a1*a2*cc2, & &e3c = 9.0*a2*a2*cc2*( 1.0-c5 ), & - &e4c = 12.0*a1*a2*cc2, & + &e4c = 12.0*a1*a2*cc2, & &e5c = 6.0*a1*a1 ! Constants for min tke in elt integration (qmin), max z/L in els (zmax), ! and factor for eddy viscosity for TKE (Kq = Sqfac*Km): - REAL, PARAMETER :: qmin=0.0, zmax=1.0, Sqfac=3.0 + real(kind_phys), PARAMETER :: qmin=0.0, zmax=1.0, Sqfac=3.0 ! Note that the following mixing-length constants are now specified in mym_length ! &cns=3.5, alp1=0.23, alp2=0.3, alp3=3.0, alp4=10.0, alp5=0.2 - REAL, PARAMETER :: gpw=5./3., qcgmin=1.e-8, qkemin=1.e-12 - REAL, PARAMETER :: tliq = 269. !all hydrometeors are liquid when T > tliq + real(kind_phys), PARAMETER :: gpw=5./3., qcgmin=1.e-8, qkemin=1.e-12 + real(kind_phys), PARAMETER :: tliq = 269. !all hydrometeors are liquid when T > tliq ! Constants for cloud PDF (mym_condensation) - REAL, PARAMETER :: rr2=0.7071068, rrp=0.3989423 + real(kind_phys), PARAMETER :: rr2=0.7071068, rrp=0.3989423 !>Use Canuto/Kitamura mod (remove Ric and negative TKE) (1:yes, 0:no) !!For more info, see Canuto et al. (2008 JAS) and Kitamura (Journal of the @@ -314,12 +304,12 @@ MODULE module_bl_mynn !!(above) back to NN2009 values (see commented out lines next to the !!parameters above). This only removes the negative TKE problem !!but does not necessarily improve performance - neutral impact. - REAL, PARAMETER :: CKmod=1. + real(kind_phys), PARAMETER :: CKmod=1. !>Use Ito et al. (2015, BLM) scale-aware (0: no, 1: yes). Note that this also has impacts !!on the cloud PDF and mass-flux scheme, using Honnert et al. (2011) similarity function !!for TKE in the upper PBL/cloud layer. - REAL, PARAMETER :: scaleaware=1. + real(kind_phys), PARAMETER :: scaleaware=1. !>Of the following the options, use one OR the other, not both. !>Adding top-down diffusion driven by cloud-top radiative cooling @@ -341,32 +331,6 @@ MODULE module_bl_mynn LOGICAL, PARAMETER :: debug_code = .false. INTEGER, PARAMETER :: idbg = 23 !specific i-point to write out -! JAYMES- -!> Constants used for empirical calculations of saturation -!! vapor pressures (in function "esat") and saturation mixing ratios -!! (in function "qsat"), reproduced from module_mp_thompson.F, -!! v3.6 - REAL, PARAMETER:: J0= .611583699E03 - REAL, PARAMETER:: J1= .444606896E02 - REAL, PARAMETER:: J2= .143177157E01 - REAL, PARAMETER:: J3= .264224321E-1 - REAL, PARAMETER:: J4= .299291081E-3 - REAL, PARAMETER:: J5= .203154182E-5 - REAL, PARAMETER:: J6= .702620698E-8 - REAL, PARAMETER:: J7= .379534310E-11 - REAL, PARAMETER:: J8=-.321582393E-13 - - REAL, PARAMETER:: K0= .609868993E03 - REAL, PARAMETER:: K1= .499320233E02 - REAL, PARAMETER:: K2= .184672631E01 - REAL, PARAMETER:: K3= .402737184E-1 - REAL, PARAMETER:: K4= .565392987E-3 - REAL, PARAMETER:: K5= .521693933E-5 - REAL, PARAMETER:: K6= .307839583E-7 - REAL, PARAMETER:: K7= .105785160E-9 - REAL, PARAMETER:: K8= .161444444E-12 -! end- - ! Used in WRF-ARW module_physics_init.F INTEGER :: mynn_level @@ -385,13 +349,12 @@ SUBROUTINE mynn_bl_driver( & &initflag,restart,cycling, & &delt,dz,dx,znt, & &u,v,w,th,sqv3d,sqc3d,sqi3d, & - &qnc,qni, & - &qnwfa,qnifa,ozone, & + &sqs3d,qnc,qni, & + &qnwfa,qnifa,qnbca,ozone, & &p,exner,rho,t3d, & &xland,ts,qsfc,ps, & &ust,ch,hfx,qfx,rmol,wspd, & &uoce,voce, & !ocean current - &vdfg, & !Katata-added for fog dep &qke,qke_adv, & &sh3d,sm3d, & &nchem,kdvel,ndvel, & !Smoke/Chem variables @@ -401,16 +364,16 @@ SUBROUTINE mynn_bl_driver( & &tsq,qsq,cov, & &rublten,rvblten,rthblten, & &rqvblten,rqcblten,rqiblten, & - &rqncblten,rqniblten, & + &rqncblten,rqniblten,rqsblten, & &rqnwfablten,rqnifablten, & - &dozone, & + &rqnbcablten,dozone, & &exch_h,exch_m, & &pblh,kpbl, & &el_pbl, & &dqke,qwt,qshear,qbuoy,qdiss, & &qc_bl,qi_bl,cldfra_bl, & &bl_mynn_tkeadvect, & - &bl_mynn_tkebudget, & + &tke_budget, & &bl_mynn_cloudpdf, & &bl_mynn_mixlength, & &icloud_bl, & @@ -429,18 +392,19 @@ SUBROUTINE mynn_bl_driver( & &spp_pbl,pattern_spp_pbl, & &rthraten, & &FLAG_QC,FLAG_QI,FLAG_QNC, & - &FLAG_QNI,FLAG_QNWFA,FLAG_QNIFA, & - &FLAG_OZONE & - &,IDS,IDE,JDS,JDE,KDS,KDE & - &,IMS,IME,JMS,JME,KMS,KME & - &,ITS,ITE,JTS,JTE,KTS,KTE) + &FLAG_QNI,FLAG_QS, & + &FLAG_QNWFA,FLAG_QNIFA, & + &FLAG_QNBCA,FLAG_OZONE, & + &IDS,IDE,JDS,JDE,KDS,KDE, & + &IMS,IME,JMS,JME,KMS,KME, & + &ITS,ITE,JTS,JTE,KTS,KTE ) !------------------------------------------------------------------- INTEGER, INTENT(in) :: initflag !INPUT NAMELIST OPTIONS: - LOGICAL, INTENT(IN) :: restart,cycling - LOGICAL, INTENT(in) :: bl_mynn_tkebudget + LOGICAL, INTENT(in) :: restart,cycling + INTEGER, INTENT(in) :: tke_budget INTEGER, INTENT(in) :: bl_mynn_cloudpdf INTEGER, INTENT(in) :: bl_mynn_mixlength INTEGER, INTENT(in) :: bl_mynn_edmf @@ -452,17 +416,18 @@ SUBROUTINE mynn_bl_driver( & INTEGER, INTENT(in) :: bl_mynn_cloudmix INTEGER, INTENT(in) :: bl_mynn_mixqt INTEGER, INTENT(in) :: icloud_bl - REAL(kind=kind_phys), INTENT(in) :: closure + real(kind_phys), INTENT(in) :: closure LOGICAL, INTENT(in) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC,& - FLAG_QNWFA,FLAG_QNIFA,FLAG_OZONE + FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA, & + FLAG_OZONE,FLAG_QS LOGICAL, INTENT(IN) :: mix_chem,enh_mix,rrfs_sd,smoke_dbg - INTEGER, INTENT(in) :: & - & IDS,IDE,JDS,JDE,KDS,KDE & - &,IMS,IME,JMS,JME,KMS,KME & - &,ITS,ITE,JTS,JTE,KTS,KTE + INTEGER, INTENT(in) :: & + & IDS,IDE,JDS,JDE,KDS,KDE & + &,IMS,IME,JMS,JME,KMS,KME & + &,ITS,ITE,JTS,JTE,KTS,KTE #ifdef HARDCODE_VERTICAL # define kts 1 @@ -479,120 +444,129 @@ SUBROUTINE mynn_bl_driver( & ! to prevent a crash on Cheyenne. Do not change it back without testing if the code runs ! on Cheyenne with the GNU compiler. - REAL(kind=kind_phys), INTENT(in) :: delt - REAL(kind=kind_phys), DIMENSION(:), INTENT(in) :: dx - REAL(kind=kind_phys), DIMENSION(:,:), INTENT(in) :: dz, & + real(kind_phys), INTENT(in) :: delt + real(kind_phys), DIMENSION(:), INTENT(in) :: dx + real(kind_phys), DIMENSION(:,:), INTENT(in) :: dz, & &u,v,w,th,sqv3D,p,exner,rho,T3D - REAL(kind=kind_phys), DIMENSION(:,:), INTENT(in) :: & - &sqc3D,sqi3D,qni,qnc,qnwfa,qnifa - REAL(kind=kind_phys), DIMENSION(:,:), INTENT(in):: ozone - REAL(kind=kind_phys), DIMENSION(:), INTENT(in):: ust, & + real(kind_phys), DIMENSION(:,:), INTENT(in) :: & + &sqc3D,sqi3D,sqs3D,qni,qnc,qnwfa,qnifa,qnbca + real(kind_phys), DIMENSION(:,:), INTENT(in):: ozone + real(kind_phys), DIMENSION(:), INTENT(in):: ust, & &ch,qsfc,ps,wspd - REAL(kind=kind_phys), DIMENSION(:,:), INTENT(inout) :: & + real(kind_phys), DIMENSION(:,:), INTENT(inout) :: & &Qke,Tsq,Qsq,Cov,qke_adv - REAL(kind=kind_phys), DIMENSION(:,:), INTENT(inout) :: & - &rublten,rvblten,rthblten,rqvblten,rqcblten, & - &rqiblten,rqniblten,rqncblten, & - &rqnwfablten,rqnifablten - REAL(kind=kind_phys), DIMENSION(:,:), INTENT(inout) :: dozone - REAL(kind=kind_phys), DIMENSION(:,:), INTENT(in) :: rthraten + real(kind_phys), DIMENSION(:,:), INTENT(inout) :: & + &rublten,rvblten,rthblten,rqvblten,rqcblten, & + &rqiblten,rqsblten,rqniblten,rqncblten, & + &rqnwfablten,rqnifablten,rqnbcablten + real(kind_phys), DIMENSION(:,:), INTENT(inout) :: dozone + real(kind_phys), DIMENSION(:,:), INTENT(in) :: rthraten - REAL(kind=kind_phys), DIMENSION(:,:), INTENT(out) :: exch_h,exch_m - REAL, DIMENSION(:), INTENT(in) :: xland,ts,znt,hfx,qfx, & - &uoce,voce + real(kind_phys), DIMENSION(:,:), INTENT(out) :: exch_h,exch_m + real(kind_phys), DIMENSION(:), INTENT(in) :: xland, & + &ts,znt,hfx,qfx,uoce,voce !These 10 arrays are only allocated when bl_mynn_output > 0 - REAL(kind=kind_phys), DIMENSION(:,:), INTENT(inout) :: & - & edmf_a,edmf_w,edmf_qt,edmf_thl,edmf_ent,edmf_qc, & + real(kind_phys), DIMENSION(:,:), INTENT(inout) :: & + & edmf_a,edmf_w,edmf_qt,edmf_thl,edmf_ent,edmf_qc, & & sub_thl3D,sub_sqv3D,det_thl3D,det_sqv3D -! REAL, DIMENSION(IMS:IME,KMS:KME) :: & +! real, DIMENSION(IMS:IME,KMS:KME) :: & ! & edmf_a_dd,edmf_w_dd,edmf_qt_dd,edmf_thl_dd,edmf_ent_dd,edmf_qc_dd - REAL(kind=kind_phys), DIMENSION(:), INTENT(inout) :: Pblh - REAL, DIMENSION(:), INTENT(inout) :: rmol + real(kind_phys), DIMENSION(:), INTENT(inout) :: Pblh + real(kind_phys), DIMENSION(:), INTENT(inout) :: rmol - REAL, DIMENSION(IMS:IME) :: Psig_bl,Psig_shcu + real(kind_phys), DIMENSION(IMS:IME) :: psig_bl,psig_shcu - INTEGER,DIMENSION(:),INTENT(INOUT) :: & + INTEGER,DIMENSION(:),INTENT(INOUT) :: & &KPBL,nupdraft,ktop_plume - REAL(kind=kind_phys), DIMENSION(:), INTENT(out) :: maxmf + real(kind_phys), DIMENSION(:), INTENT(out) :: maxmf - REAL(kind=kind_phys), DIMENSION(:,:), INTENT(inout) :: el_pbl + real(kind_phys), DIMENSION(:,:), INTENT(inout) :: el_pbl - REAL(kind=kind_phys), DIMENSION(:,:), INTENT(out) :: & + real(kind_phys), DIMENSION(:,:), INTENT(inout) :: & &qWT,qSHEAR,qBUOY,qDISS,dqke - ! 3D budget arrays are not allocated when bl_mynn_tkebudget == .false. + ! 3D budget arrays are not allocated when tke_budget == 0 ! 1D (local) budget arrays are used for passing between subroutines. - REAL, DIMENSION(kts:kte) :: qWT1,qSHEAR1,qBUOY1,qDISS1,dqke1,diss_heat + real(kind_phys), DIMENSION(kts:kte) :: & + &qwt1,qshear1,qbuoy1,qdiss1,dqke1,diss_heat - REAL(kind=kind_phys), DIMENSION(:,:), intent(out) :: Sh3D,Sm3D + real(kind_phys), DIMENSION(:,:), intent(out) :: Sh3D,Sm3D - REAL(kind=kind_phys), DIMENSION(:,:), INTENT(inout) :: & + real(kind_phys), DIMENSION(:,:), INTENT(inout) :: & &qc_bl,qi_bl,cldfra_bl - REAL, DIMENSION(KTS:KTE) :: qc_bl1D,qi_bl1D,cldfra_bl1D, & - qc_bl1D_old,qi_bl1D_old,cldfra_bl1D_old + real(kind_phys), DIMENSION(KTS:KTE) :: qc_bl1D,qi_bl1D, & + &cldfra_bl1D,qc_bl1D_old,qi_bl1D_old,cldfra_bl1D_old ! smoke/chemical arrays INTEGER, INTENT(IN ) :: nchem, kdvel, ndvel -! REAL, DIMENSION( ims:ime, kms:kme, nchem ), INTENT(INOUT), optional :: chem3d -! REAL, DIMENSION( ims:ime, kdvel, ndvel ), INTENT(IN), optional :: vdep - REAL(kind=kind_phys), DIMENSION(:, :, :), INTENT(INOUT) :: chem3d - REAL(kind=kind_phys), DIMENSION(:, :), INTENT(IN) :: vdep - REAL(kind=kind_phys), DIMENSION(:), INTENT(IN) :: frp,EMIS_ANT_NO + real(kind_phys), DIMENSION(:,:,:), INTENT(INOUT) :: chem3d + real(kind_phys), DIMENSION(:,:), INTENT(IN) :: vdep + real(kind_phys), DIMENSION(:), INTENT(IN) :: frp,EMIS_ANT_NO !local - REAL, DIMENSION(kts:kte ,nchem) :: chem1 - REAL, DIMENSION(kts:kte+1,nchem) :: s_awchem1 - REAL, DIMENSION(ndvel) :: vd1 + real(kind_phys), DIMENSION(kts:kte ,nchem) :: chem1 + real(kind_phys), DIMENSION(kts:kte+1,nchem) :: s_awchem1 + real(kind_phys), DIMENSION(ndvel) :: vd1 INTEGER :: ic !local vars INTEGER :: ITF,JTF,KTF, IMD,JMD INTEGER :: i,j,k,kproblem - REAL, DIMENSION(KTS:KTE) :: thl,thvl,tl,qv1,qc1,qi1,sqw, & - &El, Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc, & - &Vt, Vq, sgm, thlsg, sqwsg, vdfg - REAL, DIMENSION(KTS:KTE) :: thetav,sh,sm,u1,v1,w1,p1, & - &ex1,dz1,th1,tk1,rho1,qke1,tsq1,qsq1,cov1, & - &sqv,sqi,sqc,du1,dv1,dth1,dqv1,dqc1,dqi1,ozone1, & - &k_m1,k_h1,qni1,dqni1,qnc1,dqnc1,qnwfa1,qnifa1, & - &dqnwfa1,dqnifa1,dozone1 + real(kind_phys), DIMENSION(KTS:KTE) :: & + &thl,tl,qv1,qc1,qi1,qs1,sqw, & + &el, dfm, dfh, dfq, tcd, qcd, pdk, pdt, pdq, pdc, & + &vt, vq, sgm + real(kind_phys), DIMENSION(KTS:KTE) :: & + &thetav,sh,sm,u1,v1,w1,p1, & + &ex1,dz1,th1,tk1,rho1,qke1,tsq1,qsq1,cov1, & + &sqv,sqi,sqc,sqs, & + &du1,dv1,dth1,dqv1,dqc1,dqi1,dqs1,ozone1, & + &k_m1,k_h1,qni1,dqni1,qnc1,dqnc1,qnwfa1,qnifa1, & + &qnbca1,dqnwfa1,dqnifa1,dqnbca1,dozone1 !mass-flux variables - REAL, DIMENSION(KTS:KTE) :: dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf - REAL, DIMENSION(KTS:KTE) :: edmf_a1,edmf_w1,edmf_qt1, & - &edmf_thl1,edmf_ent1,edmf_qc1 - REAL, DIMENSION(KTS:KTE) :: edmf_a_dd1,edmf_w_dd1, & - &edmf_qt_dd1,edmf_thl_dd1, & + real(kind_phys), DIMENSION(KTS:KTE) :: & + &dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf + real(kind_phys), DIMENSION(KTS:KTE) :: & + &edmf_a1,edmf_w1,edmf_qt1,edmf_thl1, & + &edmf_ent1,edmf_qc1 + real(kind_phys), DIMENSION(KTS:KTE) :: & + &edmf_a_dd1,edmf_w_dd1,edmf_qt_dd1,edmf_thl_dd1, & &edmf_ent_dd1,edmf_qc_dd1 - REAL, DIMENSION(KTS:KTE) :: sub_thl,sub_sqv,sub_u,sub_v, & - det_thl,det_sqv,det_sqc,det_u,det_v - REAL,DIMENSION(KTS:KTE+1) :: s_aw1,s_awthl1,s_awqt1, & - s_awqv1,s_awqc1,s_awu1,s_awv1,s_awqke1, & - s_awqnc1,s_awqni1,s_awqnwfa1,s_awqnifa1 - REAL,DIMENSION(KTS:KTE+1) :: sd_aw1,sd_awthl1,sd_awqt1, & - sd_awqv1,sd_awqc1,sd_awu1,sd_awv1,sd_awqke1 - - REAL, DIMENSION(KTS:KTE+1) :: zw - REAL :: cpm,sqcg,flt,fltv,flq,flqv,flqc,pmz,phh,exnerg,zet,phi_m,& - & afk,abk,ts_decay, qc_bl2, qi_bl2, & - & th_sfc,ztop_plume,sqc9,sqi9,wsp + real(kind_phys), DIMENSION(KTS:KTE) :: & + &sub_thl,sub_sqv,sub_u,sub_v, & + &det_thl,det_sqv,det_sqc,det_u,det_v + real(kind_phys), DIMENSION(KTS:KTE+1) :: & + &s_aw1,s_awthl1,s_awqt1, & + &s_awqv1,s_awqc1,s_awu1,s_awv1,s_awqke1, & + &s_awqnc1,s_awqni1,s_awqnwfa1,s_awqnifa1, & + &s_awqnbca1 + real(kind_phys), DIMENSION(KTS:KTE+1) :: & + &sd_aw1,sd_awthl1,sd_awqt1, & + &sd_awqv1,sd_awqc1,sd_awu1,sd_awv1,sd_awqke1 + + real(kind_phys), DIMENSION(KTS:KTE+1) :: zw + real(kind_phys) :: cpm,sqcg,flt,fltv,flq,flqv,flqc, & + &pmz,phh,exnerg,zet,phi_m, & + &afk,abk,ts_decay, qc_bl2, qi_bl2, & + &th_sfc,ztop_plume,wsp !top-down diffusion - REAL, DIMENSION(ITS:ITE) :: maxKHtopdown - REAL,DIMENSION(KTS:KTE) :: KHtopdown,TKEprodTD + real(kind_phys), DIMENSION(ITS:ITE) :: maxKHtopdown + real(kind_phys), DIMENSION(KTS:KTE) :: KHtopdown,TKEprodTD LOGICAL :: INITIALIZE_QKE,problem ! Stochastic fields - INTEGER, INTENT(IN) :: spp_pbl - REAL(kind=kind_phys), DIMENSION( :, :), INTENT(IN) :: pattern_spp_pbl - REAL, DIMENSION(KTS:KTE) :: rstoch_col + INTEGER, INTENT(IN) :: spp_pbl + real(kind_phys), DIMENSION(:,:), INTENT(IN) :: pattern_spp_pbl + real(kind_phys), DIMENSION(KTS:KTE) :: rstoch_col ! Substepping TKE INTEGER :: nsub - real(kind=kind_phys) :: delt2 + real(kind_phys) :: delt2 if (debug_code) then !check incoming values @@ -629,7 +603,7 @@ SUBROUTINE mynn_bl_driver( & !*** Begin debugging IMD=(IMS+IME)/2 JMD=(JMS+JME)/2 -!*** End debugging +!*** End debugging JTF=JTE ITF=ITE @@ -701,6 +675,7 @@ SUBROUTINE mynn_bl_driver( & dqnc1(kts:kte)=0.0 dqnwfa1(kts:kte)=0.0 dqnifa1(kts:kte)=0.0 + dqnbca1(kts:kte)=0.0 dozone1(kts:kte)=0.0 qc_bl1D_old(kts:kte)=0.0 cldfra_bl1D_old(kts:kte)=0.0 @@ -721,7 +696,7 @@ SUBROUTINE mynn_bl_driver( & ENDDO ENDDO - IF ( bl_mynn_tkebudget ) THEN + IF (tke_budget .eq. 1) THEN DO k=KTS,KTE DO i=ITS,ITF qWT(i,k)=0. @@ -734,7 +709,23 @@ SUBROUTINE mynn_bl_driver( & ENDIF DO i=ITS,ITF - DO k=KTS,KTE !KTF + if (FLAG_QI ) then + sqi(:)=sqi3D(i,:) + else + sqi = 0.0 + endif + if (FLAG_QS ) then + sqs(:)=sqs3D(i,:) + else + sqs = 0.0 + endif + if (icloud_bl > 0) then + cldfra_bl1d(:)=cldfra_bl(i,:) + qc_bl1d(:)=qc_bl(i,:) + qi_bl1d(:)=qi_bl(i,:) + endif + + do k=KTS,KTE !KTF dz1(k)=dz(i,k) u1(k) = u(i,k) v1(k) = v(i,k) @@ -745,52 +736,15 @@ SUBROUTINE mynn_bl_driver( & rho1(k)=rho(i,k) sqc(k)=sqc3D(i,k) !/(1.+qv(i,k)) sqv(k)=sqv3D(i,k) !/(1.+qv(i,k)) - thetav(k)=th(i,k)*(1.+0.608*sqv(k)) - IF (icloud_bl > 0) THEN - CLDFRA_BL1D(k)=CLDFRA_BL(i,k) - QC_BL1D(k)=QC_BL(i,k) - QI_BL1D(k)=QI_BL(i,k) - ENDIF - IF (FLAG_QI ) THEN - sqi(k)=sqi3D(i,k) !/(1.+qv(i,k)) - sqw(k)=sqv(k)+sqc(k)+sqi(k) - thl(k)=th1(k) - xlvcp/ex1(k)*sqc(k) & - & - xlscp/ex1(k)*sqi(k) - !Use form from Tripoli and Cotton (1981) with their - !suggested min temperature to improve accuracy. - !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) & - ! & - xlscp/MAX(tk1(k),TKmin)*sqi(k)) - !COMPUTE THL USING SGS CLOUDS FOR PBLH DIAG - IF(sqc(k)<1e-6 .and. sqi(k)<1e-8 .and. CLDFRA_BL1D(k)>0.001)THEN - sqc9=QC_BL1D(k)*CLDFRA_BL1D(k) - sqi9=QI_BL1D(k)*CLDFRA_BL1D(k) - ELSE - sqc9=sqc(k) - sqi9=sqi(k) - ENDIF - thlsg(k)=th1(k) - xlvcp/ex1(k)*sqc9 & - & - xlscp/ex1(k)*sqi9 - sqwsg(k)=sqv(k)+sqc9+sqi9 - ELSE - sqi(k)=0.0 - sqw(k)=sqv(k)+sqc(k) - thl(k)=th1(k)-xlvcp/ex1(k)*sqc(k) - !Use form from Tripoli and Cotton (1981) with their - !suggested min temperature to improve accuracy. - !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k)) - !COMPUTE THL USING SGS CLOUDS FOR PBLH DIAG - IF(sqc(k)<1e-6 .and. CLDFRA_BL1D(k)>0.001)THEN - sqc9=QC_BL1D(k)*CLDFRA_BL1D(k) - sqi9=0.0 - ELSE - sqc9=sqc(k) - sqi9=0.0 - ENDIF - thlsg(k)=th1(k) - xlvcp/ex1(k)*sqc9 & - & - xlscp/ex1(k)*sqi9 - sqwsg(k)=sqv(k)+sqc9+sqi9 - ENDIF - thvl(k)=thlsg(k)*(1.+0.61*sqv(k)) + thetav(k)=th(i,k)*(1.+p608*sqv(k)) + !keep snow out for now - increases ceiling bias + sqw(k)=sqv(k)+sqc(k)+sqi(k)!+sqs(k) + thl(k)=th1(k) - xlvcp/ex1(k)*sqc(k) & + & - xlscp/ex1(k)*(sqi(k)+sqs(k)) + !Use form from Tripoli and Cotton (1981) with their + !suggested min temperature to improve accuracy. + !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) & + ! & - xlscp/MAX(tk1(k),TKmin)*sqi(k)) IF (k==kts) THEN zw(k)=0. @@ -821,9 +775,8 @@ SUBROUTINE mynn_bl_driver( & zw(kte+1)=zw(kte)+dz(i,kte) -!> - Call get_pblh() to calculate hybrid (\f$\theta_{vli}-TKE\f$) PBL height. -! CALL GET_PBLH(KTS,KTE,PBLH(i),thetav,& - CALL GET_PBLH(KTS,KTE,PBLH(i),thvl, & +!> - Call get_pblh() to calculate hybrid (\f$\theta_{v}-TKE\f$) PBL height. + CALL GET_PBLH(KTS,KTE,PBLH(i),thetav,& & Qke1,zw,dz1,xland(i),KPBL(i)) !> - Call scale_aware() to calculate similarity functions for scale-adaptive control @@ -841,18 +794,17 @@ SUBROUTINE mynn_bl_driver( & !! obtaining prerequisite variables by calling the following subroutines from !! within mym_initialize(): mym_level2() and mym_length(). CALL mym_initialize ( & - &kts,kte, & + &kts,kte,xland(i), & &dz1, dx(i), zw, & &u1, v1, thl, sqv, & - &thlsg, sqwsg, & &PBLH(i), th1, thetav, sh, sm, & &ust(i), rmol(i), & &el, Qke1, Tsq1, Qsq1, Cov1, & &Psig_bl(i), cldfra_bl1D, & &bl_mynn_mixlength, & - &edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf,& + &edmf_w1,edmf_a1, & &INITIALIZE_QKE, & - &spp_pbl,rstoch_col ) + &spp_pbl,rstoch_col ) IF (.not.restart) THEN !UPDATE 3D VARIABLES @@ -895,647 +847,582 @@ SUBROUTINE mynn_bl_driver( & ENDIF DO i=ITS,ITF - DO k=KTS,KTE !KTF - !JOE-TKE BUDGET - IF ( bl_mynn_tkebudget ) THEN - dqke(i,k)=qke(i,k) - END IF - IF (icloud_bl > 0) THEN - CLDFRA_BL1D(k)=CLDFRA_BL(i,k) - QC_BL1D(k)=QC_BL(i,k) - QI_BL1D(k)=QI_BL(i,k) - cldfra_bl1D_old(k)=cldfra_bl(i,k) - qc_bl1D_old(k)=qc_bl(i,k) - qi_bl1D_old(k)=qi_bl(i,k) - else - CLDFRA_BL1D(k)=0.0 - QC_BL1D(k)=0.0 - QI_BL1D(k)=0.0 - cldfra_bl1D_old(k)=0.0 - qc_bl1D_old(k)=0.0 - qi_bl1D_old(k)=0.0 - ENDIF - dz1(k)= dz(i,k) - u1(k) = u(i,k) - v1(k) = v(i,k) - w1(k) = w(i,k) - th1(k)= th(i,k) - tk1(k)=T3D(i,k) - p1(k) = p(i,k) - ex1(k)= exner(i,k) - rho1(k)=rho(i,k) - sqv(k)= sqv3D(i,k) !/(1.+qv(i,k)) - sqc(k)= sqc3D(i,k) !/(1.+qv(i,k)) - qv1(k)= sqv(k)/(1.-sqv(k)) - qc1(k)= sqc(k)/(1.-sqv(k)) - dqc1(k)=0.0 - dqi1(k)=0.0 - dqni1(k)=0.0 - dqnc1(k)=0.0 - dqnwfa1(k)=0.0 - dqnifa1(k)=0.0 - dozone1(k)=0.0 - IF(FLAG_QI)THEN - sqi(k)= sqi3D(i,k) !/(1.+qv(i,k)) - qi1(k)= sqi(k)/(1.-sqv(k)) - sqw(k)= sqv(k)+sqc(k)+sqi(k) - thl(k)= th1(k) - xlvcp/ex1(k)*sqc(k) & - & - xlscp/ex1(k)*sqi(k) - !Use form from Tripoli and Cotton (1981) with their - !suggested min temperature to improve accuracy. - !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) & - ! & - xlscp/MAX(tk1(k),TKmin)*sqi(k)) - !COMPUTE THL USING SGS CLOUDS FOR PBLH DIAG - IF(sqc(k)<1e-6 .and. sqi(k)<1e-8 .and. CLDFRA_BL1D(k)>0.001)THEN - sqc9=QC_BL1D(k)*CLDFRA_BL1D(k) - sqi9=QI_BL1D(k)*CLDFRA_BL1D(k) - ELSE - sqc9=sqc(k) - sqi9=sqi(k) - ENDIF - thlsg(k)=th1(k) - xlvcp/ex1(k)*sqc9 & - & - xlscp/ex1(k)*sqi9 - sqwsg(k)=sqv(k)+sqc9+sqi9 - ELSE - qi1(k)=0.0 - sqi(k)=0.0 - sqw(k)= sqv(k)+sqc(k) - thl(k)= th1(k)-xlvcp/ex1(k)*sqc(k) - !Use form from Tripoli and Cotton (1981) with their - !suggested min temperature to improve accuracy. - !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k)) - !COMPUTE THL USING SGS CLOUDS FOR PBLH DIAG - IF(sqc(k)<1e-6 .and. CLDFRA_BL1D(k)>0.001)THEN - sqc9=QC_BL1D(k)*CLDFRA_BL1D(k) - sqi9=QI_BL1D(k)*CLDFRA_BL1D(k) - ELSE - sqc9=sqc(k) - sqi9=0.0 - ENDIF - thlsg(k)=th1(k) - xlvcp/ex1(k)*sqc9 & - & - xlscp/ex1(k)*sqi9 - ENDIF - thetav(k)=th1(k)*(1.+0.608*sqv(k)) - thvl(k) =thlsg(k) *(1.+0.608*sqv(k)) - - IF (FLAG_QNI ) THEN - qni1(k)=qni(i,k) - ELSE - qni1(k)=0.0 - ENDIF - IF (FLAG_QNC ) THEN - qnc1(k)=qnc(i,k) - ELSE - qnc1(k)=0.0 - ENDIF - IF (FLAG_QNWFA ) THEN - qnwfa1(k)=qnwfa(i,k) - ELSE - qnwfa1(k)=0.0 - ENDIF - IF (FLAG_QNIFA ) THEN - qnifa1(k)=qnifa(i,k) - ELSE - qnifa1(k)=0.0 - ENDIF - IF (FLAG_OZONE) THEN - ozone1(k)=ozone(i,k) - ELSE - ozone1(k)=0.0 - ENDIF - el(k) = el_pbl(i,k) - qke1(k)=qke(i,k) - sh(k) =sh3d(i,k) - sm(k) =sm3d(i,k) - tsq1(k)=tsq(i,k) - qsq1(k)=qsq(i,k) - cov1(k)=cov(i,k) - if (spp_pbl==1) then - rstoch_col(k)=pattern_spp_pbl(i,k) - else - rstoch_col(k)=0.0 - endif - - !edmf - edmf_a1(k)=0.0 - edmf_w1(k)=0.0 - edmf_qc1(k)=0.0 - s_aw1(k)=0. - s_awthl1(k)=0. - s_awqt1(k)=0. - s_awqv1(k)=0. - s_awqc1(k)=0. - s_awu1(k)=0. - s_awv1(k)=0. - s_awqke1(k)=0. - s_awqnc1(k)=0. - s_awqni1(k)=0. - s_awqnwfa1(k)=0. - s_awqnifa1(k)=0. - ![EWDD] - edmf_a_dd1(k)=0.0 - edmf_w_dd1(k)=0.0 - edmf_qc_dd1(k)=0.0 - sd_aw1(k)=0. - sd_awthl1(k)=0. - sd_awqt1(k)=0. - sd_awqv1(k)=0. - sd_awqc1(k)=0. - sd_awu1(k)=0. - sd_awv1(k)=0. - sd_awqke1(k)=0. - sub_thl(k)=0. - sub_sqv(k)=0. - sub_u(k)=0. - sub_v(k)=0. - det_thl(k)=0. - det_sqv(k)=0. - det_sqc(k)=0. - det_u(k)=0. - det_v(k)=0. - - IF (k==kts) THEN - zw(k)=0. - ELSE - zw(k)=zw(k-1)+dz(i,k-1) - ENDIF - ENDDO ! end k - - !initialize smoke/chem arrays (if used): - IF ( mix_chem ) then - do ic = 1,ndvel - vd1(ic) = vdep(i,ic) ! dry deposition velocity - chem1(kts,ic) = chem3d(i,kts,ic) - s_awchem1(kts,ic)=0. - enddo - do k = kts+1,kte - DO ic = 1,nchem - chem1(k,ic) = chem3d(i,k,ic) - s_awchem1(k,ic)=0. - ENDDO - enddo - ELSE - do ic = 1,ndvel - vd1(ic) = 0. ! dry deposition velocity - chem1(kts,ic) = 0. - s_awchem1(kts,ic)=0. - enddo - do k = kts+1,kte - do ic = 1,nchem - chem1(k,ic) = 0. - s_awchem1(k,ic)=0. - enddo - enddo - ENDIF - - zw(kte+1)=zw(kte)+dz(i,kte) - !EDMF - s_aw1(kte+1)=0. - s_awthl1(kte+1)=0. - s_awqt1(kte+1)=0. - s_awqv1(kte+1)=0. - s_awqc1(kte+1)=0. - s_awu1(kte+1)=0. - s_awv1(kte+1)=0. - s_awqke1(kte+1)=0. - s_awqnc1(kte+1)=0. - s_awqni1(kte+1)=0. - s_awqnwfa1(kte+1)=0. - s_awqnifa1(kte+1)=0. - sd_aw1(kte+1)=0. - sd_awthl1(kte+1)=0. - sd_awqt1(kte+1)=0. - sd_awqv1(kte+1)=0. - sd_awqc1(kte+1)=0. - sd_awu1(kte+1)=0. - sd_awv1(kte+1)=0. - sd_awqke1(kte+1)=0. - IF ( mix_chem ) THEN - DO ic = 1,nchem - s_awchem1(kte+1,ic)=0. - ENDDO - ENDIF + !Initialize some arrays + if (tke_budget .eq. 1) then + dqke(i,:)=qke(i,:) + endif + if (FLAG_QI ) then + sqi(:)=sqi3D(i,:) + else + sqi = 0.0 + endif + if (FLAG_QS ) then + sqs(:)=sqs3D(i,:) + else + sqs = 0.0 + endif + if (icloud_bl > 0) then + CLDFRA_BL1D(:)=CLDFRA_BL(i,:) + QC_BL1D(:) =QC_BL(i,:) + QI_BL1D(:) =QI_BL(i,:) + cldfra_bl1D_old(:)=cldfra_bl(i,:) + qc_bl1D_old(:)=qc_bl(i,:) + qi_bl1D_old(:)=qi_bl(i,:) + else + CLDFRA_BL1D =0.0 + QC_BL1D =0.0 + QI_BL1D =0.0 + cldfra_bl1D_old=0.0 + qc_bl1D_old =0.0 + qi_bl1D_old =0.0 + endif + dz1(kts:kte) =dz(i,kts:kte) + u1(kts:kte) =u(i,kts:kte) + v1(kts:kte) =v(i,kts:kte) + w1(kts:kte) =w(i,kts:kte) + th1(kts:kte) =th(i,kts:kte) + tk1(kts:kte) =T3D(i,kts:kte) + p1(kts:kte) =p(i,kts:kte) + ex1(kts:kte) =exner(i,kts:kte) + rho1(kts:kte) =rho(i,kts:kte) + sqv(kts:kte) =sqv3D(i,kts:kte) !/(1.+qv(i,kts:kte)) + sqc(kts:kte) =sqc3D(i,kts:kte) !/(1.+qv(i,kts:kte)) + qv1(kts:kte) =sqv(kts:kte)/(1.-sqv(kts:kte)) + qc1(kts:kte) =sqc(kts:kte)/(1.-sqv(kts:kte)) + qi1(kts:kte) =sqi(kts:kte)/(1.-sqv(kts:kte)) + qs1(kts:kte) =sqs(kts:kte)/(1.-sqv(kts:kte)) + dqc1(kts:kte) =0.0 + dqi1(kts:kte) =0.0 + dqs1(kts:kte) =0.0 + dqni1(kts:kte) =0.0 + dqnc1(kts:kte) =0.0 + dqnwfa1(kts:kte)=0.0 + dqnifa1(kts:kte)=0.0 + dqnbca1(kts:kte)=0.0 + dozone1(kts:kte)=0.0 + IF (FLAG_QNI ) THEN + qni1(kts:kte)=qni(i,kts:kte) + ELSE + qni1(kts:kte)=0.0 + ENDIF + IF (FLAG_QNC ) THEN + qnc1(kts:kte)=qnc(i,kts:kte) + ELSE + qnc1(kts:kte)=0.0 + ENDIF + IF (FLAG_QNWFA ) THEN + qnwfa1(kts:kte)=qnwfa(i,kts:kte) + ELSE + qnwfa1(kts:kte)=0.0 + ENDIF + IF (FLAG_QNIFA ) THEN + qnifa1(kts:kte)=qnifa(i,kts:kte) + ELSE + qnifa1(kts:kte)=0.0 + ENDIF + IF (FLAG_QNBCA ) THEN + qnbca1(kts:kte)=qnbca(i,kts:kte) + ELSE + qnbca1(kts:kte)=0.0 + ENDIF + IF (FLAG_OZONE ) THEN + ozone1(kts:kte)=ozone(i,kts:kte) + ELSE + ozone1(kts:kte)=0.0 + ENDIF + el(kts:kte) =el_pbl(i,kts:kte) + qke1(kts:kte)=qke(i,kts:kte) + sh(kts:kte) =sh3d(i,kts:kte) + sm(kts:kte) =sm3d(i,kts:kte) + tsq1(kts:kte)=tsq(i,kts:kte) + qsq1(kts:kte)=qsq(i,kts:kte) + cov1(kts:kte)=cov(i,kts:kte) + if (spp_pbl==1) then + rstoch_col(kts:kte)=pattern_spp_pbl(i,kts:kte) + else + rstoch_col(kts:kte)=0.0 + endif + !edmf + edmf_a1 =0.0 + edmf_w1 =0.0 + edmf_qc1 =0.0 + s_aw1 =0.0 + s_awthl1 =0.0 + s_awqt1 =0.0 + s_awqv1 =0.0 + s_awqc1 =0.0 + s_awu1 =0.0 + s_awv1 =0.0 + s_awqke1 =0.0 + s_awqnc1 =0.0 + s_awqni1 =0.0 + s_awqnwfa1 =0.0 + s_awqnifa1 =0.0 + s_awqnbca1 =0.0 + ![EWDD] + edmf_a_dd1 =0.0 + edmf_w_dd1 =0.0 + edmf_qc_dd1=0.0 + sd_aw1 =0.0 + sd_awthl1 =0.0 + sd_awqt1 =0.0 + sd_awqv1 =0.0 + sd_awqc1 =0.0 + sd_awu1 =0.0 + sd_awv1 =0.0 + sd_awqke1 =0.0 + sub_thl =0.0 + sub_sqv =0.0 + sub_u =0.0 + sub_v =0.0 + det_thl =0.0 + det_sqv =0.0 + det_sqc =0.0 + det_u =0.0 + det_v =0.0 + + do k = kts,kte + if (k==kts) then + zw(k)=0. + else + zw(k)=zw(k-1)+dz(i,k-1) + endif + !keep snow out for now - increases ceiling bias + sqw(k)= sqv(k)+sqc(k)+sqi(k)!+sqs(k) + thl(k)= th1(k) - xlvcp/ex1(k)*sqc(k) & + & - xlscp/ex1(k)*(sqi(k)+sqs(k)) + !Use form from Tripoli and Cotton (1981) with their + !suggested min temperature to improve accuracy. + !thl(k)=th(i,k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) & + ! & - xlscp/MAX(tk1(k),TKmin)*sqi(k)) + thetav(k)=th1(k)*(1.+p608*sqv(k)) + enddo ! end k + zw(kte+1)=zw(kte)+dz(i,kte) + + !initialize smoke/chem arrays (if used): + if ( mix_chem ) then + do ic = 1,ndvel + vd1(ic) = vdep(i,ic) ! dry deposition velocity + chem1(kts,ic) = chem3d(i,kts,ic) + enddo + do k = kts+1,kte + do ic = 1,nchem + chem1(k,ic) = chem3d(i,k,ic) + enddo + enddo + else + do ic = 1,ndvel + vd1(ic) = 0. ! dry deposition velocity + chem1(kts,ic) = 0. + enddo + do k = kts+1,kte + do ic = 1,nchem + chem1(k,ic) = 0. + enddo + enddo + endif + s_awchem1 = 0.0 !> - Call get_pblh() to calculate the hybrid \f$\theta_{vli}-TKE\f$ !! PBL height diagnostic. -! CALL GET_PBLH(KTS,KTE,PBLH(i),thetav,& - CALL GET_PBLH(KTS,KTE,PBLH(i),thvl,& - & Qke1,zw,dz1,xland(i),KPBL(i)) + CALL GET_PBLH(KTS,KTE,PBLH(i),thetav,& + & Qke1,zw,dz1,xland(i),KPBL(i)) !> - Call scale_aware() to calculate the similarity functions, !! \f$P_{\sigma-PBL}\f$ and \f$P_{\sigma-shcu}\f$, to control !! the scale-adaptive behaviour for the local and nonlocal !! components, respectively. - IF (scaleaware > 0.) THEN - CALL SCALE_AWARE(dx(i),PBLH(i),Psig_bl(i),Psig_shcu(i)) - ELSE - Psig_bl(i)=1.0 - Psig_shcu(i)=1.0 - ENDIF + if (scaleaware > 0.) then + call SCALE_AWARE(dx(i),PBLH(i),Psig_bl(i),Psig_shcu(i)) + else + Psig_bl(i)=1.0 + Psig_shcu(i)=1.0 + endif - sqcg= 0.0 !ill-defined variable; qcg has been removed - cpm=cp*(1.+0.84*qv1(kts)) - exnerg=(ps(i)/p1000mb)**rcp - - !----------------------------------------------------- - !ORIGINAL CODE - !flt = hfx(i)/( rho(i,kts)*cpm ) & - ! +xlvcp*ch(i)*(sqc(kts)/exner(i,kts) -sqcg/exnerg) - !flq = qfx(i)/ rho(i,kts) & - ! -ch(i)*(sqc(kts) -sqcg ) - !----------------------------------------------------- - ! Katata-added - The deposition velocity of cloud (fog) - ! water is used instead of CH. - !flt = hfx(i)/( rho(i,kts)*cpm ) & - ! & +xlvcp*vdfg(i)*(sqc(kts)/exner(i,kts)- sqcg/exnerg) - !flq = qfx(i)/ rho(i,kts) & - ! & -vdfg(i)*(sqc(kts) - sqcg ) - !----------------------------------------------------- - flqv = qfx(i)/rho1(kts) - flqc = -vdfg(i)*(sqc(kts) - sqcg ) - th_sfc = ts(i)/ex1(kts) - - ! TURBULENT FLUX FOR TKE BOUNDARY CONDITIONS - flq =flqv+flqc !! LATENT - flt =hfx(i)/(rho1(kts)*cpm )-xlvcp*flqc/ex1(kts) !! Temperature flux - fltv=flt + flqv*p608*th_sfc !! Virtual temperature flux - - ! Update 1/L using updated sfc heat flux and friction velocity - rmol(i) = -karman*gtr*fltv/max(ust(i)**3,1.0e-6) - zet = 0.5*dz(i,kts)*rmol(i) - zet = MAX(zet, -20.) - zet = MIN(zet, 20.) - !if(i.eq.idbg)print*,"updated z/L=",zet - if (bl_mynn_stfunc == 0) then - !Original Kansas-type stability functions - if ( zet >= 0.0 ) then - pmz = 1.0 + (cphm_st-1.0) * zet - phh = 1.0 + cphh_st * zet - else - pmz = 1.0/ (1.0-cphm_unst*zet)**0.25 - zet - phh = 1.0/SQRT(1.0-cphh_unst*zet) - end if + sqcg= 0.0 !ill-defined variable; qcg has been removed + cpm=cp*(1.+0.84*qv1(kts)) + exnerg=(ps(i)/p1000mb)**rcp + + !----------------------------------------------------- + !ORIGINAL CODE + !flt = hfx(i)/( rho(i,kts)*cpm ) & + ! +xlvcp*ch(i)*(sqc(kts)/exner(i,kts) -sqcg/exnerg) + !flq = qfx(i)/ rho(i,kts) & + ! -ch(i)*(sqc(kts) -sqcg ) + !----------------------------------------------------- + flqv = qfx(i)/rho1(kts) + flqc = 0.0 !currently no sea-spray fluxes, fog settling handled elsewhere + th_sfc = ts(i)/ex1(kts) + + ! TURBULENT FLUX FOR TKE BOUNDARY CONDITIONS + flq =flqv+flqc !! LATENT + flt =hfx(i)/(rho1(kts)*cpm )-xlvcp*flqc/ex1(kts) !! Temperature flux + fltv=flt + flqv*p608*th_sfc !! Virtual temperature flux + + ! Update 1/L using updated sfc heat flux and friction velocity + rmol(i) = -karman*gtr*fltv/max(ust(i)**3,1.0e-6) + zet = 0.5*dz(i,kts)*rmol(i) + zet = MAX(zet, -20.) + zet = MIN(zet, 20.) + !if(i.eq.idbg)print*,"updated z/L=",zet + if (bl_mynn_stfunc == 0) then + !Original Kansas-type stability functions + if ( zet >= 0.0 ) then + pmz = 1.0 + (cphm_st-1.0) * zet + phh = 1.0 + cphh_st * zet else - !Updated stability functions (Puhales, 2020) - phi_m = phim(zet) - pmz = phi_m - zet - phh = phih(zet) + pmz = 1.0/ (1.0-cphm_unst*zet)**0.25 - zet + phh = 1.0/SQRT(1.0-cphh_unst*zet) end if + else + !Updated stability functions (Puhales, 2020) + phi_m = phim(zet) + pmz = phi_m - zet + phh = phih(zet) + end if !> - Call mym_condensation() to calculate the nonconvective component !! of the subgrid cloud fraction and mixing ratio as well as the functions !! used to calculate the buoyancy flux. Different cloud PDFs can be !! selected by use of the namelist parameter \p bl_mynn_cloudpdf. - CALL mym_condensation ( kts,kte, & - &dx(i),dz1,zw,u1,v1,xland(i), & - &thl,sqw,sqv,sqc,sqi, & - &p1,ex1,tsq1,qsq1,cov1, & - &Sh,el,bl_mynn_cloudpdf, & - &qc_bl1D,qi_bl1D,cldfra_bl1D, & - &PBLH(i),HFX(i), & - &Vt, Vq, th1, sgm, rmol(i), & - &spp_pbl, rstoch_col ) + call mym_condensation (kts,kte, & + &dx(i),dz1,zw,xland(i), & + &thl,sqw,sqv,sqc,sqi,sqs, & + &p1,ex1,tsq1,qsq1,cov1, & + &Sh,el,bl_mynn_cloudpdf, & + &qc_bl1D,qi_bl1D,cldfra_bl1D, & + &PBLH(i),HFX(i), & + &Vt, Vq, th1, sgm, rmol(i), & + &spp_pbl, rstoch_col ) !> - Add TKE source driven by cloud top cooling !! Calculate the buoyancy production of TKE from cloud-top cooling when !! \p bl_mynn_topdown =1. - IF (bl_mynn_topdown.eq.1)then - CALL topdown_cloudrad(kts,kte,dz1,zw, & - &xland(i),kpbl(i),PBLH(i), & - &sqc,sqi,sqw,thl,th1,ex1,p1,rho1,thetav, & - &cldfra_bl1D,rthraten(i,:), & - &maxKHtopdown(i),KHtopdown,TKEprodTD ) - ELSE - maxKHtopdown(i) = 0.0 - KHtopdown(kts:kte) = 0.0 - TKEprodTD(kts:kte) = 0.0 - ENDIF + if (bl_mynn_topdown.eq.1) then + call topdown_cloudrad(kts,kte,dz1,zw, & + &xland(i),kpbl(i),PBLH(i), & + &sqc,sqi,sqw,thl,th1,ex1,p1,rho1,thetav, & + &cldfra_bl1D,rthraten(i,:), & + &maxKHtopdown(i),KHtopdown,TKEprodTD ) + else + maxKHtopdown(i) = 0.0 + KHtopdown(kts:kte) = 0.0 + TKEprodTD(kts:kte) = 0.0 + endif - IF (bl_mynn_edmf > 0) THEN - !PRINT*,"Calling DMP Mass-Flux: i= ",i - CALL DMP_mf( & - &kts,kte,delt,zw,dz1,p1,rho1, & - &bl_mynn_edmf_mom, & - &bl_mynn_edmf_tke, & - &bl_mynn_mixscalars, & - &u1,v1,w1,th1,thl,thetav,tk1, & - &sqw,sqv,sqc,qke1, & - &qnc1,qni1,qnwfa1,qnifa1, & - &ex1,Vt,Vq,sgm, & - &ust(i),flt,fltv,flq,flqv, & - &PBLH(i),KPBL(i),DX(i), & - &xland(i),th_sfc, & + if (bl_mynn_edmf > 0) then + !PRINT*,"Calling DMP Mass-Flux: i= ",i + call DMP_mf( & + &kts,kte,delt,zw,dz1,p1,rho1, & + &bl_mynn_edmf_mom, & + &bl_mynn_edmf_tke, & + &bl_mynn_mixscalars, & + &u1,v1,w1,th1,thl,thetav,tk1, & + &sqw,sqv,sqc,qke1, & + &qnc1,qni1,qnwfa1,qnifa1,qnbca1, & + &ex1,Vt,Vq,sgm, & + &ust(i),flt,fltv,flq,flqv, & + &PBLH(i),KPBL(i),DX(i), & + &xland(i),th_sfc, & ! now outputs - tendencies - ! &,dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf & + ! &,dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf & ! outputs - updraft properties - & edmf_a1,edmf_w1,edmf_qt1, & - & edmf_thl1,edmf_ent1,edmf_qc1, & + &edmf_a1,edmf_w1,edmf_qt1, & + &edmf_thl1,edmf_ent1,edmf_qc1, & ! for the solver - & s_aw1,s_awthl1,s_awqt1, & - & s_awqv1,s_awqc1, & - & s_awu1,s_awv1,s_awqke1, & - & s_awqnc1,s_awqni1, & - & s_awqnwfa1,s_awqnifa1, & - & sub_thl,sub_sqv, & - & sub_u,sub_v, & - & det_thl,det_sqv,det_sqc, & - & det_u,det_v, & + &s_aw1,s_awthl1,s_awqt1, & + &s_awqv1,s_awqc1, & + &s_awu1,s_awv1,s_awqke1, & + &s_awqnc1,s_awqni1, & + &s_awqnwfa1,s_awqnifa1,s_awqnbca1, & + &sub_thl,sub_sqv, & + &sub_u,sub_v, & + &det_thl,det_sqv,det_sqc, & + &det_u,det_v, & ! chem/smoke mixing - & nchem,chem1,s_awchem1, & - & mix_chem, & - & qc_bl1D,cldfra_bl1D, & - & qc_bl1D_old,cldfra_bl1D_old, & - & FLAG_QC,FLAG_QI, & - & FLAG_QNC,FLAG_QNI, & - & FLAG_QNWFA,FLAG_QNIFA, & - & Psig_shcu(i), & - & nupdraft(i),ktop_plume(i), & - & maxmf(i),ztop_plume, & - & spp_pbl,rstoch_col ) - ENDIF + &nchem,chem1,s_awchem1, & + &mix_chem, & + &qc_bl1D,cldfra_bl1D, & + &qc_bl1D_old,cldfra_bl1D_old, & + &FLAG_QC,FLAG_QI, & + &FLAG_QNC,FLAG_QNI, & + &FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA, & + &Psig_shcu(i), & + &nupdraft(i),ktop_plume(i), & + &maxmf(i),ztop_plume, & + &spp_pbl,rstoch_col ) + endif - IF (bl_mynn_edmf_dd == 1) THEN - CALL DDMF_JPL(kts,kte,delt,zw,dz1,p1, & - &u1,v1,th1,thl,thetav,tk1, & - sqw,sqv,sqc,rho1,ex1, & - &ust(i),flt,flq, & - &PBLH(i),KPBL(i), & - &edmf_a_dd1,edmf_w_dd1,edmf_qt_dd1, & - &edmf_thl_dd1,edmf_ent_dd1, & - &edmf_qc_dd1, & - &sd_aw1,sd_awthl1,sd_awqt1, & - &sd_awqv1,sd_awqc1,sd_awu1,sd_awv1, & - &sd_awqke1, & - &qc_bl1d,cldfra_bl1d, & - &rthraten(i,:) ) - ENDIF + if (bl_mynn_edmf_dd == 1) then + call DDMF_JPL(kts,kte,delt,zw,dz1,p1, & + &u1,v1,th1,thl,thetav,tk1, & + &sqw,sqv,sqc,rho1,ex1, & + &ust(i),flt,flq, & + &PBLH(i),KPBL(i), & + &edmf_a_dd1,edmf_w_dd1,edmf_qt_dd1, & + &edmf_thl_dd1,edmf_ent_dd1, & + &edmf_qc_dd1, & + &sd_aw1,sd_awthl1,sd_awqt1, & + &sd_awqv1,sd_awqc1,sd_awu1,sd_awv1, & + &sd_awqke1, & + &qc_bl1d,cldfra_bl1d, & + &rthraten(i,:) ) + endif - !Capability to substep the eddy-diffusivity portion - !do nsub = 1,2 - delt2 = delt !*0.5 !only works if topdown=0 - - CALL mym_turbulence ( & - &kts,kte,closure, & - &dz1, DX(i), zw, & - &u1, v1, thl, thetav, sqc, sqw, & - &thlsg, sqwsg, & - &qke1, tsq1, qsq1, cov1, & - &vt, vq, & - &rmol(i), flt, flq, & - &PBLH(i),th1, & - &Sh,Sm,el, & - &Dfm,Dfh,Dfq, & - &Tcd,Qcd,Pdk, & - &Pdt,Pdq,Pdc, & - &qWT1,qSHEAR1,qBUOY1,qDISS1, & - &bl_mynn_tkebudget, & - &Psig_bl(i),Psig_shcu(i), & - &cldfra_bl1D,bl_mynn_mixlength, & - &edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf, & - &TKEprodTD, & - &spp_pbl,rstoch_col) + !Capability to substep the eddy-diffusivity portion + !do nsub = 1,2 + delt2 = delt !*0.5 !only works if topdown=0 + + call mym_turbulence( & + &kts,kte,xland(i),closure, & + &dz1, DX(i), zw, & + &u1, v1, thl, thetav, sqc, sqw, & + &qke1, tsq1, qsq1, cov1, & + &vt, vq, & + &rmol(i), flt, fltv, flq, & + &PBLH(i),th1, & + &Sh,Sm,el, & + &Dfm,Dfh,Dfq, & + &Tcd,Qcd,Pdk, & + &Pdt,Pdq,Pdc, & + &qWT1,qSHEAR1,qBUOY1,qDISS1, & + &tke_budget, & + &Psig_bl(i),Psig_shcu(i), & + &cldfra_bl1D,bl_mynn_mixlength, & + &edmf_w1,edmf_a1, & + &TKEprodTD, & + &spp_pbl,rstoch_col ) !> - Call mym_predict() to solve TKE and !! \f$\theta^{'2}, q^{'2}, and \theta^{'}q^{'}\f$ !! for the following time step. - CALL mym_predict (kts,kte,closure, & - &delt2, dz1, & - &ust(i), flt, flq, pmz, phh, & - &el, dfq, rho1, pdk, pdt, pdq, pdc,& - &Qke1, Tsq1, Qsq1, Cov1, & - &s_aw1, s_awqke1, bl_mynn_edmf_tke,& - &qWT1, qDISS1,bl_mynn_tkebudget) !! TKE budget (Puhales, 2020) - - if (dheat_opt > 0) then - DO k=kts,kte-1 - ! Set max dissipative heating rate to 7.2 K per hour - diss_heat(k) = MIN(MAX(1.0*(qke1(k)**1.5)/(b1*MAX(0.5*(el(k)+el(k+1)),1.))/cp, 0.0),0.002) - ! Limit heating above 100 mb: - diss_heat(k) = diss_heat(k) * exp(-10000./MAX(p1(k),1.)) - ENDDO - diss_heat(kte) = 0. - else - diss_heat(1:kte) = 0. - endif + call mym_predict(kts,kte,closure, & + &delt2, dz1, & + &ust(i), flt, flq, pmz, phh, & + &el, dfq, rho1, pdk, pdt, pdq, pdc, & + &Qke1, Tsq1, Qsq1, Cov1, & + &s_aw1, s_awqke1, bl_mynn_edmf_tke, & + &qWT1, qDISS1, tke_budget ) + + if (dheat_opt > 0) then + do k=kts,kte-1 + ! Set max dissipative heating rate to 7.2 K per hour + diss_heat(k) = MIN(MAX(1.0*(qke1(k)**1.5)/(b1*MAX(0.5*(el(k)+el(k+1)),1.))/cp, 0.0),0.002) + ! Limit heating above 100 mb: + diss_heat(k) = diss_heat(k) * exp(-10000./MAX(p1(k),1.)) + enddo + diss_heat(kte) = 0. + else + diss_heat(1:kte) = 0. + endif !> - Call mynn_tendencies() to solve for tendencies of !! \f$U, V, \theta, q_{v}, q_{c}, and q_{i}\f$. - CALL mynn_tendencies(kts,kte,i, & - &delt, dz1, rho1, & - &u1, v1, th1, tk1, qv1, & - &qc1, qi1, qnc1, qni1, & - &ps(i), p1, ex1, thl, & - &sqv, sqc, sqi, sqw, & - &qnwfa1, qnifa1, ozone1, & - &ust(i),flt,flq,flqv,flqc, & - &wspd(i),uoce(i),voce(i), & - &tsq1, qsq1, cov1, & - &tcd, qcd, & - &dfm, dfh, dfq, & - &Du1, Dv1, Dth1, Dqv1, & - &Dqc1, Dqi1, Dqnc1, Dqni1, & - &Dqnwfa1, Dqnifa1, Dozone1, & - &diss_heat, & + call mynn_tendencies(kts,kte,i, & + &delt, dz1, rho1, & + &u1, v1, th1, tk1, qv1, & + &qc1, qi1, qs1, qnc1, qni1, & + &ps(i), p1, ex1, thl, & + &sqv, sqc, sqi, sqs, sqw, & + &qnwfa1, qnifa1, qnbca1, ozone1, & + &ust(i),flt,flq,flqv,flqc, & + &wspd(i),uoce(i),voce(i), & + &tsq1, qsq1, cov1, & + &tcd, qcd, & + &dfm, dfh, dfq, & + &Du1, Dv1, Dth1, Dqv1, & + &Dqc1, Dqi1, Dqs1, Dqnc1, Dqni1, & + &Dqnwfa1, Dqnifa1, Dqnbca1, & + &Dozone1, & + &diss_heat, & ! mass flux components - &s_aw1,s_awthl1,s_awqt1, & - &s_awqv1,s_awqc1,s_awu1,s_awv1, & - &s_awqnc1,s_awqni1, & - &s_awqnwfa1,s_awqnifa1, & - &sd_aw1,sd_awthl1,sd_awqt1, & - &sd_awqv1,sd_awqc1, & - sd_awu1,sd_awv1, & - &sub_thl,sub_sqv, & - &sub_u,sub_v, & - &det_thl,det_sqv,det_sqc, & - &det_u,det_v, & - &FLAG_QC,FLAG_QI,FLAG_QNC, & - &FLAG_QNI,FLAG_QNWFA,FLAG_QNIFA, & - &cldfra_bl1d, & - &bl_mynn_cloudmix, & - &bl_mynn_mixqt, & - &bl_mynn_edmf, & - &bl_mynn_edmf_mom, & - &bl_mynn_mixscalars ) - - - IF ( mix_chem ) THEN - IF ( rrfs_sd ) THEN - CALL mynn_mix_chem(kts,kte,i, & - &delt, dz1, pblh(i), & - &nchem, kdvel, ndvel, & - &chem1, vd1, & - &rho1,flt, & - &tcd, qcd, & - &dfh, & - &s_aw1,s_awchem1, & - &emis_ant_no(i), & - &frp(i), rrfs_sd, & - &enh_mix, smoke_dbg ) - ELSE - CALL mynn_mix_chem(kts,kte,i, & - &delt, dz1, pblh(i), & - &nchem, kdvel, ndvel, & - &chem1, vd1, & - &rho1,flt, & - &tcd, qcd, & - &dfh, & - &s_aw1,s_awchem1, & - &zero, & - &zero, rrfs_sd, & - &enh_mix, smoke_dbg ) - ENDIF - DO ic = 1,nchem - DO k = kts,kte - chem3d(i,k,ic) = max(1.e-12, chem1(k,ic)) - ENDDO - ENDDO - ENDIF + &s_aw1,s_awthl1,s_awqt1, & + &s_awqv1,s_awqc1,s_awu1,s_awv1, & + &s_awqnc1,s_awqni1, & + &s_awqnwfa1,s_awqnifa1,s_awqnbca1, & + &sd_aw1,sd_awthl1,sd_awqt1, & + &sd_awqv1,sd_awqc1, & + &sd_awu1,sd_awv1, & + &sub_thl,sub_sqv, & + &sub_u,sub_v, & + &det_thl,det_sqv,det_sqc, & + &det_u,det_v, & + &FLAG_QC,FLAG_QI,FLAG_QNC, & + &FLAG_QNI,FLAG_QS, & + &FLAG_QNWFA,FLAG_QNIFA, & + &FLAG_QNBCA, & + &cldfra_bl1d, & + &bl_mynn_cloudmix, & + &bl_mynn_mixqt, & + &bl_mynn_edmf, & + &bl_mynn_edmf_mom, & + &bl_mynn_mixscalars ) + + + if ( mix_chem ) then + if ( rrfs_sd ) then + call mynn_mix_chem(kts,kte,i, & + &delt, dz1, pblh(i), & + &nchem, kdvel, ndvel, & + &chem1, vd1, & + &rho1,flt, & + &tcd, qcd, & + &dfh, & + &s_aw1,s_awchem1, & + &emis_ant_no(i), & + &frp(i), rrfs_sd, & + &enh_mix, smoke_dbg ) + else + call mynn_mix_chem(kts,kte,i, & + &delt, dz1, pblh(i), & + &nchem, kdvel, ndvel, & + &chem1, vd1, & + &rho1,flt, & + &tcd, qcd, & + &dfh, & + &s_aw1,s_awchem1, & + &zero, & + &zero, rrfs_sd, & + &enh_mix, smoke_dbg ) + endif + do ic = 1,nchem + do k = kts,kte + chem3d(i,k,ic) = max(1.e-12, chem1(k,ic)) + enddo + enddo + endif - CALL retrieve_exchange_coeffs(kts,kte,& - &dfm, dfh, dz1, K_m1, K_h1) - - !UPDATE 3D ARRAYS - do k=kts,kte - exch_m(i,k)=K_m1(k) - exch_h(i,k)=K_h1(k) - rublten(i,k)=du1(k) - rvblten(i,k)=dv1(k) - rthblten(i,k)=dth1(k) - rqvblten(i,k)=dqv1(k) - if (bl_mynn_cloudmix > 0) then - if (FLAG_QC) rqcblten(i,k)=dqc1(k) - if (FLAG_QI) rqiblten(i,k)=dqi1(k) - else - if (FLAG_QC) rqcblten(i,k)=0. - if (FLAG_QI) rqiblten(i,k)=0. - endif - if (bl_mynn_cloudmix > 0 .and. bl_mynn_mixscalars > 0) then - if (FLAG_QNC) rqncblten(i,k)=dqnc1(k) - if (FLAG_QNI) rqniblten(i,k)=dqni1(k) - if (FLAG_QNWFA) rqnwfablten(i,k)=dqnwfa1(k) - if (FLAG_QNIFA) rqnifablten(i,k)=dqnifa1(k) - else - if (FLAG_QNC) rqncblten(i,k)=0. - if (FLAG_QNI) rqniblten(i,k)=0. - if (FLAG_QNWFA) rqnwfablten(i,k)=0. - if (FLAG_QNIFA) rqnifablten(i,k)=0. - endif - dozone(i,k)=dozone1(k) - - if (icloud_bl > 0) then - qc_bl(i,k)=qc_bl1D(k) - qi_bl(i,k)=qi_bl1D(k) - cldfra_bl(i,k)=cldfra_bl1D(k) - endif - - el_pbl(i,k)=el(k) - qke(i,k)=qke1(k) - tsq(i,k)=tsq1(k) - qsq(i,k)=qsq1(k) - cov(i,k)=cov1(k) - sh3d(i,k)=sh(k) - sm3d(i,k)=sm(k) - enddo !end-k + call retrieve_exchange_coeffs(kts,kte, & + &dfm, dfh, dz1, K_m1, K_h1 ) + + !UPDATE 3D ARRAYS + exch_m(i,:) =k_m1(:) + exch_h(i,:) =k_h1(:) + rublten(i,:) =du1(:) + rvblten(i,:) =dv1(:) + rthblten(i,:)=dth1(:) + rqvblten(i,:)=dqv1(:) + if (bl_mynn_cloudmix > 0) then + if (flag_qc) rqcblten(i,:)=dqc1(:) + if (flag_qi) rqiblten(i,:)=dqi1(:) + if (flag_qs) rqsblten(i,:)=dqs1(:) + else + if (flag_qc) rqcblten(i,:)=0. + if (flag_qi) rqiblten(i,:)=0. + if (flag_qs) rqsblten(i,:)=0. + endif + if (bl_mynn_cloudmix > 0 .and. bl_mynn_mixscalars > 0) then + if (flag_qnc) rqncblten(i,:) =dqnc1(:) + if (flag_qni) rqniblten(i,:) =dqni1(:) + if (flag_qnwfa) rqnwfablten(i,:)=dqnwfa1(:) + if (flag_qnifa) rqnifablten(i,:)=dqnifa1(:) + if (flag_qnbca) rqnbcablten(i,:)=dqnbca1(:) + else + if (flag_qnc) rqncblten(i,:) =0. + if (flag_qni) rqniblten(i,:) =0. + if (flag_qnwfa) rqnwfablten(i,:)=0. + if (flag_qnifa) rqnifablten(i,:)=0. + if (flag_qnbca) rqnbcablten(i,:)=0. + endif + dozone(i,:)=dozone1(:) + if (icloud_bl > 0) then + qc_bl(i,:) =qc_bl1D(:) + qi_bl(i,:) =qi_bl1D(:) + cldfra_bl(i,:)=cldfra_bl1D(:) + endif + el_pbl(i,:)=el(:) + qke(i,:) =qke1(:) + tsq(i,:) =tsq1(:) + qsq(i,:) =qsq1(:) + cov(i,:) =cov1(:) + sh3d(i,:) =sh(:) + sm3d(i,:) =sm(:) + + if (tke_budget .eq. 1) then + !! TKE budget is now given in m**2/s**-3 (Puhales, 2020) + !! Lower boundary condtions (using similarity relationships such as the prognostic equation for Qke) + k=kts + qSHEAR1(k) =4.*(ust(i)**3*phi_m/(karman*dz(i,k)))-qSHEAR1(k+1) !! staggered + qBUOY1(k) =4.*(-ust(i)**3*zet/(karman*dz(i,k)))-qBUOY1(k+1) !! staggered + !! unstaggering SHEAR and BUOY and trasfering all TKE budget to 3D array + do k = kts,kte-1 + qSHEAR(i,k)=0.5*(qSHEAR1(k)+qSHEAR1(k+1)) !!! unstaggering in z + qBUOY(i,k) =0.5*(qBUOY1(k)+qBUOY1(k+1)) !!! unstaggering in z + qWT(i,k) =qWT1(k) + qDISS(i,k) =qDISS1(k) + dqke(i,k) =(qke1(k)-dqke(i,k))*0.5/delt + enddo + !! Upper boundary conditions + k=kte + qSHEAR(i,k) =0. + qBUOY(i,k) =0. + qWT(i,k) =0. + qDISS(i,k) =0. + dqke(i,k) =0. + endif - if ( bl_mynn_tkebudget ) then - !! TKE budget is now given in m**2/s**-3 (Puhales, 2020) - !! Lower boundary condtions (using similarity relationships such as the prognostic equation for Qke) - k=kts - qSHEAR1(k)=4.*(ust(i)**3*phi_m/(karman*dz(i,k)))-qSHEAR1(k+1) !! staggered - qBUOY1(k)=4.*(-ust(i)**3*zet/(karman*dz(i,k)))-qBUOY1(k+1) !! staggered - !! unstaggering SHEAR and BUOY and trasfering all TKE budget to 3D array - do k = kts,kte-1 - qSHEAR(i,k)=0.5*(qSHEAR1(k)+qSHEAR1(k+1)) !!! unstaggering in z - qBUOY(i,k)=0.5*(qBUOY1(k)+qBUOY1(k+1)) !!! unstaggering in z - qWT(i,k)=qWT1(k) - qDISS(i,k)=qDISS1(k) - dqke(i,k)=(qke1(k)-dqke(i,k))*0.5/delt - enddo - !! Upper boundary conditions - k=kte - qSHEAR(i,k)=0. - qBUOY(i,k)=0. - qWT(i,k)=0. - qDISS(i,k)=0. - dqke(i,k)=0. + !update updraft/downdraft properties + if (bl_mynn_output > 0) then !research mode == 1 + if (bl_mynn_edmf > 0) then + edmf_a(i,:) =edmf_a1(:) + edmf_w(i,:) =edmf_w1(:) + edmf_qt(i,:) =edmf_qt1(:) + edmf_thl(i,:) =edmf_thl1(:) + edmf_ent(i,:) =edmf_ent1(:) + edmf_qc(i,:) =edmf_qc1(:) + sub_thl3D(i,:)=sub_thl(:) + sub_sqv3D(i,:)=sub_sqv(:) + det_thl3D(i,:)=det_thl(:) + det_sqv3D(i,:)=det_sqv(:) endif + !if (bl_mynn_edmf_dd > 0) THEN + ! edmf_a_dd(i,:) =edmf_a_dd1(:) + ! edmf_w_dd(i,:) =edmf_w_dd1(:) + ! edmf_qt_dd(i,:) =edmf_qt_dd1(:) + ! edmf_thl_dd(i,:)=edmf_thl_dd1(:) + ! edmf_ent_dd(i,:)=edmf_ent_dd1(:) + ! edmf_qc_dd(i,:) =edmf_qc_dd1(:) + !endif + endif - !update updraft/downdraft properties - if (bl_mynn_output > 0) THEN !research mode == 1 - if (bl_mynn_edmf > 0) THEN - DO k = kts,kte - edmf_a(i,k)=edmf_a1(k) - edmf_w(i,k)=edmf_w1(k) - edmf_qt(i,k)=edmf_qt1(k) - edmf_thl(i,k)=edmf_thl1(k) - edmf_ent(i,k)=edmf_ent1(k) - edmf_qc(i,k)=edmf_qc1(k) - sub_thl3D(i,k)=sub_thl(k) - sub_sqv3D(i,k)=sub_sqv(k) - det_thl3D(i,k)=det_thl(k) - det_sqv3D(i,k)=det_sqv(k) - ENDDO - endif -! if (bl_mynn_edmf_dd > 0) THEN -! DO k = kts,kte -! edmf_a_dd(i,k)=edmf_a_dd1(k) -! edmf_w_dd(i,k)=edmf_w_dd1(k) -! edmf_qt_dd(i,k)=edmf_qt_dd1(k) -! edmf_thl_dd(i,k)=edmf_thl_dd1(k) -! edmf_ent_dd(i,k)=edmf_ent_dd1(k) -! edmf_qc_dd(i,k)=edmf_qc_dd1(k) -! ENDDO -! ENDIF - ENDIF - - !*** Begin debug prints - IF ( debug_code .and. (i .eq. idbg)) THEN - IF ( ABS(QFX(i))>.001)print*,& - "SUSPICIOUS VALUES AT: i=",i," QFX=",QFX(i) - IF ( ABS(HFX(i))>1100.)print*,& - "SUSPICIOUS VALUES AT: i=",i," HFX=",HFX(i) - DO k = kts,kte - IF ( sh(k) < 0. .OR. sh(k)> 200.)print*,& - "SUSPICIOUS VALUES AT: i,k=",i,k," sh=",sh(k) - IF ( ABS(vt(k)) > 2.0 )print*,& - "SUSPICIOUS VALUES AT: i,k=",i,k," vt=",vt(k) - IF ( ABS(vq(k)) > 7000.)print*,& - "SUSPICIOUS VALUES AT: i,k=",i,k," vq=",vq(k) - IF ( qke(i,k) < -1. .OR. qke(i,k)> 200.)print*,& - "SUSPICIOUS VALUES AT: i,k=",i,k," qke=",qke(i,k) - IF ( el_pbl(i,k) < 0. .OR. el_pbl(i,k)> 1500.)print*,& - "SUSPICIOUS VALUES AT: i,k=",i,k," el_pbl=",el_pbl(i,k) - IF ( exch_m(i,k) < 0. .OR. exch_m(i,k)> 2000.)print*,& - "SUSPICIOUS VALUES AT: i,k=",i,k," exxch_m=",exch_m(i,k) - IF (icloud_bl > 0) then - IF( cldfra_bl(i,k) < 0.0 .OR. cldfra_bl(i,k)> 1.)THEN - PRINT*,"SUSPICIOUS VALUES: CLDFRA_BL=",cldfra_bl(i,k)," qc_bl=",QC_BL(i,k) - ENDIF - ENDIF - - !IF (I==IMD .AND. J==JMD) THEN - ! PRINT*,"MYNN DRIVER END: k=",k," sh=",sh(k) - ! PRINT*," sqw=",sqw(k)," thl=",thl(k)," exch_m=",exch_m(i,k) - ! PRINT*," xland=",xland(i)," rmol=",rmol(i)," ust=",ust(i) - ! PRINT*," qke=",qke(i,k)," el=",el_pbl(i,k)," tsq=",tsq(i,k) - ! PRINT*," PBLH=",PBLH(i)," u=",u(i,k)," v=",v(i,k) - ! PRINT*," vq=",vq(k)," vt=",vt(k)," vdfg=",vdfg(i) - !ENDIF - ENDDO !end-k - ENDIF - !*** End debug prints + !*** Begin debug prints + if ( debug_code .and. (i .eq. idbg)) THEN + if ( ABS(QFX(i))>.001)print*,& + "SUSPICIOUS VALUES AT: i=",i," QFX=",QFX(i) + if ( ABS(HFX(i))>1100.)print*,& + "SUSPICIOUS VALUES AT: i=",i," HFX=",HFX(i) + do k = kts,kte + IF ( sh(k) < 0. .OR. sh(k)> 200.)print*,& + "SUSPICIOUS VALUES AT: i,k=",i,k," sh=",sh(k) + IF ( ABS(vt(k)) > 2.0 )print*,& + "SUSPICIOUS VALUES AT: i,k=",i,k," vt=",vt(k) + IF ( ABS(vq(k)) > 7000.)print*,& + "SUSPICIOUS VALUES AT: i,k=",i,k," vq=",vq(k) + IF ( qke(i,k) < -1. .OR. qke(i,k)> 200.)print*,& + "SUSPICIOUS VALUES AT: i,k=",i,k," qke=",qke(i,k) + IF ( el_pbl(i,k) < 0. .OR. el_pbl(i,k)> 1500.)print*,& + "SUSPICIOUS VALUES AT: i,k=",i,k," el_pbl=",el_pbl(i,k) + IF ( exch_m(i,k) < 0. .OR. exch_m(i,k)> 2000.)print*,& + "SUSPICIOUS VALUES AT: i,k=",i,k," exxch_m=",exch_m(i,k) + IF (icloud_bl > 0) then + IF ( cldfra_bl(i,k) < 0.0 .OR. cldfra_bl(i,k)> 1.)THEN + PRINT*,"SUSPICIOUS VALUES: CLDFRA_BL=",cldfra_bl(i,k)," qc_bl=",QC_BL(i,k) + ENDIF + ENDIF - !JOE-add tke_pbl for coupling w/shallow-cu schemes (TKE_PBL = QKE/2.) - ! TKE_PBL is defined on interfaces, while QKE is at middle of layer. - !tke_pbl(i,kts) = 0.5*MAX(qke(i,kts),1.0e-10) - !DO k = kts+1,kte - ! afk = dz1(k)/( dz1(k)+dz1(k-1) ) - ! abk = 1.0 -afk - ! tke_pbl(i,k) = 0.5*MAX(qke(i,k)*abk+qke(i,k-1)*afk,1.0e-3) - !ENDDO + !IF (I==IMD .AND. J==JMD) THEN + ! PRINT*,"MYNN DRIVER END: k=",k," sh=",sh(k) + ! PRINT*," sqw=",sqw(k)," thl=",thl(k)," exch_m=",exch_m(i,k) + ! PRINT*," xland=",xland(i)," rmol=",rmol(i)," ust=",ust(i) + ! PRINT*," qke=",qke(i,k)," el=",el_pbl(i,k)," tsq=",tsq(i,k) + ! PRINT*," PBLH=",PBLH(i)," u=",u(i,k)," v=",v(i,k) + ! PRINT*," vq=",vq(k)," vt=",vt(k) + !ENDIF + enddo !end-k + endif - ENDDO !end i-loop + enddo !end i-loop !ACF copy qke into qke_adv if using advection IF (bl_mynn_tkeadvect) THEN @@ -1610,40 +1497,40 @@ END SUBROUTINE mynn_bl_driver !!\section gen_mym_ini GSD MYNN-EDMF mym_initialize General Algorithm !> @{ SUBROUTINE mym_initialize ( & - & kts,kte, & + & kts,kte,xland, & & dz, dx, zw, & & u, v, thl, qw, & - & thlsg, qwsg, & ! & ust, rmo, pmz, phh, flt, flq, & & zi, theta, thetav, sh, sm, & & ust, rmo, el, & & Qke, Tsq, Qsq, Cov, Psig_bl, cldfra_bl1D, & & bl_mynn_mixlength, & - & edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf, & + & edmf_w1,edmf_a1, & & INITIALIZE_QKE, & & spp_pbl,rstoch_col) ! !------------------------------------------------------------------- - - INTEGER, INTENT(IN) :: kts,kte - INTEGER, INTENT(IN) :: bl_mynn_mixlength,bl_mynn_edmf - LOGICAL, INTENT(IN) :: INITIALIZE_QKE -! REAL, INTENT(IN) :: ust, rmo, pmz, phh, flt, flq - REAL, INTENT(IN) :: rmo, Psig_bl - REAL(kind=kind_phys), INTENT(IN) :: dx, ust, zi - REAL, DIMENSION(kts:kte), INTENT(in) :: dz - REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw - REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,qw,cldfra_bl1D,& - edmf_w1,edmf_a1,edmf_qc1 - REAL, DIMENSION(kts:kte), INTENT(out) :: tsq,qsq,cov - REAL, DIMENSION(kts:kte), INTENT(inout) :: el,qke - REAL, DIMENSION(kts:kte) :: & - &ql,pdk,pdt,pdq,pdc,dtl,dqw,dtv,& + + integer, INTENT(IN) :: kts,kte + integer, INTENT(IN) :: bl_mynn_mixlength + logical, INTENT(IN) :: INITIALIZE_QKE +! real(kind_phys), INTENT(IN) :: ust, rmo, pmz, phh, flt, flq + real(kind_phys), INTENT(IN) :: rmo, Psig_bl, xland + real(kind_phys), INTENT(IN) :: dx, ust, zi + real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: dz + real(kind_phys), DIMENSION(kts:kte+1), INTENT(in) :: zw + real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: u,v,thl,& + &qw,cldfra_bl1D,edmf_w1,edmf_a1 + real(kind_phys), DIMENSION(kts:kte), INTENT(out) :: tsq,qsq,cov + real(kind_phys), DIMENSION(kts:kte), INTENT(inout) :: el,qke + real(kind_phys), DIMENSION(kts:kte) :: & + &ql,pdk,pdt,pdq,pdc,dtl,dqw,dtv, & &gm,gh,sm,sh,qkw,vt,vq INTEGER :: k,l,lmax - REAL :: phm,vkz,elq,elv,b1l,b2l,pmz=1.,phh=1.,flt=0.,flq=0.,tmpq - REAL, DIMENSION(kts:kte) :: theta,thetav,thlsg,qwsg - REAL, DIMENSION(kts:kte) :: rstoch_col + real(kind_phys):: phm,vkz,elq,elv,b1l,b2l,pmz=1.,phh=1., & + &flt=0.,fltv=0.,flq=0.,tmpq + real(kind_phys), DIMENSION(kts:kte) :: theta,thetav + real(kind_phys), DIMENSION(kts:kte) :: rstoch_col INTEGER ::spp_pbl !> - At first ql, vt and vq are set to zero. @@ -1657,7 +1544,6 @@ SUBROUTINE mym_initialize ( & CALL mym_level2 ( kts,kte, & & dz, & & u, v, thl, thetav, qw, & - & thlsg, qwsg, & & ql, vt, vq, & & dtl, dqw, dtv, gm, gh, sm, sh ) ! @@ -1696,17 +1582,18 @@ SUBROUTINE mym_initialize ( & DO l = 1,lmax ! !> - call mym_length() to calculate the master length scale. - CALL mym_length ( & - & kts,kte, & - & dz, dx, zw, & - & rmo, flt, flq, & - & vt, vq, & - & u, v, qke, & - & dtv, & - & el, & - & zi,theta, & - & qkw,Psig_bl,cldfra_bl1D,bl_mynn_mixlength,& - & edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf) + CALL mym_length ( & + & kts,kte,xland, & + & dz, dx, zw, & + & rmo, flt, fltv, flq, & + & vt, vq, & + & u, v, qke, & + & dtv, & + & el, & + & zi,theta, & + & qkw,Psig_bl,cldfra_bl1D, & + & bl_mynn_mixlength, & + & edmf_w1,edmf_a1 ) ! DO k = kts+1,kte elq = el(k)*qkw(k) @@ -1816,7 +1703,6 @@ END SUBROUTINE mym_initialize SUBROUTINE mym_level2 (kts,kte, & & dz, & & u, v, thl, thetav, qw, & - & thlsg, qwsg, & & ql, vt, vq, & & dtl, dqw, dtv, gm, gh, sm, sh ) ! @@ -1829,18 +1715,19 @@ SUBROUTINE mym_level2 (kts,kte, & # define kte HARDCODE_VERTICAL #endif - REAL, DIMENSION(kts:kte), INTENT(in) :: dz - REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,qw,ql,vt,vq,& - thetav,thlsg,qwsg - REAL, DIMENSION(kts:kte), INTENT(out) :: & + real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: dz + real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: u,v, & + &thl,qw,ql,vt,vq,thetav + real(kind_phys), DIMENSION(kts:kte), INTENT(out) :: & &dtl,dqw,dtv,gm,gh,sm,sh - INTEGER :: k + integer :: k - REAL :: rfc,f1,f2,rf1,rf2,smc,shc,& - &ri1,ri2,ri3,ri4,duz,dtz,dqz,vtt,vqq,dtq,dzk,afk,abk,ri,rf + real(kind_phys):: rfc,f1,f2,rf1,rf2,smc,shc, & + &ri1,ri2,ri3,ri4,duz,dtz,dqz,vtt,vqq,dtq,dzk, & + &afk,abk,ri,rf - REAL :: a2fac + real(kind_phys):: a2fac ! ev = 2.5e6 ! tv0 = 0.61*tref @@ -1868,11 +1755,7 @@ SUBROUTINE mym_level2 (kts,kte, & duz = ( u(k)-u(k-1) )**2 +( v(k)-v(k-1) )**2 duz = duz /dzk**2 dtz = ( thl(k)-thl(k-1) )/( dzk ) - !Alternatively, use SGS clouds for thl - !dtz = ( thlsg(k)-thlsg(k-1) )/( dzk ) dqz = ( qw(k)-qw(k-1) )/( dzk ) - !Alternatively, use SGS clouds for qw - !dqz = ( qwsg(k)-qwsg(k-1) )/( dzk ) ! vtt = 1.0 +vt(k)*abk +vt(k-1)*afk ! Beta-theta in NN09, Eq. 39 vqq = tv0 +vq(k)*abk +vq(k-1)*afk ! Beta-q @@ -1949,16 +1832,17 @@ END SUBROUTINE mym_level2 !>\ingroup gsd_mynn_edmf !! This subroutine calculates the mixing lengths. SUBROUTINE mym_length ( & - & kts,kte, & + & kts,kte,xland, & & dz, dx, zw, & - & rmo, flt, flq, & + & rmo, flt, fltv, flq, & & vt, vq, & & u1, v1, qke, & & dtv, & & el, & - & zi,theta, & - & qkw,Psig_bl,cldfra_bl1D,bl_mynn_mixlength,& - & edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf) + & zi, theta, qkw, & + & Psig_bl, cldfra_bl1D, & + & bl_mynn_mixlength, & + & edmf_w1,edmf_a1 ) !------------------------------------------------------------------- @@ -1969,53 +1853,50 @@ SUBROUTINE mym_length ( & # define kte HARDCODE_VERTICAL #endif - INTEGER, INTENT(IN) :: bl_mynn_mixlength,bl_mynn_edmf - REAL, DIMENSION(kts:kte), INTENT(in) :: dz - REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw - REAL, INTENT(in) :: rmo,flt,flq,Psig_bl - REAL(kind=kind_phys), INTENT(IN) :: dx,zi - REAL, DIMENSION(kts:kte), INTENT(IN) :: u1,v1,qke,vt,vq,cldfra_bl1D,& - edmf_w1,edmf_a1,edmf_qc1 - REAL, DIMENSION(kts:kte), INTENT(out) :: qkw, el - REAL, DIMENSION(kts:kte), INTENT(in) :: dtv - - REAL :: elt,vsc - - REAL, DIMENSION(kts:kte), INTENT(IN) :: theta - REAL, DIMENSION(kts:kte) :: qtke,elBLmin,elBLavg,thetaw - REAL :: wt,wt2,zi2,h1,h2,hs,elBLmin0,elBLavg0,cldavg + INTEGER, INTENT(IN) :: bl_mynn_mixlength + real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: dz + real(kind_phys), DIMENSION(kts:kte+1), INTENT(in) :: zw + real(kind_phys), INTENT(in) :: rmo,flt,fltv,flq,Psig_bl,xland + real(kind_phys), INTENT(IN) :: dx,zi + real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: u1,v1, & + &qke,vt,vq,cldfra_bl1D,edmf_w1,edmf_a1 + real(kind_phys), DIMENSION(kts:kte), INTENT(out) :: qkw, el + real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: dtv + real(kind_phys):: elt,vsc + real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: theta + real(kind_phys), DIMENSION(kts:kte) :: qtke,elBLmin,elBLavg,thetaw + real(kind_phys):: wt,wt2,zi2,h1,h2,hs,elBLmin0,elBLavg0,cldavg ! THE FOLLOWING CONSTANTS ARE IMPORTANT FOR REGULATING THE ! MIXING LENGTHS: - REAL :: cns, & !< for surface layer (els) in stable conditions - alp1, & !< for turbulent length scale (elt) - alp2, & !< for buoyancy length scale (elb) - alp3, & !< for buoyancy enhancement factor of elb - alp4, & !< for surface layer (els) in unstable conditions - alp5, & !< for BouLac mixing length or above PBLH - alp6 !< for mass-flux/ + real(kind_phys):: cns, & !< for surface layer (els) in stable conditions + alp1, & !< for turbulent length scale (elt) + alp2, & !< for buoyancy length scale (elb) + alp3, & !< for buoyancy enhancement factor of elb + alp4, & !< for surface layer (els) in unstable conditions + alp5, & !< for BouLac mixing length or above PBLH + alp6 !< for mass-flux/ !THE FOLLOWING LIMITS DO NOT DIRECTLY AFFECT THE ACTUAL PBLH. !THEY ONLY IMPOSE LIMITS ON THE CALCULATION OF THE MIXING LENGTH !SCALES SO THAT THE BOULAC MIXING LENGTH (IN FREE ATMOS) DOES !NOT ENCROACH UPON THE BOUNDARY LAYER MIXING LENGTH (els, elb & elt). - REAL, PARAMETER :: minzi = 300. !< min mixed-layer height - REAL, PARAMETER :: maxdz = 750. !< max (half) transition layer depth + real(kind_phys), PARAMETER :: minzi = 300. !< min mixed-layer height + real(kind_phys), PARAMETER :: maxdz = 750. !< max (half) transition layer depth !! =0.3*2500 m PBLH, so the transition !! layer stops growing for PBLHs > 2.5 km. - REAL, PARAMETER :: mindz = 300. !< 300 !min (half) transition layer depth + real(kind_phys), PARAMETER :: mindz = 300. !< 300 !min (half) transition layer depth !SURFACE LAYER LENGTH SCALE MODS TO REDUCE IMPACT IN UPPER BOUNDARY LAYER - REAL, PARAMETER :: ZSLH = 100. !< Max height correlated to surface conditions (m) - REAL, PARAMETER :: CSL = 2. !< CSL = constant of proportionality to L O(1) - REAL :: z_m + real(kind_phys), PARAMETER :: ZSLH = 100. !< Max height correlated to surface conditions (m) + real(kind_phys), PARAMETER :: CSL = 2. !< CSL = constant of proportionality to L O(1) INTEGER :: i,j,k - REAL :: afk,abk,zwk,zwk1,dzk,qdz,vflx,bv,tau_cloud,wstar,elb,els, & - & els1,elf,el_stab,el_unstab,el_mf,el_stab_mf,elb_mf, & - & PBLH_PLUS_ENT,Uonset,Ugrid,el_les - REAL, PARAMETER :: ctau = 1000. !constant for tau_cloud + real(kind_phys):: afk,abk,zwk,zwk1,dzk,qdz,vflx,bv,tau_cloud, & + & wstar,elb,els,elf,el_stab,el_mf,el_stab_mf,elb_mf, & + & PBLH_PLUS_ENT,Uonset,Ugrid,wt_u,el_les + real(kind_phys), PARAMETER :: ctau = 1000. !constant for tau_cloud ! tv0 = 0.61*tref ! gtr = 9.81/tref @@ -2083,15 +1964,11 @@ SUBROUTINE mym_length ( & elf = elb ENDIF - z_m = MAX(0.,zwk - 4.) - ! ** Length scale in the surface layer ** IF ( rmo .GT. 0.0 ) THEN els = karman*zwk/(1.0+cns*MIN( zwk*rmo, zmax )) - els1 = karman*z_m/(1.0+cns*MIN( zwk*rmo, zmax )) ELSE els = karman*zwk*( 1.0 - alp4* zwk*rmo )**0.2 - els1 = karman*z_m*( 1.0 - alp4* zwk*rmo )**0.2 END IF ! ** HARMONC AVERGING OF MIXING LENGTH SCALES: @@ -2106,18 +1983,21 @@ SUBROUTINE mym_length ( & CASE (1) !NONLOCAL (using BouLac) FORM OF MIXING LENGTH - cns = 3.5 - alp1 = 0.22 !0.21 + ugrid = sqrt(u1(kts)**2 + v1(kts)**2) + uonset= 15. + wt_u = (1.0 - min(max(ugrid - uonset, 0.0)/30.0, 0.5)) + cns = 2.7 !was 3.5 + alp1 = 0.22 alp2 = 0.3 - alp3 = 2.0 !1.5 + alp3 = 2.0 * wt_u !taper off bouyancy enhancement in shear-driven pbls alp4 = 5.0 alp5 = 0.3 alp6 = 50. ! Impose limits on the height integration for elt and the transition layer depth - zi2=MAX(zi,200.) !minzi) - h1=MAX(0.3*zi2,200.) - h1=MIN(h1,500.) ! 1/2 transition layer depth + zi2=MAX(zi,300.) !minzi) + h1=MAX(0.3*zi2,300.) + h1=MIN(h1,600.) ! 1/2 transition layer depth h2=h1/2.0 ! 1/4 transition layer depth qtke(kts)=MAX(0.5*qke(kts), 0.01) !tke at full sigma levels @@ -2148,7 +2028,9 @@ SUBROUTINE mym_length ( & END DO elt = MIN( MAX( alp1*elt/vsc, 10.), 400.) - vflx = ( vt(kts)+1.0 )*flt +( vq(kts)+tv0 )*flq + !avoid use of buoyancy flux functions which are ill-defined at the surface + !vflx = ( vt(kts)+1.0 )*flt + ( vq(kts)+tv0 )*flq + vflx = fltv vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**onethird ! ** Strictly, el(i,j,1) is not zero. ** @@ -2163,31 +2045,23 @@ SUBROUTINE mym_length ( & ! ** Length scale limited by the buoyancy effect ** IF ( dtv(k) .GT. 0.0 ) THEN - alp2 = 0.3 !test+ 0.15*0.5*(cldfra_bl1D(k)+cldfra_bl1D(k-1)) bv = max( sqrt( gtr*dtv(k) ), 0.001) - !elb = alp2*qkw(k) / bv & ! formulation, - ! & *( 1.0 + alp3/alp2*& ! except keep - ! &SQRT( vsc/( bv*elt ) ) ) ! elb bounded by zwk elb = MAX(alp2*qkw(k), & & alp6*edmf_a1(k-1)*edmf_w1(k-1)) / bv & & *( 1.0 + alp3*SQRT( vsc/(bv*elt) ) ) elb = MIN(elb, zwk) - elf = 0.65 * qkw(k)/bv + elf = 0.80 * qkw(k)/bv elBLavg(k) = MAX(elBLavg(k), alp6*edmf_a1(k-1)*edmf_w1(k-1)/bv) ELSE elb = 1.0e10 elf = elb ENDIF - z_m = MAX(0.,zwk - 4.) - ! ** Length scale in the surface layer ** IF ( rmo .GT. 0.0 ) THEN els = karman*zwk/(1.0+cns*MIN( zwk*rmo, zmax )) - els1 = karman*z_m/(1.0+cns*MIN( zwk*rmo, zmax )) ELSE els = karman*zwk*( 1.0 - alp4* zwk*rmo )**0.2 - els1 = karman*z_m*( 1.0 - alp4* zwk*rmo )**0.2 END IF ! ** NOW BLEND THE MIXING LENGTH SCALES: @@ -2197,8 +2071,7 @@ SUBROUTINE mym_length ( & !defined relative to the PBLH (zi) + transition layer (h1) !el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf) !try squared-blending - !el_unstab = SQRT( els**2/(1. + (els1**2/elt**2) )) - el(k) = SQRT( els**2/(1. + (els1**2/elt**2) +(els1**2/elb**2))) + el(k) = SQRT( els**2/(1. + (els**2/elt**2) +(els**2/elb**2))) el(k) = MIN (el(k), elf) el(k) = el(k)*(1.-wt) + alp5*elBLavg(k)*wt @@ -2212,20 +2085,20 @@ SUBROUTINE mym_length ( & Uonset = 3.5 + dz(kts)*0.1 Ugrid = sqrt(u1(kts)**2 + v1(kts)**2) cns = 3.5 !JOE-test * (1.0 - MIN(MAX(Ugrid - Uonset, 0.0)/10.0, 1.0)) - alp1 = 0.22 !0.21 + alp1 = 0.22 alp2 = 0.30 - alp3 = 2.0 !1.5 + alp3 = 2.0 alp4 = 5.0 alp5 = alp2 !like alp2, but for free atmosphere alp6 = 50.0 !used for MF mixing length ! Impose limits on the height integration for elt and the transition layer depth !zi2=MAX(zi,minzi) - zi2=MAX(zi, 200.) + zi2=MAX(zi, 300.) !h1=MAX(0.3*zi2,mindz) !h1=MIN(h1,maxdz) ! 1/2 transition layer depth - h1=MAX(0.3*zi2,200.) - h1=MIN(h1,500.) + h1=MAX(0.3*zi2,300.) + h1=MIN(h1,600.) h2=h1*0.5 ! 1/4 transition layer depth qtke(kts)=MAX(0.5*qke(kts),0.01) !tke at full sigma levels @@ -2255,7 +2128,9 @@ SUBROUTINE mym_length ( & END DO elt = MIN( MAX(alp1*elt/vsc, 10.), 400.) - vflx = ( vt(kts)+1.0 )*flt +( vq(kts)+tv0 )*flq + !avoid use of buoyancy flux functions which are ill-defined at the surface + !vflx = ( vt(kts)+1.0 )*flt +( vq(kts)+tv0 )*flq + vflx = fltv vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**onethird ! ** Strictly, el(i,j,1) is not zero. ** @@ -2318,33 +2193,24 @@ SUBROUTINE mym_length ( & elb_mf = elb END IF elf = elf/(1. + (elf/800.)) !bound free-atmos mixing length to < 800 m. -! elb_mf = elb_mf/(1. + (elb_mf/800.)) !bound buoyancy mixing length to < 800 m. elb_mf = MAX(elb_mf, 0.01) !to avoid divide-by-zero below - z_m = MAX(0.,zwk - 4.) - ! ** Length scale in the surface layer ** IF ( rmo .GT. 0.0 ) THEN els = karman*zwk/(1.0+cns*MIN( zwk*rmo, zmax )) - els1 = karman*z_m/(1.0+cns*MIN( zwk*rmo, zmax )) ELSE els = karman*zwk*( 1.0 - alp4* zwk*rmo )**0.2 - els1 = karman*z_m*( 1.0 - alp4* zwk*rmo )**0.2 END IF ! ** NOW BLEND THE MIXING LENGTH SCALES: wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 - ! "el_unstab" = blended els-elt - !el_unstab = els/(1. + (els1/elt)) !try squared-blending - !el(k) = SQRT( els**2/(1. + (els1**2/elt**2) )) - el(k) = SQRT( els**2/(1. + (els1**2/elt**2) +(els1**2/elb_mf**2))) - !el(k) = MIN(el_unstab, elb_mf) + el(k) = SQRT( els**2/(1. + (els**2/elt**2) +(els**2/elb_mf**2))) el(k) = el(k)*(1.-wt) + elf*wt - ! include scale-awareness. For now, use simple asymptotic kz -> 12 m. - el_les= MIN(els/(1. + (els1/12.)), elb_mf) + ! include scale-awareness. For now, use simple asymptotic kz -> 12 m (should be ~dz). + el_les= MIN(els/(1. + (els/12.)), elb_mf) el(k) = el(k)*Psig_bl + (1.-Psig_bl)*el_les END DO @@ -2391,14 +2257,14 @@ SUBROUTINE boulac_length0(k,kts,kte,zw,dz,qtke,theta,lb1,lb2) !------------------------------------------------------------------- INTEGER, INTENT(IN) :: k,kts,kte - REAL, DIMENSION(kts:kte), INTENT(IN) :: qtke,dz,theta - REAL, INTENT(OUT) :: lb1,lb2 - REAL, DIMENSION(kts:kte+1), INTENT(IN) :: zw + real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: qtke,dz,theta + real(kind_phys), INTENT(OUT) :: lb1,lb2 + real(kind_phys), DIMENSION(kts:kte+1), INTENT(IN) :: zw !LOCAL VARS INTEGER :: izz, found - REAL :: dlu,dld - REAL :: dzt, zup, beta, zup_inf, bbb, tl, zdo, zdo_sup, zzz + real(kind_phys):: dlu,dld + real(kind_phys):: dzt, zup, beta, zup_inf, bbb, tl, zdo, zdo_sup, zzz !---------------------------------- @@ -2541,15 +2407,15 @@ SUBROUTINE boulac_length(kts,kte,zw,dz,qtke,theta,lb1,lb2) !------------------------------------------------------------------- INTEGER, INTENT(IN) :: kts,kte - REAL, DIMENSION(kts:kte), INTENT(IN) :: qtke,dz,theta - REAL, DIMENSION(kts:kte), INTENT(OUT) :: lb1,lb2 - REAL, DIMENSION(kts:kte+1), INTENT(IN) :: zw + real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: qtke,dz,theta + real(kind_phys), DIMENSION(kts:kte), INTENT(OUT):: lb1,lb2 + real(kind_phys), DIMENSION(kts:kte+1), INTENT(IN) :: zw !LOCAL VARS INTEGER :: iz, izz, found - REAL, DIMENSION(kts:kte) :: dlu,dld - REAL, PARAMETER :: Lmax=2000. !soft limit - REAL :: dzt, zup, beta, zup_inf, bbb, tl, zdo, zdo_sup, zzz + real(kind_phys), DIMENSION(kts:kte) :: dlu,dld + real(kind_phys), PARAMETER :: Lmax=2000. !soft limit + real(kind_phys):: dzt, zup, beta, zup_inf, bbb, tl, zdo, zdo_sup, zzz !print*,"IN MYNN-BouLac",kts, kte @@ -2730,30 +2596,30 @@ END SUBROUTINE boulac_length !! - Production terms of TKE,\f$\theta^{'2}\f$,\f$q^{'2}\f$, and \f$\theta^{'}q^{'}\f$ !! are calculated. !! - Eddy diffusivity \f$K_h\f$ and eddy viscosity \f$K_m\f$ are calculated. -!! - TKE budget terms are calculated (if the namelist parameter \p bl_mynn_tkebudget +!! - TKE budget terms are calculated (if the namelist parameter \p tke_budget !! is set to True) SUBROUTINE mym_turbulence ( & & kts,kte, & - & closure, & + & xland,closure, & & dz, dx, zw, & & u, v, thl, thetav, ql, qw, & - & thlsg, qwsg, & & qke, tsq, qsq, cov, & & vt, vq, & - & rmo, flt, flq, & + & rmo, flt, fltv, flq, & & zi,theta, & & sh, sm, & & El, & & Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc, & & qWT1D,qSHEAR1D,qBUOY1D,qDISS1D, & - & bl_mynn_tkebudget, & - & Psig_bl,Psig_shcu,cldfra_bl1D,bl_mynn_mixlength,& - & edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf, & + & tke_budget, & + & Psig_bl,Psig_shcu,cldfra_bl1D, & + & bl_mynn_mixlength, & + & edmf_w1,edmf_a1, & & TKEprodTD, & - & spp_pbl,rstoch_col) + & spp_pbl,rstoch_col ) !------------------------------------------------------------------- -! + INTEGER, INTENT(IN) :: kts,kte #ifdef HARDCODE_VERTICAL @@ -2761,40 +2627,38 @@ SUBROUTINE mym_turbulence ( & # define kte HARDCODE_VERTICAL #endif - INTEGER, INTENT(IN) :: bl_mynn_mixlength,bl_mynn_edmf - REAL(kind=kind_phys), INTENT(IN) :: closure - REAL, DIMENSION(kts:kte), INTENT(in) :: dz - REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw - REAL, INTENT(in) :: rmo,flt,flq,Psig_bl,Psig_shcu - REAL(kind=kind_phys), INTENT(IN) :: dx,zi - REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,thetav,qw,& - &ql,vt,vq,qke,tsq,qsq,cov,cldfra_bl1D,edmf_w1,edmf_a1,edmf_qc1,& - &TKEprodTD,thlsg,qwsg - - REAL, DIMENSION(kts:kte), INTENT(out) :: dfm,dfh,dfq,& + INTEGER, INTENT(IN) :: bl_mynn_mixlength,tke_budget + real(kind_phys), INTENT(IN) :: closure + real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: dz + real(kind_phys), DIMENSION(kts:kte+1), INTENT(in) :: zw + real(kind_phys), INTENT(in) :: rmo,flt,fltv,flq, & + &Psig_bl,Psig_shcu,xland,dx,zi + real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: u,v,thl,thetav,qw, & + &ql,vt,vq,qke,tsq,qsq,cov,cldfra_bl1D,edmf_w1,edmf_a1, & + &TKEprodTD + + real(kind_phys), DIMENSION(kts:kte), INTENT(out) :: dfm,dfh,dfq, & &pdk,pdt,pdq,pdc,tcd,qcd,el - REAL, DIMENSION(kts:kte), INTENT(inout) :: & + real(kind_phys), DIMENSION(kts:kte), INTENT(inout) :: & qWT1D,qSHEAR1D,qBUOY1D,qDISS1D - REAL :: q3sq_old,dlsq1,qWTP_old,qWTP_new - REAL :: dudz,dvdz,dTdz,& - upwp,vpwp,Tpwp - LOGICAL, INTENT(in) :: bl_mynn_tkebudget + real(kind_phys):: q3sq_old,dlsq1,qWTP_old,qWTP_new + real(kind_phys):: dudz,dvdz,dTdz,upwp,vpwp,Tpwp - REAL, DIMENSION(kts:kte) :: qkw,dtl,dqw,dtv,gm,gh,sm,sh + real(kind_phys), DIMENSION(kts:kte) :: qkw,dtl,dqw,dtv,gm,gh,sm,sh INTEGER :: k -! REAL :: cc2,cc3,e1c,e2c,e3c,e4c,e5c - REAL :: e6c,dzk,afk,abk,vtt,vqq,& +! real(kind_phys):: cc2,cc3,e1c,e2c,e3c,e4c,e5c + real(kind_phys):: e6c,dzk,afk,abk,vtt,vqq, & &cw25,clow,cupp,gamt,gamq,smd,gamv,elq,elh - REAL :: cldavg - REAL, DIMENSION(kts:kte), INTENT(in) :: theta + real(kind_phys):: cldavg + real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: theta - REAL :: a2fac, duz, ri !JOE-Canuto/Kitamura mod + real(kind_phys):: a2fac, duz, ri !JOE-Canuto/Kitamura mod - REAL:: auh,aum,adh,adm,aeh,aem,Req,Rsl,Rsl2,& - gmelq,sm20,sh20,sm25max,sh25max,sm25min,sh25min,& + real:: auh,aum,adh,adm,aeh,aem,Req,Rsl,Rsl2, & + gmelq,sm20,sh20,sm25max,sh25max,sm25min,sh25min, & sm_pbl,sh_pbl,zi2,wt,slht,wtpr DOUBLE PRECISION q2sq, t2sq, r2sq, c2sq, elsq, gmel, ghel @@ -2802,11 +2666,10 @@ SUBROUTINE mym_turbulence ( & DOUBLE PRECISION e1, e2, e3, e4, enum, eden, wden ! Stochastic - INTEGER, INTENT(IN) :: spp_pbl - REAL, DIMENSION(KTS:KTE) :: rstoch_col - REAL :: Prnum, Prlim - REAL, PARAMETER :: Prlimit = 5.0 - + INTEGER, INTENT(IN) :: spp_pbl + real(kind_phys), DIMENSION(KTS:KTE) :: rstoch_col + real(kind_phys):: Prnum, shb + real(kind_phys), PARAMETER :: Prlimit = 5.0 ! ! tv0 = 0.61*tref @@ -2824,21 +2687,21 @@ SUBROUTINE mym_turbulence ( & CALL mym_level2 (kts,kte, & & dz, & & u, v, thl, thetav, qw, & - & thlsg, qwsg, & & ql, vt, vq, & & dtl, dqw, dtv, gm, gh, sm, sh ) ! CALL mym_length ( & - & kts,kte, & + & kts,kte,xland, & & dz, dx, zw, & - & rmo, flt, flq, & + & rmo, flt, fltv, flq, & & vt, vq, & & u, v, qke, & & dtv, & & el, & & zi,theta, & - & qkw,Psig_bl,cldfra_bl1D,bl_mynn_mixlength, & - & edmf_w1,edmf_a1,edmf_qc1,bl_mynn_edmf ) + & qkw,Psig_bl,cldfra_bl1D, & + & bl_mynn_mixlength, & + & edmf_w1,edmf_a1 ) ! DO k = kts+1,kte @@ -3002,10 +2865,16 @@ SUBROUTINE mym_turbulence ( & !IF ( sm(k) > sm25max ) sm(k) = sm25max !IF ( sm(k) < sm25min ) sm(k) = sm25min !sm(k) = Prnum*sh(k) - slht = zi*0.1 - wtpr = min( max( (slht - zw(k))/slht, 0.0), 1.0) ! 1 at z=0, 0 above sfc layer - Prlim = 1.0*wtpr + (1.0 - wtpr)*Prlimit - sm(k) = MIN(sm(k), Prlimit*Sh(k)) + + !surface layer PR + !slht = zi*0.1 + !wtpr = min( max( (slht - zw(k))/slht, 0.0), 1.0) ! 1 at z=0, 0 above sfc layer + !Prlim = 1.0*wtpr + (1.0 - wtpr)*Prlimit + !Prlim = 2.0*wtpr + (1.0 - wtpr)*Prlimit + !sm(k) = MIN(sm(k), Prlim*Sh(k)) + !Pending more testing, keep same Pr limit in sfc layer + shb = max(sh(k), 0.002) + sm(k) = MIN(sm(k), Prlimit*shb) ! ** Level 3 : start ** IF ( closure .GE. 3.0 ) THEN @@ -3160,11 +3029,6 @@ SUBROUTINE mym_turbulence ( & ! with active plumes and clouds. cldavg = 0.5*(cldfra_bl1D(k-1) + cldfra_bl1D(k)) IF (edmf_a1(k) > 0.001 .OR. cldavg > 0.02) THEN - !sm(k) = MAX(sm(k), MAX(1.0 - 2.0*cldavg, 0.0)**0.33 * 0.03 * & - ! & MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) - !sh(k) = MAX(sh(k), MAX(1.0 - 2.0*cldavg, 0.0)**0.33 * 0.03 * & - ! & MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) - ! for mass-flux columns sm(k) = MAX(sm(k), 0.03*MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) sh(k) = MAX(sh(k), 0.03*MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) @@ -3178,14 +3042,14 @@ SUBROUTINE mym_turbulence ( & ! Production of TKE (pdk), T-variance (pdt), ! q-variance (pdq), and covariance (pdc) - pdk(k) = elq*( sm(k)*gm(k) & - & +sh(k)*gh(k)+gamv ) + & + pdk(k) = elq*( sm(k)*gm(k) & + & +sh(k)*gh(k)+gamv ) + & & TKEprodTD(k) pdt(k) = elh*( sh(k)*dtl(k)+gamt )*dtl(k) pdq(k) = elh*( sh(k)*dqw(k)+gamq )*dqw(k) - pdc(k) = elh*( sh(k)*dtl(k)+gamt )& - &*dqw(k)*0.5 & - &+elh*( sh(k)*dqw(k)+gamq )*dtl(k)*0.5 + pdc(k) = elh*( sh(k)*dtl(k)+gamt ) & + & *dqw(k)*0.5 & + & + elh*( sh(k)*dqw(k)+gamq )*dtl(k)*0.5 ! Contergradient terms tcd(k) = elq*gamt @@ -3200,7 +3064,7 @@ SUBROUTINE mym_turbulence ( & dfq(k) = dfm(k) ! Modified: Dec/22/2005, up to here - IF ( bl_mynn_tkebudget ) THEN + IF (tke_budget .eq. 1) THEN !TKE BUDGET ! dudz = ( u(k)-u(k-1) )/dzk ! dvdz = ( v(k)-v(k-1) )/dzk @@ -3229,7 +3093,7 @@ SUBROUTINE mym_turbulence ( & !!!Dissipation Term (now it evaluated on mym_predict) !qDISS1D(k) = (q3sq**(3./2.))/(b1*MAX(el(k),1.)) !! ORIGINAL CODE - !! >> EOB + !! >> EOB ENDIF END DO @@ -3323,7 +3187,7 @@ SUBROUTINE mym_predict (kts,kte, & & pdk, pdt, pdq, pdc, & & qke, tsq, qsq, cov, & & s_aw,s_awqke,bl_mynn_edmf_tke, & - & qWT1D, qDISS1D,bl_mynn_tkebudget) !! TKE budget (Puhales, 2020) + & qWT1D, qDISS1D,tke_budget) !! TKE budget (Puhales, 2020) !------------------------------------------------------------------- INTEGER, INTENT(IN) :: kts,kte @@ -3333,30 +3197,29 @@ SUBROUTINE mym_predict (kts,kte, & # define kte HARDCODE_VERTICAL #endif - REAL(kind=kind_phys), INTENT(IN) :: closure - INTEGER, INTENT(IN) :: bl_mynn_edmf_tke - REAL, DIMENSION(kts:kte), INTENT(IN) :: dz, dfq, el, rho - REAL, DIMENSION(kts:kte), INTENT(INOUT) :: pdk, pdt, pdq, pdc - REAL, INTENT(IN) :: flt, flq, pmz, phh - REAL(kind=kind_phys), INTENT(IN) :: ust, delt - REAL, DIMENSION(kts:kte), INTENT(INOUT) :: qke,tsq, qsq, cov + real(kind_phys), INTENT(IN) :: closure + INTEGER, INTENT(IN) :: bl_mynn_edmf_tke,tke_budget + real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: dz, dfq, el, rho + real(kind_phys), DIMENSION(kts:kte), INTENT(INOUT) :: pdk, pdt, pdq, pdc + real(kind_phys), INTENT(IN) :: flt, flq, pmz, phh + real(kind_phys), INTENT(IN) :: ust, delt + real(kind_phys), DIMENSION(kts:kte), INTENT(INOUT) :: qke,tsq, qsq, cov ! WA 8/3/15 - REAL, DIMENSION(kts:kte+1), INTENT(INOUT) :: s_awqke,s_aw + real(kind_phys), DIMENSION(kts:kte+1), INTENT(INOUT) :: s_awqke,s_aw !! TKE budget (Puhales, 2020, WRF 4.2.1) << EOB - REAL, DIMENSION(kts:kte), INTENT(OUT) :: qWT1D, qDISS1D - LOGICAL, INTENT(IN) :: bl_mynn_tkebudget - REAL, DIMENSION(kts:kte) :: tke_up,dzinv + real(kind_phys), DIMENSION(kts:kte), INTENT(OUT) :: qWT1D, qDISS1D + real(kind_phys), DIMENSION(kts:kte) :: tke_up,dzinv !! >> EOB INTEGER :: k - REAL, DIMENSION(kts:kte) :: qkw, bp, rp, df3q - REAL :: vkz,pdk1,phm,pdt1,pdq1,pdc1,b1l,b2l,onoff - REAL, DIMENSION(kts:kte) :: dtz - REAL, DIMENSION(kts:kte) :: a,b,c,d,x + real(kind_phys), DIMENSION(kts:kte) :: qkw, bp, rp, df3q + real(kind_phys):: vkz,pdk1,phm,pdt1,pdq1,pdc1,b1l,b2l,onoff + real(kind_phys), DIMENSION(kts:kte) :: dtz + real(kind_phys), DIMENSION(kts:kte) :: a,b,c,d,x - REAL, DIMENSION(kts:kte) :: rhoinv - REAL, DIMENSION(kts:kte+1) :: rhoz,kqdz,kmdz + real(kind_phys), DIMENSION(kts:kte) :: rhoinv + real(kind_phys), DIMENSION(kts:kte+1) :: rhoz,kqdz,kmdz ! REGULATE THE MOMENTUM MIXING FROM THE MASS-FLUX SCHEME (on or off) IF (bl_mynn_edmf_tke == 0) THEN @@ -3486,7 +3349,7 @@ SUBROUTINE mym_predict (kts,kte, & !! TKE budget (Puhales, 2020, WRF 4.2.1) << EOB - IF (bl_mynn_tkebudget) THEN + IF (tke_budget .eq. 1) THEN !! TKE Vertical transport << EOBvt tke_up=0.5*qke dzinv=1./dz @@ -3722,8 +3585,8 @@ END SUBROUTINE mym_predict !! calculate the buoyancy flux. Different cloud PDFs can be selected by !! use of the namelist parameter \p bl_mynn_cloudpdf . SUBROUTINE mym_condensation (kts,kte, & - & dx, dz, zw, u1, v1, xland,& - & thl, qw, qv, qc, qi, & + & dx, dz, zw, xland, & + & thl, qw, qv, qc, qi, qs, & & p,exner, & & tsq, qsq, cov, & & Sh, el, bl_mynn_cloudpdf, & @@ -3742,45 +3605,45 @@ SUBROUTINE mym_condensation (kts,kte, & # define kte HARDCODE_VERTICAL #endif - REAL, INTENT(IN) :: HFX1,rmo,xland - REAL(kind=kind_phys), INTENT(IN) :: dx,pblh1 - REAL, DIMENSION(kts:kte), INTENT(IN) :: dz - REAL, DIMENSION(kts:kte+1), INTENT(IN) :: zw - REAL, DIMENSION(kts:kte), INTENT(IN) :: p,exner,thl,qw,qv,qc,qi, & - &tsq, qsq, cov, th, u1, v1 + real(kind_phys), INTENT(IN) :: HFX1,rmo,xland + real(kind_phys), INTENT(IN) :: dx,pblh1 + real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: dz + real(kind_phys), DIMENSION(kts:kte+1), INTENT(IN) :: zw + real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: p,exner,thl,qw, & + &qv,qc,qi,qs,tsq,qsq,cov,th - REAL, DIMENSION(kts:kte), INTENT(INOUT) :: vt,vq,sgm + real(kind_phys), DIMENSION(kts:kte), INTENT(INOUT) :: vt,vq,sgm - REAL, DIMENSION(kts:kte) :: alp,a,bet,b,ql,q1,RH - REAL, DIMENSION(kts:kte), INTENT(OUT) :: qc_bl1D,qi_bl1D, & - cldfra_bl1D + real(kind_phys), DIMENSION(kts:kte) :: alp,a,bet,b,ql,q1,RH + real(kind_phys), DIMENSION(kts:kte), INTENT(OUT) :: qc_bl1D,qi_bl1D, & + &cldfra_bl1D DOUBLE PRECISION :: t3sq, r3sq, c3sq - REAL :: qsl,esat,qsat,dqsl,cld0,q1k,qlk,eq1,qll,& - &q2p,pt,rac,qt,t,xl,rsl,cpm,Fng,qww,alpha,beta,bb,& - &ls,wt,cld_factor,fac_damp,liq_frac,ql_ice,ql_water,& - &qmq,qsat_tk,wsp,wspfac + real(kind_phys):: qsl,esat,qsat,dqsl,cld0,q1k,qlk,eq1,qll, & + &q2p,pt,rac,qt,t,xl,rsl,cpm,Fng,qww,alpha,beta,bb, & + &ls,wt,cld_factor,fac_damp,liq_frac,ql_ice,ql_water, & + &qmq,qsat_tk,q1_rh,rh_hack + real(kind_phys), PARAMETER :: rhcrit=0.83 !for hom pdf min sigma INTEGER :: i,j,k - REAL :: erf + real(kind_phys):: erf !VARIABLES FOR ALTERNATIVE SIGMA - REAL::dth,dtl,dqw,dzk,els - REAL, DIMENSION(kts:kte), INTENT(IN) :: Sh,el + real:: dth,dtl,dqw,dzk,els + real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: Sh,el !variables for SGS BL clouds - REAL :: zagl,damp,PBLH2 - REAL :: cfmax - INTEGER, PARAMETER :: buoy_opt=1 ! 0: traditional SD77, 1: CB02,CB05 + real(kind_phys) :: zagl,damp,PBLH2 + real(kind_phys) :: cfmax !JAYMES: variables for tropopause-height estimation - REAL :: theta1, theta2, ht1, ht2 - INTEGER :: k_tropo + real(kind_phys) :: theta1, theta2, ht1, ht2 + INTEGER :: k_tropo ! Stochastic - INTEGER, INTENT(IN) :: spp_pbl - REAL, DIMENSION(KTS:KTE) :: rstoch_col - REAL :: qw_pert + INTEGER, INTENT(IN) :: spp_pbl + real(kind_phys), DIMENSION(KTS:KTE) :: rstoch_col + real(kind_phys) :: qw_pert ! First, obtain an estimate for the tropopause height (k), using the method employed in the ! Thompson subgrid-cloud scheme. This height will be a consideration later when determining @@ -3856,9 +3719,6 @@ SUBROUTINE mym_condensation (kts,kte, & qc_bl1D(k) = liq_frac*ql(k) qi_bl1D(k) = (1.0 - liq_frac)*ql(k) - if(cldfra_bl1D(k)>0.01 .and. qc_bl1D(k)<1.E-6)qc_bl1D(k)=1.E-6 - if(cldfra_bl1D(k)>0.01 .and. qi_bl1D(k)<1.E-8)qi_bl1D(k)=1.E-8 - !Now estimate the buoyancy flux functions q2p = xlvcp/exner(k) pt = thl(k) +q2p*ql(k) ! potential temp @@ -3916,9 +3776,6 @@ SUBROUTINE mym_condensation (kts,kte, & qc_bl1D(k) = liq_frac*ql(k) qi_bl1D(k) = (1.0 - liq_frac)*ql(k) - if(cldfra_bl1D(k)>0.01 .and. qc_bl1D(k)<1.E-6)qc_bl1D(k)=1.E-6 - if(cldfra_bl1D(k)>0.01 .and. qi_bl1D(k)<1.E-8)qi_bl1D(k)=1.E-8 - !Now estimate the buoyancy flux functions q2p = xlvcp/exner(k) pt = thl(k) +q2p*ql(k) ! potential temp @@ -3947,7 +3804,7 @@ SUBROUTINE mym_condensation (kts,kte, & xl = xl_blend(t) ! obtain latent heat qsat_tk = qsat_blend(t, p(k)) ! saturation water vapor mixing ratio at tk and p - rh(k)=MAX(MIN(1.0,qw(k)/MAX(1.E-8,qsat_tk)),0.001) + rh(k)=MAX(MIN(1.00,qw(k)/MAX(1.E-10,qsat_tk)),0.001) !dqw/dT: Clausius-Clapeyron dqsl = qsat_tk*ep_2*xlv/( r_d*t**2 ) @@ -3968,35 +3825,53 @@ SUBROUTINE mym_condensation (kts,kte, & !Use the form of Eq. (6) in Chaboureau and Bechtold (2002) !except neglect all but the first term for sig_r - r3sq = MAX( qsq(k), 0.0 ) + r3sq = max( qsq(k), 0.0 ) !Calculate sigma using higher-order moments: sgm(k) = SQRT( r3sq ) !Set limits on sigma relative to saturation water vapor - sgm(k) = MIN( sgm(k), qsat_tk*0.666 ) !500 ) - sgm(k) = MAX( sgm(k), qsat_tk*0.035 ) !Note: 0.02 results in SWDOWN similar - !to the first-order version of sigma - q1(k) = qmq / sgm(k) ! Q1, the normalized saturation + sgm(k) = min( sgm(k), qsat_tk*0.666 ) + sgm(k) = max( sgm(k), qsat_tk*0.035 ) + q1(k) = qmq / sgm(k) ! Q1, the normalized saturation + + !Add condition for falling/settling into low-RH layers, so at least + !some cloud fraction is applied for all qc and qi. + rh_hack = rh(k) + !ensure adequate RH & q1 when qi is at least 1e-9 + if (qi(k)>1.e-9) then + rh_hack =min(1.0, rhcrit + 0.06*(9.0 + log10(qi(k)))) + rh(k) =max(rh(k), rh_hack) + !add rh-based q1 + q1_rh =-3. + 3.*(rh_hack-rhcrit)/(1.-rhcrit) + q1(k) =max(q1_rh, q1(k) ) + endif + !ensure adequate RH & q1 when qc is at least 1e-6 + if (qc(k)>1.e-6) then + rh_hack =min(1.0, rhcrit + 0.09*(6.0 + log10(qc(k)))) + rh(k) =max(rh(k), rh_hack) + !add rh-based q1 + q1_rh =-3. + 3.*(rh_hack-rhcrit)/(1.-rhcrit) + q1(k) =max(q1_rh, q1(k) ) + endif + q1k = q1(k) ! backup Q1 for later modification ! Specify cloud fraction !Original C-B cloud fraction, allows cloud fractions out to q1 = -3.5 !cldfra_bl1D(K) = max(0., min(1., 0.5+0.36*atan(1.55*q1(k)))) ! Eq. 7 in CB02 - !wayne's - over-diffuse, when limits removed from vt & vq & fng + !Waynes LES fit - over-diffuse, when limits removed from vt & vq & fng !cldfra_bl1D(K) = max(0., min(1., 0.5+0.36*atan(1.2*(q1(k)+0.4)))) - !effort to reduce rh-dependency - !cldfra_bl1D(K) = max(0., min(1., 0.5+0.36*atan(2.9*(q1(k)+0.4)))) - cldfra_bl1D(K) = max(0., min(1., 0.5+0.36*atan(1.8*(q1(k)+0.4)))) - !moderate - best compromise?? - !cldfra_bl1D(K) = max(0., min(1., 0.5+0.36*atan(1.55*(q1(k)+0.2)))) - !closer to original for Q1 < -1, best for holding onto stratus, not good flowers - !cldfra_bl1D(K) = max(0., min(1., 0.5+0.36*atan(1.9*(q1(k)+0.4)))) - + !Best compromise: Improves marine stratus without adding much cold bias. + cldfra_bl1D(k) = max(0., min(1., 0.5+0.36*atan(1.8*(q1(k)+0.2)))) ! Specify hydrometeors ! JAYMES- this option added 8 May 2015 ! The cloud water formulations are taken from CB02, Eq. 8. IF (q1k < 0.) THEN !unsaturated - ql_water = sgm(k)*EXP(1.2*q1k-1) +#ifdef SINGLE_PREC + ql_water = sgm(k)*EXP(1.2*q1k-1.) +#else + ql_water = sgm(k)*EXP(1.2*q1k-1.) +#endif ql_ice = sgm(k)*EXP(1.2*q1k-1.) ELSE IF (q1k > 2.) THEN !supersaturated ql_water = sgm(k)*q1k @@ -4007,41 +3882,23 @@ SUBROUTINE mym_condensation (kts,kte, & ENDIF !In saturated grid cells, use average of SGS and resolved values - if ( qc(k) > 1.e-7 ) ql_water = 0.5 * ( ql_water + qc(k) ) - if ( qi(k) > 1.e-9 ) ql_ice = 0.5 * ( ql_ice + qi(k) ) + !if ( qc(k) > 1.e-6 ) ql_water = 0.5 * ( ql_water + qc(k) ) + !ql_ice is actually the total frozen condensate (snow+ice), + !if ( (qi(k)+qs(k)) > 1.e-9 ) ql_ice = 0.5 * ( ql_ice + (qi(k)+qs(k)) ) - if (cldfra_bl1D(k) < 0.01) then + if (cldfra_bl1D(k) < 0.001) then ql_ice = 0.0 ql_water = 0.0 cldfra_bl1D(k) = 0.0 endif - !PHASE PARTITIONING: Make some inferences about the relative amounts of - !subgrid cloud water vs. ice based on collocated explicit clouds. Otherise, - !use a simple temperature-dependent partitioning. - ! IF ( qc(k) + qi(k) > 0.0 ) THEN ! explicit condensate exists, retain its phase partitioning - ! IF ( qi(k) == 0.0 ) THEN ! explicit contains no ice; assume subgrid liquid - ! liq_frac = 1.0 - ! ELSE IF ( qc(k) == 0.0 ) THEN ! explicit contains no liquid; assume subgrid ice - ! liq_frac = 0.0 - ! ELSE IF ( (qc(k) >= 1.E-10) .AND. (qi(k) >= 1.E-10) ) THEN ! explicit contains mixed phase of workably - ! ! large amounts; assume subgrid follows - ! ! same partioning - ! liq_frac = qc(k) / ( qc(k) + qi(k) ) - ! ELSE - ! liq_frac = MIN(1.0, MAX(0.0, (t-tice)/(t0c-tice))) ! explicit contains mixed phase, but at least one - ! ! species is very small, so make a temperature- - ! ! depedent guess - ! ENDIF - ! ELSE ! no explicit condensate, so make a temperature-dependent guess - liq_frac = MIN(1.0, MAX(0.0, (t-tice)/(tliq-tice))) - ! ENDIF - + liq_frac = MIN(1.0, MAX(0.0, (t-tice)/(tliq-tice))) qc_bl1D(k) = liq_frac*ql_water ! apply liq_frac to ql_water and ql_ice qi_bl1D(k) = (1.0-liq_frac)*ql_ice - !Above tropopause: eliminate subgrid clouds from CB scheme - if (k .ge. k_tropo-1) then + !Above tropopause: eliminate subgrid clouds from CB scheme. Note that this was + !"k_tropo - 1" as of 20 Feb 2023. Changed to allow more high-level clouds. + if (k .ge. k_tropo) then cldfra_bl1D(K) = 0. qc_bl1D(k) = 0. qi_bl1D(k) = 0. @@ -4049,6 +3906,7 @@ SUBROUTINE mym_condensation (kts,kte, & !Buoyancy-flux-related calculations follow... !limiting Q1 to avoid too much diffusion in cloud layers + !q1k=max(Q1(k),-2.0) if ((xland-1.5).GE.0) then ! water q1k=max(Q1(k),-2.5) else ! land @@ -4076,64 +3934,30 @@ SUBROUTINE mym_condensation (kts,kte, & Fng = MIN(23.9 + EXP(-1.6*(q1k+2.5)), 60.) ENDIF - if (buoy_opt .eq. 1) then - cfmax= min(cldfra_bl1D(K), 0.6) - bb = b(k)*t/th(k) ! bb is "b" in BCMT95. Their "b" differs from - ! "b" in CB02 (i.e., b(k) above) by a factor - ! of T/theta. Strictly, b(k) above is formulated in - ! terms of sat. mixing ratio, but bb in BCMT95 is - ! cast in terms of sat. specific humidity. The - ! conversion is neglected here. - qww = 1.+0.61*qw(k) - alpha = 0.61*th(k) - beta = (th(k)/t)*(xl/cp) - 1.61*th(k) - vt(k) = qww - cfmax*beta*bb*Fng - 1. - vq(k) = alpha + cfmax*beta*a(k)*Fng - tv0 - ! vt and vq correspond to beta-theta and beta-q, respectively, - ! in NN09, Eq. B8. They also correspond to the bracketed - ! expressions in BCMT95, Eq. 15, since (s*ql/sigma^2) = cldfra*Fng - ! The "-1" and "-tv0" terms are included for consistency with - ! the legacy vt and vq formulations (above). - else - - !original buoyancy flux functions from SD77 - eq1 = rrp*exp( -0.5*q1k*q1k ) - qll = max( cldfra_bl1D(k)*q1k + eq1, 0.0 ) - q2p = xl/cp/exner(k) - - !qt is a THETA-V CONVERSION FOR TOTAL WATER - cfmax= min(cldfra_bl1D(K), 0.6) - qt = 1.0 +p608*qw(k) -(1.+p608)*(qc_bl1D(k)+qi_bl1D(k))*cfmax - rac = alp(k)*( cfmax-qll*eq1 )*( q2p*qt-(1.+p608)*th(k) ) - - !BUOYANCY FACTORS: wherever vt and vq are used, there is a - !"+1" and "+tv0", respectively, so these are subtracted out here. - !vt is unitless and vq has units of K. - vt(k) = qt-1.0 -rac*bet(k) - vq(k) = p608*th(k)-tv0 +rac - endif - - ! dampen the amplification factor (cld_factor) with height in order - ! to limit excessively large cloud fractions aloft - !fac_damp = 1.! -MIN(MAX( zagl-(PBLH2+1000.),0.0)/ & - ! MAX((zw(k_tropo)-(PBLH2+1000.)),500.), 1.) - !fac_damp = min(zagl * 0.01, 1.0) - wsp =sqrt(u1(k)**2 + v1(k)**2) - wspfac = 1.0 - min(max(0.,wsp-15),10.)/10. ! reduce as winds go from 15 to 25 m/s. - fac_damp = min(zagl * 0.0025, 1.0)*wspfac - !cld_factor = 1.0 + fac_damp*MAX(0.0, ( RH(k) - 0.5 ) / 0.51 )**3.3 + cfmax= min(cldfra_bl1D(k), 0.6) + bb = b(k)*t/th(k) ! bb is "b" in BCMT95. Their "b" differs from + ! "b" in CB02 (i.e., b(k) above) by a factor + ! of T/theta. Strictly, b(k) above is formulated in + ! terms of sat. mixing ratio, but bb in BCMT95 is + ! cast in terms of sat. specific humidity. The + ! conversion is neglected here. + qww = 1.+0.61*qw(k) + alpha = 0.61*th(k) + beta = (th(k)/t)*(xl/cp) - 1.61*th(k) + vt(k) = qww - cfmax*beta*bb*Fng - 1. + vq(k) = alpha + cfmax*beta*a(k)*Fng - tv0 + ! vt and vq correspond to beta-theta and beta-q, respectively, + ! in NN09, Eq. B8. They also correspond to the bracketed + ! expressions in BCMT95, Eq. 15, since (s*ql/sigma^2) = cldfra*Fng + ! The "-1" and "-tv0" terms are included for consistency with + ! the legacy vt and vq formulations (above). + + ! dampen amplification factor where need be + fac_damp = min(zagl * 0.0025, 1.0) !cld_factor = 1.0 + fac_damp*MAX(0.0, ( RH(k) - 0.75 ) / 0.26 )**1.9 !HRRRv4 - !cld_factor = 1.0 + fac_damp*(MAX(0.0, ( RH(k) - 0.80 )) / 0.22 )**2 - !cld_factor = 1.0 + fac_damp*(MAX(0.0, ( RH(k) - 0.90 )) / 0.11 )**2 - !cld_factor = 1.0 + fac_damp*1.8*(max(0.0, q1k + 0.2 ))**2 !too low of albedo - !cld_factor = 1.0 + fac_damp*1.8*(max(0.0, q1k + 0.2 ))**2 - !make this enhancement over water only? - !if ((xland-1.5).GE.0) then ! water - cld_factor = 1.0 + fac_damp*min((max(0.0, ( RH(k) - 0.92 )) / 0.25 )**2, 0.3) - !else - ! cld_factor = 1.0 - !endif - cldfra_bl1D(K) = MIN( 1., cld_factor*cldfra_bl1D(K) ) + !cld_factor = 1.0 + fac_damp*min((max(0.0, ( RH(k) - 0.92 )) / 0.25 )**2, 0.3) + cld_factor = 1.0 + fac_damp*min((max(0.0, ( RH(k) - 0.92 )) / 0.145)**2, 0.35) + cldfra_bl1D(K) = min( 1., cld_factor*cldfra_bl1D(K) ) enddo END SELECT !end cloudPDF option @@ -4166,38 +3990,39 @@ END SUBROUTINE mym_condensation !>\ingroup gsd_mynn_edmf !! This subroutine solves for tendencies of U, V, \f$\theta\f$, qv, !! qc, and qi - SUBROUTINE mynn_tendencies(kts,kte,i, & - &delt,dz,rho, & - &u,v,th,tk,qv,qc,qi,qnc,qni, & - &psfc,p,exner, & - &thl,sqv,sqc,sqi,sqw, & - &qnwfa,qnifa,ozone, & - &ust,flt,flq,flqv,flqc,wspd, & - &uoce,voce, & - &tsq,qsq,cov, & - &tcd,qcd, & - &dfm,dfh,dfq, & - &Du,Dv,Dth,Dqv,Dqc,Dqi,Dqnc,Dqni, & - &Dqnwfa,Dqnifa,Dozone, & - &diss_heat, & - &s_aw,s_awthl,s_awqt,s_awqv,s_awqc, & - &s_awu,s_awv, & - &s_awqnc,s_awqni, & - &s_awqnwfa,s_awqnifa, & - &sd_aw,sd_awthl,sd_awqt,sd_awqv, & - &sd_awqc,sd_awu,sd_awv, & - &sub_thl,sub_sqv, & - &sub_u,sub_v, & - &det_thl,det_sqv,det_sqc, & - &det_u,det_v, & - &FLAG_QC,FLAG_QI,FLAG_QNC,FLAG_QNI, & - &FLAG_QNWFA,FLAG_QNIFA, & - &cldfra_bl1d, & - &bl_mynn_cloudmix, & - &bl_mynn_mixqt, & - &bl_mynn_edmf, & - &bl_mynn_edmf_mom, & - &bl_mynn_mixscalars ) + SUBROUTINE mynn_tendencies(kts,kte,i, & + &delt,dz,rho, & + &u,v,th,tk,qv,qc,qi,qs,qnc,qni, & + &psfc,p,exner, & + &thl,sqv,sqc,sqi,sqs,sqw, & + &qnwfa,qnifa,qnbca,ozone, & + &ust,flt,flq,flqv,flqc,wspd, & + &uoce,voce, & + &tsq,qsq,cov, & + &tcd,qcd, & + &dfm,dfh,dfq, & + &Du,Dv,Dth,Dqv,Dqc,Dqi,Dqs,Dqnc,Dqni, & + &Dqnwfa,Dqnifa,Dqnbca,Dozone, & + &diss_heat, & + &s_aw,s_awthl,s_awqt,s_awqv,s_awqc, & + &s_awu,s_awv, & + &s_awqnc,s_awqni, & + &s_awqnwfa,s_awqnifa,s_awqnbca, & + &sd_aw,sd_awthl,sd_awqt,sd_awqv, & + &sd_awqc,sd_awu,sd_awv, & + &sub_thl,sub_sqv, & + &sub_u,sub_v, & + &det_thl,det_sqv,det_sqc, & + &det_u,det_v, & + &FLAG_QC,FLAG_QI,FLAG_QNC,FLAG_QNI, & + &FLAG_QS, & + &FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA, & + &cldfra_bl1d, & + &bl_mynn_cloudmix, & + &bl_mynn_mixqt, & + &bl_mynn_edmf, & + &bl_mynn_edmf_mom, & + &bl_mynn_mixscalars ) !------------------------------------------------------------------- INTEGER, INTENT(in) :: kts,kte,i @@ -4207,11 +4032,11 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & # define kte HARDCODE_VERTICAL #endif - INTEGER, INTENT(in) :: bl_mynn_cloudmix,bl_mynn_mixqt,& - bl_mynn_edmf,bl_mynn_edmf_mom, & + INTEGER, INTENT(in) :: bl_mynn_cloudmix,bl_mynn_mixqt, & + bl_mynn_edmf,bl_mynn_edmf_mom, & bl_mynn_mixscalars - LOGICAL, INTENT(IN) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC,& - FLAG_QNWFA,FLAG_QNIFA + LOGICAL, INTENT(IN) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QS, & + &FLAG_QNC,FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA ! thl - liquid water potential temperature ! qw - total water @@ -4220,46 +4045,47 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & ! flq - surface flux of qw ! mass-flux plumes - REAL, DIMENSION(kts:kte+1), INTENT(in) :: s_aw,s_awthl,s_awqt,& - &s_awqnc,s_awqni,s_awqv,s_awqc,s_awu,s_awv, & - &s_awqnwfa,s_awqnifa, & + real(kind_phys), DIMENSION(kts:kte+1), INTENT(in) :: s_aw, & + &s_awthl,s_awqt,s_awqnc,s_awqni,s_awqv,s_awqc,s_awu,s_awv, & + &s_awqnwfa,s_awqnifa,s_awqnbca, & &sd_aw,sd_awthl,sd_awqt,sd_awqv,sd_awqc,sd_awu,sd_awv ! tendencies from mass-flux environmental subsidence and detrainment - REAL, DIMENSION(kts:kte), INTENT(in) :: sub_thl,sub_sqv, & + real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: sub_thl,sub_sqv, & &sub_u,sub_v,det_thl,det_sqv,det_sqc,det_u,det_v - REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,th,tk,qv,qc,qi,qni,qnc,& - &rho,p,exner,dfq,dz,tsq,qsq,cov,tcd,qcd,cldfra_bl1d,diss_heat - REAL, DIMENSION(kts:kte), INTENT(inout) :: thl,sqw,sqv,sqc,sqi,& - &qnwfa,qnifa,ozone,dfm,dfh - REAL, DIMENSION(kts:kte), INTENT(inout) :: du,dv,dth,dqv,dqc,dqi,& - &dqni,dqnc,dqnwfa,dqnifa,dozone - REAL, INTENT(IN) :: flt,flq,flqv,flqc,uoce,voce - REAL(kind=kind_phys), INTENT(IN) :: ust,delt,psfc,wspd + real(kind_phys), DIMENSION(kts:kte), INTENT(in) :: u,v,th,tk,qv,qc,qi,& + &qs,qni,qnc,rho,p,exner,dfq,dz,tsq,qsq,cov,tcd,qcd, & + &cldfra_bl1d,diss_heat + real(kind_phys), DIMENSION(kts:kte), INTENT(inout) :: thl,sqw,sqv,sqc,& + &sqi,sqs,qnwfa,qnifa,qnbca,ozone,dfm,dfh + real(kind_phys), DIMENSION(kts:kte), INTENT(inout) :: du,dv,dth,dqv, & + &dqc,dqi,dqs,dqni,dqnc,dqnwfa,dqnifa,dqnbca,dozone + real(kind_phys), INTENT(IN) :: flt,flq,flqv,flqc,uoce,voce + real(kind_phys), INTENT(IN) :: ust,delt,psfc,wspd !debugging - REAL ::wsp,wsp2,tk2,th2 + real(kind_phys):: wsp,wsp2,tk2,th2 LOGICAL :: problem integer :: kproblem -! REAL, INTENT(IN) :: gradu_top,gradv_top,gradth_top,gradqv_top +! real(kind_phys), INTENT(IN) :: gradu_top,gradv_top,gradth_top,gradqv_top !local vars - REAL, DIMENSION(kts:kte) :: dtz,dfhc,dfmc,delp - REAL, DIMENSION(kts:kte) :: sqv2,sqc2,sqi2,sqw2,qni2,qnc2, & !AFTER MIXING - qnwfa2,qnifa2,ozone2 - REAL, DIMENSION(kts:kte) :: zfac,plumeKh,rhoinv - REAL, DIMENSION(kts:kte) :: a,b,c,d,x - REAL, DIMENSION(kts:kte+1) :: rhoz, & !rho on model interface - & khdz, kmdz - REAL :: rhs,gfluxm,gfluxp,dztop,maxdfh,mindfh,maxcf,maxKh,zw - REAL :: t,esat,qsl,onoff,kh,km,dzk,rhosfc - REAL :: ustdrag,ustdiff,qvflux - REAL :: th_new,portion_qc,portion_qi,condensate,qsat + real(kind_phys), DIMENSION(kts:kte) :: dtz,dfhc,dfmc,delp + real(kind_phys), DIMENSION(kts:kte) :: sqv2,sqc2,sqi2,sqs2,sqw2, & + &qni2,qnc2,qnwfa2,qnifa2,qnbca2,ozone2 + real(kind_phys), DIMENSION(kts:kte) :: zfac,plumeKh,rhoinv + real(kind_phys), DIMENSION(kts:kte) :: a,b,c,d,x + real(kind_phys), DIMENSION(kts:kte+1) :: rhoz, & !rho on model interface + &khdz,kmdz + real(kind_phys):: rhs,gfluxm,gfluxp,dztop,maxdfh,mindfh,maxcf,maxKh,zw + real(kind_phys):: t,esat,qsl,onoff,kh,km,dzk,rhosfc + real(kind_phys):: ustdrag,ustdiff,qvflux + real(kind_phys):: th_new,portion_qc,portion_qi,condensate,qsat INTEGER :: k,kk !Activate nonlocal mixing from the mass-flux scheme for !number concentrations and aerosols (0.0 = no; 1.0 = yes) - REAL, PARAMETER :: nonloc = 1.0 + real(kind_phys), PARAMETER :: nonloc = 1.0 dztop=.5*(dz(kte)+dz(kte-1)) @@ -4716,19 +4542,6 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & IF (bl_mynn_cloudmix > 0 .AND. FLAG_QI) THEN k=kts - -! a(k)=0. -! b(k)=1.+dtz(k)*dfh(k+1) -! c(k)= -dtz(k)*dfh(k+1) -! d(k)=sqi(k) !+ qcd(k)*delt !should we have qcd for ice? -! -! DO k=kts+1,kte-1 -! a(k)= -dtz(k)*dfh(k) -! b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) -! c(k)= -dtz(k)*dfh(k+1) -! d(k)=sqi(k) !+ qcd(k)*delt -! ENDDO - !rho-weighted: a(k)= -dtz(k)*khdz(k)*rhoinv(k) b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) @@ -4772,6 +4585,42 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & sqi2=sqi ENDIF +!============================================ +! MIX SNOW ( sqs ) +!============================================ +IF (bl_mynn_cloudmix > 0 .AND. FLAG_QS) THEN + + k=kts +!rho-weighted: + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) + d(k)=sqs(k) + + DO k=kts+1,kte-1 + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) + d(k)=sqs(k) + ENDDO + +!! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=sqs(kte) + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,sqs2) +! CALL tridiag3(kte,a,b,c,d,sqs2) + +! DO k=kts,kte +! sqs2(k)=d(k-kts+1) +! ENDDO +ELSE + sqs2=sqs +ENDIF + !!============================================ !! cloud ice number concentration (qni) !!============================================ @@ -4937,6 +4786,48 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & qnifa2=qnifa ENDIF +!============================================ +! Black-carbon aerosols ( qnbca ). +!============================================ +IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNBCA .AND. & + bl_mynn_mixscalars > 0) THEN + + k=kts + + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) - & + & 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + d(k)=qnbca(k) - dtz(k)*rhoinv(k)*s_awqnbca(k+1)*nonloc + + DO k=kts+1,kte-1 + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*nonloc + b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) + & + & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*nonloc + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + d(k)=qnbca(k) + dtz(k)*rhoinv(k)*(s_awqnbca(k)-s_awqnbca(k+1))*nonloc + ENDDO + +! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=qnbca(kte) + +! CALL tridiag(kte,a,b,c,d) +! CALL tridiag2(kte,a,b,c,d,x) + CALL tridiag3(kte,a,b,c,d,x) + + DO k=kts,kte + !qnbca2(k)=d(k-kts+1) + qnbca2(k)=x(k) + ENDDO + +ELSE + !If not mixing aerosols, set "updated" array equal to original array + qnbca2=qnbca +ENDIF + !============================================ ! Ozone - local mixing only !============================================ @@ -5061,6 +4952,19 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & ENDDO ENDIF + !=================== + ! CLOUD SNOW TENDENCY + !=================== + IF (FLAG_QS) THEN + DO k=kts,kte + Dqs(k)=(sqs2(k)/(1.-sqs2(k)) - qs(k))/delt + ENDDO + ELSE + DO k=kts,kte + Dqs(k) = 0. + ENDDO + ENDIF + !=================== ! CLOUD ICE NUM CONC TENDENCY !=================== @@ -5085,9 +4989,9 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & ENDIF !ensure non-negative moist species - CALL moisture_check(kte, delt, delp, exner, & - sqv2, sqc2, sqi2, thl, & - dqv, dqc, dqi, dth ) + CALL moisture_check(kte, delt, delp, exner, & + sqv2, sqc2, sqi2, sqs2, thl, & + dqv, dqc, dqi, dqs, dth ) !===================== ! OZONE TENDENCY CHECK @@ -5103,8 +5007,8 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & !=================== IF (FLAG_QI) THEN DO k=kts,kte - Dth(k)=(thl(k) + xlvcp/exner(k)*sqc2(k) & - & + xlscp/exner(k)*sqi2(k) & + Dth(k)=(thl(k) + xlvcp/exner(k)*sqc2(k) & + & + xlscp/exner(k)*(sqi2(k)+sqs(k)) & & - th(k))/delt !Use form from Tripoli and Cotton (1981) with their !suggested min temperature to improve accuracy: @@ -5144,6 +5048,19 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & ENDDO ENDIF + !======================== + ! BLACK-CARBON TENDENCIES + !======================== + IF (FLAG_QNBCA .AND. bl_mynn_mixscalars > 0) THEN + DO k=kts,kte + Dqnbca(k)=(qnbca2(k) - qnbca(k))/delt + ENDDO + ELSE + DO k=kts,kte + Dqnbca(k)=0. + ENDDO + ENDIF + !ensure non-negative moist species !note: if called down here, dth needs to be updated, but ! if called before the theta-tendency calculation, do not compute dth @@ -5189,9 +5106,9 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & END SUBROUTINE mynn_tendencies ! ================================================================== - SUBROUTINE moisture_check(kte, delt, dp, exner, & - qv, qc, qi, th, & - dqv, dqc, dqi, dth ) + SUBROUTINE moisture_check(kte, delt, dp, exner, & + qv, qc, qi, qs, th, & + dqv, dqc, dqi, dqs, dth ) ! This subroutine was adopted from the CAM-UW ShCu scheme and ! adapted for use here. @@ -5207,33 +5124,36 @@ SUBROUTINE moisture_check(kte, delt, dp, exner, & ! applying corresponding input tendencies and corrective tendencies. implicit none - integer, intent(in) :: kte - real(kind=kind_phys), intent(in) :: delt - real, dimension(kte), intent(in) :: dp, exner - real, dimension(kte), intent(inout) :: qv, qc, qi, th - real, dimension(kte), intent(inout) :: dqv, dqc, dqi, dth + integer, intent(in) :: kte + real(kind_phys), intent(in) :: delt + real(kind_phys), dimension(kte), intent(in) :: dp, exner + real(kind_phys), dimension(kte), intent(inout) :: qv, qc, qi, qs, th + real(kind_phys), dimension(kte), intent(inout) :: dqv, dqc, dqi, dqs, dth integer k - real :: dqc2, dqi2, dqv2, sum, aa, dum - real, parameter :: qvmin = 1e-20, & - qcmin = 0.0, & - qimin = 0.0 + real(kind_phys):: dqc2, dqi2, dqs2, dqv2, sum, aa, dum + real(kind_phys), parameter :: qvmin = 1e-20, & + qcmin = 0.0, & + qimin = 0.0 do k = kte, 1, -1 ! From the top to the surface dqc2 = max(0.0, qcmin-qc(k)) !qc deficit (>=0) dqi2 = max(0.0, qimin-qi(k)) !qi deficit (>=0) + dqs2 = max(0.0, qimin-qs(k)) !qs deficit (>=0) !fix tendencies dqc(k) = dqc(k) + dqc2/delt dqi(k) = dqi(k) + dqi2/delt - dqv(k) = dqv(k) - (dqc2+dqi2)/delt + dqs(k) = dqs(k) + dqs2/delt + dqv(k) = dqv(k) - (dqc2+dqi2+dqs2)/delt dth(k) = dth(k) + xlvcp/exner(k)*(dqc2/delt) + & - xlscp/exner(k)*(dqi2/delt) + xlscp/exner(k)*((dqi2+dqs2)/delt) !update species qc(k) = qc(k) + dqc2 qi(k) = qi(k) + dqi2 - qv(k) = qv(k) - dqc2 - dqi2 + qs(k) = qs(k) + dqs2 + qv(k) = qv(k) - dqc2 - dqi2 - dqs2 th(k) = th(k) + xlvcp/exner(k)*dqc2 + & - xlscp/exner(k)*dqi2 + xlscp/exner(k)*(dqi2+dqs2) !then fix qv dqv2 = max(0.0, qvmin-qv(k)) !qv deficit (>=0) @@ -5246,6 +5166,7 @@ SUBROUTINE moisture_check(kte, delt, dp, exner, & qv(k) = max(qv(k),qvmin) qc(k) = max(qc(k),qcmin) qi(k) = max(qi(k),qimin) + qs(k) = max(qs(k),qimin) end do ! Extra moisture used to satisfy 'qv(1)>=qvmin' is proportionally ! extracted from all the layers that has 'qv > 2*qvmin'. This fully @@ -5289,36 +5210,35 @@ SUBROUTINE mynn_mix_chem(kts,kte,i, & !------------------------------------------------------------------- INTEGER, INTENT(in) :: kts,kte,i - - REAL, DIMENSION(kts:kte), INTENT(IN) :: dfh,dz,tcd,qcd - REAL, DIMENSION(kts:kte), INTENT(INOUT) :: rho - REAL, INTENT(IN) :: flt - REAL(kind=kind_phys), INTENT(IN) :: delt,pblh + real(kind_phys), DIMENSION(kts:kte), INTENT(IN) :: dfh,dz,tcd,qcd + real(kind_phys), DIMENSION(kts:kte), INTENT(INOUT) :: rho + real(kind_phys), INTENT(IN) :: flt + real(kind_phys), INTENT(IN) :: delt,pblh INTEGER, INTENT(IN) :: nchem, kdvel, ndvel - REAL, DIMENSION( kts:kte+1), INTENT(IN) :: s_aw - REAL, DIMENSION( kts:kte, nchem ), INTENT(INOUT) :: chem1 - REAL, DIMENSION( kts:kte+1,nchem), INTENT(IN) :: s_awchem - REAL, DIMENSION( ndvel ), INTENT(IN) :: vd1 - REAL(kind=kind_phys), INTENT(IN) :: emis_ant_no,frp + real(kind_phys), DIMENSION( kts:kte+1), INTENT(IN) :: s_aw + real(kind_phys), DIMENSION( kts:kte, nchem ), INTENT(INOUT) :: chem1 + real(kind_phys), DIMENSION( kts:kte+1,nchem), INTENT(IN) :: s_awchem + real(kind_phys), DIMENSION( ndvel ), INTENT(IN) :: vd1 + real(kind_phys), INTENT(IN) :: emis_ant_no,frp LOGICAL, INTENT(IN) :: rrfs_sd,enh_mix,smoke_dbg !local vars - REAL, DIMENSION(kts:kte) :: dtz - REAL, DIMENSION(kts:kte) :: a,b,c,d,x - REAL :: rhs,dztop - REAL :: t,dzk - REAL :: hght - REAL :: khdz_old, khdz_back + real(kind_phys), DIMENSION(kts:kte) :: dtz + real(kind_phys), DIMENSION(kts:kte) :: a,b,c,d,x + real(kind_phys):: rhs,dztop + real(kind_phys):: t,dzk + real(kind_phys):: hght + real(kind_phys):: khdz_old, khdz_back INTEGER :: k,kk,kmaxfire ! JLS 12/21/21 INTEGER :: ic ! Chemical array loop index INTEGER, SAVE :: icall - REAL, DIMENSION(kts:kte) :: rhoinv - REAL, DIMENSION(kts:kte+1) :: rhoz,khdz - REAL, PARAMETER :: NO_threshold = 0.1 ! For anthropogenic sources - REAL, PARAMETER :: frp_threshold = 10.0 ! RAR 02/11/22: I increased the frp threshold to enhance mixing over big fires - REAL, PARAMETER :: pblh_threshold = 250.0 + real(kind_phys), DIMENSION(kts:kte) :: rhoinv + real(kind_phys), DIMENSION(kts:kte+1) :: rhoz,khdz + real(kind_phys), PARAMETER :: NO_threshold = 10.0 ! For anthropogenic sources + real(kind_phys), PARAMETER :: frp_threshold = 10.0 ! RAR 02/11/22: I increased the frp threshold to enhance mixing over big fires + real(kind_phys), PARAMETER :: pblh_threshold = 100.0 dztop=.5*(dz(kte)+dz(kte-1)) @@ -5419,13 +5339,13 @@ SUBROUTINE retrieve_exchange_coeffs(kts,kte,& INTEGER , INTENT(in) :: kts,kte - REAL, DIMENSION(KtS:KtE), INTENT(in) :: dz,dfm,dfh + real(kind_phys), DIMENSION(KtS:KtE), INTENT(in) :: dz,dfm,dfh - REAL, DIMENSION(KtS:KtE), INTENT(out) :: K_m, K_h + real(kind_phys), DIMENSION(KtS:KtE), INTENT(out) :: K_m, K_h INTEGER :: k - REAL :: dzk + real(kind_phys):: dzk K_m(kts)=0. K_h(kts)=0. @@ -5451,12 +5371,12 @@ SUBROUTINE tridiag(n,a,b,c,d) !------------------------------------------------------------------- INTEGER, INTENT(in):: n - REAL, DIMENSION(n), INTENT(in) :: a,b - REAL, DIMENSION(n), INTENT(inout) :: c,d + real(kind_phys), DIMENSION(n), INTENT(in) :: a,b + real(kind_phys), DIMENSION(n), INTENT(inout) :: c,d INTEGER :: i - REAL :: p - REAL, DIMENSION(n) :: q + real(kind_phys):: p + real(kind_phys), DIMENSION(n) :: q c(n)=0. q(1)=-c(1)/b(1) @@ -5486,10 +5406,10 @@ subroutine tridiag2(n,a,b,c,d,x) ! n - number of unknowns (levels) integer,intent(in) :: n - real, dimension(n),intent(in) :: a,b,c,d - real ,dimension(n),intent(out) :: x - real ,dimension(n) :: cp,dp - real :: m + real(kind_phys), dimension(n), intent(in) :: a,b,c,d + real(kind_phys), dimension(n), intent(out):: x + real(kind_phys), dimension(n) :: cp,dp + real(kind_phys):: m integer :: i ! initialize c-prime and d-prime @@ -5528,12 +5448,12 @@ subroutine tridiag3(kte,a,b,c,d,x) implicit none integer,intent(in) :: kte integer, parameter :: kts=1 - real, dimension(kte) :: a,b,c,d - real ,dimension(kte),intent(out) :: x + real(kind_phys), dimension(kte) :: a,b,c,d + real(kind_phys), dimension(kte), intent(out) :: x integer :: in ! integer kms,kme,kts,kte,in -! real a(kms:kme,3),c(kms:kme),x(kms:kme) +! real(kind_phys)a(kms:kme,3),c(kms:kme),x(kms:kme) do in=kte-1,kts,-1 d(in)=d(in)-c(in)*d(in+1)/b(in+1) @@ -5551,63 +5471,6 @@ subroutine tridiag3(kte,a,b,c,d,x) return end subroutine tridiag3 -! ================================================================== - -!>\ingroup gsd_mynn_edmf - SUBROUTINE mynn_bl_init_driver( & - &RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN, & - &RQCBLTEN,RQIBLTEN & !,RQNIBLTEN,RQNCBLTEN & - &,QKE, & - &EXCH_H & - !&,icloud_bl,qc_bl,cldfra_bl & - &,RESTART,ALLOWED_TO_READ,LEVEL & - &,IDS,IDE,JDS,JDE,KDS,KDE & - &,IMS,IME,JMS,JME,KMS,KME & - &,ITS,ITE,JTS,JTE,KTS,KTE) - - !--------------------------------------------------------------- - LOGICAL,INTENT(IN) :: ALLOWED_TO_READ,RESTART - INTEGER,INTENT(IN) :: LEVEL !,icloud_bl - - 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),INTENT(INOUT) :: & - &RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN, & - &RQCBLTEN,RQIBLTEN,& !RQNIBLTEN,RQNCBLTEN & - &QKE,EXCH_H - - INTEGER :: I,J,K,ITF,JTF,KTF - - JTF=MIN0(JTE,JDE-1) - KTF=MIN0(KTE,KDE-1) - ITF=MIN0(ITE,IDE-1) - - IF(.NOT.RESTART)THEN - DO K=KTS,KTF - DO I=ITS,ITF - RUBLTEN(i,k)=0. - RVBLTEN(i,k)=0. - RTHBLTEN(i,k)=0. - RQVBLTEN(i,k)=0. - if( p_qc >= param_first_scalar ) RQCBLTEN(i,k)=0. - if( p_qi >= param_first_scalar ) RQIBLTEN(i,k)=0. - !if( p_qnc >= param_first_scalar ) RQNCBLTEN(i,k)=0. - !if( p_qni >= param_first_scalar ) RQNIBLTEN(i,k)=0. - !QKE(i,k)=0. - EXCH_H(i,k)=0. -! if(icloud_bl > 0) qc_bl(i,k)=0. -! if(icloud_bl > 0) cldfra_bl(i,k)=0. - ENDDO - ENDDO - ENDIF - - mynn_level=level - - END SUBROUTINE mynn_bl_init_driver - ! ================================================================== !>\ingroup gsd_mynn_edmf !! This subroutine calculates hybrid diagnotic boundary-layer height (PBLH). @@ -5654,15 +5517,15 @@ SUBROUTINE GET_PBLH(KTS,KTE,zi,thetav1D,qke1D,zw1D,dz1D,landsea,kzi) # define kte HARDCODE_VERTICAL #endif - REAL(kind=kind_phys), INTENT(OUT) :: zi - REAL, INTENT(IN) :: landsea - REAL, DIMENSION(KTS:KTE), INTENT(IN) :: thetav1D, qke1D, dz1D - REAL, DIMENSION(KTS:KTE+1), INTENT(IN) :: zw1D + real(kind_phys), INTENT(OUT) :: zi + real(kind_phys), INTENT(IN) :: landsea + real(kind_phys), DIMENSION(KTS:KTE), INTENT(IN) :: thetav1D, qke1D, dz1D + real(kind_phys), DIMENSION(KTS:KTE+1), INTENT(IN) :: zw1D !LOCAL VARS - REAL :: PBLH_TKE,qtke,qtkem1,wt,maxqke,TKEeps,minthv - REAL :: delt_thv !delta theta-v; dependent on land/sea point - REAL, PARAMETER :: sbl_lim = 200. !upper limit of stable BL height (m). - REAL, PARAMETER :: sbl_damp = 400. !transition length for blending (m). + real(kind_phys):: PBLH_TKE,qtke,qtkem1,wt,maxqke,TKEeps,minthv + real(kind_phys):: delt_thv !delta theta-v; dependent on land/sea point + real(kind_phys), PARAMETER :: sbl_lim = 200. !upper limit of stable BL height (m). + real(kind_phys), PARAMETER :: sbl_damp = 400. !transition length for blending (m). INTEGER :: I,J,K,kthv,ktke,kzi !Initialize KPBL (kzi) @@ -5790,46 +5653,47 @@ END SUBROUTINE GET_PBLH !! !! This scheme remains under development, so consider it experimental code. !! - SUBROUTINE DMP_mf( & - & kts,kte,dt,zw,dz,p,rho, & - & momentum_opt, & - & tke_opt, & - & scalar_opt, & - & u,v,w,th,thl,thv,tk, & - & qt,qv,qc,qke, & - & qnc,qni,qnwfa,qnifa, & - & exner,vt,vq,sgm, & - & ust,flt,fltv,flq,flqv, & - & pblh,kpbl,DX,landsea,ts, & + SUBROUTINE DMP_mf( & + & kts,kte,dt,zw,dz,p,rho, & + & momentum_opt, & + & tke_opt, & + & scalar_opt, & + & u,v,w,th,thl,thv,tk, & + & qt,qv,qc,qke, & + & qnc,qni,qnwfa,qnifa,qnbca, & + & exner,vt,vq,sgm, & + & ust,flt,fltv,flq,flqv, & + & pblh,kpbl,dx,landsea,ts, & ! outputs - updraft properties - & edmf_a,edmf_w, & - & edmf_qt,edmf_thl, & - & edmf_ent,edmf_qc, & + & edmf_a,edmf_w, & + & edmf_qt,edmf_thl, & + & edmf_ent,edmf_qc, & ! outputs - variables needed for solver - & s_aw,s_awthl,s_awqt, & - & s_awqv,s_awqc, & - & s_awu,s_awv,s_awqke, & - & s_awqnc,s_awqni, & - & s_awqnwfa,s_awqnifa, & - & sub_thl,sub_sqv, & - & sub_u,sub_v, & - & det_thl,det_sqv,det_sqc, & - & det_u,det_v, & + & s_aw,s_awthl,s_awqt, & + & s_awqv,s_awqc, & + & s_awu,s_awv,s_awqke, & + & s_awqnc,s_awqni, & + & s_awqnwfa,s_awqnifa, & + & s_awqnbca, & + & sub_thl,sub_sqv, & + & sub_u,sub_v, & + & det_thl,det_sqv,det_sqc, & + & det_u,det_v, & ! chem/smoke - & nchem,chem1,s_awchem, & - & mix_chem, & + & nchem,chem1,s_awchem, & + & mix_chem, & ! in/outputs - subgrid scale clouds & qc_bl1d,cldfra_bl1d, & & qc_bl1D_old,cldfra_bl1D_old, & ! inputs - flags for moist arrays - & F_QC,F_QI, & - F_QNC,F_QNI, & - & F_QNWFA,F_QNIFA, & - & Psig_shcu, & + & F_QC,F_QI, & + & F_QNC,F_QNI, & + & F_QNWFA,F_QNIFA,F_QNBCA, & + & Psig_shcu, & ! output info - &nup2,ktop,maxmf,ztop, & - ! unputs for stochastic perturbations - &spp_pbl,rstoch_col) + & nup2,ktop,maxmf,ztop, & + ! inputs for stochastic perturbations + & spp_pbl,rstoch_col ) ! inputs: INTEGER, INTENT(IN) :: KTS,KTE,KPBL,momentum_opt,tke_opt,scalar_opt @@ -5840,140 +5704,134 @@ SUBROUTINE DMP_mf( & #endif ! Stochastic - INTEGER, INTENT(IN) :: spp_pbl - REAL, DIMENSION(KTS:KTE) :: rstoch_col + INTEGER, INTENT(IN) :: spp_pbl + real(kind_phys), DIMENSION(KTS:KTE) :: rstoch_col - REAL,DIMENSION(KTS:KTE), INTENT(IN) :: U,V,W,TH,THL,TK,QT,QV,QC,& - exner,dz,THV,P,rho,qke,qnc,qni,qnwfa,qnifa - REAL,DIMENSION(KTS:KTE+1), INTENT(IN) :: ZW !height at full-sigma - REAL, INTENT(IN) :: FLT,FLTV,FLQ,FLQV,& - Psig_shcu,landsea,ts - REAL(kind=kind_phys), INTENT(IN) :: dx,dt,ust,pblh - LOGICAL, OPTIONAL :: F_QC,F_QI,F_QNC,F_QNI,F_QNWFA,F_QNIFA + real(kind_phys),DIMENSION(KTS:KTE), INTENT(IN) :: & + &U,V,W,TH,THL,TK,QT,QV,QC, & + &exner,dz,THV,P,rho,qke,qnc,qni,qnwfa,qnifa,qnbca + real(kind_phys),DIMENSION(KTS:KTE+1), INTENT(IN) :: zw !height at full-sigma + real(kind_phys), INTENT(IN) :: flt,fltv,flq,flqv,Psig_shcu, & + &landsea,ts,dx,dt,ust,pblh + LOGICAL, OPTIONAL :: F_QC,F_QI,F_QNC,F_QNI,F_QNWFA,F_QNIFA,F_QNBCA ! outputs - updraft properties - REAL,DIMENSION(KTS:KTE), INTENT(OUT) :: edmf_a,edmf_w, & - & edmf_qt,edmf_thl, edmf_ent,edmf_qc + real(kind_phys),DIMENSION(KTS:KTE), INTENT(OUT) :: edmf_a,edmf_w, & + & edmf_qt,edmf_thl,edmf_ent,edmf_qc !add one local edmf variable: - REAL,DIMENSION(KTS:KTE) :: edmf_th + real(kind_phys),DIMENSION(KTS:KTE) :: edmf_th ! output INTEGER, INTENT(OUT) :: nup2,ktop - REAL(kind=kind_phys), INTENT(OUT) :: maxmf - REAL, INTENT(OUT) :: ztop + real(kind_phys), INTENT(OUT) :: maxmf + real(kind_phys), INTENT(OUT) :: ztop ! outputs - variables needed for solver - REAL,DIMENSION(KTS:KTE+1) :: s_aw, & !sum ai*rho*wis_awphi - s_awthl, & !sum ai*rho*wi*phii - s_awqt, & - s_awqv, & - s_awqc, & - s_awqnc, & - s_awqni, & - s_awqnwfa, & - s_awqnifa, & - s_awu, & - s_awv, & - s_awqke, s_aw2 - - REAL,DIMENSION(KTS:KTE), INTENT(INOUT) :: qc_bl1d,cldfra_bl1d, & - qc_bl1d_old,cldfra_bl1d_old + real(kind_phys),DIMENSION(KTS:KTE+1) :: s_aw, & !sum ai*rho*wis_awphi + &s_awthl,s_awqt,s_awqv,s_awqc,s_awqnc,s_awqni, & + &s_awqnwfa,s_awqnifa,s_awqnbca,s_awu,s_awv, & + &s_awqke,s_aw2 + + real(kind_phys),DIMENSION(KTS:KTE), INTENT(INOUT) :: & + &qc_bl1d,cldfra_bl1d,qc_bl1d_old,cldfra_bl1d_old INTEGER, PARAMETER :: nup=10, debug_mf=0 !------------- local variables ------------------- ! updraft properties defined on interfaces (k=1 is the top of the ! first model layer - REAL,DIMENSION(KTS:KTE+1,1:NUP) :: UPW,UPTHL,UPQT,UPQC,UPQV, & - UPA,UPU,UPV,UPTHV,UPQKE,UPQNC, & - UPQNI,UPQNWFA,UPQNIFA + real(kind_phys),DIMENSION(KTS:KTE+1,1:NUP) :: & + &UPW,UPTHL,UPQT,UPQC,UPQV, & + &UPA,UPU,UPV,UPTHV,UPQKE,UPQNC, & + &UPQNI,UPQNWFA,UPQNIFA,UPQNBCA ! entrainment variables - REAL,DIMENSION(KTS:KTE,1:NUP) :: ENT,ENTf - INTEGER,DIMENSION(KTS:KTE,1:NUP) :: ENTi + real(kind_phys),DIMENSION(KTS:KTE,1:NUP) :: ENT,ENTf + INTEGER,DIMENSION(KTS:KTE,1:NUP) :: ENTi ! internal variables INTEGER :: K,I,k50 - REAL :: fltv2,wstar,qstar,thstar,sigmaW,sigmaQT,sigmaTH,z0, & - pwmin,pwmax,wmin,wmax,wlv,Psig_w,maxw,maxqc,wpbl - REAL :: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,QNCn,QNIn,QNWFAn,QNIFAn, & - Wn2,Wn,EntEXP,EntEXM,EntW,BCOEFF,THVkm1,THVk,Pk,qtk,rho_int + real(kind_phys):: fltv2,wstar,qstar,thstar,sigmaW,sigmaQT, & + &sigmaTH,z0,pwmin,pwmax,wmin,wmax,wlv,Psig_w,maxw,maxqc,wpbl + real(kind_phys):: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,QNCn,QNIn, & + QNWFAn,QNIFAn,QNBCAn, & + Wn2,Wn,EntEXP,EntEXM,EntW,BCOEFF,THVkm1,THVk,Pk,rho_int ! w parameters - REAL,PARAMETER :: & - &Wa=2./3., & - &Wb=0.002, & + real(kind_phys), PARAMETER :: & + &Wa=2./3., & + &Wb=0.002, & &Wc=1.5 ! Lateral entrainment parameters ( L0=100 and ENT0=0.1) were taken from ! Suselj et al (2013, jas). Note that Suselj et al (2014,waf) use L0=200 and ENT0=0.2. - REAL,PARAMETER :: & + real(kind_phys),PARAMETER :: & & L0=100., & & ENT0=0.1 ! Implement ideas from Neggers (2016, JAMES): - REAL, PARAMETER :: Atot = 0.10 ! Maximum total fractional area of all updrafts - REAL, PARAMETER :: lmax = 1000.! diameter of largest plume - REAL, PARAMETER :: dl = 100. ! diff size of each plume - the differential multiplied by the integrand - REAL, PARAMETER :: dcut = 1.2 ! max diameter of plume to parameterize relative to dx (km) - REAL :: d != -2.3 to -1.7 ;=-1.9 in Neggers paper; power law exponent for number density (N=Cl^d). + real(kind_phys), PARAMETER :: Atot = 0.10 ! Maximum total fractional area of all updrafts + real(kind_phys), PARAMETER :: lmax = 1000.! diameter of largest plume + real(kind_phys), PARAMETER :: dl = 100. ! diff size of each plume - the differential multiplied by the integrand + real(kind_phys), PARAMETER :: dcut = 1.2 ! max diameter of plume to parameterize relative to dx (km) + real(kind_phys):: d != -2.3 to -1.7 ;=-1.9 in Neggers paper; power law exponent for number density (N=Cl^d). ! Note that changing d to -2.0 makes each size plume equally contribute to the total coverage of all plumes. ! Note that changing d to -1.7 doubles the area coverage of the largest plumes relative to the smallest plumes. - REAL :: cn,c,l,n,an2,hux,maxwidth,wspd_pbl,cloud_base,width_flx + real(kind_phys):: cn,c,l,n,an2,hux,maxwidth,wspd_pbl,cloud_base,width_flx ! chem/smoke INTEGER, INTENT(IN) :: nchem - REAL,DIMENSION(:, :) :: chem1 - REAL,DIMENSION(kts:kte+1, nchem) :: s_awchem - REAL,DIMENSION(nchem) :: chemn - REAL,DIMENSION(KTS:KTE+1,1:NUP, nchem) :: UPCHEM + real(kind_phys),DIMENSION(:, :) :: chem1 + real(kind_phys),DIMENSION(kts:kte+1, nchem) :: s_awchem + real(kind_phys),DIMENSION(nchem) :: chemn + real(kind_phys),DIMENSION(KTS:KTE+1,1:NUP, nchem) :: UPCHEM INTEGER :: ic - REAL,DIMENSION(KTS:KTE+1, nchem) :: edmf_chem + real(kind_phys),DIMENSION(KTS:KTE+1, nchem) :: edmf_chem LOGICAL, INTENT(IN) :: mix_chem !JOE: add declaration of ERF - REAL :: ERF + real(kind_phys):: ERF LOGICAL :: superadiabatic ! VARIABLES FOR CHABOUREAU-BECHTOLD CLOUD FRACTION - REAL,DIMENSION(KTS:KTE), INTENT(INOUT) :: vt, vq, sgm - REAL :: sigq,xl,rsl,cpm,a,qmq,mf_cf,Aup,Q1,diffqt,qsat_tk,& - Fng,qww,alpha,beta,bb,f,pt,t,q2p,b9,satvp,rhgrid, & + real(kind_phys),DIMENSION(KTS:KTE), INTENT(INOUT) :: vt, vq, sgm + real(kind_phys):: sigq,xl,rsl,cpm,a,qmq,mf_cf,Aup,Q1,diffqt,qsat_tk,& + Fng,qww,alpha,beta,bb,f,pt,t,q2p,b9,satvp,rhgrid, & Ac_mf,Ac_strat,qc_mf - REAL, PARAMETER :: cf_thresh = 0.5 ! only overwrite stratus CF less than this value + real(kind_phys), PARAMETER :: cf_thresh = 0.5 ! only overwrite stratus CF less than this value ! Variables for plume interpolation/saturation check - REAL,DIMENSION(KTS:KTE) :: exneri,dzi - REAL :: THp, QTp, QCp, QCs, esat, qsl - REAL :: csigma,acfac,ac_wsp,ac_cld + real(kind_phys),DIMENSION(KTS:KTE) :: exneri,dzi + real(kind_phys):: THp, QTp, QCp, QCs, esat, qsl + real(kind_phys):: csigma,acfac,ac_wsp,ac_cld !plume overshoot INTEGER :: overshoot - REAL :: bvf, Frz, dzp + real(kind_phys):: bvf, Frz, dzp !Flux limiter: not let mass-flux of heat between k=1&2 exceed (fluxportion)*(surface heat flux). !This limiter makes adjustments to the entire column. - REAL :: adjustment, flx1 - REAL, PARAMETER :: fluxportion=0.75 ! set liberally, so has minimal impact. 0.5 starts to have a noticeable impact + real(kind_phys):: adjustment, flx1 + real(kind_phys), PARAMETER :: fluxportion=0.75 ! set liberally, so has minimal impact. 0.5 starts to have a noticeable impact ! over land (decrease maxMF by 10-20%), but no impact over water. !Subsidence - REAL,DIMENSION(KTS:KTE) :: sub_thl,sub_sqv,sub_u,sub_v, & !tendencies due to subsidence - det_thl,det_sqv,det_sqc,det_u,det_v, & !tendencied due to detrainment - envm_a,envm_w,envm_thl,envm_sqv,envm_sqc, & + real(kind_phys),DIMENSION(KTS:KTE) :: sub_thl,sub_sqv,sub_u,sub_v, & !tendencies due to subsidence + det_thl,det_sqv,det_sqc,det_u,det_v, & !tendencied due to detrainment + envm_a,envm_w,envm_thl,envm_sqv,envm_sqc, & envm_u,envm_v !environmental variables defined at middle of layer - REAL,DIMENSION(KTS:KTE+1) :: envi_a,envi_w !environmental variables defined at model interface - REAL :: temp,sublim,qc_ent,qv_ent,qt_ent,thl_ent,detrate, & - detrateUV,oow,exc_fac,aratio,detturb,qc_grid,qc_sgs,& + real(kind_phys),DIMENSION(KTS:KTE+1) :: envi_a,envi_w !environmental variables defined at model interface + real(kind_phys):: temp,sublim,qc_ent,qv_ent,qt_ent,thl_ent,detrate, & + detrateUV,oow,exc_fac,aratio,detturb,qc_grid,qc_sgs, & qc_plume,exc_heat,exc_moist,tk_int - REAL, PARAMETER :: Cdet = 1./45. - REAL, PARAMETER :: dzpmax = 300. !limit dz used in detrainment - can be excessing in thick layers + real(kind_phys), PARAMETER :: Cdet = 1./45. + real(kind_phys), PARAMETER :: dzpmax = 300. !limit dz used in detrainment - can be excessing in thick layers !parameter "Csub" determines the propotion of upward vertical velocity that contributes to !environmenatal subsidence. Some portion is expected to be compensated by downdrafts instead of !gentle environmental subsidence. 1.0 assumes all upward vertical velocity in the mass-flux scheme !is compensated by "gentle" environmental subsidence. - REAL, PARAMETER :: Csub=0.25 + real(kind_phys), PARAMETER :: Csub=0.25 !Factor for the pressure gradient effects on momentum transport - REAL, PARAMETER :: pgfac = 0.00 ! Zhang and Wu showed 0.4 is more appropriate for lower troposphere - REAL :: Uk,Ukm1,Vk,Vkm1,dxsa + real(kind_phys), PARAMETER :: pgfac = 0.00 ! Zhang and Wu showed 0.4 is more appropriate for lower troposphere + real(kind_phys):: Uk,Ukm1,Vk,Vkm1,dxsa ! check the inputs ! print *,'dt',dt @@ -6002,6 +5860,7 @@ SUBROUTINE DMP_mf( & UPQNI=0. UPQNWFA=0. UPQNIFA=0. + UPQNBCA=0. IF ( mix_chem ) THEN UPCHEM(KTS:KTE+1,1:NUP,1:nchem)=0.0 ENDIF @@ -6031,6 +5890,7 @@ SUBROUTINE DMP_mf( & s_awqni=0. s_awqnwfa=0. s_awqnifa=0. + s_awqnbca=0. IF ( mix_chem ) THEN s_awchem(kts:kte+1,1:nchem) = 0.0 ENDIF @@ -6224,7 +6084,7 @@ SUBROUTINE DMP_mf( & wlv=wmin+(wmax-wmin)/NUP2*(i-1) !SURFACE UPDRAFT VERTICAL VELOCITY - UPW(1,I)=wmin + REAL(i)/REAL(NUP)*(wmax-wmin) + UPW(1,I)=wmin + real(i)/real(NUP)*(wmax-wmin) !IF (UPW(1,I) > 0.5*ZW(2)/dt) UPW(1,I) = 0.5*ZW(2)/dt UPU(1,I)=(U(KTS)*DZ(KTS+1)+U(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) @@ -6258,6 +6118,7 @@ SUBROUTINE DMP_mf( & UPQNI(1,I)=(QNI(KTS)*DZ(KTS+1)+QNI(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) UPQNWFA(1,I)=(QNWFA(KTS)*DZ(KTS+1)+QNWFA(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) UPQNIFA(1,I)=(QNIFA(KTS)*DZ(KTS+1)+QNIFA(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) + UPQNBCA(1,I)=(QNBCA(KTS)*DZ(KTS+1)+QNBCA(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) ENDDO IF ( mix_chem ) THEN @@ -6330,6 +6191,7 @@ SUBROUTINE DMP_mf( & QNIn=UPQNI(k-1,I)*(1.-EntExp) + QNI(k)*EntExp QNWFAn=UPQNWFA(k-1,I)*(1.-EntExp) + QNWFA(k)*EntExp QNIFAn=UPQNIFA(k-1,I)*(1.-EntExp) + QNIFA(k)*EntExp + QNBCAn=UPQNBCA(k-1,I)*(1.-EntExp) + QNBCA(k)*EntExp !capture the updated qc, qt & thl modified by entranment alone, !since they will be modified later if condensation occurs. @@ -6426,13 +6288,10 @@ SUBROUTINE DMP_mf( & dzp = dz(k) ENDIF - !Limit very tall plumes - Wn=Wn*EXP(-MAX(ZW(k+1)-MIN(pblh+2000.,3500.),0.0)/1000.) - - !JOE- minimize the plume penetratration in stratocu-topped PBL - ! IF (fltv2 < 0.06) THEN - ! IF(ZW(k+1) >= pblh-200. .AND. qc(k) > 1e-5 .AND. I > 4) Wn=0. - ! ENDIF + !minimize the plume penetratration in stratocu-topped PBL + !IF (fltv2 < 0.06) THEN + ! IF(ZW(k+1) >= pblh-200. .AND. qc(k) > 1e-5 .AND. I > 4) Wn=0. + !ENDIF !Modify environment variables (representative of the model layer - envm*) !following the updraft dynamical detrainment of Asai and Kasahara (1967, JAS). @@ -6470,6 +6329,7 @@ SUBROUTINE DMP_mf( & UPQNI(K,I)=QNIn UPQNWFA(K,I)=QNWFAn UPQNIFA(K,I)=QNIFAn + UPQNBCA(K,I)=QNBCAn UPA(K,I)=UPA(K-1,I) IF ( mix_chem ) THEN do ic = 1,nchem @@ -6527,11 +6387,11 @@ SUBROUTINE DMP_mf( & !to conform to grid mean properties, move qc to qv in grid mean !saturated layers, so total water fluxes are preserved but !negative qc fluxes in unsaturated layers is reduced. - IF (qc(k) > 1e-12 .OR. qc(k+1) > 1e-12) then +! if (qc(k) > 1e-12 .or. qc(k+1) > 1e-12) then qc_plume = UPQC(K,i) - ELSE - qc_plume = 0.0 - ENDIF +! else +! qc_plume = 0.0 +! endif s_awqc(k+1) = s_awqc(k+1) + rho_int*UPA(K,i)*UPW(K,i)*qc_plume*Psig_w IF (momentum_opt > 0) THEN s_awu(k+1) = s_awu(k+1) + rho_int*UPA(K,i)*UPW(K,i)*UPU(K,i)*Psig_w @@ -6567,6 +6427,7 @@ SUBROUTINE DMP_mf( & s_awqni(k+1)= s_awqni(K+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQNI(K,i)*Psig_w s_awqnwfa(k+1)= s_awqnwfa(K+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQNWFA(K,i)*Psig_w s_awqnifa(k+1)= s_awqnifa(K+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQNIFA(K,i)*Psig_w + s_awqnbca(k+1)= s_awqnbca(K+1) + rho_int*UPA(K,i)*UPW(K,i)*UPQNBCA(K,i)*Psig_w ENDDO ENDDO ENDIF @@ -6596,6 +6457,7 @@ SUBROUTINE DMP_mf( & s_awqni= s_awqni*adjustment s_awqnwfa= s_awqnwfa*adjustment s_awqnifa= s_awqnifa*adjustment + s_awqnbca= s_awqnbca*adjustment IF (momentum_opt > 0) THEN s_awu = s_awu*adjustment s_awv = s_awv*adjustment @@ -6642,9 +6504,9 @@ SUBROUTINE DMP_mf( & !smoke/chem IF ( mix_chem ) THEN - DO k=KTS,KTE-1 + DO k=kts,kte-1 IF(k > KTOP) exit - rho_int = (rho(k)*DZ(k+1)+rho(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) + rho_int = (rho(k)*dz(k+1)+rho(k+1)*dz(k))/(dz(k+1)+dz(k)) DO I=1,NUP !NUP2 IF(I > NUP2) exit do ic = 1,nchem @@ -6661,14 +6523,14 @@ SUBROUTINE DMP_mf( & ENDIF !Calculate the effects environmental subsidence. - !All envi_*variables are valid at the interfaces, like the edmf_* variables + !All envi_*variables are valid at the interfaces, like the edmf_* variables IF (env_subs) THEN - DO k=KTS+1,KTE-1 + DO k=kts+1,kte-1 !First, smooth the profiles of w & a, since sharp vertical gradients !in plume variables are not likely extended to env variables !Note1: w is treated as negative further below !Note2: both w & a will be transformed into env variables further below - envi_w(k) = onethird*(edmf_w(K-1)+edmf_w(K)+edmf_w(K+1)) + envi_w(k) = onethird*(edmf_w(k-1)+edmf_w(k)+edmf_w(k+1)) envi_a(k) = onethird*(edmf_a(k-1)+edmf_a(k)+edmf_a(k+1))*adjustment ENDDO !define env variables at k=1 (top of first model layer) @@ -6689,22 +6551,26 @@ SUBROUTINE DMP_mf( & sublim = 1.0 ENDIF !Transform w & a into env variables - DO k=KTS,KTE + DO k=kts,kte temp=envi_a(k) envi_a(k)=1.0-temp envi_w(k)=csub*sublim*envi_w(k)*temp/(1.-temp) ENDDO !calculate tendencies from subsidence and detrainment valid at the middle of - !each model layer - dzi(kts) = 0.5*(DZ(kts)+DZ(kts+1)) - sub_thl(kts)=0.5*envi_w(kts)*envi_a(kts)*(thl(kts+1)-thl(kts))/dzi(kts) - sub_sqv(kts)=0.5*envi_w(kts)*envi_a(kts)*(qv(kts+1)-qv(kts))/dzi(kts) - DO k=KTS+1,KTE-1 - dzi(k) = 0.5*(DZ(k)+DZ(k+1)) - sub_thl(k)=0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * & - (thl(k+1)-thl(k))/dzi(k) - sub_sqv(k)=0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * & - (qv(k+1)-qv(k))/dzi(k) + !each model layer. The lowest model layer uses an assumes w=0 at the surface. + dzi(kts) = 0.5*(dz(kts)+dz(kts+1)) + rho_int = (rho(kts)*dz(kts+1)+rho(kts+1)*dz(kts))/(dz(kts+1)+dz(kts)) + sub_thl(kts)= 0.5*envi_w(kts)*envi_a(kts)* & + (rho(kts+1)*thl(kts+1)-rho(kts)*thl(kts))/dzi(kts)/rho_int + sub_sqv(kts)= 0.5*envi_w(kts)*envi_a(kts)* & + (rho(kts+1)*qv(kts+1)-rho(kts)*qv(kts))/dzi(kts)/rho_int + DO k=kts+1,kte-1 + dzi(k) = 0.5*(dz(k)+dz(k+1)) + rho_int = (rho(k)*dz(k+1)+rho(k+1)*dz(k))/(dz(k+1)+dz(k)) + sub_thl(k)= 0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * & + (rho(k+1)*thl(k+1)-rho(k)*thl(k))/dzi(k)/rho_int + sub_sqv(k)= 0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * & + (rho(k+1)*qv(k+1)-rho(k)*qv(k))/dzi(k)/rho_int ENDDO DO k=KTS,KTE-1 @@ -6714,13 +6580,17 @@ SUBROUTINE DMP_mf( & ENDDO IF (momentum_opt > 0) THEN - sub_u(kts)=0.5*envi_w(kts)*envi_a(kts)*(u(kts+1)-u(kts))/dzi(kts) - sub_v(kts)=0.5*envi_w(kts)*envi_a(kts)*(v(kts+1)-v(kts))/dzi(kts) - DO k=KTS+1,KTE-1 + rho_int = (rho(kts)*dz(kts+1)+rho(kts+1)*dz(kts))/(dz(kts+1)+dz(kts)) + sub_u(kts)=0.5*envi_w(kts)*envi_a(kts)* & + (rho(kts+1)*u(kts+1)-rho(kts)*u(kts))/dzi(kts)/rho_int + sub_v(kts)=0.5*envi_w(kts)*envi_a(kts)* & + (rho(kts+1)*v(kts+1)-rho(kts)*v(kts))/dzi(kts)/rho_int + DO k=kts+1,kte-1 + rho_int = (rho(k)*dz(k+1)+rho(k+1)*dz(k))/(dz(k+1)+dz(k)) sub_u(k)=0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * & - (u(k+1)-u(k))/dzi(k) + (rho(k+1)*u(k+1)-rho(k)*u(k))/dzi(k)/rho_int sub_v(k)=0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * & - (v(k+1)-v(k))/dzi(k) + (rho(k+1)*v(k+1)-rho(k)*v(k))/dzi(k)/rho_int ENDDO DO k=KTS,KTE-1 @@ -6741,10 +6611,10 @@ SUBROUTINE DMP_mf( & !JOE: ADD CLDFRA_bl1d, qc_bl1d. Note that they have already been defined in ! mym_condensation. Here, a shallow-cu component is added, but no cumulus -! clouds can be added at k=1 (start loop at k=2). - DO K=KTS+1,KTE-2 +! clouds can be added at k=1 (start loop at k=2). + do k=kts+1,kte-2 IF(k > KTOP) exit - IF(0.5*(edmf_qc(k)+edmf_qc(k-1))>0.0)THEN + IF(0.5*(edmf_qc(k)+edmf_qc(k-1))>0.0 .and. (cldfra_bl1d(k) < cf_thresh))THEN !interpolate plume quantities to mass levels Aup = (edmf_a(k)*dzi(k-1)+edmf_a(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) THp = (edmf_th(k)*dzi(k-1)+edmf_th(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) @@ -6757,11 +6627,11 @@ SUBROUTINE DMP_mf( & qsl=ep_2*esat/max(1.e-7,(p(k)-ep_3*esat)) !condensed liquid in the plume on mass levels - IF (edmf_qc(k)>0.0 .AND. edmf_qc(k-1)>0.0)THEN + if (edmf_qc(k)>0.0 .and. edmf_qc(k-1)>0.0) then QCp = (edmf_qc(k)*dzi(k-1)+edmf_qc(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) - ELSE - QCp = MAX(edmf_qc(k),edmf_qc(k-1)) - ENDIF + else + QCp = max(edmf_qc(k),edmf_qc(k-1)) + endif !COMPUTE CLDFRA & QC_BL FROM MASS-FLUX SCHEME and recompute vt & vq xl = xl_blend(tk(k)) ! obtain blended heat capacity @@ -6794,10 +6664,11 @@ SUBROUTINE DMP_mf( & endif !CB form: - sigq = 3.5E-3 * Aup * 0.5*(edmf_w(k)+edmf_w(k-1)) * f ! convective component of sigma (CB2005) + !sigq = 3.5E-3 * Aup * 0.5*(edmf_w(k)+edmf_w(k-1)) * f ! convective component of sigma (CB2005) !sigq = SQRT(sigq**2 + sgm(k)**2) ! combined conv + stratus components !Per S.DeRoode 2009? - !sigq = 4. * Aup * (QTp - qt(k)) + !sigq = 5. * Aup * (QTp - qt(k)) + sigq = 10. * Aup * (QTp - qt(k)) !constrain sigq wrt saturation: sigq = max(sigq, qsat_tk*0.02 ) sigq = min(sigq, qsat_tk*0.25 ) @@ -6806,21 +6677,21 @@ SUBROUTINE DMP_mf( & Q1 = qmq/sigq ! the numerator of Q1 if ((landsea-1.5).GE.0) then ! WATER - mf_cf = min(max(0.5 + 0.36 * atan(1.20*(Q1+0.2)),0.01),0.6) + !modified form from LES + !mf_cf = min(max(0.5 + 0.36 * atan(1.20*(Q1+0.2)),0.01),0.6) + !Original CB + mf_cf = min(max(0.5 + 0.36 * atan(1.55*Q1),0.01),0.6) mf_cf = max(mf_cf, 1.2 * Aup) + mf_cf = min(mf_cf, 5.0 * Aup) else ! LAND - !mf_cf= min(max(0.5 + 0.36 * atan(1.55*(qmq/sigq)),0.01),0.6) - mf_cf = min(max(0.5 + 0.36 * atan(1.20*(Q1+0.4)),0.01),0.6) ! New WA fit + !LES form + !mf_cf = min(max(0.5 + 0.36 * atan(1.20*(Q1+0.4)),0.01),0.6) + !Original CB + mf_cf = min(max(0.5 + 0.36 * atan(1.55*Q1),0.01),0.6) mf_cf = max(mf_cf, 1.75 * Aup) + mf_cf = min(mf_cf, 5.0 * Aup) endif - ! WA TEST 4/15/22 use fit to Aup rather than CB - !IF (Aup > 0.1) THEN - ! mf_cf = 2.5 * Aup - !ELSE - ! mf_cf = 1.8 * Aup - !ENDIF - !IF ( debug_code ) THEN ! print*,"In MYNN, StEM edmf" ! print*," CB: env qt=",qt(k)," qsat=",qsat_tk @@ -6832,21 +6703,17 @@ SUBROUTINE DMP_mf( & ! Update cloud fractions and specific humidities in grid cells ! where the mass-flux scheme is active. The specific humidities ! are converted to grid means (not in-cloud quantities). - if ((landsea-1.5).GE.0) then ! water - !don't overwrite stratus CF & qc_bl - degrades marine stratus - if (cldfra_bl1d(k) < cf_thresh) then - if (QCp * Aup > 5e-5) then - qc_bl1d(k) = 1.86 * (QCp * Aup) - 2.2e-5 - else - qc_bl1d(k) = 1.18 * (QCp * Aup) - endif - if (mf_cf .ge. Aup) then - qc_bl1d(k) = qc_bl1d(k) / mf_cf - endif - cldfra_bl1d(k) = mf_cf - Ac_mf = mf_cf + if (QCp * Aup > 5e-5) then + qc_bl1d(k) = 1.86 * (QCp * Aup) - 2.2e-5 + else + qc_bl1d(k) = 1.18 * (QCp * Aup) endif + if (mf_cf .ge. Aup) then + qc_bl1d(k) = qc_bl1d(k) / mf_cf + endif + cldfra_bl1d(k) = mf_cf + Ac_mf = mf_cf else ! land if (QCp * Aup > 5e-5) then qc_bl1d(k) = 1.86 * (QCp * Aup) - 2.2e-5 @@ -6865,42 +6732,40 @@ SUBROUTINE DMP_mf( & !Use Bechtold and Siebesma (1998) piecewise estimation of Fng with !limits ,since they really should be recalculated after all the other changes...: !Only overwrite vt & vq in non-stratus condition - if (cldfra_bl1d(k) < cf_thresh) then - !if ((landsea-1.5).GE.0) then ! WATER - Q1=max(Q1,-2.25) - !else - ! Q1=max(Q1,-2.0) - !endif - - if (Q1 .ge. 1.0) then - Fng = 1.0 - elseif (Q1 .ge. -1.7 .and. Q1 .lt. 1.0) then - Fng = EXP(-0.4*(Q1-1.0)) - elseif (Q1 .ge. -2.5 .and. Q1 .lt. -1.7) then - Fng = 3.0 + EXP(-3.8*(Q1+1.7)) - else - Fng = min(23.9 + EXP(-1.6*(Q1+2.5)), 60.) - endif - - !link the buoyancy flux function to active clouds only (c*Aup): - vt(k) = qww - (1.5*Aup)*beta*bb*Fng - 1. - vq(k) = alpha + (1.5*Aup)*beta*a*Fng - tv0 + !if ((landsea-1.5).GE.0) then ! WATER + Q1=max(Q1,-2.25) + !else + ! Q1=max(Q1,-2.0) + !endif + + if (Q1 .ge. 1.0) then + Fng = 1.0 + elseif (Q1 .ge. -1.7 .and. Q1 .lt. 1.0) then + Fng = EXP(-0.4*(Q1-1.0)) + elseif (Q1 .ge. -2.5 .and. Q1 .lt. -1.7) then + Fng = 3.0 + EXP(-3.8*(Q1+1.7)) + else + Fng = min(23.9 + EXP(-1.6*(Q1+2.5)), 60.) endif - endif + + !link the buoyancy flux function to active clouds only (c*Aup): + vt(k) = qww - (1.5*Aup)*beta*bb*Fng - 1. + vq(k) = alpha + (1.5*Aup)*beta*a*Fng - tv0 + endif !check for (qc in plume) .and. (cldfra_bl < threshold) enddo !k-loop ENDIF !end nup2 > 0 !modify output (negative: dry plume, positive: moist plume) - IF (ktop > 0) THEN + if (ktop > 0) then maxqc = maxval(edmf_qc(1:ktop)) - IF ( maxqc < 1.E-8) maxmf = -1.0*maxmf - ENDIF + if ( maxqc < 1.E-8) maxmf = -1.0*maxmf + endif ! -! debugging +! debugging ! -IF (edmf_w(1) > 4.0) THEN +if (edmf_w(1) > 4.0) then ! surface values print *,'flq:',flq,' fltv:',fltv2 print *,'pblh:',pblh,' wstar:',wstar @@ -6953,12 +6818,12 @@ subroutine condensation_edmf(QT,THL,P,zagl,THV,QC) ! ! zero or one condensation for edmf: calculates THV and QC ! -real,intent(in) :: QT,THL,P,zagl -real,intent(out) :: THV -real,intent(inout):: QC +real(kind_phys),intent(in) :: QT,THL,P,zagl +real(kind_phys),intent(out) :: THV +real(kind_phys),intent(inout):: QC integer :: niter,i -real :: diff,exn,t,th,qs,qcold +real(kind_phys):: diff,exn,t,th,qs,qcold ! constants used from module_model_constants.F ! p1000mb @@ -7000,7 +6865,7 @@ subroutine condensation_edmf(QT,THL,P,zagl,THV,QC) !THIS BASICALLY GIVE THE SAME RESULT AS THE PREVIOUS LINE !TH = THL + xlv/cp/EXN*QC - !THV= TH*(1. + 0.608*QT) + !THV= TH*(1. + p608*QT) !print *,'t,p,qt,qs,qc' !print *,t,p,qt,qs,qc @@ -7015,11 +6880,11 @@ subroutine condensation_edmf_r(QT,THL,P,zagl,THV,QC) ! zero or one condensation for edmf: calculates THL and QC ! similar to condensation_edmf but with different inputs ! -real,intent(in) :: QT,THV,P,zagl -real,intent(out) :: THL, QC +real(kind_phys),intent(in) :: QT,THV,P,zagl +real(kind_phys),intent(out) :: THL, QC integer :: niter,i -real :: diff,exn,t,th,qs,qcold +real(kind_phys):: diff,exn,t,th,qs,qcold ! number of iterations niter=50 @@ -7065,58 +6930,58 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & &rthraten ) INTEGER, INTENT(IN) :: KTS,KTE,KPBL - REAL,DIMENSION(KTS:KTE), INTENT(IN) :: U,V,TH,THL,TK,QT,QV,QC,& + real(kind_phys),DIMENSION(KTS:KTE), INTENT(IN) :: U,V,TH,THL,TK,QT,QV,QC,& THV,P,rho,exner,dz - REAL(kind=kind_phys),DIMENSION(KTS:KTE), INTENT(IN) :: rthraten + real(kind_phys),DIMENSION(KTS:KTE), INTENT(IN) :: rthraten ! zw .. heights of the downdraft levels (edges of boxes) - REAL,DIMENSION(KTS:KTE+1), INTENT(IN) :: ZW - REAL, INTENT(IN) :: WTHL,WQT - REAL(kind=kind_phys), INTENT(IN) :: dt,ust,pblh + real(kind_phys),DIMENSION(KTS:KTE+1), INTENT(IN) :: ZW + real(kind_phys), INTENT(IN) :: WTHL,WQT + real(kind_phys), INTENT(IN) :: dt,ust,pblh ! outputs - downdraft properties - REAL,DIMENSION(KTS:KTE), INTENT(OUT) :: edmf_a_dd,edmf_w_dd, & + real(kind_phys),DIMENSION(KTS:KTE), INTENT(OUT) :: edmf_a_dd,edmf_w_dd, & & edmf_qt_dd,edmf_thl_dd, edmf_ent_dd,edmf_qc_dd ! outputs - variables needed for solver (sd_aw - sum ai*wi, sd_awphi - sum ai*wi*phii) - REAL,DIMENSION(KTS:KTE+1) :: sd_aw, sd_awthl, sd_awqt, sd_awu, & + real(kind_phys),DIMENSION(KTS:KTE+1) :: sd_aw, sd_awthl, sd_awqt, sd_awu, & sd_awv, sd_awqc, sd_awqv, sd_awqke, sd_aw2 - REAL,DIMENSION(KTS:KTE), INTENT(IN) :: qc_bl1d, cldfra_bl1d + real(kind_phys),DIMENSION(KTS:KTE), INTENT(IN) :: qc_bl1d, cldfra_bl1d INTEGER, PARAMETER :: NDOWN=5, debug_mf=0 !fixing number of plumes to 5 ! draw downdraft starting height randomly between cloud base and cloud top INTEGER, DIMENSION(1:NDOWN) :: DD_initK - REAL , DIMENSION(1:NDOWN) :: randNum + real(kind_phys) , DIMENSION(1:NDOWN) :: randNum ! downdraft properties - REAL,DIMENSION(KTS:KTE+1,1:NDOWN) :: DOWNW,DOWNTHL,DOWNQT,& + real(kind_phys),DIMENSION(KTS:KTE+1,1:NDOWN) :: DOWNW,DOWNTHL,DOWNQT,& DOWNQC,DOWNA,DOWNU,DOWNV,DOWNTHV ! entrainment variables - REAl,DIMENSION(KTS+1:KTE+1,1:NDOWN) :: ENT,ENTf + Real(Kind_phys),DIMENSION(KTS+1:KTE+1,1:NDOWN) :: ENT,ENTf INTEGER,DIMENSION(KTS+1:KTE+1,1:NDOWN) :: ENTi ! internal variables INTEGER :: K,I,ki, kminrad, qlTop, p700_ind, qlBase - REAL :: wthv,wstar,qstar,thstar,sigmaW,sigmaQT,sigmaTH,z0, & + real(kind_phys):: wthv,wstar,qstar,thstar,sigmaW,sigmaQT,sigmaTH,z0, & pwmin,pwmax,wmin,wmax,wlv,wtv,went,mindownw - REAL :: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,Wn2,Wn,THVk,Pk, & + real(kind_phys):: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,Wn2,Wn,THVk,Pk, & EntEXP,EntW, Beta_dm, EntExp_M, rho_int - REAL :: jump_thetav, jump_qt, jump_thetal, & + real(kind_phys):: jump_thetav, jump_qt, jump_thetal, & refTHL, refTHV, refQT ! DD specific internal variables - REAL :: minrad,zminrad, radflux, F0, wst_rad, wst_dd + real(kind_phys):: minrad,zminrad, radflux, F0, wst_rad, wst_dd logical :: cloudflg - REAL :: sigq,xl,rsl,cpm,a,mf_cf,diffqt,& + real(kind_phys):: sigq,xl,rsl,cpm,a,mf_cf,diffqt,& Fng,qww,alpha,beta,bb,f,pt,t,q2p,b9,satvp,rhgrid ! w parameters - REAL,PARAMETER :: & + real(kind_phys),PARAMETER :: & &Wa=1., & &Wb=1.5,& &Z00=100.,& &BCOEFF=0.2 ! entrainment parameters - REAL,PARAMETER :: & + real(kind_phys),PARAMETER :: & & L0=80,& & ENT0=0.2 @@ -7178,7 +7043,7 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & do i=1,NDOWN ! downdraft starts somewhere between cloud base to cloud top ! the probability is equally distributed - DD_initK(i) = qlTop ! nint(randNum(i)*REAL(qlTop-qlBase)) + qlBase + DD_initK(i) = qlTop ! nint(randNum(i)*real(qlTop-qlBase)) + qlBase enddo ! LOOP RADFLUX @@ -7248,13 +7113,13 @@ SUBROUTINE DDMF_JPL(kts,kte,dt,zw,dz,p, & do I=1,NDOWN !downdraft now starts at different height ki = DD_initK(I) - wlv=wmin+(wmax-wmin)/REAL(NDOWN)*(i-1) - wtv=wmin+(wmax-wmin)/REAL(NDOWN)*i + wlv=wmin+(wmax-wmin)/real(NDOWN)*(i-1) + wtv=wmin+(wmax-wmin)/real(NDOWN)*i !DOWNW(ki,I)=0.5*(wlv+wtv) DOWNW(ki,I)=wlv !DOWNA(ki,I)=0.5*ERF(wtv/(sqrt(2.)*sigmaW))-0.5*ERF(wlv/(sqrt(2.)*sigmaW)) - DOWNA(ki,I)=.1/REAL(NDOWN) + DOWNA(ki,I)=.1/real(NDOWN) DOWNU(ki,I)=(u(ki-1)*DZ(ki) + u(ki)*DZ(ki-1)) /(DZ(ki)+DZ(ki-1)) DOWNV(ki,I)=(v(ki-1)*DZ(ki) + v(ki)*DZ(ki-1)) /(DZ(ki)+DZ(ki-1)) @@ -7424,9 +7289,9 @@ SUBROUTINE SCALE_AWARE(dx,PBL1,Psig_bl,Psig_shcu) ! Psig_bl tapers local mixing ! Psig_shcu tapers nonlocal mixing - REAL(kind=kind_phys), INTENT(IN) :: dx,pbl1 - REAL, INTENT(OUT) :: Psig_bl,Psig_shcu - REAL :: dxdh + real(kind_phys), INTENT(IN) :: dx,pbl1 + real(kind_phys), INTENT(OUT) :: Psig_bl,Psig_shcu + real(kind_phys) :: dxdh Psig_bl=1.0 Psig_shcu=1.0 @@ -7498,22 +7363,42 @@ FUNCTION esat_blend(t) IMPLICIT NONE - REAL, INTENT(IN):: t - REAL :: esat_blend,XC,ESL,ESI,chi - - XC=MAX(-80.,t - t0c) !note t0c = 273.15, tice is set in module mynn_common - -! For 253 < t < 273.16 K, the vapor pressures are "blended" as a function of temperature, -! using the approach of Chaboureau and Bechtold (2002), JAS, p. 2363. The resulting + real(kind_phys), INTENT(IN):: t + real(kind_phys):: esat_blend,XC,ESL,ESI,chi + !liquid + real(kind_phys), PARAMETER:: J0= .611583699E03 + real(kind_phys), PARAMETER:: J1= .444606896E02 + real(kind_phys), PARAMETER:: J2= .143177157E01 + real(kind_phys), PARAMETER:: J3= .264224321E-1 + real(kind_phys), PARAMETER:: J4= .299291081E-3 + real(kind_phys), PARAMETER:: J5= .203154182E-5 + real(kind_phys), PARAMETER:: J6= .702620698E-8 + real(kind_phys), PARAMETER:: J7= .379534310E-11 + real(kind_phys), PARAMETER:: J8=-.321582393E-13 + !ice + real(kind_phys), PARAMETER:: K0= .609868993E03 + real(kind_phys), PARAMETER:: K1= .499320233E02 + real(kind_phys), PARAMETER:: K2= .184672631E01 + real(kind_phys), PARAMETER:: K3= .402737184E-1 + real(kind_phys), PARAMETER:: K4= .565392987E-3 + real(kind_phys), PARAMETER:: K5= .521693933E-5 + real(kind_phys), PARAMETER:: K6= .307839583E-7 + real(kind_phys), PARAMETER:: K7= .105785160E-9 + real(kind_phys), PARAMETER:: K8= .161444444E-12 + + XC=MAX(-80.,t - t0c) !note t0c = 273.15, tice is set in module mynn_common to 240 + +! For 240 < t < 268.16 K, the vapor pressures are "blended" as a function of temperature, +! using the approach similar to Chaboureau and Bechtold (2002), JAS, p. 2363. The resulting ! values are returned from the function. - IF (t .GE. t0c) THEN + IF (t .GE. (t0c-6.)) THEN esat_blend = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) ELSE IF (t .LE. tice) THEN esat_blend = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) ELSE - ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) - ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) - chi = (t0c - t)/(t0c - tice) + ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) + ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) + chi = ((t0c-6.) - t)/((t0c-6.) - tice) esat_blend = (1.-chi)*ESL + chi*ESI END IF @@ -7523,39 +7408,54 @@ END FUNCTION esat_blend !>\ingroup gsd_mynn_edmf !! This function extends function "esat" and returns a "blended" -!! saturation mixing ratio. +!! saturation mixing ratio. Tice currently set to 240 K, t0c = 273.15 K. !!\author JAYMES - FUNCTION qsat_blend(t, P, waterice) + FUNCTION qsat_blend(t, P) IMPLICIT NONE - REAL, INTENT(IN):: t, P - CHARACTER(LEN=1), OPTIONAL, INTENT(IN) :: waterice - CHARACTER(LEN=1) :: wrt - REAL :: qsat_blend,XC,ESL,ESI,RSLF,RSIF,chi - - IF ( .NOT. PRESENT(waterice) ) THEN - wrt = 'b' - ELSE - wrt = waterice - ENDIF + real(kind_phys), INTENT(IN):: t, P + real(kind_phys):: qsat_blend,XC,ESL,ESI,RSLF,RSIF,chi + !liquid + real(kind_phys), PARAMETER:: J0= .611583699E03 + real(kind_phys), PARAMETER:: J1= .444606896E02 + real(kind_phys), PARAMETER:: J2= .143177157E01 + real(kind_phys), PARAMETER:: J3= .264224321E-1 + real(kind_phys), PARAMETER:: J4= .299291081E-3 + real(kind_phys), PARAMETER:: J5= .203154182E-5 + real(kind_phys), PARAMETER:: J6= .702620698E-8 + real(kind_phys), PARAMETER:: J7= .379534310E-11 + real(kind_phys), PARAMETER:: J8=-.321582393E-13 + !ice + real(kind_phys), PARAMETER:: K0= .609868993E03 + real(kind_phys), PARAMETER:: K1= .499320233E02 + real(kind_phys), PARAMETER:: K2= .184672631E01 + real(kind_phys), PARAMETER:: K3= .402737184E-1 + real(kind_phys), PARAMETER:: K4= .565392987E-3 + real(kind_phys), PARAMETER:: K5= .521693933E-5 + real(kind_phys), PARAMETER:: K6= .307839583E-7 + real(kind_phys), PARAMETER:: K7= .105785160E-9 + real(kind_phys), PARAMETER:: K8= .161444444E-12 XC=MAX(-80.,t - t0c) - IF ((t .GE. t0c) .OR. (wrt .EQ. 'w')) THEN - ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) + IF (t .GE. (t0c-6.)) THEN + ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) + ESL = min(ESL, P*0.15) ! Even with P=1050mb and T=55C, the sat. vap. pres only contributes to ~15% of total pres. qsat_blend = 0.622*ESL/max(P-ESL, 1e-5) -! ELSE IF (t .LE. 253.) THEN ELSE IF (t .LE. tice) THEN ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) + ESI = min(ESI, P*0.15) qsat_blend = 0.622*ESI/max(P-ESI, 1e-5) ELSE ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) + ESL = min(ESL, P*0.15) ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) + ESI = min(ESI, P*0.15) RSLF = 0.622*ESL/max(P-ESL, 1e-5) RSIF = 0.622*ESI/max(P-ESI, 1e-5) -! chi = (273.16-t)/20.16 - chi = (t0c - t)/(t0c - tice) +! chi = (268.16-t)/(268.16-240.) + chi = ((t0c-6.) - t)/((t0c-6.) - tice) qsat_blend = (1.-chi)*RSLF + chi*RSIF END IF @@ -7572,8 +7472,8 @@ FUNCTION xl_blend(t) IMPLICIT NONE - REAL, INTENT(IN):: t - REAL :: xl_blend,xlvt,xlst,chi + real(kind_phys), INTENT(IN):: t + real(kind_phys):: xl_blend,xlvt,xlst,chi !note: t0c = 273.15, tice is set in mynn_common IF (t .GE. t0c) THEN @@ -7583,7 +7483,7 @@ FUNCTION xl_blend(t) ELSE xlvt = xlv + (cpv-cliq)*(t-t0c) !vaporization/condensation xlst = xls + (cpv-cice)*(t-t0c) !sublimation/deposition -! chi = (273.16-t)/20.16 +! chi = (273.16-t)/(273.16-240.) chi = (t0c - t)/(t0c - tice) xl_blend = (1.-chi)*xlvt + chi*xlst !blended END IF @@ -7601,12 +7501,12 @@ FUNCTION phim(zet) ! stable conditions [z/L ~ O(10)]. IMPLICIT NONE - REAL, INTENT(IN):: zet - REAL :: dummy_0,dummy_1,dummy_11,dummy_2,dummy_22,dummy_3,dummy_33,dummy_4,dummy_44,dummy_psi - REAL, PARAMETER :: am_st=6.1, bm_st=2.5, rbm_st=1./bm_st - REAL, PARAMETER :: ah_st=5.3, bh_st=1.1, rbh_st=1./bh_st - REAL, PARAMETER :: am_unst=10., ah_unst=34. - REAL :: phi_m,phim + real(kind_phys), INTENT(IN):: zet + real(kind_phys):: dummy_0,dummy_1,dummy_11,dummy_2,dummy_22,dummy_3,dummy_33,dummy_4,dummy_44,dummy_psi + real(kind_phys), PARAMETER :: am_st=6.1, bm_st=2.5, rbm_st=1./bm_st + real(kind_phys), PARAMETER :: ah_st=5.3, bh_st=1.1, rbh_st=1./bh_st + real(kind_phys), PARAMETER :: am_unst=10., ah_unst=34. + real(kind_phys):: phi_m,phim if ( zet >= 0.0 ) then dummy_0=1+zet**bm_st @@ -7653,12 +7553,12 @@ FUNCTION phih(zet) ! stable conditions [z/L ~ O(10)]. IMPLICIT NONE - REAL, INTENT(IN):: zet - REAL :: dummy_0,dummy_1,dummy_11,dummy_2,dummy_22,dummy_3,dummy_33,dummy_4,dummy_44,dummy_psi - REAL, PARAMETER :: am_st=6.1, bm_st=2.5, rbm_st=1./bm_st - REAL, PARAMETER :: ah_st=5.3, bh_st=1.1, rbh_st=1./bh_st - REAL, PARAMETER :: am_unst=10., ah_unst=34. - REAL :: phh,phih + real(kind_phys), INTENT(IN):: zet + real(kind_phys):: dummy_0,dummy_1,dummy_11,dummy_2,dummy_22,dummy_3,dummy_33,dummy_4,dummy_44,dummy_psi + real(kind_phys), PARAMETER :: am_st=6.1, bm_st=2.5, rbm_st=1./bm_st + real(kind_phys), PARAMETER :: ah_st=5.3, bh_st=1.1, rbh_st=1./bh_st + real(kind_phys), PARAMETER :: am_unst=10., ah_unst=34. + real(kind_phys):: phh,phih if ( zet >= 0.0 ) then dummy_0=1+zet**bh_st @@ -7698,23 +7598,23 @@ SUBROUTINE topdown_cloudrad(kts,kte,dz1,zw,xland,kpbl,PBLH, & &maxKHtopdown,KHtopdown,TKEprodTD ) !input - integer, intent(in) :: kte,kts - real, dimension(kts:kte), intent(in) :: dz1,sqc,sqi,sqw,& + integer, intent(in) :: kte,kts + real(kind_phys), dimension(kts:kte), intent(in) :: dz1,sqc,sqi,sqw,& thl,th1,ex1,p1,rho1,thetav,cldfra_bl1D - real(kind=kind_phys), dimension(kts:kte), intent(in) :: rthraten - real, dimension(kts:kte+1), intent(in) :: zw - real(kind=kind_phys), intent(in) :: pblh - real, intent(in) :: xland - integer,intent(in) :: kpbl + real(kind_phys), dimension(kts:kte), intent(in) :: rthraten + real(kind_phys), dimension(kts:kte+1), intent(in) :: zw + real(kind_phys), intent(in) :: pblh + real(kind_phys), intent(in) :: xland + integer , intent(in) :: kpbl !output - real, intent(out) :: maxKHtopdown - real, dimension(kts:kte), intent(out) :: KHtopdown,TKEprodTD + real(kind_phys), intent(out) :: maxKHtopdown + real(kind_phys), dimension(kts:kte), intent(out) :: KHtopdown,TKEprodTD !local - real, dimension(kts:kte) :: zfac,wscalek2,zfacent - real :: bfx0,sflux,wm2,wm3,h1,h2,bfxpbl,dthvx,tmp1 - real :: temps,templ,zl1,wstar3_2 - real :: ent_eff,radsum,radflux,we,rcldb,rvls,minrad,zminrad - real, parameter :: pfac =2.0, zfmin = 0.01, phifac=8.0 + real(kind_phys), dimension(kts:kte) :: zfac,wscalek2,zfacent + real(kind_phys) :: bfx0,sflux,wm2,wm3,h1,h2,bfxpbl,dthvx,tmp1 + real(kind_phys) :: temps,templ,zl1,wstar3_2 + real(kind_phys) :: ent_eff,radsum,radflux,we,rcldb,rvls,minrad,zminrad + real(kind_phys), parameter :: pfac =2.0, zfmin = 0.01, phifac=8.0 integer :: k,kk,kminrad logical :: cloudflg diff --git a/physics/mynnedmf_wrapper.F90 b/physics/mynnedmf_wrapper.F90 index 8ac6378bd..74cf8fa30 100644 --- a/physics/mynnedmf_wrapper.F90 +++ b/physics/mynnedmf_wrapper.F90 @@ -2,7 +2,6 @@ !! This file contains all of the code related to running the MYNN !! eddy-diffusivity mass-flux scheme. -!>\ingroup gsd_mynn_edmf !> The following references best describe the code within !! Olson et al. (2019, NOAA Technical Memorandum) !! Nakanishi and Niino (2009) \cite NAKANISHI_2009 @@ -18,33 +17,32 @@ subroutine mynnedmf_wrapper_init ( & & con_cpv, con_cliq, con_cice, con_rcp, & & con_XLV, con_XLF, con_p608, con_ep2, & & con_karman, con_t0c, & - & do_mynnedmf, lheatstrg, & + & do_mynnedmf, & & errmsg, errflg ) use machine, only : kind_phys use bl_mynn_common implicit none - - logical, intent(in) :: do_mynnedmf - logical, intent(in) :: lheatstrg - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - real(kind=kind_phys),intent(in) :: con_xlv - real(kind=kind_phys),intent(in) :: con_xlf - real(kind=kind_phys),intent(in) :: con_rv - real(kind=kind_phys),intent(in) :: con_rd - real(kind=kind_phys),intent(in) :: con_ep2 - real(kind=kind_phys),intent(in) :: con_grav - real(kind=kind_phys),intent(in) :: con_cp - real(kind=kind_phys),intent(in) :: con_cpv - real(kind=kind_phys),intent(in) :: con_rcp - real(kind=kind_phys),intent(in) :: con_p608 - real(kind=kind_phys),intent(in) :: con_cliq - real(kind=kind_phys),intent(in) :: con_cice - real(kind=kind_phys),intent(in) :: con_karman - real(kind=kind_phys),intent(in) :: con_t0c + + logical, intent(in) :: do_mynnedmf + character(len=*),intent(out):: errmsg + integer, intent(out) :: errflg + + real(kind_phys),intent(in) :: con_xlv + real(kind_phys),intent(in) :: con_xlf + real(kind_phys),intent(in) :: con_rv + real(kind_phys),intent(in) :: con_rd + real(kind_phys),intent(in) :: con_ep2 + real(kind_phys),intent(in) :: con_grav + real(kind_phys),intent(in) :: con_cp + real(kind_phys),intent(in) :: con_cpv + real(kind_phys),intent(in) :: con_rcp + real(kind_phys),intent(in) :: con_p608 + real(kind_phys),intent(in) :: con_cliq + real(kind_phys),intent(in) :: con_cice + real(kind_phys),intent(in) :: con_karman + real(kind_phys),intent(in) :: con_t0c ! Initialize CCPP error handling variables errmsg = '' @@ -85,10 +83,8 @@ subroutine mynnedmf_wrapper_init ( & end subroutine mynnedmf_wrapper_init - subroutine mynnedmf_wrapper_finalize () - end subroutine mynnedmf_wrapper_finalize - -! \brief This scheme (1) performs pre-mynnedmf work, (2) runs the mynnedmf, and (3) performs post-mynnedmf work +!>\defgroup gp_mynnedmf MYNN-EDMF PBL and Shallow Convection Module +!> This scheme (1) performs pre-mynnedmf work, (2) runs the mynnedmf, and (3) performs post-mynnedmf work !> \section arg_table_mynnedmf_wrapper_run Argument Table !! \htmlinclude mynnedmf_wrapper_run.html !! @@ -101,14 +97,15 @@ SUBROUTINE mynnedmf_wrapper_run( & & phii,u,v,omega,t3d, & & qgrs_water_vapor, & & qgrs_liquid_cloud, & - & qgrs_ice_cloud, & + & qgrs_ice, & + & qgrs_snow, & & qgrs_cloud_droplet_num_conc, & & qgrs_cloud_ice_num_conc, & & qgrs_ozone, & & qgrs_water_aer_num_conc, & & qgrs_ice_aer_num_conc, & & qgrs_cccn, & - & prsl,exner, & + & prsl,prsi,exner, & & slmsk,tsurf,qsfc,ps, & & ust,ch,hflx,qflx,wspd,rb, & & dtsfc1,dqsfc1, & @@ -137,16 +134,18 @@ SUBROUTINE mynnedmf_wrapper_run( & & nupdraft,maxMF,ktop_plume, & & dudt, dvdt, dtdt, & & dqdt_water_vapor, dqdt_liquid_cloud, & ! <=== ntqv, ntcw - & dqdt_ice_cloud, dqdt_ozone, & ! <=== ntiw, ntoz + & dqdt_ice, dqdt_snow, & ! <=== ntiw, ntsw + & dqdt_ozone, & ! <=== ntoz & dqdt_cloud_droplet_num_conc, dqdt_ice_num_conc, & ! <=== ntlnc, ntinc & dqdt_water_aer_num_conc, dqdt_ice_aer_num_conc,& ! <=== ntwa, ntia & dqdt_cccn, & ! <=== ntccn & flag_for_pbl_generic_tend, & & dtend, dtidx, index_of_temperature, & & index_of_x_wind, index_of_y_wind, ntke, & - & ntqv, ntcw, ntiw, ntoz, ntlnc, ntinc, ntwa, ntia, & + & ntqv, ntcw, ntiw, ntsw, & + & ntoz, ntlnc, ntinc, ntwa, ntia, & & index_of_process_pbl, htrsw, htrlw, xmu, & - & bl_mynn_tkebudget, bl_mynn_tkeadvect, & + & tke_budget, bl_mynn_tkeadvect, & & bl_mynn_cloudpdf, bl_mynn_mixlength, & & bl_mynn_edmf, & & bl_mynn_edmf_mom, bl_mynn_edmf_tke, & @@ -155,10 +154,12 @@ SUBROUTINE mynnedmf_wrapper_run( & & icloud_bl, do_mynnsfclay, & & imp_physics, imp_physics_gfdl, & & imp_physics_thompson, imp_physics_wsm6, & - & rrfs_sd, chem3d, frp, mix_chem, enh_mix, & + & imp_physics_fa, & + & chem3d, frp, mix_chem, rrfs_sd, enh_mix, & & nchem, ndvel, vdep, smoke_dbg, & & imp_physics_nssl, nssl_ccn_on, & - & ltaerosol, spp_wts_pbl, spp_pbl, lprnt, huge, errmsg, errflg ) + & ltaerosol, mraerosol, spp_wts_pbl, spp_pbl, & + & lprnt, huge, errmsg, errflg ) ! should be moved to inside the mynn: use machine, only: kind_phys @@ -170,7 +171,7 @@ SUBROUTINE mynnedmf_wrapper_run( & implicit none !------------------------------------------------------------------- - real(kind=kind_phys) :: huge + real(kind_phys) :: huge character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -185,8 +186,8 @@ SUBROUTINE mynnedmf_wrapper_run( & ! NAMELIST OPTIONS (INPUT): logical, intent(in) :: & & bl_mynn_tkeadvect, & - & bl_mynn_tkebudget, & & ltaerosol, & + & mraerosol, & & lprnt, & & do_mynnsfclay, & & flag_for_pbl_generic_tend, & @@ -203,100 +204,100 @@ SUBROUTINE mynnedmf_wrapper_run( & & bl_mynn_output, & & imp_physics, imp_physics_wsm6, & & imp_physics_thompson, imp_physics_gfdl, & - & imp_physics_nssl, & - & spp_pbl - real(kind=kind_phys), intent(in) :: & + & imp_physics_nssl, imp_physics_fa, & + & spp_pbl, & + & tke_budget + real(kind_phys), intent(in) :: & & bl_mynn_closure !TENDENCY DIAGNOSTICS - real(kind=kind_phys), intent(inout), optional :: dtend(:,:,:) + real(kind_phys), intent(inout), optional :: dtend(:,:,:) integer, intent(in) :: dtidx(:,:) integer, intent(in) :: index_of_temperature, index_of_x_wind integer, intent(in) :: index_of_y_wind, index_of_process_pbl - integer, intent(in) :: ntoz, ntqv, ntcw, ntiw, ntlnc + integer, intent(in) :: ntoz, ntqv, ntcw, ntiw, ntsw, ntlnc integer, intent(in) :: ntinc, ntwa, ntia, ntke !MISC CONFIGURATION OPTIONS - INTEGER, PARAMETER :: & + INTEGER, PARAMETER :: & & bl_mynn_mixscalars=1 - LOGICAL :: & - & FLAG_QI, FLAG_QNI, FLAG_QC, FLAG_QNC, & - & FLAG_QNWFA, FLAG_QNIFA, FLAG_OZONE + LOGICAL :: & + & FLAG_QI, FLAG_QNI, FLAG_QC, FLAG_QS, FLAG_QNC, & + & FLAG_QNWFA, FLAG_QNIFA, FLAG_QNBCA, FLAG_OZONE ! Define locally until needed from CCPP LOGICAL, PARAMETER :: cycling = .false. - INTEGER, PARAMETER :: param_first_scalar = 1 - INTEGER :: & - & p_qc, p_qr, p_qi, p_qs, p_qg, p_qnc, p_qni !MYNN-1D - REAL(kind=kind_phys), intent(in) :: delt, dtf + REAL(kind_phys), intent(in) :: delt, dtf INTEGER, intent(in) :: im, levs LOGICAL, intent(in) :: flag_init, flag_restart INTEGER :: initflag, k, i - INTEGER :: IDS,IDE,JDS,JDE,KDS,KDE, & - & IMS,IME,JMS,JME,KMS,KME, & + INTEGER :: IDS,IDE,JDS,JDE,KDS,KDE, & + & IMS,IME,JMS,JME,KMS,KME, & & ITS,ITE,JTS,JTE,KTS,KTE - REAL(kind=kind_phys) :: tem + REAL(kind_phys) :: tem !MYNN-3D - real(kind=kind_phys), dimension(:,:), intent(in) :: phii - real(kind=kind_phys), dimension(:,:), intent(inout) :: & + real(kind_phys), dimension(:,:), intent(in) :: phii + real(kind_phys), dimension(:,:), intent(inout) :: & & dtdt, dudt, dvdt, & - & dqdt_water_vapor, dqdt_liquid_cloud, dqdt_ice_cloud, & + & dqdt_water_vapor, dqdt_liquid_cloud, dqdt_ice, & + & dqdt_snow, & & dqdt_cloud_droplet_num_conc, dqdt_ice_num_conc, & & dqdt_ozone, dqdt_water_aer_num_conc, dqdt_ice_aer_num_conc - real(kind=kind_phys), dimension(:,:), intent(inout) ::dqdt_cccn - real(kind=kind_phys), dimension(:,:), intent(inout) :: & + real(kind_phys), dimension(:,:), intent(inout) ::dqdt_cccn + real(kind_phys), dimension(:,:), intent(inout) :: & & qke, qke_adv, EL_PBL, Sh3D, Sm3D, & & qc_bl, qi_bl, cldfra_bl !These 10 arrays are only allocated when bl_mynn_output > 0 - real(kind=kind_phys), dimension(:,:), intent(inout) :: & + real(kind_phys), dimension(:,:), intent(inout) :: & & edmf_a,edmf_w,edmf_qt, & & edmf_thl,edmf_ent,edmf_qc, & & sub_thl,sub_sqv,det_thl,det_sqv - real(kind=kind_phys), dimension(:,:), intent(inout) :: & + real(kind_phys), dimension(:,:), intent(inout) :: & & dqke,qWT,qSHEAR,qBUOY,qDISS - real(kind=kind_phys), dimension(:,:), intent(inout) :: & - & t3d,qgrs_water_vapor,qgrs_liquid_cloud,qgrs_ice_cloud - real(kind=kind_phys), dimension(:,:), intent(in) :: & + real(kind_phys), dimension(:,:), intent(inout) :: & + & t3d,qgrs_water_vapor,qgrs_liquid_cloud,qgrs_ice, & + & qgrs_snow + real(kind_phys), dimension(:,:), intent(in) :: & & u,v,omega, & - & exner,prsl, & + & exner,prsl,prsi, & & qgrs_cloud_droplet_num_conc, & & qgrs_cloud_ice_num_conc, & & qgrs_ozone, & & qgrs_water_aer_num_conc, & & qgrs_ice_aer_num_conc - real(kind=kind_phys), dimension(:,:), intent(in) ::qgrs_cccn - real(kind=kind_phys), dimension(:,:), intent(out) :: & + real(kind_phys), dimension(:,:), intent(in) ::qgrs_cccn + real(kind_phys), dimension(:,:), intent(out) :: & & Tsq, Qsq, Cov, exch_h, exch_m - real(kind=kind_phys), dimension(:), intent(in) :: xmu - real(kind=kind_phys), dimension(:,:), intent(in) :: htrsw, htrlw + real(kind_phys), dimension(:), intent(in) :: xmu + real(kind_phys), dimension(:,:), intent(in) :: htrsw, htrlw ! spp_wts_pbl only allocated if spp_pbl == 1 - real(kind=kind_phys), dimension(:,:), intent(in) :: spp_wts_pbl + real(kind_phys), dimension(:,:), intent(in) :: spp_wts_pbl !LOCAL - real(kind=kind_phys), dimension(im,levs) :: & - & sqv,sqc,sqi,qnc,qni,ozone,qnwfa,qnifa, & + real(kind_phys), dimension(im,levs) :: & + & sqv,sqc,sqi,sqs,qnc,qni,ozone,qnwfa,qnifa,qnbca, & & dz, w, p, rho, th, qv, delp, & & RUBLTEN, RVBLTEN, RTHBLTEN, RQVBLTEN, & - & RQCBLTEN, RQNCBLTEN, RQIBLTEN, RQNIBLTEN, & - & RQNWFABLTEN, RQNIFABLTEN - real(kind=kind_phys), allocatable :: old_ozone(:,:) + & RQCBLTEN, RQNCBLTEN, RQIBLTEN, RQNIBLTEN, RQSBLTEN, & + & RQNWFABLTEN, RQNIFABLTEN, RQNBCABLTEN + real(kind_phys), allocatable :: old_ozone(:,:) !smoke/chem arrays - real(kind=kind_phys), dimension(:), intent(inout) :: frp + real(kind_phys), dimension(:), intent(inout) :: frp logical, intent(in) :: mix_chem, enh_mix, rrfs_sd - real(kind=kind_phys), dimension(:,:,:), intent(inout) :: chem3d - real(kind=kind_phys), dimension(:,: ), intent(inout) :: vdep - real(kind=kind_phys), dimension(im) :: emis_ant_no + real(kind_phys), dimension(:,:,:), intent(inout) :: chem3d + real(kind_phys), dimension(:,: ), intent(inout) :: vdep + real(kind_phys), dimension(im) :: emis_ant_no !MYNN-2D - real(kind=kind_phys), dimension(:), intent(in) :: & + real(kind_phys), dimension(:), intent(in) :: & & dx,zorl,slmsk,tsurf,qsfc,ps, & & hflx,qflx,ust,wspd,rb,recmol - real(kind=kind_phys), dimension(:), intent(in) :: & + real(kind_phys), dimension(:), intent(in) :: & & dusfc_cice,dvsfc_cice,dtsfc_cice,dqsfc_cice, & & stress_wat,hflx_wat,qflx_wat, & & oceanfrac,fice @@ -304,26 +305,26 @@ SUBROUTINE mynnedmf_wrapper_run( & logical, dimension(:), intent(in) :: & & wet, dry, icy - real(kind=kind_phys), dimension(:), intent(inout) :: & + real(kind_phys), dimension(:), intent(inout) :: & & pblh,dusfc_diag,dvsfc_diag,dtsfc_diag,dqsfc_diag - real(kind=kind_phys), dimension(:), intent(out) :: & + real(kind_phys), dimension(:), intent(out) :: & & ch,dtsfc1,dqsfc1,dusfc1,dvsfc1, & & dtsfci_diag,dqsfci_diag,dusfci_diag,dvsfci_diag, & & maxMF integer, dimension(:), intent(inout) :: & & kpbl,nupdraft,ktop_plume - real(kind=kind_phys), dimension(:), intent(inout) :: & + real(kind_phys), dimension(:), intent(inout) :: & & dusfc_cpl,dvsfc_cpl,dtsfc_cpl,dqsfc_cpl - real(kind=kind_phys), dimension(:), intent(inout) :: & + real(kind_phys), dimension(:), intent(inout) :: & & dusfci_cpl,dvsfci_cpl,dtsfci_cpl,dqsfci_cpl !LOCAL - real, dimension(im) :: & - & hfx,qfx,rmol,xland,uoce,voce,vdfg,znt,ts + real(kind_phys), dimension(im) :: & + & hfx,qfx,rmol,xland,uoce,voce,znt,ts integer :: idtend - real, dimension(im) :: dusfci1,dvsfci1,dtsfci1,dqsfci1 - real(kind=kind_phys), allocatable :: save_qke_adv(:,:) + real(kind_phys), dimension(im) :: dusfci1,dvsfci1,dtsfci1,dqsfci1 + real(kind_phys), allocatable :: save_qke_adv(:,:) ! Initialize CCPP error handling variables errmsg = '' @@ -356,62 +357,33 @@ SUBROUTINE mynnedmf_wrapper_run( & !initialize arrays for test EMIS_ANT_NO = 0. - - ! Check incoming moist species to ensure non-negative values - ! First, create height (dz) and pressure differences (delp) - ! across model layers - do k=1,levs - do i=1,im - dz(i,k)=(phii(i,k+1) - phii(i,k))*g_inv - enddo - enddo - - do i=1,im - delp(i,1) = ps(i) - (prsl(i,2)*dz(i,1) + prsl(i,1)*dz(i,2))/(dz(i,1)+dz(i,2)) - do k=2,levs-1 - delp(i,k) = (prsl(i,k)*dz(i,k-1) + prsl(i,k-1)*dz(i,k))/(dz(i,k)+dz(i,k-1)) - & - (prsl(i,k+1)*dz(i,k) + prsl(i,k)*dz(i,k+1))/(dz(i,k)+dz(i,k+1)) - enddo - delp(i,levs) = delp(i,levs-1) - enddo - - do i=1,im - call moisture_check2(levs, delt, & - delp(i,:), exner(i,:), & - qgrs_water_vapor(i,:), & - qgrs_liquid_cloud(i,:),& - qgrs_ice_cloud(i,:), & - t3d(i,:) ) - enddo + vdep = 0. FLAG_OZONE = ntoz>0 ! Assign variables for each microphysics scheme - if (imp_physics == imp_physics_wsm6) then - ! WSM6 + if (imp_physics == imp_physics_wsm6 .or. imp_physics == imp_physics_fa) then + ! WSM6 or Ferrier-Aligo FLAG_QI = .true. FLAG_QNI= .false. FLAG_QC = .true. FLAG_QNC= .false. + FLAG_QS = .false. FLAG_QNWFA= .false. FLAG_QNIFA= .false. - p_qc = 2 - p_qr = 0 - p_qi = 2 - p_qs = 0 - p_qg = 0 - p_qnc= 0 - p_qni= 0 + FLAG_QNBCA= .false. do k=1,levs do i=1,im sqv(i,k) = qgrs_water_vapor(i,k) sqc(i,k) = qgrs_liquid_cloud(i,k) - sqi(i,k) = qgrs_ice_cloud(i,k) + sqi(i,k) = qgrs_ice(i,k) + sqs(i,k) = 0. ozone(i,k) = qgrs_ozone(i,k) qnc(i,k) = 0. qni(i,k) = 0. qnwfa(i,k) = 0. qnifa(i,k) = 0. + qnbca(i,k) = 0. enddo enddo elseif (imp_physics == imp_physics_nssl ) then @@ -420,21 +392,16 @@ SUBROUTINE mynnedmf_wrapper_run( & FLAG_QNI= .true. FLAG_QC = .true. FLAG_QNC= .true. + FLAG_QS = .false. FLAG_QNWFA= nssl_ccn_on ! ERM: Perhaps could use this field for CCN field? FLAG_QNIFA= .false. - ! p_q vars not used? - p_qc = 2 - p_qr = 0 - p_qi = 2 - p_qs = 0 - p_qg = 0 - p_qnc= 0 - p_qni= 0 + FLAG_QNBCA= .false. do k=1,levs do i=1,im sqv(i,k) = qgrs_water_vapor(i,k) sqc(i,k) = qgrs_liquid_cloud(i,k) - sqi(i,k) = qgrs_ice_cloud(i,k) + sqi(i,k) = qgrs_ice(i,k) + sqs(i,k) = 0. ozone(i,k) = qgrs_ozone(i,k) qnc(i,k) = qgrs_cloud_droplet_num_conc(i,k) qni(i,k) = qgrs_cloud_ice_num_conc(i,k) @@ -443,6 +410,7 @@ SUBROUTINE mynnedmf_wrapper_run( & qnwfa(i,k) = qgrs_cccn(i,k) ENDIF qnifa(i,k) = 0. + qnbca(i,k) = 0. enddo enddo elseif (imp_physics == imp_physics_thompson) then @@ -451,52 +419,69 @@ SUBROUTINE mynnedmf_wrapper_run( & FLAG_QI = .true. FLAG_QNI= .true. FLAG_QC = .true. + FLAG_QS = .true. FLAG_QNC= .true. FLAG_QNWFA= .true. FLAG_QNIFA= .true. - p_qc = 2 - p_qr = 0 - p_qi = 2 - p_qs = 0 - p_qg = 0 - p_qnc= 0 - p_qni= 0 + FLAG_QNBCA= .false. do k=1,levs do i=1,im sqv(i,k) = qgrs_water_vapor(i,k) sqc(i,k) = qgrs_liquid_cloud(i,k) - sqi(i,k) = qgrs_ice_cloud(i,k) + sqi(i,k) = qgrs_ice(i,k) + sqs(i,k) = qgrs_snow(i,k) qnc(i,k) = qgrs_cloud_droplet_num_conc(i,k) qni(i,k) = qgrs_cloud_ice_num_conc(i,k) ozone(i,k) = qgrs_ozone(i,k) qnwfa(i,k) = qgrs_water_aer_num_conc(i,k) qnifa(i,k) = qgrs_ice_aer_num_conc(i,k) + qnbca(i,k) = 0. + enddo + enddo + else if(mraerosol) then + FLAG_QI = .true. + FLAG_QNI= .true. + FLAG_QC = .true. + FLAG_QS = .true. + FLAG_QNC= .true. + FLAG_QNWFA= .false. + FLAG_QNIFA= .false. + FLAG_QNBCA= .false. + do k=1,levs + do i=1,im + sqv(i,k) = qgrs_water_vapor(i,k) + sqc(i,k) = qgrs_liquid_cloud(i,k) + sqi(i,k) = qgrs_ice(i,k) + sqs(i,k) = qgrs_snow(i,k) + qnc(i,k) = qgrs_cloud_droplet_num_conc(i,k) + qni(i,k) = qgrs_cloud_ice_num_conc(i,k) + ozone(i,k) = qgrs_ozone(i,k) + qnwfa(i,k) = 0. + qnifa(i,k) = 0. + qnbca(i,k) = 0. enddo enddo else FLAG_QI = .true. FLAG_QNI= .true. FLAG_QC = .true. + FLAG_QS = .true. FLAG_QNC= .false. FLAG_QNWFA= .false. FLAG_QNIFA= .false. - p_qc = 2 - p_qr = 0 - p_qi = 2 - p_qs = 0 - p_qg = 0 - p_qnc= 0 - p_qni= 0 + FLAG_QNBCA= .false. do k=1,levs do i=1,im sqv(i,k) = qgrs_water_vapor(i,k) sqc(i,k) = qgrs_liquid_cloud(i,k) - sqi(i,k) = qgrs_ice_cloud(i,k) + sqi(i,k) = qgrs_ice(i,k) + sqs(i,k) = qgrs_snow(i,k) qnc(i,k) = 0. qni(i,k) = qgrs_cloud_ice_num_conc(i,k) ozone(i,k) = qgrs_ozone(i,k) qnwfa(i,k) = 0. qnifa(i,k) = 0. + qnbca(i,k) = 0. enddo enddo endif @@ -506,24 +491,21 @@ SUBROUTINE mynnedmf_wrapper_run( & FLAG_QNI= .false. FLAG_QC = .true. FLAG_QNC= .false. + FLAG_QS = .false. FLAG_QNWFA= .false. FLAG_QNIFA= .false. - p_qc = 2 - p_qr = 0 - p_qi = 2 - p_qs = 0 - p_qg = 0 - p_qnc= 0 - p_qni= 0 + FLAG_QNBCA= .false. do k=1,levs do i=1,im sqv(i,k) = qgrs_water_vapor(i,k) sqc(i,k) = qgrs_liquid_cloud(i,k) - sqi(i,k) = qgrs_ice_cloud(i,k) + sqi(i,k) = qgrs_ice(i,k) qnc(i,k) = 0. qni(i,k) = 0. + sqs(i,k) = 0. qnwfa(i,k) = 0. qnifa(i,k) = 0. + qnbca(i,k) = 0. ozone(i,k) = qgrs_ozone(i,k) enddo enddo @@ -534,24 +516,21 @@ SUBROUTINE mynnedmf_wrapper_run( & FLAG_QNI= .false. FLAG_QC = .true. FLAG_QNC= .false. + FLAG_QS = .false. FLAG_QNWFA= .false. FLAG_QNIFA= .false. - p_qc = 2 - p_qr = 0 - p_qi = 0 - p_qs = 0 - p_qg = 0 - p_qnc= 0 - p_qni= 0 + FLAG_QNBCA= .false. do k=1,levs do i=1,im sqv(i,k) = qgrs_water_vapor(i,k) sqc(i,k) = qgrs_liquid_cloud(i,k) sqi(i,k) = 0. + sqs(i,k) = 0. qnc(i,k) = 0. qni(i,k) = 0. qnwfa(i,k) = 0. qnifa(i,k) = 0. + qnbca(i,k) = 0. ozone(i,k) = qgrs_ozone(i,k) enddo enddo @@ -560,17 +539,38 @@ SUBROUTINE mynnedmf_wrapper_run( & allocate(old_ozone(im,levs)) old_ozone = ozone endif - if (lprnt)write(0,*)"prepping MYNN-EDMF variables..." do k=1,levs do i=1,im - ! dz(i,k)=(phii(i,k+1) - phii(i,k))*g_inv th(i,k)=t3d(i,k)/exner(i,k) rho(i,k)=prsl(i,k)/(r_d*t3d(i,k)*(1.+p608*max(sqv(i,k),1e-8))) w(i,k) = -omega(i,k)/(rho(i,k)*grav) + enddo + enddo + + ! Check incoming moist species to ensure non-negative values + ! First, create height difference (dz) + do k=1,levs + do i=1,im + dz(i,k)=(phii(i,k+1) - phii(i,k))*g_inv enddo enddo + do i=1,im + do k=1,levs + delp(i,k) = prsi(i,k) - prsi(i,k+1) + enddo + enddo + + do i=1,im + call moisture_check2(levs, delt, & + delp(i,:), exner(i,:), & + sqv(i,:), sqc(i,:), & + sqi(i,:), sqs(i,:), & + t3d(i,:) ) + enddo + + !intialize more variables do i=1,im if (slmsk(i)==1. .or. slmsk(i)==2.) then !sea/land/ice mask (=0/1/2) in FV3 xland(i)=1.0 !but land/water = (1/2) in SFCLAY_mynn @@ -579,7 +579,6 @@ SUBROUTINE mynnedmf_wrapper_run( & endif uoce(i)=0.0 voce(i)=0.0 - vdfg(i)=0.0 !ust(i) = sqrt(stress(i)) ch(i)=0.0 hfx(i)=hflx(i)*rho(i,1)*cp @@ -663,7 +662,7 @@ SUBROUTINE mynnedmf_wrapper_run( & if (lprnt) then print* write(0,*)"===CALLING mynn_bl_driver; input:" - print*,"bl_mynn_tkebudget=",bl_mynn_tkebudget," bl_mynn_tkeadvect=",bl_mynn_tkeadvect + print*,"tke_budget=",tke_budget," bl_mynn_tkeadvect=",bl_mynn_tkeadvect print*,"bl_mynn_cloudpdf=",bl_mynn_cloudpdf," bl_mynn_mixlength=",bl_mynn_mixlength print*,"bl_mynn_edmf=",bl_mynn_edmf," bl_mynn_edmf_mom=",bl_mynn_edmf_mom print*,"bl_mynn_edmf_tke=",bl_mynn_edmf_tke @@ -689,7 +688,7 @@ SUBROUTINE mynnedmf_wrapper_run( & print*,"znt:",znt(1)," delt=",delt print*,"im=",im," levs=",levs print*,"PBLH=",pblh(1)," KPBL=",KPBL(1)," xland=",xland(1) - print*,"vdfg=",vdfg(1)," ch=",ch(1) + print*,"ch=",ch(1) !print*,"TKE:",TKE_PBL(1,1),TKE_PBL(1,2),TKE_PBL(1,levs) print*,"qke:",qke(1,1),qke(1,2),qke(1,levs) print*,"el_pbl:",el_pbl(1,1),el_pbl(1,2),el_pbl(1,levs) @@ -705,12 +704,12 @@ SUBROUTINE mynnedmf_wrapper_run( & & cycling=cycling, & & delt=delt,dz=dz,dx=dx,znt=znt, & & u=u,v=v,w=w,th=th,sqv3D=sqv,sqc3D=sqc, & - & sqi3D=sqi,qnc=qnc,qni=qni, & - & qnwfa=qnwfa,qnifa=qnifa,ozone=ozone, & + & sqi3D=sqi,sqs3D=sqs,qnc=qnc,qni=qni, & + & qnwfa=qnwfa,qnifa=qnifa,qnbca=qnbca,ozone=ozone, & & p=prsl,exner=exner,rho=rho,T3D=t3d, & & xland=xland,ts=ts,qsfc=qsfc,ps=ps, & & ust=ust,ch=ch,hfx=hfx,qfx=qfx,rmol=rmol, & - & wspd=wspd,uoce=uoce,voce=voce,vdfg=vdfg, & !input + & wspd=wspd,uoce=uoce,voce=voce, & !input & qke=QKE,qke_adv=qke_adv, & !output & sh3d=Sh3d,sm3d=Sm3d, & !chem/smoke @@ -724,15 +723,17 @@ SUBROUTINE mynnedmf_wrapper_run( & & RUBLTEN=RUBLTEN,RVBLTEN=RVBLTEN,RTHBLTEN=RTHBLTEN, & !output & RQVBLTEN=RQVBLTEN,RQCBLTEN=rqcblten, & & RQIBLTEN=rqiblten,RQNCBLTEN=rqncblten, & !output + & RQSBLTEN=rqsblten, & !output & RQNIBLTEN=rqniblten,RQNWFABLTEN=RQNWFABLTEN, & !output - & RQNIFABLTEN=RQNIFABLTEN,dozone=dqdt_ozone, & !output + & RQNIFABLTEN=RQNIFABLTEN,RQNBCABLTEN=RQNBCABLTEN, & !output + & dozone=dqdt_ozone, & !output & EXCH_H=exch_h,EXCH_M=exch_m, & !output & pblh=pblh,KPBL=KPBL, & !output & el_pbl=el_pbl, & !output & dqke=dqke, & !output & qWT=qWT,qSHEAR=qSHEAR,qBUOY=qBUOY,qDISS=qDISS, & !output & bl_mynn_tkeadvect=bl_mynn_tkeadvect, & - & bl_mynn_tkebudget=bl_mynn_tkebudget, & !input parameter + & tke_budget=tke_budget, & !input parameter & bl_mynn_cloudpdf=bl_mynn_cloudpdf, & !input parameter & bl_mynn_mixlength=bl_mynn_mixlength, & !input parameter & icloud_bl=icloud_bl, & !input parameter @@ -745,7 +746,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & bl_mynn_cloudmix=bl_mynn_cloudmix, & !input parameter & bl_mynn_mixqt=bl_mynn_mixqt, & !input parameter & edmf_a=edmf_a,edmf_w=edmf_w,edmf_qt=edmf_qt, & !output - & edmf_thl=edmf_thl,edmf_ent=edmf_ent,edmf_qc=edmf_qc,&!output + & edmf_thl=edmf_thl,edmf_ent=edmf_ent,edmf_qc=edmf_qc,& !output & sub_thl3D=sub_thl,sub_sqv3D=sub_sqv, & & det_thl3D=det_thl,det_sqv3D=det_sqv, & & nupdraft=nupdraft,maxMF=maxMF, & !output @@ -753,12 +754,12 @@ SUBROUTINE mynnedmf_wrapper_run( & & spp_pbl=spp_pbl,pattern_spp_pbl=spp_wts_pbl, & !input & RTHRATEN=htrlw, & !input & FLAG_QI=flag_qi,FLAG_QNI=flag_qni, & !input - & FLAG_QC=flag_qc,FLAG_QNC=flag_qnc, & !input + & FLAG_QC=flag_qc,FLAG_QNC=flag_qnc,FLAG_QS=flag_qs, & !input & FLAG_QNWFA=FLAG_QNWFA,FLAG_QNIFA=FLAG_QNIFA, & !input - & FLAG_OZONE=FLAG_OZONE, & !input + & FLAG_QNBCA=FLAG_QNBCA,FLAG_OZONE=FLAG_OZONE, & !input & IDS=1,IDE=im,JDS=1,JDE=1,KDS=1,KDE=levs, & !input & IMS=1,IME=im,JMS=1,JME=1,KMS=1,KME=levs, & !input - & ITS=1,ITE=im,JTS=1,JTE=1,KTS=1,KTE=levs) !input + & ITS=1,ITE=im,JTS=1,JTE=1,KTS=1,KTE=levs ) !input ! POST MYNN (INTERSTITIAL) WORK: @@ -799,13 +800,14 @@ SUBROUTINE mynnedmf_wrapper_run( & !enddo !DO moist/scalar/tracer tendencies: - if (imp_physics == imp_physics_wsm6) then + if (imp_physics == imp_physics_wsm6 .or. imp_physics == imp_physics_fa) then ! WSM6 do k=1,levs do i=1,im dqdt_water_vapor(i,k) = RQVBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_liquid_cloud(i,k) = RQCBLTEN(i,k) !/(1.0 + qv(i,k)) - dqdt_ice_cloud(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) + dqdt_ice(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) + dqdt_snow(i,k) = RQSBLTEN(i,k) !/(1.0 + qv(i,k)) !dqdt_ozone(i,k) = 0.0 enddo enddo @@ -819,7 +821,7 @@ SUBROUTINE mynnedmf_wrapper_run( & ! do i=1,im ! qgrs_water_vapor(i,k) = qgrs_water_vapor(i,k) + (RQVBLTEN(i,k)/(1.0+RQVBLTEN(i,k)))*delt ! qgrs_liquid_cloud(i,k) = qgrs_liquid_cloud(i,k) + RQCBLTEN(i,k)*delt - ! qgrs_ice_cloud(i,k) = qgrs_ice_cloud(i,k) + RQIBLTEN(i,k)*delt + ! qgrs_ice(i,k) = qgrs_ice(i,k) + RQIBLTEN(i,k)*delt ! !dqdt_ozone(i,k) = 0.0 ! enddo !enddo @@ -831,8 +833,9 @@ SUBROUTINE mynnedmf_wrapper_run( & dqdt_water_vapor(i,k) = RQVBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_liquid_cloud(i,k) = RQCBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_cloud_droplet_num_conc(i,k) = RQNCBLTEN(i,k) - dqdt_ice_cloud(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) + dqdt_ice(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_ice_num_conc(i,k) = RQNIBLTEN(i,k) + dqdt_snow(i,k) = RQSBLTEN(i,k) !/(1.0 + qv(i,k)) !dqdt_ozone(i,k) = 0.0 dqdt_water_aer_num_conc(i,k) = RQNWFABLTEN(i,k) dqdt_ice_aer_num_conc(i,k) = RQNIFABLTEN(i,k) @@ -851,7 +854,7 @@ SUBROUTINE mynnedmf_wrapper_run( & ! do i=1,im ! qgrs_water_vapor(i,k) = qgrs_water_vapor(i,k) + (RQVBLTEN(i,k)/(1.0+RQVBLTEN(i,k)))*delt ! qgrs_liquid_cloud(i,k) = qgrs_liquid_cloud(i,k) + RQCBLTEN(i,k)*delt - ! qgrs_ice_cloud(i,k) = qgrs_ice_cloud(i,k) + RQIBLTEN(i,k)*delt + ! qgrs_ice(i,k) = qgrs_ice(i,k) + RQIBLTEN(i,k)*delt ! qgrs_cloud_droplet_num_conc(i,k) = qgrs_cloud_droplet_num_conc(i,k) + RQNCBLTEN(i,k)*delt ! qgrs_cloud_ice_num_conc(i,k) = qgrs_cloud_ice_num_conc(i,k) + RQNIBLTEN(i,k)*delt ! !dqdt_ozone(i,k) = 0.0 @@ -859,14 +862,33 @@ SUBROUTINE mynnedmf_wrapper_run( & ! !qgrs_ice_aer_num_conc(i,k) = qgrs_ice_aer_num_conc(i,k) + RQNIFABLTEN(i,k)*delt ! enddo !enddo + else if(mraerosol) then + do k=1,levs + do i=1,im + dqdt_water_vapor(i,k) = RQVBLTEN(i,k) !/(1.0 + qv(i,k)) + dqdt_liquid_cloud(i,k) = RQCBLTEN(i,k) !/(1.0 + qv(i,k)) + dqdt_cloud_droplet_num_conc(i,k) = RQNCBLTEN(i,k) + dqdt_ice(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) + dqdt_ice_num_conc(i,k) = RQNIBLTEN(i,k) + dqdt_snow(i,k) = RQSBLTEN(i,k) !/(1.0 + qv(i,k)) + enddo + enddo + if(ldiag3d .and. .not. flag_for_pbl_generic_tend) then + call dtend_helper(100+ntqv,RQVBLTEN) + call dtend_helper(100+ntcw,RQCBLTEN) + call dtend_helper(100+ntlnc,RQNCBLTEN) + call dtend_helper(100+ntiw,RQIBLTEN) + call dtend_helper(100+ntinc,RQNIBLTEN) + endif else !Thompson (2008) do k=1,levs do i=1,im dqdt_water_vapor(i,k) = RQVBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_liquid_cloud(i,k) = RQCBLTEN(i,k) !/(1.0 + qv(i,k)) - dqdt_ice_cloud(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) + dqdt_ice(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_ice_num_conc(i,k) = RQNIBLTEN(i,k) + dqdt_snow(i,k) = RQSBLTEN(i,k) !/(1.0 + qv(i,k)) !dqdt_ozone(i,k) = 0.0 enddo enddo @@ -875,12 +897,13 @@ SUBROUTINE mynnedmf_wrapper_run( & call dtend_helper(100+ntcw,RQCBLTEN) call dtend_helper(100+ntiw,RQIBLTEN) call dtend_helper(100+ntinc,RQNIBLTEN) + call dtend_helper(100+ntsw,RQSBLTEN) endif !do k=1,levs ! do i=1,im ! qgrs_water_vapor(i,k) = qgrs_water_vapor(i,k) + (RQVBLTEN(i,k)/(1.0+RQVBLTEN(i,k)))*delt ! qgrs_liquid_cloud(i,k) = qgrs_liquid_cloud(i,k) + RQCBLTEN(i,k)*delt - ! qgrs_ice_cloud(i,k) = qgrs_ice_cloud(i,k) + RQIBLTEN(i,k)*delt + ! qgrs_ice(i,k) = qgrs_ice(i,k) + RQIBLTEN(i,k)*delt ! qgrs_cloud_ice_num_conc(i,k) = qgrs_cloud_ice_num_conc(i,k) + RQNIBLTEN(i,k)*delt ! !dqdt_ozone(i,k) = 0.0 ! enddo @@ -893,8 +916,9 @@ SUBROUTINE mynnedmf_wrapper_run( & dqdt_water_vapor(i,k) = RQVBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_liquid_cloud(i,k) = RQCBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_cloud_droplet_num_conc(i,k) = RQNCBLTEN(i,k) - dqdt_ice_cloud(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) + dqdt_ice(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_ice_num_conc(i,k) = RQNIBLTEN(i,k) + dqdt_snow(i,k) = RQSBLTEN(i,k) !/(1.0 + qv(i,k)) IF ( nssl_ccn_on ) THEN ! dqdt_cccn(i,k) = RQNWFABLTEN(i,k) ENDIF @@ -907,7 +931,7 @@ SUBROUTINE mynnedmf_wrapper_run( & do i=1,im dqdt_water_vapor(i,k) = RQVBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_liquid_cloud(i,k) = RQCBLTEN(i,k) !/(1.0 + qv(i,k)) - dqdt_ice_cloud(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) + dqdt_ice(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) !dqdt_rain(i,k) = 0.0 !dqdt_snow(i,k) = 0.0 !dqdt_graupel(i,k) = 0.0 @@ -923,7 +947,7 @@ SUBROUTINE mynnedmf_wrapper_run( & ! do i=1,im ! qgrs_water_vapor(i,k) = qgrs_water_vapor(i,k) + (RQVBLTEN(i,k)/(1.0+RQVBLTEN(i,k)))*delt ! qgrs_liquid_cloud(i,k) = qgrs_liquid_cloud(i,k) + RQCBLTEN(i,k)*delt - ! qgrs_ice_cloud(i,k) = qgrs_ice_cloud(i,k) + RQIBLTEN(i,k)*delt + ! qgrs_ice(i,k) = qgrs_ice(i,k) + RQIBLTEN(i,k)*delt ! !dqdt_ozone(i,k) = 0.0 ! enddo !enddo @@ -933,7 +957,7 @@ SUBROUTINE mynnedmf_wrapper_run( & do i=1,im dqdt_water_vapor(i,k) = RQVBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_liquid_cloud(i,k) = RQCBLTEN(i,k) !/(1.0 + qv(i,k)) - dqdt_ice_cloud(i,k) = 0.0 + dqdt_ice(i,k) = 0.0 !dqdt_rain(i,k) = 0.0 !dqdt_snow(i,k) = 0.0 !dqdt_graupel(i,k) = 0.0 @@ -970,8 +994,7 @@ SUBROUTINE mynnedmf_wrapper_run( & print*,"znt:",znt(1)," delt=",delt print*,"im=",im," levs=",levs print*,"PBLH=",pblh(1)," KPBL=",KPBL(1)," xland=",xland(1) - print*,"vdfg=",vdfg(1)," ch=",ch(1) - !print*,"TKE:",TKE_PBL(1,1),TKE_PBL(1,2),TKE_PBL(1,levs) + print*,"ch=",ch(1) print*,"qke:",qke(1,1),qke(1,2),qke(1,levs) print*,"el_pbl:",el_pbl(1,1),el_pbl(1,2),el_pbl(1,levs) print*,"Sh3d:",Sh3d(1,1),sh3d(1,2),sh3d(1,levs) @@ -1001,8 +1024,8 @@ SUBROUTINE mynnedmf_wrapper_run( & CONTAINS SUBROUTINE dtend_helper(itracer,field,mult) - real(kind=kind_phys), intent(in) :: field(im,levs) - real(kind=kind_phys), intent(in), optional :: mult(im,levs) + real(kind_phys), intent(in) :: field(im,levs) + real(kind_phys), intent(in), optional :: mult(im,levs) integer, intent(in) :: itracer integer :: idtend @@ -1018,7 +1041,7 @@ END SUBROUTINE dtend_helper ! ================================================================== SUBROUTINE moisture_check2(kte, delt, dp, exner, & - qv, qc, qi, th ) + qv, qc, qi, qs, th ) ! ! If qc < qcmin, qi < qimin, or qv < qvmin happens in any layer, ! force them to be larger than minimum value by (1) condensating @@ -1032,11 +1055,11 @@ SUBROUTINE moisture_check2(kte, delt, dp, exner, & implicit none integer, intent(in) :: kte - real(kind=kind_phys), intent(in) :: delt - real(kind=kind_phys), dimension(kte), intent(in) :: dp, exner - real(kind=kind_phys), dimension(kte), intent(inout) :: qv, qc, qi, th + real(kind_phys), intent(in) :: delt + real(kind_phys), dimension(kte), intent(in) :: dp, exner + real(kind_phys), dimension(kte), intent(inout) :: qv, qc, qi, qs, th integer k - real :: dqc2, dqi2, dqv2, sum, aa, dum + real :: dqc2, dqi2, dqs2, dqv2, sum, aa, dum real, parameter :: qvmin1= 1e-8, & !min at k=1 qvmin = 1e-20, & !min above k=1 qcmin = 0.0, & @@ -1045,17 +1068,19 @@ SUBROUTINE moisture_check2(kte, delt, dp, exner, & do k = kte, 1, -1 ! From the top to the surface dqc2 = max(0.0, qcmin-qc(k)) !qc deficit (>=0) dqi2 = max(0.0, qimin-qi(k)) !qi deficit (>=0) + dqs2 = max(0.0, qimin-qs(k)) !qs deficit (>=0) !update species qc(k) = qc(k) + dqc2 qi(k) = qi(k) + dqi2 - qv(k) = qv(k) - dqc2 - dqi2 + qs(k) = qs(k) + dqs2 + qv(k) = qv(k) - dqc2 - dqi2 - dqs2 !for theta !th(k) = th(k) + xlvcp/exner(k)*dqc2 + & ! xlscp/exner(k)*dqi2 !for temperature th(k) = th(k) + xlvcp*dqc2 + & - xlscp*dqi2 + xlscp*(dqi2+dqs2) !then fix qv if lending qv made it negative if (k .eq. 1) then @@ -1071,6 +1096,7 @@ SUBROUTINE moisture_check2(kte, delt, dp, exner, & endif qc(k) = max(qc(k),qcmin) qi(k) = max(qi(k),qimin) + qs(k) = max(qs(k),qimin) end do ! Extra moisture used to satisfy 'qv(1)>=qvmin' is proportionally diff --git a/physics/mynnedmf_wrapper.meta b/physics/mynnedmf_wrapper.meta index 044162dbb..ec4706aba 100644 --- a/physics/mynnedmf_wrapper.meta +++ b/physics/mynnedmf_wrapper.meta @@ -125,13 +125,6 @@ dimensions = () type = logical intent = in -[lheatstrg] - standard_name = flag_for_canopy_heat_storage_in_land_surface_scheme - long_name = flag for canopy heat storage parameterization - units = flag - dimensions = () - type = logical - intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -303,7 +296,7 @@ type = real kind = kind_phys intent = inout -[qgrs_ice_cloud] +[qgrs_ice] standard_name = cloud_ice_mixing_ratio long_name = ratio of mass of ice water to mass of dry air plus vapor (without condensates) units = kg kg-1 @@ -311,6 +304,14 @@ type = real kind = kind_phys intent = inout +[qgrs_snow] + standard_name = snow_mixing_ratio + long_name = ratio of mass of snow water to mass of dry air plus vapor (without condensates) + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout [qgrs_cloud_droplet_num_conc] standard_name = mass_number_concentration_of_cloud_liquid_water_particles_in_air long_name = number concentration of cloud droplets (liquid) @@ -367,6 +368,14 @@ type = real kind = kind_phys intent = in +[prsi] + standard_name = air_pressure_at_interface + long_name = air pressure at model layer interfaces + units = Pa + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in [exner] standard_name = dimensionless_exner_function long_name = Exner function at layers @@ -1017,7 +1026,7 @@ type = real kind = kind_phys intent = inout -[dqdt_ice_cloud] +[dqdt_ice] standard_name = process_split_cumulative_tendency_of_cloud_ice_mixing_ratio long_name = cloud condensed water mixing ratio tendency due to model physics units = kg kg-1 s-1 @@ -1025,6 +1034,14 @@ type = real kind = kind_phys intent = inout +[dqdt_snow] + standard_name = process_split_cumulative_tendency_of_snow_mixing_ratio + long_name = ratio of mass of snow water tendency to mass of dry air plus vapor (without condensates) due to model physics + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout [dqdt_ozone] standard_name = process_split_cumulative_tendency_of_ozone_mixing_ratio long_name = ozone mixing ratio tendency due to model physics @@ -1151,6 +1168,13 @@ dimensions = () type = integer intent = in +[ntsw] + standard_name = index_of_snow_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for snow water + units = index + dimensions = () + type = integer + intent = in [ntlnc] standard_name = index_of_mass_number_concentration_of_cloud_droplets_in_tracer_concentration_array long_name = tracer index for liquid number concentration @@ -1210,12 +1234,12 @@ type = real kind = kind_phys intent = in -[bl_mynn_tkebudget] +[tke_budget] standard_name = control_for_tke_budget_output long_name = flag for activating TKE budget units = flag dimensions = () - type = logical + type = integer intent = in [bl_mynn_tkeadvect] standard_name = flag_for_tke_advection @@ -1329,6 +1353,13 @@ dimensions = () type = integer intent = in +[imp_physics_fa] + standard_name = identifier_for_fer_hires_microphysics_scheme + long_name = choice of Ferrier-Aligo microphysics scheme + units = flag + dimensions = () + type = integer + intent = in [imp_physics_nssl] standard_name = identifier_for_nssl_microphysics_scheme long_name = choice of NSSL 2-moment microphysics scheme @@ -1416,6 +1447,13 @@ dimensions = () type = logical intent = in +[mraerosol] + standard_name = do_merra2_aerosol_awareness + long_name = flag for merra2 aerosol-aware physics for example the thompson microphysics + units = flag + dimensions = () + type = logical + intent = in [spp_wts_pbl] standard_name = spp_weights_for_pbl_scheme long_name = spp weights for pbl scheme diff --git a/physics/sgscloud_radpre.F90 b/physics/sgscloud_radpre.F90 index ae0f39dde..05ca1af2a 100644 --- a/physics/sgscloud_radpre.F90 +++ b/physics/sgscloud_radpre.F90 @@ -35,7 +35,7 @@ module sgscloud_radpre !! !>\section sgscloud_radpre_mod SGS Cloud Scheme Pre General Algorithm subroutine sgscloud_radpre_run( & - im,dt,levs, & + im,dt,fhswr,levs, & flag_init,flag_restart, & con_g, con_pi, eps, epsm1, & r_v, cpv, rcp, & @@ -43,8 +43,9 @@ subroutine sgscloud_radpre_run( & do_mynnedmf, & qc, qi, qv, T3D, P3D, exner, & qr, qs, qg, & - qci_conv,ud_mf, & + qci_conv,qlc,qli,ud_mf, & imfdeepcnv, imfdeepcnv_gf, & + imfdeepcnv_sas, & qc_save, qi_save, qs_save, & qc_bl,qi_bl,cldfra_bl, & delp,clouds1,clouds2,clouds3, & @@ -53,6 +54,7 @@ subroutine sgscloud_radpre_run( & nlay, plyr, xlat, dz,de_lgth, & cldsa,mtopa,mbota, & imp_physics, imp_physics_gfdl,& + imp_physics_fa, & iovr, & errmsg, errflg ) @@ -67,17 +69,18 @@ subroutine sgscloud_radpre_run( & real(kind=kind_phys), intent(in) :: con_g, con_pi, eps, epsm1 real(kind=kind_phys), intent(in) :: r_v, cpv, rcp real(kind=kind_phys), intent(in) :: xlv, xlf, cp - real(kind=kind_phys), intent(in) :: dt + real(kind=kind_phys), intent(in) :: dt,fhswr real :: xls, xlvcp, xlscp !derived below real(kind=kind_phys) :: gfac integer, intent(in) :: im, levs, imfdeepcnv, imfdeepcnv_gf, & - & nlay, imp_physics, imp_physics_gfdl + & nlay, imfdeepcnv_sas, imp_physics, imp_physics_gfdl, imp_physics_fa logical, intent(in) :: flag_init, flag_restart, do_mynnedmf real(kind=kind_phys), dimension(:,:), intent(inout) :: qc, qi real(kind=kind_phys), dimension(:,:), intent(inout) :: qr, qs, qg - ! qci_conv only allocated if GF is used + ! note: qci_conv only allocated if GF is used real(kind=kind_phys), dimension(:,:), intent(inout) :: qci_conv + real(kind=kind_phys), dimension(:,:), intent(inout) :: qlc, qli !for SAS real(kind=kind_phys), dimension(:,:), intent(in) :: ud_mf real(kind=kind_phys), dimension(:,:), intent(in) :: T3D,delp real(kind=kind_phys), dimension(:,:), intent(in) :: qv,P3D,exner @@ -112,7 +115,8 @@ subroutine sgscloud_radpre_run( & real :: rhgrid,h2oliq,qsat,tem1,tem2,clwt,es,onemrh,value !Chaboureau and Bechtold (2002 and 2005) - real :: a, f, sigq, qmq, qt, xl, tlk, th, thl, rsl, cpm, cb_cf + real :: a, f, sigq, qmq, qt, xl, th, thl, rsl, cpm, cb_cf + real(kind=kind_phys) :: tlk !Option to convective cloud fraction integer, parameter :: conv_cf_opt = 0 !0: C-B, 1: X-R @@ -188,7 +192,7 @@ subroutine sgscloud_radpre_run( & !endif if (qc(i,k) < 1.e-6 .and. cldfra_bl(i,k)>0.001) then - qc(i,k) = qc_bl(i,k)*cldfra_bl(i,k) + qc(i,k) = qc_bl(i,k) !eff radius cloud water (microns) from Miles et al. (2007) if (nint(slmsk(i)) == 1) then !land @@ -206,8 +210,8 @@ subroutine sgscloud_radpre_run( & !~700 mb and decrease snow to zero by ~300 mb snow_frac = min(0.5, max((p3d(i,k)-30000.0),0.0)/140000.0) ice_frac = 1.0 - snow_frac - if (qi(i,k) < 1.e-8 .and. cldfra_bl(i,k)>0.001) then - qi(i,k) = ice_frac*qi_bl(i,k)*cldfra_bl(i,k) + if (qi(i,k) < 1.e-9 .and. cldfra_bl(i,k)>0.001) then + qi(i,k) = ice_frac*qi_bl(i,k) !eff radius cloud ice (microns), from Mishra et al. (2014, JGR Atmos, fig 6b) if(qi(i,k)>1.E-8)clouds5(i,k)=max(173.45 + 2.14*Tc, 20.) @@ -219,8 +223,8 @@ subroutine sgscloud_radpre_run( & clouds4(i,k) = max(0.0, qi(i,k) * gfac * delp(i,k)) endif - if (qs(i,k) < 1.e-8 .and. cldfra_bl(i,k)>0.001) then - qs(i,k) = snow_frac*qi_bl(i,k)*cldfra_bl(i,k) + if (qs(i,k) < 1.e-9 .and. cldfra_bl(i,k)>0.001) then + qs(i,k) = snow_frac*qi_bl(i,k) !eff radius cloud ice (microns), from Mishra et al. (2014, JGR Atmos, fig 6b) if(qs(i,k)>1.E-8)clouds9(i,k)=max(2.*(173.45 + 2.14*Tc), 50.) @@ -270,7 +274,6 @@ subroutine sgscloud_radpre_run( & if (imfdeepcnv == imfdeepcnv_gf) then do k = 1, levs do i = 1, im - !if ( qci_conv(i,k) > 0. .AND. (qi(i,k) < 1E-7 .AND. qc(i,k) < 1E-7 ) ) then if ( qci_conv(i,k) > 0. ) then Tk = T3D(i,k) Tc = Tk - 273.15 @@ -321,10 +324,15 @@ subroutine sgscloud_radpre_run( & sigq = SQRT(sigq**2 + 1e-10) ! combined conv + background components qmq = a * (qt - qsat) ! saturation deficit/excess; ! the numerator of Q1 - cb_cf= min(max(0.5 + 0.36 * atan(1.55*(qmq/sigq)),0.01),0.99) + cb_cf= min(max(0.5 + 0.36 * atan(1.55*(qmq/sigq)),0.0),0.99) + if (qci_conv(i,k) .lt. 1e-9) cb_cf = 0.0 if (do_mynnedmf .and. qmq .ge. 0.0) then ! leverage C-B stratus clouds from MYNN in saturated conditions - clouds1(i,k) = 0.5*(clouds1(i,k) + cb_cf) + if (cb_cf .gt. 0.0) then + clouds1(i,k) = 0.5*(clouds1(i,k) + cb_cf) + else + !default to MYNN clouds - already specified + endif else ! unsaturated clouds1(i,k) = cb_cf endif @@ -354,7 +362,101 @@ subroutine sgscloud_radpre_run( & endif ! qci_conv enddo enddo - endif ! imfdeepcnv_gf + + elseif (imfdeepcnv == imfdeepcnv_sas) then + + do k = 1, levs + do i = 1, im + h2oliq = qlc(i,k)+qli(i,k) + if ( h2oliq > 0. ) then + Tk = T3D(i,k) + Tc = Tk - 273.15 + + !Partition the convective clouds into water & frozen species + liqfrac = min(1., max(0., (Tk-244.)/29.)) + + qc(i,k) = qc(i,k)+qlc(i,k) + !split ice & snow 50-50% + qi(i,k) = qi(i,k)+0.5*qli(i,k) + qs(i,k) = qs(i,k)+0.5*qli(i,k) + + !eff radius cloud water (microns) + if (nint(slmsk(i)) == 1) then !land + if(qc(i,k)>1.E-8)clouds3(i,k)=5.4 + else + !from Miles et al. + if(qc(i,k)>1.E-8)clouds3(i,k)=9.6 + endif + !from Mishra et al. (2014, JGR Atmos), assume R_sno = 2*R_ice + if(qi(i,k)>1.e-8)clouds5(i,k)=max( 173.45 + 2.14*Tc , 20.) + if(qs(i,k)>1.e-8)clouds9(i,k)=max(2.0*(173.45 + 2.14*Tc), 50.) + + if ( conv_cf_opt .eq. 0 ) then + !print *,'Chab-Bechtold cloud fraction used' + !Alternatively, use Chaboureau-Bechtold (CB) convective component + !Based on both CB2002 and CB2005. + xl = xlv*liqfrac + xls*(1.-liqfrac) ! blended heat capacity + tlk = t3d(i,k) - xlvcp/exner(i,k)*qc(i,k) & + & - xlscp/exner(i,k)*qi(i,k)! liquid temp + ! get saturation water vapor mixing ratio at tl and p + es = min( p3d(i,k), fpvs( tlk ) ) ! fpvs and prsl in pa + qsat= max( QMIN, eps*es / (p3d(i,k) + epsm1*es) ) + rsl = xl*qsat / (r_v*tlk**2) ! slope of C-C curve at t = tl + ! CB02, Eqn. 4 + qt = qc(i,k) + qi(i,k) + qv(i,k) !total water + cpm = cp + qt*cpv ! CB02, sec. 2, para. 1 + a = 1./(1. + xl*rsl/cpm) ! CB02 variable "a" + !Now calculate convective component of the cloud fraction: + if (a > 0.0) then + f = min(1.0/a, 4.0) ! f is the vertical profile + else ! scaling function (CB2005) + f = 1.0 + endif + sigq = 1.5E-3 * ud_mf(i,k)/dt * f + !sigq = 3.E-3 * ud_mf(i,k)/dt * f + sigq = SQRT(sigq**2 + 1e-10) ! combined conv + background components + qmq = a * (qt - qsat) ! saturation deficit/excess; + ! the numerator of Q1 + cb_cf= min(max(0.5 + 0.36 * atan(1.55*(qmq/sigq)),0.0),0.99) + if (h2oliq .lt. 1e-9) cb_cf = 0.0 + if (do_mynnedmf .and. qmq .ge. 0.0) then + ! leverage C-B stratus clouds from MYNN in saturated conditions + if (cb_cf .gt. 0.0) then + clouds1(i,k) = 0.5*(clouds1(i,k) + cb_cf) + else + !default to MYNN clouds - already specified + endif + else ! unsaturated + clouds1(i,k) = cb_cf + endif + else + !print *,'SAS with Xu-Randall cloud fraction' + ! Xu-Randall (1996) cloud fraction + es = min( p3d(i,k), fpvs( t3d(i,k) ) ) ! fpvs and prsl in pa + qsat = max( QMIN, eps*es / (p3d(i,k) + epsm1*es) ) + rhgrid = max( 0., min( 1.00, qv(i,k)/qsat ) ) + h2oliq = qc(i,k) + qi(i,k) + qr(i,k) + qs(i,k) + qg(i,k) ! g/kg + clwt = 1.0e-6 * (p3d(i,k)*0.00001) + + if (h2oliq > clwt) then + onemrh= max( 1.e-10, 1.0-rhgrid ) + tem1 = min(max((onemrh*qsat)**0.49,0.0001),1.0) !jhan + tem1 = 100.0 / tem1 + value = max( min( tem1*(h2oliq-clwt), 50.0 ), 0.0 ) + tem2 = sqrt( sqrt(rhgrid) ) + + clouds1(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) + else + clouds1(i,k) = 0.0 + endif + !print*,"XuRandla- cf:",clouds1(i,k)," rh:",rhgrid," qt:",h2oliq + !print*,"XuRandlb- clwt:",clwt," qsat:",qsat," p:",p3d(i,k) + endif ! end convective cf choice + endif ! qlc/qli check + enddo + enddo + + endif ! convection scheme check endif ! timestep > 1 diff --git a/physics/sgscloud_radpre.meta b/physics/sgscloud_radpre.meta index 28c1b7da6..887ea0b45 100644 --- a/physics/sgscloud_radpre.meta +++ b/physics/sgscloud_radpre.meta @@ -29,6 +29,14 @@ dimensions = () type = integer intent = in +[fhswr] + standard_name = period_of_shortwave_radiation_calls + long_name = frequency for shortwave radiation + units = s + dimensions = () + type = real + kind = kind_phys + intent = in [flag_init] standard_name = flag_for_first_timestep long_name = flag signaling first time step for time integration loop @@ -218,6 +226,22 @@ type = real kind = kind_phys intent = inout +[qlc] + standard_name = cloud_condensed_water_mixing_ratio_convective_transport_tracer + long_name = ratio of mass of cloud water to mass of dry air plus vapor (without condensates) in the convectively transported tracer array + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[qli] + standard_name = ice_water_mixing_ratio_convective_transport_tracer + long_name = ratio of mass of ice water to mass of dry air plus vapor (without condensates) in the convectively transported tracer array + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout [imfdeepcnv] standard_name = control_for_deep_convection_scheme long_name = flag for mass-flux deep convection scheme @@ -232,6 +256,13 @@ dimensions = () type = integer intent = in +[imfdeepcnv_sas] + standard_name = identifier_for_simplified_arakawa_schubert_deep_convection + long_name = flag for SAS deep convection scheme + units = flag + dimensions = () + type = integer + intent = in [qc_save] standard_name = cloud_condensed_water_mixing_ratio_save long_name = ratio of mass of cloud water to mass of dry air plus vapor (without condensates) before entering a physics scheme @@ -427,6 +458,13 @@ dimensions = () type = integer intent = in +[imp_physics_fa] + standard_name = identifier_for_fer_hires_microphysics_scheme + long_name = choice of Ferrier-Aligo microphysics scheme + units = flag + dimensions = () + type = integer + intent = in [iovr] standard_name = flag_for_cloud_overlap_method_for_radiation long_name = max-random overlap clouds From 9c8839690eb024ab1f6c335fb0c5911aace3ca4f Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Tue, 14 Mar 2023 03:02:32 +0000 Subject: [PATCH 153/380] bug fixes from sam to get most regression tests to pass --- physics/mynnedmf_wrapper.F90 | 4 +++- physics/rrtmgp_aerosol_optics.F90 | 7 +++++-- physics/rrtmgp_aerosol_optics.meta | 8 ++++++++ 3 files changed, 16 insertions(+), 3 deletions(-) diff --git a/physics/mynnedmf_wrapper.F90 b/physics/mynnedmf_wrapper.F90 index 74cf8fa30..be282a21a 100644 --- a/physics/mynnedmf_wrapper.F90 +++ b/physics/mynnedmf_wrapper.F90 @@ -357,7 +357,9 @@ SUBROUTINE mynnedmf_wrapper_run( & !initialize arrays for test EMIS_ANT_NO = 0. - vdep = 0. + if(rrfs_sd) then + vdep = 0. + endif FLAG_OZONE = ntoz>0 diff --git a/physics/rrtmgp_aerosol_optics.F90 b/physics/rrtmgp_aerosol_optics.F90 index ce0fa8ea9..9a92ea98a 100644 --- a/physics/rrtmgp_aerosol_optics.F90 +++ b/physics/rrtmgp_aerosol_optics.F90 @@ -27,7 +27,7 @@ module rrtmgp_aerosol_optics subroutine rrtmgp_aerosol_optics_run(doSWrad, doLWrad, nCol, nLev, nDay, idxday, p_lev, & p_lay, p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, iaermdl, iaerflg, & top_at_1, con_pi, con_rd, con_g, aerodp, aerlw_tau, aerlw_ssa, aerlw_g, aersw_tau, & - aersw_ssa, aersw_g, errmsg, errflg ) + aersw_ssa, aersw_g, ext550, errmsg, errflg ) ! Inputs logical, intent(in) :: & @@ -61,6 +61,8 @@ subroutine rrtmgp_aerosol_optics_run(doSWrad, doLWrad, nCol, nLev, nDay, idxday, aerfld ! aerosol input concentrations real(kind_phys), dimension(:,:),intent(in) :: & p_lev ! Pressure @ layer-interfaces (Pa) + real (kind=kind_phys), dimension(:,:), intent(out) :: & + ext550 ! 3d optical extinction for total aerosol species ! Outputs real(kind_phys), dimension(:,:), intent(out) :: & @@ -92,7 +94,8 @@ subroutine rrtmgp_aerosol_optics_run(doSWrad, doLWrad, nCol, nLev, nDay, idxday, ! Call module_radiation_aerosols::setaer(),to setup aerosols property profile call setaer(p_lev*0.01, p_lay*0.01, p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, nCol, nLev, & - nLev+1, .true., .true., iaermdl, iaerflg, top_at_1, con_pi, con_rd, con_g, aerosolssw2, aerosolslw, aerodp, errflg, errmsg) + nLev+1, .true., .true., iaermdl, iaerflg, top_at_1, con_pi, con_rd, con_g, aerosolssw2, aerosolslw, & + aerodp, ext550, errflg, errmsg) ! Shortwave if (doSWrad .and. (nDay .gt. 0)) then diff --git a/physics/rrtmgp_aerosol_optics.meta b/physics/rrtmgp_aerosol_optics.meta index e2b81b192..d33e9f08f 100644 --- a/physics/rrtmgp_aerosol_optics.meta +++ b/physics/rrtmgp_aerosol_optics.meta @@ -230,6 +230,14 @@ type = real kind = kind_phys intent = out +[ext550] + standard_name = atmosphere_optical_thickness_3d + long_name = 3d optical extinction for total aerosol species + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 118f72c2500298f5344b50f849681c62d89e1342 Mon Sep 17 00:00:00 2001 From: "Haiqin.Li" Date: Tue, 14 Mar 2023 15:32:03 +0000 Subject: [PATCH 154/380] "include updates from Sam and Haiqin" --- physics/mynnedmf_wrapper.F90 | 1 - physics/rrtmgp_aerosol_optics.F90 | 7 +++++-- physics/rrtmgp_aerosol_optics.meta | 8 ++++++++ 3 files changed, 13 insertions(+), 3 deletions(-) diff --git a/physics/mynnedmf_wrapper.F90 b/physics/mynnedmf_wrapper.F90 index 74cf8fa30..0f61a6e24 100644 --- a/physics/mynnedmf_wrapper.F90 +++ b/physics/mynnedmf_wrapper.F90 @@ -357,7 +357,6 @@ SUBROUTINE mynnedmf_wrapper_run( & !initialize arrays for test EMIS_ANT_NO = 0. - vdep = 0. FLAG_OZONE = ntoz>0 diff --git a/physics/rrtmgp_aerosol_optics.F90 b/physics/rrtmgp_aerosol_optics.F90 index ce0fa8ea9..9a92ea98a 100644 --- a/physics/rrtmgp_aerosol_optics.F90 +++ b/physics/rrtmgp_aerosol_optics.F90 @@ -27,7 +27,7 @@ module rrtmgp_aerosol_optics subroutine rrtmgp_aerosol_optics_run(doSWrad, doLWrad, nCol, nLev, nDay, idxday, p_lev, & p_lay, p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, iaermdl, iaerflg, & top_at_1, con_pi, con_rd, con_g, aerodp, aerlw_tau, aerlw_ssa, aerlw_g, aersw_tau, & - aersw_ssa, aersw_g, errmsg, errflg ) + aersw_ssa, aersw_g, ext550, errmsg, errflg ) ! Inputs logical, intent(in) :: & @@ -61,6 +61,8 @@ subroutine rrtmgp_aerosol_optics_run(doSWrad, doLWrad, nCol, nLev, nDay, idxday, aerfld ! aerosol input concentrations real(kind_phys), dimension(:,:),intent(in) :: & p_lev ! Pressure @ layer-interfaces (Pa) + real (kind=kind_phys), dimension(:,:), intent(out) :: & + ext550 ! 3d optical extinction for total aerosol species ! Outputs real(kind_phys), dimension(:,:), intent(out) :: & @@ -92,7 +94,8 @@ subroutine rrtmgp_aerosol_optics_run(doSWrad, doLWrad, nCol, nLev, nDay, idxday, ! Call module_radiation_aerosols::setaer(),to setup aerosols property profile call setaer(p_lev*0.01, p_lay*0.01, p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, nCol, nLev, & - nLev+1, .true., .true., iaermdl, iaerflg, top_at_1, con_pi, con_rd, con_g, aerosolssw2, aerosolslw, aerodp, errflg, errmsg) + nLev+1, .true., .true., iaermdl, iaerflg, top_at_1, con_pi, con_rd, con_g, aerosolssw2, aerosolslw, & + aerodp, ext550, errflg, errmsg) ! Shortwave if (doSWrad .and. (nDay .gt. 0)) then diff --git a/physics/rrtmgp_aerosol_optics.meta b/physics/rrtmgp_aerosol_optics.meta index e2b81b192..d33e9f08f 100644 --- a/physics/rrtmgp_aerosol_optics.meta +++ b/physics/rrtmgp_aerosol_optics.meta @@ -230,6 +230,14 @@ type = real kind = kind_phys intent = out +[ext550] + standard_name = atmosphere_optical_thickness_3d + long_name = 3d optical extinction for total aerosol species + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 67b0511d8888587e677005e379d2064b3f2b51b5 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Tue, 14 Mar 2023 19:05:59 +0000 Subject: [PATCH 155/380] do not initialize vdep --- physics/mynnedmf_wrapper.F90 | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/physics/mynnedmf_wrapper.F90 b/physics/mynnedmf_wrapper.F90 index be282a21a..27ffa162e 100644 --- a/physics/mynnedmf_wrapper.F90 +++ b/physics/mynnedmf_wrapper.F90 @@ -290,7 +290,7 @@ SUBROUTINE mynnedmf_wrapper_run( & logical, intent(in) :: mix_chem, enh_mix, rrfs_sd real(kind_phys), dimension(:,:,:), intent(inout) :: chem3d real(kind_phys), dimension(:,: ), intent(inout) :: vdep - real(kind_phys), dimension(im) :: emis_ant_no + real(kind_phys), dimension(:) :: emis_ant_no !MYNN-2D real(kind_phys), dimension(:), intent(in) :: & @@ -357,9 +357,6 @@ SUBROUTINE mynnedmf_wrapper_run( & !initialize arrays for test EMIS_ANT_NO = 0. - if(rrfs_sd) then - vdep = 0. - endif FLAG_OZONE = ntoz>0 From 50c4f1bd5665c0aab3e6c3675e4d73735aae7135 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Tue, 14 Mar 2023 19:13:07 +0000 Subject: [PATCH 156/380] revert accidental change --- physics/mynnedmf_wrapper.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/mynnedmf_wrapper.F90 b/physics/mynnedmf_wrapper.F90 index 27ffa162e..0f61a6e24 100644 --- a/physics/mynnedmf_wrapper.F90 +++ b/physics/mynnedmf_wrapper.F90 @@ -290,7 +290,7 @@ SUBROUTINE mynnedmf_wrapper_run( & logical, intent(in) :: mix_chem, enh_mix, rrfs_sd real(kind_phys), dimension(:,:,:), intent(inout) :: chem3d real(kind_phys), dimension(:,: ), intent(inout) :: vdep - real(kind_phys), dimension(:) :: emis_ant_no + real(kind_phys), dimension(im) :: emis_ant_no !MYNN-2D real(kind_phys), dimension(:), intent(in) :: & From 14557a5459e8735bdda8eaa69891bb96db078401 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Tue, 14 Mar 2023 19:41:40 +0000 Subject: [PATCH 157/380] 1.2 GB of messages is a bit too much. --- physics/module_mp_nssl_2mom.F90 | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/physics/module_mp_nssl_2mom.F90 b/physics/module_mp_nssl_2mom.F90 index 6b184c35f..149da491d 100644 --- a/physics/module_mp_nssl_2mom.F90 +++ b/physics/module_mp_nssl_2mom.F90 @@ -8117,7 +8117,9 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ! write(0,*) 'Hail,snow c: ',an(ix,jy,kz,lnh),an(ix,jy,kz,lns) ! write(0,*) 'dtmps,dtmph = ',dtmps,dtmph ! ENDIF - IF ( .not. dtmp(ix,kz) .lt. 1.e30 .or. dbz(ix,jy,kz) > 190.0 ) THEN + +! 1.2 GB of messages is a bit too much. + IF ( .false. ) then ! .not. dtmp(ix,kz) .lt. 1.e30 .or. dbz(ix,jy,kz) > 190.0 ! IF ( ix == 31 .and. kz == 20 .and. jy == 23 ) THEN ! write(0,*) 'my_rank = ',my_rank write(0,*) 'ix,jy,kz = ',ix,jy,kz From c886b46390752237671c540b7b19d58e03c08534 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Tue, 14 Mar 2023 20:53:35 +0000 Subject: [PATCH 158/380] remove unneeded hydrostatic check from maximum_hourly_diagnostics --- physics/maximum_hourly_diagnostics.F90 | 12 +++--------- physics/maximum_hourly_diagnostics.meta | 7 ------- 2 files changed, 3 insertions(+), 16 deletions(-) diff --git a/physics/maximum_hourly_diagnostics.F90 b/physics/maximum_hourly_diagnostics.F90 index df8d9202f..cd1016053 100644 --- a/physics/maximum_hourly_diagnostics.F90 +++ b/physics/maximum_hourly_diagnostics.F90 @@ -31,11 +31,11 @@ subroutine maximum_hourly_diagnostics_run(im, levs, reset, lradar, imp_physics, t02min, rh02max, rh02min, dtp, rain, pratemax, & lightning_threat, ltg1_max,ltg2_max,ltg3_max, & wgrs, prsi, qgraupel, qsnowwat, qicewat, tgrs, con_rd,& - prsl, kdt, hydrostatic, errmsg, errflg) + prsl, kdt, errmsg, errflg) ! Interface variables integer, intent(in) :: im, levs, kdt - logical, intent(in) :: reset, lradar, lightning_threat, hydrostatic + logical, intent(in) :: reset, lradar, lightning_threat integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_fer_hires, & imp_physics_nssl real(kind_phys), intent(in ) :: con_g @@ -79,13 +79,7 @@ subroutine maximum_hourly_diagnostics_run(im, levs, reset, lradar, imp_physics, !Lightning threat indices if (lightning_threat) then - if(hydrostatic) then - ltg1_max = 0 - ltg2_max = 0 - ltg3_max = 0 - else - call lightning_threat_indices - endif + call lightning_threat_indices endif !Calculate hourly max 1-km agl and -10C reflectivity diff --git a/physics/maximum_hourly_diagnostics.meta b/physics/maximum_hourly_diagnostics.meta index 9fa33a667..e9d0876d2 100644 --- a/physics/maximum_hourly_diagnostics.meta +++ b/physics/maximum_hourly_diagnostics.meta @@ -340,13 +340,6 @@ dimensions = () type = integer intent = in -[hydrostatic] - standard_name = flag_for_hydrostatic_solver - long_name = flag for hydrostatic solver from dynamics - units = flag - dimensions = () - type = logical - intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 0b369ef1fba957d3b231be26d3acb7208387a590 Mon Sep 17 00:00:00 2001 From: joeolson42 Date: Tue, 14 Mar 2023 22:24:08 +0000 Subject: [PATCH 159/380] More consistent logic for NSSL mp (mixing snow) --- physics/mynnedmf_wrapper.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/physics/mynnedmf_wrapper.F90 b/physics/mynnedmf_wrapper.F90 index d2ca9f3cc..254592433 100644 --- a/physics/mynnedmf_wrapper.F90 +++ b/physics/mynnedmf_wrapper.F90 @@ -392,16 +392,16 @@ SUBROUTINE mynnedmf_wrapper_run( & FLAG_QNI= .true. FLAG_QC = .true. FLAG_QNC= .true. - FLAG_QS = .false. + FLAG_QS = .true. FLAG_QNWFA= nssl_ccn_on ! ERM: Perhaps could use this field for CCN field? FLAG_QNIFA= .false. FLAG_QNBCA= .false. do k=1,levs do i=1,im - sqv(i,k) = qgrs_water_vapor(i,k) - sqc(i,k) = qgrs_liquid_cloud(i,k) - sqi(i,k) = qgrs_ice(i,k) - sqs(i,k) = 0. + sqv(i,k) = qgrs_water_vapor(i,k) + sqc(i,k) = qgrs_liquid_cloud(i,k) + sqi(i,k) = qgrs_ice(i,k) + sqs(i,k) = qgrs_snow(i,k) ozone(i,k) = qgrs_ozone(i,k) qnc(i,k) = qgrs_cloud_droplet_num_conc(i,k) qni(i,k) = qgrs_cloud_ice_num_conc(i,k) From 4cc7227235e49b1711584712bd4ad362813f619c Mon Sep 17 00:00:00 2001 From: joeolson42 Date: Wed, 15 Mar 2023 14:32:54 +0000 Subject: [PATCH 160/380] removing snow mixing from nssl-mp --- physics/mynnedmf_wrapper.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/mynnedmf_wrapper.F90 b/physics/mynnedmf_wrapper.F90 index 254592433..1e8eabe98 100644 --- a/physics/mynnedmf_wrapper.F90 +++ b/physics/mynnedmf_wrapper.F90 @@ -392,7 +392,7 @@ SUBROUTINE mynnedmf_wrapper_run( & FLAG_QNI= .true. FLAG_QC = .true. FLAG_QNC= .true. - FLAG_QS = .true. + FLAG_QS = .false. !.true. FLAG_QNWFA= nssl_ccn_on ! ERM: Perhaps could use this field for CCN field? FLAG_QNIFA= .false. FLAG_QNBCA= .false. @@ -401,7 +401,7 @@ SUBROUTINE mynnedmf_wrapper_run( & sqv(i,k) = qgrs_water_vapor(i,k) sqc(i,k) = qgrs_liquid_cloud(i,k) sqi(i,k) = qgrs_ice(i,k) - sqs(i,k) = qgrs_snow(i,k) + sqs(i,k) = 0.0 !qgrs_snow(i,k) ozone(i,k) = qgrs_ozone(i,k) qnc(i,k) = qgrs_cloud_droplet_num_conc(i,k) qni(i,k) = qgrs_cloud_ice_num_conc(i,k) @@ -918,7 +918,7 @@ SUBROUTINE mynnedmf_wrapper_run( & dqdt_cloud_droplet_num_conc(i,k) = RQNCBLTEN(i,k) dqdt_ice(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_ice_num_conc(i,k) = RQNIBLTEN(i,k) - dqdt_snow(i,k) = RQSBLTEN(i,k) !/(1.0 + qv(i,k)) + !dqdt_snow(i,k) = RQSBLTEN(i,k) !/(1.0 + qv(i,k)) IF ( nssl_ccn_on ) THEN ! dqdt_cccn(i,k) = RQNWFABLTEN(i,k) ENDIF From 6964aabe79905680e2a3a63efc572eb006f72397 Mon Sep 17 00:00:00 2001 From: "Haiqin.Li" Date: Wed, 15 Mar 2023 16:46:34 +0000 Subject: [PATCH 161/380] "update MYNN coupling to nssl-mp from PR #43" --- physics/mynnedmf_wrapper.F90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/physics/mynnedmf_wrapper.F90 b/physics/mynnedmf_wrapper.F90 index 0f61a6e24..83a73e6b3 100644 --- a/physics/mynnedmf_wrapper.F90 +++ b/physics/mynnedmf_wrapper.F90 @@ -391,16 +391,16 @@ SUBROUTINE mynnedmf_wrapper_run( & FLAG_QNI= .true. FLAG_QC = .true. FLAG_QNC= .true. - FLAG_QS = .false. + FLAG_QS = .false. !.true. FLAG_QNWFA= nssl_ccn_on ! ERM: Perhaps could use this field for CCN field? FLAG_QNIFA= .false. FLAG_QNBCA= .false. do k=1,levs do i=1,im - sqv(i,k) = qgrs_water_vapor(i,k) - sqc(i,k) = qgrs_liquid_cloud(i,k) - sqi(i,k) = qgrs_ice(i,k) - sqs(i,k) = 0. + sqv(i,k) = qgrs_water_vapor(i,k) + sqc(i,k) = qgrs_liquid_cloud(i,k) + sqi(i,k) = qgrs_ice(i,k) + sqs(i,k) = 0.0 !qgrs_snow(i,k) ozone(i,k) = qgrs_ozone(i,k) qnc(i,k) = qgrs_cloud_droplet_num_conc(i,k) qni(i,k) = qgrs_cloud_ice_num_conc(i,k) @@ -917,7 +917,7 @@ SUBROUTINE mynnedmf_wrapper_run( & dqdt_cloud_droplet_num_conc(i,k) = RQNCBLTEN(i,k) dqdt_ice(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_ice_num_conc(i,k) = RQNIBLTEN(i,k) - dqdt_snow(i,k) = RQSBLTEN(i,k) !/(1.0 + qv(i,k)) + !dqdt_snow(i,k) = RQSBLTEN(i,k) !/(1.0 + qv(i,k)) IF ( nssl_ccn_on ) THEN ! dqdt_cccn(i,k) = RQNWFABLTEN(i,k) ENDIF From 23037bbd60f7b727b7bdf2744069f5ff34be65f4 Mon Sep 17 00:00:00 2001 From: Lisa Bengtsson Date: Wed, 15 Mar 2023 21:15:46 +0000 Subject: [PATCH 162/380] more development... --- physics/GFS_suite_interstitial_3.F90 | 11 +++++++---- physics/GFS_suite_interstitial_3.meta | 14 ++++++++++++++ physics/cu_unified_deep.F90 | 19 ++++++++++--------- physics/cu_unified_sh.F90 | 1 - physics/progsigma_calc.f90 | 2 -- physics/samfdeepcnv.f | 2 -- physics/samfshalcnv.f | 2 -- 7 files changed, 31 insertions(+), 20 deletions(-) diff --git a/physics/GFS_suite_interstitial_3.F90 b/physics/GFS_suite_interstitial_3.F90 index 4efcf7a02..ca82f20aa 100644 --- a/physics/GFS_suite_interstitial_3.F90 +++ b/physics/GFS_suite_interstitial_3.F90 @@ -10,7 +10,8 @@ module GFS_suite_interstitial_3 !! subroutine GFS_suite_interstitial_3_run (otsptflag, & im, levs, nn, cscnv,imfshalcnv, imfdeepcnv, & - imfshalcnv_samf, imfdeepcnv_samf,progsigma, & + imfshalcnv_samf, imfdeepcnv_samf, imfdeepcnv_unified, & + imfshalcnv_unified,progsigma, & first_time_step, restart, & satmedmf, trans_trac, do_shoc, ltaerosol, ntrac, ntcw, & ntiw, ntclamt, ntrw, ntsw, ntrnc, ntsnc, ntgl, ntgnc, & @@ -38,7 +39,8 @@ subroutine GFS_suite_interstitial_3_run (otsptflag, & integer, intent(in ), dimension(:) :: islmsk, kpbl, kinver logical, intent(in ) :: cscnv, satmedmf, trans_trac, do_shoc, ltaerosol, ras, progsigma logical, intent(in ) :: first_time_step, restart - integer, intent(in ) :: imfshalcnv, imfdeepcnv, imfshalcnv_samf,imfdeepcnv_samf + integer, intent(in ) :: imfshalcnv, imfdeepcnv, imfshalcnv_samf,imfdeepcnv_samf + integer, intent(in ) :: imfshalcnv_unified,imfdeepcnv_unified integer, intent(in) :: ntinc, ntlnc logical, intent(in) :: ldiag3d, qdiag3d integer, dimension(:,:), intent(in) :: dtidx @@ -81,8 +83,9 @@ subroutine GFS_suite_interstitial_3_run (otsptflag, & ! In case of using prognostic updraf area fraction, initialize area fraction here ! since progsigma_calc is called from both deep and shallow schemes. - if(((imfshalcnv == imfshalcnv_samf) .or. (imfdeepcnv == imfdeepcnv_samf)) & - .and. progsigma)then + if(((imfshalcnv == imfshalcnv_samf) .or. (imfdeepcnv == imfdeepcnv_samf) & + .or. (imfshalcnv == imfshalcnv_unified) .or. (imfdeepcnv == imfdeepcnv_unified)) & + .and. progsigma)then if(first_time_step .and. .not. restart)then do k=1,levs do i=1,im diff --git a/physics/GFS_suite_interstitial_3.meta b/physics/GFS_suite_interstitial_3.meta index fe52a1adc..a6d656a75 100644 --- a/physics/GFS_suite_interstitial_3.meta +++ b/physics/GFS_suite_interstitial_3.meta @@ -57,6 +57,13 @@ dimensions = () type = integer intent = in +[imfdeepcnv_unified] + standard_name = identifier_for_unified_deep_convection + long_name = flag for Unified deep convection scheme + units = flag + dimensions = () + type = integer + intent = in [imfshalcnv] standard_name = control_for_shallow_convection_scheme long_name = flag for mass-flux shallow convection scheme @@ -71,6 +78,13 @@ dimensions = () type = integer intent = in +[imfshalcnv_unified] + standard_name = identifier_for_unified_shallow_convection + long_name = flag for Unified shallow convection scheme + units = flag + dimensions = () + type = integer + intent = in [progsigma] standard_name = do_prognostic_updraft_area_fraction long_name = flag for prognostic sigma in cumuls scheme diff --git a/physics/cu_unified_deep.F90 b/physics/cu_unified_deep.F90 index 2c0dfbedb..6fa0d46f1 100644 --- a/physics/cu_unified_deep.F90 +++ b/physics/cu_unified_deep.F90 @@ -26,8 +26,8 @@ module cu_unified_deep real(kind=kind_phys), parameter :: pgcd = 0.1 ! !> aerosol awareness, do not use yet! - integer, parameter :: autoconv=2 - integer, parameter :: aeroevap=3 + integer, parameter :: autoconv=1 + integer, parameter :: aeroevap=1 real(kind=kind_phys), parameter :: scav_factor = 0.5 !> still 16 ensembles for clousres integer, parameter:: maxens3=16 @@ -1539,6 +1539,7 @@ subroutine cu_unified_deep_run( & !$acc end kernels + !LB: insert calls to updraft vertical veloicity and prognostic area fraction here: call calculate_updraft_velocity(its,itf,ktf,ite,kts,kte,ierr,progsigma, & k22,kbcon,ktop,zo,entr_rate_2d,cd,fv,r_d,el2orc,qeso,tn,qo,po,dbyo, & @@ -1687,6 +1688,7 @@ subroutine cu_unified_deep_run( & enddo endif enddo + !$acc end kernels !> - Call cup_ip_aa0() to calculate workfunctions for updrafts call cup_up_aa0(aa1_bl,zo,zuo,dbyo_bl,gammao_cup_bl,tn_cup_bl, & @@ -1860,7 +1862,6 @@ subroutine cu_unified_deep_run( & enddo - do i=its,itf !trash = 0.0 !trash2 = 0.0 @@ -2187,6 +2188,7 @@ subroutine cu_unified_deep_run( & its,ite, kts,kte, & dicycle,tau_ecmwf,aa1_bl,xf_dicycle,xf_progsigma) ! + !$acc kernels do k=kts,ktf do i=its,itf @@ -2231,6 +2233,7 @@ subroutine cu_unified_deep_run( & enddo !$acc end kernels endif + call cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat_ens,dellaq_ens, & dellaqc_ens,outt, & outq,outqc,zuo,pre,pwo_ens,xmb,ktop,progsigma, & @@ -3603,7 +3606,7 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 !$acc kernels gravinv=1./g do i=its,itf - xf_progsigma(i)=0 + xf_progsigma(i)=0. enddo do i=its,itf if(ierr(i)==0)then @@ -3612,7 +3615,7 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 enddo else do i=its,itf - xf_progsigma(i)=0 + xf_progsigma(i)=0. enddo endif @@ -4219,7 +4222,6 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & do i=its,itf if(ierr(i).eq.0)then xmb(i)=xf_progsigma(i) - write(*,*)'in deep xmb=',xmb(i) endif enddo @@ -5865,7 +5867,6 @@ subroutine calculate_updraft_velocity(its,itf,ktf,ite,kts,kte,ierr,progsigma, !LB: This routine outputs updraft velocity square (m/s), updraft omega_u (Pa/s), and cloud average updraft !velocity (m/s) and omega_u (Pa/s) in the case progsima is true. - do k = 1, ktf do i = 1,itf wu2(i,k)=0. @@ -5973,7 +5974,7 @@ subroutine calculate_updraft_velocity(its,itf,ktf,ite,kts,kte,ierr,progsigma, enddo !> - For progsigma = T, calculate the mean updraft velocity within the cloud (omegac),cast in pressure coordinates. - + if(progsigma)then do i = 1, itf omegac(i) = 0. @@ -6004,6 +6005,7 @@ subroutine calculate_updraft_velocity(its,itf,ktf,ite,kts,kte,ierr,progsigma, enddo !> - For progsigma = T, calculate the xi term in Bengtsson et al. 2022 \cite Bengtsson_2022 (equation 8) + do k = 2, ktf-1 do i = 1, itf if (ierr(i)==0) then @@ -6035,7 +6037,6 @@ subroutine calculate_updraft_velocity(its,itf,ktf,ite,kts,kte,ierr,progsigma, enddo endif - end subroutine calculate_updraft_velocity !------------------------------------------------------------------------------------ diff --git a/physics/cu_unified_sh.F90 b/physics/cu_unified_sh.F90 index c3e2fb755..3d4426b81 100644 --- a/physics/cu_unified_sh.F90 +++ b/physics/cu_unified_sh.F90 @@ -995,7 +995,6 @@ subroutine cu_unified_sh_run ( & gravinv = 1./g if(ierr(i)==0)then xmb(i) = sigmab(i)*((-1.0*omegac(i))*gravinv) - write(*,*)'in shallow xmb=',xmb(i) endif else diff --git a/physics/progsigma_calc.f90 b/physics/progsigma_calc.f90 index dda33d41c..49ac40ebc 100644 --- a/physics/progsigma_calc.f90 +++ b/physics/progsigma_calc.f90 @@ -200,7 +200,6 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & if(cnvflg(i)) then sigmab(i)=sigmab(i)/betascu sigmab(i)=MAX(0.03,sigmab(i)) - write(*,*)'sigmab shallow=',sigmab(i) endif enddo else @@ -208,7 +207,6 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & if(cnvflg(i)) then sigmab(i)=sigmab(i)/betadcu sigmab(i)=MAX(0.01,sigmab(i)) - write(*,*)'sigmab deep=',sigmab(i) endif enddo endif diff --git a/physics/samfdeepcnv.f b/physics/samfdeepcnv.f index dc5236531..d8b6f83f1 100644 --- a/physics/samfdeepcnv.f +++ b/physics/samfdeepcnv.f @@ -2902,8 +2902,6 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & rho = po(i,k)*100. / (rd*to(i,k)) if(progsigma)then xmb(i) = advfac(i)*sigmab(i)*((-1.0*omegac(i))*gravinv) - write(*,*)'in samfdeep xmb=',sigmab(i)* - & ((-1.0*omegac(i))*gravinv) else xmb(i) = advfac(i)*betaw*rho*wc(i) endif diff --git a/physics/samfshalcnv.f b/physics/samfshalcnv.f index 7fec49d62..0e97cb1fe 100644 --- a/physics/samfshalcnv.f +++ b/physics/samfshalcnv.f @@ -1954,8 +1954,6 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & rho = po(i,k)*100. / (rd*to(i,k)) if(progsigma .and. gdx(i) < dxcrtas)then xmb(i) = advfac(i)*sigmab(i)*((-1.0*omegac(i))*gravinv) - write(*,*)'in samfsal xmb=',sigmab(i)* - & ((-1.0*omegac(i))*gravinv) else xmb(i) = advfac(i)*betaw*rho*wc(i) endif From 2b504ec5cb7e7eafda0049c76a7a605f67353a8b Mon Sep 17 00:00:00 2001 From: dustinswales Date: Thu, 16 Mar 2023 13:27:37 -0600 Subject: [PATCH 163/380] Fix missed change in merge. --- physics/rrtmgp_lw_main.meta | 4 ++-- physics/rrtmgp_sw_main.meta | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/physics/rrtmgp_lw_main.meta b/physics/rrtmgp_lw_main.meta index a1a384b25..48db72e37 100644 --- a/physics/rrtmgp_lw_main.meta +++ b/physics/rrtmgp_lw_main.meta @@ -149,8 +149,8 @@ type = logical intent = in [top_at_1] - standard_name = flag_for_vertical_ordering_in_RRTMGP - long_name = flag for vertical ordering in RRTMGP + standard_name = flag_for_vertical_ordering_in_radiation + long_name = flag for vertical ordering in radiation units = flag dimensions = () type = logical diff --git a/physics/rrtmgp_sw_main.meta b/physics/rrtmgp_sw_main.meta index 4ca6cc716..dbb93a5df 100644 --- a/physics/rrtmgp_sw_main.meta +++ b/physics/rrtmgp_sw_main.meta @@ -149,8 +149,8 @@ type = logical intent = in [top_at_1] - standard_name = flag_for_vertical_ordering_in_RRTMGP - long_name = flag for vertical ordering in RRTMGP + standard_name = flag_for_vertical_ordering_in_radiation + long_name = flag for vertical ordering in radiation units = flag dimensions = () type = logical From dcf8a31685223e184a1492ee89e58d3174fb4afc Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Fri, 17 Mar 2023 01:12:48 +0000 Subject: [PATCH 164/380] Taking care of Dustin Wales comments, removing unnecessary comments, cleaning, etc. --- physics/module_sf_ruclsm.F90 | 1070 +++++++++++----------------------- 1 file changed, 338 insertions(+), 732 deletions(-) diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index d0c3db631..4e44bbffd 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -8,7 +8,7 @@ !! and all terms of the surface energy balance and surface water balance. MODULE module_sf_ruclsm - use machine , only : kind_phys + use machine , only : kind_phys, kind_dbl_prec use namelist_soilveg_ruc implicit none @@ -62,7 +62,7 @@ MODULE module_sf_ruclsm !! @{ INTEGER :: SLPCATS INTEGER, PARAMETER :: NSLOPE=30 - REAL :: SBETA_DATA,FXEXP_DATA,CSOIL_DATA,SALP_DATA,REFDK_DATA, & + real (kind=kind_phys) :: SBETA_DATA,FXEXP_DATA,CSOIL_DATA,SALP_DATA,REFDK_DATA, & REFKDT_DATA,FRZK_DATA,ZBOT_DATA, SMLOW_DATA,SMHIGH_DATA, & CZIL_DATA !! @} @@ -183,8 +183,8 @@ SUBROUTINE LSMRUC(xlat,xlon, & ! INTEGER, PARAMETER :: nzss=5 ! INTEGER, PARAMETER :: nddzs=2*(nzss-2) - REAL, INTENT(IN ) :: xlat,xlon - REAL, INTENT(IN ) :: DT + real (kind=kind_phys), INTENT(IN ) :: xlat,xlon + real (kind=kind_phys), INTENT(IN ) :: DT LOGICAL, INTENT(IN ) :: myj,frpcpn,init,lsm_cold_start,exticeden INTEGER, INTENT(IN ) :: NLCAT, NSCAT INTEGER, INTENT(IN ) :: ktau, iter, nsl, isice, iswater, & @@ -193,7 +193,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & ! LOGICAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: flag_iter, flag - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + real (kind=kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme ) , & INTENT(IN ) :: QV3D, & QC3D, & p8w, & @@ -201,7 +201,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & T3D, & z3D - REAL, DIMENSION( ims:ime , jms:jme ), & + real (kind=kind_phys), DIMENSION( ims:ime , jms:jme ), & INTENT(IN ) :: RAINBL, & GLW, & GSWdn, & @@ -215,22 +215,22 @@ SUBROUTINE LSMRUC(xlat,xlon, & VEGFRA, & TBOT - REAL, DIMENSION( ims:ime , jms:jme ), & + real (kind=kind_phys), DIMENSION( ims:ime , jms:jme ), & INTENT(IN ) :: GRAUPELNCV, & SNOWNCV, & RAINCV, & RAINNCV - REAL, DIMENSION( ims:ime), INTENT(IN ) :: RHONEWSN_ex !externally-calculated srf frz precip density + real (kind=kind_phys), DIMENSION( ims:ime), INTENT(IN ) :: RHONEWSN_ex !externally-calculated srf frz precip density - REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: SHDMAX - REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: SHDMIN - REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: hgt - REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: stdev + real (kind=kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: SHDMAX + real (kind=kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: SHDMIN + real (kind=kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: hgt + real (kind=kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: stdev LOGICAL, intent(in) :: rdlai2d - REAL, DIMENSION( 1:nsl), INTENT(IN ) :: ZS + real (kind=kind_phys), DIMENSION( 1:nsl), INTENT(IN ) :: ZS - REAL, DIMENSION( ims:ime , jms:jme ), & + real (kind=kind_phys), DIMENSION( ims:ime , jms:jme ), & INTENT(INOUT) :: & SNOW, & SNOWH, & @@ -246,23 +246,23 @@ SUBROUTINE LSMRUC(xlat,xlon, & Z0 , & ZNT - REAL, DIMENSION( ims:ime , jms:jme ), & + real (kind=kind_phys), DIMENSION( ims:ime , jms:jme ), & INTENT(IN ) :: & FRZFRAC INTEGER, DIMENSION( ims:ime , jms:jme ), & INTENT(IN ) :: IVGTYP, & ISLTYP - REAL, DIMENSION( ims:ime , 1:nlcat, jms:jme ), INTENT(IN):: LANDUSEF - REAL, DIMENSION( ims:ime , 1:nscat, jms:jme ), INTENT(IN):: SOILCTOP + real (kind=kind_phys), DIMENSION( ims:ime , 1:nlcat, jms:jme ), INTENT(IN):: LANDUSEF + real (kind=kind_phys), DIMENSION( ims:ime , 1:nscat, jms:jme ), INTENT(IN):: SOILCTOP - REAL, INTENT(IN ) :: CP,G0,LV,STBOLT,RV,RD,PI, & + real (kind=kind_phys), INTENT(IN ) :: CP,G0,LV,STBOLT,RV,RD,PI, & XICE_threshold - REAL, DIMENSION( ims:ime , 1:nsl, jms:jme ) , & + real (kind=kind_phys), DIMENSION( ims:ime , 1:nsl, jms:jme ) , & INTENT(INOUT) :: SOILMOIS,SH2O,TSO - REAL, DIMENSION( ims:ime, jms:jme ) , & + real (kind=kind_phys), DIMENSION( ims:ime, jms:jme ) , & INTENT(INOUT) :: SOILT, & HFX, & QFX, & @@ -288,11 +288,11 @@ SUBROUTINE LSMRUC(xlat,xlon, & SOILT1, & TSNAV - REAL, DIMENSION( ims:ime, jms:jme ) , & + real (kind=kind_phys), DIMENSION( ims:ime, jms:jme ) , & INTENT(INOUT) :: SMAVAIL, & SMMAX - REAL, DIMENSION( its:ite, jts:jte ) :: & + real (kind=kind_phys), DIMENSION( its:ite, jts:jte ) :: & PC, & SFCRUNOFF, & UDRUNOFF, & @@ -310,7 +310,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & SEAICE, & INFILTR ! Energy and water budget variables: - REAL, DIMENSION( its:ite, jts:jte ) :: & + real (kind=kind_phys), DIMENSION( its:ite, jts:jte ) :: & budget, & acbudget, & waterbudget, & @@ -320,16 +320,16 @@ SUBROUTINE LSMRUC(xlat,xlon, & canwatold - REAL, DIMENSION( ims:ime, 1:nsl, jms:jme) & + real (kind=kind_phys), DIMENSION( ims:ime, 1:nsl, jms:jme) & :: KEEPFR3DFLAG, & SMFR3D - REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: & + real (kind=kind_phys), DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: & RHOSNF, & !RHO of snowfall PRECIPFR, & ! time-step frozen precip SNOWFALLAC !--- soil/snow properties - REAL & + real (kind=kind_phys) & :: RHOCS, & RHONEWSN, & RHOSN, & @@ -347,7 +347,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & SNHEI, & SNWE - REAL :: CN, & + real (kind=kind_phys) :: CN, & SAT,CW, & C1SN, & C2SN, & @@ -356,31 +356,31 @@ SUBROUTINE LSMRUC(xlat,xlon, & KWT - REAL, DIMENSION(1:NSL) :: ZSMAIN, & + real (kind=kind_phys), DIMENSION(1:NSL) :: ZSMAIN, & ZSHALF, & DTDZS2 - REAL, DIMENSION(1:2*(nsl-2)) :: DTDZS + real (kind=kind_phys), DIMENSION(1:2*(nsl-2)) :: DTDZS - REAL, DIMENSION(1:5001) :: TBQ + real (kind=kind_phys), DIMENSION(1:5001) :: TBQ - REAL, DIMENSION( 1:nsl ) :: SOILM1D, & + real (kind=kind_phys), DIMENSION( 1:nsl ) :: SOILM1D, & TSO1D, & SOILICE, & SOILIQW, & SMFRKEEP - REAL, DIMENSION( 1:nsl ) :: KEEPFR + real (kind=kind_phys), DIMENSION( 1:nsl ) :: KEEPFR - REAL, DIMENSION( 1:nlcat ) :: lufrac - REAL, DIMENSION( 1:nscat ) :: soilfrac + real (kind=kind_phys), DIMENSION( 1:nlcat ) :: lufrac + real (kind=kind_phys), DIMENSION( 1:nscat ) :: soilfrac - REAL :: RSM, & - SNWEPRINT, & - SNHEIPRINT + real (kind=kind_phys) :: RSM, & + SNWEPRINT, & + SNHEIPRINT - REAL :: PRCPMS, & + real (kind=kind_phys) :: PRCPMS, & NEWSNMS, & prcpncliq, & prcpncfr, & @@ -401,10 +401,10 @@ SUBROUTINE LSMRUC(xlat,xlon, & icerat, & curat, & INFILTRP - REAL :: cq,r61,r273,arp,brp,x,evs,eis - REAL :: cropsm + real (kind=kind_phys) :: cq,r61,r273,arp,brp,x,evs,eis + real (kind=kind_phys) :: cropsm - REAL :: meltfactor, ac,as, wb,rovcp + real (kind=kind_phys) :: meltfactor, ac,as, wb,rovcp INTEGER :: NROOT INTEGER :: ILAND,ISOIL,IFOREST @@ -701,10 +701,6 @@ SUBROUTINE LSMRUC(xlat,xlon, & DTDZS(K2)=X/(ZSMAIN(K+1)-ZSMAIN(K)) END DO -!27jul2011 - CN and SAT are defined in VEGPARM.TBL -! CN=0.5 ! exponent -! SAT=0.0004 ! canopy water saturated - CW =4.183E6 @@ -719,7 +715,6 @@ SUBROUTINE LSMRUC(xlat,xlon, & !--- Constants for snow density calculations C1SN and C2SN c1sn=0.026 -! c1sn=0.01 c2sn=21. !*********************************************************************** @@ -770,11 +765,9 @@ SUBROUTINE LSMRUC(xlat,xlon, & ENDIF CN=CFACTR_DATA ! exponent -! SAT=max(1.e-5,(min(5.e-4,(CMCMAX_DATA * (1.-exp(-0.5*lai(i,j))) * 0.01*VEGFRA(I,J))))) ! canopy water saturated SAT = 5.e-4 ! units [m] !-- definition of number of soil levels in the rooting zone -! IF(iforest(ivgtyp(i,j)).ne.1) THEN IF(iforest.gt.2) THEN !---- all vegetation types except evergreen and mixed forests !18apr08 - define meltfactor for Egglston melting limit: @@ -861,7 +854,6 @@ SUBROUTINE LSMRUC(xlat,xlon, & PRINT*,' sea-ice at water point, I=',I, & 'J=',J ENDIF -! ILAND = 24 ILAND = isice if(nscat == 9) then ISOIL = 9 ! ZOBLER @@ -870,7 +862,6 @@ SUBROUTINE LSMRUC(xlat,xlon, & endif ZNT(I,J) = 0.011 ! in FV3 albedo and emiss are defined for ice - !snoalb(i,j) = snoalb(i,j) emissl(i,j) = emisbck(i,j) ! no snow impact, old 0.98 used in WRF dqm = 1. ref = 1. @@ -895,9 +886,8 @@ SUBROUTINE LSMRUC(xlat,xlon, & ! or dry soil moisture content for a given soil type) as a state variable. DO k=1,nzs -! soilm1d - soil moisture content minus residual [m**3/m**3] + ! soilm1d - soil moisture content minus residual [m**3/m**3] soilm1d (k) = min(max(0.,soilmois(i,k,j)-qmin),dqm) -! soilm1d (k) = min(max(0.,soilmois(i,k,j)),dqm) tso1d (k) = tso(i,k,j) soiliqw (k) = min(max(0.,sh2o(i,k,j)-qmin),soilm1d(k)) soilice (k) =(soilm1d (k) - soiliqw (k))/0.9 @@ -922,14 +912,11 @@ SUBROUTINE LSMRUC(xlat,xlon, & smtotold(i,j)=0. - !do k=1,nzs-1 do k=1,nroot smtotold(i,j)=smtotold(i,j)+(qmin+soilm1d(k))* & (zshalf(k+1)-zshalf(k)) enddo - !smtotold(i,j)=smtotold(i,j)+(qmin+soilm1d(nzs))* & - ! (zsmain(nzs)-zshalf(nzs)) if (debug_print .and. abs(xlat-testptlat).lt.0.2 & .and. abs(xlon-testptlon).lt.0.2) then print *,'Old soilm1d ',i,soilm1d @@ -984,8 +971,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & !tgs - turn off "irrigation" while there is no fractional landuse and LAI !climatology. IF (lufrac(crop) > 0 .and. lai(i,j) > 1.1) THEN -! IF (ivgtyp(i,j) == crop .and. lai(i,j) > 1.1) THEN -! cropland + ! cropland do k=1,nroot cropsm=1.1*wilt - qmin if(soilm1d(k) < cropsm*lufrac(crop)) then @@ -1002,7 +988,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & enddo ELSEIF (ivgtyp(i,j) == natural .and. lai(i,j) > 0.7) THEN -! grassland: assume that 40% of grassland is irrigated cropland + ! grassland: assume that 40% of grassland is irrigated cropland do k=1,nroot cropsm=1.2*wilt - qmin if(soilm1d(k) < cropsm*lufrac(natural)*0.4) then @@ -1035,11 +1021,6 @@ SUBROUTINE LSMRUC(xlat,xlon, & (zshalf(k+1)-zshalf(k)) enddo - !smavail(i,j)=smavail(i,j)+(qmin+soilm1d(nzs))* & - ! (zsmain(nzs)-zshalf(nzs)) - !smmax (i,j) =smmax (i,j)+(qmin+dqm)* & - ! (zsmain(nzs)-zshalf(nzs)) - if (debug_print) then if (abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2)then print 100,'(RUC runoff) i=',i,' lat,lon=',xlat,xlon, & @@ -1050,11 +1031,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & !--- Convert the water unit into mm !-- three lines below are commented because accumulation ! happens in sfc_drv_ruc - !SFCRUNOFF(I,J) = SFCRUNOFF(I,J)+RUNOFF1(I,J)*DT*1000.0 - !UDRUNOFF (I,J) = UDRUNOFF(I,J)+RUNOFF2(I,J)*DT*1000.0 - !ACRUNOFF (I,J) = ACRUNOFF(i,j)+UDRUNOFF(I,J)+RUNOFF2(I,J)*DT*1000.0 ACRUNOFF(I,J) = (RUNOFF1(I,J)+RUNOFF2(I,J))*DT*1000.0 - !ACRUNOFF(I,J) = ACRUNOFF(i,j)+RUNOFF1(I,J)*DT*1000.0 ! acc surface runoff SMAVAIL (I,J) = SMAVAIL(I,J) * 1000. ! mm SMMAX (I,J) = SMMAX(I,J) * 1000. smtotold (I,J) = smtotold(I,J) * 1000. ! mm @@ -1077,26 +1054,23 @@ SUBROUTINE LSMRUC(xlat,xlon, & !tgs add together dew and cloud at the ground surface !30july13 qcg(i,j)=qcg(i,j)+dew(i,j)/qkms - !Z0 (I,J) = ZNT (I,J) + Z0 (I,J) = ZNT (I,J) SFCEXC (I,J) = TKMS patmb=P8w(i,1,j)*1.e-2 Q2SAT=QSN(TABS,TBQ)/PATMB QSFC(I,J) = QVG(I,J)/(1.+QVG(I,J)) -! for MYJ surface and PBL scheme -! if (myj) then -! MYJSFC expects QSFC as actual specific humidity at the surface + ! for MYJ surface and PBL scheme + ! if (myj) then + ! MYJSFC expects QSFC as actual specific humidity at the surface IF((QVATM.GE.Q2SAT*0.95).AND.QVATM.LT.qvg(I,J))THEN CHKLOWQ(I,J)=0. ELSE CHKLOWQ(I,J)=1. ENDIF -! else -! CHKLOWQ(I,J)=1. -! endif if(snow(i,j)==0.) EMISSL(i,j) = EMISBCK(i,j) EMISS (I,J) = EMISSL(I,J) -! SNOW is in [mm], SNWE is in [m]; CANWAT is in mm, CANWATR is in m + ! SNOW is in [mm], SNWE is in [m]; CANWAT is in mm, CANWATR is in m SNOW (i,j) = SNWE*1000. SNOWH (I,J) = SNHEI CANWAT (I,J) = CANWATR*1000. @@ -1114,7 +1088,6 @@ SUBROUTINE LSMRUC(xlat,xlon, & print *,' LAND, I=,J=, QFX, HFX after SFCTMP', i,j,lh(i,j),hfx(i,j) endif ENDIF -!!! QFX (I,J) = LH(I,J)/LV SFCEVP (I,J) = SFCEVP (I,J) + QFX (I,J) * DT GRDFLX (I,J) = -1. * sflx(I,J) @@ -1126,10 +1099,6 @@ SUBROUTINE LSMRUC(xlat,xlon, & ! endif !--- SNOWC snow cover flag - !if(snowfrac > 0. .and. xice(i,j).ge.xice_threshold ) then - ! SNOWFRAC = SNOWFRAC*XICE(I,J) - !endif - SNOWC(I,J)=SNOWFRAC !--- RHOSNF - density of snowfall @@ -1138,16 +1107,10 @@ SUBROUTINE LSMRUC(xlat,xlon, & ! Accumulated moisture flux [kg/m^2] SFCEVP (I,J) = SFCEVP (I,J) + QFX (I,J) * DT -!TEST!!!! for test put heat budget term in GRDFLX - -! acbudget(i,j)=acbudget(i,j)+budget(i,j)-smf(i,j) -! GRDFLX (I,J) = acbudget(i,j) - -! if(smf(i,j) .ne.0.) then -!tgs - SMF.NE.0. when there is phase change in the top soil layer -! The heat of freezing/thawing of soil water is not computed explicitly -! and is responsible for the residual in the energy budget. -! endif +!--tgs - SMF.NE.0. when there is phase change in the top soil layer +! The heat of freezing/thawing of soil water is not computed explicitly +! and is responsible for the residual in the energy budget. +! endif ! budget(i,j)=budget(i,j)-smf(i,j) if (debug_print ) then @@ -1161,46 +1124,38 @@ SUBROUTINE LSMRUC(xlat,xlon, & ac=canwat(i,j)-canwatold(i,j)*1.e3 ! canopy water change as=snwe-snowold(i,j) ! SWE change wb = smavail(i,j)-smtotold(i,j) - waterbudget(i,j)=rainbl(i,j)+smelt(i,j)*dt*1.e3 & ! source + waterbudget(i,j)=rainbl(i,j)+smelt(i,j)*dt*1.e3_kind_phys & ! source -qfx(i,j)*dt & - -runoff1(i,j)*dt*1.e3-runoff2(i,j)*dt*1.e3 & + -runoff1(i,j)*dt*1.e3_kind_phys-runoff2(i,j)*dt*1.e3_kind_phys & -ac-as ! - (smavail(i,j)-smtotold(i,j)) print *,'soilm1d ',i,soilm1d print 100,'(RUC budgets) i=',i,' lat,lon=',xlat,xlon, & 'budget ',budget(i,j),'waterbudget',waterbudget(i,j), & 'rainbl ',rainbl(i,j),'runoff1 ',runoff1(i,j), & - 'smelt ',smelt(i,j)*dt*1.e3,'smc change ',wb, & + 'smelt ',smelt(i,j)*dt*1.e3_kind_phys,'smc change ',wb, & 'snwe change ',as,'canw change ',ac,'runoff2 ',runoff2(i,j), & 'qfx*dt ',qfx(i,j)*dt,'smavail ',smavail(i,j),'smcold',smtotold(i,j) + !-- + waterbudget(i,j)=rainbl(i,j)-qfx(i,j)*dt-(smavail(i,j)-smtotold(i,j)) & + + print *,'Smf=',smf(i,j),i,j + print *,'Budget',budget(i,j),i,j + print *,'RUNOFF2= ', i,j,runoff2(i,j) + print *,'Water budget ', i,j,waterbudget(i,j),'wb=',wb + print *,'rainbl,qfx*dt,runoff1,smelt*dt*1.e3,smchange', & + i,j,rainbl(i,j),qfx(i,j)*dt,runoff1(i,j)*dt*1.e3, & + smelt(i,j)*dt*1.e3_kind_phys, & + (smavail(i,j)-smtotold(i,j)) +! + print *,'SNOW,SNOWold',i,j,snwe,snowold(i,j) + print *,'SNOW-SNOWold',i,j,max(0._kind_phys,snwe-snowold(i,j)) + print *,'CANWATold, canwat ',i,j,canwatold(i,j),canwat(i,j) + print *,'canwat(i,j)-canwatold(i,j)',max(0._kind_phys,canwat(i,j)-canwatold(i,j)) endif endif - 100 format (";;; ",a,i4,a,2f14.7/(4(a10,'='es14.7))) - !-- - - - -! waterbudget(i,j)=rainbl(i,j)-qfx(i,j)*dt-(smavail(i,j)-smtotold(i,j)) & -!tgs27apr17 acwaterbudget(i,j)=acwaterbudget(i,j)+waterbudget(i,j) - -!!!!TEST use LH to check water budget -! GRDFLX (I,J) = waterbudget(i,j) - -! print *,'Smf=',smf(i,j),i,j -! print *,'Budget',budget(i,j),i,j -! print *,'RUNOFF2= ', i,j,runoff2(i,j) -! print *,'Water budget ', i,j,waterbudget(i,j),'wb=',wb -! print *,'rainbl,qfx*dt,runoff1,smelt*dt*1.e3,smchange', & -! i,j,rainbl(i,j),qfx(i,j)*dt,runoff1(i,j)*dt*1.e3, & -! smelt(i,j)*dt*1.e3, & -! (smavail(i,j)-smtotold(i,j)) -! -! print *,'SNOW,SNOWold',i,j,snwe,snowold(i,j) -! print *,'SNOW-SNOWold',i,j,max(0.,snwe-snowold(i,j)) -! print *,'CANWATold, canwat ',i,j,canwatold(i,j),canwat(i,j) -! print *,'canwat(i,j)-canwatold(i,j)',max(0.,canwat(i,j)-canwatold(i,j)) -! ENDIF + 100 format (";;; ",a,i4,a,2f14.7/(4(a10,'='es14.7))) IF (debug_print ) THEN @@ -1265,17 +1220,17 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia INTEGER, INTENT(IN ) :: isice,i,j,nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) - REAL, INTENT(IN ) :: DELT,CONFLX,meltfactor,xlat,xlon - REAL, INTENT(IN ) :: testptlat,testptlon - REAL, INTENT(IN ) :: C1SN,C2SN,RHONEWSN_ex + real (kind=kind_phys), INTENT(IN ) :: DELT,CONFLX,meltfactor,xlat,xlon + real (kind=kind_phys), INTENT(IN ) :: testptlat,testptlon + real (kind=kind_phys), INTENT(IN ) :: C1SN,C2SN,RHONEWSN_ex LOGICAL, INTENT(IN ) :: myj, debug_print, exticeden !--- 3-D Atmospheric variables - REAL , & + real (kind=kind_phys) , & INTENT(IN ) :: PATM, & TABS, & QVATM, & QCATM - REAL , & + real (kind=kind_phys) , & INTENT(IN ) :: GLW, & GSW, & GSWdn, & @@ -1292,7 +1247,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia INTEGER, INTENT(IN ) :: IVGTYP, ISLTYP !--- 2-D variables - REAL , & + real (kind=kind_phys) , & INTENT(INOUT) :: EMISS, & EMISBCK, & MAVAIL, & @@ -1302,7 +1257,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia CST !--- soil properties - REAL :: & + real (kind=kind_phys) :: & RHOCS, & BCLH, & DQM, & @@ -1314,7 +1269,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia SAT, & WILT - REAL, INTENT(IN ) :: CN, & + real (kind=kind_phys), INTENT(IN ) :: CN, & CW, & CP, & ROVCP, & @@ -1325,26 +1280,26 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia KICE, & KWT - REAL, DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + real (kind=kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & ZSHALF, & DTDZS2 - REAL, DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real (kind=kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - REAL, DIMENSION(1:5001), INTENT(IN) :: TBQ + real (kind=kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ !--- input/output variables !-------- 3-d soil moisture and temperature - REAL, DIMENSION( 1:nzs ) , & + real (kind=kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: TS1D, & SOILM1D, & SMFRKEEP - REAL, DIMENSION( 1:nzs ) , & + real (kind=kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: KEEPFR - REAL, DIMENSION(1:NZS), INTENT(INOUT) :: SOILICE, & + real (kind=kind_phys), DIMENSION(1:NZS), INTENT(INOUT) :: SOILICE, & SOILIQW @@ -1352,7 +1307,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia INTEGER :: ILANDs !-------- 2-d variables - REAL , & + real (kind=kind_phys) , & INTENT(INOUT) :: DEW, & EDIR1, & EC1, & @@ -1392,7 +1347,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia TSNAV, & ZNT - REAL, DIMENSION(1:NZS) :: & + real (kind=kind_phys), DIMENSION(1:NZS) :: & tice, & rhosice, & capice, & @@ -1404,7 +1359,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia SOILICES, & KEEPFRS !-------- 1-d variables - REAL :: & + real (kind=kind_phys) :: & DEWS, & MAVAILS, & EDIR1s, & @@ -1429,23 +1384,23 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia - REAL, INTENT(INOUT) :: RSM, & + real (kind=kind_phys), INTENT(INOUT) :: RSM, & SNWEPRINT, & SNHEIPRINT !--- Local variables INTEGER :: K,ILNB - REAL :: BSN, XSN , & + real (kind=kind_phys) :: BSN, XSN , & RAINF, SNTH, NEWSN, PRCPMS, NEWSNMS , & T3, UPFLUX, XINET, snowfrac2, m - REAL :: snhei_crit, snhei_crit_newsn, keep_snow_albedo, SNOWFRACnewsn - REAL :: newsnowratio, dd1 + real (kind=kind_phys) :: snhei_crit, snhei_crit_newsn, keep_snow_albedo, SNOWFRACnewsn + real (kind=kind_phys) :: newsnowratio, dd1 - REAL :: rhonewgr,rhonewice + real (kind=kind_phys) :: rhonewgr,rhonewice - REAL :: RNET,GSWNEW,GSWIN,EMISSN,ZNTSN,EMISS_snowfree - REAL :: VEGFRAC, snow_mosaic, snfr, vgfr + real (kind=kind_phys) :: RNET,GSWNEW,GSWIN,EMISSN,ZNTSN,EMISS_snowfree + real (kind=kind_phys) :: VEGFRAC, snow_mosaic, snfr, vgfr real :: cice, albice, albsn, drip, dripsn, dripliq real :: interw, intersn, infwater, intwratio @@ -1465,23 +1420,23 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! with vegetation dependent parameters from Noah MP (personal ! communication with Mike Barlage) !-- SNHEI_CRIT is a threshold for fractional snow in isncovr_opt=1 - snhei_crit=0.01601*1.e3/rhosn - snhei_crit_newsn=0.0005*1.e3/rhosn + snhei_crit=0.01601_kind_phys*1.e3_kind_phys/rhosn + snhei_crit_newsn=0.0005*1.e3_kind_phys/rhosn !-- zntsn = z0tbl(isice) - snow_mosaic=0. - snfr = 1. - NEWSN=0. - newsnowratio = 0. - snowfracnewsn=0. - snowfrac2=0. - rhonewsn = 100. - if(snhei == 0.) snowfrac=0. - smelt = 0. - RAINF = 0. - RSM=0. - DD1=0. - INFILTR=0. + snow_mosaic=0._kind_phys + snfr = 1._kind_phys + NEWSN=0._kind_phys + newsnowratio = 0._kind_phys + snowfracnewsn=0._kind_phys + snowfrac2=0._kind_phys + rhonewsn = 100._kind_phys + if(snhei == 0._kind_phys) snowfrac=0._kind_phys + smelt = 0._kind_phys + RAINF = 0._kind_phys + RSM=0._kind_phys + DD1=0._kind_phys + INFILTR=0._kind_phys ! Jul 2016 - Avissar and Pielke (1989) ! This formulation depending on LAI defines relative contribution of the vegetation to ! the total heat fluxes between surface and atmosphere. @@ -1489,29 +1444,29 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! only 86% of the total surface fluxes. ! VGFR=0.01*VEGFRA ! % --> fraction ! VEGFRAC=2.*lai*vgfr/(1.+2.*lai*vgfr) - VEGFRAC=0.01*VEGFRA - drip = 0. - dripsn = 0. - dripliq = 0. - smf = 0. - interw=0. - intersn=0. - infwater=0. + VEGFRAC=0.01_kind_phys*VEGFRA + drip = 0._kind_phys + dripsn = 0._kind_phys + dripliq = 0._kind_phys + smf = 0._kind_phys + interw=0._kind_phys + intersn=0._kind_phys + infwater=0._kind_phys !---initialize local arrays for sea ice do k=1,nzs - tice(k) = 0. - rhosice(k) = 0. - cice = 0. - capice(k) = 0. - thdifice(k) = 0. + tice(k) = 0._kind_phys + rhosice(k) = 0._kind_phys + cice = 0._kind_phys + capice(k) = 0._kind_phys + thdifice(k) = 0._kind_phys enddo GSWnew=GSW GSWin=GSWdn !/(1.-alb) ALBice=ALB_SNOW_FREE ALBsn=alb_snow - EMISSN = 0.99 ! from setemis, from WRF - 0.98 + EMISSN = 0.99_kind_phys ! from setemis, from WRF - 0.98 EMISS_snowfree = EMISBCK ! LEMITBL(IVGTYP) !--- sea ice properties @@ -1535,7 +1490,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia endif IF (debug_print ) THEN -! print *,'I,J,KTAU,QKMS,TKMS', i,j,ktau,qkms,tkms print *,'alb_snow_free',ALB_SNOW_FREE print *,'GSW,GSWnew,GLW,SOILT,EMISS,ALB,ALBice,SNWE',& GSW,GSWnew,GLW,SOILT,EMISS,ALB,ALBice,SNWE @@ -1552,7 +1506,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia !-- snow_mosaic from the previous time step if(snowfrac < 0.75) snow_mosaic = 1. - !if(snowfrac < 0.9) snow_mosaic = 1. newsn=newsnms*delt !---- ACSNOW - run-total snowfall water [mm] @@ -1587,7 +1540,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! of snow, graupel and ice fractions rhosnfall = min(500.,max(58.8,(rhonewsn*snowrat + & -!13mar18 rhosnfall = min(500.,max(76.9,(rhonewsn*snowrat + & rhonewgr*grauprat + rhonewice*icerat + rhonewgr*curat))) if (debug_print) then @@ -1684,23 +1636,19 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! endif !-- update snow cover with accounting for fresh snow - m = 1.0 ! m=1.6 in Niu&Yang, m=1 in CLM + m = 1.0_kind_phys ! m=1.6 in Niu&Yang, m=1 in CLM if(isncovr_opt == 1) then - snowfrac=min(1.,snhei/(2.*snhei_crit)) + snowfrac=min(1._kind_phys,snhei/(2.*snhei_crit)) elseif(isncovr_opt == 2) then - snowfrac=min(1.,snhei/(2.*snhei_crit)) + snowfrac=min(1.,snhei/(2._kind_phys*snhei_crit)) if(ivgtyp == glacier .or. ivgtyp == bare) then !-- sparsely vegetated or land ice snowfrac2 = tanh( snhei/(2.5 * 0.2 *(rhosn/rhonewsn)**m)) - !- TEST - replace rhonewsn with 100 in Niu&Yang - !snowfrac2 = tanh( snhei/(2.5 * znt *(rhosn*1.e-2)**m)) else !-- Niu&Yang: znt=0.01 m for 1 degree (100km) resolution tests ! on 3-km scale use actual roughness, but not higher than 0.2 m. ! The factor is 20 for forests (~100/dx = 33.) snowfrac2 = tanh( snhei/(2.5 *min(0.2,znt) *(rhosn/rhonewsn)**m)) - !- TEST - replace rhonewsn with 100 in Niu&Yang - !snowfrac2 = tanh( snhei/(2.5 *min(0.2,znt) *(rhosn*1.e-2)**m)) endif !-- snow fraction is average between method 1 and 2 snowfrac = 0.5*(snowfrac+snowfrac2) @@ -1711,20 +1659,8 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! snow cover fractions on the 3-km scale. ! This factor is scale dependent. snowfrac = tanh( snhei/(10. * facsnf *(rhosn/rhonewsn)**m)) - !- TEST - replace rhonewsn with 100 in Niu&Yang - !snowfrac = tanh( snhei/(10. * facsnf *(rhosn*1.e-2)**m)) endif -! if(meltfactor > 1.5) then -! if(isltyp > 9 .and. isltyp < 13) then -!24nov15 clay soil types - SNOFRAC < 0.9 -! snowfrac=min(0.9,snowfrac) -! endif -! else -!24nov15 - SNOWFRAC for forests < 0.75 -! snowfrac=min(0.85,snowfrac) -! endif - if(newsn > 0. ) then SNOWFRACnewsn=MIN(1.,SNHEI/SNHEI_CRIT_newsn) endif @@ -1737,21 +1673,14 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia if(ivgtyp == urban) snowfrac=min(0.75,snowfrac) if(snowfrac < 0.75) snow_mosaic = 1. - !if(snowfrac < 0.9) snow_mosaic = 1. KEEP_SNOW_ALBEDO = 0. IF (NEWSN > 0. .and. snowfracnewsn > 0.99 .and. rhosnfall < 450.) THEN -! new snow + ! new snow KEEP_SNOW_ALBEDO = 1. !snow_mosaic=0. ! ??? ENDIF -!7Mar18 - turn off snow mosaic for T<271K to prevent from too warm -! temperature and loss of low-level clouds in HRRR (case 2 Feb. 2018, 15z) -! IF (TABS < 271.) then -! snow_mosaic=0. -! ENDIF - IF (debug_print ) THEN print *,'SNHEI_CRIT,SNOWFRAC,SNHEI_CRIT_newsn,SNOWFRACnewsn', & SNHEI_CRIT,SNOWFRAC,SNHEI_CRIT_newsn,SNOWFRACnewsn @@ -1772,10 +1701,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ENDIF -!--- GSWNEW in-coming solar for snow on land or on ice -! GSWNEW=GSWnew/(1.-ALB) -!-- Time to update snow and ice albedo - IF(SEAICE .LT. 0.5) THEN !----- SNOW on soil !-- ALB dependence on snow depth @@ -1784,13 +1709,12 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! hwlps with these biases.. if( snow_mosaic == 1.) then ALBsn=alb_snow -! ALBsn=max(0.4,alb_snow) if(newsn > 0. .and. KEEP_SNOW_ALBEDO > 0.9 .and. albsn < 0.4) then !-- Albedo correction with fresh snow and deep snow pack !-- will reduce warm bias in western Canada !-- and US West coast, where max snow albedo is low (0.3-0.5). !print *,'ALB increase to 0.7',alb_snow,snhei,snhei_crit,albsn,i,j - !!!!ALBsn = 0.7 + !ALBsn = 0.7 endif Emiss= emissn @@ -1803,7 +1727,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia !-- will reduce warm bias in western Canada !-- and US West coast, where max snow albedo is low (0.3-0.5). !print *,'ALB increase to 0.7',alb_snow,snhei,snhei_crit,albsn,i,j - !!!!ALBsn = 0.7 + !ALBsn = 0.7 !print *,'NO mosaic ALB increase to 0.7',alb_snow,snhei,snhei_crit,alb,i,j endif @@ -1820,10 +1744,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! higher than patchy snow treshold - then snow albedo is not less than 0.55 ! (inspired by the flight from Fairbanks to Seatle) -!test if(cst.ge.0.95*sat .and. snowfrac .gt.0.99)then -! albsn=max(alb_snow,0.55) -! endif - !-- ALB dependence on snow temperature. When snow temperature is !-- below critical value of -10C - no change to albedo. !-- If temperature is higher that -10C then albedo is decreasing. @@ -1831,7 +1751,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia !-- albedo of temperatures below -10C. if(albsn.lt.0.4 .or. keep_snow_albedo==1) then ALB=ALBsn -! ALB=max(0.4,alb_snow) else !-- change albedo when no fresh snow and snow albedo is higher than 0.5 ALB = MIN(ALBSN,MAX(ALBSN - 0.1*(soilt - 263.15)/ & @@ -2120,7 +2039,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia sublim = sublim*snowfrac prcpl = prcpls*(1.-snowfrac) + prcpl*snowfrac fltot = fltots*(1.-snowfrac) + fltot*snowfrac -!alb ALB = MAX(keep_snow_albedo*alb, & MIN((alb_snow_free + (alb - alb_snow_free) * snowfrac), alb)) @@ -2128,12 +2046,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia MIN((emiss_snowfree + & (emissn - emiss_snowfree) * snowfrac), emissn)) -! alb=alb_snow_free*(1.-snowfrac) + alb*snowfrac -! emiss=emiss_snowfree*(1.-snowfrac) + emissn*snowfrac - -! if(abs(fltot) > 2.) then -! print *,'i,j,fltot,snowfrac,fltots',fltot,snowfrac,fltots,i,j -! endif runoff1 = runoff1s*(1.-snowfrac) + runoff1*snowfrac runoff2 = runoff2s*(1.-snowfrac) + runoff2*snowfrac smelt = smelt * snowfrac @@ -2235,15 +2147,11 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia if(ivgtyp == glacier .or. ivgtyp == bare) then !-- sparsely vegetated or land ice snowfrac2 = tanh( snhei/(2.5 * 0.2 *(rhosn/rhonewsn)**m)) - !- TEST - replace rhonewsn with 100 in Niu&Yang - !snowfrac2 = tanh( snhei/(2.5 * znt *(rhosn*1.e-2)**m)) else !-- Niu&Yang: znt=0.01 m for 1 degree (100km) resolution tests ! on 3-km scale use actual roughness, but not higher than 0.2 m. ! The factor is 20 for forests (~100/dx = 33.) snowfrac2 = tanh( snhei/(2.5 *min(0.2,znt) *(rhosn/rhonewsn)**m)) - !- TEST - replace rhonewsn with 100 in Niu&Yang - !snowfrac2 = tanh( snhei/(2.5 *min(0.15,znt) *(rhosn*1.e-2)**m)) endif !-- snow fraction is average between method 1 and 2 snowfrac = 0.5*(snowfrac+snowfrac2) @@ -2254,8 +2162,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! snow cover fractions on the 3-km scale. ! This factor is scale dependent. snowfrac = tanh( snhei/(10. * facsnf *(rhosn/rhonewsn)**m)) - !- TEST - replace rhonewsn with 100 in Niu&Yang - !snowfrac = tanh( snhei/(2.5* min(0.2,znt) *(rhosn*1.e-2)**m)) endif !-- due to steep slopes and blown snow, limit snow fraction in the @@ -2275,7 +2181,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia print *,'Time-step sublim: swe,[kg m-2]',sublim*delt endif - !snowfallac = snowfallac + max(0.,(newsn - rhowater/rhonewsn*smelt*delt*newsnowratio))*1.e3 snowfallac = snowfallac + max(0.,(newsn*rhonewsn - & ! source of snow (swe) [m] (smelt+sublim*1.e-3)*delt*newsnowratio) & ! sink: melting and sublimation, (swe) [m] /rhonewsn)*1.e3 ! snow accumulation in snow depth [mm] @@ -2363,8 +2268,6 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ENDIF -! RETURN -! END !--------------------------------------------------------------- END SUBROUTINE SFCTMP !--------------------------------------------------------------- @@ -2374,10 +2277,10 @@ END SUBROUTINE SFCTMP !! the precomputed table and a given temperature. FUNCTION QSN(TN,T) !**************************************************************** - REAL, DIMENSION(1:5001), INTENT(IN ) :: T - REAL, INTENT(IN ) :: TN + real (kind=kind_phys), DIMENSION(1:5001), INTENT(IN ) :: T + real (kind=kind_phys), INTENT(IN ) :: TN - REAL QSN, R,R1,R2 + real (kind=kind_phys) QSN, R,R1,R2 INTEGER I R=(TN-173.15)/.05+1. @@ -2391,9 +2294,6 @@ FUNCTION QSN(TN,T) 20 R1=T(I) R2=R-I QSN=(T(I+1)-R1)*R2 + R1 -! print *,' in QSN, I,R,R1,R2,T(I+1),TN, QSN', I,R,r1,r2,t(i+1),tn,QSN -! RETURN -! END !----------------------------------------------------------------------- END FUNCTION QSN !------------------------------------------------------------------------ @@ -2483,15 +2383,15 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,iland,isoil - REAL, INTENT(IN ) :: DELT,CONFLX,xlat,xlon + real (kind=kind_phys), INTENT(IN ) :: DELT,CONFLX,xlat,xlon LOGICAL, INTENT(IN ) :: myj !--- 3-D Atmospheric variables - REAL, & + real (kind=kind_phys), & INTENT(IN ) :: PATM, & QVATM, & QCATM !--- 2-D variables - REAL, & + real (kind=kind_phys), & INTENT(IN ) :: GLW, & GSW, & GSWin, & @@ -2505,7 +2405,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & TKMS !--- soil properties - REAL, & + real (kind=kind_phys), & INTENT(IN ) :: RHOCS, & BCLH, & DQM, & @@ -2516,7 +2416,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & REF, & WILT - REAL, INTENT(IN ) :: CN, & + real (kind=kind_phys), INTENT(IN ) :: CN, & CW, & KQWRTZ, & KICE, & @@ -2525,27 +2425,27 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & g0_p - REAL, DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + real (kind=kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & ZSHALF, & DTDZS2 - REAL, DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real (kind=kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - REAL, DIMENSION(1:5001), INTENT(IN) :: TBQ + real (kind=kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ !--- input/output variables !-------- 3-d soil moisture and temperature - REAL, DIMENSION( 1:nzs ) , & + real (kind=kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: TSO, & SOILMOIS, & SMFRKEEP - REAL, DIMENSION( 1:nzs ) , & + real (kind=kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: KEEPFR !-------- 2-d variables - REAL, & + real (kind=kind_phys), & INTENT(INOUT) :: DEW, & CST, & DRIP, & @@ -2569,40 +2469,38 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & SOILT !-------- 1-d variables - REAL, DIMENSION(1:NZS), INTENT(OUT) :: SOILICE, & + real (kind=kind_phys), DIMENSION(1:NZS), INTENT(OUT) :: SOILICE, & SOILIQW !--- Local variables - REAL :: INFILTRP, transum , & + real (kind=kind_phys) :: INFILTRP, transum , & RAINF, PRCPMS , & TABS, T3, UPFLUX, XINET - REAL :: CP,rovcp,G0,LV,STBOLT,xlmelt,dzstop , & + real (kind=kind_phys) :: CP,rovcp,G0,LV,STBOLT,xlmelt,dzstop , & can,epot,fac,fltot,ft,fq,hft , & q1,ras,rhoice,sph , & trans,zn,ci,cvw,tln,tavln,pi , & DD1,CMC2MS,DRYCAN,WETCAN , & INFMAX,RIW, X - REAL, DIMENSION(1:NZS) :: transp,cap,diffu,hydro , & + real (kind=kind_phys), DIMENSION(1:NZS) :: transp,cap,diffu,hydro, & thdif,tranf,tav,soilmoism , & soilicem,soiliqwm,detal , & fwsat,lwsat,told,smold - REAL :: soiltold,smf - REAL :: soilres, alfa, fex, fex_fc, fc, psit + real (kind=kind_phys) :: soiltold,smf + real (kind=kind_phys) :: soilres, alfa, fex, fex_fc, fc, psit INTEGER :: nzs1,nzs2,k !----------------------------------------------------------------- !-- define constants -! STBOLT=5.670151E-8 RHOICE=900. CI=RHOICE*2100. XLMELT=3.35E+5 cvw=cw -! SAT=0.0004 prcpl=prcpms smf=0. @@ -2652,13 +2550,13 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & soilice(k)=(soilmois(k)-soiliqw(k))/RIW !---- melting and freezing is balanced, soil ice cannot increase - if(keepfr(k).eq.1.) then + if(keepfr(k).eq.1._kind_phys) then soilice(k)=min(soilice(k),smfrkeep(k)) - soiliqw(k)=max(0.,soilmois(k)-soilice(k)*riw) + soiliqw(k)=max(0._kind_phys,soilmois(k)-soilice(k)*riw) endif else - soilice(k)=0. + soilice(k)=0._kind_phys soiliqw(k)=soilmois(k) endif @@ -2670,17 +2568,17 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & soilmoism(k)=0.5*(soilmois(k)+soilmois(k+1)) tavln=log(tav(k)/273.15) - if(tavln.lt.0.) then + if(tavln.lt.0._kind_phys) then soiliqwm(k)=(dqm+qmin)*(XLMELT* & (tav(k)-273.15)/tav(k)/9.81/psis) & **(-1./bclh)-qmin fwsat(k)=dqm-soiliqwm(k) lwsat(k)=soiliqwm(k)+qmin - soiliqwm(k)=max(0.,soiliqwm(k)) + soiliqwm(k)=max(0._kind_phys,soiliqwm(k)) soiliqwm(k)=min(soiliqwm(k), soilmoism(k)) soilicem(k)=(soilmoism(k)-soiliqwm(k))/riw !---- melting and freezing is balanced, soil ice cannot increase - if(keepfr(k).eq.1.) then + if(keepfr(k).eq.1._kind_phys) then soilicem(k)=min(soilicem(k), & 0.5*(smfrkeep(k)+smfrkeep(k+1))) soiliqwm(k)=max(0.,soilmoism(k)-soilicem(k)*riw) @@ -2689,16 +2587,16 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & endif else - soilicem(k)=0. + soilicem(k)=0._kind_phys soiliqwm(k)=soilmoism(k) lwsat(k)=dqm+qmin - fwsat(k)=0. + fwsat(k)=0._kind_phys endif ENDDO do k=1,nzs - if(soilice(k).gt.0.) then + if(soilice(k).gt.0._kind_phys) then smfrkeep(k)=soilice(k) else smfrkeep(k)=soilmois(k)/riw @@ -2739,7 +2637,6 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & !--- transpiration may take place. WETCAN=min(0.25,max(0.,(CST/SAT))**CN) -! if(lai > 1.) wetcan=wetcan/lai DRYCAN=1.-WETCAN !************************************************************** @@ -2784,8 +2681,6 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & ! For now we'll go back to ref*0.5 ! 3feb21 - in RRFS testing (fv3-based), ref*0.5 gives too much direct ! evaporation. Therefore , it is replaced with ref*0.7. - !fc=max(qmin,ref*0.5) - !fc=max(qmin,ref*0.7) fc=ref fex_fc=1. if((soilmois(1)+qmin) > fc .or. (qvatm-qvg) > 0.) then @@ -2911,7 +2806,6 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & T3 = STBOLT*SOILTold*SOILTold*SOILTold UPFLUX = T3 * 0.5*(SOILTold+SOILT) XINET = EMISS*(GLW-UPFLUX) -! RNET = GSW + XINET HFT=-TKMS*CP*RHO*(TABS-SOILT) HFX=-TKMS*CP*RHO*(TABS-SOILT) & *(P1000mb*0.00001/Patm)**ROVCP @@ -2937,7 +2831,6 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & CST=CST+DELT*DEW*RAS * vegfrac IF (debug_print ) THEN ! IF(i.eq.374.and.j.eq.310.or. EETA.gt.0.0004) then -! IF(i.eq.440.and.j.eq.180.or. QFX.gt.1000..or.i.eq.417.and.j.eq.540) then print *,'Cond RUC LSM EETA',EETA,eeta*xlv, i,j ENDIF endif ! myj @@ -2958,11 +2851,6 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & CST=max(0.,CST-EC1 * DELT) -! if (EC1 > CMC2MS) then -! EC1 = min(cmc2ms,ec1) -! CST = 0. -! endif - if (myj) then !-- moisture flux for coupling with MYJ PBL EETA=-soilres*QKMS*RAS*(QVATM/(1.+QVATM) - QVG/(1.+QVG))*1.E3 @@ -2974,13 +2862,11 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & print *,'Q1*(1.-vegfrac),EDIR1',Q1*(1.-vegfrac),EDIR1 print *,'CST,WETCAN,DRYCAN',CST,WETCAN,DRYCAN print *,'EC1=',EC1,'ETT1=',ETT1,'CMC2MS=',CMC2MS,'CMC2MS*ras=',CMC2MS*ras -! print *,'MYJ EETA',eeta,eeta*xlv ENDIF !-- actual moisture flux from RUC LSM EETA = (EDIR1 + EC1 + ETT1)*1.E3 IF (debug_print ) THEN ! IF(i.eq.374.and.j.eq.310.or. EETA.gt.0.0004) then -! IF(i.eq.440.and.j.eq.180 .or. qfx.gt.1000..or.i.eq.417.and.j.eq.540) then print *,'RUC LSM EETA',EETA,eeta*xlv ENDIF endif ! myj @@ -3004,7 +2890,6 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & ENDIF if(detal(1) .ne. 0.) then ! SMF - energy of phase change in the first soil layer -! smf=xlmelt*1.e3*(soiliqwm(1)-soiliqwmold(1))/delt smf=fltot IF (debug_print ) THEN print *,'detal(1),xlmelt,soiliqwm(1),delt',detal(1),xlmelt,soiliqwm(1),delt @@ -3052,15 +2937,15 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,iland,isoil - REAL, INTENT(IN ) :: DELT,CONFLX,xlat,xlon + real (kind=kind_phys), INTENT(IN ) :: DELT,CONFLX,xlat,xlon LOGICAL, INTENT(IN ) :: myj, debug_print !--- 3-D Atmospheric variables - REAL, & + real (kind=kind_phys), & INTENT(IN ) :: PATM, & QVATM, & QCATM !--- 2-D variables - REAL, & + real (kind=kind_phys), & INTENT(IN ) :: GLW, & GSW, & EMISS, & @@ -3068,7 +2953,7 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & QKMS, & TKMS !--- sea ice properties - REAL, DIMENSION(1:NZS) , & + real (kind=kind_phys), DIMENSION(1:NZS) , & INTENT(IN ) :: & tice, & rhosice, & @@ -3076,25 +2961,25 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & thdifice - REAL, INTENT(IN ) :: & + real (kind=kind_phys), INTENT(IN ) :: & CW, & XLV - REAL, DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + real (kind=kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & ZSHALF, & DTDZS2 - REAL, DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real (kind=kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - REAL, DIMENSION(1:5001), INTENT(IN) :: TBQ + real (kind=kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ !--- input/output variables !----soil temperature - REAL, DIMENSION( 1:nzs ), INTENT(INOUT) :: TSO + real (kind=kind_phys), DIMENSION( 1:nzs ), INTENT(INOUT) :: TSO !-------- 2-d variables - REAL, & + real (kind=kind_phys), & INTENT(INOUT) :: DEW, & EETA, & EVAPL, & @@ -3109,28 +2994,27 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & SOILT !--- Local variables - REAL :: x,x1,x2,x4,tn,denom - REAL :: RAINF, PRCPMS , & - TABS, T3, UPFLUX, XINET + real (kind=kind_phys) :: x,x1,x2,x4,tn,denom + real (kind=kind_phys) :: RAINF, PRCPMS , & + TABS, T3, UPFLUX, XINET - REAL :: CP,rovcp,G0,LV,STBOLT,xlmelt,dzstop , & + real (kind=kind_phys) :: CP,rovcp,G0,LV,STBOLT,xlmelt,dzstop , & epot,fltot,ft,fq,hft,ras,cvw - REAL :: FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11 , & + real (kind=kind_phys) :: FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11, & PI,H,FKQ,R210,AA,BB,PP,Q1,QS1,TS1,TQ2,TX2 , & TDENOM,QGOLD,SNOH - REAL :: AA1,RHCS, icemelt + real (kind=kind_phys) :: AA1,RHCS, icemelt - REAL, DIMENSION(1:NZS) :: cotso,rhtso + real (kind=kind_phys), DIMENSION(1:NZS) :: cotso,rhtso INTEGER :: nzs1,nzs2,k,k1,kn,kk !----------------------------------------------------------------- !-- define constants -! STBOLT=5.670151E-8 XLMELT=3.35E+5 cvw=cw @@ -3221,7 +3105,6 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & T3 = STBOLT*TN*TN*TN UPFLUX = T3 *0.5*(TN+SOILT) XINET = EMISS*(GLW-UPFLUX) -! RNET = GSW + XINET HFT=-TKMS*CP*RHO*(TABS-SOILT) HFX=-TKMS*CP*RHO*(TABS-SOILT) & *(P1000mb*0.00001/Patm)**ROVCP @@ -3395,7 +3278,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,isoil - REAL, INTENT(IN ) :: DELT,CONFLX,PRCPMS , & + real (kind=kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS, & RAINF,NEWSNOW,RHONEWSN, & testptlat,testptlon, & SNHEI_CRIT,meltfactor,xlat,xlon @@ -3403,12 +3286,12 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & LOGICAL, INTENT(IN ) :: myj !--- 3-D Atmospheric variables - REAL, & + real (kind=kind_phys), & INTENT(IN ) :: PATM, & QVATM, & QCATM !--- 2-D variables - REAL , & + real (kind=kind_phys) , & INTENT(IN ) :: GLW, & GSW, & GSWin, & @@ -3422,7 +3305,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & INTEGER, INTENT(IN ) :: IVGTYP !--- soil properties - REAL , & + real (kind=kind_phys) , & INTENT(IN ) :: RHOCS, & BCLH, & DQM, & @@ -3434,7 +3317,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & SAT, & WILT - REAL, INTENT(IN ) :: CN, & + real (kind=kind_phys), INTENT(IN ) :: CN, & CW, & XLV, & G0_P, & @@ -3443,23 +3326,23 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & KWT - REAL, DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + real (kind=kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & ZSHALF, & DTDZS2 - REAL, DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real (kind=kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - REAL, DIMENSION(1:5001), INTENT(IN) :: TBQ + real (kind=kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ !--- input/output variables !-------- 3-d soil moisture and temperature - REAL, DIMENSION( 1:nzs ) , & + real (kind=kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: TSO, & SOILMOIS, & SMFRKEEP - REAL, DIMENSION( 1:nzs ) , & + real (kind=kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: KEEPFR @@ -3467,7 +3350,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & !-------- 2-d variables - REAL , & + real (kind=kind_phys) , & INTENT(INOUT) :: DEW, & CST, & DRIP, & @@ -3504,35 +3387,35 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & INTEGER, INTENT(INOUT) :: ILNB !-------- 1-d variables - REAL, DIMENSION(1:NZS), INTENT(OUT) :: SOILICE, & - SOILIQW + real (kind=kind_phys), DIMENSION(1:NZS), INTENT(OUT) :: SOILICE, & + SOILIQW - REAL, INTENT(OUT) :: RSM, & - SNWEPRINT, & - SNHEIPRINT + real (kind=kind_phys), INTENT(OUT) :: RSM, & + SNWEPRINT, & + SNHEIPRINT !--- Local variables INTEGER :: nzs1,nzs2,k - REAL :: INFILTRP, TRANSUM , & + real (kind=kind_phys) :: INFILTRP, TRANSUM , & SNTH, NEWSN , & TABS, T3, UPFLUX, XINET , & BETA, SNWEPR,EPDT,PP - REAL :: CP,rovcp,G0,LV,xlvm,STBOLT,xlmelt,dzstop , & + real (kind=kind_phys) :: CP,rovcp,G0,LV,xlvm,STBOLT,xlmelt,dzstop, & can,epot,fac,fltot,ft,fq,hft , & q1,ras,rhoice,sph , & trans,zn,ci,cvw,tln,tavln,pi , & DD1,CMC2MS,DRYCAN,WETCAN , & INFMAX,RIW,DELTSN,H,UMVEG - REAL, DIMENSION(1:NZS) :: transp,cap,diffu,hydro , & + real (kind=kind_phys), DIMENSION(1:NZS) :: transp,cap,diffu,hydro, & thdif,tranf,tav,soilmoism , & soilicem,soiliqwm,detal , & fwsat,lwsat,told,smold - REAL :: soiltold, qgold + real (kind=kind_phys) :: soiltold, qgold - REAL :: RNET, X + real (kind=kind_phys) :: RNET, X !----------------------------------------------------------------- @@ -3540,11 +3423,8 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & XLMELT=3.35E+5 !-- heat of water vapor sublimation XLVm=XLV+XLMELT -! STBOLT=5.670151E-8 !--- SNOW flag -- ISICE -! ILAND=isice - !--- DELTSN - is the threshold for splitting the snow layer into 2 layers. !--- With snow density 400 kg/m^3, this threshold is equal to 7.5 cm, !--- equivalent to 0.03 m SNWE. For other snow densities the threshold is @@ -3560,16 +3440,8 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & x=0. ! increase thinkness of top snow layer from 3 cm SWE to 5 cm SWE -! DELTSN=5.*SNHEI_CRIT -! snth=0.4*SNHEI_CRIT - DELTSN=0.05*1.e3/rhosn snth=0.01*1.e3/rhosn -! snth=0.01601*1.e3/rhosn - -! if(i.eq.442.and.j.eq.260) then -! print *,'deltsn,snhei,snth',i,j,deltsn,snhei,snth -! ENDIF ! For 2-layer snow model when the snow depth is marginally higher than DELTSN, ! reset DELTSN to half of snow depth. @@ -3584,7 +3456,6 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & CI=RHOICE*2100. RAS=RHO*1.E-3 RIW=rhoice*1.e-3 -! MAVAIL=1. RSM=0. DO K=1,NZS @@ -3709,7 +3580,6 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & !--- CALCULATION OF CANOPY WATER (Smirnova et al., 1996, EQ.16) AND DEW SMELT=0. -! DD1=0. H=MAVAIL ! =1. if snowfrac=1 FQ=QKMS @@ -3738,7 +3608,6 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & ENDIF WETCAN=min(0.25,max(0.,(CST/SAT))**CN) -! if(lai > 1.) wetcan=wetcan/lai DRYCAN=1.-WETCAN !************************************************************** @@ -3798,7 +3667,6 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & DO K=1,NROOT TRANSP(K)=vegfrac*RAS*FQ*(QVATM-QSG) & *tranf(K)*DRYCAN/zshalf(NROOT+1) -! IF(TRANSP(K).GT.0.) TRANSP(K)=0. ETT1=ETT1-TRANSP(K) ENDDO DO k=nroot+1,nzs @@ -3888,7 +3756,6 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & T3 = STBOLT*SOILTold*SOILTold*SOILTold UPFLUX = T3 *0.5*(SOILTold+SOILT) XINET = EMISS*(GLW-UPFLUX) -! RNET = GSW + XINET HFX=-TKMS*CP*RHO*(TABS-SOILT) & *(P1000mb*0.00001/Patm)**ROVCP IF (debug_print ) THEN @@ -3932,11 +3799,6 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & CST=max(0.,CST-EC1 * DELT) -! if(EC1 > CMC2MS) then -! EC1 = min(cmc2ms,ec1) -! CST = 0. -! endif - IF (debug_print ) THEN print*,'Q1,umveg,beta',Q1,umveg,beta print *,'wetcan,vegfrac',wetcan,vegfrac @@ -3961,7 +3823,6 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & EETA = (EDIR1 + EC1 + ETT1)*1.E3 ENDIF S=SNFLX - !sublim=EDIR1*1.E3 sublim=Q1*1.E3 !kg m-2 s-1 ! Energy budget FLTOT=RNET-HFT-XLVm*EETA-S-SNOH-x @@ -4018,19 +3879,19 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,isoil - REAL, INTENT(IN ) :: DELT,CONFLX,PRCPMS , & + real (kind=kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS, & RAINF,NEWSNOW,RHONEWSN, & meltfactor,snhei_crit,xlat,xlon real :: rhonewcsn LOGICAL, INTENT(IN ) :: myj !--- 3-D Atmospheric variables - REAL, & + real (kind=kind_phys), & INTENT(IN ) :: PATM, & QVATM, & QCATM !--- 2-D variables - REAL , & + real (kind=kind_phys) , & INTENT(IN ) :: GLW, & GSW, & RHO, & @@ -4038,35 +3899,35 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & TKMS !--- sea ice properties - REAL, DIMENSION(1:NZS) , & + real (kind=kind_phys), DIMENSION(1:NZS) , & INTENT(IN ) :: & tice, & rhosice, & capice, & thdifice - REAL, INTENT(IN ) :: & + real (kind=kind_phys), INTENT(IN ) :: & CW, & XLV - REAL, DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & - ZSHALF, & - DTDZS2 + real (kind=kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + ZSHALF, & + DTDZS2 - REAL, DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real (kind=kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - REAL, DIMENSION(1:5001), INTENT(IN) :: TBQ + real (kind=kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ !--- input/output variables !-------- 3-d soil moisture and temperature - REAL, DIMENSION( 1:nzs ) , & + real (kind=kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: TSO INTEGER, INTENT(INOUT) :: ILAND !-------- 2-d variables - REAL , & + real (kind=kind_phys) , & INTENT(INOUT) :: DEW, & EETA, & RHOSN, & @@ -4094,53 +3955,49 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & INTEGER, INTENT(INOUT) :: ILNB - REAL, INTENT(OUT) :: RSM, & - SNWEPRINT, & - SNHEIPRINT + real (kind=kind_phys), INTENT(OUT) :: RSM, & + SNWEPRINT, & + SNHEIPRINT !--- Local variables INTEGER :: nzs1,nzs2,k,k1,kn,kk - REAL :: x,x1,x2,dzstop,ft,tn,denom + real (kind=kind_phys) :: x,x1,x2,dzstop,ft,tn,denom - REAL :: SNTH, NEWSN , & + real (kind=kind_phys) :: SNTH, NEWSN , & TABS, T3, UPFLUX, XINET , & BETA, SNWEPR,EPDT,PP - REAL :: CP,rovcp,G0,LV,xlvm,STBOLT,xlmelt , & + real (kind=kind_phys) :: CP,rovcp,G0,LV,xlvm,STBOLT,xlmelt , & epot,fltot,fq,hft,q1,ras,rhoice,ci,cvw , & RIW,DELTSN,H - REAL :: rhocsn,thdifsn, & + real (kind=kind_phys) :: rhocsn,thdifsn, & xsn,ddzsn,x1sn,d1sn,d2sn,d9sn,r22sn - REAL :: cotsn,rhtsn,xsn1,ddzsn1,x1sn1,ftsnow,denomsn - REAL :: fso,fsn, & + real (kind=kind_phys) :: cotsn,rhtsn,xsn1,ddzsn1,x1sn1,ftsnow,denomsn + real (kind=kind_phys) :: fso,fsn, & FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11, & FKQ,R210,AA,BB,QS1,TS1,TQ2,TX2, & TDENOM,AA1,RHCS,H1,TSOB, SNPRIM, & SNODIF,SOH,TNOLD,QGOLD,SNOHGNEW - REAL, DIMENSION(1:NZS) :: cotso,rhtso + real (kind=kind_phys), DIMENSION(1:NZS) :: cotso,rhtso - REAL :: RNET,rsmfrac,soiltfrac,hsn,icemelt,rr + real (kind=kind_phys) :: RNET,rsmfrac,soiltfrac,hsn,icemelt,rr integer :: nmelt - REAL :: keff, fact + real (kind=kind_phys) :: keff, fact !----------------------------------------------------------------- XLMELT=3.35E+5 !-- heat of sublimation of water vapor XLVm=XLV+XLMELT -! STBOLT=5.670151E-8 !-- options for snow conductivity: !-- 1 - constant !-- opt 2 - Sturm et al., 1997 - !isncond_opt = 2 keff = 0.265 !--- SNOW flag -- ISICE -! ILAND=isice - !--- DELTSN - is the threshold for splitting the snow layer into 2 layers. !--- With snow density 400 kg/m^3, this threshold is equal to 7.5 cm, !--- equivalent to 0.03 m SNWE. For other snow densities the threshold is @@ -4149,13 +4006,8 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & !--- the top sea ice layer. SNTH is computed using snwe=0.016 m, and !--- equals 4 cm for snow density 400 kg/m^3. -! increase thickness of top snow layer from 3 cm SWE to 5 cm SWE -! DELTSN=5.*SNHEI_CRIT -! snth=0.4*SNHEI_CRIT - DELTSN=0.05*1.e3/rhosn snth=0.01*1.e3/rhosn -! snth=0.01601*1.e3/rhosn ! For 2-layer snow model when the snow depth is marginlly higher than DELTSN, ! reset DELTSN to half of snow depth. @@ -4179,7 +4031,6 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & RHOnewCSN=2090.* RHOnewSN if(isncond_opt == 1) then - !if(newsnow <= 0. .and. snhei > 5.0*SNHEI_crit) then if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). @@ -4202,9 +4053,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & keff = 0.138 - 1.01 * rhosn*1.e-3 + 3.233 * rhosn**2 * 1.e-6 fact = 2. endif - !fact = 1. - !if(newsnow <= 0. .and. snhei > 5.0*SNHEI_crit) then if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). @@ -4506,10 +4355,8 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & if(nmelt.eq.1) go to 220 !--- IF SOILT > 273.15 F then melting of snow can happen -! IF(SOILT.GT.273.15.AND.SNWE.GT.0.) THEN -! if all snow can evaporate, then there is nothing to melt - !IF(SOILT.GT.273.15.AND.SNWEPR-BETA*EPOT*RAS*DELT.GT.0..AND.SNHEI.GT.0.) THEN - IF(SOILT.GT.273.15.AND.BETA.EQ.1..AND.SNHEI.GT.0.) THEN +! if all snow can evaporate, then there is nothing to melt + IF(SOILT.GT.273.15.AND.BETA.EQ.1._kind_phys.AND.SNHEI.GT.0._kind_phys) THEN ! nmelt = 1 soiltfrac=snowfrac*273.15+(1.-snowfrac)*min(271.4,SOILT) @@ -4560,19 +4407,17 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & print *,'RAINF*CVW*PRCPMS*(max(273.15,TABS)-soiltfrac)', & RAINF*CVW*PRCPMS*(max(273.15,TABS)-soiltfrac) ENDIF - SNOH=AMAX1(0.,SNOH) + SNOH=AMAX1(0._kind_phys,SNOH) !-- SMELT is speed of melting in M/S SMELT= SNOH /XLMELT*1.E-3 SMELT=AMIN1(SMELT,SNWEPR/DELT-BETA*EPOT*RAS) - SMELT=AMAX1(0.,SMELT) + SMELT=AMAX1(0._kind_phys,SMELT) IF (debug_print ) THEN print *,'1-SMELT i,j',smelt,i,j ENDIF !18apr08 - Egglston limit SMELT= amin1 (smelt,delt/60.* 5.6E-8*meltfactor*max(1.,(soilt-273.15))) ! SnowMIP -! SMELT= amin1 (smelt,delt/60.* 5.6E-8*meltfactor*min(2.,max(0.001,(tabs-273.15))) ! SnowMIP -! SMELT= amin1 (smelt, 5.6E-8*meltfactor*max(1.,(soilt-273.15))) IF (debug_print ) THEN print *,'2-SMELT i,j',smelt,i,j ENDIF @@ -4613,9 +4458,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & !-- for evaporation and snow melt SNWE = AMAX1(0.,(SNWEPR- & (SMELT+BETA*EPOT*RAS)*DELT & -! (SMELT+BETA*EPOT*RAS)*DELT*snowfrac & ) ) -!!!! soilt=soiltfrac !--- If there is no snow melting then just evaporation !--- or condensation changes SNWE @@ -4624,7 +4467,6 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & EPOT=-QKMS*(QVATM-QSG) SNWE = AMAX1(0.,(SNWEPR- & BETA*EPOT*RAS*DELT)) -! BETA*EPOT*RAS*DELT*snowfrac)) else snwe = 0. endif @@ -4651,11 +4493,9 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & xsn=(rhosn*(snwe-rsm)+1.e3*rsm)/ & snwe rhosn=MIN(MAX(58.8,XSN),500.) -!13mar18 rhosn=MIN(MAX(76.9,XSN),500.) RHOCSN=2090.* RHOSN if(isncond_opt == 1) then - ! if(newsnow <= 0. .and. snhei > 5.0*SNHEI_crit) then if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). @@ -4678,9 +4518,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & keff = 0.138 - 1.01 * rhosn*1.e-3 + 3.233 * rhosn**2 * 1.e-6 fact = 2. endif - !fact = 1. - !if(newsn <= 0. .and. snhei > 5.0*SNHEI_crit) then if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). @@ -4732,7 +4570,6 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & T3 = STBOLT*TNold*TNold*TNold UPFLUX = T3 *0.5*(SOILT+TNold) XINET = EMISS*(GLW-UPFLUX) -! RNET = GSW + XINET HFT=-TKMS*CP*RHO*(TABS-SOILT) HFX=-TKMS*CP*RHO*(TABS-SOILT) & *(P1000mb*0.00001/Patm)**ROVCP @@ -4899,15 +4736,15 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,iland,isoil - REAL, INTENT(IN ) :: DELT,CONFLX,PRCPMS, RAINF,xlat,xlon - REAL, INTENT(INOUT) :: DRYCAN,WETCAN,TRANSUM + real (kind=kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS, RAINF,xlat,xlon + real (kind=kind_phys), INTENT(INOUT) :: DRYCAN,WETCAN,TRANSUM !--- 3-D Atmospheric variables - REAL, & + real (kind=kind_phys), & INTENT(IN ) :: PATM, & QVATM, & QCATM !--- 2-D variables - REAL , & + real (kind=kind_phys) , & INTENT(IN ) :: & EMISS, & RHO, & @@ -4920,17 +4757,17 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & TKMS !--- soil properties - REAL , & + real (kind=kind_phys) , & INTENT(IN ) :: & BCLH, & DQM, & QMIN - REAL , & + real (kind=kind_phys) , & INTENT(IN ) :: & soilres,alfa - REAL, INTENT(IN ) :: CP, & + real (kind=kind_phys), INTENT(IN ) :: CP, & CVW, & XLV, & STBOLT, & @@ -4938,23 +4775,23 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & G0_P - REAL, DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + real (kind=kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & ZSHALF, & THDIF, & CAP - REAL, DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real (kind=kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - REAL, DIMENSION(1:5001), INTENT(IN) :: TBQ + real (kind=kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ !--- input/output variables !-------- 3-d soil moisture and temperature - REAL, DIMENSION( 1:nzs ) , & + real (kind=kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: TSO !-------- 2-d variables - REAL , & + real (kind=kind_phys) , & INTENT(INOUT) :: & MAVAIL, & QVG, & @@ -4965,16 +4802,16 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & !--- Local variables - REAL :: x,x1,x2,x4,dzstop,can,ft,sph , & + real (kind=kind_phys) :: x,x1,x2,x4,dzstop,can,ft,sph , & tn,trans,umveg,denom,fex - REAL :: FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11 , & + real (kind=kind_phys) :: FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11, & PI,H,FKQ,R210,AA,BB,PP,Q1,QS1,TS1,TQ2,TX2 , & TDENOM - REAL :: C,CC,AA1,RHCS,H1, QGOLD + real (kind=kind_phys) :: C,CC,AA1,RHCS,H1, QGOLD - REAL, DIMENSION(1:NZS) :: cotso,rhtso + real (kind=kind_phys), DIMENSION(1:NZS) :: cotso,rhtso INTEGER :: nzs1,nzs2,k,k1,kn,kk, iter @@ -4996,11 +4833,6 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & !****************************************************************************** ! COEFFICIENTS FOR THOMAS ALGORITHM FOR TSO !****************************************************************************** -! did=2.*(ZSMAIN(nzs)-ZSHALF(nzs)) -! h1=DTDZS(8)*THDIF(nzs-1)*(ZSHALF(nzs)-ZSHALF(nzs-1))/did -! cotso(1)=h1/(1.+h1) -! rhtso(1)=(tso(nzs)+h1*(tso(nzs-1)-tso(nzs)))/ -! 1 (1.+h1) cotso(1)=0. rhtso(1)=TSO(NZS) DO 33 K=1,NZS2 @@ -5051,7 +4883,6 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & +RAINF*CVW*PRCPMS*max(273.15,TABS) & )/TDENOM AA1=AA+CC -! AA1=AA*alfa+CC PP=PATM*1.E3 AA1=AA1/PP CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil,xlat,xlon) @@ -5061,7 +4892,6 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & IF (debug_print ) THEN print *,'VILKA1 - TS1,QS1,TQ2,H,TX2,Q1',TS1,QS1,TQ2,H,TX2,Q1 ENDIF -!with alfa go to 100 IF(Q1.LT.QS1) GOTO 100 !--- if no saturation - goto 100 !--- if saturation - goto 90 @@ -5084,13 +4914,12 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & print *,'VILKA2 - TS1,QS1,TQ2,H,TX2,Q1',TS1,QS1,TQ2,H,TX2,Q1 ENDIF IF(Q1.GE.QS1) GOTO 90 -!with alfa 100 continue QSG=QS1 QVG=Q1 ! if( QS1>QVATM .and. QVATM > QVG) then -! very dry soil -! print *,'very dry soils mavail,qvg,qs1,qvatm,ts1',i,j,mavail,qvg,qs1,qvatm,ts1 -! QVG = QVATM + ! very dry soil + ! print *,'very dry soils mavail,qvg,qs1,qvatm,ts1',i,j,mavail,qvg,qs1,qvatm,ts1 + ! QVG = QVATM ! endif TSO(1)=TS1 QCG=0. @@ -5098,20 +4927,6 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & IF (debug_print ) THEN print *,'200 QVG,QSG,QCG,TSO(1)',QVG,QSG,QCG,TSO(1) ENDIF -if(1==2) then - if(qvatm > QSG .and. iter==0) then -!condensation regime - IF (debug_print ) THEN - print *,'turn off canopy evaporation and transpiration' - print *,' QVATM,QVG,QSG,TS1',QVATM,QVG,QSG,TS1 - print *,'before can, umveg ',can,umveg - ENDIF -! can=0. -! umveg=1. - iter=1 -! goto 2111 - endif -endif ! 1==2 IF (debug_print ) THEN if(iter == 1) then print *,'QVATM,QVG,QSG,QCG,TS1',QVATM,QVG,QSG,QCG,TS1 @@ -5227,7 +5042,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,iland,isoil - REAL, INTENT(IN ) :: DELT,CONFLX,PRCPMS , & + real (kind=kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS , & RAINF,NEWSNOW,DELTSN,SNTH , & TABS,TRANSUM,SNWEPR , & testptlat,testptlon , & @@ -5235,12 +5050,12 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & real :: rhonewcsn !--- 3-D Atmospheric variables - REAL, & + real (kind=kind_phys), & INTENT(IN ) :: PATM, & QVATM, & QCATM !--- 2-D variables - REAL , & + real (kind=kind_phys) , & INTENT(IN ) :: GLW, & GSW, & RHO, & @@ -5250,14 +5065,14 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & TKMS !--- soil properties - REAL , & + real (kind=kind_phys) , & INTENT(IN ) :: & BCLH, & DQM, & PSIS, & QMIN - REAL, INTENT(IN ) :: CP, & + real (kind=kind_phys), INTENT(IN ) :: CP, & ROVCP, & CVW, & STBOLT, & @@ -5265,25 +5080,25 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & G0_P - REAL, DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + real (kind=kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & ZSHALF, & THDIF, & CAP, & TRANF - REAL, DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real (kind=kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - REAL, DIMENSION(1:5001), INTENT(IN) :: TBQ + real (kind=kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ !--- input/output variables !-------- 3-d soil moisture and temperature - REAL, DIMENSION( 1:nzs ) , & + real (kind=kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: TSO !-------- 2-d variables - REAL , & + real (kind=kind_phys) , & INTENT(INOUT) :: DEW, & CST, & RHOSN, & @@ -5303,9 +5118,9 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & SOILT1, & TSNAV - REAL, INTENT(INOUT) :: DRYCAN, WETCAN + real (kind=kind_phys), INTENT(INOUT) :: DRYCAN, WETCAN - REAL, INTENT(OUT) :: RSM, & + real (kind=kind_phys), INTENT(OUT) :: RSM, & SNWEPRINT, & SNHEIPRINT INTEGER, INTENT(OUT) :: ilnb @@ -5314,16 +5129,16 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & INTEGER :: nzs1,nzs2,k,k1,kn,kk - REAL :: x,x1,x2,x4,dzstop,can,ft,sph, & + real (kind=kind_phys) :: x,x1,x2,x4,dzstop,can,ft,sph, & tn,trans,umveg,denom - REAL :: cotsn,rhtsn,xsn1,ddzsn1,x1sn1,ftsnow,denomsn + real (kind=kind_phys) :: cotsn,rhtsn,xsn1,ddzsn1,x1sn1,ftsnow,denomsn - REAL :: t3,upflux,xinet,ras, & + real (kind=kind_phys) :: t3,upflux,xinet,ras, & xlmelt,rhocsn,thdifsn, & beta,epot,xsn,ddzsn,x1sn,d1sn,d2sn,d9sn,r22sn - REAL :: fso,fsn, & + real (kind=kind_phys) :: fso,fsn, & FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11, & PI,H,FKQ,R210,AA,BB,PP,Q1,QS1,TS1,TQ2,TX2, & TDENOM,C,CC,AA1,RHCS,H1, & @@ -5331,15 +5146,15 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & smeltg,snohg,snodif,soh, & CMC2MS,TNOLD,QGOLD,SNOHGNEW - REAL, DIMENSION(1:NZS) :: transp,cotso,rhtso - REAL :: edir1, & + real (kind=kind_phys), DIMENSION(1:NZS) :: transp,cotso,rhtso + real (kind=kind_phys) :: edir1, & ec1, & ett1, & eeta, & qfx, & hfx - REAL :: RNET,rsmfrac,soiltfrac,hsn,rr,keff,fact + real (kind=kind_phys) :: RNET,rsmfrac,soiltfrac,hsn,rr,keff,fact integer :: nmelt, iter !----------------------------------------------------------------- @@ -5349,7 +5164,6 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & !-- options for snow conductivity: !-- 1 - constant !-- opt 2 - Sturm et al., 1997 - !isncond_opt = 1 keff = 0.265 do k=1,nzs @@ -5363,10 +5177,8 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & ENDIF XLMELT=3.35E+5 RHOCSN=2090.* RHOSN -!18apr08 - add rhonewcsn RHOnewCSN=2090.* RHOnewSN if(isncond_opt == 1) then - ! if(newsnow <= 0. .and. snhei > 5.0*SNHEI_crit) then if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). @@ -5397,9 +5209,6 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & print *,'SNOWTEMP - xlat,xlon,newsnow,rhonewsn,rhosn,fact,keff',xlat,xlon,newsnow, rhonewsn,rhosn,fact,keff endif - !fact = 1. - - ! if(newsnow <= 0. .and. snhei > 5.0*SNHEI_crit) then if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). @@ -5429,7 +5238,6 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & RSMFRAC = 0. fsn=1. fso=0. -! hsn=snhei NZS1=NZS-1 NZS2=NZS-2 @@ -5440,12 +5248,6 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & !****************************************************************************** ! COEFFICIENTS FOR THOMAS ALGORITHM FOR TSO !****************************************************************************** -! did=2.*(ZSMAIN(nzs)-ZSHALF(nzs)) -! h1=DTDZS(8)*THDIF(nzs-1)*(ZSHALF(nzs)-ZSHALF(nzs-1))/did -! cotso(1)=h1/(1.+h1) -! rhtso(1)=(tso(nzs)+h1*(tso(nzs-1)-tso(nzs)))/ -! 1 (1.+h1) - cotso(1)=0. rhtso(1)=TSO(NZS) DO 33 K=1,NZS2 @@ -5518,7 +5320,6 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & endif ENDIF IF(SNHEI.LT.SNTH.AND.SNHEI.GT.0.) then -! IF(SNHEI.LT.SNTH.AND.SNHEI.GE.0.) then !--- snow is too thin to be treated separately, therefore it !--- is combined with the first soil layer. snprim=SNHEI+zsmain(2) @@ -5691,10 +5492,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & print *,' QVATM,QVG,QSG,TS1',QVATM,QVG,QSG,TS1 print *,'before can, umveg ',can, umveg ENDIF -! can=0. -! umveg=1. iter=1 -! goto 2211 endif IF (debug_print ) THEN @@ -5747,7 +5545,6 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & TSO(1)=SOILT SOILT1=SOILT tsob=TSO(1) -!new tsob=tso(2) ENDIF if(nmelt==1.and.snowfrac==1) then !-- second iteration with full snow cover @@ -5789,7 +5586,6 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & if(nmelt.eq.1) go to 220 !--- IF SOILT > 273.15 F then melting of snow can happen -! IF(SOILT.GT.273.15.AND.SNHEI.GT.0.) THEN ! if all snow can evaporate (beta<1), then there is nothing to melt IF(SOILT.GT.273.15.AND.BETA.EQ.1.AND.SNHEI.GT.0.) THEN !-- snow sublimation and melting @@ -5800,7 +5596,6 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & T3 = STBOLT*TN*TN*TN UPFLUX = T3 * 0.5*(TN + SOILTfrac) XINET = EMISS*(GLW-UPFLUX) -! RNET = GSW + XINET EPOT = -QKMS*(QVATM-QSG) Q1=EPOT*RAS @@ -5819,7 +5614,6 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & DO K=1,NROOT TRANSP(K)=-VEGFRAC*q1 & *TRANF(K)*DRYCAN/zshalf(NROOT+1) -! IF(TRANSP(K).GT.0.) TRANSP(K)=0. ETT1=ETT1-TRANSP(K) ENDDO DO k=nroot+1,nzs @@ -5829,7 +5623,6 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & EDIR1 = Q1*UMVEG * BETA EC1 = Q1 * WETCAN * vegfrac CMC2MS=CST/DELT*RAS -! EC1=MIN(CMC2MS,EC1) EETA = (EDIR1 + EC1 + ETT1)*1.E3 ! to convert from kg m-2 s-1 to m s-1: 1/rho water=1.e-3************ QFX= XLVM * EETA @@ -5884,7 +5677,6 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & !-- (rhosn > 350.) with very warm surface temperatures (>10C) if( (rhosn < 350. .or. (newsnow > 0. .and. rhonewsn < 450.)) .and. soilt < 283. ) then SMELT= amin1 (smelt, delt/60.*5.6E-8*meltfactor*max(1.,(soilt-273.15))) -! SMELT= amin1 (smelt, delt/60.*5.6E-8*meltfactor*min(2.,max(0.001,(tabs-273.15))) ! SnowMIP IF (debug_print ) THEN !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then print *,'3- SMELT',xlat,xlon,smelt,rhosn,rhonewsn,xlat,xlon @@ -5986,11 +5778,9 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & xsn=(rhosn*(snwe-rsm)+1.e3*rsm)/ & snwe rhosn=MIN(MAX(58.8,XSN),500.) -! rhosn=MIN(MAX(76.9,XSN),500.) RHOCSN=2090.* RHOSN if(isncond_opt == 1) then - !if(newsnow<= 0. .and. snhei > 5.0*SNHEI_crit) then if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). @@ -6022,9 +5812,6 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & xlat,xlon,newsnow, rhonewsn,rhosn,fact,keff,keff/rhocsn*fact endif - !fact = 1. - - ! if(newsnow <= 0. .and. snhei > 5.0*SNHEI_crit) then if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). @@ -6229,12 +6016,12 @@ SUBROUTINE SOILMOIST ( debug_print, & !------------------------------------------------------------------ !--- input variables LOGICAL, INTENT(IN ) :: debug_print - REAL, INTENT(IN ) :: DELT + real (kind=kind_phys), INTENT(IN ) :: DELT INTEGER, INTENT(IN ) :: NZS,NDDZS ! input variables - REAL, DIMENSION(1:NZS), INTENT(IN ) :: ZSMAIN, & + real (kind=kind_phys), DIMENSION(1:NZS), INTENT(IN ) :: ZSMAIN, & ZSHALF, & DIFFU, & HYDRO, & @@ -6242,33 +6029,33 @@ SUBROUTINE SOILMOIST ( debug_print, & SOILICE, & DTDZS2 - REAL, DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real (kind=kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - REAL, INTENT(IN ) :: QSG,QVG,QCG,QCATM,QVATM , & + real (kind=kind_phys), INTENT(IN ) :: QSG,QVG,QCG,QCATM,QVATM, & QKMS,VEGFRAC,DRIP,PRCP , & DEW,SMELT,SNOWFRAC , & DQM,QMIN,REF,KSAT,RAS,RIW,SOILRES ! output - REAL, DIMENSION( 1:nzs ) , & + real (kind=kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: SOILMOIS,SOILIQW - REAL, INTENT(INOUT) :: MAVAIL,RUNOFF,RUNOFF2,INFILTRP, & + real (kind=kind_phys), INTENT(INOUT) :: MAVAIL,RUNOFF,RUNOFF2,INFILTRP, & INFMAX ! local variables - REAL, DIMENSION( 1:nzs ) :: COSMC,RHSMC + real (kind=kind_phys), DIMENSION( 1:nzs ) :: COSMC,RHSMC - REAL :: DZS,R1,R2,R3,R4,R5,R6,R7,R8,R9,R10 - REAL :: REFKDT,REFDK,DELT1,F1MAX,F2MAX - REAL :: F1,F2,FD,KDT,VAL,DDT,PX,FK,FKMAX - REAL :: QQ,UMVEG,INFMAX1,TRANS - REAL :: TOTLIQ,FLX,FLXSAT,QTOT - REAL :: DID,X1,X2,X4,DENOM,Q2,Q4 - REAL :: dice,fcr,acrt,frzx,sum,cvfrz + real (kind=kind_phys) :: DZS,R1,R2,R3,R4,R5,R6,R7,R8,R9,R10 + real (kind=kind_phys) :: REFKDT,REFDK,DELT1,F1MAX,F2MAX + real (kind=kind_phys) :: F1,F2,FD,KDT,VAL,DDT,PX,FK,FKMAX + real (kind=kind_phys) :: QQ,UMVEG,INFMAX1,TRANS + real (kind=kind_phys) :: TOTLIQ,FLX,FLXSAT,QTOT + real (kind=kind_phys) :: DID,X1,X2,X4,DENOM,Q2,Q4 + real (kind=kind_phys) :: dice,fcr,acrt,frzx,sum,cvfrz INTEGER :: NZS1,NZS2,K,KK,K1,KN,ialp1,jj,jk @@ -6288,45 +6075,23 @@ SUBROUTINE SOILMOIST ( debug_print, & DID=(ZSMAIN(NZS)-ZSHALF(NZS)) X1=ZSMAIN(NZS)-ZSMAIN(NZS1) -!7may09 DID=(ZSMAIN(NZS)-ZSHALF(NZS))*2. -! DENOM=DID/DELT+DIFFU(NZS1)/X1 -! COSMC(1)=DIFFU(NZS1)/X1/DENOM -! RHSMC(1)=(SOILMOIS(NZS)*DID/DELT -! 1 +TRANSP(NZS)-(HYDRO(NZS)*SOILMOIS(NZS) -! 1 -HYDRO(NZS1)*SOILMOIS(NZS1))*DID -! 1 /X1) /DENOM - DENOM=(1.+DIFFU(nzs1)/X1/DID*DELT+HYDRO(NZS)/(2.*DID)*DELT) COSMC(1)=DELT*(DIFFU(nzs1)/DID/X1 & +HYDRO(NZS1)/2./DID)/DENOM RHSMC(1)=(SOILMOIS(NZS)+TRANSP(NZS)*DELT/ & DID)/DENOM -! RHSMC(1)=(SOILMOIS(NZS)*DID/DELT & -! +TRANSP(NZS)-(HYDRO(NZS)*SOILMOIS(NZS) & -! -HYDRO(NZS1)*SOILMOIS(NZS1))*DID & -! /X1) /DENOM - !12 June 2014 - low boundary condition: 1 - zero diffusion below the lowest ! level; 2 - soil moisture at the low boundary can be lost due to the root uptake. ! So far - no interaction with the water table. DENOM=1.+DIFFU(nzs1)/X1/DID*DELT -!orig DENOM=(1.+DIFFU(nzs1)/X1/DID*DELT+HYDRO(NZS)/DID*DELT) -!orig COSMC(1)=DELT*(DIFFU(nzs1)/DID/X1 & -!orig +HYDRO(NZS1)/2./DID)/DENOM COSMC(1)=DELT*(DIFFU(nzs1)/DID/X1 & +HYDRO(NZS1)/DID)/DENOM -! RHSMC(1)=(SOILMOIS(NZS)+TRANSP(NZS)*DELT/ & -! DID)/DENOM - RHSMC(1)=(SOILMOIS(NZS)-HYDRO(NZS)*DELT/DID*soilmois(nzs) & +TRANSP(NZS)*DELT/DID)/DENOM -!test RHSMC(1)=SOILMOIS(NZS)-HYDRO(NZS)*soilmois(nzs) -!test!!! -!this test gave smoother soil moisture, ovwerall better results COSMC(1)=0. RHSMC(1)=SOILMOIS(NZS) ! @@ -6370,26 +6135,21 @@ SUBROUTINE SOILMOIST ( debug_print, & 191 format (f23.19) -! TOTLIQ=UMVEG*PRCP-DRIP/DELT-UMVEG*DEW*RAS-SMELT - TOTLIQ=PRCP-DRIP/DELT-(1.-VEGFRAC)*DEW*RAS-SMELT IF (debug_print ) THEN print *,'UMVEG*PRCP,DRIP/DELT,UMVEG*DEW*RAS,SMELT', & UMVEG*PRCP,DRIP/DELT,UMVEG*DEW*RAS,SMELT ENDIF -!test 16 may TOTLIQ=UMVEG*PRCP-DRIP/DELT-UMVEG*DEW*RAS-SMELT -!30july13 TOTLIQ=UMVEG*PRCP-DRIP/DELT-SMELT - FLX=TOTLIQ INFILTRP=TOTLIQ ! ----------- FROZEN GROUND VERSION ------------------------- ! REFERENCE FROZEN GROUND PARAMETER, CVFRZ, IS A SHAPE PARAMETER OF -! AREAL DISTRIBUTION FUNCTION OF SOIL ICE CONTENT WHICH EQUALS 1/CV. +! Areal (kind=kind_phys) DISTRIBUTION FUNCTION OF SOIL ICE CONTENT WHICH EQUALS 1/CV. ! CV IS A COEFFICIENT OF SPATIAL VARIATION OF SOIL ICE CONTENT. -! BASED ON FIELD DATA CV DEPENDS ON AREAL MEAN OF FROZEN DEPTH, AND IT -! CLOSE TO CONSTANT = 0.6 IF AREAL MEAN FROZEN DEPTH IS ABOVE 20 CM. +! BASED ON FIELD DATA CV DEPENDS ON Areal (kind=kind_phys) MEAN OF FROZEN DEPTH, AND IT +! CLOSE TO CONSTANT = 0.6 IF Areal (kind=kind_phys) MEAN FROZEN DEPTH IS ABOVE 20 CM. ! THAT IS WHY PARAMETER CVFRZ = 3 (INT{1/0.6*0.6}) ! ! Current logic doesn't allow CVFRZ be bigger than 3 @@ -6473,7 +6233,6 @@ SUBROUTINE SOILMOIST ( debug_print, & FLX=FLX-SOILMOIS(1)*R7 ! R8 is for direct evaporation from soil, which occurs ! only from snow-free areas -! R8=UMVEG*R6 R8=UMVEG*R6*(1.-snowfrac) QTOT=QVATM+QCATM R9=TRANS @@ -6500,7 +6259,6 @@ SUBROUTINE SOILMOIST ( debug_print, & IF (debug_print ) THEN print *,'FLXSAT,FLX,DELT',FLXSAT,FLX,DELT,RUNOFF2 ENDIF -! RUNOFF2=(FLXSAT-FLX) RUNOFF=RUNOFF+(FLXSAT-FLX) ELSE SOILMOIS(1)=min(dqm,max(1.e-8,QQ)) @@ -6515,11 +6273,8 @@ SUBROUTINE SOILMOIST ( debug_print, & DO K=2,NZS KK=NZS-K+1 QQ=COSMC(KK)*SOILMOIS(K-1)+RHSMC(KK) -! QQ=COSMC(KK)*SOILIQW(K-1)+RHSMC(KK) IF (QQ.LT.0.) THEN -! print *,'negative QQ=',qq - SOILMOIS(K)=1.e-8 ELSE IF(QQ.GT.DQM) THEN !-- saturation @@ -6529,12 +6284,8 @@ SUBROUTINE SOILMOIST ( debug_print, & print *,'hydro(k),QQ,DQM,k',hydro(k),QQ,DQM,k ENDIF RUNOFF2=RUNOFF2+((QQ-DQM)*(ZSMAIN(K)-ZSHALF(K)))/DELT -! RUNOFF2=RUNOFF2+(QQ-DQM)*hydro(k) -! print *,'RUNOFF2=',RUNOFF2 ELSE -! print *,'QQ,DQM,k',QQ,DQM,k RUNOFF2=RUNOFF2+((QQ-DQM)*(ZSHALF(K+1)-ZSHALF(K)))/DELT -! RUNOFF2=RUNOFF2+(QQ-DQM)*hydro(k) ENDIF ELSE SOILMOIS(K)=min(dqm,max(1.e-8,QQ)) @@ -6544,13 +6295,7 @@ SUBROUTINE SOILMOIST ( debug_print, & print *,'END soilmois,soiliqw,soilice',soilmois,SOILIQW,soilice*riw ENDIF -! RUNOFF2=RUNOFF2+hydro(nzs)*SOILMOIS(NZS) -! MAVAIL=max(.00001,min(1.,SOILMOIS(1)/DQM)) -! MAVAIL=max(.00001,min(1.,SOILMOIS(1)/(REF-QMIN))) MAVAIL=max(.00001,min(1.,(SOILMOIS(1)/(REF-QMIN)*(1.-snowfrac)+1.*snowfrac))) - -! RETURN -! END !------------------------------------------------------------------- END SUBROUTINE SOILMOIST !------------------------------------------------------------------- @@ -6592,7 +6337,7 @@ SUBROUTINE SOILPROP( debug_print, & !--- soil properties LOGICAL, INTENT(IN ) :: debug_print INTEGER, INTENT(IN ) :: NZS - REAL , & + real (kind=kind_phys) , & INTENT(IN ) :: RHOCS, & BCLH, & DQM, & @@ -6601,12 +6346,12 @@ SUBROUTINE SOILPROP( debug_print, & QWRTZ, & QMIN - REAL, DIMENSION( 1:nzs ) , & + real (kind=kind_phys), DIMENSION( 1:nzs ) , & INTENT(IN ) :: SOILMOIS, & keepfr - REAL, INTENT(IN ) :: CP, & + real (kind=kind_phys), INTENT(IN ) :: CP, & CVW, & RIW, & kqwrtz, & @@ -6618,7 +6363,7 @@ SUBROUTINE SOILPROP( debug_print, & !--- output variables - REAL, DIMENSION(1:NZS) , & + real (kind=kind_phys), DIMENSION(1:NZS) , & INTENT(INOUT) :: cap,diffu,hydro , & thdif,tav , & soilmoism , & @@ -6627,14 +6372,14 @@ SUBROUTINE SOILPROP( debug_print, & fwsat,lwsat !--- local variables - REAL, DIMENSION(1:NZS) :: hk,detal,kasat,kjpl + real (kind=kind_phys), DIMENSION(1:NZS) :: hk,detal,kasat,kjpl - REAL :: x,x1,x2,x4,ws,wd,fact,fach,facd,psif,ci - REAL :: tln,tavln,tn,pf,a,am,ame,h + real (kind=kind_phys) :: x,x1,x2,x4,ws,wd,fact,fach,facd,psif,ci + real (kind=kind_phys) :: tln,tavln,tn,pf,a,am,ame,h INTEGER :: nzs1,k !-- for Johansen thermal conductivity - REAL :: kzero,gamd,kdry,kas,x5,sr,ke + real (kind=kind_phys) :: kzero,gamd,kdry,kas,x5,sr,ke nzs1=nzs-1 @@ -6657,7 +6402,6 @@ SUBROUTINE SOILPROP( debug_print, & !--- Next 3 lines are for Johansen thermal conduct. gamd=(1.-ws)*2700. kdry=(0.135*gamd+64.7)/(2700.-0.947*gamd) - !kas=kqwrtz**qwrtz*kzero**(1.-qwrtz) !-- one more option from Christa's paper if(qwrtz > 0.2) then kas=kqwrtz**qwrtz*kzero**(1.-qwrtz) @@ -6701,9 +6445,6 @@ SUBROUTINE SOILPROP( debug_print, & if(soilicem(k).eq.0.) then sr=max(0.101,x5) ke=log10(sr)+1. -!--- next 2 lines - for coarse soils -! sr=max(0.0501,x5) -! ke=0.7*log10(sr)+1. else ke=x5 endif @@ -6727,15 +6468,11 @@ SUBROUTINE SOILPROP( debug_print, & if(a.ne.0.)facd=1.-a/max(1.e-8,soilmoism(K)) ame=max(1.e-8,ws-riw*soilicem(K)) !--- DIFFU is diffusional conductivity of soil water - diffu(K)=-BCLH*KSAT*PSIS/ame* & + diffu(K)=-BCLH*KSAT*PSIS/ame* & (ws/ame)**3. & *H**(BCLH+2.)*facd endif -! diffu(K)=-BCLH*KSAT*PSIS/dqm & -! *H**(BCLH+2.) - - !--- thdif - thermal diffusivity ! thdif(K)=HK(K)/CAP(K) !--- Use thermal conductivity from Johansen (1975) @@ -6756,7 +6493,7 @@ SUBROUTINE SOILPROP( debug_print, & fach=1.-riw*soilice(k)/max(1.e-8,soilmois(k)) am=max(1.e-8,ws-riw*soilice(k)) !--- HYDRO is hydraulic conductivity of soil water - hydro(K)=min(KSAT,KSAT/am* & + hydro(K)=min(KSAT,KSAT/am* & (soiliqw(K)/am) & **(2.*BCLH+2.) & * fach) @@ -6768,9 +6505,6 @@ SUBROUTINE SOILPROP( debug_print, & print *,'hydro=',hydro ENDIF -! RETURN -! END - !----------------------------------------------------------------------- END SUBROUTINE SOILPROP !----------------------------------------------------------------------- @@ -6800,31 +6534,31 @@ SUBROUTINE TRANSF( debug_print, & LOGICAL, INTENT(IN ) :: debug_print INTEGER, INTENT(IN ) :: nroot,nzs,iland - REAL , & + real (kind=kind_phys) , & INTENT(IN ) :: GSWin, TABS, lai !--- soil properties - REAL , & + real (kind=kind_phys) , & INTENT(IN ) :: DQM, & QMIN, & REF, & PC, & WILT - REAL, DIMENSION(1:NZS), INTENT(IN) :: soiliqw, & + real (kind=kind_phys), DIMENSION(1:NZS), INTENT(IN) :: soiliqw, & ZSHALF !-- output - REAL, DIMENSION(1:NZS), INTENT(OUT) :: TRANF - REAL, INTENT(OUT) :: TRANSUM + real (kind=kind_phys), DIMENSION(1:NZS), INTENT(OUT) :: TRANF + real (kind=kind_phys), INTENT(OUT) :: TRANSUM !-- local variables - REAL :: totliq, did + real (kind=kind_phys) :: totliq, did INTEGER :: k !-- for non-linear root distribution - REAL :: gx,sm1,sm2,sm3,sm4,ap0,ap1,ap2,ap3,ap4 - REAL :: FTEM, PCtot, fsol, f1, cmin, cmax, totcnd - REAL, DIMENSION(1:NZS) :: PART + real (kind=kind_phys) :: gx,sm1,sm2,sm3,sm4,ap0,ap1,ap2,ap3,ap4 + real (kind=kind_phys) :: FTEM, PCtot, fsol, f1, cmin, cmax, totcnd + real (kind=kind_phys), DIMENSION(1:NZS) :: PART !-------------------------------------------------------------------- do k=1,nzs @@ -6895,7 +6629,6 @@ SUBROUTINE TRANSF( debug_print, & ! pctot=min(0.8,max(pc,pc*lai)) endif IF ( debug_print ) THEN -! if (i==421.and.j==280) then print *,'pctot,lai,pc',pctot,lai,pc ENDIF !--- @@ -6907,7 +6640,6 @@ SUBROUTINE TRANSF( debug_print, & FTEM = 1.0 / (1.0 + EXP(0.5 * (TABS - 314.0))) ENDIF IF ( debug_print ) THEN -! if (i==421.and.j==280) then print *,'tabs,ftem',tabs,ftem ENDIF !--- incoming solar function @@ -6933,14 +6665,12 @@ SUBROUTINE TRANSF( debug_print, & fsol = 1. endif IF ( debug_print ) THEN -! if (i==421.and.j==280) then print *,'GSWin,lai,f1,fsol',gswin,lai,f1,fsol ENDIF !--- total conductance totcnd =(cmin + (cmax - cmin)*pctot*ftem*fsol)/cmax IF ( debug_print ) THEN -! if (i==421.and.j==280) then print *,'iland,RGLTBL(iland),RSTBL(iland),RSMAX_DATA,totcnd' & ,iland,RGLTBL(iland),RSTBL(iland),RSMAX_DATA,totcnd ENDIF @@ -6953,7 +6683,6 @@ SUBROUTINE TRANSF( debug_print, & transum=transum+tranf(k) END DO IF ( debug_print ) THEN -! if (i==421.and.j==280) then print *,'transum,TRANF',transum,tranf endif @@ -6970,13 +6699,13 @@ SUBROUTINE VILKA(TN,D1,D2,PP,QS,TS,TT,NSTEP,ii,j,iland,isoil,xlat,xlon) !--- VILKA finds the solution of energy budget at the surface !--- using table T,QS computed from Clausius-Klapeiron !-------------------------------------------------------------- - REAL, DIMENSION(1:5001), INTENT(IN ) :: TT - REAL, INTENT(IN ) :: TN,D1,D2,PP,xlat,xlon + real (kind=kind_phys), DIMENSION(1:5001), INTENT(IN ) :: TT + real (kind=kind_phys), INTENT(IN ) :: TN,D1,D2,PP,xlat,xlon INTEGER, INTENT(IN ) :: NSTEP,ii,j,iland,isoil - REAL, INTENT(OUT ) :: QS, TS + real (kind=kind_phys), INTENT(OUT ) :: QS, TS - REAL :: F1,T1,T2,RN + real (kind=kind_phys) :: F1,T1,T2,RN INTEGER :: I,I1 I=(TN-1.7315E2)/.05+1 @@ -6995,12 +6724,9 @@ SUBROUTINE VILKA(TN,D1,D2,PP,QS,TS,TT,NSTEP,ii,j,iland,isoil,xlat,xlon) TS=T1-.05*RN QS=(TT(I)+(TT(I)-TT(I+1))*RN)/PP GOTO 20 -! 1 PRINT *,'Crash in surface energy budget - STOP' 1 PRINT *,' AVOST IN VILKA Table index= ',I -! PRINT *,TN,D1,D2,PP,NSTEP,I,TT(i),ii,j,iland,isoil print *,'I,J=',ii,j,'LU_index = ',iland, 'Psfc[hPa] = ',pp, 'Tsfc = ',tn print *,'AVOST point at xlat/xlon=',xlat,xlon -! CALL wrf_error_fatal (' Crash in surface energy budget ' ) 20 CONTINUE !----------------------------------------------------------------------- END SUBROUTINE VILKA @@ -7071,7 +6797,7 @@ SUBROUTINE SOILVEGIN ( debug_print, & ! 19 White Sand ! !---------------------------------------------------------------------- - REAL LQMA(nsoilclas),LRHC(nsoilclas), & + real (kind=kind_phys) LQMA(nsoilclas),LRHC(nsoilclas), & LPSI(nsoilclas),LQMI(nsoilclas), & LBCL(nsoilclas),LKAS(nsoilclas), & LWIL(nsoilclas),LREF(nsoilclas), & @@ -7208,7 +6934,7 @@ SUBROUTINE SOILVEGIN ( debug_print, & !---- Below are the arrays for the vegetation parameters - REAL LALB(nvegclas),LMOI(nvegclas),LEMI(nvegclas), & + real (kind=kind_phys) LALB(nvegclas),LMOI(nvegclas),LEMI(nvegclas), & LROU(nvegclas),LTHI(nvegclas),LSIG(nvegclas), & LPC(nvegclas) @@ -7224,8 +6950,6 @@ SUBROUTINE SOILVEGIN ( debug_print, & .95,.95,.94,.98,.95,.95,.85,.92,.93,.92,.85,.95, & .85,.85,.90 / !-- Roughness length is changed for forests and some others -! DATA LROU/.5,.06,.075,.065,.05,.2,.075,.1,.11,.15,.8,.85, & -! 2.0,1.0,.563,.0001,.2,.4,.05,.1,.15,.1,.065,.05/ DATA LROU/.5,.06,.075,.065,.05,.2,.075,.1,.11,.15,.5,.5, & .5,.5,.5,.0001,.2,.4,.05,.1,.15,.1,.065,.05, & .01,.15,.01 / @@ -7235,14 +6959,8 @@ SUBROUTINE SOILVEGIN ( debug_print, & ! !---- still needs to be corrected ! -! DATA LPC/ 15*.8,0.,.8,.8,.5,.5,.5,.5,.5,.0/ DATA LPC /0.4,0.3,0.4,0.4,0.4,0.4,0.4,0.4,0.4,0.4,5*0.55,0.,0.55,0.55, & 0.3,0.3,0.4,0.4,0.3,0.,.3,0.,0./ - -! used in RUC DATA LPC /0.6,6*0.8,0.7,0.75,6*0.8,0.,0.8,0.8, & -! 0.5,0.7,0.6,0.7,0.5,0./ - - !*************************************************************************** @@ -7251,24 +6969,24 @@ SUBROUTINE SOILVEGIN ( debug_print, & ISLTYP LOGICAL, INTENT(IN ) :: myj - REAL, INTENT(IN ) :: SHDMAX - REAL, INTENT(IN ) :: SHDMIN - REAL, INTENT(IN ) :: VEGFRAC - REAL, DIMENSION( 1:NLCAT ), INTENT(IN):: LUFRAC - REAL, DIMENSION( 1:NSCAT ), INTENT(IN):: SOILFRAC + real (kind=kind_phys), INTENT(IN ) :: SHDMAX + real (kind=kind_phys), INTENT(IN ) :: SHDMIN + real (kind=kind_phys), INTENT(IN ) :: VEGFRAC + real (kind=kind_phys), DIMENSION( 1:NLCAT ), INTENT(IN):: LUFRAC + real (kind=kind_phys), DIMENSION( 1:NSCAT ), INTENT(IN):: SOILFRAC - REAL , & + real (kind=kind_phys) , & INTENT ( OUT) :: pc, & msnf, & facsnf - REAL , & + real (kind=kind_phys) , & INTENT (INOUT ) :: emiss, & lai, & znt LOGICAL, intent(in) :: rdlai2d !--- soil properties - REAL , & + real (kind=kind_phys) , & INTENT( OUT) :: RHOCS, & BCLH, & DQM, & @@ -7281,25 +6999,15 @@ SUBROUTINE SOILVEGIN ( debug_print, & INTEGER, INTENT ( OUT) :: iforest character(len=*),intent(out) :: errmsg integer, intent(out) :: errflg -! INTEGER, DIMENSION( 1:(lucats) ) , & -! INTENT ( OUT) :: iforest - - -! INTEGER, DIMENSION( 1:50 ) :: if1 INTEGER :: kstart, kfin, lstart, lfin INTEGER :: k - REAL :: area, factor, znt1, lb - REAL, DIMENSION( 1:NLCAT ) :: ZNTtoday, LAItoday, deltalai + real (kind=kind_phys) :: area, factor, znt1, lb + real (kind=kind_phys), DIMENSION( 1:NLCAT ) :: ZNTtoday, LAItoday, deltalai !*********************************************************************** ! DATA ZS1/0.0,0.05,0.20,0.40,1.6,3.0/ ! o - levels in soil ! DATA ZS2/0.0,0.025,0.125,0.30,1.,2.3/ ! x - levels in soil -! DATA IF1/12*0,1,1,1,12*0/ - -! do k=1,LUCATS -! iforest(k)=if1(k) -! enddo ! Initialize error-handling errflg = 0 @@ -7344,7 +7052,6 @@ SUBROUTINE SOILVEGIN ( debug_print, & endif else LAItoday(k) = LAITBL(K) -! ZNTtoday(k) = Z0TBL(K) ZNTtoday(k) = ZNT ! do not overwrite z0 over water with the table value endif enddo @@ -7429,7 +7136,7 @@ SUBROUTINE SOILVEGIN ( debug_print, & if(mosaic_soil == 1 ) then do k = 1, nscat if(k.ne.14) then ! STATSGO value for water -!exclude watrer points from this loop + !exclude water points from this loop AREA = AREA + soilfrac(k) RHOCS = RHOCS + HC(k)*1.E6*soilfrac(k) BCLH = BCLH + BB(K)*soilfrac(k) @@ -7484,18 +7191,6 @@ SUBROUTINE SOILVEGIN ( debug_print, & QWRTZ = QTZ(ISLTYP) endif endif -! print *,'rhocs,dqm,qmin,qwrtz',j,rhocs,dqm,qmin,qwrtz - -! parameters from the look-up tables -! BCLH = LBCL(ISLTYP) -! DQM = LQMA(ISLTYP)- & -! LQMI(ISLTYP) -! KSAT = LKAS(ISLTYP) -! PSIS = - LPSI(ISLTYP) -! QMIN = LQMI(ISLTYP) -! REF = LREF(ISLTYP) -! WILT = LWIL(ISLTYP) -! QWRTZ = DATQTZ(ISLTYP) !-------------------------------------------------------------------------- END SUBROUTINE SOILVEGIN @@ -7518,33 +7213,33 @@ SUBROUTINE RUCLSMINIT( debug_print, landfrac, fice, min_seaice, & #endif IMPLICIT NONE LOGICAL, INTENT(IN ) :: debug_print - REAL, DIMENSION( ims:ime), INTENT(IN ) :: landfrac, fice - REAL, INTENT(IN ) :: min_seaice + real (kind=kind_phys), DIMENSION( ims:ime), INTENT(IN ) :: landfrac, fice + real (kind=kind_phys), INTENT(IN ) :: min_seaice INTEGER, INTENT(IN ) :: & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & nzs - REAL, DIMENSION( ims:ime, 1:nzs, jms:jme ) , & + real (kind=kind_phys), DIMENSION( ims:ime, 1:nzs, jms:jme ), & INTENT(IN) :: TSLB, & SMOIS INTEGER, DIMENSION( ims:ime, jms:jme ) , & INTENT(INOUT) :: ISLTYP,IVGTYP - REAL, DIMENSION( ims:ime, 1:nzs, jms:jme ) , & + real (kind=kind_phys), DIMENSION( ims:ime, 1:nzs, jms:jme ) , & INTENT(OUT) :: SMFR3D, & SH2O - REAL, DIMENSION( ims:ime, jms:jme ) , & + real (kind=kind_phys), DIMENSION( ims:ime, jms:jme ) , & INTENT(OUT) :: MAVAIL !-- local - REAL, DIMENSION ( 1:nzs ) :: SOILIQW + real (kind=kind_phys), DIMENSION ( 1:nzs ) :: SOILIQW INTEGER :: I,J,L,itf,jtf - REAL :: RIW,XLMELT,TLN,DQM,REF,PSIS,QMIN,BCLH + real (kind=kind_phys) :: RIW,XLMELT,TLN,DQM,REF,PSIS,QMIN,BCLH INTEGER :: errflag @@ -7600,7 +7295,6 @@ SUBROUTINE RUCLSMINIT( debug_print, landfrac, fice, min_seaice, & soiliqw(l)=(dqm+qmin)*(XLMELT* & (tslb(i,l,j)-273.15)/tslb(i,l,j)/9.81/psis) & **(-1./bclh) - !**(-1./bclh)-qmin soiliqw(l)=max(0.,soiliqw(l)) soiliqw(l)=min(soiliqw(l),smois(i,l,j)) sh2o(i,l,j)=soiliqw(l) @@ -7636,21 +7330,6 @@ SUBROUTINE RUCLSMINIT( debug_print, landfrac, fice, min_seaice, & END SUBROUTINE ruclsminit ! -!----------------------------------------------------------------- -! SUBROUTINE RUCLSM_PARM_INIT -!----------------------------------------------------------------- - -! character*9 :: MMINLU, MMINSL - -! MMINLU='MODIS-RUC' -! MMINLU='USGS-RUC' -! MMINSL='STAS-RUC' -! call RUCLSM_SOILVEGPARM( MMINLU, MMINSL) - -!----------------------------------------------------------------- -! END SUBROUTINE RUCLSM_PARM_INIT -!----------------------------------------------------------------- - !----------------------------------------------------------------- !>\ingroup lsm_ruc_group !> This subroutine specifies vegetation related characteristics. @@ -7796,34 +7475,6 @@ SUBROUTINE RUCLSM_SOILVEGPARM( debug_print,MMINLURUC, MMINSL) ! CALL wrf_error_fatal ("Land Use Dataset '"//MMINLURUC//"' not found in VEGPARM.TBL.") ENDIF -! END IF - -! CALL wrf_dm_bcast_string ( LUTYPE , 8 ) -! CALL wrf_dm_bcast_integer ( LUCATS , 1 ) -! CALL wrf_dm_bcast_integer ( IINDEX , 1 ) -! CALL wrf_dm_bcast_integer ( LUMATCH , 1 ) -! CALL wrf_dm_bcast_real ( ALBTBL , NLUS ) -! CALL wrf_dm_bcast_real ( Z0TBL , NLUS ) -! CALL wrf_dm_bcast_real ( LEMITBL , NLUS ) -! CALL wrf_dm_bcast_real ( PCTBL , NLUS ) -! CALL wrf_dm_bcast_real ( SHDTBL , NLUS ) -! CALL wrf_dm_bcast_real ( IFORTBL , NLUS ) -! CALL wrf_dm_bcast_real ( RSTBL , NLUS ) -! CALL wrf_dm_bcast_real ( RGLTBL , NLUS ) -! CALL wrf_dm_bcast_real ( HSTBL , NLUS ) -! CALL wrf_dm_bcast_real ( SNUPTBL , NLUS ) -! CALL wrf_dm_bcast_real ( LAITBL , NLUS ) -! CALL wrf_dm_bcast_real ( MAXALB , NLUS ) -! CALL wrf_dm_bcast_real ( TOPT_DATA , 1 ) -! CALL wrf_dm_bcast_real ( CMCMAX_DATA , 1 ) -! CALL wrf_dm_bcast_real ( CFACTR_DATA , 1 ) -! CALL wrf_dm_bcast_real ( RSMAX_DATA , 1 ) -! CALL wrf_dm_bcast_integer ( BARE , 1 ) -! CALL wrf_dm_bcast_integer ( NATURAL , 1 ) -! CALL wrf_dm_bcast_integer ( CROP , 1 ) -! CALL wrf_dm_bcast_integer ( URBAN , 1 ) - -! !-----READ IN SOIL PROPERTIES FROM SOILPARM.TBL ! ! IF ( wrf_dm_on_monitor() ) THEN @@ -7888,23 +7539,6 @@ SUBROUTINE RUCLSM_SOILVEGPARM( debug_print,MMINLURUC, MMINSL) 2003 CONTINUE CLOSE (19) -! ENDIF - -! CALL wrf_dm_bcast_integer ( LUMATCH , 1 ) -! CALL wrf_dm_bcast_string ( SLTYPE , 8 ) -! CALL wrf_dm_bcast_string ( MMINSL , 8 ) ! since this is reset above, see oct2 ^ -! CALL wrf_dm_bcast_integer ( SLCATS , 1 ) -! CALL wrf_dm_bcast_integer ( IINDEX , 1 ) -! CALL wrf_dm_bcast_real ( BB , NSLTYPE ) -! CALL wrf_dm_bcast_real ( DRYSMC , NSLTYPE ) -! CALL wrf_dm_bcast_real ( HC , NSLTYPE ) -! CALL wrf_dm_bcast_real ( MAXSMC , NSLTYPE ) -! CALL wrf_dm_bcast_real ( REFSMC , NSLTYPE ) -! CALL wrf_dm_bcast_real ( SATPSI , NSLTYPE ) -! CALL wrf_dm_bcast_real ( SATDK , NSLTYPE ) -! CALL wrf_dm_bcast_real ( SATDW , NSLTYPE ) -! CALL wrf_dm_bcast_real ( WLTSMC , NSLTYPE ) -! CALL wrf_dm_bcast_real ( QTZ , NSLTYPE ) IF(LUMATCH.EQ.0)THEN print *, 'SOIl TEXTURE IN INPUT FILE DOES NOT ' @@ -7915,7 +7549,6 @@ SUBROUTINE RUCLSM_SOILVEGPARM( debug_print,MMINLURUC, MMINSL) ! !-----READ IN GENERAL PARAMETERS FROM GENPARM.TBL ! -! IF ( wrf_dm_on_monitor() ) THEN OPEN(19, FILE='GENPARM.TBL',FORM='FORMATTED',STATUS='OLD',IOSTAT=ierr) IF(ierr .NE. OPEN_OK ) THEN print *,& @@ -7961,23 +7594,6 @@ SUBROUTINE RUCLSM_SOILVEGPARM( debug_print,MMINLURUC, MMINSL) READ (19,*)SMHIGH_DATA !sms$serial end CLOSE (19) -! ENDIF - -! CALL wrf_dm_bcast_integer ( NUM_SLOPE , 1 ) -! CALL wrf_dm_bcast_integer ( SLPCATS , 1 ) -! CALL wrf_dm_bcast_real ( SLOPE_DATA , NSLOPE ) -! CALL wrf_dm_bcast_real ( SBETA_DATA , 1 ) -! CALL wrf_dm_bcast_real ( FXEXP_DATA , 1 ) -! CALL wrf_dm_bcast_real ( CSOIL_DATA , 1 ) -! CALL wrf_dm_bcast_real ( SALP_DATA , 1 ) -! CALL wrf_dm_bcast_real ( REFDK_DATA , 1 ) -! CALL wrf_dm_bcast_real ( REFKDT_DATA , 1 ) -! CALL wrf_dm_bcast_real ( FRZK_DATA , 1 ) -! CALL wrf_dm_bcast_real ( ZBOT_DATA , 1 ) -! CALL wrf_dm_bcast_real ( CZIL_DATA , 1 ) -! CALL wrf_dm_bcast_real ( SMLOW_DATA , 1 ) -! CALL wrf_dm_bcast_real ( SMHIGH_DATA , 1 ) - !----------------------------------------------------------------- END SUBROUTINE RUCLSM_SOILVEGPARM @@ -8018,7 +7634,7 @@ SUBROUTINE SOILIN (ISLTYP, DQM, REF, PSIS, QMIN, BCLH ) integer, intent ( in) :: isltyp real, intent ( out) :: dqm,ref,qmin,psis,bclh - REAL LQMA(nsoilclas),LREF(nsoilclas),LBCL(nsoilclas), & + real (kind=kind_phys) LQMA(nsoilclas),LREF(nsoilclas),LBCL(nsoilclas), & LPSI(nsoilclas),LQMI(nsoilclas) !-- LQMA Rawls et al.[1982] @@ -8066,37 +7682,27 @@ END SUBROUTINE SOILIN !>\ingroup lsm_ruc_group !> This function calculates the liquid saturation vapor mixing ratio as !! a function of temperature and pressure (from Thompson scheme). - REAL FUNCTION RSLF(P,T) + real (kind=kind_phys) FUNCTION RSLF(P,T) IMPLICIT NONE - REAL, INTENT(IN):: P, T - REAL:: ESL,X - REAL, PARAMETER:: C0= .611583699E03 - REAL, PARAMETER:: C1= .444606896E02 - REAL, PARAMETER:: C2= .143177157E01 - REAL, PARAMETER:: C3= .264224321E-1 - REAL, PARAMETER:: C4= .299291081E-3 - REAL, PARAMETER:: C5= .203154182E-5 - REAL, PARAMETER:: C6= .702620698E-8 - REAL, PARAMETER:: C7= .379534310E-11 - REAL, PARAMETER:: C8=-.321582393E-13 + real (kind=kind_phys), INTENT(IN):: P, T + real (kind=kind_phys):: ESL,X + real (kind=kind_phys), PARAMETER:: C0= .611583699E03 + real (kind=kind_phys), PARAMETER:: C1= .444606896E02 + real (kind=kind_phys), PARAMETER:: C2= .143177157E01 + real (kind=kind_phys), PARAMETER:: C3= .264224321E-1 + real (kind=kind_phys), PARAMETER:: C4= .299291081E-3 + real (kind=kind_phys), PARAMETER:: C5= .203154182E-5 + real (kind=kind_phys), PARAMETER:: C6= .702620698E-8 + real (kind=kind_phys), PARAMETER:: C7= .379534310E-11 + real (kind=kind_phys), PARAMETER:: C8=-.321582393E-13 X=MAX(-80.,T-273.16) -! print *,'rslfmp',p,t,x -! ESL=612.2*EXP(17.67*X/(T-29.65)) ESL=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8))))))) ESL=MIN(ESL, P*0.15) ! Even with P=1050mb and T=55C, the sat. vap. pres only contributes to ~15% of total pres. RSLF=.622*ESL/max(1.e-4,(P-ESL)) -! ALTERNATIVE -! ; Source: Murphy and Koop, Review of the vapour pressure of ice and -! supercooled water for atmospheric applications, Q. J. R. -! Meteorol. Soc (2005), 131, pp. 1539-1565. -! ESL = EXP(54.842763 - 6763.22 / T - 4.210 * ALOG(T) + 0.000367 * T -! + TANH(0.0415 * (T - 218.8)) * (53.878 - 1331.22 -! / T - 9.44523 * ALOG(T) + 0.014025 * T)) - END FUNCTION RSLF From 1036acfbf585499d74b02cc1645c300a9774496a Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Fri, 17 Mar 2023 17:21:39 +0000 Subject: [PATCH 165/380] do not set wet(i) in random locations --- physics/GFS_surface_composites_inter.F90 | 1 - physics/GFS_surface_composites_post.F90 | 5 ----- physics/sfc_diff.f | 4 ---- 3 files changed, 10 deletions(-) diff --git a/physics/GFS_surface_composites_inter.F90 b/physics/GFS_surface_composites_inter.F90 index a4004bb82..5ceeb6ac8 100644 --- a/physics/GFS_surface_composites_inter.F90 +++ b/physics/GFS_surface_composites_inter.F90 @@ -62,7 +62,6 @@ subroutine GFS_surface_composites_inter_run (im, dry, icy, wet, semis_wat, semis ! --- ... define the downward lw flux absorbed by ground do i=1,im - if(use_lake_model(i)>0.0) wet(i)=.true. if (dry(i)) gabsbdlw_lnd(i) = semis_lnd(i) * adjsfcdlw(i) if (icy(i)) gabsbdlw_ice(i) = semis_ice(i) * adjsfcdlw(i) if (wet(i)) gabsbdlw_wat(i) = semis_wat(i) * adjsfcdlw(i) diff --git a/physics/GFS_surface_composites_post.F90 b/physics/GFS_surface_composites_post.F90 index 9683eac83..ab7528a62 100644 --- a/physics/GFS_surface_composites_post.F90 +++ b/physics/GFS_surface_composites_post.F90 @@ -88,11 +88,6 @@ subroutine GFS_surface_composites_post_run ( errflg = 0 ! --- generate ocean/land/ice composites - do i=1, im - if(use_lake_model(i) > 0.0) then - wet(i) = .true. - endif - enddo fractional_grid: if (frac_grid) then diff --git a/physics/sfc_diff.f b/physics/sfc_diff.f index 0c452c58f..4da342cd7 100644 --- a/physics/sfc_diff.f +++ b/physics/sfc_diff.f @@ -167,10 +167,6 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! ps is in pascals, wind is wind speed, ! surface roughness length is converted to m from cm ! - do i=1,im - if(use_lake_model(i) > 0) wet(i) = .true. - enddo - ! write(0,*)'in sfc_diff, sfc_z0_type=',sfc_z0_type do i=1,im From 5f43b2b20365edd3055590f409bc7c33eebc6b8e Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Fri, 17 Mar 2023 19:51:42 +0000 Subject: [PATCH 166/380] Address reviewers comments in the RUC LSM driver. --- physics/lsm_ruc.F90 | 321 ++++++++++++++++++++------------------------ 1 file changed, 148 insertions(+), 173 deletions(-) diff --git a/physics/lsm_ruc.F90 b/physics/lsm_ruc.F90 index 9215a0ae1..a8afa7f92 100644 --- a/physics/lsm_ruc.F90 +++ b/physics/lsm_ruc.F90 @@ -3,7 +3,7 @@ module lsm_ruc - use machine, only: kind_phys + use machine, only: kind_phys, kind_dbl_prec use namelist_soilveg_ruc use set_soilveg_ruc_mod, only: set_soilveg_ruc @@ -16,8 +16,8 @@ module lsm_ruc public :: lsm_ruc_init, lsm_ruc_run, lsm_ruc_finalize - real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys, epsln = 1.0e-10_kind_phys - real(kind=kind_phys), dimension (2), parameter, private :: d = (/0.1,0.25/) + real(kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys, epsln = 1.0e-10_kind_phys + real(kind_phys), dimension (2), parameter, private :: d = (/0.1,0.25/) integer, dimension(20), parameter, private:: & istwe = (/1,1,1,1,1,2,2,1,1,2,2,2,2,2,1,2,2,1,2,2/) ! IGBP 20 classes @@ -57,60 +57,60 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & integer, intent(in) :: kice integer, intent(in) :: nlev integer, intent(in) :: lsm_ruc, lsm - real (kind=kind_phys),intent(in) :: con_fvirt - real (kind=kind_phys),intent(in) :: con_rd + real (kind_phys),intent(in) :: con_fvirt + real (kind_phys),intent(in) :: con_rd - real (kind=kind_phys), dimension(:), intent(in) :: slmsk + real (kind_phys), dimension(:), intent(in) :: slmsk integer, dimension(:), intent(in) :: stype integer, dimension(:), intent(in) :: vtype - real (kind=kind_phys), dimension(:), intent(in) :: landfrac - real (kind=kind_phys), dimension(:), intent(in) :: q1 - real (kind=kind_phys), dimension(:), intent(in) :: prsl1 - real (kind=kind_phys), dimension(:), intent(in) :: tsfc_lnd - real (kind=kind_phys), dimension(:), intent(in) :: tsfc_ice - real (kind=kind_phys), dimension(:), intent(in) :: tsfc_wat - real (kind=kind_phys), dimension(:), intent(in) :: tg3 - real (kind=kind_phys), dimension(:), intent(in) :: sncovr_lnd - real (kind=kind_phys), dimension(:), intent(in) :: sncovr_ice - real (kind=kind_phys), dimension(:), intent(in) :: snoalb - real (kind=kind_phys), dimension(:), intent(in) :: fice - real (kind=kind_phys), dimension(:), intent(in) :: facsf - real (kind=kind_phys), dimension(:), intent(in) :: facwf - real (kind=kind_phys), dimension(:), intent(in) :: alvsf - real (kind=kind_phys), dimension(:), intent(in) :: alvwf - real (kind=kind_phys), dimension(:), intent(in) :: alnsf - real (kind=kind_phys), dimension(:), intent(in) :: alnwf - - real (kind=kind_phys), dimension(:,:), intent(in) :: smc,slc,stc - real (kind=kind_phys), intent(in) :: min_seaice + real (kind_phys), dimension(:), intent(in) :: landfrac + real (kind_phys), dimension(:), intent(in) :: q1 + real (kind_phys), dimension(:), intent(in) :: prsl1 + real (kind_phys), dimension(:), intent(in) :: tsfc_lnd + real (kind_phys), dimension(:), intent(in) :: tsfc_ice + real (kind_phys), dimension(:), intent(in) :: tsfc_wat + real (kind_phys), dimension(:), intent(in) :: tg3 + real (kind_phys), dimension(:), intent(in) :: sncovr_lnd + real (kind_phys), dimension(:), intent(in) :: sncovr_ice + real (kind_phys), dimension(:), intent(in) :: snoalb + real (kind_phys), dimension(:), intent(in) :: fice + real (kind_phys), dimension(:), intent(in) :: facsf + real (kind_phys), dimension(:), intent(in) :: facwf + real (kind_phys), dimension(:), intent(in) :: alvsf + real (kind_phys), dimension(:), intent(in) :: alvwf + real (kind_phys), dimension(:), intent(in) :: alnsf + real (kind_phys), dimension(:), intent(in) :: alnwf + + real (kind_phys), dimension(:,:), intent(in) :: smc,slc,stc + real (kind_phys), intent(in) :: min_seaice ! --- in/out: - real (kind=kind_phys), dimension(:), intent(inout) :: wetness + real (kind_phys), dimension(:), intent(inout) :: wetness ! --- inout - real (kind=kind_phys), dimension(:,:), intent(inout) :: sh2o, smfrkeep - real (kind=kind_phys), dimension(:,:), intent(inout) :: tslb, smois - real (kind=kind_phys), dimension(:), intent(inout) :: semis_lnd - real (kind=kind_phys), dimension(:), intent(inout) :: semis_ice - real (kind=kind_phys), dimension(:), intent(inout) :: & - albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, & - albdvis_ice, albdnir_ice, albivis_ice, albinir_ice, & - sfcqv_lnd, sfcqv_ice + real (kind_phys), dimension(:,:), intent(inout) :: sh2o, smfrkeep + real (kind_phys), dimension(:,:), intent(inout) :: tslb, smois + real (kind_phys), dimension(:), intent(inout) :: semis_lnd + real (kind_phys), dimension(:), intent(inout) :: semis_ice + real (kind_phys), dimension(:), intent(inout) :: & + albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, & + albdvis_ice, albdnir_ice, albivis_ice, albinir_ice, & + sfcqv_lnd, sfcqv_ice ! --- out - real (kind=kind_phys), dimension(:), intent(out) :: zs - real (kind=kind_phys), dimension(:), intent(inout) :: sfalb_lnd_bck - real (kind=kind_phys), dimension(:,:), intent(inout) :: tsice - real (kind=kind_phys), dimension(:), intent(out) :: semisbase - real (kind=kind_phys), dimension(:), intent(out) :: pores, resid + real (kind_phys), dimension(:), intent(out) :: zs + real (kind_phys), dimension(:), intent(inout) :: sfalb_lnd_bck + real (kind_phys), dimension(:,:), intent(inout) :: tsice + real (kind_phys), dimension(:), intent(out) :: semisbase + real (kind_phys), dimension(:), intent(out) :: pores, resid character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg ! --- local - real (kind=kind_phys), dimension(lsoil_ruc) :: dzs - real (kind=kind_phys) :: alb_lnd, alb_ice - real (kind=kind_phys) :: q0, qs1 + real (kind_phys), dimension(lsoil_ruc) :: dzs + real (kind_phys) :: alb_lnd, alb_ice + real (kind_phys) :: q0, qs1 integer :: ipr, i, k logical :: debug_print @@ -367,8 +367,8 @@ subroutine lsm_ruc_run & ! inputs implicit none ! --- constant parameters: - real(kind=kind_phys), parameter :: rhoh2o = 1000.0 - real(kind=kind_phys), parameter :: stbolt = 5.670400e-8 + real(kind_phys), parameter :: rhoh2o = 1000.0 + real(kind_phys), parameter :: stbolt = 5.670400e-8 ! --- input: integer, intent(in) :: me, master @@ -377,10 +377,10 @@ subroutine lsm_ruc_run & ! inputs integer, intent(in) :: lsm_ruc, lsm integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, & imp_physics_nssl - real (kind=kind_phys), dimension(:), intent(in) :: xlat_d, xlon_d - real (kind=kind_phys), dimension(:), intent(in) :: oro, sigma + real (kind_phys), dimension(:), intent(in) :: xlat_d, xlon_d + real (kind_phys), dimension(:), intent(in) :: oro, sigma - real (kind=kind_phys), dimension(:), intent(in) :: & + real (kind_phys), dimension(:), intent(in) :: & & t1, sigmaf, laixy, dlwflx, dswsfc, tg3, & & coszen, prsl1, wind, shdmin, shdmax, & & sfalb_lnd_bck, snoalb, zf, qc, q1, & @@ -391,8 +391,8 @@ subroutine lsm_ruc_run & ! inputs ! for ice & cm_ice, ch_ice - real (kind=kind_phys), intent(in) :: delt, min_seaice, min_lakeice - real (kind=kind_phys), intent(in) :: con_cp, con_rv, con_g, & + real (kind_phys), intent(in) :: delt, min_seaice, min_lakeice + real (kind_phys), intent(in) :: con_cp, con_rv, con_g, & con_pi, con_rd, & con_hvap, con_hfus, con_fvirt @@ -409,12 +409,12 @@ subroutine lsm_ruc_run & ! inputs integer, dimension(:), intent(inout) :: stype integer, dimension(:), intent(in) :: vtype - real (kind=kind_phys), dimension(:,:), intent(in) :: vegtype_frac - real (kind=kind_phys), dimension(:,:), intent(in) :: soiltype_frac + real (kind_phys), dimension(:,:), intent(in) :: vegtype_frac + real (kind_phys), dimension(:,:), intent(in) :: soiltype_frac - real (kind=kind_phys), dimension(:), intent(in) :: zs - real (kind=kind_phys), dimension(:), intent(in) :: srflag - real (kind=kind_phys), dimension(:), intent(inout) :: & + real (kind_phys), dimension(:), intent(in) :: zs + real (kind_phys), dimension(:), intent(in) :: srflag + real (kind_phys), dimension(:), intent(inout) :: & & canopy, trans, smcwlt2, smcref2, & ! for land & weasd_lnd, snwdph_lnd, tskin_lnd, & @@ -426,15 +426,15 @@ subroutine lsm_ruc_run & ! inputs & sfcqc_ice, sfcqv_ice, fice ! --- in - real (kind=kind_phys), dimension(:), intent(in) :: & + real (kind_phys), dimension(:), intent(in) :: & & rainnc, rainc, ice, snow, graupel, rhonewsn1 ! --- in/out: ! --- on RUC levels - real (kind=kind_phys), dimension(:,:), intent(inout) :: & + real (kind_phys), dimension(:,:), intent(inout) :: & & smois, tsice, tslb, sh2o, keepfr, smfrkeep ! --- output: - real (kind=kind_phys), dimension(:), intent(inout) :: & + real (kind_phys), dimension(:), intent(inout) :: & & rhosnf, runof, drain, runoff, srunoff, evbs, evcw, & & stm, wetness, semisbase, semis_lnd, semis_ice, & & sfalb_lnd, sfalb_ice, & @@ -447,7 +447,7 @@ subroutine lsm_ruc_run & ! inputs & cmm_ice, chh_ice, hflx_ice, & & snowfallac_ice, acsnow_ice, snowmt_ice - real (kind=kind_phys), dimension(:), intent( out) :: & + real (kind_phys), dimension(:), intent( out) :: & & albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, & & albdvis_ice, albdnir_ice, albivis_ice, albinir_ice @@ -457,10 +457,10 @@ subroutine lsm_ruc_run & ! inputs ! --- SPP - should be INTENT(IN) integer :: spp_lsm - real(kind=kind_phys), dimension(im,nlev) :: pattern_spp + real(kind_phys), dimension(im,nlev) :: pattern_spp ! --- locals: - real (kind=kind_phys), dimension(im) :: rho, rhonewsn_ex, & + real (kind_phys), dimension(im) :: rho, rhonewsn_ex, & & q0, qs1, albbcksol, srunoff_old, runoff_old, & & tprcp_old, srflag_old, sr_old, canopy_old, wetness_old, & ! for land @@ -475,26 +475,26 @@ subroutine lsm_ruc_run & ! inputs & sncovr1_ice_old,snowmt_ice_old !-- local spp pattern array - real (kind=kind_phys), dimension(im,lsoil_ruc,1) :: pattern_spp_lsm + real (kind_phys), dimension(im,lsoil_ruc,1) :: pattern_spp_lsm - real (kind=kind_phys), dimension(lsoil_ruc) :: et + real (kind_phys), dimension(lsoil_ruc) :: et - real (kind=kind_phys), dimension(im,lsoil_ruc,1) :: smsoil, & + real (kind_phys), dimension(im,lsoil_ruc,1) :: smsoil, & slsoil, stsoil, smfrsoil, keepfrsoil, stsice - real (kind=kind_phys), dimension(im,lsoil_ruc,1) :: smice, & + real (kind_phys), dimension(im,lsoil_ruc,1) :: smice, & slice, stice, smfrice, keepfrice - real (kind=kind_phys), dimension(im,lsoil_ruc) :: smois_old, & - & tsice_old, tslb_old, sh2o_old, & + real (kind_phys), dimension(im,lsoil_ruc) :: smois_old, & + & tsice_old, tslb_old, sh2o_old, & & keepfr_old, smfrkeep_old - real (kind=kind_phys), dimension(im,nlcat,1) :: landusef - real (kind=kind_phys), dimension(im,nscat,1) :: soilctop + real (kind_phys), dimension(im,nlcat,1) :: landusef + real (kind_phys), dimension(im,nscat,1) :: soilctop - real (kind=kind_phys),dimension (im,1,1) :: & + real (kind_phys),dimension (im,1,1) :: & & conflx2, sfcprs, sfctmp, q2, qcatm, rho2 - real (kind=kind_phys),dimension (im,1) :: orog, stdev - real (kind=kind_phys),dimension (im,1) :: & + real (kind_phys),dimension (im,1) :: orog, stdev + real (kind_phys),dimension (im,1) :: & & albbck_lnd, alb_lnd, chs_lnd, flhc_lnd, flqc_lnd, & & wet, wet_ice, smmax, cmc, drip, ec, edir, ett, & & dew_lnd, lh_lnd, esnow_lnd, etp, qfx_lnd, acceta, & @@ -510,7 +510,7 @@ subroutine lsm_ruc_run & ! inputs & precipfr, snfallac_lnd, acsn_lnd, & & qsfc_lnd, qsg_lnd, qvg_lnd, qcg_lnd, soilt1_lnd, chklowq ! ice - real (kind=kind_phys),dimension (im,1) :: & + real (kind_phys),dimension (im,1) :: & & albbck_ice, alb_ice, chs_ice, flhc_ice, flqc_ice, & & dew_ice, lh_ice, esnow_ice, qfx_ice, & & solnet_ice, sfcems_ice, hfx_ice, & @@ -520,8 +520,8 @@ subroutine lsm_ruc_run & ! inputs & qsfc_ice, qsg_ice, qvg_ice, qcg_ice, soilt1_ice - real (kind=kind_phys) :: xice_threshold - real (kind=kind_phys) :: fwat, qsw, evapw, hfxw + real (kind_phys) :: xice_threshold + real (kind_phys) :: fwat, qsw, evapw, hfxw character(len=256) :: llanduse !< Land-use dataset. Valid values are : !! "USGS" (USGS 24/27 category dataset) and @@ -536,13 +536,13 @@ subroutine lsm_ruc_run & ! inputs ! local integer :: ims,ime, its,ite, jms,jme, jts,jte, kms,kme, kts,kte integer :: l, k, i, j, fractional_seaice, ilst - real (kind=kind_phys) :: dm, cimin(im) + real (kind_phys) :: dm, cimin(im) logical :: flag(im), flag_ice(im), flag_ice_uncoupled(im) logical :: rdlai2d, myj, frpcpn logical :: debug_print !-- diagnostic point - real (kind=kind_phys) :: testptlat, testptlon + real (kind_phys) :: testptlat, testptlon ! ! Initialize CCPP error handling variables errmsg = '' @@ -637,8 +637,7 @@ subroutine lsm_ruc_run & ! inputs if ( fractional_seaice == 0 ) then xice_threshold = 0.5 else if ( fractional_seaice == 1 ) then - xice_threshold = 0.02 ! HRRR value - !xice_threshold = 0.15 ! consistent with GFS physics + xice_threshold = 0.15 ! consistent with GFS physics, 0.02 in HRRR endif nsoil = lsoil_ruc @@ -659,10 +658,8 @@ subroutine lsm_ruc_run & ! inputs do i = 1, im ! i - horizontal loop if (flag(i) .and. flag_guess(i)) then !> - Save land-related prognostic fields for guess run. - !if(me==0 .and. i==ipr) write (0,*)'before call to RUC guess run', i wetness_old(i) = wetness(i) canopy_old(i) = canopy(i) - !srflag_old(i) = srflag(i) ! for land weasd_lnd_old(i) = weasd_lnd(i) snwdph_lnd_old(i) = snwdph_lnd(i) @@ -704,7 +701,7 @@ subroutine lsm_ruc_run & ! inputs ! --- ... initialization block - do j = 1, 1 + do j = jms, jme do i = 1, im ! i - horizontal loop if (flag_iter(i) .and. flag(i)) then evap_lnd(i) = 0.0 @@ -790,7 +787,7 @@ subroutine lsm_ruc_run & ! inputs frpcpn = .false. endif - do j = 1, 1 ! 1:1 + do j = jms, jme do i = 1, im ! i - horizontal loop orog(i,j) = oro(i) !topography stdev(i,j) = sigma(i) ! st. deviation (m) @@ -803,7 +800,7 @@ subroutine lsm_ruc_run & ! inputs enddo enddo - do j = 1, 1 ! 1:1 + do j = jms, jme do i = 1, im ! i - horizontal loop xice(i,j) = 0. if (flag_iter(i) .and. flag(i)) then @@ -866,9 +863,9 @@ subroutine lsm_ruc_run & ! inputs rhonewsn_ex(i) = rhonewsn1(i) if (debug_print) then !-- diagnostics for a test point with known lat/lon - if (abs(xlat_d(i)-testptlat).lt.0.2 .and. & + if (abs(xlat_d(i)-testptlat).lt.0.2 .and. & abs(xlon_d(i)-testptlon).lt.0.2)then - !if(weasd_lnd(i) > 0.) & + !if(weasd_lnd(i) > 0.) & print 100,'(ruc_lsm_drv) i=',i, & ' lat,lon=',xlat_d(i),xlon_d(i), & 'rainc',rainc(i),'rainnc',rainnc(i), & @@ -876,7 +873,6 @@ subroutine lsm_ruc_run & ! inputs 'dlwflx',dlwflx(i),'dswsfc',dswsfc(i), & 'sncovr1_lnd',sncovr1_lnd(i),'sfalb_lnd_bck',sfalb_lnd_bck(i),& 'prsl1',prsl1(i),'t1',t1(i), & - !'snow',snow(i), 'snowncv',snowncv(i,j), & 'srflag',srflag(i),'weasd mm ',weasd_lnd(i), & 'tsnow_lnd',tsnow_lnd(i),'snwdph mm',snwdph_lnd(i), & 'tsurf_lnd',tsurf_lnd(i),'tslb(i,1)',tslb(i,1) @@ -885,12 +881,6 @@ subroutine lsm_ruc_run & ! inputs 100 format (";;; ",a,i4,a,2f14.7/(4(a10,'='es9.2))) !-- - ! ice precipitation is not used - ! precipfr(i,j) = rainncv(i,j) * ffrozp(i,j) - - ! ice not used - ! precipfr(i,j) = rainncv(i,j) * ffrozp(i,j) - tbot(i,j) = tg3(i) !> - 3. canopy/soil characteristics (s): @@ -913,9 +903,7 @@ subroutine lsm_ruc_run & ! inputs stype_ice(i,j) = 16 ! STASGO endif !> - Prepare land/ice/water masks for RUC LSM - !SLMSK0 - SEA(0),LAND(1),ICE(2) MASK - !if(islmsk(i) == 0.) then - !elseif(islmsk(i) == 1.) then ! land + ! SLMSK0 - SEA(0),LAND(1),ICE(2) MASK if(land(i)) then ! some land xland(i,j) = 1. @@ -1051,56 +1039,56 @@ subroutine lsm_ruc_run & ! inputs endif !> -- sanity checks on sneqv and snowh - if (sneqv_lnd(i,j) /= 0.0d0 .and. snowh_lnd(i,j) == 0.0d0) then + if (sneqv_lnd(i,j) /= 0.0_kind_dbl_prec .and. snowh_lnd(i,j) == 0.0_kind_dbl_prec) then if (debug_print) print *,'bad sneqv_lnd',kdt,i,j,sneqv_lnd(i,j),snowh_lnd(i,j),xlat_d(i),xlon_d(i) - if(sneqv_lnd(i,j) < 1.e-7.or.soilt_lnd(i,j)>273.15d0) then - sneqv_lnd(i,j) = 0.d0 - snowh_lnd(i,j) = 0.d0 + if(sneqv_lnd(i,j) < 1.e-7_kind_dbl_prec.or.soilt_lnd(i,j)>273.15_kind_dbl_prec) then + sneqv_lnd(i,j) = 0._kind_dbl_prec + snowh_lnd(i,j) = 0._kind_dbl_prec else - sneqv_lnd(i,j) = 300.d0 * snowh_lnd(i,j) ! snow density ~300 kg m-3 + sneqv_lnd(i,j) = 300._kind_dbl_prec * snowh_lnd(i,j) ! snow density ~300 kg m-3 endif if (debug_print) print *,'fixed sneqv_lnd',kdt,i,j,sneqv_lnd(i,j),snowh_lnd(i,j) - elseif (snowh_lnd(i,j) /= 0.0d0 .and. sneqv_lnd(i,j) == 0.0d0) then + elseif (snowh_lnd(i,j) /= 0.0_kind_dbl_prec .and. sneqv_lnd(i,j) == 0.0_kind_dbl_prec) then if (debug_print) print *,'bad snowh_lnd',kdt,i,j,sneqv_lnd(i,j),snowh_lnd(i,j),xlat_d(i),xlon_d(i) - if(snowh_lnd(i,j) < 3.d-10.or.soilt_lnd(i,j)>273.15d0) then - snowh_lnd(i,j) = 0.d0 - sneqv_lnd(i,j) = 0.d0 + if(snowh_lnd(i,j) < 3.e-10_kind_dbl_prec.or.soilt_lnd(i,j)>273.15_kind_dbl_prec) then + snowh_lnd(i,j) = 0._kind_dbl_prec + sneqv_lnd(i,j) = 0._kind_dbl_prec else - snowh_lnd(i,j) = 0.003d0 * sneqv_lnd(i,j) ! snow density ~300 kg m-3 + snowh_lnd(i,j) = 0.003_kind_dbl_prec * sneqv_lnd(i,j) ! snow density ~300 kg m-3 endif if (debug_print) print *,'fixed snowh_lnd',kdt,i,j,sneqv_lnd(i,j),snowh_lnd(i,j) - elseif (sneqv_lnd(i,j) > 0.d0 .and. snowh_lnd(i,j) > 0.d0) then - if (debug_print .and. abs(xlat_d(i)-testptlat).lt.2.5 .and. & - abs(xlon_d(i)-testptlon).lt.2.5)then + elseif (sneqv_lnd(i,j) > 0._kind_dbl_prec .and. snowh_lnd(i,j) > 0._kind_dbl_prec) then + if (debug_print .and. abs(xlat_d(i)-testptlat).lt.0.5 .and. & + abs(xlon_d(i)-testptlon).lt.0.5)then print *,'sneqv_lnd(i,j)/snowh_lnd(i,j)',kdt,i,j,sneqv_lnd(i,j)/snowh_lnd(i,j),sneqv_lnd(i,j),snowh_lnd(i,j) endif - if(sneqv_lnd(i,j)/snowh_lnd(i,j) > 500.d0) then + if(sneqv_lnd(i,j)/snowh_lnd(i,j) > 500._kind_dbl_prec) then if (debug_print .and. abs(xlat_d(i)-testptlat).lt.0.5 .and. & abs(xlon_d(i)-testptlon).lt.0.5)then print *,'large snow density',kdt,i,j,sneqv_lnd(i,j)/snowh_lnd(i,j),sneqv_lnd(i,j),snowh_lnd(i,j) print *,'large snow density lat/lon',kdt,i,j,xlat_d(i),xlon_d(i) endif - if(soilt_lnd(i,j)>273.15d0) then - snowh_lnd(i,j) = 0.d0 - sneqv_lnd(i,j) = 0.d0 + if(soilt_lnd(i,j)>273.15_kind_dbl_prec) then + snowh_lnd(i,j) = 0._kind_dbl_prec + sneqv_lnd(i,j) = 0._kind_dbl_prec else - snowh_lnd(i,j) = 0.002d0 * sneqv_lnd(i,j) + snowh_lnd(i,j) = 0.002_kind_dbl_prec * sneqv_lnd(i,j) endif if (debug_print .and. abs(xlat_d(i)-testptlat).lt.0.5 .and. & abs(xlon_d(i)-testptlon).lt.0.5)then print *,'fixed large snow density',kdt,i,j,sneqv_lnd(i,j)/snowh_lnd(i,j),sneqv_lnd(i,j),snowh_lnd(i,j) endif - elseif(sneqv_lnd(i,j)/snowh_lnd(i,j) < 58.d0) then + elseif(sneqv_lnd(i,j)/snowh_lnd(i,j) < 58._kind_dbl_prec) then if (debug_print .and. abs(xlat_d(i)-testptlat).lt.0.5 .and. & abs(xlon_d(i)-testptlon).lt.0.5)then print *,'small snow density',kdt,i,j,sneqv_lnd(i,j)/snowh_lnd(i,j),sneqv_lnd(i,j),snowh_lnd(i,j) print *,'small snow density lat/lon',kdt,i,j,xlat_d(i),xlon_d(i) endif - if(soilt_lnd(i,j)>273.15d0) then - snowh_lnd(i,j) = 0.d0 - sneqv_lnd(i,j) = 0.d0 + if(soilt_lnd(i,j)>273.15_kind_dbl_prec) then + snowh_lnd(i,j) = 0._kind_dbl_prec + sneqv_lnd(i,j) = 0._kind_dbl_prec else - sneqv_lnd(i,j) = 58.d0 * snowh_lnd(i,j) + sneqv_lnd(i,j) = 58._kind_dbl_prec * snowh_lnd(i,j) endif if (debug_print .and. abs(xlat_d(i)-testptlat).lt.0.5 .and. & abs(xlon_d(i)-testptlon).lt.0.5)then @@ -1132,12 +1120,11 @@ subroutine lsm_ruc_run & ! inputs if (kdt < 10) then if (abs(xlat_d(i)-testptlat).lt.0.5 .and. & abs(xlon_d(i)-testptlon).lt.0.5)then - !if(weasd_lnd(i) > 0.) & + !if(weasd_lnd(i) > 0.) & print 100,'(ruc_lsm_drv before RUC land call) i=',i, & ' lat,lon=',xlat_d(i),xlon_d(i), & 'rainc',rainc(i),'rainnc',rainnc(i),'prcp',prcp(i,j), & 'graupel',graupel(i),'qc',qc(i),'sfcqv_lnd',sfcqv_lnd(i),& - !'snow',snow(i), 'snowncv',snowncv(i,j), & 'dlwflx',dlwflx(i),'dswsfc',dswsfc(i), & 'sncovr1_lnd',sncovr1_lnd(i),'sfalb_lnd_bck',sfalb_lnd_bck(i),& 'albbcksol',albbcksol(i),'alb_lnd',alb_lnd(i,j), & @@ -1336,12 +1323,10 @@ subroutine lsm_ruc_run & ! inputs if (debug_print) then if (abs(xlat_d(i)-testptlat).lt.0.1 .and. & abs(xlon_d(i)-testptlon).lt.0.1)then - !if(weasd_ice(i) > 0.) & - print 101,'(ruc_lsm_drv_ice) i=',i, & - ' lat,lon=',xlat_d(i),xlon_d(i), & - !'rainc',rainc(i),'rainnc',rainnc(i), & - 'sfcqv_ice',sfcqv_ice(i),& - !'dlwflx',dlwflx(i),'dswsfc',dswsfc(i), & + !if(weasd_ice(i) > 0.) & + print 101,'(ruc_lsm_drv_ice) i=',i, & + ' lat,lon=',xlat_d(i),xlon_d(i), & + 'sfcqv_ice',sfcqv_ice(i), & 'sncovr1_ice',sncovr1_ice(i),'sfalb_ice',sfalb_ice(i),& 'sfcqc_ice',sfcqc_ice(i),'tsnow_ice',tsnow_ice(i), & 'prsl1',prsl1(i),'t1',t1(i),'snwdph_ice ',snwdph_ice(i), & @@ -1536,7 +1521,7 @@ subroutine lsm_ruc_run & ! inputs enddo ! i !> - Restore land-related prognostic fields for guess run. - do j = 1, 1 + do j = jms, jme do i = 1, im if (flag(i)) then if(debug_print) write (0,*)'end ',i,flag_guess(i),flag_iter(i) @@ -1547,7 +1532,6 @@ subroutine lsm_ruc_run & ! inputs snwdph_lnd(i) = snwdph_lnd_old(i) tskin_lnd(i) = tskin_lnd_old(i) canopy(i) = canopy_old(i) - !srflag(i) = srflag_old(i) tsnow_lnd(i) = tsnow_lnd_old(i) snowfallac_lnd(i) = snowfallac_lnd_old(i) acsnow_lnd(i) = acsnow_lnd_old(i) @@ -1612,24 +1596,24 @@ subroutine rucinit (lsm_cold_start, im, lsoil_ruc, lsoil, & ! in integer, intent(in ) :: im, nlev integer, intent(in ) :: lsoil_ruc integer, intent(in ) :: lsoil - real (kind=kind_phys), intent(in ) :: min_seaice - real (kind=kind_phys), dimension(im), intent(in ) :: slmsk - real (kind=kind_phys), dimension(im), intent(in ) :: landfrac - real (kind=kind_phys), dimension(im), intent(in ) :: fice - real (kind=kind_phys), dimension(im), intent(in ) :: tskin_lnd, tskin_wat - real (kind=kind_phys), dimension(im), intent(in ) :: tg3 - real (kind=kind_phys), dimension(1:lsoil_ruc), intent(in ) :: zs - real (kind=kind_phys), dimension(1:lsoil_ruc), intent(in ) :: dzs - real (kind=kind_phys), dimension(im,lsoil), intent(in ) :: smc ! Noah - real (kind=kind_phys), dimension(im,lsoil), intent(in ) :: stc ! Noah - real (kind=kind_phys), dimension(im,lsoil), intent(in ) :: slc ! Noah + real (kind_phys), intent(in ) :: min_seaice + real (kind_phys), dimension(im), intent(in ) :: slmsk + real (kind_phys), dimension(im), intent(in ) :: landfrac + real (kind_phys), dimension(im), intent(in ) :: fice + real (kind_phys), dimension(im), intent(in ) :: tskin_lnd, tskin_wat + real (kind_phys), dimension(im), intent(in ) :: tg3 + real (kind_phys), dimension(1:lsoil_ruc), intent(in ) :: zs + real (kind_phys), dimension(1:lsoil_ruc), intent(in ) :: dzs + real (kind_phys), dimension(im,lsoil), intent(in ) :: smc ! Noah + real (kind_phys), dimension(im,lsoil), intent(in ) :: stc ! Noah + real (kind_phys), dimension(im,lsoil), intent(in ) :: slc ! Noah integer, dimension(im), intent(in) :: stype, vtype - real (kind=kind_phys), dimension(im), intent(inout) :: wetness - real (kind=kind_phys), dimension(im,lsoil_ruc), intent(inout) :: smois! ruc - real (kind=kind_phys), dimension(im,lsoil_ruc), intent(inout) :: tslb ! ruc - real (kind=kind_phys), dimension(im,lsoil_ruc), intent(inout) :: sh2o ! ruc - real (kind=kind_phys), dimension(im,lsoil_ruc), intent(inout) :: smfrkeep ! ruc + real (kind_phys), dimension(im), intent(inout) :: wetness + real (kind_phys), dimension(im,lsoil_ruc), intent(inout) :: smois! ruc + real (kind_phys), dimension(im,lsoil_ruc), intent(inout) :: tslb ! ruc + real (kind_phys), dimension(im,lsoil_ruc), intent(inout) :: sh2o ! ruc + real (kind_phys), dimension(im,lsoil_ruc), intent(inout) :: smfrkeep ! ruc integer, intent(in ) :: me integer, intent(in ) :: master @@ -1642,28 +1626,28 @@ subroutine rucinit (lsm_cold_start, im, lsoil_ruc, lsoil, & ! in logical :: swi_init ! for initialization in terms of SWI (soil wetness index) integer :: flag_soil_layers, flag_soil_levels, flag_sst - real (kind=kind_phys), dimension(1:lsoil_ruc) :: factorsm - real (kind=kind_phys), dimension(im) :: smcref2 - real (kind=kind_phys), dimension(im) :: smcwlt2 + real (kind_phys), dimension(1:lsoil_ruc) :: factorsm + real (kind_phys), dimension(im) :: smcref2 + real (kind_phys), dimension(im) :: smcwlt2 integer , dimension( 1:im , 1:1 ) :: ivgtyp integer , dimension( 1:im , 1:1) :: isltyp - real (kind=kind_phys), dimension( 1:im , 1:1 ) :: mavail - real (kind=kind_phys), dimension( 1:im , 1:1 ) :: sst - real (kind=kind_phys), dimension( 1:im , 1:1 ) :: landmask - real (kind=kind_phys), dimension( 1:im , 1:1 ) :: tsk - real (kind=kind_phys), dimension( 1:im , 1:1 ) :: tbot - real (kind=kind_phys), dimension( 1:im , 1:1 ) :: smtotn - real (kind=kind_phys), dimension( 1:im , 1:1 ) :: smtotr - real (kind=kind_phys), dimension( 1:im , 1:lsoil_ruc, 1:1 ) :: dumsm - real (kind=kind_phys), dimension( 1:im , 1:lsoil_ruc, 1:1 ) :: dumt - real (kind=kind_phys), dimension( 1:im , 1:lsoil_ruc, 1:1 ) :: smfr - real (kind=kind_phys), dimension( 1:im , 1:lsoil_ruc, 1:1 ) :: soilm - real (kind=kind_phys), dimension( 1:im , 1:lsoil_ruc, 1:1 ) :: soiltemp - real (kind=kind_phys), dimension( 1:im , 1:lsoil_ruc, 1:1 ) :: soilh2o - - real (kind=kind_phys) :: st_input(1:im,1:lsoil_ruc*3,1:1) - real (kind=kind_phys) :: sm_input(1:im,1:lsoil_ruc*3,1:1) + real (kind_phys), dimension( 1:im , 1:1 ) :: mavail + real (kind_phys), dimension( 1:im , 1:1 ) :: sst + real (kind_phys), dimension( 1:im , 1:1 ) :: landmask + real (kind_phys), dimension( 1:im , 1:1 ) :: tsk + real (kind_phys), dimension( 1:im , 1:1 ) :: tbot + real (kind_phys), dimension( 1:im , 1:1 ) :: smtotn + real (kind_phys), dimension( 1:im , 1:1 ) :: smtotr + real (kind_phys), dimension( 1:im , 1:lsoil_ruc, 1:1 ) :: dumsm + real (kind_phys), dimension( 1:im , 1:lsoil_ruc, 1:1 ) :: dumt + real (kind_phys), dimension( 1:im , 1:lsoil_ruc, 1:1 ) :: smfr + real (kind_phys), dimension( 1:im , 1:lsoil_ruc, 1:1 ) :: soilm + real (kind_phys), dimension( 1:im , 1:lsoil_ruc, 1:1 ) :: soiltemp + real (kind_phys), dimension( 1:im , 1:lsoil_ruc, 1:1 ) :: soilh2o + + real (kind_phys) :: st_input(1:im,1:lsoil_ruc*3,1:1) + real (kind_phys) :: sm_input(1:im,1:lsoil_ruc*3,1:1) integer :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -1976,15 +1960,6 @@ subroutine rucinit (lsm_cold_start, im, lsoil_ruc, lsoil, & ! in enddo enddo - !do i=1,im - ! wetness (i) = 1. - ! do k=1,min(lsoil,lsoil_ruc) - ! smois(i,k) = smc(i,k) - ! tslb(i,k) = stc(i,k) - ! sh2o(i,k) = slc(i,k) - ! enddo - !enddo - if(debug_print) then do i=1,im write (0,*)'End of RUC LSM initialization' From ebb0c17e31794edfecb0546b7746b34f88ebe558 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Fri, 17 Mar 2023 19:52:30 +0000 Subject: [PATCH 167/380] Clean-up print statements. --- physics/module_sf_ruclsm.F90 | 18 ++++-------------- 1 file changed, 4 insertions(+), 14 deletions(-) diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 4e44bbffd..13d81eb43 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -8,7 +8,7 @@ !! and all terms of the surface energy balance and surface water balance. MODULE module_sf_ruclsm - use machine , only : kind_phys, kind_dbl_prec + use machine , only : kind_phys use namelist_soilveg_ruc implicit none @@ -970,6 +970,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & !tgs - turn off "irrigation" while there is no fractional landuse and LAI !climatology. + if(1==2) then IF (lufrac(crop) > 0 .and. lai(i,j) > 1.1) THEN ! cropland do k=1,nroot @@ -1004,6 +1005,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & endif enddo ENDIF + endif ! 1==2 !*** DIAGNOSTICS !--- available and maximum soil moisture content in the soil @@ -1091,11 +1093,9 @@ SUBROUTINE LSMRUC(xlat,xlon, & SFCEVP (I,J) = SFCEVP (I,J) + QFX (I,J) * DT GRDFLX (I,J) = -1. * sflx(I,J) -! if(smf(i,j) .ne.0.) then !tgs - SMF.NE.0. when there is phase change in the top soil layer ! The heat of soil water freezing/thawing is not computed explicitly ! and is responsible for the residual in the energy budget. -! print *,'Budget',budget(i,j),i,j,smf(i,j) ! endif !--- SNOWC snow cover flag @@ -1136,18 +1136,8 @@ SUBROUTINE LSMRUC(xlat,xlon, & 'smelt ',smelt(i,j)*dt*1.e3_kind_phys,'smc change ',wb, & 'snwe change ',as,'canw change ',ac,'runoff2 ',runoff2(i,j), & 'qfx*dt ',qfx(i,j)*dt,'smavail ',smavail(i,j),'smcold',smtotold(i,j) - !-- - waterbudget(i,j)=rainbl(i,j)-qfx(i,j)*dt-(smavail(i,j)-smtotold(i,j)) & - + !-- print *,'Smf=',smf(i,j),i,j - print *,'Budget',budget(i,j),i,j - print *,'RUNOFF2= ', i,j,runoff2(i,j) - print *,'Water budget ', i,j,waterbudget(i,j),'wb=',wb - print *,'rainbl,qfx*dt,runoff1,smelt*dt*1.e3,smchange', & - i,j,rainbl(i,j),qfx(i,j)*dt,runoff1(i,j)*dt*1.e3, & - smelt(i,j)*dt*1.e3_kind_phys, & - (smavail(i,j)-smtotold(i,j)) -! print *,'SNOW,SNOWold',i,j,snwe,snowold(i,j) print *,'SNOW-SNOWold',i,j,max(0._kind_phys,snwe-snowold(i,j)) print *,'CANWATold, canwat ',i,j,canwatold(i,j),canwat(i,j) From af1e1bcd2ead2ef488187aaafe06a27cdd0f43cd Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Fri, 17 Mar 2023 19:53:18 +0000 Subject: [PATCH 168/380] Added table parameters for option 3 of snow cover fraction computation. --- physics/set_soilveg_ruc.F90 | 35 +++++++++++++++++++++++++++++++---- 1 file changed, 31 insertions(+), 4 deletions(-) diff --git a/physics/set_soilveg_ruc.F90 b/physics/set_soilveg_ruc.F90 index f29726645..79c1be310 100644 --- a/physics/set_soilveg_ruc.F90 +++ b/physics/set_soilveg_ruc.F90 @@ -30,8 +30,9 @@ subroutine set_soilveg_ruc(me,isot,ivet,nlunit,errmsg,errflg) NAMELIST /SOIL_VEG_RUC/ SLOPE_DATA, ALBTBL, Z0TBL, LEMITBL, & & PCTBL, SHDTBL, & & IFORTBL, RSTBL, RGLTBL, HSTBL, SNUPTBL, LAITBL, MAXALB, & + & MFSNO, SNCOVFAC, & & LPARAM, TOPT_DATA, CMCMAX_DATA, CFACTR_DATA, & - & RSMAX_DATA, BARE, NATURAL, CROP, URBAN, & + & RSMAX_DATA, BARE, GLACIER, NATURAL, CROP, URBAN, & & DEFINED_VEG, DEFINED_SOIL, DEFINED_SLOPE, & & BB, DRYSMC, HC, MAXSMC, REFSMC, SATPSI, SATDK, SATDW, & & WLTSMC, QTZ, mosaic_soil, mosaic_lu, & @@ -200,15 +201,41 @@ subroutine set_soilveg_ruc(me,isot,ivet,nlunit,errmsg,errflg) & 70., 55., 60., 75., 70., 0., 0., 0., & & 0., 0., 0., 0., 0., 0./) + mfsno = & !< modified for RRFS Noah_MP snowmelt curve parameter () + & (/ 1.00, 1.00, 1.00, 1.00, 2.00, 2.00, & + & 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, & + & 3.00, 3.00, 2.00, 2.00, 2.00, 2.00, & + & 2.00, 2.00, 0.00, 0.00, 0.00, 0.00, & +! & 3.00, 3.00, 2.00, 3.00, 3.00, 3.00, & +! & 3.00, 3.00, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 /) + +!-- Noah MP snowmelt curve values +! & (/ 1.00, 1.00, 1.00, 1.00, 1.00, 2.00, & +! & 2.00, 2.00, 2.00, 2.00, 3.00, 3.00, & +! & 4.00, 4.00, 2.50, 3.00, 3.00, 3.50, & +! & 3.50, 3.50, 0.00, 0.00, 0.00, 0.00, & +! & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 /) + + sncovfac = & !< Noah_MP snow cover factor (m), first 5 categories are modified for RRFS + & (/ 0.030, 0.030, 0.030, 0.030, 0.030, & + !& (/ 0.008, 0.008, 0.008, 0.008, 0.008, & + & 0.016, 0.016, 0.020, 0.020, 0.020, & + & 0.020, 0.014, 0.042, 0.026, 0.030, & + & 0.016, 0.030, 0.030, 0.030, 0.030, & + & 0.000, 0.000, 0.000, 0.000, 0.000, & + & 0.000, 0.000, 0.000, 0.000, 0.000 /) + natural = 10 - bare = 16 crop = 12 urban = 13 + glacier = 15 + bare = 16 endif ! end if veg table ! - set mosaic_lu=1 when info for fractional landuse is available - mosaic_lu = 1 + mosaic_lu = 0 topt_data =298.0 cmcmax_data =0.2e-3 @@ -413,7 +440,7 @@ subroutine set_soilveg_ruc(me,isot,ivet,nlunit,errmsg,errflg) END DO ! - set mosaic_soil=1 when info for fractional landuse is available - mosaic_soil = 1 + mosaic_soil = 0 ! PT 5/18/2015 - changed to FALSE to match atm_namelist setting ! PT LPARAM is not used anywhere From eb9b6b682d78751a0a667fc53c9b4c4bd5a82521 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Fri, 17 Mar 2023 19:54:25 +0000 Subject: [PATCH 169/380] Updated the sfc_diag.f that computes 2-m diagnostics. Should not affect results for physics suites not using RUC LSM. --- physics/sfc_diag.f | 187 +++++++++++++++++++++++++++++++++++------- physics/sfc_diag.meta | 120 ++++++++++++++++++++++++++- 2 files changed, 277 insertions(+), 30 deletions(-) diff --git a/physics/sfc_diag.f b/physics/sfc_diag.f index 045ad75b0..f5bd081e0 100644 --- a/physics/sfc_diag.f +++ b/physics/sfc_diag.f @@ -1,39 +1,61 @@ !> \file sfc_diag.f !! This file contains the land surface diagnose calculation scheme. +!> \defgroup Sfc_diag Land Surface Diagnose Calculation +!! @{ + module sfc_diag contains - -!> \defgroup sfc_diag_mod GFS sfc_diag module -!! This module contains the land surface diagose calculation. -!> @{ -!! \section arg_table_sfc_diag_run Argument Table + + subroutine sfc_diag_init + end subroutine sfc_diag_init + + subroutine sfc_diag_finalize + end subroutine sfc_diag_finalize + +!> \brief Brief description of the subroutine +!! +!! \section arg_table_sfc_diag_run Arguments !! \htmlinclude sfc_diag_run.html !! - subroutine sfc_diag_run & - & (im,grav,cp,eps,epsm1,ps,u1,v1,t1,q1,prslki, & - & evap,fm,fh,fm10,fh2,tskin,qsurf,thsfc_loc, & - & f10m,u10m,v10m,t2m,q2m,errmsg,errflg & +!! \section general General Algorithm +!! \section detailed Detailed Algorithm +!! @{ + subroutine sfc_diag_run (im,xlat_d,xlon_d, & + & lsm,lsm_ruc,grav,cp,eps,epsm1,rocp, & + & wet,shflx,chs2,cqs2,cdq,wind, & + & zf,ps,u1,v1,t1,q1,prslki,evap,fm,fh,fm10,fh2, & + & tskin,qsurf,thsfc_loc,diag_flux,diag_log, & + & f10m,u10m,v10m,t2m,q2m,dpt2m,errmsg,errflg & & ) ! use machine , only : kind_phys use funcphys, only : fpvs implicit none ! - integer, intent(in) :: im + integer, intent(in) :: im, lsm, lsm_ruc logical, intent(in) :: thsfc_loc ! Flag for reference pot. temp. - real(kind=kind_phys), intent(in) :: grav,cp,eps,epsm1 - real(kind=kind_phys), dimension(:), intent(in) :: & - & ps, u1, v1, t1, q1, tskin, & - & qsurf, prslki, evap, fm, fh, fm10, fh2 + logical, intent(in) :: diag_flux ! Flag for flux method in 2-m diagnostics + logical, intent(in) :: diag_log ! Flag for 2-m log diagnostics under stable conditions + real(kind=kind_phys), intent(in) :: grav,cp,eps,epsm1,rocp + real(kind=kind_phys), dimension(:), intent( in) :: & + & zf, ps, u1, v1, t1, q1, tskin, wet, & + & qsurf, prslki, evap, fm, fh, fm10, fh2, & + & shflx, chs2, cqs2, cdq, wind, xlat_d, xlon_d real(kind=kind_phys), dimension(:), intent(out) :: & - & f10m, u10m, v10m, t2m, q2m + & f10m, u10m, v10m, t2m, q2m, dpt2m character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg ! ! locals ! + logical :: debug_print real(kind=kind_phys), parameter :: qmin=1.0e-8 + real(kind=kind_phys) :: q1c, qv, tem, qv1, th2m, x2m, rho + real(kind=kind_phys) :: dT, dQ, qsfcmr, qsfcprox, ff, fac, dz1 + real(kind=kind_phys) :: t2_alt, q2_alt + real(kind=kind_phys) :: thcon, cqs, chs + real(kind=kind_phys) :: testptlat, testptlon integer :: k,i ! real(kind=kind_phys) :: fhi, qss, wrk @@ -44,6 +66,12 @@ subroutine sfc_diag_run & ! Initialize CCPP error handling variables errmsg = '' errflg = 0 + + !-- + testptlat = 35.3 !41.02 !42.05 !39.0 !74.12 !29.5 + testptlon = 273.0 !284.50 !286.75 !280.6 !164.0 !283.0 + !-- + debug_print = .false. ! ! estimate sigma ** k at 2 m ! @@ -53,6 +81,8 @@ subroutine sfc_diag_run & ! ps is in pascals ! !! + + do i = 1, im f10m(i) = fm10(i) / fm(i) ! f10m(i) = min(f10m(i),1.) @@ -64,23 +94,123 @@ subroutine sfc_diag_run & ! t2m(i) = t2m(i) * sig2k wrk = 1.0 - fhi + thcon = (1.e5/ps(i))**rocp + !-- make sure 1st level q is not higher than saturated value + qss = fpvs(t1(i)) + qss = eps * qss / (ps(i) + epsm1 * qss) + q1c = min(q1(i),qss) ! lev 1 spec. humidity - if(thsfc_loc) then ! Use local potential temperature - t2m(i) = tskin(i)*wrk + t1(i)*prslki(i)*fhi - (grav+grav)/cp - else ! Use potential temperature referenced to 1000 hPa - t2m(i) = tskin(i)*wrk + t1(i)*fhi - (grav+grav)/cp - endif + qv1 = q1c / (1. - q1c) ! lev 1 mixing ratio + qsfcmr = qsurf(i)/(1. - qsurf(i)) ! surface mixing ratio + chs = cdq(i) * wind(i) + cqs = chs + qsfcprox = max(qmin,qv1 + evap(i)/cqs) ! surface mix. ratio computed from the flux - if(evap(i) >= 0.) then ! for evaporation>0, use inferred qsurf to deduce q2m - q2m(i) = qsurf(i)*wrk + max(qmin,q1(i))*fhi - else ! for dew formation, use saturated q at tskin - qss = fpvs(tskin(i)) - qss = eps * qss / (ps(i) + epsm1 * qss) - q2m(i) = qss*wrk + max(qmin,q1(i))*fhi - endif + if(.not. diag_flux) then + !-- original method + if(lsm /= lsm_ruc) then + if(thsfc_loc) then ! Use local potential temperature + t2m(i)=tskin(i)*wrk + t1(i)*prslki(i)*fhi - (grav+grav)/cp + else ! Use potential temperature referenced to 1000 hPa + t2m(i) = tskin(i)*wrk + t1(i)*fhi - (grav+grav)/cp + endif + if(evap(i) >= 0.) then ! for evaporation>0, use inferred qsurf to deduce q2m + q2m(i) = qsurf(i)*wrk + max(qmin,q1c)*fhi + else ! for dew formation, use saturated q at tskin + qss = fpvs(tskin(i)) + qss = eps * qss/(ps(i) + epsm1 * qss) + q2m(i) = qss*wrk + max(qmin,q1c)*fhi + endif + else + t2m(i) = tskin(i)*wrk + t1(i)*fhi - (grav+grav)/cp + q2m(i) = qsurf(i)*wrk + max(qmin,q1c)*fhi + endif ! RUC lsm + + else + !-- flux method + th2m = tskin(i)*thcon - shflx(i)/chs2(i) + t2m(i) = th2m/thcon + + x2m = max(qmin,qsfcprox - evap(i)/cqs2(i)) ! mix. ratio + q2m(i) = x2m/(1. + x2m) ! spec. humidity + endif ! flux method + + if(diag_log) then + !-- Alternative logarithmic diagnostics: + dT = t1(i) - tskin(i) + dQ = qv1 - qsfcmr + dz1= zf(i) ! level of atm. forcing + IF (dT > 0.) THEN + ff = MIN(MAX(1.-dT/10.,0.01), 1.0) + !for now, set zt = 0.05 + fac = LOG((2. + .05)/(0.05 + ff))/ & + & LOG((dz1 + .05)/(0.05 + ff)) + T2_alt = tskin(i) + fac * dT + ELSE + !no alternatives (yet) for unstable conditions + T2_alt = t2m(i) + ENDIF + + IF (dQ > 0.) THEN + ff = MIN(MAX(1.-dQ/0.003,0.01), 1.0) + !-- for now, set zt = 0.05 + fac = LOG((2. + .05)/(0.05 + ff))/ & + & LOG((dz1 + .05)/(0.05 + ff)) + Q2_alt = qsfcmr + fac * dQ ! mix. ratio + Q2_alt = Q2_alt/(1. + Q2_alt) ! spec. humidity + ELSE + !no alternatives (yet) for unstable conditions + Q2_alt = q2m(i) + ENDIF + !-- Note: use of alternative diagnostics will make + ! it cooler and drier with stable stratification + t2m(i) = T2_alt + q2m(i) = Q2_alt + endif ! log method for stable regime + + !-- check that T2m values lie in the range between tskin and t1 + x2m = max(min(tskin(i),t1(i)) , t2m(i)) + t2m(i) = min(max(tskin(i),t1(i)) , x2m) + !-- check that Q2m values lie in the range between qsurf and q1 + x2m = max(min(qsurf(i),q1c) , q2m(i)) + q2m(i) = min(max(qsurf(i),q1c) , x2m) + + !-- make sure q2m is not oversaturated qss = fpvs(t2m(i)) - qss = eps * qss / (ps(i) + epsm1 * qss) + qss = eps * qss/(ps(i) + epsm1 * qss) q2m(i) = min(q2m(i),qss) + + if(diag_flux) then + !-- from WRF, applied in HRRR - Jimy Dudhia + ! Limit Q2m diagnostic to no more than 5 percent higher than lowest level value + ! This prevents unrealistic values when QFX is not mostly surface + ! flux because calculation is based on surface flux only. + ! Problems occurred in transition periods and weak winds and vegetation source + q2m(i) = min(q2m(i),1.05*q1c) ! works if qsurf > q1c, evaporation + endif + + + !-- Compute dew point, using vapor pressure + qv = max(qmin,(q2m(i)/(1.-q2m(i)))) + tem = max(ps(i) * qv/( eps - epsm1 *qv), 1.e-8) + dpt2m(i) = 243.5/( ( 17.67 / log(tem/611.2) ) - 1.) + 273.14 + dpt2m(i) = min(dpt2m(i),t2m(i)) + + + if (debug_print) then + !-- diagnostics for a test point with known lat/lon + if (abs(xlat_d(i)-testptlat).lt.0.2 .and. & + & abs(xlon_d(i)-testptlon).lt.0.2)then + print 100,'(ruc_lsm_diag) i=',i, & + & ' lat,lon=',xlat_d(i),xlon_d(i),'zf ',zf(i), & + & 'tskin ',tskin(i),'t2m ',t2m(i),'t1',t1(i),'shflx',shflx(i),& + & 'qsurf ',qsurf(i),'qsfcprox ',qsfcprox,'q2m ',q2m(i), & + & 'q1 ',q1(i),'evap ',evap(i),'dpt2m ',dpt2m(i), & + & 'chs2 ',chs2(i),'cqs2 ',cqs2(i),'cqs ',cqs,'cdq',cdq(i) + endif + endif + 100 format (";;; ",a,i4,a,2f14.7/(4(a10,'='es11.4))) + enddo return @@ -88,3 +218,4 @@ end subroutine sfc_diag_run !> @} end module sfc_diag +!> @} diff --git a/physics/sfc_diag.meta b/physics/sfc_diag.meta index dd3bf79b8..91a5c8d41 100644 --- a/physics/sfc_diag.meta +++ b/physics/sfc_diag.meta @@ -14,6 +14,36 @@ dimensions = () type = integer intent = in +[xlat_d] + standard_name = latitude_in_degree + long_name = latitude in degree north + units = degree_north + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[xlon_d] + standard_name = longitude_in_degree + long_name = longitude in degree east + units = degree_east + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[lsm] + standard_name = control_for_land_surface_scheme + long_name = flag for land surface model + units = flag + dimensions = () + type = integer + intent = in +[lsm_ruc] + standard_name = identifier_for_ruc_land_surface_scheme + long_name = flag for RUC land surface model + units = flag + dimensions = () + type = integer + intent = in [grav] standard_name = gravitational_acceleration long_name = gravitational acceleration @@ -46,6 +76,30 @@ type = real kind = kind_phys intent = in +[rocp] + standard_name = ratio_of_gas_constant_dry_air_to_specific_heat_of_dry_air_at_constant_pressure + long_name = (rd/cp) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[wet] + standard_name = normalized_soil_wetness_for_land_surface_model + long_name = normalized soil wetness + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[zf] + standard_name = height_above_ground_at_lowest_model_layer + long_name = layer 1 height above ground (not MSL) + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [ps] standard_name = surface_air_pressure long_name = surface pressure @@ -71,7 +125,7 @@ kind = kind_phys intent = in [t1] - standard_name = air_temperature_of_new_state_at_surface_adjacent_layer + standard_name = air_temperature_at_surface_adjacent_layer long_name = 1st model layer air temperature units = K dimensions = (horizontal_loop_extent) @@ -79,7 +133,7 @@ kind = kind_phys intent = in [q1] - standard_name = specific_humidity_of_new_state_at_surface_adjacent_layer + standard_name = specific_humidity_at_surface_adjacent_layer long_name = 1st model layer specific humidity units = kg kg-1 dimensions = (horizontal_loop_extent) @@ -157,6 +211,60 @@ dimensions = () type = logical intent = in +[diag_flux] + standard_name = flag_for_flux_method_in_2m_diagnostics + long_name = flag for flux method in 2-m diagnostics + units = flag + dimensions = () + type = logical + intent = in +[diag_log] + standard_name = flag_for_log_method_in_2m_diagnostics + long_name = flag for log method in 2-m diagnostics + units = flag + dimensions = () + type = logical + intent = in +[shflx] + standard_name = surface_upward_temperature_flux + long_name = kinematic surface upward sensible heat flux + units = K m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[chs2] + standard_name = surface_exchange_coefficient_for_heat_at_2m + long_name = exchange coefficient for heat at 2 meters + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[cqs2] + standard_name = surface_exchange_coefficient_for_moisture_at_2m + long_name = exchange coefficient for moisture at 2 meters + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[cdq] + standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air + long_name = surface exchange coeff heat & moisture + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[wind] + standard_name = wind_speed_at_lowest_model_layer + long_name = wind speed at lowest model level + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [f10m] standard_name = ratio_of_wind_at_surface_adjacent_layer_to_wind_at_10m long_name = ratio of fm10 and fm @@ -197,6 +305,14 @@ type = real kind = kind_phys intent = out +[dpt2m] + standard_name = dewpoint_temperature_at_2m + long_name = 2 meter dewpoint temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 706bc40f5a76c2d77a2cde44fabe3b6db92d579b Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Fri, 17 Mar 2023 21:50:47 +0000 Subject: [PATCH 170/380] In module_sf_ruclsm.F90 changes rellated to kind_physics. --- physics/module_sf_ruclsm.F90 | 730 +++++++++++++++---------------- physics/namelist_soilveg_ruc.F90 | 72 +-- physics/set_soilveg_ruc.F90 | 3 +- 3 files changed, 405 insertions(+), 400 deletions(-) diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 13d81eb43..dcc4723c3 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -8,7 +8,7 @@ !! and all terms of the surface energy balance and surface water balance. MODULE module_sf_ruclsm - use machine , only : kind_phys + use machine , only : kind_phys, kind_dbl_prec use namelist_soilveg_ruc implicit none @@ -20,11 +20,13 @@ MODULE module_sf_ruclsm !> CONSTANT PARAMETERS !! @{ - real (kind=kind_phys), parameter :: P1000mb = 100000. - real (kind=kind_phys), parameter :: xls = 2.85E6 - real (kind=kind_phys), parameter :: rhowater= 1000. - real (kind=kind_phys), parameter :: piconst = 3.1415926535897931 - real (kind=kind_phys), parameter :: r_v = 4.6150e+2 + real (kind_phys), parameter :: P1000mb = 100000._kind_dbl_prec + real (kind_phys), parameter :: xls = 2.85E6_kind_dbl_prec + real (kind_phys), parameter :: rhowater= 1000._kind_dbl_prec + real (kind_phys), parameter :: piconst = 3.1415926535897931_kind_dbl_prec + real (kind_phys), parameter :: r_v = 461.50_kind_dbl_prec + real (kind_phys), parameter :: zero = 0._kind_dbl_prec + real (kind_phys), parameter :: one = 1._kind_dbl_prec !-- options for snow conductivity: 1 - constant, 2 - Sturm et al.,1997 integer, parameter :: isncond_opt = 1 @@ -62,7 +64,7 @@ MODULE module_sf_ruclsm !! @{ INTEGER :: SLPCATS INTEGER, PARAMETER :: NSLOPE=30 - real (kind=kind_phys) :: SBETA_DATA,FXEXP_DATA,CSOIL_DATA,SALP_DATA,REFDK_DATA, & + real (kind_phys) :: SBETA_DATA,FXEXP_DATA,CSOIL_DATA,SALP_DATA,REFDK_DATA, & REFKDT_DATA,FRZK_DATA,ZBOT_DATA, SMLOW_DATA,SMHIGH_DATA, & CZIL_DATA !! @} @@ -183,8 +185,8 @@ SUBROUTINE LSMRUC(xlat,xlon, & ! INTEGER, PARAMETER :: nzss=5 ! INTEGER, PARAMETER :: nddzs=2*(nzss-2) - real (kind=kind_phys), INTENT(IN ) :: xlat,xlon - real (kind=kind_phys), INTENT(IN ) :: DT + real (kind_phys), INTENT(IN ) :: xlat,xlon + real (kind_phys), INTENT(IN ) :: DT LOGICAL, INTENT(IN ) :: myj,frpcpn,init,lsm_cold_start,exticeden INTEGER, INTENT(IN ) :: NLCAT, NSCAT INTEGER, INTENT(IN ) :: ktau, iter, nsl, isice, iswater, & @@ -193,7 +195,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & ! LOGICAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: flag_iter, flag - real (kind=kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme ) , & + real (kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme ) , & INTENT(IN ) :: QV3D, & QC3D, & p8w, & @@ -201,7 +203,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & T3D, & z3D - real (kind=kind_phys), DIMENSION( ims:ime , jms:jme ), & + real (kind_phys), DIMENSION( ims:ime , jms:jme ), & INTENT(IN ) :: RAINBL, & GLW, & GSWdn, & @@ -211,31 +213,31 @@ SUBROUTINE LSMRUC(xlat,xlon, & FLQC, & CHS , & XICE, & - XLAND, &! ALBBCK, & + XLAND, & VEGFRA, & TBOT - real (kind=kind_phys), DIMENSION( ims:ime , jms:jme ), & + real (kind_phys), DIMENSION( ims:ime , jms:jme ), & INTENT(IN ) :: GRAUPELNCV, & SNOWNCV, & RAINCV, & RAINNCV - real (kind=kind_phys), DIMENSION( ims:ime), INTENT(IN ) :: RHONEWSN_ex !externally-calculated srf frz precip density + real (kind_phys), DIMENSION( ims:ime), INTENT(IN ) :: RHONEWSN_ex !externally-calculated srf frz precip density - real (kind=kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: SHDMAX - real (kind=kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: SHDMIN - real (kind=kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: hgt - real (kind=kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: stdev + real (kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: SHDMAX + real (kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: SHDMIN + real (kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: hgt + real (kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: stdev LOGICAL, intent(in) :: rdlai2d - real (kind=kind_phys), DIMENSION( 1:nsl), INTENT(IN ) :: ZS + real (kind_phys), DIMENSION( 1:nsl), INTENT(IN ) :: ZS - real (kind=kind_phys), DIMENSION( ims:ime , jms:jme ), & + real (kind_phys), DIMENSION( ims:ime , jms:jme ), & INTENT(INOUT) :: & SNOW, & SNOWH, & SNOWC, & - CANWAT, & ! new + CANWAT, & SNOALB, & ALB, & LAI, & @@ -246,23 +248,23 @@ SUBROUTINE LSMRUC(xlat,xlon, & Z0 , & ZNT - real (kind=kind_phys), DIMENSION( ims:ime , jms:jme ), & + real (kind_phys), DIMENSION( ims:ime , jms:jme ), & INTENT(IN ) :: & FRZFRAC INTEGER, DIMENSION( ims:ime , jms:jme ), & INTENT(IN ) :: IVGTYP, & ISLTYP - real (kind=kind_phys), DIMENSION( ims:ime , 1:nlcat, jms:jme ), INTENT(IN):: LANDUSEF - real (kind=kind_phys), DIMENSION( ims:ime , 1:nscat, jms:jme ), INTENT(IN):: SOILCTOP + real (kind_phys), DIMENSION( ims:ime , 1:nlcat, jms:jme ), INTENT(IN):: LANDUSEF + real (kind_phys), DIMENSION( ims:ime , 1:nscat, jms:jme ), INTENT(IN):: SOILCTOP - real (kind=kind_phys), INTENT(IN ) :: CP,G0,LV,STBOLT,RV,RD,PI, & - XICE_threshold + real (kind_phys), INTENT(IN ) :: CP,G0,LV,STBOLT,RV,RD,PI, & + XICE_threshold - real (kind=kind_phys), DIMENSION( ims:ime , 1:nsl, jms:jme ) , & + real (kind_phys), DIMENSION( ims:ime , 1:nsl, jms:jme ) , & INTENT(INOUT) :: SOILMOIS,SH2O,TSO - real (kind=kind_phys), DIMENSION( ims:ime, jms:jme ) , & + real (kind_phys), DIMENSION( ims:ime, jms:jme ) , & INTENT(INOUT) :: SOILT, & HFX, & QFX, & @@ -288,11 +290,11 @@ SUBROUTINE LSMRUC(xlat,xlon, & SOILT1, & TSNAV - real (kind=kind_phys), DIMENSION( ims:ime, jms:jme ) , & + real (kind_phys), DIMENSION( ims:ime, jms:jme ) , & INTENT(INOUT) :: SMAVAIL, & SMMAX - real (kind=kind_phys), DIMENSION( its:ite, jts:jte ) :: & + real (kind_phys), DIMENSION( its:ite, jts:jte ) :: & PC, & SFCRUNOFF, & UDRUNOFF, & @@ -310,7 +312,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & SEAICE, & INFILTR ! Energy and water budget variables: - real (kind=kind_phys), DIMENSION( its:ite, jts:jte ) :: & + real (kind_phys), DIMENSION( its:ite, jts:jte ) :: & budget, & acbudget, & waterbudget, & @@ -320,16 +322,16 @@ SUBROUTINE LSMRUC(xlat,xlon, & canwatold - real (kind=kind_phys), DIMENSION( ims:ime, 1:nsl, jms:jme) & + real (kind_phys), DIMENSION( ims:ime, 1:nsl, jms:jme) & :: KEEPFR3DFLAG, & SMFR3D - real (kind=kind_phys), DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: & - RHOSNF, & !RHO of snowfall + real (kind_phys), DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: & + RHOSNF, & ! RHO of snowfall PRECIPFR, & ! time-step frozen precip SNOWFALLAC !--- soil/snow properties - real (kind=kind_phys) & + real (kind_phys) & :: RHOCS, & RHONEWSN, & RHOSN, & @@ -347,7 +349,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & SNHEI, & SNWE - real (kind=kind_phys) :: CN, & + real (kind_phys) :: CN, & SAT,CW, & C1SN, & C2SN, & @@ -356,31 +358,31 @@ SUBROUTINE LSMRUC(xlat,xlon, & KWT - real (kind=kind_phys), DIMENSION(1:NSL) :: ZSMAIN, & - ZSHALF, & - DTDZS2 + real (kind_phys), DIMENSION(1:NSL) :: ZSMAIN, & + ZSHALF, & + DTDZS2 - real (kind=kind_phys), DIMENSION(1:2*(nsl-2)) :: DTDZS + real (kind_phys), DIMENSION(1:2*(nsl-2)) :: DTDZS - real (kind=kind_phys), DIMENSION(1:5001) :: TBQ + real (kind_phys), DIMENSION(1:5001) :: TBQ - real (kind=kind_phys), DIMENSION( 1:nsl ) :: SOILM1D, & + real (kind_phys), DIMENSION( 1:nsl ) :: SOILM1D, & TSO1D, & SOILICE, & SOILIQW, & SMFRKEEP - real (kind=kind_phys), DIMENSION( 1:nsl ) :: KEEPFR + real (kind_phys), DIMENSION( 1:nsl ) :: KEEPFR - real (kind=kind_phys), DIMENSION( 1:nlcat ) :: lufrac - real (kind=kind_phys), DIMENSION( 1:nscat ) :: soilfrac + real (kind_phys), DIMENSION( 1:nlcat ) :: lufrac + real (kind_phys), DIMENSION( 1:nscat ) :: soilfrac - real (kind=kind_phys) :: RSM, & - SNWEPRINT, & - SNHEIPRINT + real (kind_phys) :: RSM, & + SNWEPRINT, & + SNHEIPRINT - real (kind=kind_phys) :: PRCPMS, & + real (kind_phys) :: PRCPMS, & NEWSNMS, & prcpncliq, & prcpncfr, & @@ -401,10 +403,10 @@ SUBROUTINE LSMRUC(xlat,xlon, & icerat, & curat, & INFILTRP - real (kind=kind_phys) :: cq,r61,r273,arp,brp,x,evs,eis - real (kind=kind_phys) :: cropsm + real (kind_phys) :: cq,r61,r273,arp,brp,x,evs,eis + real (kind_phys) :: cropsm - real (kind=kind_phys) :: meltfactor, ac,as, wb,rovcp + real (kind_phys) :: meltfactor, ac,as, wb,rovcp INTEGER :: NROOT INTEGER :: ILAND,ISOIL,IFOREST @@ -413,7 +415,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & logical :: debug_print !-- diagnostic point - real (kind=kind_phys) :: testptlat, testptlon + real (kind_phys) :: testptlat, testptlon character(len=*),intent(out) :: errmsg integer, intent(out) :: errflg @@ -432,23 +434,23 @@ SUBROUTINE LSMRUC(xlat,xlon, & NDDZS=2*(nzs-2) !-- - testptlat = 48.7074 !39.958 !42.05 !39.0 !74.12 !29.5 - testptlon = 289.03 !271.622 !286.75 !280.6 !164.0 !283.0 + testptlat = 48.7074_kind_phys !39.958 !42.05 !39.0 !74.12 !29.5 + testptlon = 289.03_kind_phys !271.622 !286.75 !280.6 !164.0 !283.0 !-- !> - Table TBQ is for resolution of balance equation in vilka() - CQ=173.15-.05 - R273=1./273.15 - R61=6.1153*0.62198 - ARP=77455.*41.9/461.525 - BRP=64.*41.9/461.525 + CQ=173.15_kind_dbl_prec-.05_kind_dbl_prec + R273=1._kind_dbl_prec/273.15_kind_dbl_prec + R61=6.1153_kind_dbl_prec*0.62198_kind_dbl_prec + ARP=77455._kind_dbl_prec*41.9_kind_dbl_prec/461.525_kind_dbl_prec + BRP=64._kind_dbl_prec*41.9_kind_dbl_prec/461.525_kind_dbl_prec DO K=1,5001 - CQ=CQ+.05 - EVS=EXP(17.67*(CQ-273.15)/(CQ-29.65)) - EIS=EXP(22.514-6.15E3/CQ) - if(CQ.ge.273.15) then + CQ=CQ+.05_kind_dbl_prec + EVS=EXP(17.67_kind_dbl_prec*(CQ-273.15_kind_dbl_prec)/(CQ-29.65_kind_dbl_prec)) + EIS=EXP(22.514_kind_phys-6.15E3_kind_dbl_prec/CQ) + if(CQ.ge.273.15_kind_dbl_prec) then ! tbq is in mb tbq(k) = R61*evs else @@ -468,9 +470,9 @@ SUBROUTINE LSMRUC(xlat,xlon, & DO i=its,ite ! !> - Initializing inside-snow temp if it is not defined - IF((soilt1(i,j) .LT. 170.) .or. (soilt1(i,j) .GT.400.)) THEN - IF(snowc(i,j).gt.0.) THEN - soilt1(i,j)=min(273.15,0.5*(soilt(i,j)+tso(i,1,j)) ) + IF((soilt1(i,j) .LT. 170._kind_phys) .or. (soilt1(i,j) .GT.400._kind_phys)) THEN + IF(snowc(i,j).gt.zero) THEN + soilt1(i,j)=min(273.15_kind_phys,0.5_kind_phys*(soilt(i,j)+tso(i,1,j)) ) IF (debug_print ) THEN print *, & 'Temperature inside snow is initialized in RUCLSM ', soilt1(i,j),i,xlat,xlon @@ -479,24 +481,24 @@ SUBROUTINE LSMRUC(xlat,xlon, & soilt1(i,j) = tso(i,1,j) ENDIF ENDIF - tsnav(i,j) =min(0.,0.5*(soilt(i,j)+tso(i,1,j))-273.15) + tsnav(i,j) =min(zero,0.5_kind_phys*(soilt(i,j)+tso(i,1,j))-273.15_kind_phys) !- 10feb22 - limit snow albedo at high elevations !- based on Roesch et al., Climate Dynamics (2001),17:933-946 - if(hgt(i,j) > 2500.) then - snoalb(i,j) = min(0.65,snoalb(i,j)) + if(hgt(i,j) > 2500._kind_phys) then + snoalb(i,j) = min(0.65_kind_phys,snoalb(i,j)) endif - patmb=P8w(i,kms,j)*1.e-2 + patmb=P8w(i,kms,j)*1.e-2_kind_phys QSG (i,j) = QSN(SOILT(i,j),TBQ)/PATMB - if((qcg(i,j) < 0.) .or. (qcg(i,j) > 0.1)) then + if((qcg(i,j) < zero) .or. (qcg(i,j) > 0.1_kind_phys)) then qcg (i,j) = qc3d(i,1,j) if (debug_print ) then print *, 'QCG is initialized in RUCLSM ', qcg(i,j),qc3d(i,1,j),i,xlat,xlon endif endif - if((qvg(i,j) .LE. 0.) .or. (qvg(i,j) .GT.0.1)) then + if((qvg(i,j) .LE. zero) .or. (qvg(i,j) .GT.0.1_kind_phys)) then qvg (i,j) = qv3d(i,1,j) if (debug_print ) then print *, 'QVG is initialized in RUCLSM ', qvg(i,j),mavail(i,j),qsg(i,j),i,xlat,xlon @@ -504,64 +506,64 @@ SUBROUTINE LSMRUC(xlat,xlon, & endif qsfc(i,j) = qvg(i,j)/(1.+qvg(i,j)) - SMELT(i,j) = 0. - SNOM (i,j) = 0. - ACSNOW(i,j) = 0. - SNOWFALLAC(i,j) = 0. - PRECIPFR(i,j) = 0. - RHOSNF(i,j) = -1.e3 ! non-zero flag - SNFLX(i,j) = 0. - DEW (i,j) = 0. - PC (i,j) = 0. - zntl (i,j) = 0. - RUNOFF1(i,j) = 0. - RUNOFF2(i,j) = 0. - SFCRUNOFF(i,j) = 0. - UDRUNOFF(i,j) = 0. - ACRUNOFF(i,j) = 0. - emissl (i,j) = 0. - msnf (i,j) = 0. - facsnf (i,j) = 0. - budget(i,j) = 0. - acbudget(i,j) = 0. - waterbudget(i,j) = 0. - acwaterbudget(i,j) = 0. - smtotold(i,j)=0. - canwatold(i,j)=0. + SMELT(i,j) = zero + SNOM (i,j) = zero + ACSNOW(i,j) = zero + SNOWFALLAC(i,j) = zero + PRECIPFR(i,j) = zero + RHOSNF(i,j) = -1.e3_kind_phys ! non-zero flag + SNFLX(i,j) = zero + DEW (i,j) = zero + PC (i,j) = zero + zntl (i,j) = zero + RUNOFF1(i,j) = zero + RUNOFF2(i,j) = zero + SFCRUNOFF(i,j) = zero + UDRUNOFF(i,j) = zero + ACRUNOFF(i,j) = zero + emissl (i,j) = zero + msnf (i,j) = zero + facsnf (i,j) = zero + budget(i,j) = zero + acbudget(i,j) = zero + waterbudget(i,j) = zero + acwaterbudget(i,j) = zero + smtotold(i,j)=zero + canwatold(i,j)=zero !> - For RUC LSM CHKLOWQ needed for MYJPBL should !! 1 because is actual specific humidity at the surface, and !! not the saturation value - chklowq(i,j) = 1. - infiltr(i,j) = 0. - snoh (i,j) = 0. - edir (i,j) = 0. - ec (i,j) = 0. - ett (i,j) = 0. - sublim(i,j) = 0. - sflx (i,j) = 0. - smf (i,j) = 0. - evapl (i,j) = 0. - prcpl (i,j) = 0. + chklowq(i,j) = one + infiltr(i,j) = zero + snoh (i,j) = zero + edir (i,j) = zero + ec (i,j) = zero + ett (i,j) = zero + sublim(i,j) = zero + sflx (i,j) = zero + smf (i,j) = zero + evapl (i,j) = zero + prcpl (i,j) = zero ENDDO ENDDO - infiltrp = 0. + infiltrp = zero do k=1,nsl - soilice(k)=0. - soiliqw(k)=0. + soilice(k)=zero + soiliqw(k)=zero enddo endif ! cold start endif ! init==.true. !----------------------------------------------------------------- - PRCPMS = 0. - newsnms = 0. - prcpncliq = 0. - prcpculiq = 0. - prcpncfr = 0. - prcpcufr = 0. + PRCPMS = zero + newsnms = zero + prcpncliq = zero + prcpculiq = zero + prcpncfr = zero + prcpcufr = zero DO J=jts,jte @@ -586,66 +588,64 @@ SUBROUTINE LSMRUC(xlat,xlon, & TABS = T3D(i,kms,j) QVATM = QV3D(i,kms,j) QCATM = QC3D(i,kms,j) - PATM = P8w(i,kms,j)*1.e-5 + PATM = P8w(i,kms,j)*1.e-5_kind_phys !> - Z3D(1) is thickness between first full sigma level and the surface, !! but first mass level is at the half of the first sigma level !! (u and v are also at the half of first sigma level) - CONFLX = Z3D(i,kms,j)*0.5 + CONFLX = Z3D(i,kms,j)*0.5_kind_phys RHO = RHO3D(I,kms,J) !> - Initialize snow, graupel and ice fractions in frozen precip - snowrat = 0. - grauprat = 0. - icerat = 0. - curat = 0. + snowrat = zero + grauprat = zero + icerat = zero + curat = zero IF(FRPCPN) THEN prcpncliq = rainncv(i,j)*(1.-frzfrac(i,j)) prcpncfr = rainncv(i,j)*frzfrac(i,j) !> - Apply the same frozen precipitation fraction to convective precip !tgs - 31 mar17 - add temperature check in case Thompson MP produces ! frozen precip at T > 273. - if(frzfrac(i,j) > 0. .and. tabs < 273.) then - prcpculiq = max(0.,raincv(i,j)*(1.-frzfrac(i,j))) - prcpcufr = max(0.,raincv(i,j)*frzfrac(i,j)) -! prcpculiq = max(0.,(rainbl(i,j)-rainncv(i,j))*(1.-frzfrac(i,j))) -! prcpcufr = max(0.,(rainbl(i,j)-rainncv(i,j))*frzfrac(i,j)) + if(frzfrac(i,j) > zero .and. tabs < 273._kind_phys) then + prcpculiq = max(zero,raincv(i,j)*(one-frzfrac(i,j))) + prcpcufr = max(zero,raincv(i,j)*frzfrac(i,j)) else - if(tabs < 273.) then - prcpcufr = max(0.,raincv(i,j)) - prcpculiq = 0. + if(tabs < 273._kind_phys) then + prcpcufr = max(zero,raincv(i,j)) + prcpculiq = zero else - prcpcufr = 0. - prcpculiq = max(0.,raincv(i,j)) + prcpcufr = zero + prcpculiq = max(zero,raincv(i,j)) endif ! tabs < 273. endif ! frzfrac > 0. !--- 1*e-3 is to convert from mm/s to m/s - PRCPMS = (prcpncliq + prcpculiq)/DT*1.e-3 - NEWSNMS = (prcpncfr + prcpcufr)/DT*1.e-3 + PRCPMS = (prcpncliq + prcpculiq)/DT*1.e-3_kind_phys + NEWSNMS = (prcpncfr + prcpcufr)/DT*1.e-3_kind_phys - if((prcpncfr + prcpcufr) > 0.) then + if((prcpncfr + prcpcufr) > zero) then !> - Calculate snow, graupel and ice fractions in falling frozen precip - snowrat=min(1.,max(0.,snowncv(i,j)/(prcpncfr + prcpcufr))) - grauprat=min(1.,max(0.,graupelncv(i,j)/(prcpncfr + prcpcufr))) - icerat=min(1.,max(0.,(prcpncfr-snowncv(i,j)-graupelncv(i,j)) & + snowrat=min(one,max(zero,snowncv(i,j)/(prcpncfr + prcpcufr))) + grauprat=min(one,max(zero,graupelncv(i,j)/(prcpncfr + prcpcufr))) + icerat=min(one,max(zero,(prcpncfr-snowncv(i,j)-graupelncv(i,j)) & /(prcpncfr + prcpcufr))) - curat=min(1.,max(0.,(prcpcufr/(prcpncfr + prcpcufr)))) + curat=min(one,max(zero,(prcpcufr/(prcpncfr + prcpcufr)))) endif ELSE ! .not. FRPCPN - if (tabs.le.273.15) then - PRCPMS = 0. - NEWSNMS = RAINBL(i,j)/DT*1.e-3 + if (tabs.le.273.15_kind_phys) then + PRCPMS = zero + NEWSNMS = RAINBL(i,j)/DT*1.e-3_kind_phys !> - If here no info about constituents of frozen precipitation, !! suppose it is all snow - snowrat = 1. + snowrat = one else - PRCPMS = RAINBL(i,j)/DT*1.e-3 - NEWSNMS = 0. + PRCPMS = RAINBL(i,j)/DT*1.e-3_kind_phys + NEWSNMS = zero endif ENDIF ! -- save time-step water equivalent of frozen precipitation in PRECIPFR array to be used in ! module_diagnostics - precipfr(i,j) = NEWSNMS * DT *1.e3 + precipfr(i,j) = NEWSNMS * DT *1.e3_kind_phys if (myj) then QKMS=CHS(i,j) @@ -654,23 +654,23 @@ SUBROUTINE LSMRUC(xlat,xlon, & !> - Convert exchange coeff QKMS to [m/s] QKMS=FLQC(I,J)/RHO/MAVAIL(I,J) ! TKMS=FLHC(I,J)/RHO/CP - TKMS=FLHC(I,J)/RHO/(CP*(1.+0.84*QVATM)) ! mynnsfc uses CPM + TKMS=FLHC(I,J)/RHO/(CP*(one+0.84_kind_phys*QVATM)) ! mynnsfc uses CPM endif !> - Convert incoming snow and canwat from mm to m - SNWE=SNOW(I,J)*1.E-3 + SNWE=SNOW(I,J)*1.E-3_kind_phys SNHEI=SNOWH(I,J) - CANWATR=CANWAT(I,J)*1.E-3 + CANWATR=CANWAT(I,J)*1.E-3_kind_phys SNOWFRAC=SNOWC(I,J) RHOSNFALL=RHOSNF(I,J) snowold(i,j)=snwe !----- - zsmain(1)=0. - zshalf(1)=0. + zsmain(1)=zero + zshalf(1)=zero do k=2,nzs zsmain(k)= zs(k) - zshalf(k)=0.5*(zsmain(k-1) + zsmain(k)) + zshalf(k)=0.5_kind_phys*(zsmain(k-1) + zsmain(k)) enddo do k=1,nlcat @@ -701,32 +701,32 @@ SUBROUTINE LSMRUC(xlat,xlon, & DTDZS(K2)=X/(ZSMAIN(K+1)-ZSMAIN(K)) END DO - CW =4.183E6 + CW =4.183E6_kind_dbl_prec !--- Constants used in Johansen soil thermal !--- conductivity method - KQWRTZ=7.7 - KICE=2.2 - KWT=0.57 + KQWRTZ=7.7_kind_dbl_prec + KICE=2.2_kind_dbl_prec + KWT=0.57_kind_dbl_prec !*********************************************************************** !--- Constants for snow density calculations C1SN and C2SN - c1sn=0.026 - c2sn=21. + c1sn=0.026_kind_dbl_prec + c2sn=21._kind_dbl_prec !*********************************************************************** NROOT= 4 ! ! rooting depth - RHONEWSN = 200. - if(SNOW(i,j).gt.0. .and. SNOWH(i,j).gt.0.02) then + RHONEWSN = 200._kind_phys + if(SNOW(i,j).gt.zero .and. SNOWH(i,j).gt.0.02_kind_phys) then RHOSN = SNOW(i,j)/SNOWH(i,j) else - RHOSN = 300. + RHOSN = 300._kind_phys endif IF (debug_print ) THEN @@ -1210,17 +1210,17 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia INTEGER, INTENT(IN ) :: isice,i,j,nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) - real (kind=kind_phys), INTENT(IN ) :: DELT,CONFLX,meltfactor,xlat,xlon - real (kind=kind_phys), INTENT(IN ) :: testptlat,testptlon - real (kind=kind_phys), INTENT(IN ) :: C1SN,C2SN,RHONEWSN_ex + real (kind_phys), INTENT(IN ) :: DELT,CONFLX,meltfactor,xlat,xlon + real (kind_phys), INTENT(IN ) :: testptlat,testptlon + real (kind_phys), INTENT(IN ) :: C1SN,C2SN,RHONEWSN_ex LOGICAL, INTENT(IN ) :: myj, debug_print, exticeden !--- 3-D Atmospheric variables - real (kind=kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: PATM, & TABS, & QVATM, & QCATM - real (kind=kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: GLW, & GSW, & GSWdn, & @@ -1237,7 +1237,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia INTEGER, INTENT(IN ) :: IVGTYP, ISLTYP !--- 2-D variables - real (kind=kind_phys) , & + real (kind_phys) , & INTENT(INOUT) :: EMISS, & EMISBCK, & MAVAIL, & @@ -1247,7 +1247,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia CST !--- soil properties - real (kind=kind_phys) :: & + real (kind_phys) :: & RHOCS, & BCLH, & DQM, & @@ -1259,7 +1259,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia SAT, & WILT - real (kind=kind_phys), INTENT(IN ) :: CN, & + real (kind_phys), INTENT(IN ) :: CN, & CW, & CP, & ROVCP, & @@ -1270,26 +1270,26 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia KICE, & KWT - real (kind=kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & ZSHALF, & DTDZS2 - real (kind=kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - real (kind=kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ + real (kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ !--- input/output variables !-------- 3-d soil moisture and temperature - real (kind=kind_phys), DIMENSION( 1:nzs ) , & + real (kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: TS1D, & SOILM1D, & SMFRKEEP - real (kind=kind_phys), DIMENSION( 1:nzs ) , & + real (kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: KEEPFR - real (kind=kind_phys), DIMENSION(1:NZS), INTENT(INOUT) :: SOILICE, & + real (kind_phys), DIMENSION(1:NZS), INTENT(INOUT) :: SOILICE, & SOILIQW @@ -1297,7 +1297,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia INTEGER :: ILANDs !-------- 2-d variables - real (kind=kind_phys) , & + real (kind_phys) , & INTENT(INOUT) :: DEW, & EDIR1, & EC1, & @@ -1337,7 +1337,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia TSNAV, & ZNT - real (kind=kind_phys), DIMENSION(1:NZS) :: & + real (kind_phys), DIMENSION(1:NZS) :: & tice, & rhosice, & capice, & @@ -1349,7 +1349,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia SOILICES, & KEEPFRS !-------- 1-d variables - real (kind=kind_phys) :: & + real (kind_phys) :: & DEWS, & MAVAILS, & EDIR1s, & @@ -1374,23 +1374,23 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia - real (kind=kind_phys), INTENT(INOUT) :: RSM, & + real (kind_phys), INTENT(INOUT) :: RSM, & SNWEPRINT, & SNHEIPRINT !--- Local variables INTEGER :: K,ILNB - real (kind=kind_phys) :: BSN, XSN , & + real (kind_phys) :: BSN, XSN , & RAINF, SNTH, NEWSN, PRCPMS, NEWSNMS , & T3, UPFLUX, XINET, snowfrac2, m - real (kind=kind_phys) :: snhei_crit, snhei_crit_newsn, keep_snow_albedo, SNOWFRACnewsn - real (kind=kind_phys) :: newsnowratio, dd1 + real (kind_phys) :: snhei_crit, snhei_crit_newsn, keep_snow_albedo, SNOWFRACnewsn + real (kind_phys) :: newsnowratio, dd1 - real (kind=kind_phys) :: rhonewgr,rhonewice + real (kind_phys) :: rhonewgr,rhonewice - real (kind=kind_phys) :: RNET,GSWNEW,GSWIN,EMISSN,ZNTSN,EMISS_snowfree - real (kind=kind_phys) :: VEGFRAC, snow_mosaic, snfr, vgfr + real (kind_phys) :: RNET,GSWNEW,GSWIN,EMISSN,ZNTSN,EMISS_snowfree + real (kind_phys) :: VEGFRAC, snow_mosaic, snfr, vgfr real :: cice, albice, albsn, drip, dripsn, dripliq real :: interw, intersn, infwater, intwratio @@ -2267,10 +2267,10 @@ END SUBROUTINE SFCTMP !! the precomputed table and a given temperature. FUNCTION QSN(TN,T) !**************************************************************** - real (kind=kind_phys), DIMENSION(1:5001), INTENT(IN ) :: T - real (kind=kind_phys), INTENT(IN ) :: TN + real (kind_phys), DIMENSION(1:5001), INTENT(IN ) :: T + real (kind_phys), INTENT(IN ) :: TN - real (kind=kind_phys) QSN, R,R1,R2 + real (kind_phys) QSN, R,R1,R2 INTEGER I R=(TN-173.15)/.05+1. @@ -2373,15 +2373,15 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,iland,isoil - real (kind=kind_phys), INTENT(IN ) :: DELT,CONFLX,xlat,xlon + real (kind_phys), INTENT(IN ) :: DELT,CONFLX,xlat,xlon LOGICAL, INTENT(IN ) :: myj !--- 3-D Atmospheric variables - real (kind=kind_phys), & + real (kind_phys), & INTENT(IN ) :: PATM, & QVATM, & QCATM !--- 2-D variables - real (kind=kind_phys), & + real (kind_phys), & INTENT(IN ) :: GLW, & GSW, & GSWin, & @@ -2395,7 +2395,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & TKMS !--- soil properties - real (kind=kind_phys), & + real (kind_phys), & INTENT(IN ) :: RHOCS, & BCLH, & DQM, & @@ -2406,7 +2406,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & REF, & WILT - real (kind=kind_phys), INTENT(IN ) :: CN, & + real (kind_phys), INTENT(IN ) :: CN, & CW, & KQWRTZ, & KICE, & @@ -2415,27 +2415,27 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & g0_p - real (kind=kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & ZSHALF, & DTDZS2 - real (kind=kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - real (kind=kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ + real (kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ !--- input/output variables !-------- 3-d soil moisture and temperature - real (kind=kind_phys), DIMENSION( 1:nzs ) , & + real (kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: TSO, & SOILMOIS, & SMFRKEEP - real (kind=kind_phys), DIMENSION( 1:nzs ) , & + real (kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: KEEPFR !-------- 2-d variables - real (kind=kind_phys), & + real (kind_phys), & INTENT(INOUT) :: DEW, & CST, & DRIP, & @@ -2459,27 +2459,27 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & SOILT !-------- 1-d variables - real (kind=kind_phys), DIMENSION(1:NZS), INTENT(OUT) :: SOILICE, & + real (kind_phys), DIMENSION(1:NZS), INTENT(OUT) :: SOILICE, & SOILIQW !--- Local variables - real (kind=kind_phys) :: INFILTRP, transum , & + real (kind_phys) :: INFILTRP, transum , & RAINF, PRCPMS , & TABS, T3, UPFLUX, XINET - real (kind=kind_phys) :: CP,rovcp,G0,LV,STBOLT,xlmelt,dzstop , & + real (kind_phys) :: CP,rovcp,G0,LV,STBOLT,xlmelt,dzstop , & can,epot,fac,fltot,ft,fq,hft , & q1,ras,rhoice,sph , & trans,zn,ci,cvw,tln,tavln,pi , & DD1,CMC2MS,DRYCAN,WETCAN , & INFMAX,RIW, X - real (kind=kind_phys), DIMENSION(1:NZS) :: transp,cap,diffu,hydro, & + real (kind_phys), DIMENSION(1:NZS) :: transp,cap,diffu,hydro, & thdif,tranf,tav,soilmoism , & soilicem,soiliqwm,detal , & fwsat,lwsat,told,smold - real (kind=kind_phys) :: soiltold,smf - real (kind=kind_phys) :: soilres, alfa, fex, fex_fc, fc, psit + real (kind_phys) :: soiltold,smf + real (kind_phys) :: soilres, alfa, fex, fex_fc, fc, psit INTEGER :: nzs1,nzs2,k @@ -2927,15 +2927,15 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,iland,isoil - real (kind=kind_phys), INTENT(IN ) :: DELT,CONFLX,xlat,xlon + real (kind_phys), INTENT(IN ) :: DELT,CONFLX,xlat,xlon LOGICAL, INTENT(IN ) :: myj, debug_print !--- 3-D Atmospheric variables - real (kind=kind_phys), & + real (kind_phys), & INTENT(IN ) :: PATM, & QVATM, & QCATM !--- 2-D variables - real (kind=kind_phys), & + real (kind_phys), & INTENT(IN ) :: GLW, & GSW, & EMISS, & @@ -2943,7 +2943,7 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & QKMS, & TKMS !--- sea ice properties - real (kind=kind_phys), DIMENSION(1:NZS) , & + real (kind_phys), DIMENSION(1:NZS) , & INTENT(IN ) :: & tice, & rhosice, & @@ -2951,25 +2951,25 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & thdifice - real (kind=kind_phys), INTENT(IN ) :: & + real (kind_phys), INTENT(IN ) :: & CW, & XLV - real (kind=kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & ZSHALF, & DTDZS2 - real (kind=kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - real (kind=kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ + real (kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ !--- input/output variables !----soil temperature - real (kind=kind_phys), DIMENSION( 1:nzs ), INTENT(INOUT) :: TSO + real (kind_phys), DIMENSION( 1:nzs ), INTENT(INOUT) :: TSO !-------- 2-d variables - real (kind=kind_phys), & + real (kind_phys), & INTENT(INOUT) :: DEW, & EETA, & EVAPL, & @@ -2984,21 +2984,21 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & SOILT !--- Local variables - real (kind=kind_phys) :: x,x1,x2,x4,tn,denom - real (kind=kind_phys) :: RAINF, PRCPMS , & + real (kind_phys) :: x,x1,x2,x4,tn,denom + real (kind_phys) :: RAINF, PRCPMS , & TABS, T3, UPFLUX, XINET - real (kind=kind_phys) :: CP,rovcp,G0,LV,STBOLT,xlmelt,dzstop , & + real (kind_phys) :: CP,rovcp,G0,LV,STBOLT,xlmelt,dzstop , & epot,fltot,ft,fq,hft,ras,cvw - real (kind=kind_phys) :: FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11, & + real (kind_phys) :: FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11, & PI,H,FKQ,R210,AA,BB,PP,Q1,QS1,TS1,TQ2,TX2 , & TDENOM,QGOLD,SNOH - real (kind=kind_phys) :: AA1,RHCS, icemelt + real (kind_phys) :: AA1,RHCS, icemelt - real (kind=kind_phys), DIMENSION(1:NZS) :: cotso,rhtso + real (kind_phys), DIMENSION(1:NZS) :: cotso,rhtso INTEGER :: nzs1,nzs2,k,k1,kn,kk @@ -3268,7 +3268,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,isoil - real (kind=kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS, & + real (kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS, & RAINF,NEWSNOW,RHONEWSN, & testptlat,testptlon, & SNHEI_CRIT,meltfactor,xlat,xlon @@ -3276,12 +3276,12 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & LOGICAL, INTENT(IN ) :: myj !--- 3-D Atmospheric variables - real (kind=kind_phys), & + real (kind_phys), & INTENT(IN ) :: PATM, & QVATM, & QCATM !--- 2-D variables - real (kind=kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: GLW, & GSW, & GSWin, & @@ -3295,7 +3295,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & INTEGER, INTENT(IN ) :: IVGTYP !--- soil properties - real (kind=kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: RHOCS, & BCLH, & DQM, & @@ -3307,7 +3307,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & SAT, & WILT - real (kind=kind_phys), INTENT(IN ) :: CN, & + real (kind_phys), INTENT(IN ) :: CN, & CW, & XLV, & G0_P, & @@ -3316,23 +3316,23 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & KWT - real (kind=kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & ZSHALF, & DTDZS2 - real (kind=kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - real (kind=kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ + real (kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ !--- input/output variables !-------- 3-d soil moisture and temperature - real (kind=kind_phys), DIMENSION( 1:nzs ) , & + real (kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: TSO, & SOILMOIS, & SMFRKEEP - real (kind=kind_phys), DIMENSION( 1:nzs ) , & + real (kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: KEEPFR @@ -3340,7 +3340,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & !-------- 2-d variables - real (kind=kind_phys) , & + real (kind_phys) , & INTENT(INOUT) :: DEW, & CST, & DRIP, & @@ -3377,10 +3377,10 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & INTEGER, INTENT(INOUT) :: ILNB !-------- 1-d variables - real (kind=kind_phys), DIMENSION(1:NZS), INTENT(OUT) :: SOILICE, & + real (kind_phys), DIMENSION(1:NZS), INTENT(OUT) :: SOILICE, & SOILIQW - real (kind=kind_phys), INTENT(OUT) :: RSM, & + real (kind_phys), INTENT(OUT) :: RSM, & SNWEPRINT, & SNHEIPRINT !--- Local variables @@ -3388,24 +3388,24 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & INTEGER :: nzs1,nzs2,k - real (kind=kind_phys) :: INFILTRP, TRANSUM , & + real (kind_phys) :: INFILTRP, TRANSUM , & SNTH, NEWSN , & TABS, T3, UPFLUX, XINET , & BETA, SNWEPR,EPDT,PP - real (kind=kind_phys) :: CP,rovcp,G0,LV,xlvm,STBOLT,xlmelt,dzstop, & + real (kind_phys) :: CP,rovcp,G0,LV,xlvm,STBOLT,xlmelt,dzstop, & can,epot,fac,fltot,ft,fq,hft , & q1,ras,rhoice,sph , & trans,zn,ci,cvw,tln,tavln,pi , & DD1,CMC2MS,DRYCAN,WETCAN , & INFMAX,RIW,DELTSN,H,UMVEG - real (kind=kind_phys), DIMENSION(1:NZS) :: transp,cap,diffu,hydro, & + real (kind_phys), DIMENSION(1:NZS) :: transp,cap,diffu,hydro, & thdif,tranf,tav,soilmoism , & soilicem,soiliqwm,detal , & fwsat,lwsat,told,smold - real (kind=kind_phys) :: soiltold, qgold + real (kind_phys) :: soiltold, qgold - real (kind=kind_phys) :: RNET, X + real (kind_phys) :: RNET, X !----------------------------------------------------------------- @@ -3869,19 +3869,19 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,isoil - real (kind=kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS, & + real (kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS, & RAINF,NEWSNOW,RHONEWSN, & meltfactor,snhei_crit,xlat,xlon real :: rhonewcsn LOGICAL, INTENT(IN ) :: myj !--- 3-D Atmospheric variables - real (kind=kind_phys), & + real (kind_phys), & INTENT(IN ) :: PATM, & QVATM, & QCATM !--- 2-D variables - real (kind=kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: GLW, & GSW, & RHO, & @@ -3889,35 +3889,35 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & TKMS !--- sea ice properties - real (kind=kind_phys), DIMENSION(1:NZS) , & + real (kind_phys), DIMENSION(1:NZS) , & INTENT(IN ) :: & tice, & rhosice, & capice, & thdifice - real (kind=kind_phys), INTENT(IN ) :: & + real (kind_phys), INTENT(IN ) :: & CW, & XLV - real (kind=kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & ZSHALF, & DTDZS2 - real (kind=kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - real (kind=kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ + real (kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ !--- input/output variables !-------- 3-d soil moisture and temperature - real (kind=kind_phys), DIMENSION( 1:nzs ) , & + real (kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: TSO INTEGER, INTENT(INOUT) :: ILAND !-------- 2-d variables - real (kind=kind_phys) , & + real (kind_phys) , & INTENT(INOUT) :: DEW, & EETA, & RHOSN, & @@ -3945,37 +3945,37 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & INTEGER, INTENT(INOUT) :: ILNB - real (kind=kind_phys), INTENT(OUT) :: RSM, & + real (kind_phys), INTENT(OUT) :: RSM, & SNWEPRINT, & SNHEIPRINT !--- Local variables INTEGER :: nzs1,nzs2,k,k1,kn,kk - real (kind=kind_phys) :: x,x1,x2,dzstop,ft,tn,denom + real (kind_phys) :: x,x1,x2,dzstop,ft,tn,denom - real (kind=kind_phys) :: SNTH, NEWSN , & + real (kind_phys) :: SNTH, NEWSN , & TABS, T3, UPFLUX, XINET , & BETA, SNWEPR,EPDT,PP - real (kind=kind_phys) :: CP,rovcp,G0,LV,xlvm,STBOLT,xlmelt , & + real (kind_phys) :: CP,rovcp,G0,LV,xlvm,STBOLT,xlmelt , & epot,fltot,fq,hft,q1,ras,rhoice,ci,cvw , & RIW,DELTSN,H - real (kind=kind_phys) :: rhocsn,thdifsn, & + real (kind_phys) :: rhocsn,thdifsn, & xsn,ddzsn,x1sn,d1sn,d2sn,d9sn,r22sn - real (kind=kind_phys) :: cotsn,rhtsn,xsn1,ddzsn1,x1sn1,ftsnow,denomsn - real (kind=kind_phys) :: fso,fsn, & + real (kind_phys) :: cotsn,rhtsn,xsn1,ddzsn1,x1sn1,ftsnow,denomsn + real (kind_phys) :: fso,fsn, & FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11, & FKQ,R210,AA,BB,QS1,TS1,TQ2,TX2, & TDENOM,AA1,RHCS,H1,TSOB, SNPRIM, & SNODIF,SOH,TNOLD,QGOLD,SNOHGNEW - real (kind=kind_phys), DIMENSION(1:NZS) :: cotso,rhtso + real (kind_phys), DIMENSION(1:NZS) :: cotso,rhtso - real (kind=kind_phys) :: RNET,rsmfrac,soiltfrac,hsn,icemelt,rr + real (kind_phys) :: RNET,rsmfrac,soiltfrac,hsn,icemelt,rr integer :: nmelt - real (kind=kind_phys) :: keff, fact + real (kind_phys) :: keff, fact !----------------------------------------------------------------- XLMELT=3.35E+5 @@ -4726,15 +4726,15 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,iland,isoil - real (kind=kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS, RAINF,xlat,xlon - real (kind=kind_phys), INTENT(INOUT) :: DRYCAN,WETCAN,TRANSUM + real (kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS, RAINF,xlat,xlon + real (kind_phys), INTENT(INOUT) :: DRYCAN,WETCAN,TRANSUM !--- 3-D Atmospheric variables - real (kind=kind_phys), & + real (kind_phys), & INTENT(IN ) :: PATM, & QVATM, & QCATM !--- 2-D variables - real (kind=kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: & EMISS, & RHO, & @@ -4747,17 +4747,17 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & TKMS !--- soil properties - real (kind=kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: & BCLH, & DQM, & QMIN - real (kind=kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: & soilres,alfa - real (kind=kind_phys), INTENT(IN ) :: CP, & + real (kind_phys), INTENT(IN ) :: CP, & CVW, & XLV, & STBOLT, & @@ -4765,23 +4765,23 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & G0_P - real (kind=kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & ZSHALF, & THDIF, & CAP - real (kind=kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - real (kind=kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ + real (kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ !--- input/output variables !-------- 3-d soil moisture and temperature - real (kind=kind_phys), DIMENSION( 1:nzs ) , & + real (kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: TSO !-------- 2-d variables - real (kind=kind_phys) , & + real (kind_phys) , & INTENT(INOUT) :: & MAVAIL, & QVG, & @@ -4792,16 +4792,16 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & !--- Local variables - real (kind=kind_phys) :: x,x1,x2,x4,dzstop,can,ft,sph , & + real (kind_phys) :: x,x1,x2,x4,dzstop,can,ft,sph , & tn,trans,umveg,denom,fex - real (kind=kind_phys) :: FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11, & + real (kind_phys) :: FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11, & PI,H,FKQ,R210,AA,BB,PP,Q1,QS1,TS1,TQ2,TX2 , & TDENOM - real (kind=kind_phys) :: C,CC,AA1,RHCS,H1, QGOLD + real (kind_phys) :: C,CC,AA1,RHCS,H1, QGOLD - real (kind=kind_phys), DIMENSION(1:NZS) :: cotso,rhtso + real (kind_phys), DIMENSION(1:NZS) :: cotso,rhtso INTEGER :: nzs1,nzs2,k,k1,kn,kk, iter @@ -5032,7 +5032,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,iland,isoil - real (kind=kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS , & + real (kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS , & RAINF,NEWSNOW,DELTSN,SNTH , & TABS,TRANSUM,SNWEPR , & testptlat,testptlon , & @@ -5040,12 +5040,12 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & real :: rhonewcsn !--- 3-D Atmospheric variables - real (kind=kind_phys), & + real (kind_phys), & INTENT(IN ) :: PATM, & QVATM, & QCATM !--- 2-D variables - real (kind=kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: GLW, & GSW, & RHO, & @@ -5055,14 +5055,14 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & TKMS !--- soil properties - real (kind=kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: & BCLH, & DQM, & PSIS, & QMIN - real (kind=kind_phys), INTENT(IN ) :: CP, & + real (kind_phys), INTENT(IN ) :: CP, & ROVCP, & CVW, & STBOLT, & @@ -5070,25 +5070,25 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & G0_P - real (kind=kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & ZSHALF, & THDIF, & CAP, & TRANF - real (kind=kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - real (kind=kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ + real (kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ !--- input/output variables !-------- 3-d soil moisture and temperature - real (kind=kind_phys), DIMENSION( 1:nzs ) , & + real (kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: TSO !-------- 2-d variables - real (kind=kind_phys) , & + real (kind_phys) , & INTENT(INOUT) :: DEW, & CST, & RHOSN, & @@ -5108,9 +5108,9 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & SOILT1, & TSNAV - real (kind=kind_phys), INTENT(INOUT) :: DRYCAN, WETCAN + real (kind_phys), INTENT(INOUT) :: DRYCAN, WETCAN - real (kind=kind_phys), INTENT(OUT) :: RSM, & + real (kind_phys), INTENT(OUT) :: RSM, & SNWEPRINT, & SNHEIPRINT INTEGER, INTENT(OUT) :: ilnb @@ -5119,16 +5119,16 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & INTEGER :: nzs1,nzs2,k,k1,kn,kk - real (kind=kind_phys) :: x,x1,x2,x4,dzstop,can,ft,sph, & + real (kind_phys) :: x,x1,x2,x4,dzstop,can,ft,sph, & tn,trans,umveg,denom - real (kind=kind_phys) :: cotsn,rhtsn,xsn1,ddzsn1,x1sn1,ftsnow,denomsn + real (kind_phys) :: cotsn,rhtsn,xsn1,ddzsn1,x1sn1,ftsnow,denomsn - real (kind=kind_phys) :: t3,upflux,xinet,ras, & + real (kind_phys) :: t3,upflux,xinet,ras, & xlmelt,rhocsn,thdifsn, & beta,epot,xsn,ddzsn,x1sn,d1sn,d2sn,d9sn,r22sn - real (kind=kind_phys) :: fso,fsn, & + real (kind_phys) :: fso,fsn, & FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11, & PI,H,FKQ,R210,AA,BB,PP,Q1,QS1,TS1,TQ2,TX2, & TDENOM,C,CC,AA1,RHCS,H1, & @@ -5136,15 +5136,15 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & smeltg,snohg,snodif,soh, & CMC2MS,TNOLD,QGOLD,SNOHGNEW - real (kind=kind_phys), DIMENSION(1:NZS) :: transp,cotso,rhtso - real (kind=kind_phys) :: edir1, & + real (kind_phys), DIMENSION(1:NZS) :: transp,cotso,rhtso + real (kind_phys) :: edir1, & ec1, & ett1, & eeta, & qfx, & hfx - real (kind=kind_phys) :: RNET,rsmfrac,soiltfrac,hsn,rr,keff,fact + real (kind_phys) :: RNET,rsmfrac,soiltfrac,hsn,rr,keff,fact integer :: nmelt, iter !----------------------------------------------------------------- @@ -6006,12 +6006,12 @@ SUBROUTINE SOILMOIST ( debug_print, & !------------------------------------------------------------------ !--- input variables LOGICAL, INTENT(IN ) :: debug_print - real (kind=kind_phys), INTENT(IN ) :: DELT + real (kind_phys), INTENT(IN ) :: DELT INTEGER, INTENT(IN ) :: NZS,NDDZS ! input variables - real (kind=kind_phys), DIMENSION(1:NZS), INTENT(IN ) :: ZSMAIN, & + real (kind_phys), DIMENSION(1:NZS), INTENT(IN ) :: ZSMAIN, & ZSHALF, & DIFFU, & HYDRO, & @@ -6019,33 +6019,33 @@ SUBROUTINE SOILMOIST ( debug_print, & SOILICE, & DTDZS2 - real (kind=kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - real (kind=kind_phys), INTENT(IN ) :: QSG,QVG,QCG,QCATM,QVATM, & + real (kind_phys), INTENT(IN ) :: QSG,QVG,QCG,QCATM,QVATM, & QKMS,VEGFRAC,DRIP,PRCP , & DEW,SMELT,SNOWFRAC , & DQM,QMIN,REF,KSAT,RAS,RIW,SOILRES ! output - real (kind=kind_phys), DIMENSION( 1:nzs ) , & + real (kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: SOILMOIS,SOILIQW - real (kind=kind_phys), INTENT(INOUT) :: MAVAIL,RUNOFF,RUNOFF2,INFILTRP, & + real (kind_phys), INTENT(INOUT) :: MAVAIL,RUNOFF,RUNOFF2,INFILTRP, & INFMAX ! local variables - real (kind=kind_phys), DIMENSION( 1:nzs ) :: COSMC,RHSMC + real (kind_phys), DIMENSION( 1:nzs ) :: COSMC,RHSMC - real (kind=kind_phys) :: DZS,R1,R2,R3,R4,R5,R6,R7,R8,R9,R10 - real (kind=kind_phys) :: REFKDT,REFDK,DELT1,F1MAX,F2MAX - real (kind=kind_phys) :: F1,F2,FD,KDT,VAL,DDT,PX,FK,FKMAX - real (kind=kind_phys) :: QQ,UMVEG,INFMAX1,TRANS - real (kind=kind_phys) :: TOTLIQ,FLX,FLXSAT,QTOT - real (kind=kind_phys) :: DID,X1,X2,X4,DENOM,Q2,Q4 - real (kind=kind_phys) :: dice,fcr,acrt,frzx,sum,cvfrz + real (kind_phys) :: DZS,R1,R2,R3,R4,R5,R6,R7,R8,R9,R10 + real (kind_phys) :: REFKDT,REFDK,DELT1,F1MAX,F2MAX + real (kind_phys) :: F1,F2,FD,KDT,VAL,DDT,PX,FK,FKMAX + real (kind_phys) :: QQ,UMVEG,INFMAX1,TRANS + real (kind_phys) :: TOTLIQ,FLX,FLXSAT,QTOT + real (kind_phys) :: DID,X1,X2,X4,DENOM,Q2,Q4 + real (kind_phys) :: dice,fcr,acrt,frzx,sum,cvfrz INTEGER :: NZS1,NZS2,K,KK,K1,KN,ialp1,jj,jk @@ -6136,10 +6136,10 @@ SUBROUTINE SOILMOIST ( debug_print, & ! ----------- FROZEN GROUND VERSION ------------------------- ! REFERENCE FROZEN GROUND PARAMETER, CVFRZ, IS A SHAPE PARAMETER OF -! Areal (kind=kind_phys) DISTRIBUTION FUNCTION OF SOIL ICE CONTENT WHICH EQUALS 1/CV. +! Areal (kind_phys) DISTRIBUTION FUNCTION OF SOIL ICE CONTENT WHICH EQUALS 1/CV. ! CV IS A COEFFICIENT OF SPATIAL VARIATION OF SOIL ICE CONTENT. -! BASED ON FIELD DATA CV DEPENDS ON Areal (kind=kind_phys) MEAN OF FROZEN DEPTH, AND IT -! CLOSE TO CONSTANT = 0.6 IF Areal (kind=kind_phys) MEAN FROZEN DEPTH IS ABOVE 20 CM. +! BASED ON FIELD DATA CV DEPENDS ON Areal (kind_phys) MEAN OF FROZEN DEPTH, AND IT +! CLOSE TO CONSTANT = 0.6 IF Areal (kind_phys) MEAN FROZEN DEPTH IS ABOVE 20 CM. ! THAT IS WHY PARAMETER CVFRZ = 3 (INT{1/0.6*0.6}) ! ! Current logic doesn't allow CVFRZ be bigger than 3 @@ -6327,7 +6327,7 @@ SUBROUTINE SOILPROP( debug_print, & !--- soil properties LOGICAL, INTENT(IN ) :: debug_print INTEGER, INTENT(IN ) :: NZS - real (kind=kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: RHOCS, & BCLH, & DQM, & @@ -6336,12 +6336,12 @@ SUBROUTINE SOILPROP( debug_print, & QWRTZ, & QMIN - real (kind=kind_phys), DIMENSION( 1:nzs ) , & + real (kind_phys), DIMENSION( 1:nzs ) , & INTENT(IN ) :: SOILMOIS, & keepfr - real (kind=kind_phys), INTENT(IN ) :: CP, & + real (kind_phys), INTENT(IN ) :: CP, & CVW, & RIW, & kqwrtz, & @@ -6353,7 +6353,7 @@ SUBROUTINE SOILPROP( debug_print, & !--- output variables - real (kind=kind_phys), DIMENSION(1:NZS) , & + real (kind_phys), DIMENSION(1:NZS) , & INTENT(INOUT) :: cap,diffu,hydro , & thdif,tav , & soilmoism , & @@ -6362,14 +6362,14 @@ SUBROUTINE SOILPROP( debug_print, & fwsat,lwsat !--- local variables - real (kind=kind_phys), DIMENSION(1:NZS) :: hk,detal,kasat,kjpl + real (kind_phys), DIMENSION(1:NZS) :: hk,detal,kasat,kjpl - real (kind=kind_phys) :: x,x1,x2,x4,ws,wd,fact,fach,facd,psif,ci - real (kind=kind_phys) :: tln,tavln,tn,pf,a,am,ame,h + real (kind_phys) :: x,x1,x2,x4,ws,wd,fact,fach,facd,psif,ci + real (kind_phys) :: tln,tavln,tn,pf,a,am,ame,h INTEGER :: nzs1,k !-- for Johansen thermal conductivity - real (kind=kind_phys) :: kzero,gamd,kdry,kas,x5,sr,ke + real (kind_phys) :: kzero,gamd,kdry,kas,x5,sr,ke nzs1=nzs-1 @@ -6524,31 +6524,31 @@ SUBROUTINE TRANSF( debug_print, & LOGICAL, INTENT(IN ) :: debug_print INTEGER, INTENT(IN ) :: nroot,nzs,iland - real (kind=kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: GSWin, TABS, lai !--- soil properties - real (kind=kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: DQM, & QMIN, & REF, & PC, & WILT - real (kind=kind_phys), DIMENSION(1:NZS), INTENT(IN) :: soiliqw, & + real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: soiliqw, & ZSHALF !-- output - real (kind=kind_phys), DIMENSION(1:NZS), INTENT(OUT) :: TRANF - real (kind=kind_phys), INTENT(OUT) :: TRANSUM + real (kind_phys), DIMENSION(1:NZS), INTENT(OUT) :: TRANF + real (kind_phys), INTENT(OUT) :: TRANSUM !-- local variables - real (kind=kind_phys) :: totliq, did + real (kind_phys) :: totliq, did INTEGER :: k !-- for non-linear root distribution - real (kind=kind_phys) :: gx,sm1,sm2,sm3,sm4,ap0,ap1,ap2,ap3,ap4 - real (kind=kind_phys) :: FTEM, PCtot, fsol, f1, cmin, cmax, totcnd - real (kind=kind_phys), DIMENSION(1:NZS) :: PART + real (kind_phys) :: gx,sm1,sm2,sm3,sm4,ap0,ap1,ap2,ap3,ap4 + real (kind_phys) :: FTEM, PCtot, fsol, f1, cmin, cmax, totcnd + real (kind_phys), DIMENSION(1:NZS) :: PART !-------------------------------------------------------------------- do k=1,nzs @@ -6689,13 +6689,13 @@ SUBROUTINE VILKA(TN,D1,D2,PP,QS,TS,TT,NSTEP,ii,j,iland,isoil,xlat,xlon) !--- VILKA finds the solution of energy budget at the surface !--- using table T,QS computed from Clausius-Klapeiron !-------------------------------------------------------------- - real (kind=kind_phys), DIMENSION(1:5001), INTENT(IN ) :: TT - real (kind=kind_phys), INTENT(IN ) :: TN,D1,D2,PP,xlat,xlon + real (kind_phys), DIMENSION(1:5001), INTENT(IN ) :: TT + real (kind_phys), INTENT(IN ) :: TN,D1,D2,PP,xlat,xlon INTEGER, INTENT(IN ) :: NSTEP,ii,j,iland,isoil - real (kind=kind_phys), INTENT(OUT ) :: QS, TS + real (kind_phys), INTENT(OUT ) :: QS, TS - real (kind=kind_phys) :: F1,T1,T2,RN + real (kind_phys) :: F1,T1,T2,RN INTEGER :: I,I1 I=(TN-1.7315E2)/.05+1 @@ -6787,7 +6787,7 @@ SUBROUTINE SOILVEGIN ( debug_print, & ! 19 White Sand ! !---------------------------------------------------------------------- - real (kind=kind_phys) LQMA(nsoilclas),LRHC(nsoilclas), & + real (kind_phys) LQMA(nsoilclas),LRHC(nsoilclas), & LPSI(nsoilclas),LQMI(nsoilclas), & LBCL(nsoilclas),LKAS(nsoilclas), & LWIL(nsoilclas),LREF(nsoilclas), & @@ -6924,7 +6924,7 @@ SUBROUTINE SOILVEGIN ( debug_print, & !---- Below are the arrays for the vegetation parameters - real (kind=kind_phys) LALB(nvegclas),LMOI(nvegclas),LEMI(nvegclas), & + real (kind_phys) LALB(nvegclas),LMOI(nvegclas),LEMI(nvegclas), & LROU(nvegclas),LTHI(nvegclas),LSIG(nvegclas), & LPC(nvegclas) @@ -6959,24 +6959,24 @@ SUBROUTINE SOILVEGIN ( debug_print, & ISLTYP LOGICAL, INTENT(IN ) :: myj - real (kind=kind_phys), INTENT(IN ) :: SHDMAX - real (kind=kind_phys), INTENT(IN ) :: SHDMIN - real (kind=kind_phys), INTENT(IN ) :: VEGFRAC - real (kind=kind_phys), DIMENSION( 1:NLCAT ), INTENT(IN):: LUFRAC - real (kind=kind_phys), DIMENSION( 1:NSCAT ), INTENT(IN):: SOILFRAC + real (kind_phys), INTENT(IN ) :: SHDMAX + real (kind_phys), INTENT(IN ) :: SHDMIN + real (kind_phys), INTENT(IN ) :: VEGFRAC + real (kind_phys), DIMENSION( 1:NLCAT ), INTENT(IN):: LUFRAC + real (kind_phys), DIMENSION( 1:NSCAT ), INTENT(IN):: SOILFRAC - real (kind=kind_phys) , & + real (kind_phys) , & INTENT ( OUT) :: pc, & msnf, & facsnf - real (kind=kind_phys) , & + real (kind_phys) , & INTENT (INOUT ) :: emiss, & lai, & znt LOGICAL, intent(in) :: rdlai2d !--- soil properties - real (kind=kind_phys) , & + real (kind_phys) , & INTENT( OUT) :: RHOCS, & BCLH, & DQM, & @@ -6991,8 +6991,8 @@ SUBROUTINE SOILVEGIN ( debug_print, & integer, intent(out) :: errflg INTEGER :: kstart, kfin, lstart, lfin INTEGER :: k - real (kind=kind_phys) :: area, factor, znt1, lb - real (kind=kind_phys), DIMENSION( 1:NLCAT ) :: ZNTtoday, LAItoday, deltalai + real (kind_phys) :: area, factor, znt1, lb + real (kind_phys), DIMENSION( 1:NLCAT ) :: ZNTtoday, LAItoday, deltalai !*********************************************************************** ! DATA ZS1/0.0,0.05,0.20,0.40,1.6,3.0/ ! o - levels in soil @@ -7203,33 +7203,33 @@ SUBROUTINE RUCLSMINIT( debug_print, landfrac, fice, min_seaice, & #endif IMPLICIT NONE LOGICAL, INTENT(IN ) :: debug_print - real (kind=kind_phys), DIMENSION( ims:ime), INTENT(IN ) :: landfrac, fice - real (kind=kind_phys), INTENT(IN ) :: min_seaice + real (kind_phys), DIMENSION( ims:ime), INTENT(IN ) :: landfrac, fice + real (kind_phys), INTENT(IN ) :: min_seaice INTEGER, INTENT(IN ) :: & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & nzs - real (kind=kind_phys), DIMENSION( ims:ime, 1:nzs, jms:jme ), & + real (kind_phys), DIMENSION( ims:ime, 1:nzs, jms:jme ), & INTENT(IN) :: TSLB, & SMOIS INTEGER, DIMENSION( ims:ime, jms:jme ) , & INTENT(INOUT) :: ISLTYP,IVGTYP - real (kind=kind_phys), DIMENSION( ims:ime, 1:nzs, jms:jme ) , & + real (kind_phys), DIMENSION( ims:ime, 1:nzs, jms:jme ) , & INTENT(OUT) :: SMFR3D, & SH2O - real (kind=kind_phys), DIMENSION( ims:ime, jms:jme ) , & + real (kind_phys), DIMENSION( ims:ime, jms:jme ) , & INTENT(OUT) :: MAVAIL !-- local - real (kind=kind_phys), DIMENSION ( 1:nzs ) :: SOILIQW + real (kind_phys), DIMENSION ( 1:nzs ) :: SOILIQW INTEGER :: I,J,L,itf,jtf - real (kind=kind_phys) :: RIW,XLMELT,TLN,DQM,REF,PSIS,QMIN,BCLH + real (kind_phys) :: RIW,XLMELT,TLN,DQM,REF,PSIS,QMIN,BCLH INTEGER :: errflag @@ -7624,7 +7624,7 @@ SUBROUTINE SOILIN (ISLTYP, DQM, REF, PSIS, QMIN, BCLH ) integer, intent ( in) :: isltyp real, intent ( out) :: dqm,ref,qmin,psis,bclh - real (kind=kind_phys) LQMA(nsoilclas),LREF(nsoilclas),LBCL(nsoilclas), & + real (kind_phys) LQMA(nsoilclas),LREF(nsoilclas),LBCL(nsoilclas), & LPSI(nsoilclas),LQMI(nsoilclas) !-- LQMA Rawls et al.[1982] @@ -7672,20 +7672,20 @@ END SUBROUTINE SOILIN !>\ingroup lsm_ruc_group !> This function calculates the liquid saturation vapor mixing ratio as !! a function of temperature and pressure (from Thompson scheme). - real (kind=kind_phys) FUNCTION RSLF(P,T) + real (kind_phys) FUNCTION RSLF(P,T) IMPLICIT NONE - real (kind=kind_phys), INTENT(IN):: P, T - real (kind=kind_phys):: ESL,X - real (kind=kind_phys), PARAMETER:: C0= .611583699E03 - real (kind=kind_phys), PARAMETER:: C1= .444606896E02 - real (kind=kind_phys), PARAMETER:: C2= .143177157E01 - real (kind=kind_phys), PARAMETER:: C3= .264224321E-1 - real (kind=kind_phys), PARAMETER:: C4= .299291081E-3 - real (kind=kind_phys), PARAMETER:: C5= .203154182E-5 - real (kind=kind_phys), PARAMETER:: C6= .702620698E-8 - real (kind=kind_phys), PARAMETER:: C7= .379534310E-11 - real (kind=kind_phys), PARAMETER:: C8=-.321582393E-13 + real (kind_phys), INTENT(IN):: P, T + real (kind_phys):: ESL,X + real (kind_phys), PARAMETER:: C0= .611583699E03 + real (kind_phys), PARAMETER:: C1= .444606896E02 + real (kind_phys), PARAMETER:: C2= .143177157E01 + real (kind_phys), PARAMETER:: C3= .264224321E-1 + real (kind_phys), PARAMETER:: C4= .299291081E-3 + real (kind_phys), PARAMETER:: C5= .203154182E-5 + real (kind_phys), PARAMETER:: C6= .702620698E-8 + real (kind_phys), PARAMETER:: C7= .379534310E-11 + real (kind_phys), PARAMETER:: C8=-.321582393E-13 X=MAX(-80.,T-273.16) diff --git a/physics/namelist_soilveg_ruc.F90 b/physics/namelist_soilveg_ruc.F90 index 2270d35eb..d71d2ebfd 100644 --- a/physics/namelist_soilveg_ruc.F90 +++ b/physics/namelist_soilveg_ruc.F90 @@ -1,6 +1,10 @@ !>\file namelist_soilveg_ruc.F90 !>\ingroup RUC_lsm + module namelist_soilveg_ruc + + use machine , only : kind_phys + implicit none save @@ -12,27 +16,27 @@ module namelist_soilveg_ruc PARAMETER(MAX_SOILTYP = 30) PARAMETER(MAX_VEGTYP = 30) - REAL SLOPE_DATA(MAX_SLOPETYP) + real(kind_phys) SLOPE_DATA(MAX_SLOPETYP) !> vegetation - REAL ALBTBL(MAX_VEGTYP) - REAL Z0TBL(MAX_VEGTYP) - REAL LEMITBL(MAX_VEGTYP) - REAL PCTBL(MAX_VEGTYP) - REAL SHDTBL(MAX_VEGTYP) + real(kind_phys) ALBTBL(MAX_VEGTYP) + real(kind_phys) Z0TBL(MAX_VEGTYP) + real(kind_phys) LEMITBL(MAX_VEGTYP) + real(kind_phys) PCTBL(MAX_VEGTYP) + real(kind_phys) SHDTBL(MAX_VEGTYP) INTEGER IFORTBL(MAX_VEGTYP) - REAL RSTBL(MAX_VEGTYP) - REAL RGLTBL(MAX_VEGTYP) - REAL HSTBL(MAX_VEGTYP) - REAL SNUPTBL(MAX_VEGTYP) - REAL LAITBL(MAX_VEGTYP) - REAL MAXALB(MAX_VEGTYP) - REAL MFSNO(MAX_VEGTYP) - REAL SNCOVFAC(MAX_VEGTYP) + real(kind_phys) RSTBL(MAX_VEGTYP) + real(kind_phys) RGLTBL(MAX_VEGTYP) + real(kind_phys) HSTBL(MAX_VEGTYP) + real(kind_phys) SNUPTBL(MAX_VEGTYP) + real(kind_phys) LAITBL(MAX_VEGTYP) + real(kind_phys) MAXALB(MAX_VEGTYP) + real(kind_phys) MFSNO(MAX_VEGTYP) + real(kind_phys) SNCOVFAC(MAX_VEGTYP) LOGICAL LPARAM - REAL TOPT_DATA - REAL CMCMAX_DATA - REAL CFACTR_DATA - REAL RSMAX_DATA + real(kind_phys) TOPT_DATA + real(kind_phys) CMCMAX_DATA + real(kind_phys) CFACTR_DATA + real(kind_phys) RSMAX_DATA INTEGER BARE INTEGER GLACIER INTEGER NATURAL @@ -43,21 +47,21 @@ module namelist_soilveg_ruc INTEGER DEFINED_SLOPE INTEGER MOSAIC_LU !> -- soils - REAL BB(MAX_SOILTYP) - REAL DRYSMC(MAX_SOILTYP) - REAL HC(MAX_SOILTYP) - REAL MAXSMC(MAX_SOILTYP) - REAL REFSMC(MAX_SOILTYP) - REAL SATPSI(MAX_SOILTYP) - REAL SATDK(MAX_SOILTYP) - REAL SATDW(MAX_SOILTYP) - REAL WLTSMC(MAX_SOILTYP) - REAL QTZ(MAX_SOILTYP) - REAL REFSMCnoah(MAX_SOILTYP) - REAL WLTSMCnoah(MAX_SOILTYP) - REAL BBnoah(MAX_SOILTYP) - REAL SATDKnoah(MAX_SOILTYP) - REAL SATPSInoah(MAX_SOILTYP) - REAL MAXSMCnoah(MAX_SOILTYP) + real(kind_phys) BB(MAX_SOILTYP) + real(kind_phys) DRYSMC(MAX_SOILTYP) + real(kind_phys) HC(MAX_SOILTYP) + real(kind_phys) MAXSMC(MAX_SOILTYP) + real(kind_phys) REFSMC(MAX_SOILTYP) + real(kind_phys) SATPSI(MAX_SOILTYP) + real(kind_phys) SATDK(MAX_SOILTYP) + real(kind_phys) SATDW(MAX_SOILTYP) + real(kind_phys) WLTSMC(MAX_SOILTYP) + real(kind_phys) QTZ(MAX_SOILTYP) + real(kind_phys) REFSMCnoah(MAX_SOILTYP) + real(kind_phys) WLTSMCnoah(MAX_SOILTYP) + real(kind_phys) BBnoah(MAX_SOILTYP) + real(kind_phys) SATDKnoah(MAX_SOILTYP) + real(kind_phys) SATPSInoah(MAX_SOILTYP) + real(kind_phys) MAXSMCnoah(MAX_SOILTYP) INTEGER MOSAIC_SOIL end module namelist_soilveg_ruc diff --git a/physics/set_soilveg_ruc.F90 b/physics/set_soilveg_ruc.F90 index 79c1be310..f04a49648 100644 --- a/physics/set_soilveg_ruc.F90 +++ b/physics/set_soilveg_ruc.F90 @@ -4,6 +4,7 @@ module set_soilveg_ruc_mod + use machine , only : kind_phys use namelist_soilveg_ruc implicit none @@ -25,7 +26,7 @@ subroutine set_soilveg_ruc(me,isot,ivet,nlunit,errmsg,errflg) integer me integer i - real refsmc1, wltsmc1 + real(kind_phys) refsmc1, wltsmc1 NAMELIST /SOIL_VEG_RUC/ SLOPE_DATA, ALBTBL, Z0TBL, LEMITBL, & & PCTBL, SHDTBL, & From d99ff8b2bbac9ec915d61aeee96a26ae02e4155b Mon Sep 17 00:00:00 2001 From: Lisa Bengtsson Date: Tue, 21 Mar 2023 15:02:08 +0000 Subject: [PATCH 171/380] cleaning --- physics/progsigma_calc.f90 | 1 - 1 file changed, 1 deletion(-) diff --git a/physics/progsigma_calc.f90 b/physics/progsigma_calc.f90 index 49ac40ebc..4bbd305ae 100644 --- a/physics/progsigma_calc.f90 +++ b/physics/progsigma_calc.f90 @@ -117,7 +117,6 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & mcon = (hvap*(qadv(i,k)+tmf(i,k)+qmicro(i,k))*dp(i,k)) buy2 = termD(i)+mcon+mcons(i) ! Do the integral over buoyant layers with positive mcon acc from surface - !if(k > kbcon1(i) .and. k < ktcon(i) .and. buy2 > 0.)then if(dbyo1(i,k)>0 .and. buy2 > 0.)then inbu(i,k)=1. endif From 50537e2b2bcf3502ede6f9ca94b3506d5efbc5bb Mon Sep 17 00:00:00 2001 From: Lisa Bengtsson Date: Tue, 21 Mar 2023 15:57:29 +0000 Subject: [PATCH 172/380] delete untracked content --- physics/cu_unified_driver_post.F90~ | 65 ----------------------------- 1 file changed, 65 deletions(-) delete mode 100644 physics/cu_unified_driver_post.F90~ diff --git a/physics/cu_unified_driver_post.F90~ b/physics/cu_unified_driver_post.F90~ deleted file mode 100644 index 963817beb..000000000 --- a/physics/cu_unified_driver_post.F90~ +++ /dev/null @@ -1,65 +0,0 @@ -!> \file cu_unified_driver_post.F90 -!! Contains code related to unified convective schemes to be used within the GFS physics suite. - -module cu_gf_driver_post - - implicit none - - private - - public :: cu_gf_driver_post_run - - contains - -!>\ingroup cu_gf_group -!> \section arg_table_cu_gf_driver_post_run Argument Table -!! \htmlinclude cu_gf_driver_post_run.html -!! - subroutine cu_gf_driver_post_run (im, t, q, prevst, prevsq, cactiv, cactiv_m, conv_act, conv_act_m, errmsg, errflg) - - use machine, only: kind_phys - - implicit none - - ! Interface variables - integer, intent(in) :: im - real(kind_phys), intent(in) :: t(:,:) - real(kind_phys), intent(in) :: q(:,:) - real(kind_phys), intent(out) :: prevst(:,:) - real(kind_phys), intent(out) :: prevsq(:,:) - integer, intent(in) :: cactiv(:) - integer, intent(in) :: cactiv_m(:) - real(kind_phys), intent(out) :: conv_act(:) - real(kind_phys), intent(out) :: conv_act_m(:) - character(len=*), intent(out) :: errmsg -!$acc declare copyin(t,q,cactiv,cactiv_m) copyout(prevst,prevsq,conv_act,conv_act_m) - integer, intent(out) :: errflg - - ! Local variables - integer :: i - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - -!$acc kernels - prevst(:,:) = t(:,:) - prevsq(:,:) = q(:,:) - - do i = 1, im - if (cactiv(i).gt.0) then - conv_act(i) = conv_act(i)+1.0 - else - conv_act(i)=0.0 - endif - if (cactiv_m(i).gt.0) then - conv_act_m(i) = conv_act_m(i)+1.0 - else - conv_act_m(i)=0.0 - endif - enddo -!$acc end kernels - - end subroutine cu_gf_driver_post_run - -end module cu_gf_driver_post From 2817751da6658ec07b35dc6dba1efa101426b1c5 Mon Sep 17 00:00:00 2001 From: Lisa Bengtsson Date: Tue, 21 Mar 2023 15:57:36 +0000 Subject: [PATCH 173/380] delete untracked content --- physics/cu_unified_driver_pre.F90~ | 84 ------------------------------ 1 file changed, 84 deletions(-) delete mode 100644 physics/cu_unified_driver_pre.F90~ diff --git a/physics/cu_unified_driver_pre.F90~ b/physics/cu_unified_driver_pre.F90~ deleted file mode 100644 index 5742f8bc8..000000000 --- a/physics/cu_unified_driver_pre.F90~ +++ /dev/null @@ -1,84 +0,0 @@ -!> \file cu_unified_driver_pre.F90 -!! Contains code related to the unified convective schemes to be used within the GFS physics suite. - -module cu_gf_driver_pre - - implicit none - - private - - public :: cu_gf_driver_pre_run - - contains - -!>\ingroup cu_gf_group -!> \section arg_table_cu_gf_driver_pre_run Argument Table -!! \htmlinclude cu_gf_driver_pre_run.html -!! - subroutine cu_gf_driver_pre_run (flag_init, flag_restart, kdt, fhour, dtp, t, q, prevst, prevsq, & - forcet, forceq, cactiv, cactiv_m, conv_act, conv_act_m, & - errmsg, errflg) - - use machine, only: kind_phys - - implicit none - - logical, intent(in) :: flag_init - logical, intent(in) :: flag_restart - integer, intent(in) :: kdt - real(kind_phys), intent(in) :: fhour - real(kind_phys), intent(in) :: dtp - real(kind_phys), intent(in) :: t(:,:) - real(kind_phys), intent(in) :: q(:,:) - real(kind_phys), intent(in) :: prevst(:,:) - real(kind_phys), intent(in) :: prevsq(:,:) -!$acc declare copyin(t,q,prevst,prevsq) - real(kind_phys), intent(out) :: forcet(:,:) - real(kind_phys), intent(out) :: forceq(:,:) - integer, intent(out) :: cactiv(:) - integer, intent(out) :: cactiv_m(:) -!$acc declare copyout(forcet,forceq,cactiv,cactiv_m) - real(kind_phys), intent(in) :: conv_act(:) - real(kind_phys), intent(in) :: conv_act_m(:) -!$acc declare copyin(conv_act,conv_act_m) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! local variables - real(kind=kind_phys) :: dtdyn - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - ! For restart runs, can assume that prevst and prevsq - ! are read from the restart files beforehand, same - ! for conv_act. - if(flag_init .and. .not.flag_restart) then -!$acc kernels - forcet(:,:)=0.0 - forceq(:,:)=0.0 -!$acc end kernels - else - dtdyn=3600.0*(fhour)/kdt - if(dtp > dtdyn) then -!$acc kernels - forcet(:,:)=(t(:,:) - prevst(:,:))/dtp - forceq(:,:)=(q(:,:) - prevsq(:,:))/dtp -!$acc end kernels - else -!$acc kernels - forcet(:,:)=(t(:,:) - prevst(:,:))/dtdyn - forceq(:,:)=(q(:,:) - prevsq(:,:))/dtdyn -!$acc end kernels - endif - endif - -!$acc kernels - cactiv(:)=nint(conv_act(:)) - cactiv_m(:)=nint(conv_act_m(:)) -!$acc end kernels - - end subroutine cu_gf_driver_pre_run - -end module cu_gf_driver_pre From 01adfea9672f5cef3edf2e27418d3830ef240ad2 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Tue, 21 Mar 2023 18:24:58 +0000 Subject: [PATCH 174/380] Fixed the problem in sfc_daig.f: it was using "surface_exchange_coefficient_for_heat_at_2m" which is provided only by MYNN surface layer scheme and not the others. Now this variable is comuted internally in sfc_diag.f. --- physics/sfc_diag.f | 21 ++++++++++++--------- physics/sfc_diag.meta | 31 +++++++++++++++---------------- 2 files changed, 27 insertions(+), 25 deletions(-) diff --git a/physics/sfc_diag.f b/physics/sfc_diag.f index f5bd081e0..585bd4b7d 100644 --- a/physics/sfc_diag.f +++ b/physics/sfc_diag.f @@ -22,10 +22,10 @@ end subroutine sfc_diag_finalize !! \section detailed Detailed Algorithm !! @{ subroutine sfc_diag_run (im,xlat_d,xlon_d, & - & lsm,lsm_ruc,grav,cp,eps,epsm1,rocp, & - & wet,shflx,chs2,cqs2,cdq,wind, & + & lsm,lsm_ruc,grav,cp,eps,epsm1,rocp,con_karman,& + & wet,shflx,cdq,wind, & & zf,ps,u1,v1,t1,q1,prslki,evap,fm,fh,fm10,fh2, & - & tskin,qsurf,thsfc_loc,diag_flux,diag_log, & + & ust,tskin,qsurf,thsfc_loc,diag_flux,diag_log, & & f10m,u10m,v10m,t2m,q2m,dpt2m,errmsg,errflg & & ) ! @@ -38,10 +38,11 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & logical, intent(in) :: diag_flux ! Flag for flux method in 2-m diagnostics logical, intent(in) :: diag_log ! Flag for 2-m log diagnostics under stable conditions real(kind=kind_phys), intent(in) :: grav,cp,eps,epsm1,rocp + real(kind=kind_phys), intent(in) :: con_karman real(kind=kind_phys), dimension(:), intent( in) :: & - & zf, ps, u1, v1, t1, q1, tskin, wet, & + & zf, ps, u1, v1, t1, q1, ust, tskin, wet, & & qsurf, prslki, evap, fm, fh, fm10, fh2, & - & shflx, chs2, cqs2, cdq, wind, xlat_d, xlon_d + & shflx, cdq, wind, xlat_d, xlon_d real(kind=kind_phys), dimension(:), intent(out) :: & & f10m, u10m, v10m, t2m, q2m, dpt2m character(len=*), intent(out) :: errmsg @@ -54,7 +55,7 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & real(kind=kind_phys) :: q1c, qv, tem, qv1, th2m, x2m, rho real(kind=kind_phys) :: dT, dQ, qsfcmr, qsfcprox, ff, fac, dz1 real(kind=kind_phys) :: t2_alt, q2_alt - real(kind=kind_phys) :: thcon, cqs, chs + real(kind=kind_phys) :: thcon, cqs, chs, chs2, cqs2 real(kind=kind_phys) :: testptlat, testptlon integer :: k,i ! @@ -104,6 +105,8 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & qsfcmr = qsurf(i)/(1. - qsurf(i)) ! surface mixing ratio chs = cdq(i) * wind(i) cqs = chs + chs2 = ust(i)*con_karman/fh2(i) + cqs2 = chs2 qsfcprox = max(qmin,qv1 + evap(i)/cqs) ! surface mix. ratio computed from the flux if(.not. diag_flux) then @@ -128,10 +131,10 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & else !-- flux method - th2m = tskin(i)*thcon - shflx(i)/chs2(i) + th2m = tskin(i)*thcon - shflx(i)/chs2 t2m(i) = th2m/thcon - x2m = max(qmin,qsfcprox - evap(i)/cqs2(i)) ! mix. ratio + x2m = max(qmin,qsfcprox - evap(i)/cqs2) ! mix. ratio q2m(i) = x2m/(1. + x2m) ! spec. humidity endif ! flux method @@ -206,7 +209,7 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & & 'tskin ',tskin(i),'t2m ',t2m(i),'t1',t1(i),'shflx',shflx(i),& & 'qsurf ',qsurf(i),'qsfcprox ',qsfcprox,'q2m ',q2m(i), & & 'q1 ',q1(i),'evap ',evap(i),'dpt2m ',dpt2m(i), & - & 'chs2 ',chs2(i),'cqs2 ',cqs2(i),'cqs ',cqs,'cdq',cdq(i) + & 'chs2 ',chs2,'cqs2 ',cqs2,'cqs ',cqs,'cdq',cdq(i) endif endif 100 format (";;; ",a,i4,a,2f14.7/(4(a10,'='es11.4))) diff --git a/physics/sfc_diag.meta b/physics/sfc_diag.meta index 91a5c8d41..7618a4a00 100644 --- a/physics/sfc_diag.meta +++ b/physics/sfc_diag.meta @@ -84,6 +84,13 @@ type = real kind = kind_phys intent = in +[con_karman] + standard_name = von_karman_constant + long_name = von karman constant + units = none + dimensions = () + type = real + intent = in [wet] standard_name = normalized_soil_wetness_for_land_surface_model long_name = normalized soil wetness @@ -188,6 +195,14 @@ type = real kind = kind_phys intent = in +[ust] + standard_name = surface_friction_velocity + long_name = boundary layer parameter + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout [tskin] standard_name = surface_skin_temperature long_name = surface skin temperature @@ -233,22 +248,6 @@ type = real kind = kind_phys intent = in -[chs2] - standard_name = surface_exchange_coefficient_for_heat_at_2m - long_name = exchange coefficient for heat at 2 meters - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[cqs2] - standard_name = surface_exchange_coefficient_for_moisture_at_2m - long_name = exchange coefficient for moisture at 2 meters - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in [cdq] standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air long_name = surface exchange coeff heat & moisture From ffccfc8f8aca54c035268e025e29f50e4b2bdeb9 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Tue, 21 Mar 2023 14:30:18 -0400 Subject: [PATCH 175/380] remove test for MYNN SFC when using MYNN EDMF in noahmpdrv.F90; remove Dom and add Dustin in CMakeLists.txt authors --- CMakeLists.txt | 2 +- physics/noahmpdrv.F90 | 7 ------- 2 files changed, 1 insertion(+), 8 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 90f6556e3..950bd048e 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -6,7 +6,7 @@ project(ccpp_physics #------------------------------------------------------------------------------ set(PACKAGE "ccpp-physics") -set(AUTHORS "Grant Firl" "Dom Heinzeller" "Man Zhang" "Mike Kavulich" "Chunxi Zhang") +set(AUTHORS "Grant Firl" "Dustin Swales" "Man Zhang" "Mike Kavulich" ) #------------------------------------------------------------------------------ # Set OpenMP flags for C/C++/Fortran diff --git a/physics/noahmpdrv.F90 b/physics/noahmpdrv.F90 index ac3867c1c..771cfa0f6 100644 --- a/physics/noahmpdrv.F90 +++ b/physics/noahmpdrv.F90 @@ -77,13 +77,6 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, me, isot, ivegsrc, & return end if - if (.not. do_mynnsfclay .and. do_mynnedmf) then - errmsg = 'Problem : do_mynnsfclay = .false.' // & - 'but mynnpbl is .true.. Exiting ...' - errflg = 1 - return - end if - if ( do_mynnsfclay .and. .not. do_mynnedmf) then errmsg = 'Problem : do_mynnsfclay = .true.' // & 'but mynnpbl is .false.. Exiting ...' From faba00461b20c9d1a121a80a44f59f02c59584ff Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Tue, 21 Mar 2023 19:34:52 +0000 Subject: [PATCH 176/380] Continue changes for kind_phys with constants. --- physics/module_sf_ruclsm.F90 | 968 +++++++++++++++++------------------ 1 file changed, 483 insertions(+), 485 deletions(-) diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index dcc4723c3..ea253ad2a 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -27,6 +27,7 @@ MODULE module_sf_ruclsm real (kind_phys), parameter :: r_v = 461.50_kind_dbl_prec real (kind_phys), parameter :: zero = 0._kind_dbl_prec real (kind_phys), parameter :: one = 1._kind_dbl_prec + real (kind_phys), parameter :: tfrz = 273.15_kind_dbl_prec !-- options for snow conductivity: 1 - constant, 2 - Sturm et al.,1997 integer, parameter :: isncond_opt = 1 @@ -190,12 +191,12 @@ SUBROUTINE LSMRUC(xlat,xlon, & LOGICAL, INTENT(IN ) :: myj,frpcpn,init,lsm_cold_start,exticeden INTEGER, INTENT(IN ) :: NLCAT, NSCAT INTEGER, INTENT(IN ) :: ktau, iter, nsl, isice, iswater, & - ims,ime, jms,jme, kms,kme, & + ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ! LOGICAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: flag_iter, flag - real (kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme ) , & + real (kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme ) , & INTENT(IN ) :: QV3D, & QC3D, & p8w, & @@ -203,7 +204,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & T3D, & z3D - real (kind_phys), DIMENSION( ims:ime , jms:jme ), & + real (kind_phys), DIMENSION( ims:ime , jms:jme ), & INTENT(IN ) :: RAINBL, & GLW, & GSWdn, & @@ -258,10 +259,10 @@ SUBROUTINE LSMRUC(xlat,xlon, & real (kind_phys), DIMENSION( ims:ime , 1:nlcat, jms:jme ), INTENT(IN):: LANDUSEF real (kind_phys), DIMENSION( ims:ime , 1:nscat, jms:jme ), INTENT(IN):: SOILCTOP - real (kind_phys), INTENT(IN ) :: CP,G0,LV,STBOLT,RV,RD,PI, & + real (kind_phys), INTENT(IN ) :: CP,G0,LV,STBOLT,RV,RD,PI, & XICE_threshold - real (kind_phys), DIMENSION( ims:ime , 1:nsl, jms:jme ) , & + real (kind_phys), DIMENSION( ims:ime , 1:nsl, jms:jme ) , & INTENT(INOUT) :: SOILMOIS,SH2O,TSO real (kind_phys), DIMENSION( ims:ime, jms:jme ) , & @@ -326,7 +327,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & :: KEEPFR3DFLAG, & SMFR3D - real (kind_phys), DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: & + real (kind_phys),DIMENSION( ims:ime, jms:jme ),INTENT(OUT) :: & RHOSNF, & ! RHO of snowfall PRECIPFR, & ! time-step frozen precip SNOWFALLAC @@ -358,13 +359,13 @@ SUBROUTINE LSMRUC(xlat,xlon, & KWT - real (kind_phys), DIMENSION(1:NSL) :: ZSMAIN, & - ZSHALF, & - DTDZS2 + real (kind_phys), DIMENSION(1:NSL) :: ZSMAIN, & + ZSHALF, & + DTDZS2 - real (kind_phys), DIMENSION(1:2*(nsl-2)) :: DTDZS + real (kind_phys), DIMENSION(1:2*(nsl-2)) :: DTDZS - real (kind_phys), DIMENSION(1:5001) :: TBQ + real (kind_phys), DIMENSION(1:5001) :: TBQ real (kind_phys), DIMENSION( 1:nsl ) :: SOILM1D, & @@ -373,10 +374,10 @@ SUBROUTINE LSMRUC(xlat,xlon, & SOILIQW, & SMFRKEEP - real (kind_phys), DIMENSION( 1:nsl ) :: KEEPFR + real (kind_phys), DIMENSION( 1:nsl ) :: KEEPFR - real (kind_phys), DIMENSION( 1:nlcat ) :: lufrac - real (kind_phys), DIMENSION( 1:nscat ) :: soilfrac + real (kind_phys), DIMENSION( 1:nlcat ) :: lufrac + real (kind_phys), DIMENSION( 1:nscat ) :: soilfrac real (kind_phys) :: RSM, & SNWEPRINT, & @@ -441,22 +442,21 @@ SUBROUTINE LSMRUC(xlat,xlon, & !> - Table TBQ is for resolution of balance equation in vilka() CQ=173.15_kind_dbl_prec-.05_kind_dbl_prec - R273=1._kind_dbl_prec/273.15_kind_dbl_prec + R273=1._kind_dbl_prec/tfrz R61=6.1153_kind_dbl_prec*0.62198_kind_dbl_prec ARP=77455._kind_dbl_prec*41.9_kind_dbl_prec/461.525_kind_dbl_prec BRP=64._kind_dbl_prec*41.9_kind_dbl_prec/461.525_kind_dbl_prec DO K=1,5001 CQ=CQ+.05_kind_dbl_prec - EVS=EXP(17.67_kind_dbl_prec*(CQ-273.15_kind_dbl_prec)/(CQ-29.65_kind_dbl_prec)) - EIS=EXP(22.514_kind_phys-6.15E3_kind_dbl_prec/CQ) - if(CQ.ge.273.15_kind_dbl_prec) then -! tbq is in mb - tbq(k) = R61*evs - else - tbq(k) = R61*eis - endif - + EVS=EXP(17.67_kind_dbl_prec*(CQ-tfrz)/(CQ-29.65_kind_dbl_prec)) + EIS=EXP(22.514_kind_dbl_prec-6.15E3_kind_dbl_prec/CQ) + if(CQ.ge.tfrz) then + ! tbq is in mb + tbq(k) = R61*evs + else + tbq(k) = R61*eis + endif END DO !> - Initialize soil/vegetation parameters @@ -472,7 +472,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & !> - Initializing inside-snow temp if it is not defined IF((soilt1(i,j) .LT. 170._kind_phys) .or. (soilt1(i,j) .GT.400._kind_phys)) THEN IF(snowc(i,j).gt.zero) THEN - soilt1(i,j)=min(273.15_kind_phys,0.5_kind_phys*(soilt(i,j)+tso(i,1,j)) ) + soilt1(i,j)=min(tfrz,0.5_kind_phys*(soilt(i,j)+tso(i,1,j)) ) IF (debug_print ) THEN print *, & 'Temperature inside snow is initialized in RUCLSM ', soilt1(i,j),i,xlat,xlon @@ -481,7 +481,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & soilt1(i,j) = tso(i,1,j) ENDIF ENDIF - tsnav(i,j) =min(zero,0.5_kind_phys*(soilt(i,j)+tso(i,1,j))-273.15_kind_phys) + tsnav(i,j) =min(zero,0.5_kind_phys*(soilt(i,j)+tso(i,1,j))-tfrz) !- 10feb22 - limit snow albedo at high elevations !- based on Roesch et al., Climate Dynamics (2001),17:933-946 if(hgt(i,j) > 2500._kind_phys) then @@ -582,7 +582,6 @@ SUBROUTINE LSMRUC(xlat,xlon, & endif ENDIF - ILAND = IVGTYP(i,j) ISOIL = ISLTYP(I,J) TABS = T3D(i,kms,j) @@ -605,11 +604,11 @@ SUBROUTINE LSMRUC(xlat,xlon, & !> - Apply the same frozen precipitation fraction to convective precip !tgs - 31 mar17 - add temperature check in case Thompson MP produces ! frozen precip at T > 273. - if(frzfrac(i,j) > zero .and. tabs < 273._kind_phys) then + if(frzfrac(i,j) > zero .and. tabs < tfrz) then prcpculiq = max(zero,raincv(i,j)*(one-frzfrac(i,j))) prcpcufr = max(zero,raincv(i,j)*frzfrac(i,j)) else - if(tabs < 273._kind_phys) then + if(tabs < tfrz) then prcpcufr = max(zero,raincv(i,j)) prcpculiq = zero else @@ -631,7 +630,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & endif ELSE ! .not. FRPCPN - if (tabs.le.273.15_kind_phys) then + if (tabs.le.tfrz) then PRCPMS = zero NEWSNMS = RAINBL(i,j)/DT*1.e-3_kind_phys !> - If here no info about constituents of frozen precipitation, @@ -765,7 +764,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & ENDIF CN=CFACTR_DATA ! exponent - SAT = 5.e-4 ! units [m] + SAT = 5.e-4_kind_phys ! units [m] !-- definition of number of soil levels in the rooting zone IF(iforest.gt.2) THEN @@ -774,10 +773,10 @@ SUBROUTINE LSMRUC(xlat,xlon, & ! for open areas factor is 2, and for forests - factor is 0.85 ! This will make limit on snow melting smaller and let snow stay ! longer in the forests. - meltfactor = 2.0 + meltfactor = 2.0_kind_phys do k=2,nzs - if(zsmain(k).ge.0.4) then + if(zsmain(k).ge.0.4_kind_phys) then NROOT=K goto 111 endif @@ -789,10 +788,10 @@ SUBROUTINE LSMRUC(xlat,xlon, & ! 28 March 11 - Previously used value of metfactor= 1.5 needs to be further reduced ! to compensate for low snow albedos in the forested areas. ! Melting rate in forests will reduce. - meltfactor = 0.85 + meltfactor = 0.85_kind_phys do k=2,nzs - if(zsmain(k).ge.1.1) then + if(zsmain(k).ge.1.1_kind_phys) then NROOT=K goto 111 endif @@ -808,29 +807,29 @@ SUBROUTINE LSMRUC(xlat,xlon, & print *,'NROOT, meltfactor, iforest, ivgtyp, i,j ', nroot,meltfactor,iforest,ivgtyp(I,J),I,J ENDIF - IF((XLAND(I,J)-1.5).GE.0.)THEN + IF((XLAND(I,J)-1.5).GE.0._kind_phys)THEN !-- Water - SMAVAIL(I,J)=1.0 - SMMAX(I,J)=1.0 - SNOW(I,J)=0.0 - SNOWH(I,J)=0.0 - SNOWC(I,J)=0.0 - LMAVAIL(I,J)=1.0 + SMAVAIL(I,J)= one + SMMAX(I,J)= one + SNOW(I,J) = zero + SNOWH(I,J)= zero + SNOWC(I,J)= zero + LMAVAIL(I,J)= one ! accumulated water equivalent of frozen precipitation over water [mm] acsnow(i,j)=acsnow(i,j)+precipfr(i,j) ILAND=iswater ISOIL=14 - patmb=P8w(i,1,j)*1.e-2 + patmb=P8w(i,1,j)*1.e-2_kind_phys qvg (i,j) = QSN(SOILT(i,j),TBQ)/PATMB qsfc(i,j) = qvg(i,j)/(1.+qvg(i,j)) - CHKLOWQ(I,J)=1. + CHKLOWQ(I,J)= one Q2SAT=QSN(TABS,TBQ)/PATMB DO K=1,NZS - SOILMOIS(I,K,J)=1.0 - SH2O (I,K,J)=1.0 + SOILMOIS(I,K,J)=one + SH2O (I,K,J)=one TSO(I,K,J)= SOILT(I,J) ENDDO @@ -843,12 +842,12 @@ SUBROUTINE LSMRUC(xlat,xlon, & ! LAND POINT OR SEA ICE if(xice(i,j).ge.xice_threshold) then - SEAICE(i,j)=1. + SEAICE(i,j)=one else - SEAICE(i,j)=0. + SEAICE(i,j)=zero endif - IF(SEAICE(I,J).GT.0.5)THEN + IF(SEAICE(I,J).GT.0.5_kind_phys)THEN !-- Sea-ice case IF (debug_print ) THEN PRINT*,' sea-ice at water point, I=',I, & @@ -860,25 +859,25 @@ SUBROUTINE LSMRUC(xlat,xlon, & else ISOIL = 16 ! STATSGO endif - ZNT(I,J) = 0.011 + ZNT(I,J) = 0.011_kind_phys ! in FV3 albedo and emiss are defined for ice emissl(i,j) = emisbck(i,j) ! no snow impact, old 0.98 used in WRF - dqm = 1. - ref = 1. - qmin = 0. - wilt = 0. + dqm = one + ref = one + qmin = zero + wilt = zero - patmb=P8w(i,1,j)*1.e-2 + patmb=P8w(i,1,j)*1.e-2_kind_phys qvg (i,j) = QSN(SOILT(i,j),TBQ)/PATMB qsg (i,j) = qvg(i,j) qsfc(i,j) = qvg(i,j)/(1.+qvg(i,j)) DO K=1,NZS - soilmois(i,k,j) = 1. - smfr3d(i,k,j) = 1. - sh2o(i,k,j) = 0. - keepfr3dflag(i,k,j) = 0. - tso(i,k,j) = min(271.4,tso(i,k,j)) + soilmois(i,k,j) = one + smfr3d(i,k,j) = one + sh2o(i,k,j) = zero + keepfr3dflag(i,k,j) = zero + tso(i,k,j) = min(271.4_kind_phys,tso(i,k,j)) ENDDO ENDIF @@ -887,10 +886,10 @@ SUBROUTINE LSMRUC(xlat,xlon, & DO k=1,nzs ! soilm1d - soil moisture content minus residual [m**3/m**3] - soilm1d (k) = min(max(0.,soilmois(i,k,j)-qmin),dqm) + soilm1d (k) = min(max(zero,soilmois(i,k,j)-qmin),dqm) tso1d (k) = tso(i,k,j) - soiliqw (k) = min(max(0.,sh2o(i,k,j)-qmin),soilm1d(k)) - soilice (k) =(soilm1d (k) - soiliqw (k))/0.9 + soiliqw (k) = min(max(zero,sh2o(i,k,j)-qmin),soilm1d(k)) + soilice (k) =(soilm1d (k) - soiliqw (k))/0.9_kind_phys ENDDO do k=1,nzs @@ -898,7 +897,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & keepfr (k) = keepfr3dflag(i,k,j) enddo - LMAVAIL(I,J)=max(0.00001,min(1.,soilm1d(1)/(ref-qmin))) + LMAVAIL(I,J)=max(0.00001_kind_phys,min(one,soilm1d(1)/(ref-qmin))) IF (debug_print ) THEN if (abs(xlat-testptlat).lt.0.2 .and. & @@ -971,10 +970,10 @@ SUBROUTINE LSMRUC(xlat,xlon, & !tgs - turn off "irrigation" while there is no fractional landuse and LAI !climatology. if(1==2) then - IF (lufrac(crop) > 0 .and. lai(i,j) > 1.1) THEN + IF (lufrac(crop) > zero .and. lai(i,j) > 1.1_kind_phys) THEN ! cropland do k=1,nroot - cropsm=1.1*wilt - qmin + cropsm=1.1_kind_phys*wilt - qmin if(soilm1d(k) < cropsm*lufrac(crop)) then IF (debug_print ) THEN print * ,'Soil moisture is below wilting in cropland category at time step',ktau & @@ -991,14 +990,14 @@ SUBROUTINE LSMRUC(xlat,xlon, & ELSEIF (ivgtyp(i,j) == natural .and. lai(i,j) > 0.7) THEN ! grassland: assume that 40% of grassland is irrigated cropland do k=1,nroot - cropsm=1.2*wilt - qmin + cropsm=1.2_kind_phys*wilt - qmin if(soilm1d(k) < cropsm*lufrac(natural)*0.4) then IF (debug_print ) THEN print * ,'Soil moisture is below wilting in mixed grassland/cropland category at time step',ktau & ,'i,j,lufrac(natural),k,soilm1d(k),wilt', & i,j,lufrac(natural),k,soilm1d(k),wilt ENDIF - soilm1d(k) = cropsm * lufrac(natural)*0.4 + soilm1d(k) = cropsm * lufrac(natural)*0.4_kind_phys IF (debug_print ) THEN print * ,'Added soil water to grassland category, i,j,k,soilm1d(k)',i,j,k,soilm1d(k) ENDIF @@ -1011,8 +1010,8 @@ SUBROUTINE LSMRUC(xlat,xlon, & !--- available and maximum soil moisture content in the soil !--- domain - smavail(i,j) = 0. - smmax (i,j) = 0. + smavail(i,j) = zero + smmax (i,j) = zero !do k=1,nzs-1 !-- root-zone soil moisture @@ -1033,10 +1032,10 @@ SUBROUTINE LSMRUC(xlat,xlon, & !--- Convert the water unit into mm !-- three lines below are commented because accumulation ! happens in sfc_drv_ruc - ACRUNOFF(I,J) = (RUNOFF1(I,J)+RUNOFF2(I,J))*DT*1000.0 - SMAVAIL (I,J) = SMAVAIL(I,J) * 1000. ! mm - SMMAX (I,J) = SMMAX(I,J) * 1000. - smtotold (I,J) = smtotold(I,J) * 1000. ! mm + ACRUNOFF(I,J) = (RUNOFF1(I,J)+RUNOFF2(I,J))*DT*rhowater + SMAVAIL (I,J) = SMAVAIL(I,J) * rhowater ! mm + SMMAX (I,J) = SMMAX(I,J) * rhowater + smtotold (I,J) = smtotold(I,J) * rhowater ! mm do k=1,nzs @@ -1058,24 +1057,24 @@ SUBROUTINE LSMRUC(xlat,xlon, & Z0 (I,J) = ZNT (I,J) SFCEXC (I,J) = TKMS - patmb=P8w(i,1,j)*1.e-2 + patmb=P8w(i,1,j)*1.e-2_kind_phys Q2SAT=QSN(TABS,TBQ)/PATMB - QSFC(I,J) = QVG(I,J)/(1.+QVG(I,J)) + QSFC(I,J) = QVG(I,J)/(one+QVG(I,J)) ! for MYJ surface and PBL scheme ! if (myj) then ! MYJSFC expects QSFC as actual specific humidity at the surface - IF((QVATM.GE.Q2SAT*0.95).AND.QVATM.LT.qvg(I,J))THEN - CHKLOWQ(I,J)=0. + IF((QVATM.GE.Q2SAT*0.95_kind_phys).AND.QVATM.LT.qvg(I,J))THEN + CHKLOWQ(I,J)=zero ELSE - CHKLOWQ(I,J)=1. + CHKLOWQ(I,J)=one ENDIF - if(snow(i,j)==0.) EMISSL(i,j) = EMISBCK(i,j) + if(snow(i,j)==zero) EMISSL(i,j) = EMISBCK(i,j) EMISS (I,J) = EMISSL(I,J) ! SNOW is in [mm], SNWE is in [m]; CANWAT is in mm, CANWATR is in m - SNOW (i,j) = SNWE*1000. + SNOW (i,j) = SNWE*1000._kind_phys SNOWH (I,J) = SNHEI - CANWAT (I,J) = CANWATR*1000. + CANWAT (I,J) = CANWATR*1000._kind_phys if (debug_print) then if (abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2)then @@ -1091,7 +1090,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & endif ENDIF SFCEVP (I,J) = SFCEVP (I,J) + QFX (I,J) * DT - GRDFLX (I,J) = -1. * sflx(I,J) + GRDFLX (I,J) = -one * sflx(I,J) !tgs - SMF.NE.0. when there is phase change in the top soil layer ! The heat of soil water freezing/thawing is not computed explicitly @@ -1117,16 +1116,16 @@ SUBROUTINE LSMRUC(xlat,xlon, & if (abs(xlat-testptlat).lt.0.2 .and. & abs(xlon-testptlon).lt.0.2)then !-- compute budget for a test point - ac=0. - as=0. - wb=0. + ac=zero + as=zero + wb=zero - ac=canwat(i,j)-canwatold(i,j)*1.e3 ! canopy water change + ac=canwat(i,j)-canwatold(i,j)*rhowater ! canopy water change as=snwe-snowold(i,j) ! SWE change wb = smavail(i,j)-smtotold(i,j) - waterbudget(i,j)=rainbl(i,j)+smelt(i,j)*dt*1.e3_kind_phys & ! source + waterbudget(i,j)=rainbl(i,j)+smelt(i,j)*dt*rhowater & ! source -qfx(i,j)*dt & - -runoff1(i,j)*dt*1.e3_kind_phys-runoff2(i,j)*dt*1.e3_kind_phys & + -runoff1(i,j)*dt*rhowater-runoff2(i,j)*dt*rhowater & -ac-as ! - (smavail(i,j)-smtotold(i,j)) print *,'soilm1d ',i,soilm1d @@ -1139,9 +1138,9 @@ SUBROUTINE LSMRUC(xlat,xlon, & !-- print *,'Smf=',smf(i,j),i,j print *,'SNOW,SNOWold',i,j,snwe,snowold(i,j) - print *,'SNOW-SNOWold',i,j,max(0._kind_phys,snwe-snowold(i,j)) + print *,'SNOW-SNOWold',i,j,max(zero,snwe-snowold(i,j)) print *,'CANWATold, canwat ',i,j,canwatold(i,j),canwat(i,j) - print *,'canwat(i,j)-canwatold(i,j)',max(0._kind_phys,canwat(i,j)-canwatold(i,j)) + print *,'canwat(i,j)-canwatold(i,j)',max(zero,canwat(i,j)-canwatold(i,j)) endif endif @@ -1215,12 +1214,12 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia real (kind_phys), INTENT(IN ) :: C1SN,C2SN,RHONEWSN_ex LOGICAL, INTENT(IN ) :: myj, debug_print, exticeden !--- 3-D Atmospheric variables - real (kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: PATM, & TABS, & QVATM, & QCATM - real (kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: GLW, & GSW, & GSWdn, & @@ -1237,7 +1236,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia INTEGER, INTENT(IN ) :: IVGTYP, ISLTYP !--- 2-D variables - real (kind_phys) , & + real (kind_phys) , & INTENT(INOUT) :: EMISS, & EMISBCK, & MAVAIL, & @@ -1247,7 +1246,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia CST !--- soil properties - real (kind_phys) :: & + real (kind_phys) :: & RHOCS, & BCLH, & DQM, & @@ -1259,7 +1258,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia SAT, & WILT - real (kind_phys), INTENT(IN ) :: CN, & + real (kind_phys), INTENT(IN ) :: CN, & CW, & CP, & ROVCP, & @@ -1270,34 +1269,34 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia KICE, & KWT - real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & ZSHALF, & DTDZS2 - real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - real (kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ + real (kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ !--- input/output variables !-------- 3-d soil moisture and temperature - real (kind_phys), DIMENSION( 1:nzs ) , & + real (kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: TS1D, & SOILM1D, & SMFRKEEP - real (kind_phys), DIMENSION( 1:nzs ) , & + real (kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: KEEPFR - real (kind_phys), DIMENSION(1:NZS), INTENT(INOUT) :: SOILICE, & - SOILIQW + real (kind_phys), DIMENSION(1:NZS),INTENT(INOUT) :: SOILICE, & + SOILIQW INTEGER, INTENT(INOUT) :: ILAND,ISOIL INTEGER :: ILANDs !-------- 2-d variables - real (kind_phys) , & + real (kind_phys) , & INTENT(INOUT) :: DEW, & EDIR1, & EC1, & @@ -1337,7 +1336,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia TSNAV, & ZNT - real (kind_phys), DIMENSION(1:NZS) :: & + real (kind_phys), DIMENSION(1:NZS) :: & tice, & rhosice, & capice, & @@ -1374,14 +1373,14 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia - real (kind_phys), INTENT(INOUT) :: RSM, & + real (kind_phys), INTENT(INOUT) :: RSM, & SNWEPRINT, & SNHEIPRINT !--- Local variables INTEGER :: K,ILNB - real (kind_phys) :: BSN, XSN , & + real (kind_phys) :: BSN, XSN , & RAINF, SNTH, NEWSN, PRCPMS, NEWSNMS , & T3, UPFLUX, XINET, snowfrac2, m real (kind_phys) :: snhei_crit, snhei_crit_newsn, keep_snow_albedo, SNOWFRACnewsn @@ -1410,23 +1409,23 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! with vegetation dependent parameters from Noah MP (personal ! communication with Mike Barlage) !-- SNHEI_CRIT is a threshold for fractional snow in isncovr_opt=1 - snhei_crit=0.01601_kind_phys*1.e3_kind_phys/rhosn - snhei_crit_newsn=0.0005*1.e3_kind_phys/rhosn + snhei_crit=0.01601_kind_phys*rhowater/rhosn + snhei_crit_newsn=0.0005_kind_phys*rhowater/rhosn !-- zntsn = z0tbl(isice) - snow_mosaic=0._kind_phys - snfr = 1._kind_phys - NEWSN=0._kind_phys - newsnowratio = 0._kind_phys - snowfracnewsn=0._kind_phys - snowfrac2=0._kind_phys + snow_mosaic = zero + snfr = one + NEWSN= zero + newsnowratio = zero + snowfracnewsn= zero + snowfrac2= zero rhonewsn = 100._kind_phys - if(snhei == 0._kind_phys) snowfrac=0._kind_phys - smelt = 0._kind_phys - RAINF = 0._kind_phys - RSM=0._kind_phys - DD1=0._kind_phys - INFILTR=0._kind_phys + if(snhei == zero) snowfrac=zero + smelt = zero + RAINF = zero + RSM = zero + DD1 = zero + INFILTR = zero ! Jul 2016 - Avissar and Pielke (1989) ! This formulation depending on LAI defines relative contribution of the vegetation to ! the total heat fluxes between surface and atmosphere. @@ -1435,21 +1434,21 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! VGFR=0.01*VEGFRA ! % --> fraction ! VEGFRAC=2.*lai*vgfr/(1.+2.*lai*vgfr) VEGFRAC=0.01_kind_phys*VEGFRA - drip = 0._kind_phys - dripsn = 0._kind_phys - dripliq = 0._kind_phys - smf = 0._kind_phys - interw=0._kind_phys - intersn=0._kind_phys - infwater=0._kind_phys + drip = zero + dripsn = zero + dripliq = zero + smf = zero + interw = zero + intersn = zero + infwater = zero !---initialize local arrays for sea ice do k=1,nzs - tice(k) = 0._kind_phys - rhosice(k) = 0._kind_phys - cice = 0._kind_phys - capice(k) = 0._kind_phys - thdifice(k) = 0._kind_phys + tice(k) = zero + rhosice(k) = zero + cice = zero + capice(k) = zero + thdifice(k) = zero enddo GSWnew=GSW @@ -1463,20 +1462,20 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia !--- N.N Zubov "Arctic Ice" !--- no salinity dependence because we consider the ice pack !--- to be old and to have low salinity (0.0002) - if(SEAICE.ge.0.5) then + if(SEAICE.ge.0.5_kind_phys) then do k=1,nzs - tice(k) = ts1d(k) - 273.15 - rhosice(k) = 917.6/(1-0.000165*tice(k)) - cice = 2115.85 +7.7948*tice(k) + tice(k) = ts1d(k) - tfrz + rhosice(k) = 917.6_kind_phys/(one-0.000165_kind_phys*tice(k)) + cice = 2115.85_kind_phys +7.7948_kind_phys*tice(k) capice(k) = cice*rhosice(k) - thdifice(k) = 2.260872/capice(k) + thdifice(k) = 2.260872_kind_phys/capice(k) enddo !-- SEA ICE ALB dependence on ice temperature. When ice temperature is !-- below critical value of -10C - no change to albedo. !-- If temperature is higher that -10C then albedo is decreasing. !-- The minimum albedo at t=0C for ice is 0.1 less. - ALBice = MIN(ALB_SNOW_FREE,MAX(ALB_SNOW_FREE - 0.05, & - ALB_SNOW_FREE - 0.1*(tice(1)+10.)/10. )) + ALBice = MIN(ALB_SNOW_FREE,MAX(ALB_SNOW_FREE - 0.05_kind_phys, & + ALB_SNOW_FREE - 0.1_kind_phys*(tice(1)+10._kind_phys)/10._kind_phys )) endif IF (debug_print ) THEN @@ -1485,29 +1484,29 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia GSW,GSWnew,GLW,SOILT,EMISS,ALB,ALBice,SNWE ENDIF - if(snhei.gt.0.0081*1.e3/rhosn) then + if(snhei.gt.0.0081_kind_phys*rhowater/rhosn) then !*** Update snow density for current temperature (Koren et al. 1999) - BSN=delt/3600.*c1sn*exp(0.08*min(0.,tsnav)-c2sn*rhosn*1.e-3) - if(bsn*snwe*100..lt.1.e-4) goto 777 - XSN=rhosn*(exp(bsn*snwe*100.)-1.)/(bsn*snwe*100.) - rhosn=MIN(MAX(58.8,XSN),500.) + BSN=delt/3600._kind_phys*c1sn*exp(0.08_kind_phys*min(zero,tsnav)-c2sn*rhosn*1.e-3_kind_phys) + if(bsn*snwe*100._kind_phys.lt.1.e-4_kind_phys) goto 777 + XSN=rhosn*(exp(bsn*snwe*100._kind_phys)-one)/(bsn*snwe*100._kind_phys) + rhosn=MIN(MAX(58.8_kind_phys,XSN),500._kind_phys) 777 continue endif !-- snow_mosaic from the previous time step - if(snowfrac < 0.75) snow_mosaic = 1. + if(snowfrac < 0.75_kind_phys) snow_mosaic = one newsn=newsnms*delt !---- ACSNOW - run-total snowfall water [mm] - acsnow=acsnow+newsn*1.e3 + acsnow=acsnow+newsn*rhowater - IF(NEWSN.GT.0.) THEN + IF(NEWSN.GT.zero) THEN IF (debug_print ) THEN print *, 'THERE IS NEW SNOW, newsn', newsn ENDIF - newsnowratio = min(1.,newsn/(snwe+newsn)) + newsnowratio = min(one,newsn/(snwe+newsn)) !if(isncovr_opt == 2) then !-- update snow fraction for fresh snowfall (Swenson&Lawrence,JGR,2012) @@ -1522,14 +1521,14 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia if (exticeden) then rhonewsn = rhonewsn_ex else - rhonewsn=min(125.,1000.0/max(8.,(17.*tanh((276.65-Tabs)*0.15)))) - rhonewgr=min(500.,rhowater/max(2.,(3.5*tanh((274.15-Tabs)*0.3333)))) + rhonewsn=min(125._kind_phys,rhowater/max(8._kind_phys,(17._kind_phys*tanh((276.65_kind_phys-Tabs)*0.15_kind_phys)))) + rhonewgr=min(500._kind_phys,rhowater/max(2._kind_phys,(3.5_kind_phys*tanh((274.15_kind_phys-Tabs)*0.3333_kind_phys)))) rhonewice=rhonewsn !--- compute density of "snowfall" from weighted contribution ! of snow, graupel and ice fractions - rhosnfall = min(500.,max(58.8,(rhonewsn*snowrat + & + rhosnfall = min(500._kind_phys,max(58.8_kind_phys,(rhonewsn*snowrat + & rhonewgr*grauprat + rhonewice*icerat + rhonewgr*curat))) if (debug_print) then @@ -1548,10 +1547,10 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia !*** without snow melt ) xsn=(rhosn*snwe+rhonewsn*newsn)/ & (snwe+newsn) - rhosn=MIN(MAX(58.8,XSN),500.) + rhosn=MIN(MAX(58.8_kind_phys,XSN),500._kind_phys) ENDIF ! end NEWSN > 0. - IF(PRCPMS.NE.0.) THEN + IF(PRCPMS > zero) THEN ! PRCPMS is liquid precipitation rate ! RAINF is a flag used for calculation of rain water @@ -1559,18 +1558,18 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! is set equal to air temperature at the first atmospheric ! level. - RAINF=1. + RAINF=one ENDIF - drip = 0. - intwratio=0. - if(vegfrac > 0.01) then + drip = zero + intwratio= zero + if(vegfrac > 0.01_kind_phys) then ! compute intercepted precipitation - Eq. 1 Lawrence et al., ! J. of Hydrometeorology, 2006, CLM. - interw=0.25*DELT*PRCPMS*(1.-exp(-0.5*lai))*vegfrac - intersn=0.25*NEWSN*(1.-exp(-0.5*lai))*vegfrac + interw=0.25_kind_phys*DELT*PRCPMS*(one-exp(-0.5_kind_phys*lai))*vegfrac + intersn=0.25_kind_phys*NEWSN*(one-exp(-0.5_kind_phys*lai))*vegfrac infwater=PRCPMS - interw/delt - if((interw+intersn) > 0.) then + if((interw+intersn) > zero) then intwratio=interw/(interw+intersn) endif @@ -1582,26 +1581,26 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia DRIP=DD1-SAT ENDIF else - CST=0. - DRIP=0. - interw=0. - intersn=0. + CST=zero + DRIP=zero + interw=zero + intersn=zero infwater=PRCPMS endif ! vegfrac > 0.01 - IF(NEWSN.GT.0.) THEN + IF(NEWSN.GT.zero) THEN !Update snow on the ground - snwe=max(0.,snwe+newsn-intersn) + snwe=max(zero,snwe+newsn-intersn) ! Add drip to snow on the ground - if(drip > 0.) then - if (snow_mosaic==1.) then + if(drip > zero) then + if (snow_mosaic==one) then dripliq=drip*intwratio dripsn = drip - dripliq snwe=snwe+dripsn infwater=infwater+dripliq - dripliq=0. - dripsn = 0. + dripliq=zero + dripsn = zero else snwe=snwe+drip endif @@ -1610,7 +1609,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia NEWSN=NEWSN*rhowater/rhonewsn ENDIF - IF(SNHEI.GT.0.0) THEN + IF(SNHEI.GT.zero) THEN !-- SNOW on the ground !--- Land-use category should be changed to snow/ice for grid points with snow>0 ILAND=ISICE @@ -1626,48 +1625,48 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! endif !-- update snow cover with accounting for fresh snow - m = 1.0_kind_phys ! m=1.6 in Niu&Yang, m=1 in CLM + m = one ! m=1.6 in Niu&Yang, m=1 in CLM if(isncovr_opt == 1) then - snowfrac=min(1._kind_phys,snhei/(2.*snhei_crit)) + snowfrac=min(one,snhei/(2._kind_phys*snhei_crit)) elseif(isncovr_opt == 2) then - snowfrac=min(1.,snhei/(2._kind_phys*snhei_crit)) + snowfrac=min(one,snhei/(2._kind_phys*snhei_crit)) if(ivgtyp == glacier .or. ivgtyp == bare) then !-- sparsely vegetated or land ice - snowfrac2 = tanh( snhei/(2.5 * 0.2 *(rhosn/rhonewsn)**m)) + snowfrac2 = tanh( snhei/(2.5_kind_phys * 0.2_kind_phys *(rhosn/rhonewsn)**m)) else !-- Niu&Yang: znt=0.01 m for 1 degree (100km) resolution tests ! on 3-km scale use actual roughness, but not higher than 0.2 m. ! The factor is 20 for forests (~100/dx = 33.) - snowfrac2 = tanh( snhei/(2.5 *min(0.2,znt) *(rhosn/rhonewsn)**m)) + snowfrac2 = tanh( snhei/(2.5_kind_phys *min(0.2_kind_phys,znt) *(rhosn/rhonewsn)**m)) endif !-- snow fraction is average between method 1 and 2 - snowfrac = 0.5*(snowfrac+snowfrac2) + snowfrac = 0.5_kind_phys*(snowfrac+snowfrac2) else !-- isncovr_opt=3 !m = msnf ! vegetation dependent facsnf/msnf from Noah MP !-- for RRFS a factor 10. was added to 'facsnf' to get reasonal values of ! snow cover fractions on the 3-km scale. ! This factor is scale dependent. - snowfrac = tanh( snhei/(10. * facsnf *(rhosn/rhonewsn)**m)) + snowfrac = tanh( snhei/(10._kind_phys * facsnf *(rhosn/rhonewsn)**m)) endif - if(newsn > 0. ) then - SNOWFRACnewsn=MIN(1.,SNHEI/SNHEI_CRIT_newsn) + if(newsn > zero ) then + SNOWFRACnewsn=MIN(one,SNHEI/SNHEI_CRIT_newsn) endif !-- due to steep slopes and blown snow, limit snow fraction in the !-- mountains to 0.85 (based on Swiss weather model over the Alps) - if(hgt > 2500. .and. ivgtyp == glacier) snowfrac=min(0.85,snowfrac) + if(hgt > 2500._kind_phys .and. ivgtyp == glacier) snowfrac=min(0.85_kind_phys,snowfrac) !24nov15 - SNOWFRAC for urban category < 0.75 - if(ivgtyp == urban) snowfrac=min(0.75,snowfrac) + if(ivgtyp == urban) snowfrac=min(0.75_kind_phys,snowfrac) - if(snowfrac < 0.75) snow_mosaic = 1. + if(snowfrac < 0.75_kind_phys) snow_mosaic = one - KEEP_SNOW_ALBEDO = 0. - IF (NEWSN > 0. .and. snowfracnewsn > 0.99 .and. rhosnfall < 450.) THEN + KEEP_SNOW_ALBEDO = zero + IF (NEWSN > zero .and. snowfracnewsn > 0.99_kind_phys .and. rhosnfall < 450._kind_phys) THEN ! new snow - KEEP_SNOW_ALBEDO = 1. + KEEP_SNOW_ALBEDO = one !snow_mosaic=0. ! ??? ENDIF @@ -1678,33 +1677,33 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia !-- Set znt for snow from VEGPARM table (snow/ice landuse), except for !-- land-use types with higher roughness (forests, urban). - IF(newsn.eq.0. .and. znt.le.0.2 .and. IVGTYP.ne.isice) then - if( snhei .le. 2.*ZNT)then + IF(newsn.eq.zero .and. znt.le.0.2_kind_phys .and. IVGTYP.ne.isice) then + if( snhei .le. 2._kind_phys*ZNT)then ! shallow snow - znt=0.55*znt+0.45*z0tbl(iland) - elseif( snhei .gt. 2.*ZNT .and. snhei .le. 4.*ZNT)then - znt=0.2*znt+0.8*z0tbl(iland) - elseif(snhei > 4.*ZNT) then + znt=0.55_kind_phys*znt+0.45_kind_phys*z0tbl(iland) + elseif( snhei .gt. 2._kind_phys*ZNT .and. snhei .le. 4._kind_phys*ZNT)then + znt=0.2_kind_phys*znt+0.8_kind_phys*z0tbl(iland) + elseif(snhei > 4._kind_phys*ZNT) then ! deep snow znt=z0tbl(iland) endif ENDIF - IF(SEAICE .LT. 0.5) THEN + IF(SEAICE .LT. 0.5_kind_phys) THEN !----- SNOW on soil !-- ALB dependence on snow depth ! ALB_SNOW across Canada's forested areas is very low - 0.27-0.35, this ! causes significant warm biases. Limiting ALB in these areas to be higher than 0.4 ! hwlps with these biases.. - if( snow_mosaic == 1.) then + if( snow_mosaic == one) then ALBsn=alb_snow - if(newsn > 0. .and. KEEP_SNOW_ALBEDO > 0.9 .and. albsn < 0.4) then + if(newsn > zero .and. KEEP_SNOW_ALBEDO > 0.9_kind_phys .and. albsn < 0.4_kind_phys) then !-- Albedo correction with fresh snow and deep snow pack !-- will reduce warm bias in western Canada !-- and US West coast, where max snow albedo is low (0.3-0.5). !print *,'ALB increase to 0.7',alb_snow,snhei,snhei_crit,albsn,i,j - !ALBsn = 0.7 + !ALBsn = 0.7_kind_phys endif Emiss= emissn @@ -1712,12 +1711,12 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ALBsn = MAX(keep_snow_albedo*alb_snow, & MIN((alb_snow_free + & (alb_snow - alb_snow_free) * snowfrac), alb_snow)) - if(newsn > 0. .and. KEEP_SNOW_ALBEDO > 0.9 .and. albsn < 0.4) then + if(newsn > zero .and. KEEP_SNOW_ALBEDO > 0.9_kind_phys .and. albsn < 0.4_kind_phys) then !-- Albedo correction with fresh snow and deep snow pack !-- will reduce warm bias in western Canada !-- and US West coast, where max snow albedo is low (0.3-0.5). !print *,'ALB increase to 0.7',alb_snow,snhei,snhei_crit,albsn,i,j - !ALBsn = 0.7 + !ALBsn = 0.7_kind_phys !print *,'NO mosaic ALB increase to 0.7',alb_snow,snhei,snhei_crit,alb,i,j endif @@ -1739,16 +1738,16 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia !-- If temperature is higher that -10C then albedo is decreasing. !-- The minimum albedo at t=0C for snow on land is 15% less than !-- albedo of temperatures below -10C. - if(albsn.lt.0.4 .or. keep_snow_albedo==1) then + if(albsn.lt.0.4_kind_phys .or. keep_snow_albedo==1) then ALB=ALBsn else !-- change albedo when no fresh snow and snow albedo is higher than 0.5 - ALB = MIN(ALBSN,MAX(ALBSN - 0.1*(soilt - 263.15)/ & - (273.15-263.15)*ALBSN, ALBSN - 0.05)) + ALB = MIN(ALBSN,MAX(ALBSN - 0.1_kind_phys*(soilt - 263.15_kind_phys)/ & + (tfrz-263.15_kind_phys)*ALBSN, ALBSN - 0.05_kind_phys)) endif ELSE !----- SNOW on ice - if( snow_mosaic == 1.) then + if( snow_mosaic == one) then ALBsn=alb_snow Emiss= emissn else @@ -1766,25 +1765,25 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia !-- ALB dependence on snow temperature. When snow temperature is !-- below critical value of -10C - no change to albedo. !-- If temperature is higher that -10C then albedo is decreasing. - if(albsn.lt.alb_snow .or. keep_snow_albedo .eq.1.)then + if(albsn.lt.alb_snow .or. keep_snow_albedo .eq.one)then ALB=ALBsn else !-- change albedo when no fresh snow - ALB = MIN(ALBSN,MAX(ALBSN - 0.15*ALBSN*(soilt - 263.15)/ & - (273.15-263.15), ALBSN - 0.1)) + ALB = MIN(ALBSN,MAX(ALBSN - 0.15_kind_phys*ALBSN*(soilt - 263.15_kind_phys)/ & + (tfrz-263.15_kind_phys), ALBSN - 0.1_kind_phys)) endif ENDIF - if (snow_mosaic==1.) then + if (snow_mosaic==one) then !may 2014 - treat separately snow-free and snow-covered areas - if(SEAICE .LT. 0.5) then + if(SEAICE .LT. 0.5_kind_phys) then ! LAND ! portion not covered with snow ! compute absorbed GSW for snow-free portion - gswnew=GSWin*(1.-alb_snow_free) + gswnew=GSWin*(one-alb_snow_free) !-------------- T3 = STBOLT*SOILT*SOILT*SOILT UPFLUX = T3 *SOILT @@ -1808,9 +1807,9 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia qcgs = qcg csts = cst mavails = mavail - smelt=0. - runoff1s=0. - runoff2s=0. + smelt=zero + runoff1s=zero + runoff2s=zero ilands = ivgtyp @@ -1838,7 +1837,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! portion not covered with snow ! compute absorbed GSW for snow-free portion - gswnew=GSWin*(1.-albice) + gswnew=GSWin*(one-albice) !-------------- T3 = STBOLT*SOILT*SOILT*SOILT UPFLUX = T3 *SOILT @@ -1855,15 +1854,15 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia qvgs = qvg qsgs = qsg qcgs = qcg - smelt=0. - runoff1s=0. - runoff2s=0. + smelt=zero + runoff1s=zero + runoff2s=zero CALL SICE(debug_print,xlat,xlon, & !--- input variables i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew, & - 0.98,RNET,QKMS,TKMS,rho,myj, & + 0.98_kind_phys,RNET,QKMS,TKMS,rho,myj, & !--- sea ice parameters tice,rhosice,capice,thdifice, & zsmain,zshalf,DTDZS,DTDZS2,tbq, & @@ -1873,20 +1872,20 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ts1ds,dews,soilts,qvgs,qsgs,qcgs, & eetas,qfxs,hfxs,ss,evapls,prcpls,fltots & ) - edir1 = eeta*1.e-3 - ec1 = 0. - ett1 = 0. + edir1 = eeta*1.e-3_kind_phys + ec1 = zero + ett1 = zero runoff1 = prcpms - runoff2 = 0. - mavail = 1. - infiltr=0. - cst=0. + runoff2 = zero + mavail = one + infiltr= zero + cst= zero do k=1,nzs - soilm1d(k)=1. - soiliqw(k)=0. - soilice(k)=1. - smfrkeep(k)=1. - keepfr(k)=0. + soilm1d(k)=one + soiliqw(k)=zero + soilice(k)=one + smfrkeep(k)=one + keepfr(k)=zero enddo endif ! seaice < 0.5 @@ -1894,7 +1893,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia !--- recompute absorbed solar radiation and net radiation !--- for updated value of snow albedo - ALB - gswnew=GSWin*(1.-alb) + gswnew=GSWin*(one-alb) !-------------- T3 = STBOLT*SOILT*SOILT*SOILT UPFLUX = T3 *SOILT @@ -1908,10 +1907,10 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia print *,'GSWnew',gswnew,'alb=',alb ENDIF - if (SEAICE .LT. 0.5) then + if (SEAICE .LT. 0.5_kind_phys) then ! LAND - if(snow_mosaic==1.)then - snfr=1. + if(snow_mosaic==one)then + snfr=one else snfr=snowfrac endif @@ -1939,8 +1938,8 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia mavail,soilice,soiliqw,infiltr ) else ! SEA ICE - if(snow_mosaic==1.)then - snfr=1. + if(snow_mosaic==one)then + snfr=one else snfr=snowfrac endif @@ -1964,28 +1963,28 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia SMELT,SNOH,SNFLX,SNOM,eeta, & qfx,hfx,s,sublim,prcpl,fltot & ) - edir1 = eeta*1.e-3 - ec1 = 0. - ett1 = 0. + edir1 = eeta*1.e-3_kind_phys + ec1 = zero + ett1 = zero runoff1 = smelt - runoff2 = 0. - mavail = 1. - infiltr=0. - cst=0. + runoff2 = zero + mavail = one + infiltr = zero + cst = zero do k=1,nzs - soilm1d(k)=1. - soiliqw(k)=0. - soilice(k)=1. - smfrkeep(k)=1. - keepfr(k)=0. + soilm1d(k)=one + soiliqw(k)=zero + soilice(k)=one + smfrkeep(k)=one + keepfr(k)=zero enddo endif - if (snow_mosaic==1.) then + if (snow_mosaic==one) then ! May 2014 - now combine snow covered and snow-free land fluxes, soil temp, moist, ! etc. - if(SEAICE .LT. 0.5) then + if(SEAICE .LT. 0.5_kind_phys) then ! LAND IF (debug_print ) THEN !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then @@ -2004,7 +2003,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia soilm1d(k) = soilm1ds(k)*(1.-snowfrac) + soilm1d(k)*snowfrac ts1d(k) = ts1ds(k)*(1.-snowfrac) + ts1d(k)*snowfrac smfrkeep(k) = smfrkeeps(k)*(1.-snowfrac) + smfrkeep(k)*snowfrac - if(snowfrac > 0.5) then + if(snowfrac > 0.5_kind_phys) then keepfr(k) = keepfr(k) else keepfr(k) = keepfrs(k) @@ -2012,23 +2011,23 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia soilice(k) = soilices(k)*(1.-snowfrac) + soilice(k)*snowfrac soiliqw(k) = soiliqws(k)*(1.-snowfrac) + soiliqw(k)*snowfrac enddo - dew = dews*(1.-snowfrac) + dew*snowfrac - soilt = soilts*(1.-snowfrac) + soilt*snowfrac - qvg = qvgs*(1.-snowfrac) + qvg*snowfrac - qsg = qsgs*(1.-snowfrac) + qsg*snowfrac - qcg = qcgs*(1.-snowfrac) + qcg*snowfrac - edir1 = edir1s*(1.-snowfrac) + edir1*snowfrac - ec1 = ec1s*(1.-snowfrac) + ec1*snowfrac - cst = csts*(1.-snowfrac) + cst*snowfrac - ett1 = ett1s*(1.-snowfrac) + ett1*snowfrac - eeta = eetas*(1.-snowfrac) + eeta*snowfrac - qfx = qfxs*(1.-snowfrac) + qfx*snowfrac - hfx = hfxs*(1.-snowfrac) + hfx*snowfrac - s = ss*(1.-snowfrac) + s*snowfrac - evapl = evapls*(1.-snowfrac) + dew = dews*(one-snowfrac) + dew*snowfrac + soilt = soilts*(one-snowfrac) + soilt*snowfrac + qvg = qvgs*(one-snowfrac) + qvg*snowfrac + qsg = qsgs*(one-snowfrac) + qsg*snowfrac + qcg = qcgs*(one-snowfrac) + qcg*snowfrac + edir1 = edir1s*(one-snowfrac) + edir1*snowfrac + ec1 = ec1s*(one-snowfrac) + ec1*snowfrac + cst = csts*(one-snowfrac) + cst*snowfrac + ett1 = ett1s*(one-snowfrac) + ett1*snowfrac + eeta = eetas*(one-snowfrac) + eeta*snowfrac + qfx = qfxs*(one-snowfrac) + qfx*snowfrac + hfx = hfxs*(one-snowfrac) + hfx*snowfrac + s = ss*(one-snowfrac) + s*snowfrac + evapl = evapls*(one-snowfrac) sublim = sublim*snowfrac - prcpl = prcpls*(1.-snowfrac) + prcpl*snowfrac - fltot = fltots*(1.-snowfrac) + fltot*snowfrac + prcpl = prcpls*(one-snowfrac) + prcpl*snowfrac + fltot = fltots*(one-snowfrac) + fltot*snowfrac ALB = MAX(keep_snow_albedo*alb, & MIN((alb_snow_free + (alb - alb_snow_free) * snowfrac), alb)) @@ -2036,14 +2035,14 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia MIN((emiss_snowfree + & (emissn - emiss_snowfree) * snowfrac), emissn)) - runoff1 = runoff1s*(1.-snowfrac) + runoff1*snowfrac - runoff2 = runoff2s*(1.-snowfrac) + runoff2*snowfrac + runoff1 = runoff1s*(one-snowfrac) + runoff1*snowfrac + runoff2 = runoff2s*(one-snowfrac) + runoff2*snowfrac smelt = smelt * snowfrac snoh = snoh * snowfrac snflx = snflx * snowfrac snom = snom * snowfrac - mavail = mavails*(1.-snowfrac) + 1.*snowfrac - infiltr = infiltrs*(1.-snowfrac) + infiltr*snowfrac + mavail = mavails*(one-snowfrac) + one*snowfrac + infiltr = infiltrs*(one-snowfrac) + infiltr*snowfrac IF (debug_print ) THEN !if (abs(xlat-33.35).lt.0.2 .and. & abs(xlon-272.55).lt.0.2)then @@ -2058,27 +2057,27 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia print *,'SOILT snow on ice', soilt ENDIF do k=1,nzs - ts1d(k) = ts1ds(k)*(1.-snowfrac) + ts1d(k)*snowfrac + ts1d(k) = ts1ds(k)*(one-snowfrac) + ts1d(k)*snowfrac enddo - dew = dews*(1.-snowfrac) + dew*snowfrac - soilt = soilts*(1.-snowfrac) + soilt*snowfrac - qvg = qvgs*(1.-snowfrac) + qvg*snowfrac - qsg = qsgs*(1.-snowfrac) + qsg*snowfrac - qcg = qcgs*(1.-snowfrac) + qcg*snowfrac + dew = dews*(one-snowfrac) + dew*snowfrac + soilt = soilts*(one-snowfrac) + soilt*snowfrac + qvg = qvgs*(one-snowfrac) + qvg*snowfrac + qsg = qsgs*(one-snowfrac) + qsg*snowfrac + qcg = qcgs*(one-snowfrac) + qcg*snowfrac sublim = eeta*snowfrac - eeta = eetas*(1.-snowfrac) + eeta*snowfrac - qfx = qfxs*(1.-snowfrac) + qfx*snowfrac - hfx = hfxs*(1.-snowfrac) + hfx*snowfrac - s = ss*(1.-snowfrac) + s*snowfrac - prcpl = prcpls*(1.-snowfrac) + prcpl*snowfrac - fltot = fltots*(1.-snowfrac) + fltot*snowfrac + eeta = eetas*(one-snowfrac) + eeta*snowfrac + qfx = qfxs*(one-snowfrac) + qfx*snowfrac + hfx = hfxs*(one-snowfrac) + hfx*snowfrac + s = ss*(one-snowfrac) + s*snowfrac + prcpl = prcpls*(one-snowfrac) + prcpl*snowfrac + fltot = fltots*(one-snowfrac) + fltot*snowfrac ALB = MAX(keep_snow_albedo*alb, & MIN((albice + (alb - alb_snow_free) * snowfrac), alb)) Emiss = MAX(keep_snow_albedo*emissn, & MIN((emiss_snowfree + & (emissn - emiss_snowfree) * snowfrac), emissn)) - runoff1 = runoff1s*(1.-snowfrac) + runoff1*snowfrac - runoff2 = runoff2s*(1.-snowfrac) + runoff2*snowfrac + runoff1 = runoff1s*(one-snowfrac) + runoff1*snowfrac + runoff2 = runoff2s*(one-snowfrac) + runoff2*snowfrac smelt = smelt * snowfrac snoh = snoh * snowfrac snflx = snflx * snowfrac @@ -2120,23 +2119,23 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! Limit on znt (<0.25) is needed to avoid very small snow fractions in the ! forested areas with large roughness - IF(snhei == 0.) then + IF(snhei == zero) then !--- all snow is melted iland=ivgtyp - snowfrac = 0. + snowfrac = zero alb = alb_snow_free emiss = emiss_snowfree ELSE !-- update snow cover after possible melting - m = 1.0 ! m=1.6 in Niu&Yang, m=1 in CLM + m = one ! m=1.6_kind_phys in Niu&Yang, m=1 in CLM if(isncovr_opt == 1) then - snowfrac=min(1.,snhei/(2.*snhei_crit)) + snowfrac=min(one,snhei/(2._kind_phys*snhei_crit)) elseif(isncovr_opt == 2) then !-- isncovr_opt=2 - snowfrac=min(1.,snhei/(2.*snhei_crit)) + snowfrac=min(one,snhei/(2._kind_phys*snhei_crit)) if(ivgtyp == glacier .or. ivgtyp == bare) then !-- sparsely vegetated or land ice - snowfrac2 = tanh( snhei/(2.5 * 0.2 *(rhosn/rhonewsn)**m)) + snowfrac2 = tanh( snhei/(2.5_kind_phys * 0.2_kind_phys *(rhosn/rhonewsn)**m)) else !-- Niu&Yang: znt=0.01 m for 1 degree (100km) resolution tests ! on 3-km scale use actual roughness, but not higher than 0.2 m. @@ -2144,21 +2143,21 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia snowfrac2 = tanh( snhei/(2.5 *min(0.2,znt) *(rhosn/rhonewsn)**m)) endif !-- snow fraction is average between method 1 and 2 - snowfrac = 0.5*(snowfrac+snowfrac2) + snowfrac = 0.5_kind_phys*(snowfrac+snowfrac2) else !-- isncovr_opt=3 !m = msnf ! vegetation dependent facsnf/msnf from Noah MP !-- for RRFS a factor 10. was added to 'facsnf' to get reasonal values of ! snow cover fractions on the 3-km scale. ! This factor is scale dependent. - snowfrac = tanh( snhei/(10. * facsnf *(rhosn/rhonewsn)**m)) + snowfrac = tanh( snhei/(10._kind_phys * facsnf *(rhosn/rhonewsn)**m)) endif !-- due to steep slopes and blown snow, limit snow fraction in the !-- mountains ( Swiss weather model) - if(hgt > 2500. .and. ivgtyp == glacier) snowfrac=min(0.85,snowfrac) + if(hgt > 2500._kind_phys .and. ivgtyp == glacier) snowfrac=min(0.85_kind_phys,snowfrac) - if(ivgtyp == urban) snowfrac=min(0.75,snowfrac) + if(ivgtyp == urban) snowfrac=min(0.75_kind_phys,snowfrac) ! run-total accumulated snow based on snowfall and snowmelt in [mm] @@ -2171,9 +2170,9 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia print *,'Time-step sublim: swe,[kg m-2]',sublim*delt endif - snowfallac = snowfallac + max(0.,(newsn*rhonewsn - & ! source of snow (swe) [m] - (smelt+sublim*1.e-3)*delt*newsnowratio) & ! sink: melting and sublimation, (swe) [m] - /rhonewsn)*1.e3 ! snow accumulation in snow depth [mm] + snowfallac = snowfallac + max(zero,(newsn*rhonewsn - & ! source of snow (swe) [m] + (smelt+sublim*1.e-3_kind_phys)*delt*newsnowratio) & ! sink: melting and sublimation, (swe) [m] + /rhonewsn)*rhowater ! snow accumulation in snow depth [mm] IF (debug_print ) THEN !if (abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2)then @@ -2183,9 +2182,9 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ELSE !--- no snow - snheiprint=0. - snweprint=0. - smelt=0. + snheiprint=zero + snweprint=zero + smelt=zero !-------------- T3 = STBOLT*SOILT*SOILT*SOILT @@ -2196,7 +2195,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia print *,'NO snow on the ground GSWnew -',GSWnew,'RNET=',rnet ENDIF - if(SEAICE .LT. 0.5) then + if(SEAICE .LT. 0.5_kind_phys) then ! LAND CALL SOIL(debug_print,xlat,xlon, & !--- input variables @@ -2221,7 +2220,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! SEA ICE ! If current ice albedo is not the same as from the previous time step, then ! update GSW, ALB and RNET for surface energy budget - if(ALB.ne.ALBice) GSWnew=GSW/(1.-ALB)*(1.-ALBice) + if(ALB.ne.ALBice) GSWnew=GSW/(one-ALB)*(one-ALBice) alb=albice RNET = GSWnew + XINET @@ -2237,22 +2236,22 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia lv,CP,rovcp,cw,stbolt,tabs, & !--- output variables ts1d,dew,soilt,qvg,qsg,qcg, & - eeta,qfx,hfx,s,evapl,prcpl,fltot & + eeta,qfx,hfx,s,evapl,prcpl,fltot & ) - edir1 = eeta*1.e-3 - ec1 = 0. - ett1 = 0. + edir1 = eeta*1.e-3_kind_phys + ec1 = zero + ett1 = zero runoff1 = prcpms - runoff2 = 0. - mavail = 1. - infiltr=0. - cst=0. + runoff2 = zero + mavail = one + infiltr = zero + cst = zero do k=1,nzs - soilm1d(k)=1. - soiliqw(k)=0. - soilice(k)=1. - smfrkeep(k)=1. - keepfr(k)=0. + soilm1d(k)= one + soiliqw(k)= zero + soilice(k)= one + smfrkeep(k)= one + keepfr(k)= zero enddo endif @@ -2273,14 +2272,14 @@ FUNCTION QSN(TN,T) real (kind_phys) QSN, R,R1,R2 INTEGER I - R=(TN-173.15)/.05+1. + R=(TN-173.15_kind_dbl_prec)/.05_kind_dbl_prec+one I=INT(R) IF(I.GE.1) goto 10 I=1 R=1. 10 IF(I.LE.5000) GOTO 20 I=5000 - R=5001. + R=5001._kind_dbl_prec 20 R1=T(I) R2=R-I QSN=(T(I+1)-R1)*R2 + R1 @@ -2376,12 +2375,12 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & real (kind_phys), INTENT(IN ) :: DELT,CONFLX,xlat,xlon LOGICAL, INTENT(IN ) :: myj !--- 3-D Atmospheric variables - real (kind_phys), & + real (kind_phys), & INTENT(IN ) :: PATM, & QVATM, & QCATM !--- 2-D variables - real (kind_phys), & + real (kind_phys), & INTENT(IN ) :: GLW, & GSW, & GSWin, & @@ -2395,7 +2394,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & TKMS !--- soil properties - real (kind_phys), & + real (kind_phys), & INTENT(IN ) :: RHOCS, & BCLH, & DQM, & @@ -2406,7 +2405,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & REF, & WILT - real (kind_phys), INTENT(IN ) :: CN, & + real (kind_phys), INTENT(IN ) :: CN, & CW, & KQWRTZ, & KICE, & @@ -2415,7 +2414,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & g0_p - real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & ZSHALF, & DTDZS2 @@ -2426,16 +2425,16 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & !--- input/output variables !-------- 3-d soil moisture and temperature - real (kind_phys), DIMENSION( 1:nzs ) , & + real (kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: TSO, & SOILMOIS, & SMFRKEEP - real (kind_phys), DIMENSION( 1:nzs ) , & + real (kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: KEEPFR !-------- 2-d variables - real (kind_phys), & + real (kind_phys), & INTENT(INOUT) :: DEW, & CST, & DRIP, & @@ -2459,12 +2458,12 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & SOILT !-------- 1-d variables - real (kind_phys), DIMENSION(1:NZS), INTENT(OUT) :: SOILICE, & + real (kind_phys), DIMENSION(1:NZS), INTENT(OUT) :: SOILICE, & SOILIQW !--- Local variables - real (kind_phys) :: INFILTRP, transum , & + real (kind_phys) :: INFILTRP, transum , & RAINF, PRCPMS , & TABS, T3, UPFLUX, XINET real (kind_phys) :: CP,rovcp,G0,LV,STBOLT,xlmelt,dzstop , & @@ -2473,7 +2472,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & trans,zn,ci,cvw,tln,tavln,pi , & DD1,CMC2MS,DRYCAN,WETCAN , & INFMAX,RIW, X - real (kind_phys), DIMENSION(1:NZS) :: transp,cap,diffu,hydro, & + real (kind_phys), DIMENSION(1:NZS) :: transp,cap,diffu,hydro, & thdif,tranf,tav,soilmoism , & soilicem,soiliqwm,detal , & fwsat,lwsat,told,smold @@ -2486,67 +2485,67 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & !----------------------------------------------------------------- !-- define constants - RHOICE=900. - CI=RHOICE*2100. - XLMELT=3.35E+5 + RHOICE=900._kind_phys + CI=RHOICE*2100._kind_phys + XLMELT=3.35E+5_kind_phys cvw=cw prcpl=prcpms - smf=0. + smf = zero soiltold = soilt - wetcan=0. - drycan=1. + wetcan= zero + drycan= one !--- Initializing local arrays DO K=1,NZS - TRANSP (K)=0. - soilmoism(k)=0. - soilice (k)=0. - soiliqw (k)=0. - soilicem (k)=0. - soiliqwm (k)=0. - lwsat (k)=0. - fwsat (k)=0. - tav (k)=0. - cap (k)=0. - thdif (k)=0. - diffu (k)=0. - hydro (k)=0. - tranf (k)=0. - detal (k)=0. - told (k)=0. - smold (k)=0. + TRANSP (K)=zero + soilmoism(k)=zero + soilice (k)=zero + soiliqw (k)=zero + soilicem (k)=zero + soiliqwm (k)=zero + lwsat (k)=zero + fwsat (k)=zero + tav (k)=zero + cap (k)=zero + thdif (k)=zero + diffu (k)=zero + hydro (k)=zero + tranf (k)=zero + detal (k)=zero + told (k)=zero + smold (k)=zero ENDDO NZS1=NZS-1 NZS2=NZS-2 - dzstop=1./(zsmain(2)-zsmain(1)) - RAS=RHO*1.E-3 - RIW=rhoice*1.e-3 + dzstop=one/(zsmain(2)-zsmain(1)) + RAS=RHO*1.E-3_kind_phys + RIW=rhoice*1.e-3_kind_phys !--- Computation of volumetric content of ice in soil DO K=1,NZS !- main levels - tln=log(tso(k)/273.15) - if(tln.lt.0.) then + tln=log(tso(k)/tfrz) + if(tln.lt.zero) then soiliqw(k)=(dqm+qmin)*(XLMELT* & - (tso(k)-273.15)/tso(k)/9.81/psis) & - **(-1./bclh)-qmin - soiliqw(k)=max(0.,soiliqw(k)) + (tso(k)-tfrz)/tso(k)/9.81_kind_phys/psis) & + **(-one/bclh)-qmin + soiliqw(k)=max(zero,soiliqw(k)) soiliqw(k)=min(soiliqw(k),soilmois(k)) soilice(k)=(soilmois(k)-soiliqw(k))/RIW !---- melting and freezing is balanced, soil ice cannot increase - if(keepfr(k).eq.1._kind_phys) then + if(keepfr(k).eq.one) then soilice(k)=min(soilice(k),smfrkeep(k)) - soiliqw(k)=max(0._kind_phys,soilmois(k)-soilice(k)*riw) + soiliqw(k)=max(zero,soilmois(k)-soilice(k)*riw) endif else - soilice(k)=0._kind_phys + soilice(k)=zero soiliqw(k)=soilmois(k) endif @@ -2554,39 +2553,39 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & DO K=1,NZS1 !- middle of soil layers - tav(k)=0.5*(tso(k)+tso(k+1)) - soilmoism(k)=0.5*(soilmois(k)+soilmois(k+1)) - tavln=log(tav(k)/273.15) + tav(k)=0.5_kind_phys*(tso(k)+tso(k+1)) + soilmoism(k)=0.5_kind_phys*(soilmois(k)+soilmois(k+1)) + tavln=log(tav(k)/tfrz) - if(tavln.lt.0._kind_phys) then + if(tavln.lt.zero) then soiliqwm(k)=(dqm+qmin)*(XLMELT* & - (tav(k)-273.15)/tav(k)/9.81/psis) & - **(-1./bclh)-qmin + (tav(k)-tfrz)/tav(k)/9.81_kind_phys/psis) & + **(-one/bclh)-qmin fwsat(k)=dqm-soiliqwm(k) lwsat(k)=soiliqwm(k)+qmin - soiliqwm(k)=max(0._kind_phys,soiliqwm(k)) + soiliqwm(k)=max(zero,soiliqwm(k)) soiliqwm(k)=min(soiliqwm(k), soilmoism(k)) soilicem(k)=(soilmoism(k)-soiliqwm(k))/riw !---- melting and freezing is balanced, soil ice cannot increase - if(keepfr(k).eq.1._kind_phys) then + if(keepfr(k).eq.one) then soilicem(k)=min(soilicem(k), & - 0.5*(smfrkeep(k)+smfrkeep(k+1))) - soiliqwm(k)=max(0.,soilmoism(k)-soilicem(k)*riw) + 0.5_kind_phys*(smfrkeep(k)+smfrkeep(k+1))) + soiliqwm(k)=max(zero,soilmoism(k)-soilicem(k)*riw) fwsat(k)=dqm-soiliqwm(k) lwsat(k)=soiliqwm(k)+qmin endif else - soilicem(k)=0._kind_phys + soilicem(k)=zero soiliqwm(k)=soilmoism(k) lwsat(k)=dqm+qmin - fwsat(k)=0._kind_phys + fwsat(k)=zero endif ENDDO do k=1,nzs - if(soilice(k).gt.0._kind_phys) then + if(soilice(k).gt.zero) then smfrkeep(k)=soilice(k) else smfrkeep(k)=soilmois(k)/riw @@ -2617,7 +2616,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & Q1=-QKMS*RAS*(QVATM - QSG) - DEW=0. + DEW=zero IF(QVATM.GE.QSG)THEN DEW=FQ*(QVATM-QSG) ENDIF @@ -2626,8 +2625,8 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & !--- water, and DRYCAN is the fraction of vegetated area where !--- transpiration may take place. - WETCAN=min(0.25,max(0.,(CST/SAT))**CN) - DRYCAN=1.-WETCAN + WETCAN=min(0.25_kind_phys,max(zero,(CST/SAT))**CN) + DRYCAN=one-WETCAN !************************************************************** ! TRANSF computes transpiration function @@ -2648,16 +2647,16 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & ! Sakaguchi and Zeng (2009) - dry soil resistance to evaporation ! if (vgtype==11) then ! MODIS wetland - alfa=1. + alfa=one ! else - fex=min(1.,soilmois(1)/dqm) - fex=max(fex,0.01) + fex=min(one,soilmois(1)/dqm) + fex=max(fex,0.01_kind_phys) psit=psis*fex ** (-bclh) - psit = max(-1.e5, psit) - alfa=min(1.,exp(G0_P*psit/r_v/SOILT)) + psit = max(-1.e5_kind_phys, psit) + alfa=min(one,exp(G0_P*psit/r_v/SOILT)) ! print *,'alfa=',alfa, exp(G0_P*psit/r_v/SOILT) ! endif - alfa=1. + alfa=one ! field capacity ! 20jun18 - beta in Eq. (5) is called soilres in the code - it limits soil evaporation ! when soil moisture is below field capacity. [Lee and Pielke, 1992] @@ -2672,13 +2671,13 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & ! 3feb21 - in RRFS testing (fv3-based), ref*0.5 gives too much direct ! evaporation. Therefore , it is replaced with ref*0.7. fc=ref - fex_fc=1. - if((soilmois(1)+qmin) > fc .or. (qvatm-qvg) > 0.) then - soilres = 1. + fex_fc=one + if((soilmois(1)+qmin) > fc .or. (qvatm-qvg) > zero) then + soilres = one else - fex_fc=min(1.,(soilmois(1)+qmin)/fc) - fex_fc=max(fex_fc,0.01) - soilres=0.25*(1.-cos(piconst*fex_fc))**2. + fex_fc=min(one,(soilmois(1)+qmin)/fc) + fex_fc=max(fex_fc,0.01_kind_phys) + soilres=0.25_kind_phys*(one-cos(piconst*fex_fc))**2._kind_phys endif IF ( debug_print ) THEN print *,'piconst=',piconst @@ -2709,14 +2708,14 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & !************************************************************************ !--- CALCULATION OF DEW USING NEW VALUE OF QSG OR TRANSP IF NO DEW - ETT1=0. - DEW=0. + ETT1=zero + DEW=zero IF(QVATM.GE.QSG)THEN DEW=QKMS*(QVATM-QSG) - ETT1=0. + ETT1=zero DO K=1,NZS - TRANSP(K)=0. + TRANSP(K)=zero ENDDO ELSE @@ -2724,33 +2723,33 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & TRANSP(K)=VEGFRAC*RAS*QKMS* & (QVATM-QSG)* & TRANF(K)*DRYCAN/ZSHALF(NROOT+1) - IF(TRANSP(K).GT.0.) TRANSP(K)=0. + IF(TRANSP(K).GT.zero) TRANSP(K)=zero ETT1=ETT1-TRANSP(K) ENDDO DO k=nroot+1,nzs - transp(k)=0. + transp(k)=zero enddo ENDIF !-- Recalculate volumetric content of frozen water in soil DO K=1,NZS !- main levels - tln=log(tso(k)/273.15) - if(tln.lt.0.) then + tln=log(tso(k)/tfrz) + if(tln.lt.zero) then soiliqw(k)=(dqm+qmin)*(XLMELT* & - (tso(k)-273.15)/tso(k)/9.81/psis) & - **(-1./bclh)-qmin - soiliqw(k)=max(0.,soiliqw(k)) + (tso(k)-tfrz)/tso(k)/9.81_kind_phys/psis) & + **(-one/bclh)-qmin + soiliqw(k)=max(zero,soiliqw(k)) soiliqw(k)=min(soiliqw(k),soilmois(k)) soilice(k)=(soilmois(k)-soiliqw(k))/riw !---- melting and freezing is balanced, soil ice cannot increase - if(keepfr(k).eq.1.) then + if(keepfr(k).eq.one) then soilice(k)=min(soilice(k),smfrkeep(k)) - soiliqw(k)=max(0.,soilmois(k)-soilice(k)*riw) + soiliqw(k)=max(zero,soilmois(k)-soilice(k)*riw) endif else - soilice(k)=0. + soilice(k)=zero soiliqw(k)=soilmois(k) endif ENDDO @@ -2764,8 +2763,8 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & delt,nzs,nddzs,DTDZS,DTDZS2,RIW, & zsmain,zshalf,diffu,hydro, & QSG,QVG,QCG,QCATM,QVATM,-infwater, & - QKMS,TRANSP,DRIP,DEW,0.,SOILICE,VEGFRAC, & - 0.,soilres, & + QKMS,TRANSP,DRIP,DEW,zero,SOILICE,VEGFRAC, & + zero,soilres, & !-- soil properties DQM,QMIN,REF,KSAT,RAS,INFMAX, & !-- output @@ -2782,11 +2781,11 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & !--- frozen soil. do k=1,nzs - if (soilice(k).gt.0.) then + if (soilice(k).gt.zero) then if(tso(k).gt.told(k).and.soilmois(k).gt.smold(k)) then - keepfr(k)=1. + keepfr(k)=one else - keepfr(k)=0. + keepfr(k)=zero endif endif enddo @@ -2794,22 +2793,22 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & !--- THE DIAGNOSTICS OF SURFACE FLUXES T3 = STBOLT*SOILTold*SOILTold*SOILTold - UPFLUX = T3 * 0.5*(SOILTold+SOILT) + UPFLUX = T3 * 0.5_kind_phys*(SOILTold+SOILT) XINET = EMISS*(GLW-UPFLUX) HFT=-TKMS*CP*RHO*(TABS-SOILT) HFX=-TKMS*CP*RHO*(TABS-SOILT) & - *(P1000mb*0.00001/Patm)**ROVCP + *(P1000mb*0.00001_kind_phys/Patm)**ROVCP Q1=-QKMS*RAS*(QVATM - QSG) - CMC2MS = 0. - IF (Q1.LE.0.) THEN + CMC2MS = zero + IF (Q1.LE.zero) THEN ! --- condensation - EC1=0. - EDIR1=0. - ETT1=0. + EC1= zero + EDIR1= zero + ETT1= zero if(myj) then !-- moisture flux for coupling with MYJ PBL - EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*1.E3 + EETA=-QKMS*RAS*(QVATM/(one+QVATM) - QSG/(one+QSG))*rhowater CST= CST-EETA*DELT*vegfrac IF (debug_print ) THEN !!! IF(i.eq.374.and.j.eq.310.or. EETA.gt.0.0004) then @@ -2828,7 +2827,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & EETA= - RHO*DEW ELSE ! --- evaporation - EDIR1 =-soilres*(1.-vegfrac)*QKMS*RAS* & + EDIR1 =-soilres*(one-vegfrac)*QKMS*RAS* & (QVATM-QVG) CMC2MS=CST/DELT*RAS EC1 = Q1 * WETCAN * vegfrac @@ -2839,11 +2838,11 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & ENDIF ENDIF - CST=max(0.,CST-EC1 * DELT) + CST=max(zero,CST-EC1 * DELT) if (myj) then !-- moisture flux for coupling with MYJ PBL - EETA=-soilres*QKMS*RAS*(QVATM/(1.+QVATM) - QVG/(1.+QVG))*1.E3 + EETA=-soilres*QKMS*RAS*(QVATM/(one+QVATM) - QVG/(one+QVG))*rhowater else ! myj IF (debug_print ) THEN ! IF(i.eq.440.and.j.eq.180.or. QFX.gt.1000..or.i.eq.417.and.j.eq.540) then @@ -2854,14 +2853,14 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & print *,'EC1=',EC1,'ETT1=',ETT1,'CMC2MS=',CMC2MS,'CMC2MS*ras=',CMC2MS*ras ENDIF !-- actual moisture flux from RUC LSM - EETA = (EDIR1 + EC1 + ETT1)*1.E3 + EETA = (EDIR1 + EC1 + ETT1)*rhowater IF (debug_print ) THEN ! IF(i.eq.374.and.j.eq.310.or. EETA.gt.0.0004) then print *,'RUC LSM EETA',EETA,eeta*xlv ENDIF endif ! myj QFX= XLV * EETA - EETA = (EDIR1 + EC1 + ETT1)*1.E3 + EETA = (EDIR1 + EC1 + ETT1)*rhowater ENDIF IF (debug_print ) THEN print *,'potential temp HFT ',HFT @@ -2878,7 +2877,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & print *,'edir1,ec1,ett1,mavail,qkms,qvatm,qvg,qsg,vegfrac',& edir1,ec1,ett1,mavail,qkms,qvatm,qvg,qsg,vegfrac ENDIF - if(detal(1) .ne. 0.) then + if(detal(1) .ne. zero) then ! SMF - energy of phase change in the first soil layer smf=fltot IF (debug_print ) THEN @@ -3058,7 +3057,7 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & AA=XLS*(FKQ+R210)/TDENOM BB=(D10*TABS+R21*TN+XLS*(QVATM*FKQ & +R210*QVG)+D11+D9*(D2+R22*TN) & - +RAINF*CVW*PRCPMS*max(273.15,TABS) & + +RAINF*CVW*PRCPMS*max(tfrz,TABS) & )/TDENOM AA1=AA PP=PATM*1.E3 @@ -3146,7 +3145,7 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & XLS*rho*r211*(QSG-QGOLD) X=X & ! "heat" from rain - -RAINF*CVW*PRCPMS*(max(273.15,TABS)-SOILT) + -RAINF*CVW*PRCPMS*(max(tfrz,TABS)-SOILT) !-- excess energy spent on sea ice melt icemelt=RNET-XLS*EETA -HFT -S -X @@ -3486,10 +3485,10 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & !tgs - water in soil if there is any DO K=1,NZS - tln=log(tso(k)/273.15) + tln=log(tso(k)/tfrz) if(tln.lt.0.) then soiliqw(k)=(dqm+qmin)*(XLMELT* & - (tso(k)-273.15)/tso(k)/9.81/psis) & + (tso(k)-tfrz)/tso(k)/9.81/psis) & **(-1./bclh)-qmin soiliqw(k)=max(0.,soiliqw(k)) soiliqw(k)=min(soiliqw(k),soilmois(k)) @@ -3512,11 +3511,11 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & tav(k)=0.5*(tso(k)+tso(k+1)) soilmoism(k)=0.5*(soilmois(k)+soilmois(k+1)) - tavln=log(tav(k)/273.15) + tavln=log(tav(k)/tfrz) if(tavln.lt.0.) then soiliqwm(k)=(dqm+qmin)*(XLMELT* & - (tav(k)-273.15)/tav(k)/9.81/psis) & + (tav(k)-tfrz)/tav(k)/9.81/psis) & **(-1./bclh)-qmin fwsat(k)=dqm-soiliqwm(k) lwsat(k)=soiliqwm(k)+qmin @@ -3674,10 +3673,10 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & !-- recalculating of frozen water in soil DO K=1,NZS - tln=log(tso(k)/273.15) + tln=log(tso(k)/tfrz) if(tln.lt.0.) then soiliqw(k)=(dqm+qmin)*(XLMELT* & - (tso(k)-273.15)/tso(k)/9.81/psis) & + (tso(k)-tfrz)/tso(k)/9.81/psis) & **(-1./bclh)-qmin soiliqw(k)=max(0.,soiliqw(k)) soiliqw(k)=min(soiliqw(k),soilmois(k)) @@ -3716,7 +3715,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & !-- Restore land-use parameters if all snow is melted IF(SNHEI.EQ.0.) then - tsnav=soilt-273.15 + tsnav=soilt-tfrz ENDIF ! 21apr2009 @@ -4141,7 +4140,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & rhtsn=rhtso(NZS) !*** Average temperature of snow pack (C) tsnav=0.5*(soilt+tso(1)) & - -273.15 + -tfrz else !-- 2 layers in snow, SOILT1 is temperasture at DELTSN depth @@ -4168,7 +4167,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & !*** Average temperature of snow pack (C) tsnav=0.5/snhei*((soilt+soilt1)*deltsn & +(soilt1+tso(1))*(SNHEI-DELTSN)) & - -273.15 + -tfrz endif ENDIF @@ -4190,7 +4189,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & cotso(nzs1) = x1sn/denom rhtso(nzs1)=(FT+X2*rhtso(NZS-2))/denom tsnav=0.5*(soilt+tso(1)) & - -273.15 + -tfrz cotso(nzs)=cotso(NZS1) rhtso(nzs)=rhtso(nzs1) cotsn=cotso(NZS) @@ -4263,8 +4262,8 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & BB=(D10*TABS+R21*TN+XLVM*(QVATM* & (BETA*FKQ) & +R210*QVG)+D11+D9SN*(D2SN+R22SN*TN) & - +RAINF*CVW*PRCPMS*max(273.15,TABS) & - + RHOnewCSN*NEWSNOW/DELT*min(273.15,TABS) & + +RAINF*CVW*PRCPMS*max(tfrz,TABS) & + + RHOnewCSN*NEWSNOW/DELT*min(tfrz,TABS) & )/TDENOM AA1=AA PP=PATM*1.E3 @@ -4288,7 +4287,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & !--- SOILT - skin temperature of snow on ice SOILT=TS1 if(nmelt==1 .and. snowfrac==1) then - soilt = min(273.15,soilt) + soilt = min(tfrz,soilt) endif IF (debug_print ) THEN @@ -4299,7 +4298,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & IF(SNHEI.GE.SNTH) THEN if(snhei.gt.DELTSN+SNTH) then !-- 2-layer snow model - SOILT1=min(273.15,rhtsn+cotsn*SOILT) + SOILT1=min(tfrz,rhtsn+cotsn*SOILT) TSO(1)=min(271.4,(rhtso(NZS)+cotso(NZS)*SOILT1)) tsob=soilt1 else @@ -4344,18 +4343,17 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & if(nmelt.eq.1) go to 220 -!--- IF SOILT > 273.15 F then melting of snow can happen +!--- IF SOILT > tfrz F then melting of snow can happen ! if all snow can evaporate, then there is nothing to melt - IF(SOILT.GT.273.15.AND.BETA.EQ.1._kind_phys.AND.SNHEI.GT.0._kind_phys) THEN + IF(SOILT>tfrz .AND. BETA==one .AND. SNHEI>zero) THEN ! nmelt = 1 - soiltfrac=snowfrac*273.15+(1.-snowfrac)*min(271.4,SOILT) + soiltfrac=snowfrac*tfrz+(1.-snowfrac)*min(271.4,SOILT) QSG= QSN(soiltfrac,TBQ)/PP T3 = STBOLT*TNold*TNold*TNold UPFLUX = T3 * 0.5*(TNold+SOILTfrac) XINET = EMISS*(GLW-UPFLUX) -! RNET = GSW + XINET EPOT = -QKMS*(QVATM-QSG) Q1=EPOT*RAS @@ -4386,16 +4384,16 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & XLVM*R210*(QSG-QGOLD) !-- SNOH is energy flux of snow phase change SNOH=RNET+QFX +HFX & - +RHOnewCSN*NEWSNOW/DELT*(min(273.15,TABS)-soiltfrac) & + +RHOnewCSN*NEWSNOW/DELT*(min(tfrz,TABS)-soiltfrac) & -SOH-X+RAINF*CVW*PRCPMS* & - (max(273.15,TABS)-soiltfrac) + (max(tfrz,TABS)-soiltfrac) IF (debug_print ) THEN print *,'SNOWSEAICE melt I,J,SNOH,RNET,QFX,HFX,SOH,X',i,j,SNOH,RNET,QFX,HFX,SOH,X - print *,'RHOnewCSN*NEWSNOW/DELT*(min(273.15,TABS)-soiltfrac)', & - RHOnewCSN*NEWSNOW/DELT*(min(273.15,TABS)-soiltfrac) - print *,'RAINF*CVW*PRCPMS*(max(273.15,TABS)-soiltfrac)', & - RAINF*CVW*PRCPMS*(max(273.15,TABS)-soiltfrac) + print *,'RHOnewCSN*NEWSNOW/DELT*(min(tfrz,TABS)-soiltfrac)', & + RHOnewCSN*NEWSNOW/DELT*(min(tfrz,TABS)-soiltfrac) + print *,'RAINF*CVW*PRCPMS*(max(tfrz,TABS)-soiltfrac)', & + RAINF*CVW*PRCPMS*(max(tfrz,TABS)-soiltfrac) ENDIF SNOH=AMAX1(0._kind_phys,SNOH) !-- SMELT is speed of melting in M/S @@ -4407,7 +4405,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & print *,'1-SMELT i,j',smelt,i,j ENDIF !18apr08 - Egglston limit - SMELT= amin1 (smelt,delt/60.* 5.6E-8*meltfactor*max(1.,(soilt-273.15))) ! SnowMIP + SMELT= amin1 (smelt,delt/60.* 5.6E-8*meltfactor*max(1.,(soilt-tfrz))) ! SnowMIP IF (debug_print ) THEN print *,'2-SMELT i,j',smelt,i,j ENDIF @@ -4538,9 +4536,9 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & if(ilnb.gt.1) then tsnav=0.5/snhei*((soilt+soilt1)*deltsn & +(soilt1+tso(1))*(SNHEI-DELTSN)) & - -273.15 + -tfrz else - tsnav=0.5*(soilt+tso(1)) - 273.15 + tsnav=0.5*(soilt+tso(1)) - tfrz endif ENDIF !--- RECALCULATION OF DEW USING NEW VALUE OF QSG @@ -4624,8 +4622,8 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & R21,D9sn,r22sn,soiltfrac,tnold,qsg,qgold,snprim ENDIF X=X & - -RHOnewCSN*NEWSNOW/DELT*(min(273.15,TABS)-SOILT) & - -RAINF*CVW*PRCPMS*(max(273.15,TABS)-SOILT) + -RHOnewCSN*NEWSNOW/DELT*(min(tfrz,TABS)-SOILT) & + -RAINF*CVW*PRCPMS*(max(tfrz,TABS)-SOILT) ! -- excess energy is spent on ice melt icemelt = RNET-HFT-XLVm*EETA-S-SNOH-X @@ -4642,7 +4640,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & ENDIF !-- Restore sea-ice parameters if snow is less than threshold IF(SNHEI.EQ.0.) then - tsnav=soilt-273.15 + tsnav=soilt-tfrz emiss=0.98 znt=0.011 alb=0.55 @@ -4870,7 +4868,7 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & BB=(D10*TABS+R21*TN+XLV*(QVATM* & (FKQ*UMVEG+C) & +R210*QVG)+D11+D9*(D2+R22*TN) & - +RAINF*CVW*PRCPMS*max(273.15,TABS) & + +RAINF*CVW*PRCPMS*max(tfrz,TABS) & )/TDENOM AA1=AA+CC PP=PATM*1.E3 @@ -4944,7 +4942,7 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & ENDIF X=X & ! "heat" from rain - -RAINF*CVW*PRCPMS*(max(273.15,TABS)-SOILT) + -RAINF*CVW*PRCPMS*(max(tfrz,TABS)-SOILT) IF (debug_print ) THEN print *,'x=',x @@ -5276,7 +5274,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & rhtsn=rhtso(NZS) !*** Average temperature of snow pack (C) tsnav=min(0.,0.5*(soilt+tso(1)) & - -273.15) + -tfrz) else !-- 2 layers in snow, SOILT1 is temperasture at DELTSN depth @@ -5306,7 +5304,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & !*** Average temperature of snow pack (C) tsnav=min(0.,0.5/snhei*((soilt+soilt1)*deltsn & +(soilt1+tso(1))*(SNHEI-DELTSN)) & - -273.15) + -tfrz) endif ENDIF IF(SNHEI.LT.SNTH.AND.SNHEI.GT.0.) then @@ -5327,7 +5325,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & cotso(nzs1) = x1sn/denom rhtso(nzs1)=(FT+X2*rhtso(NZS-2))/denom tsnav=min(0.,0.5*(soilt+tso(1)) & - -273.15) + -tfrz) cotso(NZS)=cotso(nzs1) rhtso(NZS)=rhtso(nzs1) cotsn=cotso(NZS) @@ -5425,8 +5423,8 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & BB=(D10*TABS+R21*TN+XLVM*(QVATM* & (BETA*FKQ*UMVEG+C) & +R210*QGOLD)+D11+D9SN*(D2SN+R22SN*TN) & - +RAINF*CVW*PRCPMS*max(273.15,TABS) & - + RHOnewCSN*NEWSNOW/DELT*min(273.15,TABS) & + +RAINF*CVW*PRCPMS*max(tfrz,TABS) & + + RHOnewCSN*NEWSNOW/DELT*min(tfrz,TABS) & )/TDENOM AA1=AA+CC PP=PATM*1.E3 @@ -5494,15 +5492,15 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & !--- SOILT - skin temperature SOILT=TS1 - if(nmelt==1 .and. snowfrac==1 .and. snwe > 0. .and. SOILT > 273.15) then + if(nmelt==1 .and. snowfrac==1 .and. snwe > 0. .and. SOILT > tfrz) then !--7feb22 on the second iteration when SNOH is known and snwe > 0. after melting, - !-- check if the snow skin temperature is =<273.15K + !-- check if the snow skin temperature is = 0.) THEN + IF(TSO(1).GT.tfrz .and. snhei > 0.) THEN !-- melting at the soil/snow interface if (snhei.GT.deltsn+snth) then hsn = snhei - deltsn @@ -5862,7 +5860,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & hsn = snhei endif - soiltfrac=snowfrac*273.15+(1.-snowfrac)*TSO(1) + soiltfrac=snowfrac*tfrz+(1.-snowfrac)*TSO(1) SNOHG=(TSO(1)-soiltfrac)*(cap(1)*zshalf(2)+ & RHOCSN*0.5*hsn) / DELT @@ -5926,8 +5924,8 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & X=X & ! "heat" from snow and rain - -RHOnewCSN*NEWSNOW/DELT*(min(273.15,TABS)-SOILT) & - -RAINF*CVW*PRCPMS*(max(273.15,TABS)-SOILT) + -RHOnewCSN*NEWSNOW/DELT*(min(tfrz,TABS)-SOILT) & + -RAINF*CVW*PRCPMS*(max(tfrz,TABS)-SOILT) IF (debug_print ) THEN print *,'x=',x print *,'SNHEI=',snhei @@ -5938,12 +5936,12 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & if(ilnb.gt.1) then tsnav=min(0.,0.5/snhei*((soilt+soilt1)*deltsn & +(soilt1+tso(1))*(SNHEI-DELTSN)) & - -273.15) + -tfrz) else - tsnav=min(0.,0.5*(soilt+tso(1)) - 273.15) + tsnav=min(0.,0.5*(soilt+tso(1)) - tfrz) endif ELSE - tsnav= min(0.,soilt - 273.15) + tsnav= min(0.,soilt - tfrz) ENDIF !------------------------------------------------------------------------ @@ -6400,7 +6398,7 @@ SUBROUTINE SOILPROP( debug_print, & endif DO K=1,NZS1 - tn=tav(k) - 273.15 + tn=tav(k) - tfrz wd=ws - riw*soilicem(k) psif=psis*100.*(wd/(soiliqwm(k)+qmin))**bclh & * (ws/wd)**3. @@ -6418,7 +6416,7 @@ SUBROUTINE SOILPROP( debug_print, & !--- DETAL is taking care of energy spent on freezing or released from ! melting of soil water - DETAL(K)=273.15*X2/(TAV(K)*TAV(K))* & + DETAL(K)=tfrz*X2/(TAV(K)*TAV(K))* & (TAV(K)/(X1*TN))**X4 if(keepfr(k).eq.1.) then @@ -7279,11 +7277,11 @@ SUBROUTINE RUCLSMINIT( debug_print, landfrac, fice, min_seaice, & DO L=1,NZS !-- for land points initialize soil ice - tln=log(TSLB(i,l,j)/273.15) + tln=log(TSLB(i,l,j)/tfrz) if(tln.lt.0.) then soiliqw(l)=(dqm+qmin)*(XLMELT* & - (tslb(i,l,j)-273.15)/tslb(i,l,j)/9.81/psis) & + (tslb(i,l,j)-tfrz)/tslb(i,l,j)/9.81/psis) & **(-1./bclh) soiliqw(l)=max(0.,soiliqw(l)) soiliqw(l)=min(soiliqw(l),smois(i,l,j)) From 4a74783b79a33d80dfdb7cd85853c7902b456910 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Tue, 21 Mar 2023 20:34:04 +0000 Subject: [PATCH 177/380] More changes related to kin_phys. --- physics/module_sf_ruclsm.F90 | 292 +++++++++++++++++------------------ 1 file changed, 146 insertions(+), 146 deletions(-) diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index ea253ad2a..653323419 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -2846,9 +2846,9 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & else ! myj IF (debug_print ) THEN ! IF(i.eq.440.and.j.eq.180.or. QFX.gt.1000..or.i.eq.417.and.j.eq.540) then - print *,'QKMS,RAS,QVATM/(1.+QVATM),QVG/(1.+QVG),QSG ', & - QKMS,RAS,QVATM/(1.+QVATM),QVG/(1.+QVG),QSG - print *,'Q1*(1.-vegfrac),EDIR1',Q1*(1.-vegfrac),EDIR1 + print *,'QKMS,RAS,QVATM/(one+QVATM),QVG/(one+QVG),QSG ', & + QKMS,RAS,QVATM/(one+QVATM),QVG/(one+QVG),QSG + print *,'Q1*(1.-vegfrac),EDIR1',Q1*(one-vegfrac),EDIR1 print *,'CST,WETCAN,DRYCAN',CST,WETCAN,DRYCAN print *,'EC1=',EC1,'ETT1=',ETT1,'CMC2MS=',CMC2MS,'CMC2MS*ras=',CMC2MS*ras ENDIF @@ -2929,12 +2929,12 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & real (kind_phys), INTENT(IN ) :: DELT,CONFLX,xlat,xlon LOGICAL, INTENT(IN ) :: myj, debug_print !--- 3-D Atmospheric variables - real (kind_phys), & + real (kind_phys), & INTENT(IN ) :: PATM, & QVATM, & QCATM !--- 2-D variables - real (kind_phys), & + real (kind_phys), & INTENT(IN ) :: GLW, & GSW, & EMISS, & @@ -2942,7 +2942,7 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & QKMS, & TKMS !--- sea ice properties - real (kind_phys), DIMENSION(1:NZS) , & + real (kind_phys), DIMENSION(1:NZS) , & INTENT(IN ) :: & tice, & rhosice, & @@ -2950,16 +2950,16 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & thdifice - real (kind_phys), INTENT(IN ) :: & + real (kind_phys), INTENT(IN ) :: & CW, & XLV - real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & ZSHALF, & DTDZS2 - real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS real (kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ @@ -2968,7 +2968,7 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & !----soil temperature real (kind_phys), DIMENSION( 1:nzs ), INTENT(INOUT) :: TSO !-------- 2-d variables - real (kind_phys), & + real (kind_phys), & INTENT(INOUT) :: DEW, & EETA, & EVAPL, & @@ -2984,15 +2984,15 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & !--- Local variables real (kind_phys) :: x,x1,x2,x4,tn,denom - real (kind_phys) :: RAINF, PRCPMS , & + real (kind_phys) :: RAINF, PRCPMS , & TABS, T3, UPFLUX, XINET real (kind_phys) :: CP,rovcp,G0,LV,STBOLT,xlmelt,dzstop , & epot,fltot,ft,fq,hft,ras,cvw - real (kind_phys) :: FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11, & - PI,H,FKQ,R210,AA,BB,PP,Q1,QS1,TS1,TQ2,TX2 , & - TDENOM,QGOLD,SNOH + real (kind_phys) :: FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11, & + PI,H,FKQ,R210,AA,BB,PP,Q1,QS1,TS1,TQ2,TX2 , & + TDENOM,QGOLD,SNOH real (kind_phys) :: AA1,RHCS, icemelt @@ -3004,7 +3004,7 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & !----------------------------------------------------------------- !-- define constants - XLMELT=3.35E+5 + XLMELT=3.35E+5_kind_dbl_prec cvw=cw prcpl=prcpms @@ -3012,14 +3012,14 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & NZS1=NZS-1 NZS2=NZS-2 dzstop=1./(zsmain(2)-zsmain(1)) - RAS=RHO*1.E-3 + RAS=RHO*1.E-3_kind_phys do k=1,nzs - cotso(k)=0. - rhtso(k)=0. + cotso(k)=zero + rhtso(k)=zero enddo - cotso(1)=0. + cotso(1)=zero rhtso(1)=TSO(NZS) DO 33 K=1,NZS2 @@ -3037,20 +3037,20 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & !************************************************************************ !--- THE HEAT BALANCE EQUATION (Smirnova et al., 1996, EQ. 21,26) RHCS=CAPICE(1) - H=1. + H=one FKT=TKMS D1=cotso(NZS1) D2=rhtso(NZS1) TN=TSO(1) D9=THDIFICE(1)*RHCS*dzstop D10=TKMS*CP*RHO - R211=.5*CONFLX/DELT + R211=.5_kind_phys*CONFLX/DELT R21=R211*CP*RHO - R22=.5/(THDIFICE(1)*DELT*dzstop**2) - R6=EMISS *STBOLT*.5*TN**4 + R22=.5_kind_phys/(THDIFICE(1)*DELT*dzstop**2) + R6=EMISS *STBOLT*.5_kind_phys*TN**4 R7=R6/TN D11=RNET+R6 - TDENOM=D9*(1.-D1+R22)+D10+R21+R7 & + TDENOM=D9*(one-D1+R22)+D10+R21+R7 & +RAINF*CVW*PRCPMS FKQ=QKMS*RHO R210=R211*RHO @@ -3060,7 +3060,7 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & +RAINF*CVW*PRCPMS*max(tfrz,TABS) & )/TDENOM AA1=AA - PP=PATM*1.E3 + PP=PATM*rhowater AA1=AA1/PP IF (debug_print ) THEN PRINT *,' VILKA-SEAICE1' @@ -3077,32 +3077,32 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & !--- it is saturation over sea ice QVG=QS1 QSG=QS1 - TSO(1)=min(271.4,TS1) - QCG=0. + TSO(1)=min(271.4_kind_phys,TS1) + QCG=zero !--- sea ice melting is not included in this simple approach !--- SOILT - skin temperature SOILT=TSO(1) !---- Final solution for soil temperature - TSO DO K=2,NZS KK=NZS-K+1 - TSO(K)=min(271.4,rhtso(KK)+cotso(KK)*TSO(K-1)) + TSO(K)=min(271.4_kind_phys,rhtso(KK)+cotso(KK)*TSO(K-1)) END DO !--- CALCULATION OF DEW USING NEW VALUE OF QSG OR TRANSP IF NO DEW - DEW=0. + DEW=zero !--- THE DIAGNOSTICS OF SURFACE FLUXES T3 = STBOLT*TN*TN*TN - UPFLUX = T3 *0.5*(TN+SOILT) + UPFLUX = T3 *0.5_kind_phys*(TN+SOILT) XINET = EMISS*(GLW-UPFLUX) HFT=-TKMS*CP*RHO*(TABS-SOILT) HFX=-TKMS*CP*RHO*(TABS-SOILT) & - *(P1000mb*0.00001/Patm)**ROVCP + *(P1000mb*0.00001_kind_phys/Patm)**ROVCP Q1=-QKMS*RAS*(QVATM - QSG) - IF (Q1.LE.0.) THEN + IF (Q1.LE.zero) THEN ! --- condensation if(myj) then !-- moisture flux for coupling with MYJ PBL - EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*1.E3 + EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*rhowater IF (debug_print ) THEN print *,'MYJ EETA',eeta ENDIF @@ -3120,28 +3120,28 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & ! --- evaporation if(myj) then !-- moisture flux for coupling with MYJ PBL - EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QVG/(1.+QVG))*1.E3 + EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QVG/(1.+QVG))*rhowater IF (debug_print ) THEN print *,'MYJ EETA',eeta ENDIF else ! myj ! to convert from m s-1 to kg m-2 s-1: *rho water=1.e3************ !-- actual moisture flux from RUC LSM - EETA = Q1*1.E3 + EETA = Q1*rhowater IF (debug_print ) THEN print *,'RUC LSM EETA',eeta ENDIF endif ! myj QFX= XLS * EETA - EETA = Q1*1.E3 + EETA = Q1*rhowater ENDIF EVAPL=EETA S=THDIFICE(1)*CAPICE(1)*DZSTOP*(TSO(1)-TSO(2)) ! heat storage in surface layer - SNOH=0. + SNOH=zero ! There is ice melt - X= (cp*rho*r211+rhcs*zsmain(2)*0.5/delt)*(SOILT-TN) + & + X= (cp*rho*r211+rhcs*zsmain(2)*0.5_kind_phys/delt)*(SOILT-TN) + & XLS*rho*r211*(QSG-QGOLD) X=X & ! "heat" from rain @@ -3188,7 +3188,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & dew,soilt,soilt1,tsnav, & qvg,qsg,qcg,SMELT,SNOH,SNFLX,SNOM, & edir1,ec1,ett1,eeta,qfx,hfx,s,sublim, & - prcpl,fltot,runoff1,runoff2,mavail,soilice, & + prcpl,fltot,runoff1,runoff2,mavail,soilice, & soiliqw,infiltrp ) !*************************************************************** @@ -3275,12 +3275,12 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & LOGICAL, INTENT(IN ) :: myj !--- 3-D Atmospheric variables - real (kind_phys), & + real (kind_phys), & INTENT(IN ) :: PATM, & QVATM, & QCATM !--- 2-D variables - real (kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: GLW, & GSW, & GSWin, & @@ -3294,7 +3294,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & INTEGER, INTENT(IN ) :: IVGTYP !--- soil properties - real (kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: RHOCS, & BCLH, & DQM, & @@ -3306,7 +3306,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & SAT, & WILT - real (kind_phys), INTENT(IN ) :: CN, & + real (kind_phys), INTENT(IN ) :: CN, & CW, & XLV, & G0_P, & @@ -3315,23 +3315,23 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & KWT - real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & ZSHALF, & DTDZS2 - real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - real (kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ + real (kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ !--- input/output variables !-------- 3-d soil moisture and temperature - real (kind_phys), DIMENSION( 1:nzs ) , & + real (kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: TSO, & SOILMOIS, & SMFRKEEP - real (kind_phys), DIMENSION( 1:nzs ) , & + real (kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: KEEPFR @@ -3339,7 +3339,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & !-------- 2-d variables - real (kind_phys) , & + real (kind_phys) , & INTENT(INOUT) :: DEW, & CST, & DRIP, & @@ -3376,10 +3376,10 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & INTEGER, INTENT(INOUT) :: ILNB !-------- 1-d variables - real (kind_phys), DIMENSION(1:NZS), INTENT(OUT) :: SOILICE, & - SOILIQW + real (kind_phys), DIMENSION(1:NZS), INTENT(OUT) :: SOILICE, & + SOILIQW - real (kind_phys), INTENT(OUT) :: RSM, & + real (kind_phys), INTENT(OUT) :: RSM, & SNWEPRINT, & SNHEIPRINT !--- Local variables @@ -3387,7 +3387,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & INTEGER :: nzs1,nzs2,k - real (kind_phys) :: INFILTRP, TRANSUM , & + real (kind_phys) :: INFILTRP, TRANSUM , & SNTH, NEWSN , & TABS, T3, UPFLUX, XINET , & BETA, SNWEPR,EPDT,PP @@ -3398,7 +3398,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & DD1,CMC2MS,DRYCAN,WETCAN , & INFMAX,RIW,DELTSN,H,UMVEG - real (kind_phys), DIMENSION(1:NZS) :: transp,cap,diffu,hydro, & + real (kind_phys), DIMENSION(1:NZS) :: transp,cap,diffu,hydro, & thdif,tranf,tav,soilmoism , & soilicem,soiliqwm,detal , & fwsat,lwsat,told,smold @@ -3409,7 +3409,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & !----------------------------------------------------------------- cvw=cw - XLMELT=3.35E+5 + XLMELT=3.35E+5_kind_dbl_prec !-- heat of water vapor sublimation XLVm=XLV+XLMELT @@ -3426,48 +3426,48 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & soiltold=soilt qgold=qvg - x=0. + x=zero ! increase thinkness of top snow layer from 3 cm SWE to 5 cm SWE - DELTSN=0.05*1.e3/rhosn - snth=0.01*1.e3/rhosn + DELTSN=0.05_kind_phys*rhowater/rhosn + snth=0.01_kind_phys*rhowater/rhosn ! For 2-layer snow model when the snow depth is marginally higher than DELTSN, ! reset DELTSN to half of snow depth. IF(SNHEI.GE.DELTSN+SNTH) THEN - if(snhei-deltsn-snth.lt.snth) deltsn=0.5*(snhei-snth) + if(snhei-deltsn-snth.lt.snth) deltsn=0.5_kind_phys*(snhei-snth) IF (debug_print ) THEN print *,'DELTSN is changed,deltsn,snhei,snth',i,j,deltsn,snhei,snth ENDIF ENDIF - RHOICE=900. - CI=RHOICE*2100. - RAS=RHO*1.E-3 - RIW=rhoice*1.e-3 - RSM=0. + RHOICE=900._kind_dbl_prec + CI=RHOICE*2100._kind_dbl_prec + RAS=RHO*1.E-3_kind_dbl_prec + RIW=rhoice*1.e-3_kind_dbl_prec + RSM=zero DO K=1,NZS - TRANSP (K)=0. - soilmoism (k)=0. - soiliqwm (k)=0. - soilice (k)=0. - soilicem (k)=0. - lwsat (k)=0. - fwsat (k)=0. - tav (k)=0. - cap (k)=0. - diffu (k)=0. - hydro (k)=0. - thdif (k)=0. - tranf (k)=0. - detal (k)=0. - told (k)=0. - smold (k)=0. + TRANSP (K)=zero + soilmoism (k)=zero + soiliqwm (k)=zero + soilice (k)=zero + soilicem (k)=zero + lwsat (k)=zero + fwsat (k)=zero + tav (k)=zero + cap (k)=zero + diffu (k)=zero + hydro (k)=zero + thdif (k)=zero + tranf (k)=zero + detal (k)=zero + told (k)=zero + smold (k)=zero ENDDO - snweprint=0. - snheiprint=0. + snweprint=zero + snheiprint=zero prcpl=prcpms !*** DELTSN is the depth of the top layer of snow where @@ -3477,7 +3477,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & NZS1=NZS-1 NZS2=NZS-2 - DZSTOP=1./(zsmain(2)-zsmain(1)) + DZSTOP=one/(zsmain(2)-zsmain(1)) !----- THE CALCULATION OF THERMAL DIFFUSIVITY, DIFFUSIONAL AND --- !----- HYDRAULIC CONDUCTIVITY (SMIRNOVA ET AL. 1996, EQ.2,5,6) --- @@ -3486,22 +3486,22 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & DO K=1,NZS tln=log(tso(k)/tfrz) - if(tln.lt.0.) then + if(tln.lt.zero) then soiliqw(k)=(dqm+qmin)*(XLMELT* & - (tso(k)-tfrz)/tso(k)/9.81/psis) & - **(-1./bclh)-qmin - soiliqw(k)=max(0.,soiliqw(k)) + (tso(k)-tfrz)/tso(k)/9.81_kind_phys/psis) & + **(-one/bclh)-qmin + soiliqw(k)=max(zero,soiliqw(k)) soiliqw(k)=min(soiliqw(k),soilmois(k)) soilice(k)=(soilmois(k)-soiliqw(k))/riw !---- melting and freezing is balanced, soil ice cannot increase if(keepfr(k).eq.1.) then soilice(k)=min(soilice(k),smfrkeep(k)) - soiliqw(k)=max(0.,soilmois(k)-soilice(k)*rhoice*1.e-3) + soiliqw(k)=max(zero,soilmois(k)-soilice(k)*rhoice*1.e-3_kind_phys) endif else - soilice(k)=0. + soilice(k)=zero soiliqw(k)=soilmois(k) endif @@ -3509,39 +3509,39 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & DO K=1,NZS1 - tav(k)=0.5*(tso(k)+tso(k+1)) - soilmoism(k)=0.5*(soilmois(k)+soilmois(k+1)) + tav(k)=0.5_kind_phys*(tso(k)+tso(k+1)) + soilmoism(k)=0.5_kind_phys*(soilmois(k)+soilmois(k+1)) tavln=log(tav(k)/tfrz) - if(tavln.lt.0.) then + if(tavln.lt.zero) then soiliqwm(k)=(dqm+qmin)*(XLMELT* & - (tav(k)-tfrz)/tav(k)/9.81/psis) & - **(-1./bclh)-qmin + (tav(k)-tfrz)/tav(k)/9.81_kind_phys/psis) & + **(-one/bclh)-qmin fwsat(k)=dqm-soiliqwm(k) lwsat(k)=soiliqwm(k)+qmin - soiliqwm(k)=max(0.,soiliqwm(k)) + soiliqwm(k)=max(zero,soiliqwm(k)) soiliqwm(k)=min(soiliqwm(k), soilmoism(k)) soilicem(k)=(soilmoism(k)-soiliqwm(k))/riw !---- melting and freezing is balanced, soil ice cannot increase - if(keepfr(k).eq.1.) then + if(keepfr(k).eq.one) then soilicem(k)=min(soilicem(k), & - 0.5*(smfrkeep(k)+smfrkeep(k+1))) - soiliqwm(k)=max(0.,soilmoism(k)-soilicem(k)*riw) + 0.5_kind_phys*(smfrkeep(k)+smfrkeep(k+1))) + soiliqwm(k)=max(zero,soilmoism(k)-soilicem(k)*riw) fwsat(k)=dqm-soiliqwm(k) lwsat(k)=soiliqwm(k)+qmin endif else - soilicem(k)=0. + soilicem(k)=zero soiliqwm(k)=soilmoism(k) lwsat(k)=dqm+qmin - fwsat(k)=0. + fwsat(k)=zero endif ENDDO do k=1,nzs - if(soilice(k).gt.0.) then + if(soilice(k).gt.zero) then smfrkeep(k)=soilice(k) else smfrkeep(k)=soilmois(k)/riw @@ -3568,7 +3568,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & !******************************************************************** !--- CALCULATION OF CANOPY WATER (Smirnova et al., 1996, EQ.16) AND DEW - SMELT=0. + SMELT=zero H=MAVAIL ! =1. if snowfrac=1 FQ=QKMS @@ -3577,8 +3577,8 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & !--- If vegfrac.ne.0. then part of falling snow can be !--- intercepted by the canopy. - DEW=0. - UMVEG=1.-vegfrac + DEW=zero + UMVEG=one-vegfrac EPOT = -FQ*(QVATM-QSG) IF (debug_print ) THEN @@ -3589,15 +3589,15 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & SNWEPR=SNWE ! check if all snow can evaporate during DT - BETA=1. + BETA=one EPDT = EPOT * RAS *DELT - IF(EPDT.gt.0. .and. SNWEPR.LE.EPDT) THEN + IF(EPDT > zero .and. SNWEPR.LE.EPDT) THEN BETA=SNWEPR/EPDT - SNWE=0. + SNWE=zero ENDIF - WETCAN=min(0.25,max(0.,(CST/SAT))**CN) - DRYCAN=1.-WETCAN + WETCAN=min(0.25_kind_phys,max(zero,(CST/SAT))**CN) + DRYCAN=one-WETCAN !************************************************************** ! TRANSF computes transpiration function @@ -3647,11 +3647,11 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & !************************************************************************ !--- RECALCULATION OF DEW USING NEW VALUE OF QSG OR TRANSP IF NO DEW - DEW=0. - ETT1=0. - PP=PATM*1.E3 + DEW=zero + ETT1=zero + PP=PATM*rhowater EPOT = -FQ*(QVATM-QSG) - IF(EPOT.GT.0.) THEN + IF(EPOT.GT.zero) THEN ! Evaporation DO K=1,NROOT TRANSP(K)=vegfrac*RAS*FQ*(QVATM-QSG) & @@ -3659,36 +3659,36 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & ETT1=ETT1-TRANSP(K) ENDDO DO k=nroot+1,nzs - transp(k)=0. + transp(k)=zero enddo ELSE ! Sublimation DEW=-EPOT DO K=1,NZS - TRANSP(K)=0. + TRANSP(K)=zero ENDDO - ETT1=0. + ETT1=zero ENDIF !-- recalculating of frozen water in soil DO K=1,NZS tln=log(tso(k)/tfrz) - if(tln.lt.0.) then + if(tln.lt.zero) then soiliqw(k)=(dqm+qmin)*(XLMELT* & - (tso(k)-tfrz)/tso(k)/9.81/psis) & - **(-1./bclh)-qmin - soiliqw(k)=max(0.,soiliqw(k)) + (tso(k)-tfrz)/tso(k)/9.81_kind_phys/psis) & + **(-one/bclh)-qmin + soiliqw(k)=max(zero,soiliqw(k)) soiliqw(k)=min(soiliqw(k),soilmois(k)) soilice(k)=(soilmois(k)-soiliqw(k))/riw !---- melting and freezing is balanced, soil ice cannot increase - if(keepfr(k).eq.1.) then + if(keepfr(k).eq.one) then soilice(k)=min(soilice(k),smfrkeep(k)) - soiliqw(k)=max(0.,soilmois(k)-soilice(k)*riw) + soiliqw(k)=max(zero,soilmois(k)-soilice(k)*riw) endif else - soilice(k)=0. + soilice(k)=zero soiliqw(k)=soilmois(k) endif ENDDO @@ -3702,9 +3702,9 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & delt,nzs,nddzs,DTDZS,DTDZS2,RIW, & zsmain,zshalf,diffu,hydro, & QSG,QVG,QCG,QCATM,QVATM,-INFWATER, & - QKMS,TRANSP,0., & - 0.,SMELT,soilice,vegfrac, & - snowfrac,1., & + QKMS,TRANSP,zero, & + zero,SMELT,soilice,vegfrac, & + snowfrac,one, & !-- soil properties DQM,QMIN,REF,KSAT,RAS,INFMAX, & !-- output @@ -3714,13 +3714,13 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & ! endif !-- Restore land-use parameters if all snow is melted - IF(SNHEI.EQ.0.) then + IF(SNHEI.EQ.zero) then tsnav=soilt-tfrz ENDIF ! 21apr2009 ! SNOM [mm] goes into the passed-in ACSNOM variable in the grid derived type - SNOM=SNOM+SMELT*DELT*1.e3 + SNOM=SNOM+SMELT*DELT*rhowater ! !--- KEEPFR is 1 when the temperature and moisture in soil !--- are both increasing. In this case soil ice should not @@ -3732,21 +3732,21 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & !--- frozen soil. do k=1,nzs - if (soilice(k).gt.0.) then + if (soilice(k).gt.zero) then if(tso(k).gt.told(k).and.soilmois(k).gt.smold(k)) then - keepfr(k)=1. + keepfr(k)=one else - keepfr(k)=0. + keepfr(k)=zero endif endif enddo !--- THE DIAGNOSTICS OF SURFACE FLUXES T3 = STBOLT*SOILTold*SOILTold*SOILTold - UPFLUX = T3 *0.5*(SOILTold+SOILT) + UPFLUX = T3 *0.5_kind_phys*(SOILTold+SOILT) XINET = EMISS*(GLW-UPFLUX) HFX=-TKMS*CP*RHO*(TABS-SOILT) & - *(P1000mb*0.00001/Patm)**ROVCP + *(P1000mb*0.00001_kind_phys/Patm)**ROVCP IF (debug_print ) THEN print *,'potential temp HFX',hfx ENDIF @@ -3755,16 +3755,16 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & print *,'abs temp HFX',hft ENDIF Q1 = - FQ*RAS* (QVATM - QSG) - CMC2MS=0. - IF (Q1.LT.0.) THEN + CMC2MS= zero + IF (Q1.LT.zero) THEN ! --- condensation - EDIR1=0. - EC1=0. - ETT1=0. + EDIR1=zero + EC1=zero + ETT1=zero ! --- condensation if(myj) then !-- moisture flux for coupling with MYJ PBL - EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*1.E3 + EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*rhowater CST= CST-EETA*DELT*vegfrac IF (debug_print ) THEN print *,'MYJ EETA cond', EETA @@ -3786,7 +3786,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & CMC2MS=CST/DELT*RAS EC1 = Q1 * WETCAN * vegfrac - CST=max(0.,CST-EC1 * DELT) + CST=max(zero,CST-EC1 * DELT) IF (debug_print ) THEN print*,'Q1,umveg,beta',Q1,umveg,beta @@ -3796,23 +3796,23 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & if(myj) then !-- moisture flux for coupling with MYJ PBL - EETA=-(QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*1.E3)*BETA + EETA=-(QKMS*RAS*(QVATM/(one+QVATM) - QSG/(one+QSG))*rhowater)*BETA IF (debug_print ) THEN print *,'MYJ EETA', EETA*XLVm,EETA ENDIF else ! myj ! to convert from m s-1 to kg m-2 s-1: *rho water=1.e3************ !-- actual moisture flux from RUC LSM - EETA = (EDIR1 + EC1 + ETT1)*1.E3 + EETA = (EDIR1 + EC1 + ETT1)*rhowater IF (debug_print ) THEN print *,'RUC LSM EETA',EETA*XLVm,EETA ENDIF endif ! myj QFX= XLVm * EETA - EETA = (EDIR1 + EC1 + ETT1)*1.E3 + EETA = (EDIR1 + EC1 + ETT1)*rhowater ENDIF S=SNFLX - sublim=Q1*1.E3 !kg m-2 s-1 + sublim=Q1*rhowater !kg m-2 s-1 ! Energy budget FLTOT=RNET-HFT-XLVm*EETA-S-SNOH-x IF (debug_print ) THEN @@ -5578,11 +5578,11 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & IF(SOILT.GT.tfrz.AND.BETA.EQ.1.AND.SNHEI.GT.0.) THEN !-- snow sublimation and melting nmelt = 1 - soiltfrac=snowfrac*tfrz+(1.-snowfrac)*SOILT + soiltfrac=snowfrac*tfrz+(one-snowfrac)*SOILT QSG=min(QSG, QSN(soiltfrac,TBQ)/PP) qvg=qsg T3 = STBOLT*TN*TN*TN - UPFLUX = T3 * 0.5*(TN + SOILTfrac) + UPFLUX = T3 * 0.5_kind_phys*(TN + SOILTfrac) XINET = EMISS*(GLW-UPFLUX) EPOT = -QKMS*(QVATM-QSG) Q1=EPOT*RAS From 94ff8a2f430a55a5848bdb2a7799bc58b41d0f2a Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Wed, 22 Mar 2023 14:18:40 +0000 Subject: [PATCH 178/380] More changes in RUC LSM related to kind_phys. --- physics/module_sf_ruclsm.F90 | 313 +++++++++++++++++------------------ 1 file changed, 156 insertions(+), 157 deletions(-) diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 653323419..16fb5ef28 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -3875,12 +3875,12 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & LOGICAL, INTENT(IN ) :: myj !--- 3-D Atmospheric variables - real (kind_phys), & + real (kind_phys), & INTENT(IN ) :: PATM, & QVATM, & QCATM !--- 2-D variables - real (kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: GLW, & GSW, & RHO, & @@ -3888,35 +3888,35 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & TKMS !--- sea ice properties - real (kind_phys), DIMENSION(1:NZS) , & + real (kind_phys), DIMENSION(1:NZS) , & INTENT(IN ) :: & tice, & rhosice, & capice, & thdifice - real (kind_phys), INTENT(IN ) :: & + real (kind_phys), INTENT(IN ) :: & CW, & XLV - real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & - ZSHALF, & - DTDZS2 + real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + ZSHALF, & + DTDZS2 - real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - real (kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ + real (kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ !--- input/output variables !-------- 3-d soil moisture and temperature - real (kind_phys), DIMENSION( 1:nzs ) , & + real (kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: TSO INTEGER, INTENT(INOUT) :: ILAND !-------- 2-d variables - real (kind_phys) , & + real (kind_phys) , & INTENT(INOUT) :: DEW, & EETA, & RHOSN, & @@ -3944,27 +3944,27 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & INTEGER, INTENT(INOUT) :: ILNB - real (kind_phys), INTENT(OUT) :: RSM, & - SNWEPRINT, & - SNHEIPRINT + real (kind_phys), INTENT(OUT) :: RSM, & + SNWEPRINT, & + SNHEIPRINT !--- Local variables INTEGER :: nzs1,nzs2,k,k1,kn,kk real (kind_phys) :: x,x1,x2,dzstop,ft,tn,denom - real (kind_phys) :: SNTH, NEWSN , & + real (kind_phys) :: SNTH, NEWSN , & TABS, T3, UPFLUX, XINET , & BETA, SNWEPR,EPDT,PP - real (kind_phys) :: CP,rovcp,G0,LV,xlvm,STBOLT,xlmelt , & + real (kind_phys) :: CP,rovcp,G0,LV,xlvm,STBOLT,xlmelt , & epot,fltot,fq,hft,q1,ras,rhoice,ci,cvw , & RIW,DELTSN,H - real (kind_phys) :: rhocsn,thdifsn, & + real (kind_phys) :: rhocsn,thdifsn, & xsn,ddzsn,x1sn,d1sn,d2sn,d9sn,r22sn real (kind_phys) :: cotsn,rhtsn,xsn1,ddzsn1,x1sn1,ftsnow,denomsn - real (kind_phys) :: fso,fsn, & + real (kind_phys) :: fso,fsn, & FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11, & FKQ,R210,AA,BB,QS1,TS1,TQ2,TX2, & TDENOM,AA1,RHCS,H1,TSOB, SNPRIM, & @@ -3977,14 +3977,14 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & real (kind_phys) :: keff, fact !----------------------------------------------------------------- - XLMELT=3.35E+5 + XLMELT=3.35E+5_kind_dbl_prec !-- heat of sublimation of water vapor XLVm=XLV+XLMELT !-- options for snow conductivity: !-- 1 - constant !-- opt 2 - Sturm et al., 1997 - keff = 0.265 + keff = 0.265_kind_phys !--- SNOW flag -- ISICE !--- DELTSN - is the threshold for splitting the snow layer into 2 layers. @@ -3995,78 +3995,78 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & !--- the top sea ice layer. SNTH is computed using snwe=0.016 m, and !--- equals 4 cm for snow density 400 kg/m^3. - DELTSN=0.05*1.e3/rhosn - snth=0.01*1.e3/rhosn + DELTSN=0.05_kind_phys*rhowater/rhosn + snth=0.01_kind_phys*rhowater/rhosn ! For 2-layer snow model when the snow depth is marginlly higher than DELTSN, ! reset DELTSN to half of snow depth. IF(SNHEI.GE.DELTSN+SNTH) THEN - if(snhei-deltsn-snth.lt.snth) deltsn=0.5*(snhei-snth) + if(snhei-deltsn-snth.lt.snth) deltsn=0.5_kind_phys*(snhei-snth) IF (debug_print ) THEN print *,'DELTSN ICE is changed,deltsn,snhei,snth', & i,j, deltsn,snhei,snth ENDIF ENDIF - RHOICE=900. - CI=RHOICE*2100. - RAS=RHO*1.E-3 - RIW=rhoice*1.e-3 - RSM=0. + RHOICE=900._kind_dbl_prec + CI=RHOICE*2100._kind_dbl_prec + RAS=RHO*1.E-3_kind_dbl_prec + RIW=rhoice*1.e-3_kind_dbl_prec + RSM=zero - XLMELT=3.35E+5 - RHOCSN=2090.* RHOSN + XLMELT=3.35E+5_kind_dbl_prec + RHOCSN=2090._kind_dbl_prec * RHOSN !18apr08 - add rhonewcsn - RHOnewCSN=2090.* RHOnewSN + RHOnewCSN=2090._kind_dbl_prec * RHOnewSN if(isncond_opt == 1) then - if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then + if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. !-- In future a better compaction scheme is needed for these areas. - thdifsn = 2.5e-6 + thdifsn = 2.5e-6_kind_phys else !-- old version thdifsn = 0.265/RHOCSN - THDIFSN = 0.265/RHOCSN + THDIFSN = 0.265_kind_phys/RHOCSN endif else !-- 07Jun19 - thermal conductivity (K_eff) from Sturm et al.(1997) !-- keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652) - fact = 1. - if(rhosn < 156. .or. (newsnow > 0. .and. rhonewsn < 156.)) then - keff = 0.023 + 0.234 * rhosn * 1.e-3 + fact = one + if(rhosn < 156._kind_phys .or. (newsnow > zero .and. rhonewsn < 156._kind_phys)) then + keff = 0.023_kind_phys + 0.234_kind_phys * rhosn * 1.e-3_kind_phys !-- fact is added by tgs based on 4 Jan 2017 testing - fact = 5. + fact = 5._kind_phys else - keff = 0.138 - 1.01 * rhosn*1.e-3 + 3.233 * rhosn**2 * 1.e-6 - fact = 2. + keff = 0.138_kind_phys - 1.01_kind_phys * rhosn*1.e-3_kind_phys + 3.233_kind_phys * rhosn**2 * 1.e-6_kind_phys + fact = 2._kind_phys endif - if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then + if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. !-- In future a better compaction scheme is needed for these areas. - thdifsn = 2.5e-6 + thdifsn = 2.5e-6_kind_phys else thdifsn = keff/rhocsn * fact endif endif - RAS=RHO*1.E-3 + RAS=RHO*1.E-3_kind_phys SOILTFRAC=SOILT - SMELT=0. - SOH=0. - SNODIF=0. - SNOH=0. - SNOHGNEW=0. - RSM = 0. - RSMFRAC = 0. - fsn=1. - fso=0. + SMELT=zero + SOH=zero + SNODIF=zero + SNOH=zero + SNOHGNEW=zero + RSM=zero + RSMFRAC=zero + fsn=one + fso=zero cvw=cw NZS1=NZS-1 @@ -4074,10 +4074,10 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & QGOLD=QSG TNOLD=SOILT - DZSTOP=1./(ZSMAIN(2)-ZSMAIN(1)) + DZSTOP=one/(ZSMAIN(2)-ZSMAIN(1)) - snweprint=0. - snheiprint=0. + snweprint=zero + snheiprint=zero prcpl=prcpms !*** DELTSN is the depth of the top layer of snow where @@ -4085,27 +4085,27 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & !*** is considered to have constant temperature - H=1. - SMELT=0. + H=one + SMELT=zero FQ=QKMS - SNHEI=SNWE*1.e3/RHOSN - SNWEPR=SNWE + SNHEI=SNWE*rhowater/RHOSN + SNWEPR=SNWE ! check if all snow can evaporate during DT - BETA=1. + BETA=one EPOT = -FQ*(QVATM-QSG) EPDT = EPOT * RAS *DELT - IF(EPDT.GT.0. .and. SNWEPR.LE.EPDT) THEN - BETA=SNWEPR/max(1.e-8,EPDT) - SNWE=0. + IF(EPDT.GT.zero .and. SNWEPR.LE.EPDT) THEN + BETA=SNWEPR/max(1.e-8_kind_phys,EPDT) + SNWE=zero ENDIF !****************************************************************************** ! COEFFICIENTS FOR THOMAS ALGORITHM FOR TSO !****************************************************************************** - cotso(1)=0. + cotso(1)=zero rhtso(1)=TSO(NZS) DO 33 K=1,NZS2 KN=NZS-K @@ -4127,19 +4127,19 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & snprim=max(snth,snhei) soilt1=tso(1) tsob=tso(1) - XSN = DELT/2./(zshalf(2)+0.5*SNPRIM) + XSN = DELT/2._kind_phys/(zshalf(2)+0.5_kind_phys*SNPRIM) DDZSN = XSN / SNPRIM X1SN = DDZSN * thdifsn X2 = DTDZS(1)*THDIFICE(1) FT = TSO(1)+X1SN*(SOILT-TSO(1)) & -X2*(TSO(1)-TSO(2)) - DENOM = 1. + X1SN + X2 -X2*cotso(NZS1) + DENOM = one + X1SN + X2 -X2*cotso(NZS1) cotso(NZS)=X1SN/DENOM rhtso(NZS)=(FT+X2*rhtso(NZS1))/DENOM cotsn=cotso(NZS) rhtsn=rhtso(NZS) !*** Average temperature of snow pack (C) - tsnav=0.5*(soilt+tso(1)) & + tsnav=0.5_kind_phys*(soilt+tso(1)) & -tfrz else @@ -4147,8 +4147,8 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & ilnb=2 snprim=deltsn tsob=soilt1 - XSN = DELT/2./(0.5*SNHEI) - XSN1= DELT/2./(zshalf(2)+0.5*(SNHEI-DELTSN)) + XSN = DELT/2._kind_phys/(0.5_kind_phys*SNHEI) + XSN1= DELT/2._kind_phys/(zshalf(2)+0.5_kind_phys*(SNHEI-DELTSN)) DDZSN = XSN / DELTSN DDZSN1 = XSN1 / (SNHEI-DELTSN) X1SN = DDZSN * thdifsn @@ -4156,7 +4156,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & X2 = DTDZS(1)*THDIFICE(1) FT = TSO(1)+X1SN1*(SOILT1-TSO(1)) & -X2*(TSO(1)-TSO(2)) - DENOM = 1. + X1SN1 + X2 - X2*cotso(NZS1) + DENOM = one + X1SN1 + X2 - X2*cotso(NZS1) cotso(nzs)=x1sn1/denom rhtso(nzs)=(ft+x2*rhtso(nzs1))/denom ftsnow = soilt1+x1sn*(soilt-soilt1) & @@ -4165,30 +4165,30 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & cotsn=x1sn/denomsn rhtsn=(ftsnow+X1SN1*rhtso(NZS))/denomsn !*** Average temperature of snow pack (C) - tsnav=0.5/snhei*((soilt+soilt1)*deltsn & + tsnav=0.5_kind_phys/snhei*((soilt+soilt1)*deltsn & +(soilt1+tso(1))*(SNHEI-DELTSN)) & -tfrz endif ENDIF - IF(SNHEI.LT.SNTH.AND.SNHEI.GT.0.) then + IF(SNHEI.LT.SNTH.AND.SNHEI.GT.zero) then !--- snow is too thin to be treated separately, therefore it !--- is combined with the first sea ice layer. snprim=SNHEI+zsmain(2) fsn=SNHEI/snprim - fso=1.-fsn + fso=one-fsn soilt1=tso(1) tsob=tso(2) - XSN = DELT/2./((zshalf(3)-zsmain(2))+0.5*snprim) + XSN = DELT/2._kind_phys/((zshalf(3)-zsmain(2))+0.5_kind_phys*snprim) DDZSN = XSN /snprim X1SN = DDZSN * (fsn*thdifsn+fso*thdifice(1)) X2=DTDZS(2)*THDIFICE(2) FT=TSO(2)+X1SN*(SOILT-TSO(2))- & X2*(TSO(2)-TSO(3)) - denom = 1. + x1sn + x2 - x2*cotso(nzs-2) + denom = one + x1sn + x2 - x2*cotso(nzs-2) cotso(nzs1) = x1sn/denom rhtso(nzs1)=(FT+X2*rhtso(NZS-2))/denom - tsnav=0.5*(soilt+tso(1)) & + tsnav=0.5_kind_phys*(soilt+tso(1)) & -tfrz cotso(nzs)=cotso(NZS1) rhtso(nzs)=rhtso(nzs1) @@ -4200,21 +4200,21 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & !--- THE HEAT BALANCE EQUATION !18apr08 nmelt is the flag for melting, and SNOH is heat of snow phase changes nmelt=0 - SNOH=0. + SNOH=zero EPOT=-QKMS*(QVATM-QSG) RHCS=CAPICE(1) - H=1. + H=one FKT=TKMS D1=cotso(NZS1) D2=rhtso(NZS1) TN=SOILT D9=THDIFICE(1)*RHCS*dzstop D10=TKMS*CP*RHO - R211=.5*CONFLX/DELT + R211=.5_kind_phys*CONFLX/DELT R21=R211*CP*RHO - R22=.5/(THDIFICE(1)*DELT*dzstop**2) - R6=EMISS *STBOLT*.5*TN**4 + R22=.5_kind_phys/(THDIFICE(1)*DELT*dzstop**2) + R6=EMISS *STBOLT*.5_kind_phys*TN**4 R7=R6/TN D11=RNET+R6 @@ -4229,20 +4229,20 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & D2SN = rhtsn endif D9SN= THDIFSN*RHOCSN / SNPRIM - R22SN = SNPRIM*SNPRIM*0.5/(THDIFSN*DELT) + R22SN = SNPRIM*SNPRIM*0.5_kind_phys/(THDIFSN*DELT) ENDIF - IF(SNHEI.LT.SNTH.AND.SNHEI.GT.0.) then + IF(SNHEI.LT.SNTH.AND.SNHEI.GT.zero) then !--- thin snow is combined with sea ice D1SN = D1 D2SN = D2 D9SN = (fsn*THDIFSN*RHOCSN+fso*THDIFICE(1)*RHCS)/ & snprim - R22SN = snprim*snprim*0.5 & + R22SN = snprim*snprim*0.5_kind_phys & /((fsn*THDIFSN+fso*THDIFICE(1))*delt) ENDIF - IF(SNHEI.eq.0.)then + IF(SNHEI.eq.zero)then !--- all snow is sublimated D9SN = D9 R22SN = R22 @@ -4252,7 +4252,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & !---- TDENOM for snow - TDENOM = D9SN*(1.-D1SN +R22SN)+D10+R21+R7 & + TDENOM = D9SN*(one-D1SN +R22SN)+D10+R21+R7 & +RAINF*CVW*PRCPMS & +RHOnewCSN*NEWSNOW/DELT @@ -4262,11 +4262,11 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & BB=(D10*TABS+R21*TN+XLVM*(QVATM* & (BETA*FKQ) & +R210*QVG)+D11+D9SN*(D2SN+R22SN*TN) & - +RAINF*CVW*PRCPMS*max(tfrz,TABS) & - + RHOnewCSN*NEWSNOW/DELT*min(tfrz,TABS) & + +RAINF*CVW*PRCPMS*max(tfrz,TABS) & + + RHOnewCSN*NEWSNOW/DELT*min(tfrz,TABS) & )/TDENOM AA1=AA - PP=PATM*1.E3 + PP=PATM*1.E3_kind_phys AA1=AA1/PP !18apr08 - the iteration start point 212 continue @@ -4282,11 +4282,11 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & !--- it is saturation over snow QVG=QS1 QSG=QS1 - QCG=0. + QCG=zero !--- SOILT - skin temperature of snow on ice SOILT=TS1 - if(nmelt==1 .and. snowfrac==1) then + if(nmelt==1 .and. snowfrac==one) then soilt = min(tfrz,soilt) endif @@ -4299,37 +4299,37 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & if(snhei.gt.DELTSN+SNTH) then !-- 2-layer snow model SOILT1=min(tfrz,rhtsn+cotsn*SOILT) - TSO(1)=min(271.4,(rhtso(NZS)+cotso(NZS)*SOILT1)) + TSO(1)=min(271.4_kind_phys,(rhtso(NZS)+cotso(NZS)*SOILT1)) tsob=soilt1 else !-- 1 layer in snow - TSO(1)=min(271.4,(rhtso(NZS)+cotso(NZS)*SOILT)) + TSO(1)=min(271.4_kind_phys,(rhtso(NZS)+cotso(NZS)*SOILT)) SOILT1=TSO(1) tsob=tso(1) endif - ELSEIF (SNHEI > 0. .and. SNHEI < SNTH) THEN + ELSEIF (SNHEI > zero .and. SNHEI < SNTH) THEN ! blended - TSO(2)=min(271.4,(rhtso(NZS1)+cotso(NZS1)*SOILT)) - tso(1)=min(271.4,(tso(2)+(soilt-tso(2))*fso)) + TSO(2)=min(271.4_kind_phys,(rhtso(NZS1)+cotso(NZS1)*SOILT)) + tso(1)=min(271.4_kind_phys,(tso(2)+(soilt-tso(2))*fso)) SOILT1=TSO(1) tsob=TSO(2) ELSE ! snow is melted - TSO(1)=min(271.4,SOILT) - SOILT1=min(271.4,SOILT) + TSO(1)=min(271.4_kind_phys,SOILT) + SOILT1=min(271.4_kind_phys,SOILT) tsob=tso(1) ENDIF !---- Final solution for TSO in sea ice - IF (SNHEI > 0. .and. SNHEI < SNTH) THEN + IF (SNHEI > zero .and. SNHEI < SNTH) THEN ! blended or snow is melted DO K=3,NZS KK=NZS-K+1 - TSO(K)=min(271.4,rhtso(KK)+cotso(KK)*TSO(K-1)) + TSO(K)=min(271.4_kind_phys,rhtso(KK)+cotso(KK)*TSO(K-1)) END DO ELSE DO K=2,NZS KK=NZS-K+1 - TSO(K)=min(271.4,rhtso(KK)+cotso(KK)*TSO(K-1)) + TSO(K)=min(271.4_kind_phys,rhtso(KK)+cotso(KK)*TSO(K-1)) END DO ENDIF !--- For thin snow layer combined with the top soil layer @@ -4348,16 +4348,16 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & IF(SOILT>tfrz .AND. BETA==one .AND. SNHEI>zero) THEN ! nmelt = 1 - soiltfrac=snowfrac*tfrz+(1.-snowfrac)*min(271.4,SOILT) + soiltfrac=snowfrac*tfrz+(1.-snowfrac)*min(271.4_kind_phys,SOILT) QSG= QSN(soiltfrac,TBQ)/PP T3 = STBOLT*TNold*TNold*TNold - UPFLUX = T3 * 0.5*(TNold+SOILTfrac) + UPFLUX = T3 * 0.5_kind_phys*(TNold+SOILTfrac) XINET = EMISS*(GLW-UPFLUX) EPOT = -QKMS*(QVATM-QSG) Q1=EPOT*RAS - IF (Q1.LE.0.) THEN + IF (Q1.LE.zero) THEN ! --- condensation DEW=-EPOT @@ -4365,7 +4365,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & EETA=QFX/XLVM ELSE ! --- evaporation - EETA = Q1 * BETA *1.E3 + EETA = Q1 * BETA * rhowater ! to convert from kg m-2 s-1 to m s-1: 1/rho water=1.e-3************ QFX= - XLVM * EETA ENDIF @@ -4395,17 +4395,17 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & print *,'RAINF*CVW*PRCPMS*(max(tfrz,TABS)-soiltfrac)', & RAINF*CVW*PRCPMS*(max(tfrz,TABS)-soiltfrac) ENDIF - SNOH=AMAX1(0._kind_phys,SNOH) + SNOH=AMAX1(zero,SNOH) !-- SMELT is speed of melting in M/S - SMELT= SNOH /XLMELT*1.E-3 + SMELT= SNOH /XLMELT*1.E-3_kind_phys SMELT=AMIN1(SMELT,SNWEPR/DELT-BETA*EPOT*RAS) - SMELT=AMAX1(0._kind_phys,SMELT) + SMELT=AMAX1(zero,SMELT) IF (debug_print ) THEN print *,'1-SMELT i,j',smelt,i,j ENDIF !18apr08 - Egglston limit - SMELT= amin1 (smelt,delt/60.* 5.6E-8*meltfactor*max(1.,(soilt-tfrz))) ! SnowMIP + SMELT= amin1 (smelt,delt/60._kind_phys* 5.6E-8_kind_phys*meltfactor*max(one,(soilt-tfrz))) ! SnowMIP IF (debug_print ) THEN print *,'2-SMELT i,j',smelt,i,j ENDIF @@ -4417,7 +4417,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & print *,'3- SMELT i,j,smelt,rr',i,j,smelt,rr ENDIF SNOHGNEW=SMELT*XLMELT*1.E3 - SNODIF=AMAX1(0.,(SNOH-SNOHGNEW)) + SNODIF=AMAX1(zero,(SNOH-SNOHGNEW)) SNOH=SNOHGNEW @@ -4428,15 +4428,15 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & ENDIF !*** From Koren et al. (1999) 13% of snow melt stays in the snow pack - rsmfrac=min(0.18,(max(0.08,snwepr/0.10*0.13))) - if(snhei > 0.01) then + rsmfrac=min(0.18_kind_phys,(max(0.08_kind_phys,snwepr/0.10_kind_phys*0.13_kind_phys))) + if(snhei > 0.01_kind_phys) then rsm=rsmfrac*smelt*delt else ! do not keep melted water if snow depth is less that 1 cm - rsm=0. + rsm=zero endif !18apr08 rsm is part of melted water that stays in snow as liquid - SMELT=AMAX1(0.,SMELT-rsm/delt) + SMELT=AMAX1(zero,SMELT-rsm/delt) IF (debug_print ) THEN print *,'4-SMELT i,j,smelt,rsm,snwepr,rsmfrac', & i,j,smelt,rsm,snwepr,rsmfrac @@ -4444,19 +4444,19 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & !-- update liquid equivalent of snow depth !-- for evaporation and snow melt - SNWE = AMAX1(0.,(SNWEPR- & + SNWE = AMAX1(zero,(SNWEPR- & (SMELT+BETA*EPOT*RAS)*DELT & ) ) soilt=soiltfrac !--- If there is no snow melting then just evaporation !--- or condensation changes SNWE ELSE - if(snhei.ne.0..and. beta == 1.) then + if(snhei > zero.and. beta == one) then EPOT=-QKMS*(QVATM-QSG) - SNWE = AMAX1(0.,(SNWEPR- & + SNWE = AMAX1(zero,(SNWEPR- & BETA*EPOT*RAS*DELT)) else - snwe = 0. + snwe = zero endif ENDIF @@ -4466,7 +4466,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & ! if(nmelt.eq.1) goto 212 ! second iteration 220 continue - if(smelt > 0..and. rsm > 0.) then + if(smelt > zero .and. rsm > zero) then if(snwe.le.rsm) then IF (debug_print ) THEN print *,'SEAICE SNWE 3.0*SNHEI_crit .and. rhosn > 250.) then + if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. !-- In future a better compaction scheme is needed for these areas. - thdifsn = 2.5e-6 + thdifsn = 2.5e-6_kind_phys else !-- old version thdifsn = 0.265/RHOCSN - THDIFSN = 0.265/RHOCSN + THDIFSN = 0.265_kind_phys/RHOCSN endif else !-- 07Jun19 - thermal conductivity (K_eff) from Sturm et al.(1997) !-- keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652) - fact = 1. - if(rhosn < 156. .or. (newsn > 0. .and. rhonewsn < 156.)) then - keff = 0.023 + 0.234 * rhosn * 1.e-3 + fact = one + if(rhosn < 156._kind_phys .or. (newsn > zero .and. rhonewsn < 156._kind_phys)) then + keff = 0.023_kind_phys + 0.234_kind_phys * rhosn * 1.e-3_kind_phys !-- fact is added by tgs based on 4 Jan 2017 testing - fact = 5. + fact = 5._kind_phys else - keff = 0.138 - 1.01 * rhosn*1.e-3 + 3.233 * rhosn**2 * 1.e-6 - fact = 2. + keff = 0.138_kind_phys - 1.01_kind_phys * rhosn*1.e-3_kind_phys + 3.233_kind_phys * rhosn**2 * 1.e-6_kind_phys + fact = 2._kind_phys endif - if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then + if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. !-- In future a better compaction scheme is needed for these areas. - thdifsn = 2.5e-6 + thdifsn = 2.5e-6_kind_phys else thdifsn = keff/rhocsn * fact endif @@ -4522,51 +4522,50 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & endif snweprint=snwe -! & !--- if VEGFRAC.ne.0. then some snow stays on the canopy !--- and should be added to SNWE for water conservation -! 4 Nov 07 +VEGFRAC*cst - snheiprint=snweprint*1.E3 / RHOSN +! +VEGFRAC*cst + snheiprint=snweprint*rhowater / RHOSN IF (debug_print ) THEN print *, 'snweprint : ',snweprint print *, 'D9SN,SOILT,TSOB : ', D9SN,SOILT,TSOB ENDIF - IF(SNHEI.GT.0.) THEN + IF(SNHEI.GT.zero) THEN if(ilnb.gt.1) then - tsnav=0.5/snhei*((soilt+soilt1)*deltsn & + tsnav=0.5_kind_phys/snhei*((soilt+soilt1)*deltsn & +(soilt1+tso(1))*(SNHEI-DELTSN)) & -tfrz else - tsnav=0.5*(soilt+tso(1)) - tfrz + tsnav=0.5_kind_phys*(soilt+tso(1)) - tfrz endif ENDIF !--- RECALCULATION OF DEW USING NEW VALUE OF QSG - DEW=0. - PP=PATM*1.E3 + DEW=zero + PP=PATM*1.E3_kind_phys QSG= QSN(SOILT,TBQ)/PP EPOT = -FQ*(QVATM-QSG) - IF(EPOT.LT.0.) THEN + IF(EPOT.LT.zero) THEN ! Sublimation DEW=-EPOT ENDIF - SNOM=SNOM+SMELT*DELT*1.e3 + SNOM=SNOM+SMELT*DELT*rhowater !--- THE DIAGNOSTICS OF SURFACE FLUXES T3 = STBOLT*TNold*TNold*TNold - UPFLUX = T3 *0.5*(SOILT+TNold) + UPFLUX = T3 *0.5_kind_phys*(SOILT+TNold) XINET = EMISS*(GLW-UPFLUX) HFT=-TKMS*CP*RHO*(TABS-SOILT) HFX=-TKMS*CP*RHO*(TABS-SOILT) & - *(P1000mb*0.00001/Patm)**ROVCP + *(P1000mb*0.00001_kind_phys/Patm)**ROVCP Q1 = - FQ*RAS* (QVATM - QSG) - IF (Q1.LT.0.) THEN + IF (Q1.LT.zero) THEN ! --- condensation if(myj) then !-- moisture flux for coupling with MYJ PBL - EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*1.E3 + EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*rhowater else ! myj !-- actual moisture flux from RUC LSM DEW=QKMS*(QVATM-QSG) @@ -4579,22 +4578,22 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & ! --- evaporation if(myj) then !-- moisture flux for coupling with MYJ PBL - EETA=-QKMS*RAS*BETA*(QVATM/(1.+QVATM) - QVG/(1.+QVG))*1.E3 + EETA=-QKMS*RAS*BETA*(QVATM/(1.+QVATM) - QVG/(1.+QVG))*rhowater else ! myj ! to convert from m s-1 to kg m-2 s-1: *rho water=1.e3************ !-- actual moisture flux from RUC LSM - EETA = Q1*BETA*1.E3 + EETA = Q1*BETA*rhowater endif ! myj QFX= XLVm * EETA - EETA = Q1*BETA*1.E3 + EETA = Q1*BETA*rhowater sublim = EETA ENDIF - icemelt=0. + icemelt=zero IF(SNHEI.GE.SNTH)then S=thdifsn*RHOCSN*(soilt-TSOB)/SNPRIM SNFLX=S - ELSEIF(SNHEI.lt.SNTH.and.SNHEI.GT.0.) then + ELSEIF(SNHEI.lt.SNTH.and.SNHEI.GT.zero) then S=(fsn*thdifsn*rhocsn+fso*thdifice(1)*rhcs)* & (soilt-TSOB)/snprim SNFLX=S @@ -4608,7 +4607,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & ENDIF ENDIF - SNHEI=SNWE *1.E3 / RHOSN + SNHEI=SNWE *rhowater / RHOSN IF (debug_print ) THEN print *,'SNHEI,SNOH',i,j,SNHEI,SNOH @@ -4639,11 +4638,11 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & ,FLTOT,RNET,HFT,XLVm*EETA,s,SNOH,icemelt,snodif,X,SOILT ENDIF !-- Restore sea-ice parameters if snow is less than threshold - IF(SNHEI.EQ.0.) then + IF(SNHEI.EQ.zero) then tsnav=soilt-tfrz - emiss=0.98 - znt=0.011 - alb=0.55 + emiss=0.98_kind_phys + znt=0.011_kind_phys + alb=0.55_kind_phys ENDIF !------------------------------------------------------------------------ From e0d3d45caf6f531656c56e860f7f61e432736b95 Mon Sep 17 00:00:00 2001 From: "Haiqin.Li" Date: Wed, 22 Mar 2023 15:34:01 +0000 Subject: [PATCH 179/380] "to address the comments and suggestions from the ccpp reviewer" --- physics/GFS_rrtmg_pre.meta | 2 +- physics/rrtmgp_aerosol_optics.meta | 2 +- physics/smoke_dust/module_smoke_plumerise.F90 | 18 +----------- physics/smoke_dust/rrfs_smoke_postpbl.F90 | 1 - physics/smoke_dust/rrfs_smoke_wrapper.F90 | 28 +++++++++++-------- 5 files changed, 20 insertions(+), 31 deletions(-) diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 782868be6..a8b549bce 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -1286,7 +1286,7 @@ kind = kind_phys intent = out [ext550] - standard_name = atmosphere_optical_thickness_3d + standard_name = aerosol_optical_depth_at_550nm long_name = 3d optical extinction for total aerosol species units = none dimensions = (horizontal_loop_extent,vertical_layer_dimension) diff --git a/physics/rrtmgp_aerosol_optics.meta b/physics/rrtmgp_aerosol_optics.meta index d33e9f08f..cc9eb1cc2 100644 --- a/physics/rrtmgp_aerosol_optics.meta +++ b/physics/rrtmgp_aerosol_optics.meta @@ -231,7 +231,7 @@ kind = kind_phys intent = out [ext550] - standard_name = atmosphere_optical_thickness_3d + standard_name = aerosol_optical_depth_at_550nm long_name = 3d optical extinction for total aerosol species units = none dimensions = (horizontal_loop_extent,vertical_layer_dimension) diff --git a/physics/smoke_dust/module_smoke_plumerise.F90 b/physics/smoke_dust/module_smoke_plumerise.F90 index 5a1a2319d..61be06181 100755 --- a/physics/smoke_dust/module_smoke_plumerise.F90 +++ b/physics/smoke_dust/module_smoke_plumerise.F90 @@ -448,20 +448,7 @@ subroutine get_fire_properties(coms,imm,iveg_ag,burnt_area,FRP,errmsg,errflg) !real(kind=kind_phys), parameter :: beta = 5.0 !ref.: Wooster et al., 2005 REAL(kind=kind_phys), parameter :: beta = 0.88 !ref.: Paugam et al., 2015 -!data heat_flux/ & RAR: not used -!--------------------------------------------------------------------- -! heat flux !IGBP Land Cover ! -! min ! max !Legend and ! reference -! kW/m^2 !description ! -!-------------------------------------------------------------------- -!30.0, 80.0, &! Tropical Forest ! igbp 2 & 4 -!30.0, 80.0, &! Boreal(kind=kind_phys) forest ! igbp 1 & 3 -!4.4, 23.0, &! cerrado/woody savanna | igbp 5 thru 9 -!3.3, 3.3 /! Grassland/cropland ! igbp 10 thru 17 -!-------------------------------------------------------------------- -!-- fire at surface -! -!coms%area = 20.e+4 ! area of burn, m^2 +! coms%area = burnt_area! area of burn, m^2 !IF ( PLUMERISE_flag == 1) THEN @@ -567,9 +554,6 @@ subroutine get_fire_properties(coms,imm,iveg_ag,burnt_area,FRP,errmsg,errflg) COMS%HEATING (3) = 2. * HINC COMS%HEATING (4) = 3. * HINC ELSE - ! RAR: I've commented out so we don't use the look-up table for heat flux - ! HINC = (COMS%HEATING (1) - heat_flux(imm-1,iveg_ag) * 1000. *0.55)/ 4. - ! COMS%HEATING (1) = heat_flux(imm-1,iveg_ag) * 1000. *0.55 + 0.1 COMS%HEATING (2) = COMS%HEATING (1)+ HINC COMS%HEATING (3) = COMS%HEATING (2)+ HINC COMS%HEATING (4) = COMS%HEATING (3)+ HINC diff --git a/physics/smoke_dust/rrfs_smoke_postpbl.F90 b/physics/smoke_dust/rrfs_smoke_postpbl.F90 index 8fbfa7a51..220284dbb 100755 --- a/physics/smoke_dust/rrfs_smoke_postpbl.F90 +++ b/physics/smoke_dust/rrfs_smoke_postpbl.F90 @@ -5,7 +5,6 @@ module rrfs_smoke_postpbl use machine , only : kind_phys - use rrfs_smoke_config implicit none diff --git a/physics/smoke_dust/rrfs_smoke_wrapper.F90 b/physics/smoke_dust/rrfs_smoke_wrapper.F90 index 530d875db..80c43360b 100755 --- a/physics/smoke_dust/rrfs_smoke_wrapper.F90 +++ b/physics/smoke_dust/rrfs_smoke_wrapper.F90 @@ -4,17 +4,23 @@ module rrfs_smoke_wrapper - use machine , only : kind_phys - use rrfs_smoke_config - use dust_data_mod - use seas_mod, only : gocart_seasalt_driver - use dust_fengsha_mod,only : gocart_dust_fengsha_driver - use plume_data_mod - use module_plumerise1 !plume_rise_mod - use module_add_emiss_burn - use coarsepm_settling_mod - use dep_dry_mod - use module_wetdep_ls + use machine , only : kind_phys + use rrfs_smoke_config, only : kemit, dust_opt, seas_opt, do_plumerise, & + addsmoke_flag, plumerisefire_frq, wetdep_ls_opt, & + drydep_opt, coarsepm_settling, aero_ind_fdb, & + dbg_opt, smoke_forecast, wetdep_ls_alpha, & + num_moist, num_chem, num_emis_seas, num_emis_dust, & + DUST_OPT_FENGSHA, p_qv, p_atm_shum, p_atm_cldq, & + p_smoke, p_dust_1, p_coarse_pm, epsilc + use dust_data_mod, only : dust_alpha, dust_gamma + use plume_data_mod, only : p_frp_std, p_frp_hr, num_frp_plume + use seas_mod, only : gocart_seasalt_driver + use dust_fengsha_mod, only : gocart_dust_fengsha_driver + use dep_dry_mod, only : dry_dep_driver + use module_wetdep_ls, only : wetdep_ls + use module_plumerise1, only : ebu_driver + use module_add_emiss_burn, only : add_emis_burn + use coarsepm_settling_mod, only : coarsepm_settling_driver implicit none From 0dbe50abdd1895954af6fcca93574c4715d31428 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Wed, 22 Mar 2023 19:39:08 +0000 Subject: [PATCH 180/380] In GFS_diag.F90 moved Trans variable from Diag DDT to GFS_diagtoscreen. Uncommented snowd_land, and removed snowd_water. --- physics/GFS_debug.F90 | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 0414a553f..f98eec824 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -699,6 +699,7 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%tdomzr ', Diag%tdomzr) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%tdomip ', Diag%tdomip) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%tdoms ', Diag%tdoms) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%trans ', Diag%trans) ! CCPP/RUC only if (Model%lsm == Model%lsm_ruc) then call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%wetness ', Sfcprop%wetness) @@ -1318,8 +1319,7 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%sigmatot ', Interstitial%sigmatot ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowc ', Interstitial%snowc ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowd_ice ', Interstitial%snowd_ice ) -! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowd_land ', Interstitial%snowd_land ) -! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowd_water ', Interstitial%snowd_water ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowd_land ', Interstitial%snowd_land ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snohf ', Interstitial%snohf ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowmt ', Interstitial%snowmt ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%stress ', Interstitial%stress ) @@ -1332,7 +1332,6 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tprcp_ice ', Interstitial%tprcp_ice ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tprcp_land ', Interstitial%tprcp_land ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tprcp_water ', Interstitial%tprcp_water ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%trans ', Interstitial%trans ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tseal ', Interstitial%tseal ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tsfa ', Interstitial%tsfa ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tsfc_water ', Interstitial%tsfc_water ) From 777637ba73974134991bee2b730791bc8cf2a893 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Wed, 22 Mar 2023 22:05:00 +0000 Subject: [PATCH 181/380] More changes related to kind_phys. Use constants from Physcons. --- physics/module_sf_ruclsm.F90 | 849 +++++++++++++++++------------------ 1 file changed, 417 insertions(+), 432 deletions(-) diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 16fb5ef28..66f4cb660 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -10,6 +10,8 @@ MODULE module_sf_ruclsm use machine , only : kind_phys, kind_dbl_prec use namelist_soilveg_ruc + use physcons, only : rhowater, con_t0c, con_hfus, con_hvap, & + con_pi, con_rv, con_g, con_csol, con_tice implicit none @@ -20,14 +22,19 @@ MODULE module_sf_ruclsm !> CONSTANT PARAMETERS !! @{ - real (kind_phys), parameter :: P1000mb = 100000._kind_dbl_prec - real (kind_phys), parameter :: xls = 2.85E6_kind_dbl_prec - real (kind_phys), parameter :: rhowater= 1000._kind_dbl_prec - real (kind_phys), parameter :: piconst = 3.1415926535897931_kind_dbl_prec - real (kind_phys), parameter :: r_v = 461.50_kind_dbl_prec - real (kind_phys), parameter :: zero = 0._kind_dbl_prec - real (kind_phys), parameter :: one = 1._kind_dbl_prec - real (kind_phys), parameter :: tfrz = 273.15_kind_dbl_prec + real (kind_phys), parameter :: tfrz = con_t0c + real (kind_phys), parameter :: xls = con_hvap + con_hfus + real (kind_phys), parameter :: piconst = con_pi + real (kind_phys), parameter :: r_v = con_rv + real (kind_phys), parameter :: grav = con_g + real (kind_phys), parameter :: sheatice = con_csol + + real (kind_phys), parameter :: rhoice = 917._kind_phys ! ice density + real (kind_phys), parameter :: sheatsn = 2090._kind_phys ! snow heat capacity + real (kind_phys), parameter :: P1000mb = 100000._kind_phys + + real (kind_phys), parameter :: zero = 0._kind_dbl_prec + real (kind_phys), parameter :: one = 1._kind_dbl_prec !-- options for snow conductivity: 1 - constant, 2 - Sturm et al.,1997 integer, parameter :: isncond_opt = 1 @@ -877,7 +884,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & smfr3d(i,k,j) = one sh2o(i,k,j) = zero keepfr3dflag(i,k,j) = zero - tso(i,k,j) = min(271.4_kind_phys,tso(i,k,j)) + tso(i,k,j) = min(con_tice,tso(i,k,j)) ENDDO ENDIF @@ -2468,7 +2475,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & TABS, T3, UPFLUX, XINET real (kind_phys) :: CP,rovcp,G0,LV,STBOLT,xlmelt,dzstop , & can,epot,fac,fltot,ft,fq,hft , & - q1,ras,rhoice,sph , & + q1,ras,sph , & trans,zn,ci,cvw,tln,tavln,pi , & DD1,CMC2MS,DRYCAN,WETCAN , & INFMAX,RIW, X @@ -2485,9 +2492,8 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & !----------------------------------------------------------------- !-- define constants - RHOICE=900._kind_phys - CI=RHOICE*2100._kind_phys - XLMELT=3.35E+5_kind_phys + CI=RHOICE*sheatice + XLMELT=con_hfus cvw=cw prcpl=prcpms @@ -2522,8 +2528,8 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & NZS1=NZS-1 NZS2=NZS-2 dzstop=one/(zsmain(2)-zsmain(1)) - RAS=RHO*1.E-3_kind_phys - RIW=rhoice*1.e-3_kind_phys + RAS=RHO*1.E-3_kind_phys ! rho/rhowater + RIW=rhoice*1.e-3_kind_phys ! rhoice/rhowater !--- Computation of volumetric content of ice in soil @@ -2532,7 +2538,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & tln=log(tso(k)/tfrz) if(tln.lt.zero) then soiliqw(k)=(dqm+qmin)*(XLMELT* & - (tso(k)-tfrz)/tso(k)/9.81_kind_phys/psis) & + (tso(k)-tfrz)/tso(k)/grav/psis) & **(-one/bclh)-qmin soiliqw(k)=max(zero,soiliqw(k)) soiliqw(k)=min(soiliqw(k),soilmois(k)) @@ -2559,7 +2565,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & if(tavln.lt.zero) then soiliqwm(k)=(dqm+qmin)*(XLMELT* & - (tav(k)-tfrz)/tav(k)/9.81_kind_phys/psis) & + (tav(k)-tfrz)/tav(k)/grav/psis) & **(-one/bclh)-qmin fwsat(k)=dqm-soiliqwm(k) lwsat(k)=soiliqwm(k)+qmin @@ -2737,7 +2743,7 @@ SUBROUTINE SOIL (debug_print,xlat,xlon, & tln=log(tso(k)/tfrz) if(tln.lt.zero) then soiliqw(k)=(dqm+qmin)*(XLMELT* & - (tso(k)-tfrz)/tso(k)/9.81_kind_phys/psis) & + (tso(k)-tfrz)/tso(k)/grav/psis) & **(-one/bclh)-qmin soiliqw(k)=max(zero,soiliqw(k)) soiliqw(k)=min(soiliqw(k),soilmois(k)) @@ -3004,7 +3010,7 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & !----------------------------------------------------------------- !-- define constants - XLMELT=3.35E+5_kind_dbl_prec + XLMELT=con_hfus cvw=cw prcpl=prcpms @@ -3077,7 +3083,7 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & !--- it is saturation over sea ice QVG=QS1 QSG=QS1 - TSO(1)=min(271.4_kind_phys,TS1) + TSO(1)=min(con_tice,TS1) QCG=zero !--- sea ice melting is not included in this simple approach !--- SOILT - skin temperature @@ -3085,7 +3091,7 @@ SUBROUTINE SICE ( debug_print,xlat,xlon, & !---- Final solution for soil temperature - TSO DO K=2,NZS KK=NZS-K+1 - TSO(K)=min(271.4_kind_phys,rhtso(KK)+cotso(KK)*TSO(K-1)) + TSO(K)=min(con_tice,rhtso(KK)+cotso(KK)*TSO(K-1)) END DO !--- CALCULATION OF DEW USING NEW VALUE OF QSG OR TRANSP IF NO DEW DEW=zero @@ -3393,7 +3399,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & BETA, SNWEPR,EPDT,PP real (kind_phys) :: CP,rovcp,G0,LV,xlvm,STBOLT,xlmelt,dzstop, & can,epot,fac,fltot,ft,fq,hft , & - q1,ras,rhoice,sph , & + q1,ras,sph , & trans,zn,ci,cvw,tln,tavln,pi , & DD1,CMC2MS,DRYCAN,WETCAN , & INFMAX,RIW,DELTSN,H,UMVEG @@ -3409,7 +3415,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & !----------------------------------------------------------------- cvw=cw - XLMELT=3.35E+5_kind_dbl_prec + XLMELT=con_hfus !-- heat of water vapor sublimation XLVm=XLV+XLMELT @@ -3441,10 +3447,9 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & ENDIF ENDIF - RHOICE=900._kind_dbl_prec - CI=RHOICE*2100._kind_dbl_prec - RAS=RHO*1.E-3_kind_dbl_prec - RIW=rhoice*1.e-3_kind_dbl_prec + CI=RHOICE*sheatice + RAS=RHO*1.E-3_kind_dbl_prec ! rho/rhowater + RIW=rhoice*1.e-3_kind_dbl_prec ! rhoice/rhowater RSM=zero DO K=1,NZS @@ -3488,7 +3493,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & tln=log(tso(k)/tfrz) if(tln.lt.zero) then soiliqw(k)=(dqm+qmin)*(XLMELT* & - (tso(k)-tfrz)/tso(k)/9.81_kind_phys/psis) & + (tso(k)-tfrz)/tso(k)/grav/psis) & **(-one/bclh)-qmin soiliqw(k)=max(zero,soiliqw(k)) soiliqw(k)=min(soiliqw(k),soilmois(k)) @@ -3497,7 +3502,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & !---- melting and freezing is balanced, soil ice cannot increase if(keepfr(k).eq.1.) then soilice(k)=min(soilice(k),smfrkeep(k)) - soiliqw(k)=max(zero,soilmois(k)-soilice(k)*rhoice*1.e-3_kind_phys) + soiliqw(k)=max(zero,soilmois(k)-soilice(k)*riw) endif else @@ -3515,7 +3520,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & if(tavln.lt.zero) then soiliqwm(k)=(dqm+qmin)*(XLMELT* & - (tav(k)-tfrz)/tav(k)/9.81_kind_phys/psis) & + (tav(k)-tfrz)/tav(k)/grav/psis) & **(-one/bclh)-qmin fwsat(k)=dqm-soiliqwm(k) lwsat(k)=soiliqwm(k)+qmin @@ -3676,7 +3681,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & tln=log(tso(k)/tfrz) if(tln.lt.zero) then soiliqw(k)=(dqm+qmin)*(XLMELT* & - (tso(k)-tfrz)/tso(k)/9.81_kind_phys/psis) & + (tso(k)-tfrz)/tso(k)/grav/psis) & **(-one/bclh)-qmin soiliqw(k)=max(zero,soiliqw(k)) soiliqw(k)=min(soiliqw(k),soilmois(k)) @@ -3957,7 +3962,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & TABS, T3, UPFLUX, XINET , & BETA, SNWEPR,EPDT,PP real (kind_phys) :: CP,rovcp,G0,LV,xlvm,STBOLT,xlmelt , & - epot,fltot,fq,hft,q1,ras,rhoice,ci,cvw , & + epot,fltot,fq,hft,q1,ras,ci,cvw , & RIW,DELTSN,H real (kind_phys) :: rhocsn,thdifsn, & @@ -3977,7 +3982,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & real (kind_phys) :: keff, fact !----------------------------------------------------------------- - XLMELT=3.35E+5_kind_dbl_prec + XLMELT=con_hfus !-- heat of sublimation of water vapor XLVm=XLV+XLMELT @@ -4008,16 +4013,15 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & ENDIF ENDIF - RHOICE=900._kind_dbl_prec - CI=RHOICE*2100._kind_dbl_prec - RAS=RHO*1.E-3_kind_dbl_prec - RIW=rhoice*1.e-3_kind_dbl_prec + CI=RHOICE*sheatice + RAS=RHO*1.E-3_kind_dbl_prec ! rho/rhowater + RIW=rhoice*1.e-3_kind_dbl_prec ! rhoice/rhowater RSM=zero - XLMELT=3.35E+5_kind_dbl_prec - RHOCSN=2090._kind_dbl_prec * RHOSN + XLMELT=con_hfus + RHOCSN=sheatsn * RHOSN !18apr08 - add rhonewcsn - RHOnewCSN=2090._kind_dbl_prec * RHOnewSN + RHOnewCSN=sheatsn * RHOnewSN if(isncond_opt == 1) then if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then @@ -4299,24 +4303,24 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & if(snhei.gt.DELTSN+SNTH) then !-- 2-layer snow model SOILT1=min(tfrz,rhtsn+cotsn*SOILT) - TSO(1)=min(271.4_kind_phys,(rhtso(NZS)+cotso(NZS)*SOILT1)) + TSO(1)=min(con_tice,(rhtso(NZS)+cotso(NZS)*SOILT1)) tsob=soilt1 else !-- 1 layer in snow - TSO(1)=min(271.4_kind_phys,(rhtso(NZS)+cotso(NZS)*SOILT)) + TSO(1)=min(con_tice,(rhtso(NZS)+cotso(NZS)*SOILT)) SOILT1=TSO(1) tsob=tso(1) endif ELSEIF (SNHEI > zero .and. SNHEI < SNTH) THEN ! blended - TSO(2)=min(271.4_kind_phys,(rhtso(NZS1)+cotso(NZS1)*SOILT)) - tso(1)=min(271.4_kind_phys,(tso(2)+(soilt-tso(2))*fso)) + TSO(2)=min(con_tice,(rhtso(NZS1)+cotso(NZS1)*SOILT)) + tso(1)=min(con_tice,(tso(2)+(soilt-tso(2))*fso)) SOILT1=TSO(1) tsob=TSO(2) ELSE ! snow is melted - TSO(1)=min(271.4_kind_phys,SOILT) - SOILT1=min(271.4_kind_phys,SOILT) + TSO(1)=min(con_tice,SOILT) + SOILT1=min(con_tice,SOILT) tsob=tso(1) ENDIF !---- Final solution for TSO in sea ice @@ -4324,12 +4328,12 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & ! blended or snow is melted DO K=3,NZS KK=NZS-K+1 - TSO(K)=min(271.4_kind_phys,rhtso(KK)+cotso(KK)*TSO(K-1)) + TSO(K)=min(con_tice,rhtso(KK)+cotso(KK)*TSO(K-1)) END DO ELSE DO K=2,NZS KK=NZS-K+1 - TSO(K)=min(271.4_kind_phys,rhtso(KK)+cotso(KK)*TSO(K-1)) + TSO(K)=min(con_tice,rhtso(KK)+cotso(KK)*TSO(K-1)) END DO ENDIF !--- For thin snow layer combined with the top soil layer @@ -4348,7 +4352,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & IF(SOILT>tfrz .AND. BETA==one .AND. SNHEI>zero) THEN ! nmelt = 1 - soiltfrac=snowfrac*tfrz+(1.-snowfrac)*min(271.4_kind_phys,SOILT) + soiltfrac=snowfrac*tfrz+(1.-snowfrac)*min(con_tice,SOILT) QSG= QSN(soiltfrac,TBQ)/PP T3 = STBOLT*TNold*TNold*TNold @@ -4482,7 +4486,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & snwe rhosn=MIN(MAX(58.8_kind_phys,XSN),500._kind_phys) - RHOCSN=2090._kind_phys* RHOSN + RHOCSN=sheatsn* RHOSN if(isncond_opt == 1) then if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then !-- some areas with large snow depth have unrealistically @@ -4726,12 +4730,12 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & real (kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS, RAINF,xlat,xlon real (kind_phys), INTENT(INOUT) :: DRYCAN,WETCAN,TRANSUM !--- 3-D Atmospheric variables - real (kind_phys), & + real (kind_phys), & INTENT(IN ) :: PATM, & QVATM, & QCATM !--- 2-D variables - real (kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: & EMISS, & RHO, & @@ -4744,17 +4748,17 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & TKMS !--- soil properties - real (kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: & BCLH, & DQM, & QMIN - real (kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: & soilres,alfa - real (kind_phys), INTENT(IN ) :: CP, & + real (kind_phys), INTENT(IN ) :: CP, & CVW, & XLV, & STBOLT, & @@ -4762,23 +4766,23 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & G0_P - real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & ZSHALF, & THDIF, & CAP - real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - real (kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ + real (kind_phys), DIMENSION(1:5001), INTENT(IN) :: TBQ !--- input/output variables !-------- 3-d soil moisture and temperature - real (kind_phys), DIMENSION( 1:nzs ) , & + real (kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: TSO !-------- 2-d variables - real (kind_phys) , & + real (kind_phys) , & INTENT(INOUT) :: & MAVAIL, & QVG, & @@ -4789,12 +4793,12 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & !--- Local variables - real (kind_phys) :: x,x1,x2,x4,dzstop,can,ft,sph , & + real (kind_phys) :: x,x1,x2,x4,dzstop,can,ft,sph , & tn,trans,umveg,denom,fex real (kind_phys) :: FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11, & - PI,H,FKQ,R210,AA,BB,PP,Q1,QS1,TS1,TQ2,TX2 , & - TDENOM + PI,H,FKQ,R210,AA,BB,PP,Q1,QS1,TS1,TQ2,TX2 , & + TDENOM real (kind_phys) :: C,CC,AA1,RHCS,H1, QGOLD @@ -4814,13 +4818,13 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & qgold=qvg do k=1,nzs - cotso(k)=0. - rhtso(k)=0. + cotso(k)=zero + rhtso(k)=zero enddo !****************************************************************************** ! COEFFICIENTS FOR THOMAS ALGORITHM FOR TSO !****************************************************************************** - cotso(1)=0. + cotso(1)=zero rhtso(1)=TSO(NZS) DO 33 K=1,NZS2 KN=NZS-K @@ -4851,13 +4855,13 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & TN=SOILT D9=THDIF(1)*RHCS*dzstop D10=TKMS*CP*RHO - R211=.5*CONFLX/DELT + R211=.5_kind_phys*CONFLX/DELT R21=R211*CP*RHO - R22=.5/(THDIF(1)*DELT*dzstop**2) - R6=EMISS *STBOLT*.5*TN**4 + R22=.5_kind_phys/(THDIF(1)*DELT*dzstop**2) + R6=EMISS *STBOLT*.5_kind_phys*TN**4 R7=R6/TN D11=RNET+R6 - TDENOM=D9*(1.-D1+R22)+D10+R21+R7 & + TDENOM=D9*(one-D1+R22)+D10+R21+R7 & +RAINF*CVW*PRCPMS FKQ=QKMS*RHO R210=R211*RHO @@ -4867,14 +4871,14 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & BB=(D10*TABS+R21*TN+XLV*(QVATM* & (FKQ*UMVEG+C) & +R210*QVG)+D11+D9*(D2+R22*TN) & - +RAINF*CVW*PRCPMS*max(tfrz,TABS) & + +RAINF*CVW*PRCPMS*max(tfrz,TABS) & )/TDENOM AA1=AA+CC - PP=PATM*1.E3 + PP=PATM*1.E3_kind_phys AA1=AA1/PP CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil,xlat,xlon) TQ2=QVATM - TX2=TQ2*(1.-H) + TX2=TQ2*(one-H) Q1=TX2+H*QS1 IF (debug_print ) THEN print *,'VILKA1 - TS1,QS1,TQ2,H,TX2,Q1',TS1,QS1,TQ2,H,TX2,Q1 @@ -4885,7 +4889,7 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & 90 QVG=QS1 QSG=QS1 TSO(1)=TS1 - QCG=max(0.,Q1-QS1) + QCG=max(zero,Q1-QS1) IF (debug_print ) THEN print *,'90 QVG,QSG,QCG,TSO(1)',QVG,QSG,QCG,TSO(1) ENDIF @@ -4909,7 +4913,7 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & ! QVG = QVATM ! endif TSO(1)=TS1 - QCG=0. + QCG=zero 200 CONTINUE IF (debug_print ) THEN print *,'200 QVG,QSG,QCG,TSO(1)',QVG,QSG,QCG,TSO(1) @@ -4929,14 +4933,14 @@ SUBROUTINE SOILTEMP( debug_print,xlat,xlon, & TSO(K)=rhtso(KK)+cotso(KK)*TSO(K-1) END DO - X= (cp*rho*r211+rhcs*zsmain(2)*0.5/delt)*(SOILT-TN) + & + X= (cp*rho*r211+rhcs*zsmain(2)*0.5_kind_phys/delt)*(SOILT-TN) + & XLV*rho*r211*(QVG-QGOLD) IF (debug_print ) THEN print*,'SOILTEMP storage, i,j,x,soilt,tn,qvg,qvgold', & i,j,x,soilt,tn,qvg,qgold print *,'TEMP term (cp*rho*r211+rhcs*zsmain(2)*0.5/delt)*(SOILT-TN)',& - (cp*rho*r211+rhcs*zsmain(2)*0.5/delt)*(SOILT-TN) + (cp*rho*r211+rhcs*zsmain(2)*0.5_kind_phys/delt)*(SOILT-TN) print *,'QV term XLV*rho*r211*(QVG-QGOLD)',XLV*rho*r211*(QVG-QGOLD) ENDIF X=X & @@ -5029,7 +5033,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & nddzs !nddzs=2*(nzs-2) INTEGER, INTENT(IN ) :: i,j,iland,isoil - real (kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS , & + real (kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS , & RAINF,NEWSNOW,DELTSN,SNTH , & TABS,TRANSUM,SNWEPR , & testptlat,testptlon , & @@ -5037,12 +5041,12 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & real :: rhonewcsn !--- 3-D Atmospheric variables - real (kind_phys), & + real (kind_phys), & INTENT(IN ) :: PATM, & QVATM, & QCATM !--- 2-D variables - real (kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: GLW, & GSW, & RHO, & @@ -5052,14 +5056,14 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & TKMS !--- soil properties - real (kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: & BCLH, & DQM, & PSIS, & QMIN - real (kind_phys), INTENT(IN ) :: CP, & + real (kind_phys), INTENT(IN ) :: CP, & ROVCP, & CVW, & STBOLT, & @@ -5067,7 +5071,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & G0_P - real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & ZSHALF, & THDIF, & CAP, & @@ -5080,12 +5084,12 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & !--- input/output variables !-------- 3-d soil moisture and temperature - real (kind_phys), DIMENSION( 1:nzs ) , & + real (kind_phys), DIMENSION( 1:nzs ) , & INTENT(INOUT) :: TSO !-------- 2-d variables - real (kind_phys) , & + real (kind_phys) , & INTENT(INOUT) :: DEW, & CST, & RHOSN, & @@ -5107,7 +5111,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & real (kind_phys), INTENT(INOUT) :: DRYCAN, WETCAN - real (kind_phys), INTENT(OUT) :: RSM, & + real (kind_phys), INTENT(OUT) :: RSM, & SNWEPRINT, & SNHEIPRINT INTEGER, INTENT(OUT) :: ilnb @@ -5116,16 +5120,16 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & INTEGER :: nzs1,nzs2,k,k1,kn,kk - real (kind_phys) :: x,x1,x2,x4,dzstop,can,ft,sph, & + real (kind_phys) :: x,x1,x2,x4,dzstop,can,ft,sph, & tn,trans,umveg,denom real (kind_phys) :: cotsn,rhtsn,xsn1,ddzsn1,x1sn1,ftsnow,denomsn - real (kind_phys) :: t3,upflux,xinet,ras, & + real (kind_phys) :: t3,upflux,xinet,ras, & xlmelt,rhocsn,thdifsn, & beta,epot,xsn,ddzsn,x1sn,d1sn,d2sn,d9sn,r22sn - real (kind_phys) :: fso,fsn, & + real (kind_phys) :: fso,fsn, & FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11, & PI,H,FKQ,R210,AA,BB,PP,Q1,QS1,TS1,TQ2,TX2, & TDENOM,C,CC,AA1,RHCS,H1, & @@ -5134,7 +5138,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & CMC2MS,TNOLD,QGOLD,SNOHGNEW real (kind_phys), DIMENSION(1:NZS) :: transp,cotso,rhtso - real (kind_phys) :: edir1, & + real (kind_phys) :: edir1, & ec1, & ett1, & eeta, & @@ -5151,91 +5155,91 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & !-- options for snow conductivity: !-- 1 - constant !-- opt 2 - Sturm et al., 1997 - keff = 0.265 + keff = 0.265_kind_phys do k=1,nzs - transp (k)=0. - cotso (k)=0. - rhtso (k)=0. + transp (k)=zero + cotso (k)=zero + rhtso (k)=zero enddo IF (debug_print ) THEN print *, 'SNOWTEMP: SNHEI,SNTH,SOILT1: ',SNHEI,SNTH,SOILT1,soilt ENDIF - XLMELT=3.35E+5 - RHOCSN=2090.* RHOSN - RHOnewCSN=2090.* RHOnewSN + XLMELT=con_hfus + RHOCSN=sheatsn* RHOSN + RHOnewCSN=sheatsn* RHOnewSN if(isncond_opt == 1) then - if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then + if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. !-- In future a better compaction scheme is needed for these areas. - thdifsn = 2.5e-6 + thdifsn = 2.5e-6_kind_phys else !-- old version thdifsn = 0.265/RHOCSN - THDIFSN = 0.265/RHOCSN + THDIFSN = 0.265_kind_phys/RHOCSN endif else !-- 07Jun19 - thermal conductivity (K_eff) from Sturm et al.(1997) !-- keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652) - fact = 1. - if(rhosn < 156. .or. (newsnow > 0. .and. rhonewsn < 156.)) then - keff = 0.023 + 0.234 * rhosn * 1.e-3 + fact = one + if(rhosn < 156._kind_phys .or. (newsnow > zero .and. rhonewsn < 156._kind_phys)) then + keff = 0.023_kind_phys + 0.234_kind_phys * rhosn * 1.e-3_kind_phys !-- fact is added by tgs based on 4 Jan 2017 testing - fact = 5. + fact = 5._kind_phys else - keff = 0.138 - 1.01 * rhosn*1.e-3 + 3.233 * rhosn**2 * 1.e-6 - fact = 2. + keff = 0.138_kind_phys - 1.01_kind_phys * rhosn*1.e-3_kind_phys + 3.233_kind_phys * rhosn**2 * 1.e-6_kind_phys + fact = 2._kind_phys if(debug_print) then print *,'SnowTemp xlat,xlon,rhosn,keff', xlat,xlon,rhosn,keff,keff/rhocsn*fact - print *,'SNOWTEMP - 0.265/rhocsn',0.265/rhocsn + print *,'SNOWTEMP - 0.265/rhocsn',0.265_kind_phys/rhocsn endif endif if ( debug_print .and. abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2) then print *,'SNOWTEMP - xlat,xlon,newsnow,rhonewsn,rhosn,fact,keff',xlat,xlon,newsnow, rhonewsn,rhosn,fact,keff endif - if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then + if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. !-- In future a better compaction scheme is needed for these areas. - thdifsn = 2.5e-6 + thdifsn = 2.5e-6_kind_phys else thdifsn = keff/rhocsn * fact endif if (debug_print .and. abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2) then print *,'SNOWTEMP - thdifsn',xlat,xlon,thdifsn - print *,'SNOWTEMP - 0.265/rhocsn',0.265/rhocsn + print *,'SNOWTEMP - 0.265/rhocsn',0.265_kind_phys/rhocsn endif endif - RAS=RHO*1.E-3 + RAS=RHO*1.E-3_kind_phys SOILTFRAC=SOILT - SMELT=0. - SOH=0. - SMELTG=0. - SNOHG=0. - SNODIF=0. - RSM = 0. - RSMFRAC = 0. - fsn=1. - fso=0. + SMELT=zero + SOH=zero + SMELTG=zero + SNOHG=zero + SNODIF=zero + RSM = zero + RSMFRAC = zero + fsn=one + fso=zero NZS1=NZS-1 NZS2=NZS-2 QGOLD=QVG - DZSTOP=1./(ZSMAIN(2)-ZSMAIN(1)) + DZSTOP=one/(ZSMAIN(2)-ZSMAIN(1)) !****************************************************************************** ! COEFFICIENTS FOR THOMAS ALGORITHM FOR TSO !****************************************************************************** - cotso(1)=0. + cotso(1)=zero rhtso(1)=TSO(NZS) DO 33 K=1,NZS2 KN=NZS-K @@ -5260,20 +5264,19 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & snprim=max(snth,snhei) tsob=tso(1) soilt1=tso(1) - XSN = DELT/2./(zshalf(2)+0.5*SNPRIM) + XSN = DELT/2._kind_phys/(zshalf(2)+0.5_kind_phys*SNPRIM) DDZSN = XSN / SNPRIM X1SN = DDZSN * thdifsn X2 = DTDZS(1)*THDIF(1) FT = TSO(1)+X1SN*(SOILT-TSO(1)) & -X2*(TSO(1)-TSO(2)) - DENOM = 1. + X1SN + X2 -X2*cotso(NZS1) + DENOM = one + X1SN + X2 -X2*cotso(NZS1) cotso(NZS)=X1SN/DENOM rhtso(NZS)=(FT+X2*rhtso(NZS1))/DENOM cotsn=cotso(NZS) rhtsn=rhtso(NZS) !*** Average temperature of snow pack (C) - tsnav=min(0.,0.5*(soilt+tso(1)) & - -tfrz) + tsnav=min(zero,0.5_kind_phys*(soilt+tso(1))-tfrz) else !-- 2 layers in snow, SOILT1 is temperasture at DELTSN depth @@ -5283,8 +5286,8 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & ilnb=2 snprim=deltsn tsob=soilt1 - XSN = DELT/2./(0.5*deltsn) - XSN1= DELT/2./(zshalf(2)+0.5*(SNHEI-DELTSN)) + XSN = DELT/2._kind_phys/(0.5_kind_phys*deltsn) + XSN1= DELT/2._kind_phys/(zshalf(2)+0.5_kind_phys*(SNHEI-DELTSN)) DDZSN = XSN / DELTSN DDZSN1 = XSN1 / (SNHEI-DELTSN) X1SN = DDZSN * thdifsn @@ -5297,33 +5300,33 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & rhtso(nzs)=(ft+x2*rhtso(nzs1))/denom ftsnow = soilt1+x1sn*(soilt-soilt1) & -x1sn1*(soilt1-tso(1)) - denomsn = 1. + X1SN + X1SN1 - X1SN1*cotso(NZS) + denomsn = one + X1SN + X1SN1 - X1SN1*cotso(NZS) cotsn=x1sn/denomsn rhtsn=(ftsnow+X1SN1*rhtso(NZS))/denomsn !*** Average temperature of snow pack (C) - tsnav=min(0.,0.5/snhei*((soilt+soilt1)*deltsn & + tsnav=min(zero,0.5_kind_phys/snhei*((soilt+soilt1)*deltsn & +(soilt1+tso(1))*(SNHEI-DELTSN)) & -tfrz) endif ENDIF - IF(SNHEI.LT.SNTH.AND.SNHEI.GT.0.) then + IF(SNHEI.LT.SNTH.AND.SNHEI.GT.zero) then !--- snow is too thin to be treated separately, therefore it !--- is combined with the first soil layer. snprim=SNHEI+zsmain(2) fsn=SNHEI/snprim - fso=1.-fsn + fso=one-fsn soilt1=tso(1) tsob=tso(2) - XSN = DELT/2./((zshalf(3)-zsmain(2))+0.5*snprim) + XSN = DELT/2._kind_phys/((zshalf(3)-zsmain(2))+0.5_kind_phys*snprim) DDZSN = XSN /snprim X1SN = DDZSN * (fsn*thdifsn+fso*thdif(1)) X2=DTDZS(2)*THDIF(2) FT=TSO(2)+X1SN*(SOILT-TSO(2))- & X2*(TSO(2)-TSO(3)) - denom = 1. + x1sn + x2 - x2*cotso(nzs-2) + denom = one + x1sn + x2 - x2*cotso(nzs-2) cotso(nzs1) = x1sn/denom rhtso(nzs1)=(FT+X2*rhtso(NZS-2))/denom - tsnav=min(0.,0.5*(soilt+tso(1)) & + tsnav=min(zero,0.5_kind_phys*(soilt+tso(1)) & -tfrz) cotso(NZS)=cotso(nzs1) rhtso(NZS)=rhtso(nzs1) @@ -5336,25 +5339,25 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & !--- THE HEAT BALANCE EQUATION (Smirnova et al. 1996, EQ. 21,26) !18apr08 nmelt is the flag for melting, and SNOH is heat of snow phase changes nmelt=0 - SNOH=0. + SNOH=zero - ETT1=0. + ETT1=zero EPOT=-QKMS*(QVATM-QGOLD) RHCS=CAP(1) H=MAVAIL !1. TRANS=TRANSUM*DRYCAN/ZSHALF(NROOT+1) CAN=WETCAN+TRANS - UMVEG=1.-VEGFRAC + UMVEG=one-VEGFRAC FKT=TKMS D1=cotso(NZS1) D2=rhtso(NZS1) TN=SOILT D9=THDIF(1)*RHCS*dzstop D10=TKMS*CP*RHO - R211=.5*CONFLX/DELT + R211=.5_kind_phys*CONFLX/DELT R21=R211*CP*RHO - R22=.5/(THDIF(1)*DELT*dzstop**2) - R6=EMISS *STBOLT*.5*TN**4 + R22=.5_kind_phys/(THDIF(1)*DELT*dzstop**2) + R6=EMISS *STBOLT*.5_kind_phys*TN**4 R7=R6/TN D11=RNET+R6 @@ -5375,25 +5378,25 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & ENDIF endif D9SN= THDIFSN*RHOCSN / SNPRIM - R22SN = SNPRIM*SNPRIM*0.5/(THDIFSN*DELT) + R22SN = SNPRIM*SNPRIM*0.5_kind_phys/(THDIFSN*DELT) IF (debug_print ) THEN print *,'1 or 2 layers D9sn,R22sn',d9sn,r22sn ENDIF ENDIF - IF(SNHEI.LT.SNTH.AND.SNHEI.GT.0.) then + IF(SNHEI.LT.SNTH.AND.SNHEI.GT.zero) then !--- thin snow is combined with soil D1SN = D1 D2SN = D2 D9SN = (fsn*THDIFSN*RHOCSN+fso*THDIF(1)*RHCS)/ & snprim - R22SN = snprim*snprim*0.5 & + R22SN = snprim*snprim*0.5_kind_phys & /((fsn*THDIFSN+fso*THDIF(1))*delt) IF (debug_print ) THEN print *,' Combined D9SN,R22SN,D1SN,D2SN: ',D9SN,R22SN,D1SN,D2SN ENDIF ENDIF - IF(SNHEI.eq.0.)then + IF(SNHEI.eq.zero)then !--- all snow is sublimated D9SN = D9 R22SN = R22 @@ -5410,7 +5413,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & 212 continue !---- TDENOM for snow - TDENOM = D9SN*(1.-D1SN +R22SN)+D10+R21+R7 & + TDENOM = D9SN*(one-D1SN +R22SN)+D10+R21+R7 & +RAINF*CVW*PRCPMS & +RHOnewCSN*NEWSNOW/DELT @@ -5422,11 +5425,11 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & BB=(D10*TABS+R21*TN+XLVM*(QVATM* & (BETA*FKQ*UMVEG+C) & +R210*QGOLD)+D11+D9SN*(D2SN+R22SN*TN) & - +RAINF*CVW*PRCPMS*max(tfrz,TABS) & - + RHOnewCSN*NEWSNOW/DELT*min(tfrz,TABS) & + +RAINF*CVW*PRCPMS*max(tfrz,TABS) & + + RHOnewCSN*NEWSNOW/DELT*min(tfrz,TABS) & )/TDENOM AA1=AA+CC - PP=PATM*1.E3 + PP=PATM*1.E3_kind_phys AA1=AA1/PP BB=BB-SNOH/TDENOM @@ -5438,7 +5441,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & ENDIF CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil,xlat,xlon) TQ2=QVATM - TX2=TQ2*(1.-H) + TX2=TQ2*(one-H) Q1=TX2+H*QS1 IF (debug_print ) THEN !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then @@ -5449,7 +5452,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & !--- if saturation - goto 90 90 QVG=QS1 QSG=QS1 - QCG=max(0.,Q1-QS1) + QCG=max(zero,Q1-QS1) IF (debug_print ) THEN print *,'90 QVG,QSG,QCG,TSO(1)',QVG,QSG,QCG,TSO(1) ENDIF @@ -5465,33 +5468,15 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & IF(Q1.GT.QS1) GOTO 90 QSG=QS1 QVG=Q1 - QCG=0. + QCG=zero IF (debug_print ) THEN print *,'No Saturation QVG,QSG,QCG,TSO(1)',QVG,QSG,QCG,TSO(1) ENDIF 200 CONTINUE -if(1==2) then - if(qvatm > QSG .and. iter==0) then -!condensation regime - IF (debug_print ) THEN - print *,'SNOW turn off canopy evaporation and transpiration' - print *,' QVATM,QVG,QSG,TS1',QVATM,QVG,QSG,TS1 - print *,'before can, umveg ',can, umveg - ENDIF - iter=1 - endif - - IF (debug_print ) THEN - if(iter==1) then - print *,'SNOW - QVATM,QVG,QSG,QCG,TS1',QVATM,QVG,QSG,QCG,TS1 - endif - ENDIF -endif ! 1==2 - !--- SOILT - skin temperature SOILT=TS1 - if(nmelt==1 .and. snowfrac==1 .and. snwe > 0. .and. SOILT > tfrz) then + if(nmelt==1 .and. snowfrac==one .and. snwe > zero .and. SOILT > tfrz) then !--7feb22 on the second iteration when SNOH is known and snwe > 0. after melting, !-- check if the snow skin temperature is = 0. .and. SNHEI < SNTH) THEN + ELSEIF (SNHEI > zero .and. SNHEI < SNTH) THEN ! blended TSO(2)=rhtso(NZS1)+cotso(NZS1)*SOILT tso(1)=(tso(2)+(soilt-tso(2))*fso) @@ -5533,7 +5518,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & SOILT1=SOILT tsob=TSO(1) ENDIF - if(nmelt==1.and.snowfrac==1) then + if(nmelt==1.and.snowfrac==one) then !-- second iteration with full snow cover SOILT1= min(tfrz,SOILT1) TSO(1)= min(tfrz,TSO(1)) @@ -5541,7 +5526,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & endif !---- Final solution for TSO - IF (SNHEI > 0. .and. SNHEI < SNTH) THEN + IF (SNHEI > zero .and. SNHEI < SNTH) THEN ! blended or snow is melted DO K=3,NZS KK=NZS-K+1 @@ -5574,7 +5559,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & !--- IF SOILT > tfrz F then melting of snow can happen ! if all snow can evaporate (beta<1), then there is nothing to melt - IF(SOILT.GT.tfrz.AND.BETA.EQ.1.AND.SNHEI.GT.0.) THEN + IF(SOILT > tfrz.AND.BETA==one.AND.SNHEI>zero) THEN !-- snow sublimation and melting nmelt = 1 soiltfrac=snowfrac*tfrz+(one-snowfrac)*SOILT @@ -5610,7 +5595,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & EDIR1 = Q1*UMVEG * BETA EC1 = Q1 * WETCAN * vegfrac CMC2MS=CST/DELT*RAS - EETA = (EDIR1 + EC1 + ETT1)*1.E3 + EETA = (EDIR1 + EC1 + ETT1)*rhowater ! to convert from kg m-2 s-1 to m s-1: 1/rho water=1.e-3************ QFX= XLVM * EETA ENDIF @@ -5641,17 +5626,17 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & +RAINF*CVW*PRCPMS*(max(tfrz,TABS)-soiltfrac) SNOH=AMAX1(0.,SNOH) !-- SMELT is speed of melting in M/S - SMELT= SNOH /XLMELT*1.E-3 + SMELT= SNOH /XLMELT*1.E-3_kind_phys IF (debug_print ) THEN !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then print *,'1- SMELT',smelt,snoh,xlat,xlon ENDIF - IF(EPOT.gt.0. .and. SNWEPR.LE.EPOT*RAS*DELT) THEN + IF(EPOT.gt.zero .and. SNWEPR.LE.EPOT*RAS*DELT) THEN !-- all snow can evaporate BETA=SNWEPR/(EPOT*RAS*DELT) - SMELT=AMAX1(0.,AMIN1(SMELT,SNWEPR/DELT-BETA*EPOT*RAS)) - SNWE=0. + SMELT=AMAX1(zero,AMIN1(SMELT,SNWEPR/DELT-BETA*EPOT*RAS)) + SNWE=zero IF (debug_print ) THEN !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then print *,'2- SMELT',xlat,xlon,snwe,smelt,rhonewsn,xlat,xlon @@ -5662,8 +5647,8 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & !18apr08 - Egglston limit !-- 22apr22 Do not limit snow melting for hail (rhonewsn > 450), or dense snow !-- (rhosn > 350.) with very warm surface temperatures (>10C) - if( (rhosn < 350. .or. (newsnow > 0. .and. rhonewsn < 450.)) .and. soilt < 283. ) then - SMELT= amin1 (smelt, delt/60.*5.6E-8*meltfactor*max(1.,(soilt-tfrz))) + if( (rhosn < 350._kind_phys .or. (newsnow > zero .and. rhonewsn < 450._kind_phys)) .and. soilt < 283._kind_phys ) then + SMELT= amin1 (smelt, delt/60._kind_phys*5.6E-8_kind_phys*meltfactor*max(one,(soilt-tfrz))) IF (debug_print ) THEN !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then print *,'3- SMELT',xlat,xlon,smelt,rhosn,rhonewsn,xlat,xlon @@ -5671,18 +5656,18 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & endif ! rr - potential melting - rr=max(0.,SNWEPR/delt-BETA*EPOT*RAS) + rr=max(zero,SNWEPR/delt-BETA*EPOT*RAS) if(smelt > rr) then SMELT = min(SMELT,rr) - SNWE = 0. + SNWE = zero IF (debug_print ) THEN !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then print *,'4- SMELT i,j,smelt,rr',xlat,xlon,smelt,rr ENDIF endif 88 continue - SNOHGNEW=SMELT*XLMELT*1.E3 - SNODIF=AMAX1(0.,(SNOH-SNOHGNEW)) + SNOHGNEW=SMELT*XLMELT*rhowater + SNODIF=AMAX1(zero,(SNOH-SNOHGNEW)) SNOH=SNOHGNEW IF (debug_print ) THEN @@ -5691,19 +5676,19 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & print *,' xlat, xlon', xlat, xlon ENDIF - IF( smelt > 0.) then + IF( smelt > zero) then !*** From Koren et al. (1999) 13% of snow melt stays in the snow pack - rsmfrac=min(0.18,(max(0.08,snwepr/0.10*0.13))) - if(snhei > 0.01 .and. rhosn < 350.) then + rsmfrac=min(0.18_kind_phys,(max(0.08_kind_phys,snwepr/0.10_kind_phys*0.13_kind_phys))) + if(snhei > 0.01_kind_phys .and. rhosn < 350._kind_phys) then rsm=min(snwe,rsmfrac*smelt*delt) else ! do not keep melted water if snow depth is less that 1 cm ! or if snow is dense - rsm=0. + rsm=zero endif !18apr08 rsm is part of melted water that stays in snow as liquid - if(rsm > 0.) then - SMELT=max(0.,SMELT-rsm/delt) + if(rsm > zero) then + SMELT=max(zero,SMELT-rsm/delt) IF (debug_print ) THEN !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then print *,'5- SMELT i,j,smelt,rsm,snwepr,rsmfrac', & @@ -5716,8 +5701,8 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & !-- update of liquid equivalent of snow depth !-- due to evaporation and snow melt - if(snwe > 0.) then - SNWE = AMAX1(0.,(SNWEPR- & + if(snwe > zero) then + SNWE = AMAX1(zero,(SNWEPR- & (SMELT+BETA*EPOT*RAS)*DELT & ) ) IF (debug_print ) THEN @@ -5735,13 +5720,13 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & !-- NO MELTING, only sublimation !--- If there is no snow melting then just evaporation !--- or condensation changes SNWE - if(snhei.ne.0..and. beta == 1.) then + if(snhei.ne.zero .and. beta == one) then EPOT=-QKMS*(QVATM-QSG) - SNWE = AMAX1(0.,(SNWEPR- & + SNWE = AMAX1(zero,(SNWEPR- & BETA*EPOT*RAS*DELT)) else !-- all snow is sublibated - snwe = 0. + snwe = zero endif ENDIF @@ -5751,7 +5736,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & if(nmelt.eq.1) goto 212 ! second interation 220 continue - if(smelt.gt.0..and.rsm.gt.0.) then + if(smelt > zero .and. rsm > zero) then if(snwe.le.rsm) then IF ( debug_print ) THEN print *,'SNWE 3.0*SNHEI_crit .and. rhosn > 250.) then + if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. !-- In future a better compaction scheme is needed for these areas. - thdifsn = 2.5e-6 + thdifsn = 2.5e-6_kind_phys else !-- old version thdifsn = 0.265/RHOCSN - THDIFSN = 0.265/RHOCSN + THDIFSN = 0.265_kind_phys/RHOCSN endif else !-- 07Jun19 - thermal conductivity (K_eff) from Sturm et al.(1997) !-- keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652) - fact = 1. - if(rhosn < 156. .or. (newsnow > 0. .and. rhonewsn < 156.)) then - keff = 0.023 + 0.234 * rhosn * 1.e-3 + fact = one + if(rhosn < 156._kind_phys .or. (newsnow > zero .and. rhonewsn < 156._kind_phys)) then + keff = 0.023_kind_phys + 0.234_kind_phys * rhosn * 1.e-3_kind_phys !-- fact is added by tgs based on 4 Jan 2017 testing - fact = 5. + fact = 5._kind_phys else - keff = 0.138 - 1.01 * rhosn*1.e-3 + 3.233 * rhosn**2 * 1.e-6 - fact = 2. + keff = 0.138_kind_phys - 1.01_kind_phys * rhosn*1.e-3_kind_phys + 3.233_kind_phys * rhosn**2 * 1.e-6_kind_phys + fact = 2._kind_phys if(debug_print) then print *,'End SNOWTEMP - xlat,xlon,rhosn,keff',xlat,xlon,rhosn,keff print *,'End SNOWTEMP - 0.265/rhocsn',0.265/rhocsn @@ -5799,12 +5784,12 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & xlat,xlon,newsnow, rhonewsn,rhosn,fact,keff,keff/rhocsn*fact endif - if(newsnow <= 0. .and. snhei > 3.0*SNHEI_crit .and. rhosn > 250.) then + if(newsnow <= zero .and. snhei > 3.0_kind_phys*SNHEI_crit .and. rhosn > 250._kind_phys) then !-- some areas with large snow depth have unrealistically !-- low snow density (in the Rockie's with snow depth > 1 m). !-- Based on Sturm et al. the 2.5e-6 is typical for hard snow slabs. !-- In future a better compaction scheme is needed for these areas. - thdifsn = 2.5e-6 + thdifsn = 2.5e-6_kind_phys else thdifsn = keff/rhocsn * fact endif @@ -5822,7 +5807,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & S=thdifsn*RHOCSN*(soilt-TSOB)/SNPRIM SNFLX=S S=D9*(tso(1)-tso(2)) - ELSEIF(SNHEI.lt.SNTH.and.SNHEI.GT.0.) then + ELSEIF(SNHEI.lt.SNTH.and.SNHEI.GT.zero) then S=(fsn*thdifsn*rhocsn+fso*thdif(1)*rhcs)* & (soilt-TSOB)/snprim SNFLX=S @@ -5834,7 +5819,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & ENDIF !-- Update snow depth after melting at the interface with the atmosphere - SNHEI=SNWE *1.E3 / RHOSN + SNHEI=SNWE * rhowater / RHOSN !-- If ground surface temperature !-- is above freezing snow can melt from the bottom at the interface with soild. The following @@ -5845,7 +5830,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & print *,'snhei,snwe,rhosn,snowfr',snhei,snwe,rhosn,snowfrac,xlat,xlon endif - IF(TSO(1).GT.tfrz .and. snhei > 0.) THEN + IF(TSO(1).GT.tfrz .and. snhei > zero) THEN !-- melting at the soil/snow interface if (snhei.GT.deltsn+snth) then hsn = snhei - deltsn @@ -5859,41 +5844,41 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & hsn = snhei endif - soiltfrac=snowfrac*tfrz+(1.-snowfrac)*TSO(1) + soiltfrac=snowfrac*tfrz+(one-snowfrac)*TSO(1) SNOHG=(TSO(1)-soiltfrac)*(cap(1)*zshalf(2)+ & - RHOCSN*0.5*hsn) / DELT - SNOHG=AMAX1(0.,SNOHG) - SNODIF=0. - SMELTG=SNOHG/XLMELT*1.E-3 + RHOCSN*0.5_kind_phys*hsn) / DELT + SNOHG=AMAX1(zero,SNOHG) + SNODIF=zero + SMELTG=SNOHG/XLMELT*1.E-3_kind_phys IF (debug_print ) THEN !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then print *,' SMELTG =',smeltg,xlat,xlon endif ! Egglston - empirical limit on snow melt from the bottom of snow pack !9jun22-- the next line excludeis cases of summer hail from snowmelt limiting - if( (rhosn < 350. .or. (newsnow > 0. .and. rhonewsn < 450.)) .and. soilt < 283. ) then - SMELT=AMIN1(SMELTG, 5.8e-9) + if( (rhosn < 350._kind_phys .or. (newsnow > zero .and. rhonewsn < 450._kind_phys)) .and. soilt < 283._kind_phys ) then + SMELT=AMIN1(SMELTG, 5.8e-9_kind_phys) endif ! rr - potential melting rr=SNWE/delt SMELTG=AMIN1(SMELTG, rr) - SNOHGNEW=SMELTG*XLMELT*1.e3 - SNODIF=AMAX1(0.,(SNOHG-SNOHGNEW)) + SNOHGNEW=SMELTG*XLMELT*rhowater + SNODIF=AMAX1(zero,(SNOHG-SNOHGNEW)) IF (debug_print ) THEN !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then print *,'TSO(1),soiltfrac,snowfrac,smeltg,SNODIF',TSO(1),soiltfrac,snowfrac,smeltg,SNODIF print *,' xlat, xlon', xlat, xlon ENDIF - snwe=max(0.,snwe-smeltg*delt) - SNHEI=SNWE *1.E3 / RHOSN + snwe=max(zero,snwe-smeltg*delt) + SNHEI=SNWE * rhowater / RHOSN !-- add up all snow melt SMELT = SMELT + SMELTG - if(snhei > 0.) TSO(1) = soiltfrac + if(snhei > zero) TSO(1) = soiltfrac IF (debug_print ) THEN !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then @@ -5902,14 +5887,14 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & print *,'TSO(1),soiltfrac,snowfrac,smeltg,SNODIF',TSO(1),soiltfrac,snowfrac,smeltg,SNODIF print *,'Melt from the bottom snwe,snhei,snoh',snwe,snhei,snoh print *,' Final TSO ',tso - if (snhei==0.) & + if (snhei==zero) & print *,'Snow is all melted on the warm ground' ENDIF ENDIF ! melt on snow/soil interface snweprint=snwe - snheiprint=snweprint*1.E3 / RHOSN + snheiprint=snweprint*rhowater / RHOSN X= (R21+D9SN*R22SN)*(soilt-TN) + & XLVM*R210*(QSG-QGOLD) @@ -5923,7 +5908,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & X=X & ! "heat" from snow and rain - -RHOnewCSN*NEWSNOW/DELT*(min(tfrz,TABS)-SOILT) & + -RHOnewCSN*NEWSNOW/DELT*(min(tfrz,TABS)-SOILT) & -RAINF*CVW*PRCPMS*(max(tfrz,TABS)-SOILT) IF (debug_print ) THEN print *,'x=',x @@ -5931,16 +5916,16 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & print *,'SNFLX=',snflx ENDIF - IF(SNHEI.GT.0.) THEN + IF(SNHEI.GT.zero) THEN if(ilnb.gt.1) then - tsnav=min(0.,0.5/snhei*((soilt+soilt1)*deltsn & - +(soilt1+tso(1))*(SNHEI-DELTSN)) & + tsnav=min(zero,0.5_kind_phys/snhei*((soilt+soilt1)*deltsn & + +(soilt1+tso(1))*(SNHEI-DELTSN)) & -tfrz) else - tsnav=min(0.,0.5*(soilt+tso(1)) - tfrz) + tsnav=min(zero,0.5_kind_phys*(soilt+tso(1)) - tfrz) endif ELSE - tsnav= min(0.,soilt - tfrz) + tsnav= min(zero,soilt - tfrz) ENDIF !------------------------------------------------------------------------ @@ -6008,7 +5993,7 @@ SUBROUTINE SOILMOIST ( debug_print, & ! input variables - real (kind_phys), DIMENSION(1:NZS), INTENT(IN ) :: ZSMAIN, & + real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & ZSHALF, & DIFFU, & HYDRO, & @@ -6018,18 +6003,17 @@ SUBROUTINE SOILMOIST ( debug_print, & real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - real (kind_phys), INTENT(IN ) :: QSG,QVG,QCG,QCATM,QVATM, & + real (kind_phys), INTENT(IN ) :: QSG,QVG,QCG,QCATM,QVATM, & QKMS,VEGFRAC,DRIP,PRCP , & DEW,SMELT,SNOWFRAC , & DQM,QMIN,REF,KSAT,RAS,RIW,SOILRES ! output - real (kind_phys), DIMENSION( 1:nzs ) , & - - INTENT(INOUT) :: SOILMOIS,SOILIQW - - real (kind_phys), INTENT(INOUT) :: MAVAIL,RUNOFF,RUNOFF2,INFILTRP, & + real (kind_phys), DIMENSION( 1:nzs ) , & + INTENT(INOUT) :: SOILMOIS,SOILIQW + + real (kind_phys), INTENT(INOUT) :: MAVAIL,RUNOFF,RUNOFF2,INFILTRP, & INFMAX ! local variables @@ -6055,16 +6039,16 @@ SUBROUTINE SOILMOIST ( debug_print, & 118 format(6(10Pf23.19)) do k=1,nzs - cosmc(k)=0. - rhsmc(k)=0. + cosmc(k)=zero + rhsmc(k)=zero enddo DID=(ZSMAIN(NZS)-ZSHALF(NZS)) X1=ZSMAIN(NZS)-ZSMAIN(NZS1) - DENOM=(1.+DIFFU(nzs1)/X1/DID*DELT+HYDRO(NZS)/(2.*DID)*DELT) - COSMC(1)=DELT*(DIFFU(nzs1)/DID/X1 & - +HYDRO(NZS1)/2./DID)/DENOM + DENOM=(one+DIFFU(nzs1)/X1/DID*DELT+HYDRO(NZS)/(2._kind_phys*DID)*DELT) + COSMC(1)=DELT*(DIFFU(nzs1)/DID/X1 & + +HYDRO(NZS1)/2._kind_phys/DID)/DENOM RHSMC(1)=(SOILMOIS(NZS)+TRANSP(NZS)*DELT/ & DID)/DENOM @@ -6073,13 +6057,13 @@ SUBROUTINE SOILMOIST ( debug_print, & ! So far - no interaction with the water table. DENOM=1.+DIFFU(nzs1)/X1/DID*DELT - COSMC(1)=DELT*(DIFFU(nzs1)/DID/X1 & + COSMC(1)=DELT*(DIFFU(nzs1)/DID/X1 & +HYDRO(NZS1)/DID)/DENOM - RHSMC(1)=(SOILMOIS(NZS)-HYDRO(NZS)*DELT/DID*soilmois(nzs) & + RHSMC(1)=(SOILMOIS(NZS)-HYDRO(NZS)*DELT/DID*soilmois(nzs) & +TRANSP(NZS)*DELT/DID)/DENOM - COSMC(1)=0. + COSMC(1)=zero RHSMC(1)=SOILMOIS(NZS) ! DO K=1,NZS2 @@ -6089,7 +6073,7 @@ SUBROUTINE SOILMOIST ( debug_print, & X2=2.*DTDZS(K1+1)*DIFFU(KN) Q4=X4+HYDRO(KN-1)*DTDZS2(KN-1) Q2=X2-HYDRO(KN+1)*DTDZS2(KN-1) - DENOM=1.+X2+X4-Q2*COSMC(K) + DENOM=one+X2+X4-Q2*COSMC(K) COSMC(K+1)=Q4/DENOM IF (debug_print ) THEN print *,'q2,soilmois(kn),DIFFU(KN),x2,HYDRO(KN+1),DTDZS2(KN-1),kn,k' & @@ -6104,16 +6088,16 @@ SUBROUTINE SOILMOIST ( debug_print, & ! --- MOISTURE BALANCE BEGINS HERE TRANS=TRANSP(1) - UMVEG=(1.-VEGFRAC)*soilres + UMVEG=(one-VEGFRAC)*soilres - RUNOFF=0. - RUNOFF2=0. + RUNOFF=zero + RUNOFF2=zero DZS=ZSMAIN(2) R1=COSMC(NZS1) R2= RHSMC(NZS1) R3=DIFFU(1)/DZS - R4=R3+HYDRO(1)*.5 - R5=R3-HYDRO(2)*.5 + R4=R3+HYDRO(1)*.5_kind_phys + R5=R3-HYDRO(2)*.5_kind_phys R6=QKMS*RAS !-- Total liquid water available on the top of soil domain !-- Without snow - 3 sources of water: precipitation, @@ -6122,7 +6106,7 @@ SUBROUTINE SOILMOIST ( debug_print, & 191 format (f23.19) - TOTLIQ=PRCP-DRIP/DELT-(1.-VEGFRAC)*DEW*RAS-SMELT + TOTLIQ=PRCP-DRIP/DELT-(one-VEGFRAC)*DEW*RAS-SMELT IF (debug_print ) THEN print *,'UMVEG*PRCP,DRIP/DELT,UMVEG*DEW*RAS,SMELT', & UMVEG*PRCP,DRIP/DELT,UMVEG*DEW*RAS,SMELT @@ -6140,32 +6124,32 @@ SUBROUTINE SOILMOIST ( debug_print, & ! THAT IS WHY PARAMETER CVFRZ = 3 (INT{1/0.6*0.6}) ! ! Current logic doesn't allow CVFRZ be bigger than 3 - CVFRZ = 3. + CVFRZ = 3._kind_phys !-- SCHAAKE/KOREN EXPRESSION for calculation of max infiltration - REFKDT=3. - REFDK=3.4341E-6 - DELT1=DELT/86400. + REFKDT=3._kind_phys + REFDK=3.4341E-6_kind_phys + DELT1=DELT/86400._kind_phys F1MAX=DQM*ZSHALF(2) F2MAX=DQM*(ZSHALF(3)-ZSHALF(2)) - F1=F1MAX*(1.-SOILMOIS(1)/DQM) + F1=F1MAX*(one-SOILMOIS(1)/DQM) DICE=SOILICE(1)*ZSHALF(2) FD=F1 do k=2,nzs1 DICE=DICE+(ZSHALF(k+1)-ZSHALF(k))*SOILICE(K) FKMAX=DQM*(ZSHALF(k+1)-ZSHALF(k)) - FK=FKMAX*(1.-SOILMOIS(k)/DQM) + FK=FKMAX*(one-SOILMOIS(k)/DQM) FD=FD+FK enddo KDT=REFKDT*KSAT/REFDK VAL=(1.-EXP(-KDT*DELT1)) DDT = FD*VAL PX= - TOTLIQ * DELT - IF(PX.LT.0.0) PX = 0.0 - IF(PX.gt.0.0) THEN + IF(PX < zero) PX = zero + IF(PX > zero) THEN INFMAX1 = (PX*(DDT/(PX+DDT)))/DELT ELSE - INFMAX1 = 0. + INFMAX1 = zero ENDIF IF (debug_print ) THEN print *,'INFMAX1 before frozen part',INFMAX1 @@ -6176,11 +6160,12 @@ SUBROUTINE SOILMOIST ( debug_print, & ! ! ------------------------------------------------------------------ - FRZX= 0.15*((dqm+qmin)/ref) * (0.412 / 0.468) - FCR = 1. - IF ( DICE .GT. 1.E-2) THEN + FRZX= 0.15_kind_phys*((dqm+qmin)/ref) * (0.412_kind_phys / 0.468_kind_phys) + + FCR = one + IF ( DICE .GT. 1.E-2_kind_phys) THEN ACRT = CVFRZ * FRZX / DICE - SUM = 1. + SUM = one IALP1 = CVFRZ - 1 DO JK = 1,IALP1 K = 1 @@ -6189,7 +6174,7 @@ SUBROUTINE SOILMOIST ( debug_print, & END DO SUM = SUM + (ACRT ** ( CVFRZ-JK)) / FLOAT (K) END DO - FCR = 1. - EXP(-ACRT) * SUM + FCR = one - EXP(-ACRT) * SUM END IF IF (debug_print ) THEN print *,'FCR--------',fcr @@ -6215,18 +6200,18 @@ SUBROUTINE SOILMOIST ( debug_print, & ! INFILTRP is total infiltration flux in M/S INFILTRP=FLX ! Solution of moisture budget - R7=.5*DZS/DELT + R7=.5_kind_phys*DZS/DELT R4=R4+R7 FLX=FLX-SOILMOIS(1)*R7 ! R8 is for direct evaporation from soil, which occurs ! only from snow-free areas - R8=UMVEG*R6*(1.-snowfrac) + R8=UMVEG*R6*(one-snowfrac) QTOT=QVATM+QCATM R9=TRANS R10=QTOT-QSG !-- evaporation regime - IF(R10.LE.0.) THEN + IF(R10.LE.zero) THEN QQ=(R5*R2-FLX+R9)/(R4-R5*R1-R10*R8/(REF-QMIN)) FLXSAT=-DQM*(R4-R5*R1-R10*R8/(REF-QMIN)) & +R5*R2+R9 @@ -6238,7 +6223,7 @@ SUBROUTINE SOILMOIST ( debug_print, & IF(QQ.LT.0.) THEN ! print *,'negative QQ=',qq - SOILMOIS(1)=1.e-8 + SOILMOIS(1)=1.e-8_kind_phys ELSE IF(QQ.GT.DQM) THEN !-- saturation @@ -6248,7 +6233,7 @@ SUBROUTINE SOILMOIST ( debug_print, & ENDIF RUNOFF=RUNOFF+(FLXSAT-FLX) ELSE - SOILMOIS(1)=min(dqm,max(1.e-8,QQ)) + SOILMOIS(1)=min(dqm,max(1.e-8_kind_phys,QQ)) END IF IF (debug_print ) THEN @@ -6261,7 +6246,7 @@ SUBROUTINE SOILMOIST ( debug_print, & KK=NZS-K+1 QQ=COSMC(KK)*SOILMOIS(K-1)+RHSMC(KK) - IF (QQ.LT.0.) THEN + IF (QQ.LT.zero) THEN ELSE IF(QQ.GT.DQM) THEN !-- saturation @@ -6275,14 +6260,14 @@ SUBROUTINE SOILMOIST ( debug_print, & RUNOFF2=RUNOFF2+((QQ-DQM)*(ZSHALF(K+1)-ZSHALF(K)))/DELT ENDIF ELSE - SOILMOIS(K)=min(dqm,max(1.e-8,QQ)) + SOILMOIS(K)=min(dqm,max(1.e-8_kind_phys,QQ)) END IF END DO IF (debug_print ) THEN print *,'END soilmois,soiliqw,soilice',soilmois,SOILIQW,soilice*riw ENDIF - MAVAIL=max(.00001,min(1.,(SOILMOIS(1)/(REF-QMIN)*(1.-snowfrac)+1.*snowfrac))) + MAVAIL=max(.00001_kind_phys,min(one,(SOILMOIS(1)/(REF-QMIN)*(one-snowfrac)+one*snowfrac))) !------------------------------------------------------------------- END SUBROUTINE SOILMOIST !------------------------------------------------------------------- @@ -6324,7 +6309,7 @@ SUBROUTINE SOILPROP( debug_print, & !--- soil properties LOGICAL, INTENT(IN ) :: debug_print INTEGER, INTENT(IN ) :: NZS - real (kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: RHOCS, & BCLH, & DQM, & @@ -6333,12 +6318,12 @@ SUBROUTINE SOILPROP( debug_print, & QWRTZ, & QMIN - real (kind_phys), DIMENSION( 1:nzs ) , & + real (kind_phys), DIMENSION( 1:nzs ) , & INTENT(IN ) :: SOILMOIS, & keepfr - real (kind_phys), INTENT(IN ) :: CP, & + real (kind_phys), INTENT(IN ) :: CP, & CVW, & RIW, & kqwrtz, & @@ -6350,7 +6335,7 @@ SUBROUTINE SOILPROP( debug_print, & !--- output variables - real (kind_phys), DIMENSION(1:NZS) , & + real (kind_phys), DIMENSION(1:NZS) , & INTENT(INOUT) :: cap,diffu,hydro , & thdif,tav , & soilmoism , & @@ -6372,66 +6357,66 @@ SUBROUTINE SOILPROP( debug_print, & nzs1=nzs-1 !-- Constants for Johansen (1975) thermal conductivity - kzero =2. ! if qwrtz > 0.2 + kzero =2._kind_phys ! if qwrtz > 0.2 do k=1,nzs - detal (k)=0. - kasat (k)=0. - kjpl (k)=0. - hk (k)=0. + detal (k)=zero + kasat (k)=zero + kjpl (k)=zero + hk (k)=zero enddo ws=dqm+qmin x1=xlmelt/(g0_p*psis) x2=x1/bclh*ws - x4=(bclh+1.)/bclh + x4=(bclh+one)/bclh !--- Next 3 lines are for Johansen thermal conduct. - gamd=(1.-ws)*2700. - kdry=(0.135*gamd+64.7)/(2700.-0.947*gamd) + gamd=(one-ws)*2700._kind_phys + kdry=(0.135_kind_phys*gamd+64.7_kind_phys)/(2700._kind_phys-0.947_kind_phys*gamd) !-- one more option from Christa's paper - if(qwrtz > 0.2) then + if(qwrtz > 0.2_kind_phys) then kas=kqwrtz**qwrtz*kzero**(1.-qwrtz) else - kas=kqwrtz**qwrtz*3.**(1.-qwrtz) + kas=kqwrtz**qwrtz*3._kind_phys**(one-qwrtz) endif DO K=1,NZS1 tn=tav(k) - tfrz wd=ws - riw*soilicem(k) - psif=psis*100.*(wd/(soiliqwm(k)+qmin))**bclh & - * (ws/wd)**3. + psif=psis*100._kind_phys*(wd/(soiliqwm(k)+qmin))**bclh & + * (ws/wd)**3._kind_phys !--- PSIF should be in [CM] to compute PF pf=log10(abs(psif)) - fact=1.+riw*soilicem(k) + fact=one+riw*soilicem(k) !--- HK is for McCumber thermal conductivity - IF(PF.LE.5.2) THEN - HK(K)=420.*EXP(-(PF+2.7))*fact + IF(PF.LE.5.2_kind_phys) THEN + HK(K)=420._kind_phys*EXP(-(PF+2.7_kind_phys))*fact ELSE - HK(K)=.1744*fact + HK(K)=.1744_kind_phys*fact END IF - IF(soilicem(k).NE.0.AND.TN.LT.0.) then + IF(soilicem(k).NE.zero.AND.TN.LT.zero) then !--- DETAL is taking care of energy spent on freezing or released from ! melting of soil water DETAL(K)=tfrz*X2/(TAV(K)*TAV(K))* & (TAV(K)/(X1*TN))**X4 - if(keepfr(k).eq.1.) then - detal(k)=0. + if(keepfr(k).eq.one) then + detal(k)=zero endif ENDIF !--- Next 10 lines calculate Johansen thermal conductivity KJPL - kasat(k)=kas**(1.-ws)*kice**fwsat(k) & + kasat(k)=kas**(one-ws)*kice**fwsat(k) & *kwt**lwsat(k) X5=(soilmoism(k)+qmin)/ws - if(soilicem(k).eq.0.) then - sr=max(0.101,x5) - ke=log10(sr)+1. + if(soilicem(k).eq.zero) then + sr=max(0.101_kind_phys,x5) + ke=log10(sr)+one else ke=x5 endif @@ -6439,25 +6424,25 @@ SUBROUTINE SOILPROP( debug_print, & kjpl(k)=ke*(kasat(k)-kdry)+kdry !--- CAP -volumetric heat capacity - CAP(K)=(1.-WS)*RHOCS & + CAP(K)=(one-WS)*RHOCS & + (soiliqwm(K)+qmin)*CVW & + soilicem(K)*CI & - + (dqm-soilmoism(k))*CP*1.2 & - - DETAL(K)*1.e3*xlmelt + + (dqm-soilmoism(k))*CP*1.2_kind_phys & + - DETAL(K)*rhowater*xlmelt a=RIW*soilicem(K) - if((ws-a).lt.0.12)then - diffu(K)=0. + if((ws-a).lt.0.12_kind_phys)then + diffu(K)=zero else - H=max(0.,(soilmoism(K)+qmin-a)/(max(1.e-8,(ws-a)))) - facd=1. - if(a.ne.0.)facd=1.-a/max(1.e-8,soilmoism(K)) - ame=max(1.e-8,ws-riw*soilicem(K)) + H=max(zero,(soilmoism(K)+qmin-a)/(max(1.e-8_kind_phys,(ws-a)))) + facd=one + if(a.ne.zero)facd=one-a/max(1.e-8_kind_phys,soilmoism(K)) + ame=max(1.e-8_kind_phys,ws-riw*soilicem(K)) !--- DIFFU is diffusional conductivity of soil water diffu(K)=-BCLH*KSAT*PSIS/ame* & - (ws/ame)**3. & - *H**(BCLH+2.)*facd + (ws/ame)**3._kind_phys & + *H**(BCLH+2._kind_phys)*facd endif !--- thdif - thermal diffusivity @@ -6472,19 +6457,19 @@ SUBROUTINE SOILPROP( debug_print, & ENDIF DO K=1,NZS - if((ws-riw*soilice(k)).lt.0.12)then - hydro(k)=0. + if((ws-riw*soilice(k)).lt.0.12_kind_phys)then + hydro(k)=zero else - fach=1. - if(soilice(k).ne.0.) & - fach=1.-riw*soilice(k)/max(1.e-8,soilmois(k)) - am=max(1.e-8,ws-riw*soilice(k)) + fach=one + if(soilice(k).ne.zero) & + fach=one-riw*soilice(k)/max(1.e-8_kind_phys,soilmois(k)) + am=max(1.e-8_kind_phys,ws-riw*soilice(k)) !--- HYDRO is hydraulic conductivity of soil water hydro(K)=min(KSAT,KSAT/am* & (soiliqw(K)/am) & - **(2.*BCLH+2.) & + **(2._kind_phys*BCLH+2._kind_phys) & * fach) - if(hydro(k)<1.e-10)hydro(k)=0. + if(hydro(k)<1.e-10_kind_phys)hydro(k)=zero endif ENDDO @@ -6521,22 +6506,22 @@ SUBROUTINE TRANSF( debug_print, & LOGICAL, INTENT(IN ) :: debug_print INTEGER, INTENT(IN ) :: nroot,nzs,iland - real (kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: GSWin, TABS, lai !--- soil properties - real (kind_phys) , & + real (kind_phys) , & INTENT(IN ) :: DQM, & QMIN, & REF, & PC, & WILT - real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: soiliqw, & - ZSHALF + real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: soiliqw, & + ZSHALF !-- output - real (kind_phys), DIMENSION(1:NZS), INTENT(OUT) :: TRANF - real (kind_phys), INTENT(OUT) :: TRANSUM + real (kind_phys), DIMENSION(1:NZS), INTENT(OUT) :: TRANF + real (kind_phys), INTENT(OUT) :: TRANSUM !-- local variables real (kind_phys) :: totliq, did @@ -6549,32 +6534,32 @@ SUBROUTINE TRANSF( debug_print, & !-------------------------------------------------------------------- do k=1,nzs - part(k)=0. - tranf(k)=0. + part(k)=zero + tranf(k)=zero enddo - transum=0. + transum=zero totliq=soiliqw(1)+qmin sm1=totliq sm2=sm1*sm1 sm3=sm2*sm1 sm4=sm3*sm1 - ap0=0.299 - ap1=-8.152 - ap2=61.653 - ap3=-115.876 - ap4=59.656 + ap0=0.299_kind_phys + ap1=-8.152_kind_phys + ap2=61.653_kind_phys + ap3=-115.876_kind_phys + ap4=59.656_kind_phys gx=ap0+ap1*sm1+ap2*sm2+ap3*sm3+ap4*sm4 - if(totliq.ge.ref) gx=1. - if(totliq.le.0.) gx=0. - if(gx.gt.1.) gx=1. - if(gx.lt.0.) gx=0. + if(totliq.ge.ref) gx=one + if(totliq.le.zero) gx=zero + if(gx.gt.one) gx=one + if(gx.lt.zero) gx=zero DID=zshalf(2) part(1)=DID*gx IF(TOTLIQ.GT.REF) THEN TRANF(1)=DID ELSE IF(TOTLIQ.LE.WILT) THEN - TRANF(1)=0. + TRANF(1)=zero ELSE TRANF(1)=(TOTLIQ-WILT)/(REF-WILT)*DID ENDIF @@ -6588,16 +6573,16 @@ SUBROUTINE TRANSF( debug_print, & sm3=sm2*sm1 sm4=sm3*sm1 gx=ap0+ap1*sm1+ap2*sm2+ap3*sm3+ap4*sm4 - if(totliq.ge.ref) gx=1. - if(totliq.le.0.) gx=0. - if(gx.gt.1.) gx=1. - if(gx.lt.0.) gx=0. + if(totliq.ge.ref) gx=one + if(totliq.le.zero) gx=zero + if(gx.gt.one) gx=one + if(gx.lt.zero) gx=zero DID=zshalf(K+1)-zshalf(K) part(k)=did*gx IF(totliq.GE.REF) THEN TRANF(K)=DID ELSE IF(totliq.LE.WILT) THEN - TRANF(K)=0. + TRANF(K)=zero ELSE TRANF(K)=(totliq-WILT) & /(REF-WILT)*DID @@ -6607,8 +6592,8 @@ SUBROUTINE TRANSF( debug_print, & END DO ! For LAI> 3 => transpiration at potential rate (F.Tardieu, 2013) - if(lai > 4.) then - pctot=0.8 + if(lai > 4._kind_phys) then + pctot=0.8_kind_phys else pctot=pc !- 26aug16- next 2 lines could lead to LH increase and higher 2-m Q during the day @@ -6621,22 +6606,22 @@ SUBROUTINE TRANSF( debug_print, & !--- !--- air temperature function ! Avissar (1985) and AX 7/95 - IF (TABS .LE. 302.15) THEN - FTEM = 1.0 / (1.0 + EXP(-0.41 * (TABS - 282.05))) + IF (TABS .LE. 302.15_kind_phys) THEN + FTEM = one / (one + EXP(-0.41_kind_phys * (TABS - 282.05_kind_phys))) ELSE - FTEM = 1.0 / (1.0 + EXP(0.5 * (TABS - 314.0))) + FTEM = one / (one + EXP(0.5_kind_phys * (TABS - 314.0_kind_phys))) ENDIF IF ( debug_print ) THEN print *,'tabs,ftem',tabs,ftem ENDIF !--- incoming solar function - cmin = 1./rsmax_data - cmax = 1./rstbl(iland) - if(lai > 1.) then + cmin = one/rsmax_data + cmax = one/rstbl(iland) + if(lai > one) then cmax = lai/rstbl(iland) ! max conductance endif ! Noihlan & Planton (1988) - f1=0. + f1=zero ! if(lai > 0.01) then ! f1 = 1.1/lai*gswin/rgltbl(iland)! f1=0. when GSWin=0. ! fsol = (f1+cmin/cmax)/(1.+f1) @@ -6647,9 +6632,9 @@ SUBROUTINE TRANSF( debug_print, & ! totcnd = max(lai/rstbl(iland), pctot * ftem * f1) ! Mahrer & Avissar (1982), Avissar et al. (1985) if (GSWin < rgltbl(iland)) then - fsol = 1. / (1. + exp(-0.034 * (GSWin - 3.5))) + fsol = one / (one + exp(-0.034_kind_phys * (GSWin - 3.5_kind_phys))) else - fsol = 1. + fsol = one endif IF ( debug_print ) THEN print *,'GSWin,lai,f1,fsol',gswin,lai,f1,fsol @@ -6663,7 +6648,7 @@ SUBROUTINE TRANSF( debug_print, & ENDIF !-- TRANSUM - total for the rooting zone - transum=0. + transum=zero DO K=1,NROOT ! linear root distribution TRANF(k)=max(cmin,TRANF(k)*totcnd) @@ -6695,20 +6680,20 @@ SUBROUTINE VILKA(TN,D1,D2,PP,QS,TS,TT,NSTEP,ii,j,iland,isoil,xlat,xlon) real (kind_phys) :: F1,T1,T2,RN INTEGER :: I,I1 - I=(TN-1.7315E2)/.05+1 - T1=173.1+FLOAT(I)*.05 + I=(TN-1.7315E2_kind_dbl_prec)/.05_kind_dbl_prec+1 + T1=173.1_kind_dbl_prec+FLOAT(I)*.05_kind_dbl_prec F1=T1+D1*TT(I)-D2 - I1=I-F1/(.05+D1*(TT(I+1)-TT(I))) + I1=I-F1/(.05_kind_dbl_prec+D1*(TT(I+1)-TT(I))) I=I1 IF(I.GT.5000.OR.I.LT.1) GOTO 1 10 I1=I - T1=173.1+FLOAT(I)*.05 + T1=173.1_kind_dbl_prec+FLOAT(I)*.05_kind_dbl_prec F1=T1+D1*TT(I)-D2 - RN=F1/(.05+D1*(TT(I+1)-TT(I))) + RN=F1/(.05_kind_dbl_prec+D1*(TT(I+1)-TT(I))) I=I-INT(RN) IF(I.GT.5000.OR.I.LT.1) GOTO 1 IF(I1.NE.I) GOTO 10 - TS=T1-.05*RN + TS=T1-.05_kind_dbl_prec*RN QS=(TT(I)+(TT(I)-TT(I+1))*RN)/PP GOTO 20 1 PRINT *,' AVOST IN VILKA Table index= ',I @@ -6784,7 +6769,7 @@ SUBROUTINE SOILVEGIN ( debug_print, & ! 19 White Sand ! !---------------------------------------------------------------------- - real (kind_phys) LQMA(nsoilclas),LRHC(nsoilclas), & + real (kind_phys) LQMA(nsoilclas),LRHC(nsoilclas), & LPSI(nsoilclas),LQMI(nsoilclas), & LBCL(nsoilclas),LKAS(nsoilclas), & LWIL(nsoilclas),LREF(nsoilclas), & @@ -6921,8 +6906,8 @@ SUBROUTINE SOILVEGIN ( debug_print, & !---- Below are the arrays for the vegetation parameters - real (kind_phys) LALB(nvegclas),LMOI(nvegclas),LEMI(nvegclas), & - LROU(nvegclas),LTHI(nvegclas),LSIG(nvegclas), & + real (kind_phys) LALB(nvegclas),LMOI(nvegclas),LEMI(nvegclas), & + LROU(nvegclas),LTHI(nvegclas),LSIG(nvegclas), & LPC(nvegclas) !************************************************************************ @@ -6962,18 +6947,18 @@ SUBROUTINE SOILVEGIN ( debug_print, & real (kind_phys), DIMENSION( 1:NLCAT ), INTENT(IN):: LUFRAC real (kind_phys), DIMENSION( 1:NSCAT ), INTENT(IN):: SOILFRAC - real (kind_phys) , & + real (kind_phys) , & INTENT ( OUT) :: pc, & msnf, & facsnf - real (kind_phys) , & + real (kind_phys) , & INTENT (INOUT ) :: emiss, & lai, & znt LOGICAL, intent(in) :: rdlai2d !--- soil properties - real (kind_phys) , & + real (kind_phys) , & INTENT( OUT) :: RHOCS, & BCLH, & DQM, & @@ -7007,25 +6992,25 @@ SUBROUTINE SOILVEGIN ( debug_print, & ifortbl(ivgtyp),ivgtyp,laitbl(ivgtyp),z0tbl(ivgtyp) ENDIF - deltalai(:) = 0. + deltalai(:) = zero ! 11oct2012 - seasonal correction on ZNT for crops and LAI for all veg. types ! factor = 1 with minimum greenness --> vegfrac = shdmin (cold season) ! factor = 0 with maximum greenness --> vegfrac = shdmax ! SHDMAX, SHDMIN and VEGFRAC are in % here. - if((shdmax - shdmin) .lt. 1) then - factor = 1. ! min greenness + if((shdmax - shdmin) .lt. one) then + factor = one ! min greenness else - factor = 1. - max(0.,min(1.,(vegfrac - shdmin)/max(1.,(shdmax-shdmin)))) + factor = one - max(zero,min(one,(vegfrac - shdmin)/max(one,(shdmax-shdmin)))) endif ! 18sept18 - LAITBL and Z0TBL are the max values do k = 1,nlcat - if(IFORTBL(k) == 1) deltalai(k)=min(0.2,0.8*LAITBL(K)) - if(IFORTBL(k) == 2 .or. IFORTBL(k) == 7) deltalai(k)=min(0.5,0.8*LAITBL(K)) - if(IFORTBL(k) == 3) deltalai(k)=min(0.45,0.8*LAITBL(K)) - if(IFORTBL(k) == 4) deltalai(k)=min(0.75,0.8*LAITBL(K)) - if(IFORTBL(k) == 5) deltalai(k)=min(0.86,0.8*LAITBL(K)) + if(IFORTBL(k) == 1) deltalai(k)=min(0.2_kind_phys,0.8_kind_phys*LAITBL(K)) + if(IFORTBL(k) == 2 .or. IFORTBL(k) == 7) deltalai(k)=min(0.5_kind_phys,0.8_kind_phys*LAITBL(K)) + if(IFORTBL(k) == 3) deltalai(k)=min(0.45_kind_phys,0.8_kind_phys*LAITBL(K)) + if(IFORTBL(k) == 4) deltalai(k)=min(0.75_kind_phys,0.8_kind_phys*LAITBL(K)) + if(IFORTBL(k) == 5) deltalai(k)=min(0.86_kind_phys,0.8_kind_phys*LAITBL(K)) if(k.ne.iswater) then !-- 20aug18 - change in LAItoday based on the greenness fraction for the current day @@ -7033,7 +7018,7 @@ SUBROUTINE SOILVEGIN ( debug_print, & if(IFORTBL(k) == 7) then !-- seasonal change of roughness length for crops - ZNTtoday(k) = Z0TBL(K) - 0.125 * factor + ZNTtoday(k) = Z0TBL(K) - 0.125_kind_phys * factor else ZNTtoday(k) = Z0TBL(K) endif @@ -7048,24 +7033,24 @@ SUBROUTINE SOILVEGIN ( debug_print, & i,j,ivgtyp,factor,vegfrac,shdmin,shdmax,deltalai(ivgtyp),laitoday(ivgtyp),znttoday(ivgtyp) ENDIF - EMISS = 0. - ZNT = 0. - ZNT1 = 0. - PC = 0. - MSNF = 0. - FACSNF= 0. - if(.not.rdlai2d) LAI = 0. - AREA = 0. + EMISS = zero + ZNT = zero + ZNT1 = zero + PC = zero + MSNF = zero + FACSNF= zero + if(.not.rdlai2d) LAI = zero + AREA = zero !-- mosaic approach to landuse in the grid box ! Use Mason (1988) Eq.(15) to compute effective ZNT; ! Lb - blending height = L/200., where L is the length scale ! of regions with varying Z0 (Lb = 5 if L=1000 m) - LB = 5. + LB = 5._kind_phys if(mosaic_lu == 1) then do k = 1,nlcat AREA = AREA + lufrac(k) EMISS = EMISS+ LEMITBL(K)*lufrac(k) - ZNT = ZNT + lufrac(k)/ALOG(LB/ZNTtoday(K))**2. + ZNT = ZNT + lufrac(k)/ALOG(LB/ZNTtoday(K))**2._kind_phys ! ZNT1 - weighted average in the grid box, not used, computed for comparison ZNT1 = ZNT1 + lufrac(k)*ZNTtoday(K) if(.not.rdlai2d) LAI = LAI + LAItoday(K)*lufrac(k) @@ -7074,8 +7059,8 @@ SUBROUTINE SOILVEGIN ( debug_print, & FACSNF= FACSNF + SNCOVFAC(K)*lufrac(k) enddo - if (area.gt.1.) area=1. - if (area <= 0.) then + if (area.gt.one) area=one + if (area <= zero) then print *,'Bad area of grid box', area errflg = 1 errmsg = 'ERROR(SOILVEGIN): Bad area of grid box' @@ -7088,7 +7073,7 @@ SUBROUTINE SOILVEGIN ( debug_print, & EMISS = EMISS/AREA ZNT1 = ZNT1/AREA - ZNT = LB/EXP(SQRT(1./ZNT)) + ZNT = LB/EXP(SQRT(one/ZNT)) if(.not.rdlai2d) LAI = LAI/AREA PC = PC /AREA MSNF = MSNF /AREA @@ -7109,23 +7094,23 @@ SUBROUTINE SOILVEGIN ( debug_print, & endif ! parameters from SOILPARM.TBL - RHOCS = 0. - BCLH = 0. - DQM = 0. - KSAT = 0. - PSIS = 0. - QMIN = 0. - REF = 0. - WILT = 0. - QWRTZ = 0. - AREA = 0. + RHOCS = zero + BCLH = zero + DQM = zero + KSAT = zero + PSIS = zero + QMIN = zero + REF = zero + WILT = zero + QWRTZ = zero + AREA = zero ! mosaic approach if(mosaic_soil == 1 ) then do k = 1, nscat if(k.ne.14) then ! STATSGO value for water !exclude water points from this loop AREA = AREA + soilfrac(k) - RHOCS = RHOCS + HC(k)*1.E6*soilfrac(k) + RHOCS = RHOCS + HC(k)*1.E6_kind_phys*soilfrac(k) BCLH = BCLH + BB(K)*soilfrac(k) DQM = DQM + (MAXSMC(K)- & DRYSMC(K))*soilfrac(k) @@ -7137,11 +7122,11 @@ SUBROUTINE SOILVEGIN ( debug_print, & QWRTZ = QWRTZ + QTZ(K)*soilfrac(k) endif enddo - if (area.gt.1.) area=1. - if (area <= 0.) then + if (area.gt.one) area=one + if (area <= zero) then ! area = 0. for water points ! print *,'Area of a grid box', area, 'iswater = ',iswater - RHOCS = HC(ISLTYP)*1.E6 + RHOCS = HC(ISLTYP)*1.E6_kind_phys BCLH = BB(ISLTYP) DQM = MAXSMC(ISLTYP)- & DRYSMC(ISLTYP) @@ -7166,7 +7151,7 @@ SUBROUTINE SOILVEGIN ( debug_print, & ! dominant category approach else if(isltyp.ne.14) then - RHOCS = HC(ISLTYP)*1.E6 + RHOCS = HC(ISLTYP)*1.E6_kind_phys BCLH = BB(ISLTYP) DQM = MAXSMC(ISLTYP)- & DRYSMC(ISLTYP) @@ -7208,18 +7193,18 @@ SUBROUTINE RUCLSMINIT( debug_print, landfrac, fice, min_seaice, & its,ite, jts,jte, kts,kte, & nzs - real (kind_phys), DIMENSION( ims:ime, 1:nzs, jms:jme ), & + real (kind_phys), DIMENSION( ims:ime, 1:nzs, jms:jme ) , & INTENT(IN) :: TSLB, & SMOIS INTEGER, DIMENSION( ims:ime, jms:jme ) , & INTENT(INOUT) :: ISLTYP,IVGTYP - real (kind_phys), DIMENSION( ims:ime, 1:nzs, jms:jme ) , & + real (kind_phys), DIMENSION( ims:ime, 1:nzs, jms:jme ) , & INTENT(OUT) :: SMFR3D, & SH2O - real (kind_phys), DIMENSION( ims:ime, jms:jme ) , & + real (kind_phys), DIMENSION( ims:ime, jms:jme ) , & INTENT(OUT) :: MAVAIL !-- local @@ -7230,8 +7215,8 @@ SUBROUTINE RUCLSMINIT( debug_print, landfrac, fice, min_seaice, & INTEGER :: errflag - RIW=900.*1.e-3 - XLMELT=3.35E+5 + RIW=rhoice*1.e-3_kind_phys + XLMELT=con_hfus ! for FIM itf=ite ! min0(ite,ide-1) @@ -7261,7 +7246,7 @@ SUBROUTINE RUCLSMINIT( debug_print, landfrac, fice, min_seaice, & ! has isltyp=14 for water if (isltyp(i,j) == 0) isltyp(i,j)=14 - if(landfrac(i) > 0. ) then + if(landfrac(i) > zero ) then !-- land !-- Computate volumetric content of ice in soil !-- and initialize MAVAIL @@ -7272,41 +7257,41 @@ SUBROUTINE RUCLSMINIT( debug_print, landfrac, fice, min_seaice, & QMIN = DRYSMC (ISLTYP(I,J)) BCLH = BB (ISLTYP(I,J)) - mavail(i,j) = max(0.00001,min(1.,(smois(i,1,j)-qmin)/(ref-qmin))) + mavail(i,j) = max(0.00001_kind_phys,min(one,(smois(i,1,j)-qmin)/(ref-qmin))) DO L=1,NZS !-- for land points initialize soil ice tln=log(TSLB(i,l,j)/tfrz) - if(tln.lt.0.) then + if(tln.lt.zero) then soiliqw(l)=(dqm+qmin)*(XLMELT* & - (tslb(i,l,j)-tfrz)/tslb(i,l,j)/9.81/psis) & - **(-1./bclh) - soiliqw(l)=max(0.,soiliqw(l)) + (tslb(i,l,j)-tfrz)/tslb(i,l,j)/grav/psis) & + **(-one/bclh) + soiliqw(l)=max(zero,soiliqw(l)) soiliqw(l)=min(soiliqw(l),smois(i,l,j)) sh2o(i,l,j)=soiliqw(l) smfr3d(i,l,j)=(smois(i,l,j)-soiliqw(l))/RIW else - smfr3d(i,l,j)=0. + smfr3d(i,l,j)=zero sh2o(i,l,j)=smois(i,l,j) endif ENDDO elseif( fice(i) > min_seaice) then !-- ice - mavail(i,j) = 1. + mavail(i,j) = one DO L=1,NZS - smfr3d(i,l,j)=1. - sh2o(i,l,j)=0. + smfr3d(i,l,j)=one + sh2o(i,l,j)=zero ENDDO else !-- water ISLTYP=14 - mavail(i,j) = 1. + mavail(i,j) = one DO L=1,NZS - smfr3d(i,l,j)=0. - sh2o(i,l,j)=1. + smfr3d(i,l,j)=zero + sh2o(i,l,j)=one ENDDO endif ! land @@ -7684,11 +7669,11 @@ real (kind_phys) FUNCTION RSLF(P,T) real (kind_phys), PARAMETER:: C7= .379534310E-11 real (kind_phys), PARAMETER:: C8=-.321582393E-13 - X=MAX(-80.,T-273.16) + X=MAX(-80._kind_dbl_prec,T-273.16_kind_dbl_prec) ESL=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8))))))) - ESL=MIN(ESL, P*0.15) ! Even with P=1050mb and T=55C, the sat. vap. pres only contributes to ~15% of total pres. - RSLF=.622*ESL/max(1.e-4,(P-ESL)) + ESL=MIN(ESL, P*0.15_kind_dbl_prec) ! Even with P=1050mb and T=55C, the sat. vap. pres only contributes to ~15% of total pres. + RSLF=.622_kind_dbl_prec*ESL/max(1.e-4_kind_dbl_prec,(P-ESL)) END FUNCTION RSLF From f10866c59c35418214ce8dab1cbee01af5ec5964 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Wed, 22 Mar 2023 22:07:15 +0000 Subject: [PATCH 182/380] Use constants from host in RUC LSM driver. --- physics/lsm_ruc.F90 | 13 +++++-------- physics/lsm_ruc.meta | 16 ++++++++++++++++ 2 files changed, 21 insertions(+), 8 deletions(-) diff --git a/physics/lsm_ruc.F90 b/physics/lsm_ruc.F90 index a8afa7f92..4a7519f50 100644 --- a/physics/lsm_ruc.F90 +++ b/physics/lsm_ruc.F90 @@ -336,7 +336,7 @@ subroutine lsm_ruc_run & ! inputs & min_lakeice, min_seaice, oceanfrac, rhonewsn1, & ! --- constants & con_cp, con_rd, con_rv, con_g, con_pi, con_hvap, & - & con_hfus, con_fvirt, & + & con_hfus, con_fvirt, stbolt, rhoh2o, & ! --- in/outs for ice and land & semisbase, semis_lnd, semis_ice, sfalb_lnd, sfalb_ice, & & sncovr1_lnd, weasd_lnd, snwdph_lnd, tskin_lnd, & @@ -366,10 +366,6 @@ subroutine lsm_ruc_run & ! inputs implicit none -! --- constant parameters: - real(kind_phys), parameter :: rhoh2o = 1000.0 - real(kind_phys), parameter :: stbolt = 5.670400e-8 - ! --- input: integer, intent(in) :: me, master integer, intent(in) :: im, nlev, iter, lsoil_ruc, lsoil, kdt, isot, ivegsrc @@ -392,9 +388,10 @@ subroutine lsm_ruc_run & ! inputs & cm_ice, ch_ice real (kind_phys), intent(in) :: delt, min_seaice, min_lakeice - real (kind_phys), intent(in) :: con_cp, con_rv, con_g, & - con_pi, con_rd, & - con_hvap, con_hfus, con_fvirt + real (kind_phys), intent(in) :: con_cp, con_rv, con_g, & + con_pi, con_rd, & + con_hvap, con_hfus, & + con_fvirt, stbolt, rhoh2o logical, dimension(:), intent(in) :: flag_iter, flag_guess logical, dimension(:), intent(in) :: land, icy, use_lake diff --git a/physics/lsm_ruc.meta b/physics/lsm_ruc.meta index 3ff016f85..38ebbcd67 100644 --- a/physics/lsm_ruc.meta +++ b/physics/lsm_ruc.meta @@ -1077,6 +1077,22 @@ type = real kind = kind_phys intent = in +[stbolt] + standard_name = stefan_boltzmann_constant + long_name = Stefan-Boltzmann constant + units = W m-2 K-4 + dimensions = () + type = real + kind = kind_phys + intent = in +[rhoh2o] + standard_name = density_of_fresh_water + long_name = density of fresh water + units = kg m-3 + dimensions = () + type = real + kind = kind_phys + intent = in [semisbase] standard_name = baseline_surface_longwave_emissivity long_name = baseline surface lw emissivity in fraction From 4933f03329bce3422b7a4fb469f1998abc76a326 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Thu, 23 Mar 2023 17:19:44 +0000 Subject: [PATCH 183/380] Removed wet - not used. Also rename rocp into con_rocp --- physics/sfc_diag.f | 11 ++++++----- physics/sfc_diag.meta | 10 +--------- 2 files changed, 7 insertions(+), 14 deletions(-) diff --git a/physics/sfc_diag.f b/physics/sfc_diag.f index 585bd4b7d..be648bd61 100644 --- a/physics/sfc_diag.f +++ b/physics/sfc_diag.f @@ -22,8 +22,9 @@ end subroutine sfc_diag_finalize !! \section detailed Detailed Algorithm !! @{ subroutine sfc_diag_run (im,xlat_d,xlon_d, & - & lsm,lsm_ruc,grav,cp,eps,epsm1,rocp,con_karman,& - & wet,shflx,cdq,wind, & + & lsm,lsm_ruc,grav,cp,eps,epsm1,con_rocp, & + & con_karman, & + & shflx,cdq,wind, & & zf,ps,u1,v1,t1,q1,prslki,evap,fm,fh,fm10,fh2, & & ust,tskin,qsurf,thsfc_loc,diag_flux,diag_log, & & f10m,u10m,v10m,t2m,q2m,dpt2m,errmsg,errflg & @@ -37,10 +38,10 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & logical, intent(in) :: thsfc_loc ! Flag for reference pot. temp. logical, intent(in) :: diag_flux ! Flag for flux method in 2-m diagnostics logical, intent(in) :: diag_log ! Flag for 2-m log diagnostics under stable conditions - real(kind=kind_phys), intent(in) :: grav,cp,eps,epsm1,rocp + real(kind=kind_phys), intent(in) :: grav,cp,eps,epsm1,con_rocp real(kind=kind_phys), intent(in) :: con_karman real(kind=kind_phys), dimension(:), intent( in) :: & - & zf, ps, u1, v1, t1, q1, ust, tskin, wet, & + & zf, ps, u1, v1, t1, q1, ust, tskin, & & qsurf, prslki, evap, fm, fh, fm10, fh2, & & shflx, cdq, wind, xlat_d, xlon_d real(kind=kind_phys), dimension(:), intent(out) :: & @@ -95,7 +96,7 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & ! t2m(i) = t2m(i) * sig2k wrk = 1.0 - fhi - thcon = (1.e5/ps(i))**rocp + thcon = (1.e5/ps(i))**con_rocp !-- make sure 1st level q is not higher than saturated value qss = fpvs(t1(i)) qss = eps * qss / (ps(i) + epsm1 * qss) diff --git a/physics/sfc_diag.meta b/physics/sfc_diag.meta index 7618a4a00..6eac1dc4b 100644 --- a/physics/sfc_diag.meta +++ b/physics/sfc_diag.meta @@ -76,7 +76,7 @@ type = real kind = kind_phys intent = in -[rocp] +[con_rocp] standard_name = ratio_of_gas_constant_dry_air_to_specific_heat_of_dry_air_at_constant_pressure long_name = (rd/cp) units = none @@ -91,14 +91,6 @@ dimensions = () type = real intent = in -[wet] - standard_name = normalized_soil_wetness_for_land_surface_model - long_name = normalized soil wetness - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in [zf] standard_name = height_above_ground_at_lowest_model_layer long_name = layer 1 height above ground (not MSL) From da70f9b556e0a68614a4d84880e14ccb0b41c7f6 Mon Sep 17 00:00:00 2001 From: drnimbusrain Date: Thu, 23 Mar 2023 17:29:28 +0000 Subject: [PATCH 184/380] Added canopy effects for multiple model layers...if necessary --- physics/satmedmfvdifq.F | 35 ++++++++++++++++++++++++++--------- 1 file changed, 26 insertions(+), 9 deletions(-) diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index 3f10ffd41..f908845e2 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -267,10 +267,10 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & real(kind=kind_phys) bfac, mffac !PCC_CANOPY------------------------------------ - integer COUNTCAN + integer COUNTCAN,KCAN real(kind=kind_phys) FCH, MOL, HOL, TLCAN, & SIGMACAN, RRCAN, BBCAN, - & AACAN, ZCAN, ZFL, + & AACAN, ZCAN, ZFL, BOTCAN, & EDDYVEST1, EDDYVEST_INT ! in canopy eddy diffusivity [ m**2/s ] @@ -1315,13 +1315,22 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & enddo enddo !PCC_CANOPY------------------------------------ - if (do_canopy) then + if (do_canopy) then do k = 1, km1 do i = 1, im FCH = hvt_table(vegtype(i)) !top of canopy - IF (k .EQ. 1) THEN !first model layer -! Check for Contiguous Canopy Grid Cells + KCAN = 1 + ELSE + IF (FCH .GT. zl(i,k-1) + & .AND. FCH .LE. zl(i,k) ) THEN + KCAN = 1 + ELSE + KCAN = 0 + END IF + END IF + IF (KCAN .EQ. 1) THEN !canopy could be inside model layer +! Check for other Contiguous Canopy Grid Cell Conditions IF ( lai(i) .LT. 0.1 !from LSM & .OR. FCH .LT. 0.5 ) THEN ! & .OR. MAX(0.0, 1.0 - FRT) .GT. 0.5 @@ -1340,10 +1349,17 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & ! (1989), 115, pp 609-632 MOL = zol(i)/zl(i,k) !Monin-Obukhov Length HOL = FCH/MOL !local canopy stability parameter (hc/MOL) - ZCAN = zl(i,k) ! Initialize canopy top (m) = First model layer height above canopy + ZCAN = zl(i,k) ! Initialize canopy top (m) = Each model layer that contains canopy ZFL = ZCAN ! Set ZFL = ZCAN COUNTCAN = 0 ! Initialize canopy layers - DO WHILE (ZCAN.GE.0.5) !canopy threshold >= 0.5 m + + IF (k .EQ. 1) THEN !Find bottom in each model layer + BOTCAN = 0.5 + ELSE + BOTCAN = zl(i,k-1) + END IF + + DO WHILE (ZCAN.GE.BOTCAN) ! TLCAN = Lagrangian timescale TLCAN = (FCH/ustar(i)) * ( & (0.256 * (ZCAN-(0.75*FCH))/FCH ) + @@ -1396,7 +1412,7 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & IF ( HOL .GE. 0.9 ) THEN !VERY STABLE SIGMACAN = 0.25*ustar(i) END IF - IF ( ZCAN .EQ. ZFL ) THEN ! First model layer above canopy + IF ( ZCAN .EQ. ZFL ) THEN ! Each model layer that includes canopy EDDYVEST1 = (SIGMACAN*SIGMACAN)*TLCAN ELSE IF ( ZCAN .LE. FCH ) THEN !in-canopy layers and set arrays COUNTCAN = COUNTCAN + 1 @@ -1411,7 +1427,8 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & dkq(i,k)= (dkq(i,k)/EDDYVEST1) * EDDYVEST_INT !Scale dkq to resolved eddy diffusivity dku(i,k)= (dku(i,k)/EDDYVEST1) * EDDYVEST_INT !Scale dku to resolved eddy diffusivity END IF !contigous canopy conditions - END IF ! first model layer scaled canopy +! END IF ! first model layer scaled canopy + END IF ! model layers containing canopy enddo !i enddo !k endif !do_canopy From f7839dea35783b80383a619b3e0363cd349b091f Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Thu, 23 Mar 2023 18:27:34 +0000 Subject: [PATCH 185/380] More changes in RUC LSM related to kind_phys and use of constants from Physcons. --- physics/lsm_ruc.F90 | 412 ++++++++++++++++++++++---------------------- 1 file changed, 207 insertions(+), 205 deletions(-) diff --git a/physics/lsm_ruc.F90 b/physics/lsm_ruc.F90 index 4a7519f50..cec87e689 100644 --- a/physics/lsm_ruc.F90 +++ b/physics/lsm_ruc.F90 @@ -10,13 +10,15 @@ module lsm_ruc use module_soil_pre use module_sf_ruclsm + use physcons, only : con_t0c + implicit none private public :: lsm_ruc_init, lsm_ruc_run, lsm_ruc_finalize - real(kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys, epsln = 1.0e-10_kind_phys + real(kind_phys), parameter :: zero = 0.0_kind_dbl_prec, one = 1.0_kind_dbl_prec, epsln = 1.0e-8_kind_dbl_prec real(kind_phys), dimension (2), parameter, private :: d = (/0.1,0.25/) integer, dimension(20), parameter, private:: & istwe = (/1,1,1,1,1,2,2,1,1,2,2,2,2,2,1,2,2,1,2,2/) ! IGBP 20 classes @@ -171,26 +173,26 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & if (lsm_cold_start) then !-- land - semis_lnd(i) = semisbase(i) * (1.-sncovr_lnd(i)) & - + 0.99 * sncovr_lnd(i) - sfalb_lnd_bck(i) = 0.25*(alnsf(i) + alnwf(i) + alvsf(i) + alvwf(i)) & - * min(1., facsf(i)+facwf(i)) - alb_lnd = sfalb_lnd_bck(i) * (1. - sncovr_lnd(i)) & + semis_lnd(i) = semisbase(i) * (one-sncovr_lnd(i)) & + + 0.99_kind_phys * sncovr_lnd(i) + sfalb_lnd_bck(i) = 0.25_kind_phys*(alnsf(i) + alnwf(i) + alvsf(i) + alvwf(i)) & + * min(one, facsf(i)+facwf(i)) + alb_lnd = sfalb_lnd_bck(i) * (one - sncovr_lnd(i)) & + snoalb(i) * sncovr_lnd(i) albdvis_lnd(i) = alb_lnd albdnir_lnd(i) = alb_lnd albivis_lnd(i) = alb_lnd albinir_lnd(i) = alb_lnd !-- ice - semis_ice(i) = 0.97 * (1. - sncovr_ice(i)) + 0.99 * sncovr_ice(i) - alb_ice = 0.55 * (1. - sncovr_ice(i)) + 0.75 * sncovr_ice(i) + semis_ice(i) = 0.97_kind_phys * (one - sncovr_ice(i)) + 0.99_kind_phys * sncovr_ice(i) + alb_ice = 0.55_kind_phys * (one - sncovr_ice(i)) + 0.75_kind_phys * sncovr_ice(i) albdvis_ice(i) = alb_ice albdnir_ice(i) = alb_ice albivis_ice(i) = alb_ice albinir_ice(i) = alb_ice !-- initialize QV mixing ratio at the surface from atm. 1st level - q0 = max(q1(i)/(1.-q1(i)), 1.e-8) ! q1=specific humidity at level 1 (kg/kg) + q0 = max(q1(i)/(one-q1(i)), epsln) ! q1=specific humidity at level 1 (kg/kg) qs1 = rslf(prsl1(i),tsfc_lnd(i)) !* qs1=sat. mixing ratio at level 1 (kg/kg) q0 = min(qs1, q0) sfcqv_lnd(i) = q0 @@ -376,7 +378,7 @@ subroutine lsm_ruc_run & ! inputs real (kind_phys), dimension(:), intent(in) :: xlat_d, xlon_d real (kind_phys), dimension(:), intent(in) :: oro, sigma - real (kind_phys), dimension(:), intent(in) :: & + real (kind_phys), dimension(:), intent(in) :: & & t1, sigmaf, laixy, dlwflx, dswsfc, tg3, & & coszen, prsl1, wind, shdmin, shdmax, & & sfalb_lnd_bck, snoalb, zf, qc, q1, & @@ -548,13 +550,13 @@ subroutine lsm_ruc_run & ! inputs ipr = 10 !-- - testptlat = 68.6 !41.02 !42.05 !39.0 !74.12 !29.5 - testptlon = 298.6 !284.50 !286.75 !280.6 !164.0 !283.0 + testptlat = 68.6_kind_phys + testptlon = 298.6_kind_phys !-- debug_print=.false. - chklowq = 1. + chklowq = one do i = 1, im ! i - horizontal loop flag_ice(i) = .false. @@ -632,9 +634,9 @@ subroutine lsm_ruc_run & ! inputs fractional_seaice = 1 if ( fractional_seaice == 0 ) then - xice_threshold = 0.5 + xice_threshold = 0.5_kind_phys else if ( fractional_seaice == 1 ) then - xice_threshold = 0.15 ! consistent with GFS physics, 0.02 in HRRR + xice_threshold = 0.15_kind_phys ! consistent with GFS physics, 0.02 in HRRR endif nsoil = lsoil_ruc @@ -643,8 +645,8 @@ subroutine lsm_ruc_run & ! inputs ! reassign smcref2 and smcwlt2 to RUC values if(.not. land(i)) then !water and sea ice - smcref2 (i) = 1. - smcwlt2 (i) = 0. + smcref2 (i) = one + smcwlt2 (i) = zero else !land smcref2 (i) = REFSMC(stype(i)) @@ -701,52 +703,52 @@ subroutine lsm_ruc_run & ! inputs do j = jms, jme do i = 1, im ! i - horizontal loop if (flag_iter(i) .and. flag(i)) then - evap_lnd(i) = 0.0 - evap_ice(i) = 0.0 - hflx_lnd (i) = 0.0 - hflx_ice (i) = 0.0 - gflux_lnd(i) = 0.0 - gflux_ice(i) = 0.0 - drain(i) = 0.0 - canopy(i) = max(canopy(i), 0.0) - - evbs (i) = 0.0 - evcw (i) = 0.0 - trans(i) = 0.0 - sbsno(i) = 0.0 + evap_lnd(i) = zero + evap_ice(i) = zero + hflx_lnd (i) = zero + hflx_ice (i) = zero + gflux_lnd(i) = zero + gflux_ice(i) = zero + drain(i) = zero + canopy(i) = max(canopy(i), zero) + + evbs (i) = zero + evcw (i) = zero + trans(i) = zero + sbsno(i) = zero !local i,j arrays - snoh_lnd(i,j) = 0.0 - snoh_ice(i,j) = 0.0 - dew_lnd(i,j) = 0.0 - dew_ice(i,j) = 0.0 - soilm(i,j) = 0.0 - smmax(i,j) = 0.0 - hfx_lnd(i,j) = 0.0 - hfx_ice(i,j) = 0.0 - qfx_lnd(i,j) = 0.0 - qfx_ice(i,j) = 0.0 - lh_lnd(i,j) = 0.0 - lh_ice(i,j) = 0.0 - esnow_lnd(i,j) = 0.0 - esnow_ice(i,j) = 0.0 - sfcexc(i,j) = 0.0 - acceta(i,j) = 0.0 - ssoil_lnd(i,j) = 0.0 - ssoil_ice(i,j) = 0.0 - infiltr(i,j) = 0.0 - precipfr(i,j) = 0.0 - rhosnfr(i,j) = -1.e3 - runoff1(i,j) = 0.0 - runoff2(i,j) = 0.0 + snoh_lnd(i,j) = zero + snoh_ice(i,j) = zero + dew_lnd(i,j) = zero + dew_ice(i,j) = zero + soilm(i,j) = zero + smmax(i,j) = zero + hfx_lnd(i,j) = zero + hfx_ice(i,j) = zero + qfx_lnd(i,j) = zero + qfx_ice(i,j) = zero + lh_lnd(i,j) = zero + lh_ice(i,j) = zero + esnow_lnd(i,j)= zero + esnow_ice(i,j)= zero + sfcexc(i,j) = zero + acceta(i,j) = zero + ssoil_lnd(i,j)= zero + ssoil_ice(i,j)= zero + infiltr(i,j) = zero + precipfr(i,j) = zero + rhosnfr(i,j) = -1.e3_kind_phys + runoff1(i,j) = zero + runoff2(i,j) = zero if(kdt == 1) then - acrunoff(i,j) = 0.0 - snfallac_lnd(i,j) = 0.0 - acsn_lnd(i,j) = 0.0 - snfallac_ice(i,j) = 0.0 - acsn_ice(i,j) = 0.0 - snomlt_lnd(i,j) = 0.0 - snomlt_ice(i,j) = 0.0 + acrunoff(i,j) = zero + snfallac_lnd(i,j) = zero + acsn_lnd(i,j) = zero + snfallac_ice(i,j) = zero + acsn_ice(i,j) = zero + snomlt_lnd(i,j) = zero + snomlt_ice(i,j) = zero endif endif enddo ! i=1,im @@ -756,9 +758,9 @@ subroutine lsm_ruc_run & ! inputs do i = 1, im if (flag_iter(i) .and. flag(i)) then - q0(i) = max(q1(i)/(1.-q1(i)), 1.e-8) !* q1=specific humidity at level 1 (kg/kg) + q0(i) = max(q1(i)/(one-q1(i)), epsln) !* q1=specific humidity at level 1 (kg/kg) - rho(i) = prsl1(i) / (con_rd*t1(i)*(1.0+con_fvirt*q0(i))) + rho(i) = prsl1(i) / (con_rd*t1(i)*(one+con_fvirt*q0(i))) qs1(i) = rslf(prsl1(i),t1(i)) !* qs1=sat. mixing ratio at level 1 (kg/kg) q0 (i) = min(qs1(i), q0(i)) endif ! flag_iter & flag @@ -799,7 +801,7 @@ subroutine lsm_ruc_run & ! inputs do j = jms, jme do i = 1, im ! i - horizontal loop - xice(i,j) = 0. + xice(i,j) = zero if (flag_iter(i) .and. flag(i)) then if (frpcpn) then @@ -813,8 +815,8 @@ subroutine lsm_ruc_run & ! inputs rdlai2d = rdlai - conflx2(i,1,j) = zf(i) * 2. ! factor 2. is needed to get the height of - ! atm. forcing inside RUC LSM (inherited + conflx2(i,1,j) = zf(i) * 2._kind_phys ! factor 2. is needed to get the height of + ! atm. forcing inside RUC LSM (inherited ! from WRF) !> - 2. forcing data (f): @@ -827,7 +829,7 @@ subroutine lsm_ruc_run & ! inputs sfcprs(i,1,j) = prsl1(i) sfctmp(i,1,j) = t1(i) q2(i,1,j) = q0(i) - qcatm(i,1,j) = max(0., qc(i)) + qcatm(i,1,j) = max(zero, qc(i)) rho2(i,1,j) = rho(i) !!\n \a lwdn - lw dw radiation flux at surface (\f$W m^{-2}\f$) @@ -903,10 +905,10 @@ subroutine lsm_ruc_run & ! inputs ! SLMSK0 - SEA(0),LAND(1),ICE(2) MASK if(land(i)) then ! some land - xland(i,j) = 1. - xice_lnd(i,j) = 0. + xland(i,j) = one + xice_lnd(i,j) = zero elseif(flag_ice_uncoupled(i)) then ! some ice - xland(i,j) = 1. + xland(i,j) = one xice(i,j) = fice(i) ! fraction of sea-ice endif else @@ -916,14 +918,14 @@ subroutine lsm_ruc_run & ! inputs if(rdlai2d) then xlai(i,j) = laixy(i) else - xlai(i,j) = 0. + xlai(i,j) = zero endif semis_bck(i,j) = semisbase(i) ! --- units % - shdfac(i,j) = sigmaf(i)*100. - shdmin1d(i,j) = shdmin(i)*100. - shdmax1d(i,j) = shdmax(i)*100. + shdfac(i,j) = sigmaf(i)*100._kind_phys + shdmin1d(i,j) = shdmin(i)*100._kind_phys + shdmax1d(i,j) = shdmax(i)*100._kind_phys if (land(i)) then ! at least some land in the grid cell @@ -954,22 +956,22 @@ subroutine lsm_ruc_run & ! inputs qcg_lnd(i,j) = sfcqc_lnd(i) sncovr_lnd(i,j) = sncovr1_lnd(i) if (kdt == 1) then - sfcems_lnd(i,j) = semisbase(i) * (1.-sncovr_lnd(i,j)) + 0.99 * sncovr_lnd(i,j) + sfcems_lnd(i,j) = semisbase(i) * (one-sncovr_lnd(i,j)) + 0.99_kind_phys * sncovr_lnd(i,j) else sfcems_lnd(i,j) = semis_lnd(i) endif - if(coszen(i) > 0. .and. weasd_lnd(i) < 1.e-4) then + if(coszen(i) > zero .and. weasd_lnd(i) < 1.e-4_kind_phys) then !-- solar zenith angle dependence when no snow ilst=istwe(vtype(i)) ! 1 or 2 - dm = (1.+2.*d(ilst))/(1.+2.*d(ilst)*coszen(i)) + dm = (one+2._kind_phys*d(ilst))/(one+2._kind_phys*d(ilst)*coszen(i)) albbcksol(i) = sfalb_lnd_bck(i)*dm else albbcksol(i) = sfalb_lnd_bck(i) endif ! coszen > 0. snoalb1d_lnd(i,j) = snoalb(i) - albbck_lnd(i,j) = min(0.9,albbcksol(i)) !sfalb_lnd_bck(i) + albbck_lnd(i,j) = min(0.9_kind_phys,albbcksol(i)) !sfalb_lnd_bck(i) !-- spp_lsm @@ -980,29 +982,29 @@ subroutine lsm_ruc_run & ! inputs enddo !-- stochastic perturbation of snow-free albedo, emissivity and veg. !-- fraction - albbck_lnd(i,j) = min(albbck_lnd(i,j) * (1. + 0.4*pattern_spp_lsm(i,1,j)), 1.) - sfcems_lnd(i,j) = min(sfcems_lnd(i,j) * (1. + 0.1*pattern_spp_lsm(i,1,j)), 1.) - shdfac(i,j) = min(0.01*shdfac(i,j) * (1. + 0.33*pattern_spp_lsm(i,1,j)),1.)*100. + albbck_lnd(i,j) = min(albbck_lnd(i,j) * (one + 0.4_kind_phys*pattern_spp_lsm(i,1,j)), one) + sfcems_lnd(i,j) = min(sfcems_lnd(i,j) * (one + 0.1_kind_phys*pattern_spp_lsm(i,1,j)), one) + shdfac(i,j) = min(0.01_kind_phys*shdfac(i,j) * (one + 0.33_kind_phys*pattern_spp_lsm(i,1,j)),one)*100._kind_phys if (kdt == 2) then !-- stochastic perturbation of soil moisture at time step 2 do k = 1, lsoil_ruc - smois(i,k) = smois(i,k)*(1+1.5*pattern_spp_lsm(i,k,j)) + smois(i,k) = smois(i,k)*(one+1.5_kind_phys*pattern_spp_lsm(i,k,j)) enddo endif endif - alb_lnd(i,j) = albbck_lnd(i,j) * (1.-sncovr_lnd(i,j)) + snoalb(i) * sncovr_lnd(i,j) ! sfalb_lnd(i) - solnet_lnd(i,j) = dswsfc(i)*(1.-alb_lnd(i,j)) !..net sw rad flx (dn-up) at sfc in w/m2 + alb_lnd(i,j) = albbck_lnd(i,j) * (one-sncovr_lnd(i,j)) + snoalb(i) * sncovr_lnd(i,j) ! sfalb_lnd(i) + solnet_lnd(i,j) = dswsfc(i)*(one-alb_lnd(i,j)) !..net sw rad flx (dn-up) at sfc in w/m2 cmc(i,j) = canopy(i) ! [mm] soilt_lnd(i,j) = tsurf_lnd(i) ! sanity check for snow temperature tsnow - if (tsnow_lnd(i) > 200. .and. tsnow_lnd(i) < 273.15) then + if (tsnow_lnd(i) > 200._kind_phys .and. tsnow_lnd(i) < con_t0c) then soilt1_lnd(i,j) = tsnow_lnd(i) else soilt1_lnd(i,j) = tsurf_lnd(i) endif - tsnav_lnd(i,j) = min(0.,0.5*(soilt_lnd(i,j) + soilt1_lnd(i,j)) - 273.15) + tsnav_lnd(i,j) = min(zero,0.5_kind_phys*(soilt_lnd(i,j) + soilt1_lnd(i,j)) - con_t0c) do k = 1, lsoil_ruc smsoil (i,k,j) = smois(i,k) slsoil (i,k,j) = sh2o(i,k) @@ -1011,14 +1013,14 @@ subroutine lsm_ruc_run & ! inputs keepfrsoil(i,k,j) = keepfr(i,k) enddo ! land - if (wetness(i) > 0.) then + if (wetness(i) > zero) then wet(i,j) = wetness(i) else - wet(i,j) = max(0.0001,smsoil(i,1,j)/0.3) + wet(i,j) = max(0.0001_kind_phys,smsoil(i,1,j)/0.3_kind_phys) endif chs_lnd (i,j) = ch_lnd(i) * wind(i) ! compute conductance - flhc_lnd(i,j) = chs_lnd(i,j) * rho(i) * con_cp * (1.+0.84*q2(i,1,j)) + flhc_lnd(i,j) = chs_lnd(i,j) * rho(i) * con_cp * (one+0.84_kind_phys*q2(i,1,j)) flqc_lnd(i,j) = chs_lnd(i,j) * rho(i) * wet(i,j) ! for output @@ -1026,7 +1028,7 @@ subroutine lsm_ruc_run & ! inputs chh_lnd(i) = chs_lnd(i,j) * rho(i) ! sneqv_lnd(i,j) = weasd_lnd(i) - snowh_lnd(i,j) = snwdph_lnd(i) * 0.001 ! convert from mm to m + snowh_lnd(i,j) = snwdph_lnd(i) * 0.001_kind_phys ! convert from mm to m if(kdt > 1) then !-- run-total accumulation @@ -1036,38 +1038,38 @@ subroutine lsm_ruc_run & ! inputs endif !> -- sanity checks on sneqv and snowh - if (sneqv_lnd(i,j) /= 0.0_kind_dbl_prec .and. snowh_lnd(i,j) == 0.0_kind_dbl_prec) then + if (sneqv_lnd(i,j) /= zero .and. snowh_lnd(i,j) == zero) then if (debug_print) print *,'bad sneqv_lnd',kdt,i,j,sneqv_lnd(i,j),snowh_lnd(i,j),xlat_d(i),xlon_d(i) - if(sneqv_lnd(i,j) < 1.e-7_kind_dbl_prec.or.soilt_lnd(i,j)>273.15_kind_dbl_prec) then - sneqv_lnd(i,j) = 0._kind_dbl_prec - snowh_lnd(i,j) = 0._kind_dbl_prec + if(sneqv_lnd(i,j) < epsln.or.soilt_lnd(i,j)>con_t0c) then + sneqv_lnd(i,j) = zero + snowh_lnd(i,j) = zero else - sneqv_lnd(i,j) = 300._kind_dbl_prec * snowh_lnd(i,j) ! snow density ~300 kg m-3 + sneqv_lnd(i,j) = 300._kind_phys * snowh_lnd(i,j) ! snow density ~300 kg m-3 endif if (debug_print) print *,'fixed sneqv_lnd',kdt,i,j,sneqv_lnd(i,j),snowh_lnd(i,j) - elseif (snowh_lnd(i,j) /= 0.0_kind_dbl_prec .and. sneqv_lnd(i,j) == 0.0_kind_dbl_prec) then + elseif (snowh_lnd(i,j) /= zero .and. sneqv_lnd(i,j) == zero) then if (debug_print) print *,'bad snowh_lnd',kdt,i,j,sneqv_lnd(i,j),snowh_lnd(i,j),xlat_d(i),xlon_d(i) - if(snowh_lnd(i,j) < 3.e-10_kind_dbl_prec.or.soilt_lnd(i,j)>273.15_kind_dbl_prec) then - snowh_lnd(i,j) = 0._kind_dbl_prec - sneqv_lnd(i,j) = 0._kind_dbl_prec + if(snowh_lnd(i,j) < 3.e-10_kind_dbl_prec.or.soilt_lnd(i,j)>con_t0c) then + snowh_lnd(i,j) = zero + sneqv_lnd(i,j) = zero else snowh_lnd(i,j) = 0.003_kind_dbl_prec * sneqv_lnd(i,j) ! snow density ~300 kg m-3 endif if (debug_print) print *,'fixed snowh_lnd',kdt,i,j,sneqv_lnd(i,j),snowh_lnd(i,j) - elseif (sneqv_lnd(i,j) > 0._kind_dbl_prec .and. snowh_lnd(i,j) > 0._kind_dbl_prec) then + elseif (sneqv_lnd(i,j) > zero .and. snowh_lnd(i,j) > zero) then if (debug_print .and. abs(xlat_d(i)-testptlat).lt.0.5 .and. & abs(xlon_d(i)-testptlon).lt.0.5)then print *,'sneqv_lnd(i,j)/snowh_lnd(i,j)',kdt,i,j,sneqv_lnd(i,j)/snowh_lnd(i,j),sneqv_lnd(i,j),snowh_lnd(i,j) endif - if(sneqv_lnd(i,j)/snowh_lnd(i,j) > 500._kind_dbl_prec) then + if(sneqv_lnd(i,j)/snowh_lnd(i,j) > 500._kind_phys) then if (debug_print .and. abs(xlat_d(i)-testptlat).lt.0.5 .and. & abs(xlon_d(i)-testptlon).lt.0.5)then print *,'large snow density',kdt,i,j,sneqv_lnd(i,j)/snowh_lnd(i,j),sneqv_lnd(i,j),snowh_lnd(i,j) print *,'large snow density lat/lon',kdt,i,j,xlat_d(i),xlon_d(i) endif - if(soilt_lnd(i,j)>273.15_kind_dbl_prec) then - snowh_lnd(i,j) = 0._kind_dbl_prec - sneqv_lnd(i,j) = 0._kind_dbl_prec + if(soilt_lnd(i,j)>con_t0c) then + snowh_lnd(i,j) = zero + sneqv_lnd(i,j) = zero else snowh_lnd(i,j) = 0.002_kind_dbl_prec * sneqv_lnd(i,j) endif @@ -1075,17 +1077,17 @@ subroutine lsm_ruc_run & ! inputs abs(xlon_d(i)-testptlon).lt.0.5)then print *,'fixed large snow density',kdt,i,j,sneqv_lnd(i,j)/snowh_lnd(i,j),sneqv_lnd(i,j),snowh_lnd(i,j) endif - elseif(sneqv_lnd(i,j)/snowh_lnd(i,j) < 58._kind_dbl_prec) then + elseif(sneqv_lnd(i,j)/snowh_lnd(i,j) < 58._kind_phys) then if (debug_print .and. abs(xlat_d(i)-testptlat).lt.0.5 .and. & abs(xlon_d(i)-testptlon).lt.0.5)then print *,'small snow density',kdt,i,j,sneqv_lnd(i,j)/snowh_lnd(i,j),sneqv_lnd(i,j),snowh_lnd(i,j) print *,'small snow density lat/lon',kdt,i,j,xlat_d(i),xlon_d(i) endif - if(soilt_lnd(i,j)>273.15_kind_dbl_prec) then - snowh_lnd(i,j) = 0._kind_dbl_prec - sneqv_lnd(i,j) = 0._kind_dbl_prec + if(soilt_lnd(i,j)>con_t0c) then + snowh_lnd(i,j) = zero + sneqv_lnd(i,j) = zero else - sneqv_lnd(i,j) = 58._kind_dbl_prec * snowh_lnd(i,j) + sneqv_lnd(i,j) = 58._kind_phys * snowh_lnd(i,j) endif if (debug_print .and. abs(xlat_d(i)-testptlat).lt.0.5 .and. & abs(xlon_d(i)-testptlon).lt.0.5)then @@ -1095,8 +1097,8 @@ subroutine lsm_ruc_run & ! inputs endif !-- z0rl is in [cm] - z0_lnd(i,j) = z0rl_lnd(i)/100. - znt_lnd(i,j) = z0rl_lnd(i)/100. + z0_lnd(i,j) = z0rl_lnd(i)/100._kind_phys + znt_lnd(i,j) = z0rl_lnd(i)/100._kind_phys ! Workaround needed for subnormal numbers. This should be ! done after all other sanity checks, in case a sanity check @@ -1105,34 +1107,34 @@ subroutine lsm_ruc_run & ! inputs ! This bug was caught by the UFS gfortran debug-mode ! regression tests, and the fix is necessary to pass those ! tests. - if(abs(snowh_lnd(i,j))<1e-20) then - snowh_lnd(i,j)=0 + if(abs(snowh_lnd(i,j))<1e-20_kind_phys) then + snowh_lnd(i,j)=zero endif - if(abs(sneqv_lnd(i,j))<1e-20) then - sneqv_lnd(i,j)=0 + if(abs(sneqv_lnd(i,j))<1e-20_kind_phys) then + sneqv_lnd(i,j)=zero endif - !if (debug_print) then + if (debug_print) then !-- diagnostics for a land test point with known lat/lon - if (kdt < 10) then + !if (kdt < 10) then if (abs(xlat_d(i)-testptlat).lt.0.5 .and. & abs(xlon_d(i)-testptlon).lt.0.5)then !if(weasd_lnd(i) > 0.) & - print 100,'(ruc_lsm_drv before RUC land call) i=',i, & - ' lat,lon=',xlat_d(i),xlon_d(i), & - 'rainc',rainc(i),'rainnc',rainnc(i),'prcp',prcp(i,j), & - 'graupel',graupel(i),'qc',qc(i),'sfcqv_lnd',sfcqv_lnd(i),& - 'dlwflx',dlwflx(i),'dswsfc',dswsfc(i), & + print 100,'(ruc_lsm_drv before RUC land call) i=',i, & + ' lat,lon=',xlat_d(i),xlon_d(i), & + 'rainc',rainc(i),'rainnc',rainnc(i),'prcp',prcp(i,j), & + 'graupel',graupel(i),'qc',qc(i),'sfcqv_lnd',sfcqv_lnd(i), & + 'dlwflx',dlwflx(i),'dswsfc',dswsfc(i), & 'sncovr1_lnd',sncovr1_lnd(i),'sfalb_lnd_bck',sfalb_lnd_bck(i),& - 'albbcksol',albbcksol(i),'alb_lnd',alb_lnd(i,j), & - 'solnet_lnd',solnet_lnd(i,j),'t1',t1(i), & - 'sfcems_lnd',sfcems_lnd(i,j),'flhc_lnd',flhc_lnd(i,j), & - 'flqc_lnd',flqc_lnd(i,j),'wet',wet(i,j),'cmc',cmc(i,j),& - 'qcg_lnd',qcg_lnd(i,j),'dew',dew_lnd(i,j), & - 'znt_lnd',znt_lnd(i,j),'shdfac',shdfac(i,j), & - 'srflag',srflag(i),'weasd_lnd',weasd_lnd(i), & - 'smsoil1',smsoil(i,1,j),'slsoil',slsoil(i,1,j), & - 'keepfrsoil',keepfrsoil(i,1,j), & + 'albbcksol',albbcksol(i),'alb_lnd',alb_lnd(i,j), & + 'solnet_lnd',solnet_lnd(i,j),'t1',t1(i), & + 'sfcems_lnd',sfcems_lnd(i,j),'flhc_lnd',flhc_lnd(i,j), & + 'flqc_lnd',flqc_lnd(i,j),'wet',wet(i,j),'cmc',cmc(i,j), & + 'qcg_lnd',qcg_lnd(i,j),'dew',dew_lnd(i,j), & + 'znt_lnd',znt_lnd(i,j),'shdfac',shdfac(i,j), & + 'srflag',srflag(i),'weasd_lnd',weasd_lnd(i), & + 'smsoil1',smsoil(i,1,j),'slsoil',slsoil(i,1,j), & + 'keepfrsoil',keepfrsoil(i,1,j), & 'tsurf_lnd',tsurf_lnd(i),'tslb(i,1)',tslb(i,1) endif endif ! debug_print @@ -1259,7 +1261,7 @@ subroutine lsm_ruc_run & ! inputs qsurf_lnd(i) = qsfc_lnd(i,j) tsurf_lnd(i) = soilt_lnd(i,j) tsnow_lnd(i) = soilt1_lnd(i,j) - stm(i) = soilm(i,j) * 1.e-3 ! convert to [m] + stm(i) = soilm(i,j) * 1.e-3_kind_phys ! convert to [m] runof (i) = runoff1(i,j) * rhoh2o ! surface kg m-2 s-1 drain (i) = runoff2(i,j) * rhoh2o ! kg m-2 s-1 @@ -1280,14 +1282,14 @@ subroutine lsm_ruc_run & ! inputs ! --- ... accumulated frozen precipitation (accumulation in lsmruc) snowfallac_lnd(i) = snfallac_lnd(i,j) ! accum kg m-2 ! --- ... unit conversion (from m to mm) - snwdph_lnd(i) = snowh_lnd(i,j) * 1000.0 + snwdph_lnd(i) = snowh_lnd(i,j) * rhoh2o canopy(i) = cmc(i,j) ! mm weasd_lnd(i) = sneqv_lnd(i,j) ! mm sncovr1_lnd(i) = sncovr_lnd(i,j) ! ---- ... outside RUC LSM, roughness uses cm as unit ! (update after snow's effect) - z0rl_lnd(i) = znt_lnd(i,j)*100. + z0rl_lnd(i) = znt_lnd(i,j)*100._kind_phys !-- semis_lnd is with snow effect semis_lnd(i) = sfcems_lnd(i,j) !-- semisbas is without snow effect, but can have vegetation mosaic effect @@ -1333,46 +1335,46 @@ subroutine lsm_ruc_run & ! inputs endif 101 format (";;; ",a,i4,a,2f14.7/(4(a10,'='es9.2))) - edir (i,j) = 0.0 - ec (i,j) = 0.0 - ett (i,j) = 0.0 + edir (i,j) = zero + ec (i,j) = zero + ett (i,j) = zero sncovr_ice(i,j) = sncovr1_ice(i) !-- alb_ice* is computed in setalb called from rrtmg_sw_pre. - snoalb1d_ice(i,j) = 0.75 !alb_ice_snow(i) !0.75 is RAP value for max snow alb on ice - albbck_ice(i,j) = 0.55 !alb_ice_snowfree(i) !0.55 is RAP value for ice alb + snoalb1d_ice(i,j) = 0.75_kind_phys !alb_ice_snow(i) !0.75 is RAP value for max snow alb on ice + albbck_ice(i,j) = 0.55_kind_phys !alb_ice_snowfree(i) !0.55 is RAP value for ice alb alb_ice(i,j) = sfalb_ice(i) - solnet_ice(i,j) = dswsfc(i)*(1.-alb_ice(i,j)) + solnet_ice(i,j) = dswsfc(i)*(one-alb_ice(i,j)) qvg_ice(i,j) = sfcqv_ice(i) - qsfc_ice(i,j) = sfcqv_ice(i)/(1.+sfcqv_ice(i)) + qsfc_ice(i,j) = sfcqv_ice(i)/(one+sfcqv_ice(i)) qsg_ice(i,j) = rslf(prsl1(i),tsurf_ice(i)) qcg_ice(i,j) = sfcqc_ice(i) - semis_bck(i,j) = 0.99 + semis_bck(i,j) = 0.99_kind_phys if (kdt == 1) then - sfcems_ice(i,j) = semisbase(i) * (1.-sncovr_ice(i,j)) + 0.99 * sncovr_ice(i,j) + sfcems_ice(i,j) = semisbase(i) * (one-sncovr_ice(i,j)) + 0.99_kind_phys * sncovr_ice(i,j) else sfcems_ice(i,j) = semis_ice(i) endif cmc(i,j) = canopy(i) ! [mm] soilt_ice(i,j) = tsurf_ice(i) - if (tsnow_ice(i) > 150. .and. tsnow_ice(i) < 273.15) then + if (tsnow_ice(i) > 150._kind_phys .and. tsnow_ice(i) < con_t0c) then soilt1_ice(i,j) = tsnow_ice(i) else soilt1_ice(i,j) = tsurf_ice(i) endif - tsnav_ice(i,j) = min(0.,0.5*(soilt_ice(i,j) + soilt1_ice(i,j)) - 273.15) + tsnav_ice(i,j) = min(zero,0.5_kind_phys*(soilt_ice(i,j) + soilt1_ice(i,j)) - con_t0c) do k = 1, lsoil_ruc stsice (i,k,j) = tsice(i,k) - smice (i,k,j) = 1. - slice (i,k,j) = 0. - smfrice (i,k,j) = 1. - keepfrice(i,k,j) = 1. + smice (i,k,j) = one + slice (i,k,j) = zero + smfrice (i,k,j) = one + keepfrice(i,k,j) = one enddo - wet_ice(i,j) = 1. + wet_ice(i,j) = one chs_ice (i,j) = ch_ice(i) * wind(i) ! compute conductance - flhc_ice(i,j) = chs_ice(i,j) * rho(i) * con_cp * (1. + 0.84*q2(i,1,j)) + flhc_ice(i,j) = chs_ice(i,j) * rho(i) * con_cp * (one + 0.84_kind_phys*q2(i,1,j)) flqc_ice(i,j) = chs_ice(i,j) * rho(i) * wet_ice(i,j) ! for output @@ -1380,8 +1382,8 @@ subroutine lsm_ruc_run & ! inputs chh_ice(i) = chs_ice(i,j) * rho(i) - snowh_ice(i,j) = snwdph_ice(i) * 0.001 ! convert from mm to m - sneqv_ice(i,j) = weasd_ice(i) ! [mm] + snowh_ice(i,j) = snwdph_ice(i) * 0.001_kind_phys ! convert from mm to m + sneqv_ice(i,j) = weasd_ice(i) ! [mm] if(kdt > 1) then snfallac_ice(i,j) = snowfallac_ice(i) acsn_ice(i,j) = acsnow_ice(i) @@ -1389,25 +1391,25 @@ subroutine lsm_ruc_run & ! inputs endif !> -- sanity checks on sneqv and snowh - if (sneqv_ice(i,j) /= 0.0 .and. snowh_ice(i,j) == 0.0) then - snowh_ice(i,j) = 0.003 * sneqv_ice(i,j) ! snow density ~300 kg m-3 + if (sneqv_ice(i,j) /= zero .and. snowh_ice(i,j) == zero) then + snowh_ice(i,j) = 0.003_kind_phys * sneqv_ice(i,j) ! snow density ~300 kg m-3 endif - if (snowh_ice(i,j) /= 0.0 .and. sneqv_ice(i,j) == 0.0) then - sneqv_ice(i,j) = 300. * snowh_ice(i,j) ! snow density ~300 kg m-3 + if (snowh_ice(i,j) /= zero .and. sneqv_ice(i,j) == zero) then + sneqv_ice(i,j) = 300._kind_phys * snowh_ice(i,j) ! snow density ~300 kg m-3 endif - if (sneqv_ice(i,j) > 0. .and. snowh_ice(i,j) > 0.) then - if(sneqv_ice(i,j)/snowh_ice(i,j) > 950.) then - sneqv_ice(i,j) = 300. * snowh_ice(i,j) + if (sneqv_ice(i,j) > zero .and. snowh_ice(i,j) > zero) then + if(sneqv_ice(i,j)/snowh_ice(i,j) > 950._kind_phys) then + sneqv_ice(i,j) = 300._kind_phys * snowh_ice(i,j) endif endif - z0_ice(i,j) = z0rl_ice(i)/100. - znt_ice(i,j) = z0rl_ice(i)/100. + z0_ice(i,j) = z0rl_ice(i)/100._kind_phys + znt_ice(i,j) = z0rl_ice(i)/100._kind_phys - runoff1(i,j) = 0. - runoff2(i,j) = 0. + runoff1(i,j) = zero + runoff2(i,j) = zero ! Workaround needed for subnormal numbers. This should be ! done after all other sanity checks, in case a sanity check @@ -1415,11 +1417,11 @@ subroutine lsm_ruc_run & ! inputs ! ! Although this bug has not been triggered yet, it is expected ! to be, like the _lnd variants many lines up from here. - if(abs(snowh_ice(i,j))<1e-20) then - snowh_ice(i,j)=0 + if(abs(snowh_ice(i,j))<1e-20_kind_phys) then + snowh_ice(i,j)=zero endif - if(abs(sneqv_ice(i,j))<1e-20) then - sneqv_ice(i,j)=0 + if(abs(sneqv_ice(i,j))<1e-20_kind_phys) then + sneqv_ice(i,j)=zero endif !> - Call RUC LSM lsmruc() for ice. @@ -1482,7 +1484,7 @@ subroutine lsm_ruc_run & ! inputs snwdph_ice(i) = snowh_ice(i,j) * rhoh2o weasd_ice(i) = sneqv_ice(i,j) ! kg m-2 sncovr1_ice(i) = sncovr_ice(i,j) - z0rl_ice(i) = znt_ice(i,j)*100. ! cm + z0rl_ice(i) = znt_ice(i,j)*100._kind_phys ! cm !-- semis_ice is with snow effect semis_ice(i) = sfcems_ice(i,j) !-- sfalb_ice is with snow effect @@ -1497,11 +1499,11 @@ subroutine lsm_ruc_run & ! inputs do k = 1, lsoil_ruc tsice(i,k) = stsice(i,k,j) if(.not. frac_grid .or. .not. land(i)) then - smois(i,k) = 1. - sh2o(i,k) = 0. + smois(i,k) = one + sh2o(i,k) = zero tslb(i,k) = stsice(i,k,j) - keepfr(i,k) = 1. - smfrkeep(i,k) = 1. + keepfr(i,k) = one + smfrkeep(i,k) = one endif enddo if(debug_print) then @@ -1587,12 +1589,12 @@ subroutine rucinit (lsm_cold_start, im, lsoil_ruc, lsoil, & ! in implicit none - logical, intent(in ) :: lsm_cold_start - integer, intent(in ) :: lsm - integer, intent(in ) :: lsm_ruc - integer, intent(in ) :: im, nlev - integer, intent(in ) :: lsoil_ruc - integer, intent(in ) :: lsoil + logical, intent(in ) :: lsm_cold_start + integer, intent(in ) :: lsm + integer, intent(in ) :: lsm_ruc + integer, intent(in ) :: im, nlev + integer, intent(in ) :: lsoil_ruc + integer, intent(in ) :: lsoil real (kind_phys), intent(in ) :: min_seaice real (kind_phys), dimension(im), intent(in ) :: slmsk real (kind_phys), dimension(im), intent(in ) :: landfrac @@ -1605,8 +1607,8 @@ subroutine rucinit (lsm_cold_start, im, lsoil_ruc, lsoil, & ! in real (kind_phys), dimension(im,lsoil), intent(in ) :: stc ! Noah real (kind_phys), dimension(im,lsoil), intent(in ) :: slc ! Noah - integer, dimension(im), intent(in) :: stype, vtype - real (kind_phys), dimension(im), intent(inout) :: wetness + integer, dimension(im), intent(in) :: stype, vtype + real (kind_phys), dimension(im), intent(inout) :: wetness real (kind_phys), dimension(im,lsoil_ruc), intent(inout) :: smois! ruc real (kind_phys), dimension(im,lsoil_ruc), intent(inout) :: tslb ! ruc real (kind_phys), dimension(im,lsoil_ruc), intent(inout) :: sh2o ! ruc @@ -1742,7 +1744,7 @@ subroutine rucinit (lsm_cold_start, im, lsoil_ruc, lsoil, & ! in write (0,*)'tskin_wat(ipr) =', tskin_wat(ipr) write (0,*)'vtype(ipr) =', ipr, vtype(ipr) write (0,*)'stype(ipr) =', ipr, stype(ipr) - write (0,*)'its,ite,jts,jte =',its,ite,jts,jte + write (0,*)'its,ite,jts,jte =', its,ite,jts,jte endif @@ -1753,14 +1755,14 @@ subroutine rucinit (lsm_cold_start, im, lsoil_ruc, lsoil, & ! in tbot(i,j) = tg3(i) ivgtyp(i,j) = vtype(i) isltyp(i,j) = stype(i) - if (landfrac(i) > 0. .or. fice(i) > 0.) then + if (landfrac(i) > zero .or. fice(i) > zero) then !-- land or ice tsk(i,j) = tskin_lnd(i) - landmask(i,j)=1. + landmask(i,j)=one else !-- water tsk(i,j) = tskin_wat(i) - landmask(i,j)=0. + landmask(i,j)=zero endif ! land(i) enddo @@ -1772,30 +1774,30 @@ subroutine rucinit (lsm_cold_start, im, lsoil_ruc, lsoil, & ! in do i=its,ite ! i = horizontal loop st_input(i,1,j)=tsk(i,j) - sm_input(i,1,j)=0. + sm_input(i,1,j)=zero !--- initialize smcwlt2 and smcref2 with Noah values - if(landfrac(i) > 0.) then + if(landfrac(i) > zero) then smcref2 (i) = REFSMCnoah(stype(i)) smcwlt2 (i) = WLTSMCnoah(stype(i)) else - smcref2 (i) = 1. - smcwlt2 (i) = 0. + smcref2 (i) = one + smcwlt2 (i) = zero endif do k=1,lsoil st_input(i,k+1,j)=stc(i,k) ! convert volumetric soil moisture to SWI (soil wetness index) - if(landfrac(i) > 0. .and. swi_init) then - sm_input(i,k+1,j)=min(1.,max(0.,(smc(i,k) - smcwlt2(i))/ & + if(landfrac(i) > zero .and. swi_init) then + sm_input(i,k+1,j)=min(one,max(zero,(smc(i,k) - smcwlt2(i))/ & (smcref2(i) - smcwlt2(i)))) else sm_input(i,k+1,j)=smc(i,k) endif enddo do k=lsoil+2,lsoil_ruc * 3 - st_input(i,k,j)=0. - sm_input(i,k,j)=0. + st_input(i,k,j)=zero + sm_input(i,k,j)=zero enddo enddo ! i - horizontal loop @@ -1821,7 +1823,7 @@ subroutine rucinit (lsm_cold_start, im, lsoil_ruc, lsoil, & ! in do j=jts,jte do i=its,ite - if (landfrac(i) == 1.) then + if (landfrac(i) == one) then !-- land do k=1,lsoil_ruc ! convert from SWI to RUC volumetric soil moisture @@ -1837,7 +1839,7 @@ subroutine rucinit (lsm_cold_start, im, lsoil_ruc, lsoil, & ! in else !-- ice or water do k=1,lsoil_ruc - soilm(i,k,j) = 1. + soilm(i,k,j) = one soiltemp(i,k,j) = dumt(i,k,j) enddo ! k endif ! land @@ -1862,20 +1864,20 @@ subroutine rucinit (lsm_cold_start, im, lsoil_ruc, lsoil, & ! in do j=jts,jte do i=its,ite - if (landfrac(i) > 0.) then + if (landfrac(i) > zero) then ! initialize factor do k=1,lsoil_ruc - factorsm(k)=1. + factorsm(k)=one enddo ! RUC soil moisture bucket - smtotr(i,j)=0. + smtotr(i,j)=zero do k=1,lsoil_ruc -1 smtotr(i,j)=smtotr(i,j) + soilm(i,k,j) *dzs(k) enddo ! Noah soil moisture bucket - smtotn(i,j)=smc(i,1)*0.1 + smc(i,2)*0.2 + smc(i,3)*0.7 + smc(i,4)*1. + smtotn(i,j)=smc(i,1)*0.1_kind_phys + smc(i,2)*0.2_kind_phys + smc(i,3)*0.7_kind_phys + smc(i,4)*one if(debug_print) then if(i==ipr) then @@ -1887,16 +1889,16 @@ subroutine rucinit (lsm_cold_start, im, lsoil_ruc, lsoil, & ! in ! RUC soil moisture correction to match Noah soil moisture bucket do k=1,lsoil_ruc-1 - soilm(i,k,j) = max(0.02,soilm(i,k,j)*smtotn(i,j)/(0.9*smtotr(i,j))) + soilm(i,k,j) = max(0.02_kind_phys,soilm(i,k,j)*smtotn(i,j)/(0.9_kind_phys*smtotr(i,j))) enddo if( soilm(i,2,j) > soilm(i,1,j) .and. soilm(i,3,j) > soilm(i,2,j)) then ! typical for daytime, no recent precip - factorsm(1) = 0.75 - factorsm(2) = 0.8 - factorsm(3) = 0.85 - factorsm(4) = 0.9 - factorsm(5) = 0.95 + factorsm(1) = 0.75_kind_phys + factorsm(2) = 0.8_kind_phys + factorsm(3) = 0.85_kind_phys + factorsm(4) = 0.9_kind_phys + factorsm(5) = 0.95_kind_phys endif do k=1,lsoil_ruc soilm(i,k,j) = factorsm(k) * soilm(i,k,j) @@ -1904,7 +1906,7 @@ subroutine rucinit (lsm_cold_start, im, lsoil_ruc, lsoil, & ! in if(debug_print) then if(i==ipr) write (0,*)'after smois=',i,j,soilm(i,:,j) endif - smtotr(i,j) = 0. + smtotr(i,j) = zero do k=1,lsoil_ruc - 1 smtotr(i,j)=smtotr(i,j) + soilm(i,k,j) *dzs(k) enddo From 486877983e1fdb5153b5b3ebdf4956043f29041d Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 23 Mar 2023 18:29:22 +0000 Subject: [PATCH 186/380] bug fixes and updates from develop --- CMakeLists.txt | 6 ++++-- physics/mp_nssl.F90 | 5 ++++- physics/mp_nssl.meta | 40 ++++++++++++++++++++++++++++++++-------- physics/noahmpdrv.F90 | 7 ------- 4 files changed, 40 insertions(+), 18 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 482081614..950bd048e 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -6,7 +6,7 @@ project(ccpp_physics #------------------------------------------------------------------------------ set(PACKAGE "ccpp-physics") -set(AUTHORS "Grant Firl" "Dom Heinzeller" "Man Zhang" "Mike Kavulich" "Chunxi Zhang") +set(AUTHORS "Grant Firl" "Dustin Swales" "Man Zhang" "Mike Kavulich" ) #------------------------------------------------------------------------------ # Set OpenMP flags for C/C++/Fortran @@ -183,7 +183,9 @@ set_target_properties(ccpp_physics PROPERTIES VERSION ${PROJECT_VERSION} target_include_directories(ccpp_physics PUBLIC $) -target_link_libraries(ccpp_physics PUBLIC w3emc::w3emc_d NetCDF::NetCDF_Fortran) +target_link_libraries(ccpp_physics PUBLIC w3emc::w3emc_d + sp::sp_d + NetCDF::NetCDF_Fortran) # Define where to install the library install(TARGETS ccpp_physics diff --git a/physics/mp_nssl.F90 b/physics/mp_nssl.F90 index d6de5a0a0..4e0e323ce 100644 --- a/physics/mp_nssl.F90 +++ b/physics/mp_nssl.F90 @@ -31,6 +31,7 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & con_t0c, con_cliq, con_csol, con_eps, & imp_physics, imp_physics_nssl, & nssl_cccn, nssl_alphah, nssl_alphahl, & + nssl_alphar, nssl_ehw0_in, nssl_ehlw0_in, & nssl_ccn_on, nssl_hail_on, nssl_invertccn ) @@ -52,6 +53,7 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & integer, intent(in) :: imp_physics integer, intent(in) :: imp_physics_nssl real(kind_phys), intent(in) :: nssl_cccn, nssl_alphah, nssl_alphahl + real(kind_phys), intent(in) :: nssl_alphar, nssl_ehw0_in, nssl_ehlw0_in logical, intent(in) :: nssl_ccn_on, nssl_hail_on, nssl_invertccn ! Local variables: dimensions used in nssl_init @@ -115,6 +117,7 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & nssl_params(11) = 0 ! nssl_ipelec_tmp nssl_params(12) = 11 ! nssl_isaund nssl_params(13) = 0 ! 1= turn on cccna; 0 = turn off + nssl_params(14) = nssl_alphar nssl_qccn = nssl_cccn/1.225 ! if (mpirank==mpiroot) then @@ -129,7 +132,7 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & ! write(0,*) 'call nssl_2mom_init' CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0, & - ihvol=ihailv,errmsg=errmsg,errflg=errflg,myrank=mpirank,mpiroot=mpiroot) + ihvol=ihailv,nssl_ehw0=nssl_ehw0_in,nssl_ehlw0=nssl_ehlw0_in,errmsg=errmsg,errflg=errflg,myrank=mpirank,mpiroot=mpiroot) ! For restart runs, the init is done here if (restart) then diff --git a/physics/mp_nssl.meta b/physics/mp_nssl.meta index 9b913da2b..c7e398f0a 100644 --- a/physics/mp_nssl.meta +++ b/physics/mp_nssl.meta @@ -151,7 +151,7 @@ intent = in [nssl_alphah] standard_name = nssl_alpha_graupel - long_name = graupel PSD shape parameter in NSSL micro + long_name = graupel particle size distribution(PSD) shape parameter in NSSL microphysics scheme units = none dimensions = () type = real @@ -159,7 +159,31 @@ intent = in [nssl_alphahl] standard_name = nssl_alpha_hail - long_name = hail PSD shape parameter in NSSL micro + long_name = hail particle size distribution(PSD) shape parameter in NSSL microphysics scheme + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[nssl_alphar] + standard_name = nssl_alpha_rain + long_name = rain particle size distribution(PSD) shape parameter in NSSL microphysics scheme + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[nssl_ehw0_in] + standard_name = nssl_graupel_collection_efficiency + long_name = graupel droplet collection efficiency in NSSL microphysics scheme + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[nssl_ehlw0_in] + standard_name = nssl_hail_collection_efficiency + long_name = hail droplet collection efficiency in NSSL microphysics scheme units = none dimensions = () type = real @@ -167,21 +191,21 @@ intent = in [nssl_ccn_on] standard_name = nssl_ccn_on - long_name = CCN activation flag in NSSL micro + long_name = CCN activation flag in NSSL microphysics scheme units = flag dimensions = () type = logical intent = in [nssl_hail_on] standard_name = nssl_hail_on - long_name = hail activation flag in NSSL micro + long_name = hail activation flag in NSSL microphysics scheme units = flag dimensions = () type = logical intent = in [nssl_invertccn] standard_name = nssl_invertccn - long_name = flag to invert CCN in NSSL micro + long_name = flag to invert CCN in NSSL microphysics scheme units = flag dimensions = () type = logical @@ -571,21 +595,21 @@ intent = in [nssl_ccn_on] standard_name = nssl_ccn_on - long_name = CCN activation flag in NSSL micro + long_name = CCN activation flag in NSSL microphysics scheme units = flag dimensions = () type = logical intent = in [nssl_hail_on] standard_name = nssl_hail_on - long_name = hail activation flag in NSSL micro + long_name = hail activation flag in NSSL microphysics scheme units = flag dimensions = () type = logical intent = in [nssl_invertccn] standard_name = nssl_invertccn - long_name = flag to invert CCN in NSSL micro + long_name = flag to invert CCN in NSSL microphysics scheme units = flag dimensions = () type = logical diff --git a/physics/noahmpdrv.F90 b/physics/noahmpdrv.F90 index ac3867c1c..771cfa0f6 100644 --- a/physics/noahmpdrv.F90 +++ b/physics/noahmpdrv.F90 @@ -77,13 +77,6 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, me, isot, ivegsrc, & return end if - if (.not. do_mynnsfclay .and. do_mynnedmf) then - errmsg = 'Problem : do_mynnsfclay = .false.' // & - 'but mynnpbl is .true.. Exiting ...' - errflg = 1 - return - end if - if ( do_mynnsfclay .and. .not. do_mynnedmf) then errmsg = 'Problem : do_mynnsfclay = .true.' // & 'but mynnpbl is .false.. Exiting ...' From f54132caf2f96c4b44d28cfeea6e88c83d260521 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 23 Mar 2023 19:36:09 +0000 Subject: [PATCH 187/380] restore a disabled debug check, and require debugging to be turned on to print it --- physics/module_mp_nssl_2mom.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/physics/module_mp_nssl_2mom.F90 b/physics/module_mp_nssl_2mom.F90 index 884bf657d..d190e94b4 100644 --- a/physics/module_mp_nssl_2mom.F90 +++ b/physics/module_mp_nssl_2mom.F90 @@ -8119,8 +8119,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ! write(0,*) 'dtmps,dtmph = ',dtmps,dtmph ! ENDIF -! 1.2 GB of messages is a bit too much. - IF ( .false. ) then ! .not. dtmp(ix,kz) .lt. 1.e30 .or. dbz(ix,jy,kz) > 190.0 + IF ( ndebug>1 .and. .not. dtmp(ix,kz) .lt. 1.e30 .or. dbz(ix,jy,kz) > 190.0 ) THEN ! IF ( ix == 31 .and. kz == 20 .and. jy == 23 ) THEN ! write(0,*) 'my_rank = ',my_rank write(0,*) 'ix,jy,kz = ',ix,jy,kz From 3105170f4a62487a4179034d7fa1bfc5341f521d Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Thu, 23 Mar 2023 19:42:16 +0000 Subject: [PATCH 188/380] Changes related to kind_phys. --- physics/sfc_diag.f | 53 +++++++++++++++++++++++----------------------- 1 file changed, 27 insertions(+), 26 deletions(-) diff --git a/physics/sfc_diag.f b/physics/sfc_diag.f index be648bd61..7a3defa62 100644 --- a/physics/sfc_diag.f +++ b/physics/sfc_diag.f @@ -30,9 +30,14 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & & f10m,u10m,v10m,t2m,q2m,dpt2m,errmsg,errflg & & ) ! - use machine , only : kind_phys + use machine , only : kind_phys, kind_dbl_prec use funcphys, only : fpvs + use physcons, only : con_t0c implicit none + + real (kind_phys), parameter :: zero = 0._kind_dbl_prec + real (kind_phys), parameter :: one = 1._kind_dbl_prec + real (kind_phys), parameter :: qmin = 1.0e-8_kind_dbl_prec ! integer, intent(in) :: im, lsm, lsm_ruc logical, intent(in) :: thsfc_loc ! Flag for reference pot. temp. @@ -52,7 +57,6 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & ! locals ! logical :: debug_print - real(kind=kind_phys), parameter :: qmin=1.0e-8 real(kind=kind_phys) :: q1c, qv, tem, qv1, th2m, x2m, rho real(kind=kind_phys) :: dT, dQ, qsfcmr, qsfcprox, ff, fac, dz1 real(kind=kind_phys) :: t2_alt, q2_alt @@ -70,8 +74,8 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & errflg = 0 !-- - testptlat = 35.3 !41.02 !42.05 !39.0 !74.12 !29.5 - testptlon = 273.0 !284.50 !286.75 !280.6 !164.0 !283.0 + testptlat = 35.3_kind_phys + testptlon = 273.0_kind_phys !-- debug_print = .false. ! @@ -87,23 +91,19 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & do i = 1, im f10m(i) = fm10(i) / fm(i) -! f10m(i) = min(f10m(i),1.) u10m(i) = f10m(i) * u1(i) v10m(i) = f10m(i) * v1(i) fhi = fh2(i) / fh(i) -! t2m(i) = tskin(i)*(1. - fhi) + t1(i) * prslki(i) * fhi -! sig2k = 1. - (grav+grav) / (cp * t2m(i)) -! t2m(i) = t2m(i) * sig2k - wrk = 1.0 - fhi + wrk = one - fhi - thcon = (1.e5/ps(i))**con_rocp + thcon = (1.e5_kind_dbl_prec/ps(i))**con_rocp !-- make sure 1st level q is not higher than saturated value qss = fpvs(t1(i)) qss = eps * qss / (ps(i) + epsm1 * qss) q1c = min(q1(i),qss) ! lev 1 spec. humidity - qv1 = q1c / (1. - q1c) ! lev 1 mixing ratio - qsfcmr = qsurf(i)/(1. - qsurf(i)) ! surface mixing ratio + qv1 = q1c / (one - q1c) ! lev 1 mixing ratio + qsfcmr = qsurf(i)/(one - qsurf(i)) ! surface mixing ratio chs = cdq(i) * wind(i) cqs = chs chs2 = ust(i)*con_karman/fh2(i) @@ -118,7 +118,7 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & else ! Use potential temperature referenced to 1000 hPa t2m(i) = tskin(i)*wrk + t1(i)*fhi - (grav+grav)/cp endif - if(evap(i) >= 0.) then ! for evaporation>0, use inferred qsurf to deduce q2m + if(evap(i) >= zero) then ! for evaporation>0, use inferred qsurf to deduce q2m q2m(i) = qsurf(i)*wrk + max(qmin,q1c)*fhi else ! for dew formation, use saturated q at tskin qss = fpvs(tskin(i)) @@ -136,7 +136,7 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & t2m(i) = th2m/thcon x2m = max(qmin,qsfcprox - evap(i)/cqs2) ! mix. ratio - q2m(i) = x2m/(1. + x2m) ! spec. humidity + q2m(i) = x2m/(one + x2m) ! spec. humidity endif ! flux method if(diag_log) then @@ -144,24 +144,24 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & dT = t1(i) - tskin(i) dQ = qv1 - qsfcmr dz1= zf(i) ! level of atm. forcing - IF (dT > 0.) THEN - ff = MIN(MAX(1.-dT/10.,0.01), 1.0) + IF (dT > zero) THEN + ff = MIN(MAX(one-dT/10._kind_phys,0.01_kind_phys), one) !for now, set zt = 0.05 - fac = LOG((2. + .05)/(0.05 + ff))/ & - & LOG((dz1 + .05)/(0.05 + ff)) + fac = LOG((2._kind_phys + .05_kind_phys)/(0.05_kind_phys + & + & ff))/LOG((dz1 + .05_kind_phys)/(0.05_kind_phys + ff)) T2_alt = tskin(i) + fac * dT ELSE !no alternatives (yet) for unstable conditions T2_alt = t2m(i) ENDIF - IF (dQ > 0.) THEN - ff = MIN(MAX(1.-dQ/0.003,0.01), 1.0) + IF (dQ > zero) THEN + ff = MIN(MAX(one-dQ/0.003_kind_phys,0.01_kind_phys), one) !-- for now, set zt = 0.05 - fac = LOG((2. + .05)/(0.05 + ff))/ & - & LOG((dz1 + .05)/(0.05 + ff)) + fac = LOG((2._kind_phys + .05_kind_phys)/(0.05_kind_phys + & + & ff))/LOG((dz1 + .05_kind_phys)/(0.05_kind_phys + ff)) Q2_alt = qsfcmr + fac * dQ ! mix. ratio - Q2_alt = Q2_alt/(1. + Q2_alt) ! spec. humidity + Q2_alt = Q2_alt/(one + Q2_alt) ! spec. humidity ELSE !no alternatives (yet) for unstable conditions Q2_alt = q2m(i) @@ -190,14 +190,15 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & ! This prevents unrealistic values when QFX is not mostly surface ! flux because calculation is based on surface flux only. ! Problems occurred in transition periods and weak winds and vegetation source - q2m(i) = min(q2m(i),1.05*q1c) ! works if qsurf > q1c, evaporation + q2m(i) = min(q2m(i),1.05_kind_dbl_prec*q1c) ! works if qsurf > q1c, evaporation endif !-- Compute dew point, using vapor pressure qv = max(qmin,(q2m(i)/(1.-q2m(i)))) - tem = max(ps(i) * qv/( eps - epsm1 *qv), 1.e-8) - dpt2m(i) = 243.5/( ( 17.67 / log(tem/611.2) ) - 1.) + 273.14 + tem = max(ps(i) * qv/( eps - epsm1 *qv), qmin) + dpt2m(i) = 243.5_kind_dbl_prec/( ( 17.67_kind_dbl_prec / & + & log(tem/611.2_kind_dbl_prec) ) - one) + con_t0c dpt2m(i) = min(dpt2m(i),t2m(i)) From e10de25b750629da21140fc78afcefff334ac52b Mon Sep 17 00:00:00 2001 From: Lisa Bengtsson Date: Thu, 23 Mar 2023 19:58:28 +0000 Subject: [PATCH 189/380] Add (1-sigmab)^2 scaling to cu_unified deep and shallow. Use generic tendency due to PBL scheme to allow the scheme to work with other PBL schemes outside of satmedmfvdifq. Update computation of total cloud condensate to not be scaled by normalized mass-flux --- physics/cu_unified_deep.F90 | 23 +++++++++++++++-------- physics/cu_unified_driver.F90 | 18 +++++++++++++----- physics/cu_unified_driver.meta | 6 +++--- physics/cu_unified_sh.F90 | 11 ++++++++++- physics/samfdeepcnv.f | 12 +++++++++--- physics/samfdeepcnv.meta | 6 +++--- physics/samfshalcnv.f | 13 ++++++++++--- physics/samfshalcnv.meta | 6 +++--- physics/satmedmfvdifq.F | 24 ++++-------------------- physics/satmedmfvdifq.meta | 8 -------- 10 files changed, 70 insertions(+), 57 deletions(-) diff --git a/physics/cu_unified_deep.F90 b/physics/cu_unified_deep.F90 index 6fa0d46f1..bd6b73fd7 100644 --- a/physics/cu_unified_deep.F90 +++ b/physics/cu_unified_deep.F90 @@ -45,9 +45,9 @@ module cu_unified_deep contains -!>\defgroup cu_unified_deep_group Grell-Freitas Deep Convection Module +!>\defgroup cu_unified_deep_group Unified Deep Convection Module !>\ingroup cu_unified_group -!! This is Grell-Freitas deep convection scheme module +!! This is Unified deep convection scheme module !> @{ integer function my_maxloc1d(A,N) !$acc routine vector @@ -70,8 +70,8 @@ integer function my_maxloc1d(A,N) return end function my_maxloc1d -!>Driver for the deep or congestus GF routine. -!! \section general_unified_deep Grell-Freitas Deep Convection General Algorithm +!>Driver for the deep or congestus routine. +!! \section general_unified_deep Unified Deep Convection General Algorithm subroutine cu_unified_deep_run( & itf,ktf,its,ite, kts,kte & ,flag_init & @@ -4183,7 +4183,7 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & real(kind=kind_phys) :: & clos_wei,dtt,dp,dtq,dtqc,dtpw,dtpwd real(kind=kind_phys), dimension (its:ite) :: & - pre2,xmb_ave,pwtot + pre2,xmb_ave,pwtot,scaldfunc !$acc declare create(pre2,xmb_ave,pwtot) ! character *(*), intent (in) :: & @@ -4201,6 +4201,7 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & do i=its,itf pre(i)=0. xmb(i)=0. + scaldfunc(i)=0. enddo do i=its,itf if(ierr(i).eq.0)then @@ -4218,10 +4219,16 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & !LB: Prognostic closure: if(progsigma)then - + do i=its,itf if(ierr(i).eq.0)then - xmb(i)=xf_progsigma(i) + if (dx(i) < 10.E3) then + scaldfunc(i)=(1.-sigmab(i))*(1.-sigmab(i)) + scaldfunc(i) = max(min(scaldfunc(i), 1.0), 0.) + else + scaldfunc(i) = 1.0 + endif + xmb(i)=scaldfunc(i)*xf_progsigma(i) endif enddo @@ -6030,7 +6037,7 @@ subroutine calculate_updraft_velocity(its,itf,ktf,ite,kts,kte,ierr,progsigma, do i = 1, itf if (ierr(i)==0) then if(k > kbcon(i) .and. k < ktcon(i)) then - zdqca(i,k)=clw_all(i,k)*zu(i,k) + zdqca(i,k)=clw_all(i,k) endif endif enddo diff --git a/physics/cu_unified_driver.F90 b/physics/cu_unified_driver.F90 index 3439a9a39..2ca1fe687 100644 --- a/physics/cu_unified_driver.F90 +++ b/physics/cu_unified_driver.F90 @@ -105,12 +105,13 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& index_of_process_scnv, index_of_process_dcnv, ntqv, ntcw, ntiw !$acc declare copyin(dtidx) real(kind=kind_phys), dimension( : , : ), intent(in ) :: forcet,forceqv_spechum,w,phil,delp - real(kind=kind_phys), dimension ( : , : ), intent(in ) :: sigmain,qmicro,tmf + real(kind=kind_phys), dimension ( : , : ), intent(in ) :: sigmain,qmicro real(kind=kind_phys), dimension( : , : ), intent(inout ) :: t,us,vs real(kind=kind_phys), dimension( : , : ), intent(inout ) :: qci_conv real(kind=kind_phys), dimension( : , : ), intent(out ) :: cnvw_moist,cnvc real(kind=kind_phys), dimension ( : , : ), intent(out ) :: sigmaout real(kind=kind_phys), dimension( : , : ), intent(inout ) :: cliw, clcw + real(kind=kind_phys), dimension ( : , : , :), intent(in ) :: tmf !$acc declare copyin(forcet,forceqv_spechum,w,phil) !$acc declare copy(t,us,vs,qci_conv,cliw, clcw) !$acc declare copyout(cnvw_moist,cnvc) @@ -172,7 +173,7 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& real(kind=kind_phys), dimension (im,km) :: outts,outqs,outqcs,outu,outv,outus,outvs real(kind=kind_phys), dimension (im,km) :: outtm,outqm,outqcm,submm,cupclwm real(kind=kind_phys), dimension (im,km) :: cnvwt,cnvwts,cnvwtm - real(kind=kind_phys), dimension (im,km) :: hco,hcdo,zdo,zdd,hcom,hcdom,zdom + real(kind=kind_phys), dimension (im,km) :: hco,hcdo,zdo,zdd,hcom,hcdom,zdom,tmfq real(kind=kind_phys), dimension (km) :: zh real(kind=kind_phys), dimension (im) :: tau_ecmwf,edt,edtm,edtd,ter11,aa0,xlandi real(kind=kind_phys), dimension (im) :: pret,prets,pretm,hexec @@ -465,6 +466,13 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& gdc2(i,k,1)=0. enddo enddo + + do k=kts,kte + do i=its,ite + tmfq(i,k)=tmf(i,k,1) + enddo + enddo + ierr(:)=0 ierrm(:)=0 ierrs(:)=0 @@ -638,7 +646,7 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ! turning off shallow convection for grid points zus,xmbs,kbcons,ktops,k22s,ierrs,ierrcs, & !Prog closure - flag_init, flag_restart,fv,r_d,delp,tmf,qmicro, & + flag_init, flag_restart,fv,r_d,delp,tmfq,qmicro, & forceqv_spechum,sigmain,sigmaout,progsigma, & ! output tendencies outts,outqs,outqcs,outus,outvs,cnvwt,prets,cupclws, & @@ -679,7 +687,7 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,forcing2 & ,t2d & ,q2d & - ,tmf & + ,tmfq & ,qmicro & ,forceqv_spechum & ,sigmain & @@ -770,7 +778,7 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,forcing & ,t2d & ,q2d & - ,tmf & + ,tmfq & ,qmicro & ,forceqv_spechum & ,sigmain & diff --git a/physics/cu_unified_driver.meta b/physics/cu_unified_driver.meta index 1990ad59a..31f4b0ab7 100644 --- a/physics/cu_unified_driver.meta +++ b/physics/cu_unified_driver.meta @@ -213,10 +213,10 @@ kind = kind_phys intent = in [tmf] - standard_name = instantaneous_tendency_of_specific_humidity_due_to_PBL - long_name = instantaneous_tendency_of_specific_humidity_due_to_PBL + standard_name = tendency_of_vertically_diffused_tracer_concentration + long_name = updated tendency of the tracers due to vertical diffusion in PBL scheme units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_vertical_diffusion_tracers) type = real kind = kind_phys intent = in diff --git a/physics/cu_unified_sh.F90 b/physics/cu_unified_sh.F90 index 3d4426b81..c9b3bf271 100644 --- a/physics/cu_unified_sh.F90 +++ b/physics/cu_unified_sh.F90 @@ -220,7 +220,8 @@ subroutine cu_unified_sh_run ( & flux_tun,hkbo,xhkb, & rand_vmas,xmbmax,xmb, & cap_max,entr_rate, & - cap_max_increment,lambau,wc,omegac,sigmab + cap_max_increment,lambau,wc,omegac,sigmab, & + scaldfunc integer, dimension (its:ite) :: & kstabi,xland1,kbmax,ktopx !$acc declare create( & @@ -260,6 +261,7 @@ subroutine cu_unified_sh_run ( & flux_tun(:)=fluxtune lambau(:)=2. c1d(:,:)=0. + scaldfunc(:)=0. !$acc end kernels el2orc=xlv*xlv/(r_v*cp) @@ -995,6 +997,13 @@ subroutine cu_unified_sh_run ( & gravinv = 1./g if(ierr(i)==0)then xmb(i) = sigmab(i)*((-1.0*omegac(i))*gravinv) + if (dx(i) < 10.E3) then + scaldfunc(i)=(1.-sigmab(i))*(1.-sigmab(i)) + scaldfunc(i) = max(min(scaldfunc(i), 1.0), 0.) + else + scaldfunc(i) = 1.0 + endif + xmb(i)=scaldfunc(i)*xmb(i) endif else diff --git a/physics/samfdeepcnv.f b/physics/samfdeepcnv.f index d8b6f83f1..156f69d11 100644 --- a/physics/samfdeepcnv.f +++ b/physics/samfdeepcnv.f @@ -102,7 +102,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & real(kind=kind_phys), intent(in) :: nthresh real(kind=kind_phys), intent(in) :: ca_deep(:) real(kind=kind_phys), intent(in) :: sigmain(:,:),qmicro(:,:), & - & tmf(:,:),q(:,:), prevsq(:,:) + & tmf(:,:,:),q(:,:), prevsq(:,:) real(kind=kind_phys), intent(out) :: rainevap(:) real(kind=kind_phys), intent(out) :: sigmaout(:,:) logical, intent(in) :: do_ca,ca_closure,ca_entr,ca_trigger @@ -209,7 +209,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & & bb1, bb2, wucb ! ! parameters for prognostic sigma closure - real(kind=kind_phys) omega_u(im,km),zdqca(im,km), + real(kind=kind_phys) omega_u(im,km),zdqca(im,km),tmfq(im,km) & omegac(im),zeta(im,km),dbyo1(im,km),sigmab(im),qadv(im,km) real(kind=kind_phys) gravinv,invdelt logical flag_shallow @@ -2886,9 +2886,15 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & enddo endif + do k = 1,km + do i = 1,im + tmfq(i,k)=tmf(i,k,1) + enddo + enddo + flag_shallow = .false. call progsigma_calc(im,km,first_time_step,restart,flag_shallow, - & del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,hvap,delt, + & del,tmfq,qmicro,dbyo1,zdqca,omega_u,zeta,hvap,delt, & qadv,kbcon1,ktcon,cnvflg, & sigmain,sigmaout,sigmab) endif diff --git a/physics/samfdeepcnv.meta b/physics/samfdeepcnv.meta index 3f28035b6..bed4d655d 100644 --- a/physics/samfdeepcnv.meta +++ b/physics/samfdeepcnv.meta @@ -70,10 +70,10 @@ type = logical intent = in [tmf] - standard_name = instantaneous_tendency_of_specific_humidity_due_to_PBL - long_name = instantaneous_tendency_of_specific_humidity_due_to_PBL + standard_name = tendency_of_vertically_diffused_tracer_concentration + long_name = updated tendency of the tracers due to vertical diffusion in PBL scheme units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_vertical_diffusion_tracers) type = real kind = kind_phys intent = in diff --git a/physics/samfshalcnv.f b/physics/samfshalcnv.f index 0e97cb1fe..0e610c454 100644 --- a/physics/samfshalcnv.f +++ b/physics/samfshalcnv.f @@ -70,7 +70,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & real(kind=kind_phys), intent(in) :: delt real(kind=kind_phys), intent(in) :: psp(:), delp(:,:), & & prslp(:,:), garea(:), hpbl(:), dot(:,:), phil(:,:), & - & qmicro(:,:),tmf(:,:),prevsq(:,:),q(:,:) + & qmicro(:,:),tmf(:,:,:),prevsq(:,:),q(:,:) real(kind=kind_phys), intent(in) :: sigmain(:,:) ! @@ -156,7 +156,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & cc ! parameters for prognostic sigma closure - real(kind=kind_phys) omega_u(im,km),zdqca(im,km), + real(kind=kind_phys) omega_u(im,km),zdqca(im,km),tmfq(im,km), & omegac(im),zeta(im,km),dbyo1(im,km), & sigmab(im),qadv(im,km) real(kind=kind_phys) gravinv,dxcrtas,invdelt @@ -1938,9 +1938,16 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & enddo enddo endif + + do k = 1,km + do i = 1,im + tmfq(i,k)=tmf(i,k,1) + enddo + enddo + flag_shallow = .true. call progsigma_calc(im,km,first_time_step,restart,flag_shallow, - & del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,hvap,delt, + & del,tmfq,qmicro,dbyo1,zdqca,omega_u,zeta,hvap,delt, & qadv,kbcon1,ktcon,cnvflg, & sigmain,sigmaout,sigmab) endif diff --git a/physics/samfshalcnv.meta b/physics/samfshalcnv.meta index 8c9735c32..c1fffef58 100644 --- a/physics/samfshalcnv.meta +++ b/physics/samfshalcnv.meta @@ -70,10 +70,10 @@ type = logical intent = in [tmf] - standard_name = instantaneous_tendency_of_specific_humidity_due_to_PBL - long_name = instantaneous_tendency_of_specific_humidity_due_to_PBL + standard_name = tendency_of_vertically_diffused_tracer_concentration + long_name = updated tendency of the tracers due to vertical diffusion in PBL scheme units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_vertical_diffusion_tracers) type = real kind = kind_phys intent = in diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index 08876f8f0..0387185e4 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -73,9 +73,9 @@ end subroutine satmedmfvdifq_init !! -# A mass-flux approach is also used to represent the stratocumulus-top-induced turbulence !! (mfscuq.f). !! \section detail_satmedmfvidfq GFS satmedmfvdifq Detailed Algorithm - subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & + subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & & ntiw,ntke,grav,rd,cp,rv,hvap,hfus,fv,eps,epsm1, & - & dv,du,tdt,rtg,tmf,u1,v1,t1,q1,swh,hlw,xmu,garea,zvfun, & + & dv,du,tdt,rtg,u1,v1,t1,q1,swh,hlw,xmu,garea,zvfun, & & psk,rbsoil,zorl,u10m,v10m,fm,fh, & & tsea,heat,evap,stress,spd1,kpbl, & & prsi,del,prsl,prslk,phii,phil,delt, & @@ -98,7 +98,7 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & integer, intent(in) :: tc_pbl integer, intent(in) :: kinver(:) integer, intent(out) :: kpbl(:) - logical, intent(in) :: gen_tend,ldiag3d,progsigma + logical, intent(in) :: gen_tend,ldiag3d ! real(kind=kind_phys), intent(in) :: grav,rd,cp,rv,hvap,hfus,fv, & & eps,epsm1 @@ -106,7 +106,7 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & real(kind=kind_phys), intent(in) :: dspfac, bl_upfr, bl_dnfr real(kind=kind_phys), intent(in) :: rlmx, elmx real(kind=kind_phys), intent(inout) :: dv(:,:), du(:,:), & - & tdt(:,:), rtg(:,:,:), tmf(:,:) + & tdt(:,:), rtg(:,:,:) real(kind=kind_phys), intent(in) :: & & u1(:,:), v1(:,:), & & t1(:,:), q1(:,:,:), & @@ -331,14 +331,6 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & zm(i,k) = zi(i,k+1) enddo enddo -!> - Initialize variables needed for prognostic cumulus closure - if(progsigma)then - do k=1,km - do i=1,im - tmf(i,k) = 0. - enddo - enddo - endif !> - Compute horizontal grid size (\p gdx) do i=1,im gdx(i) = sqrt(garea(i)) @@ -2206,14 +2198,6 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & enddo enddo - if(progsigma)then - do k = 1,km - do i = 1,im - tmf(i,k)=(f2(i,k)-q1(i,k,1))*rdt - enddo - enddo - endif - do i = 1,im dtsfc(i) = rho_a(i) * cp * heat(i) dqsfc(i) = rho_a(i) * hvap * evap(i) diff --git a/physics/satmedmfvdifq.meta b/physics/satmedmfvdifq.meta index d9ab8c859..c1e243c47 100644 --- a/physics/satmedmfvdifq.meta +++ b/physics/satmedmfvdifq.meta @@ -208,14 +208,6 @@ type = real kind = kind_phys intent = inout -[tmf] - standard_name = instantaneous_tendency_of_specific_humidity_due_to_PBL - long_name = instantaneous_tendency_of_specific_humidity_due_to_PBL - units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout [u1] standard_name = x_wind long_name = x component of layer wind From 067bc162efc1754503e5f2fde9ab7bb59865c7d5 Mon Sep 17 00:00:00 2001 From: Lisa Bengtsson Date: Thu, 23 Mar 2023 20:02:33 +0000 Subject: [PATCH 190/380] update samfdeep and samfshal cumulus schemes zdqca term --- physics/samfdeepcnv.f | 4 ++-- physics/samfshalcnv.f | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/physics/samfdeepcnv.f b/physics/samfdeepcnv.f index 156f69d11..93eda5edb 100644 --- a/physics/samfdeepcnv.f +++ b/physics/samfdeepcnv.f @@ -1515,7 +1515,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & pwavo(i) = pwavo(i) + pwo(i,k) ! cnvwt(i,k) = (etah*qlk + pwo(i,k)) * grav / dp cnvwt(i,k) = etah * qlk * grav / dp - zdqca(i,k)=dq + zdqca(i,k)=dq/eta(i,k) endif ! ! compute buoyancy and drag for updraft velocity @@ -1690,7 +1690,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & pwavo(i) = pwavo(i) + pwo(i,k) ! cnvwt(i,k) = (etah*qlk + pwo(i,k)) * grav / dp cnvwt(i,k) = etah * qlk * grav / dp - zdqca(i,k)=dq + zdqca(i,k)=dq/eta(i,k) endif endif endif diff --git a/physics/samfshalcnv.f b/physics/samfshalcnv.f index 0e610c454..ab25e9922 100644 --- a/physics/samfshalcnv.f +++ b/physics/samfshalcnv.f @@ -1270,7 +1270,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & qcko(i,k)= qlk + qrch pwo(i,k) = etah * c0t(i,k) * dz * qlk cnvwt(i,k) = etah * qlk * grav / dp - zdqca(i,k)=dq + zdqca(i,k)=dq/eta(i,k) endif ! ! compute buoyancy and drag for updraft velocity @@ -1435,7 +1435,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & qcko(i,k) = qlk + qrch pwo(i,k) = etah * c0t(i,k) * dz * qlk cnvwt(i,k) = etah * qlk * grav / dp - zdqca(i,k)=dq + zdqca(i,k)=dq/eta(i,k) endif endif endif From 6c83c4fc3f99d4436073fdc7edf3c8009f30d423 Mon Sep 17 00:00:00 2001 From: Lisa Bengtsson Date: Thu, 23 Mar 2023 20:36:50 +0000 Subject: [PATCH 191/380] Some additional cleaning/fixes --- physics/cu_unified_deep.F90 | 6 +++--- physics/cu_unified_driver.F90 | 4 ++-- physics/cu_unified_sh.F90 | 4 ++-- physics/samfdeepcnv.f | 2 +- physics/satmedmfvdifq.meta | 7 ------- 5 files changed, 8 insertions(+), 15 deletions(-) diff --git a/physics/cu_unified_deep.F90 b/physics/cu_unified_deep.F90 index bd6b73fd7..5781f7abf 100644 --- a/physics/cu_unified_deep.F90 +++ b/physics/cu_unified_deep.F90 @@ -2241,7 +2241,7 @@ subroutine cu_unified_deep_run( & po_cup,pr_ens,maxens3, & sig,closure_n,xland1,xmbm_in,xmbs_in, & ichoice,imid,ipr,itf,ktf, & - its,ite, kts,kte, & + its,ite, kts,kte,dx,sigmab, & dicycle,xf_dicycle,xf_progsigma) !> - Call rain_evap_below_cloudbase() to calculate evaporation below cloud base @@ -4110,7 +4110,7 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & maxens3, & sig,closure_n,xland1,xmbm_in,xmbs_in, & ichoice,imid,ipr,itf,ktf, & - its,ite, kts,kte, & + its,ite, kts,kte, dx,sigmab, & dicycle,xf_dicycle,xf_progsigma) implicit none @@ -4151,7 +4151,7 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & zu,pwd,p_cup real(kind=kind_phys), dimension (its:ite) & ,intent (in ) :: & - sig,xmbm_in,xmbs_in,edt + sig,xmbm_in,xmbs_in,edt,sigmab,dx real(kind=kind_phys), dimension (its:ite,2) & ,intent (in ) :: & xff_mid diff --git a/physics/cu_unified_driver.F90 b/physics/cu_unified_driver.F90 index 2ca1fe687..2ccf197ac 100644 --- a/physics/cu_unified_driver.F90 +++ b/physics/cu_unified_driver.F90 @@ -646,8 +646,8 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ! turning off shallow convection for grid points zus,xmbs,kbcons,ktops,k22s,ierrs,ierrcs, & !Prog closure - flag_init, flag_restart,fv,r_d,delp,tmfq,qmicro, & - forceqv_spechum,sigmain,sigmaout,progsigma, & + flag_init, flag_restart,fv,r_d,delp,tmfq,qmicro, & + forceqv_spechum,sigmain,sigmaout,progsigma,dx, & ! output tendencies outts,outqs,outqcs,outus,outvs,cnvwt,prets,cupclws, & ! dimesnional variables diff --git a/physics/cu_unified_sh.F90 b/physics/cu_unified_sh.F90 index c9b3bf271..2dc9279b9 100644 --- a/physics/cu_unified_sh.F90 +++ b/physics/cu_unified_sh.F90 @@ -66,7 +66,7 @@ subroutine cu_unified_sh_run ( & hfx,qfx,xland,ichoice,tcrit,dtime, & zuo,xmb_out,kbcon,ktop,k22,ierr,ierrc, & flag_init, flag_restart,fv,r_d,delp,tmf,qmicro, & - forceqv_spechum,sigmain,sigmaout,progsigma, & + forceqv_spechum,sigmain,sigmaout,progsigma,dx, & outt,outq,outqc,outu,outv,cnvwt,pre,cupclw, & ! output tendencies itf,ktf,its,ite, kts,kte,ipr,tropics) ! dimesnional variables ! @@ -125,7 +125,7 @@ subroutine cu_unified_sh_run ( & q,qo real(kind=kind_phys), dimension (its:ite) & ,intent (in ) :: & - xland,z1,psur,hfx,qfx + xland,z1,psur,hfx,qfx,dx real(kind=kind_phys) & ,intent (in ) :: & diff --git a/physics/samfdeepcnv.f b/physics/samfdeepcnv.f index 93eda5edb..cd130dfd0 100644 --- a/physics/samfdeepcnv.f +++ b/physics/samfdeepcnv.f @@ -209,7 +209,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & & bb1, bb2, wucb ! ! parameters for prognostic sigma closure - real(kind=kind_phys) omega_u(im,km),zdqca(im,km),tmfq(im,km) + real(kind=kind_phys) omega_u(im,km),zdqca(im,km),tmfq(im,km), & omegac(im),zeta(im,km),dbyo1(im,km),sigmab(im),qadv(im,km) real(kind=kind_phys) gravinv,invdelt logical flag_shallow diff --git a/physics/satmedmfvdifq.meta b/physics/satmedmfvdifq.meta index c1e243c47..d0b11656a 100644 --- a/physics/satmedmfvdifq.meta +++ b/physics/satmedmfvdifq.meta @@ -62,13 +62,6 @@ dimensions = () type = integer intent = in -[progsigma] - standard_name = do_prognostic_updraft_area_fraction - long_name = flag for prognostic sigma in cumuls scheme - units = flag - dimensions = () - type = logical - intent = in [ntrac] standard_name = number_of_vertical_diffusion_tracers long_name = number of tracers to diffuse vertically From 6572200899f170d64fbdbd6fabd23da69f31c95b Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Thu, 23 Mar 2023 21:40:29 +0000 Subject: [PATCH 192/380] Moved RUC LSM options to namelist parameters. Also, some clean-up of print statements. --- physics/lsm_ruc.F90 | 8 ++- physics/lsm_ruc.meta | 28 +++++++++ physics/module_sf_ruclsm.F90 | 114 +++++++++++++++++++++++------------ 3 files changed, 110 insertions(+), 40 deletions(-) diff --git a/physics/lsm_ruc.F90 b/physics/lsm_ruc.F90 index cec87e689..b4b357f36 100644 --- a/physics/lsm_ruc.F90 +++ b/physics/lsm_ruc.F90 @@ -326,7 +326,8 @@ subroutine lsm_ruc_run & ! inputs & ( iter, me, master, delt, kdt, im, nlev, lsm_ruc, lsm, & & imp_physics, imp_physics_gfdl, imp_physics_thompson, & & imp_physics_nssl, do_mynnsfclay, & - & exticeden, lsoil_ruc, lsoil, nlcat, nscat, & + & exticeden, lsoil_ruc, lsoil, mosaic_lu, mosaic_soil, & + & isncond_opt, isncovr_opt, nlcat, nscat, & & rdlai, xlat_d, xlon_d, & & oro, sigma, zs, t1, q1, qc, stype, vtype, vegtype_frac, & & soiltype_frac, sigmaf, laixy, & @@ -371,6 +372,7 @@ subroutine lsm_ruc_run & ! inputs ! --- input: integer, intent(in) :: me, master integer, intent(in) :: im, nlev, iter, lsoil_ruc, lsoil, kdt, isot, ivegsrc + integer, intent(in) :: mosaic_lu, mosaic_soil, isncond_opt, isncovr_opt integer, intent(in) :: nlcat, nscat integer, intent(in) :: lsm_ruc, lsm integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, & @@ -1154,6 +1156,8 @@ subroutine lsm_ruc_run & ! inputs & qcatm(i,1,j), rho2(i,1,j), semis_bck(i,j), lwdn(i,j), & & swdn(i,j), solnet_lnd(i,j), sfcems_lnd(i,j), chklowq(i,j), & & chs_lnd(i,j), flqc_lnd(i,j), flhc_lnd(i,j), rhonewsn_ex(i), & +! --- snow model options + & mosaic_lu, mosaic_soil, isncond_opt, isncovr_opt, & ! --- input/outputs: & wet(i,j), cmc(i,j), shdfac(i,j), alb_lnd(i,j), znt_lnd(i,j), & & z0_lnd(i,j), snoalb1d_lnd(i,j), albbck_lnd(i,j), & @@ -1438,6 +1442,8 @@ subroutine lsm_ruc_run & ! inputs & qcatm(i,1,j), rho2(i,1,j), semis_bck(i,j), lwdn(i,j), & & swdn(i,j), solnet_ice(i,j), sfcems_ice(i,j), chklowq(i,j), & & chs_ice(i,j), flqc_ice(i,j), flhc_ice(i,j), rhonewsn_ex(i), & +! --- snow model options + & mosaic_lu, mosaic_soil, isncond_opt, isncovr_opt, & ! --- input/outputs: & wet_ice(i,j), cmc(i,j), shdfac(i,j), alb_ice(i,j), & & znt_ice(i,j), z0_ice(i,j), snoalb1d_ice(i,j), & diff --git a/physics/lsm_ruc.meta b/physics/lsm_ruc.meta index 38ebbcd67..57bf0b3cf 100644 --- a/physics/lsm_ruc.meta +++ b/physics/lsm_ruc.meta @@ -655,6 +655,34 @@ dimensions = () type = integer intent = in +[mosaic_lu] + standard_name = control_for_fractional_landuse_in_ruc_land_surface_scheme + long_name = control for use of fractional landuse info in RUC land surface model + units = flag + dimensions = () + type = integer + intent = in +[mosaic_soil] + standard_name = control_for_fractional_soil_in_ruc_land_surface_scheme + long_name = control for use of fractional soil info in RUC land surface model + units = flag + dimensions = () + type = integer + intent = in +[isncond_opt] + standard_name = control_for_soil_thermal_conductivity_option_in_ruc_lsm + long_name = control for soil thermal conductivity option in RUC land surface model + units = flag + dimensions = () + type = integer + intent = in +[isncovr_opt] + standard_name = control_for_snow_cover_fraction_option_in_ruc_lsm + long_name = control for snow cover fraction option in RUC land surface model + units = flag + dimensions = () + type = integer + intent = in [nlcat] standard_name = number_of_vegetation_categories long_name = number of vegetation categories diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 66f4cb660..850e3ee5e 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -37,11 +37,10 @@ MODULE module_sf_ruclsm real (kind_phys), parameter :: one = 1._kind_dbl_prec !-- options for snow conductivity: 1 - constant, 2 - Sturm et al.,1997 - integer, parameter :: isncond_opt = 1 - + !integer, parameter :: isncond_opt = 1 !-- Snow fraction options !-- option 1: original formulation using threshold snow depth to compute snow fraction - integer, parameter :: isncovr_opt = 1 + !integer, parameter :: isncovr_opt = 1 !-- option 2: the tanh formulation from Niu,G.-Y.,and Yang,Z.-L., 2007,JGR,DOI:10.1029/2007JD008674. !integer, parameter :: isncovr_opt = 2 !-- option 3: the tanh formulation from Niu,G.-Y.,and Yang,Z with @@ -93,7 +92,9 @@ SUBROUTINE LSMRUC(xlat,xlon, & rhosnf,precipfr,exticeden, hgt,stdev, & Z3D,P8W,T3D,QV3D,QC3D,RHO3D,EMISBCK, & GLW,GSWdn,GSW,EMISS,CHKLOWQ, CHS, & - FLQC,FLHC,rhonewsn_ex,MAVAIL,CANWAT,VEGFRA, & + FLQC,FLHC,rhonewsn_ex,mosaic_lu, & + mosaic_soil,isncond_opt,isncovr_opt, & + MAVAIL,CANWAT,VEGFRA, & ALB,ZNT,Z0,SNOALB,ALBBCK,LAI, & landusef, nlcat, soilctop, nscat, & QSFC,QSG,QVG,QCG,DEW,SOILT1,TSNAV, & @@ -197,6 +198,8 @@ SUBROUTINE LSMRUC(xlat,xlon, & real (kind_phys), INTENT(IN ) :: DT LOGICAL, INTENT(IN ) :: myj,frpcpn,init,lsm_cold_start,exticeden INTEGER, INTENT(IN ) :: NLCAT, NSCAT + INTEGER, INTENT(IN ) :: mosaic_lu,mosaic_soil + INTEGER, INTENT(IN ) :: isncond_opt,isncovr_opt INTEGER, INTENT(IN ) :: ktau, iter, nsl, isice, iswater, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte @@ -692,10 +695,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & NZS1=NZS-1 !----- IF (debug_print ) THEN - if (abs(xlat-testptlat).lt.0.2 .and. & - abs(xlon-testptlon).lt.0.2)then print *,' DT,NZS1, ZSMAIN, ZSHALF --->', dt,nzs1,zsmain,zshalf - endif ENDIF DO K=2,NZS1 @@ -739,6 +739,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & if(init) then if (abs(xlat-testptlat).lt.0.2 .and. & abs(xlon-testptlon).lt.0.2)then + print*,' lat,lon=',xlat,xlon print *,'before SOILVEGIN - z0,znt',i,z0(i,j),znt(i,j) print *,'ILAND, ISOIL =',i,iland,isoil endif @@ -747,7 +748,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & !> - Call soilvegin() to initialize soil and surface properties !-- land or ice - CALL SOILVEGIN ( debug_print, & + CALL SOILVEGIN ( debug_print, mosaic_lu, mosaic_soil, & soilfrac,nscat,shdmin(i,j),shdmax(i,j), & NLCAT,ILAND,ISOIL,iswater,MYJ,IFOREST,lufrac,VEGFRA(I,J), & EMISSL(I,J),PC(I,J),MSNF(I,J),FACSNF(I,J), & @@ -761,6 +762,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & if(init)then if (abs(xlat-testptlat).lt.0.2 .and. & abs(xlon-testptlon).lt.0.2)then + print*,' lat,lon=',xlat,xlon print *,'after SOILVEGIN - z0,znt,lai',i,z0(i,j),znt(i,j),lai(i,j) print *,'NLCAT,iland,EMISSL(I,J),PC(I,J),ZNT(I,J),LAI(I,J)', & NLCAT,iland,EMISSL(I,J),PC(I,J),ZNT(I,J),LAI(I,J),i,j @@ -808,10 +810,14 @@ SUBROUTINE LSMRUC(xlat,xlon, & !----- IF (debug_print ) THEN + if (abs(xlat-testptlat).lt.0.2 .and. & + abs(xlon-testptlon).lt.0.2)then + print*,' lat,lon=',xlat,xlon print *,' ZNT, LAI, VEGFRA, SAT, EMIS, PC --->', & ZNT(I,J),LAI(I,J),VEGFRA(I,J),SAT,EMISSL(I,J),PC(I,J) print *,' ZS, ZSMAIN, ZSHALF, CONFLX, CN, SAT, --->', zs,zsmain,zshalf,conflx,cn,sat print *,'NROOT, meltfactor, iforest, ivgtyp, i,j ', nroot,meltfactor,iforest,ivgtyp(I,J),I,J + endif ENDIF IF((XLAND(I,J)-1.5).GE.0._kind_phys)THEN @@ -841,8 +847,11 @@ SUBROUTINE LSMRUC(xlat,xlon, & ENDDO IF (debug_print ) THEN - PRINT*,' water point, I=',I, & - 'J=',J, 'SOILT=', SOILT(i,j) + if (abs(xlat-testptlat).lt.0.2 .and. & + abs(xlon-testptlon).lt.0.2)then + PRINT*,' water point' + print*,' lat,lon=',xlat,xlon,'SOILT=', SOILT(i,j) + endif ENDIF ELSE @@ -857,8 +866,11 @@ SUBROUTINE LSMRUC(xlat,xlon, & IF(SEAICE(I,J).GT.0.5_kind_phys)THEN !-- Sea-ice case IF (debug_print ) THEN - PRINT*,' sea-ice at water point, I=',I, & - 'J=',J + if (abs(xlat-testptlat).lt.0.2 .and. & + abs(xlon-testptlon).lt.0.2)then + PRINT*,' sea-ice at water point' + print*,' lat,lon=',xlat,xlon + endif ENDIF ILAND = isice if(nscat == 9) then @@ -909,6 +921,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & IF (debug_print ) THEN if (abs(xlat-testptlat).lt.0.2 .and. & abs(xlon-testptlon).lt.0.2)then + print*,' lat,lon=',xlat,xlon print *,'LAND, i,j,tso1d,soilm1d,PATM,TABS,QVATM,QCATM,RHO', & i,j,tso1d,soilm1d,PATM,TABS,QVATM,QCATM,RHO print *,'CONFLX =',CONFLX @@ -934,6 +947,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & xlat, xlon, testptlat, testptlon, & !--- input variables nzs,nddzs,nroot,meltfactor, & !added meltfactor + isncond_opt,isncovr_opt, & iland,isoil,ivgtyp(i,j),isltyp(i,j), & PRCPMS, NEWSNMS,SNWE,SNHEI,SNOWFRAC, & exticeden,RHOSN,RHONEWSN_ex(I),RHONEWSN, & @@ -973,23 +987,29 @@ SUBROUTINE LSMRUC(xlat,xlon, & ! croplands. ! This change violates LSM moisture budget, but ! can be considered as a compensation for irrigation not included into LSM. - -!tgs - turn off "irrigation" while there is no fractional landuse and LAI -!climatology. - if(1==2) then +!tgs - "irrigation" uses fractional landuse, therefore mosaic_lu=1. + if(mosaic_lu == 1) then IF (lufrac(crop) > zero .and. lai(i,j) > 1.1_kind_phys) THEN ! cropland do k=1,nroot - cropsm=1.1_kind_phys*wilt - qmin + cropsm=1.1_kind_phys*wilt - qmin if(soilm1d(k) < cropsm*lufrac(crop)) then IF (debug_print ) THEN -print * ,'Soil moisture is below wilting in cropland category at time step',ktau & - ,'i,j,lufrac(crop),k,soilm1d(k),wilt,cropsm', & - i,j,lufrac(crop),k,soilm1d(k),wilt,cropsm + if (abs(xlat-testptlat).lt.0.2 .and. & + abs(xlon-testptlon).lt.0.2)then +print * ,'Soil moisture is below wilting in cropland category at time step',ktau + print*,' lat,lon=',xlat,xlon & + ,'lufrac(crop),k,soilm1d(k),wilt,cropsm', & + lufrac(crop),k,soilm1d(k),wilt,cropsm + endif ENDIF - soilm1d(k) = cropsm*lufrac(crop) + soilm1d(k) = cropsm*lufrac(crop) IF (debug_print ) THEN - print * ,'Added soil water to cropland category, i,j,k,soilm1d(k)',i,j,k,soilm1d(k) + if (abs(xlat-testptlat).lt.0.2 .and. & + abs(xlon-testptlon).lt.0.2)then + print*,' lat,lon=',xlat,xlon + print * ,'Added soil water to cropland category, i,j,k,soilm1d(k)',i,j,k,soilm1d(k) + endif ENDIF endif enddo @@ -997,21 +1017,30 @@ SUBROUTINE LSMRUC(xlat,xlon, & ELSEIF (ivgtyp(i,j) == natural .and. lai(i,j) > 0.7) THEN ! grassland: assume that 40% of grassland is irrigated cropland do k=1,nroot - cropsm=1.2_kind_phys*wilt - qmin + cropsm=1.2_kind_phys*wilt - qmin if(soilm1d(k) < cropsm*lufrac(natural)*0.4) then IF (debug_print ) THEN -print * ,'Soil moisture is below wilting in mixed grassland/cropland category at time step',ktau & - ,'i,j,lufrac(natural),k,soilm1d(k),wilt', & - i,j,lufrac(natural),k,soilm1d(k),wilt + if (abs(xlat-testptlat).lt.0.2 .and. & + abs(xlon-testptlon).lt.0.2)then +print * ,'Soil moisture is below wilting in mixed grassland/cropland category at time step',ktau + print*,' lat,lon=',xlat,xlon, & + 'lufrac(natural),k,soilm1d(k),wilt', & + lufrac(natural),k,soilm1d(k),wilt + endif ENDIF - soilm1d(k) = cropsm * lufrac(natural)*0.4_kind_phys + soilm1d(k) = cropsm * lufrac(natural)*0.4_kind_phys + IF (debug_print ) THEN - print * ,'Added soil water to grassland category, i,j,k,soilm1d(k)',i,j,k,soilm1d(k) + if (abs(xlat-testptlat).lt.0.2 .and. & + abs(xlon-testptlon).lt.0.2)then + print*,' lat,lon=',xlat,xlon + print * ,'Added soil water to grassland category, i,j,k,soilm1d(k)',i,j,k,soilm1d(k) + endif ENDIF endif enddo ENDIF - endif ! 1==2 + endif ! mosaic_lu !*** DIAGNOSTICS !--- available and maximum soil moisture content in the soil @@ -1046,7 +1075,6 @@ SUBROUTINE LSMRUC(xlat,xlon, & do k=1,nzs -! soilmois(i,k,j) = soilm1d(k) soilmois(i,k,j) = soilm1d(k) + qmin sh2o (i,k,j) = min(soiliqw(k) + qmin,soilmois(i,k,j)) tso(i,k,j) = tso1d(k) @@ -1102,7 +1130,6 @@ SUBROUTINE LSMRUC(xlat,xlon, & !tgs - SMF.NE.0. when there is phase change in the top soil layer ! The heat of soil water freezing/thawing is not computed explicitly ! and is responsible for the residual in the energy budget. -! endif !--- SNOWC snow cover flag SNOWC(I,J)=SNOWFRAC @@ -1157,9 +1184,9 @@ SUBROUTINE LSMRUC(xlat,xlon, & IF (debug_print ) THEN if (abs(xlat-testptlat).lt.0.2 .and. & abs(xlon-testptlon).lt.0.2)then - print *,'LAND, i,j,tso1d,soilm1d,soilt - end of time step', & - i,j,tso1d,soilm1d,soilt(i,j) - print *,'LAND, QFX, HFX after SFCTMP', i,j,lh(i,j),hfx(i,j) + print *,'LAND, i,tso1d,soilm1d,soilt - end of time step', & + i,tso1d,soilm1d,soilt(i,j) + print *,'LAND, QFX, HFX after SFCTMP', i,lh(i,j),hfx(i,j) endif ENDIF @@ -1187,6 +1214,7 @@ END SUBROUTINE LSMRUC SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input variables xlat,xlon,testptlat,testptlon, & nzs,nddzs,nroot,meltfactor, & + isncond_opt,isncovr_opt, & ILAND,ISOIL,IVGTYP,ISLTYP,PRCPMS, & NEWSNMS,SNWE,SNHEI,SNOWFRAC, & exticeden,RHOSN,RHONEWSN_ex,RHONEWSN,RHOSNFALL, & @@ -1215,6 +1243,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia INTEGER, INTENT(IN ) :: isice,i,j,nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) + integer, intent(in ) :: isncond_opt,isncovr_opt real (kind_phys), INTENT(IN ) :: DELT,CONFLX,meltfactor,xlat,xlon real (kind_phys), INTENT(IN ) :: testptlat,testptlon @@ -1923,6 +1952,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia endif CALL SNOWSOIL (debug_print,xlat,xlon,testptlat,testptlon, & !--- input variables i,j,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & + isncond_opt,isncovr_opt, & meltfactor,rhonewsn,SNHEI_CRIT, & ! new ILAND,PRCPMS,RAINF,NEWSN,snhei,SNWE,snfr, & RHOSN,PATM,QVATM,QCATM, & @@ -1951,8 +1981,9 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia snfr=snowfrac endif - CALL SNOWSEAICE (debug_print,xlat,xlon, & + CALL SNOWSEAICE (debug_print,xlat,xlon, & i,j,isoil,delt,ktau,conflx,nzs,nddzs, & + isncond_opt,isncovr_opt, & meltfactor,rhonewsn,SNHEI_CRIT, & ! new ILAND,PRCPMS,RAINF,NEWSN,snhei,SNWE,snfr, & RHOSN,PATM,QVATM,QCATM, & @@ -3177,6 +3208,7 @@ END SUBROUTINE SICE SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & testptlat,testptlon, & i,j,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & !--- input variables + isncond_opt,isncovr_opt, & meltfactor,rhonewsn,SNHEI_CRIT, & ! new ILAND,PRCPMS,RAINF,NEWSNOW,snhei,SNWE,SNOWFRAC, & RHOSN, & @@ -3271,7 +3303,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & LOGICAL, INTENT(IN ) :: debug_print INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) - INTEGER, INTENT(IN ) :: i,j,isoil + INTEGER, INTENT(IN ) :: i,j,isoil,isncond_opt,isncovr_opt real (kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS, & RAINF,NEWSNOW,RHONEWSN, & @@ -3632,6 +3664,7 @@ SUBROUTINE SNOWSOIL ( debug_print,xlat,xlon, & !--- input variables i,j,iland,isoil, & delt,ktau,conflx,nzs,nddzs,nroot, & + isncond_opt,isncovr_opt, & snwe,snwepr,snhei,newsnow,snowfrac,snhei_crit, & beta,deltsn,snth,rhosn,rhonewsn,meltfactor, & ! add meltfactor PRCPMS,RAINF, & @@ -3844,6 +3877,7 @@ END SUBROUTINE SNOWSOIL !! temperature, snow and ice temperatures, snow depth and snow melt. SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & i,j,isoil,delt,ktau,conflx,nzs,nddzs, & + isncond_opt,isncovr_opt, & meltfactor,rhonewsn,SNHEI_CRIT, & ! new ILAND,PRCPMS,RAINF,NEWSNOW,snhei,SNWE,snowfrac, & RHOSN,PATM,QVATM,QCATM, & @@ -3871,7 +3905,7 @@ SUBROUTINE SNOWSEAICE( debug_print,xlat,xlon, & LOGICAL, INTENT(IN ) :: debug_print INTEGER, INTENT(IN ) :: ktau,nzs , & nddzs !nddzs=2*(nzs-2) - INTEGER, INTENT(IN ) :: i,j,isoil + INTEGER, INTENT(IN ) :: i,j,isoil,isncond_opt,isncovr_opt real (kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS, & RAINF,NEWSNOW,RHONEWSN, & @@ -4961,6 +4995,7 @@ END SUBROUTINE SOILTEMP SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & testptlat,testptlon,i,j,iland,isoil, & !--- input variables delt,ktau,conflx,nzs,nddzs,nroot, & + isncond_opt,isncovr_opt, & snwe,snwepr,snhei,newsnow,snowfrac,snhei_crit, & beta,deltsn,snth,rhosn,rhonewsn,meltfactor, & ! add meltfactor PRCPMS,RAINF, & @@ -5032,7 +5067,7 @@ SUBROUTINE SNOWTEMP( debug_print,xlat,xlon, & INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) - INTEGER, INTENT(IN ) :: i,j,iland,isoil + INTEGER, INTENT(IN ) :: i,j,iland,isoil,isncond_opt,isncovr_opt real (kind_phys), INTENT(IN ) :: DELT,CONFLX,PRCPMS , & RAINF,NEWSNOW,DELTSN,SNTH , & TABS,TRANSUM,SNWEPR , & @@ -6708,7 +6743,7 @@ END SUBROUTINE VILKA !! This subroutine computes effective land and soil parameters in the !! grid cell from the weighted contribution of soil and land categories !! represented in the grid cell. - SUBROUTINE SOILVEGIN ( debug_print, & + SUBROUTINE SOILVEGIN ( debug_print,mosaic_lu,mosaic_soil, & soilfrac,nscat,shdmin, shdmax, & NLCAT,IVGTYP,ISLTYP,iswater,MYJ, & IFOREST,lufrac,vegfrac,EMISS,PC, & @@ -6743,6 +6778,7 @@ SUBROUTINE SOILVEGIN ( debug_print, & integer, parameter :: ilsnow=99 LOGICAL, INTENT(IN ) :: debug_print + INTEGER, INTENT(IN ) :: mosaic_lu, mosaic_soil INTEGER, INTENT(IN ) :: nlcat, nscat, iswater, i, j !--- soiltyp classification according to STATSGO(nclasses=16) From 98426eab3e6f275e1d947e85c38dbd53a65a7a5d Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Thu, 23 Mar 2023 22:13:36 +0000 Subject: [PATCH 193/380] Surface_snow_amount_vardens_over_land is changed to surface_snow_amount_vardens_over_land Same for ice. --- physics/lsm_ruc.meta | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/lsm_ruc.meta b/physics/lsm_ruc.meta index 57bf0b3cf..f7a0dd5f0 100644 --- a/physics/lsm_ruc.meta +++ b/physics/lsm_ruc.meta @@ -1442,7 +1442,7 @@ kind = kind_phys intent = inout [snowfallac_lnd] - standard_name = surface_snow_amount_vardens_over_land + standard_name = surface_snow_amount_assuming_variable_snow_density_over_land long_name = run-total snow accumulation on the ground with variable snow density over land units = kg m-2 dimensions = (horizontal_loop_extent) @@ -1602,7 +1602,7 @@ kind = kind_phys intent = in [snowfallac_ice] - standard_name = surface_snow_amount_vardens_over_ice + standard_name = surface_snow_amount_assuming_variable_snow_density_over_ice long_name = run-total snow accumulation on the ground with variable snow density over ice units = kg m-2 dimensions = (horizontal_loop_extent) From 1f2b01c43129c5925b518420f7dcc2bed317f5b6 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Thu, 23 Mar 2023 22:15:08 +0000 Subject: [PATCH 194/380] Active = (control_for_land_surface_scheme == identifier_for_ruc_land_surface_scheme) is removed. --- physics/lsm_ruc.meta | 1 - 1 file changed, 1 deletion(-) diff --git a/physics/lsm_ruc.meta b/physics/lsm_ruc.meta index f7a0dd5f0..df2b11600 100644 --- a/physics/lsm_ruc.meta +++ b/physics/lsm_ruc.meta @@ -1665,7 +1665,6 @@ type = real kind = kind_phys intent = inout - active = (control_for_land_surface_scheme == identifier_for_ruc_land_surface_scheme) [sbsno] standard_name = snow_deposition_sublimation_upward_latent_heat_flux long_name = latent heat flux from snow depo/subl From be146a8ebc073412b1e0364ad6225dbdef2f26fe Mon Sep 17 00:00:00 2001 From: Lisa Bengtsson Date: Fri, 24 Mar 2023 01:36:23 +0000 Subject: [PATCH 195/380] Correction to convective cloud condensate term in prog closure for HR2 --- physics/progsigma_calc.f90 | 28 ++++-------------- physics/samfdeepcnv.f | 59 +++++++++++++++++++++----------------- physics/samfdeepcnv.meta | 6 ++-- physics/samfshalcnv.f | 54 ++++++++++++++++++++-------------- physics/samfshalcnv.meta | 6 ++-- physics/satmedmfvdifq.F | 24 +++------------- physics/satmedmfvdifq.meta | 15 ---------- 7 files changed, 81 insertions(+), 111 deletions(-) diff --git a/physics/progsigma_calc.f90 b/physics/progsigma_calc.f90 index eaa1d3fda..4bbd305ae 100644 --- a/physics/progsigma_calc.f90 +++ b/physics/progsigma_calc.f90 @@ -13,8 +13,8 @@ !!\section gen_progsigma progsigma_calc General Algorithm subroutine progsigma_calc (im,km,flag_init,flag_restart, & flag_shallow,del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,hvap, & - delt,prevsq,q,kbcon1,ktcon,cnvflg,sigmain,sigmaout, & - sigmab,errmsg,errflg) + delt,qadv,kbcon1,ktcon,cnvflg,sigmain,sigmaout, & + sigmab) ! ! use machine, only : kind_phys @@ -25,7 +25,7 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & ! intent in integer, intent(in) :: im,km,kbcon1(im),ktcon(im) real(kind=kind_phys), intent(in) :: hvap,delt - real(kind=kind_phys), intent(in) :: prevsq(im,km), q(im,km),del(im,km), & + real(kind=kind_phys), intent(in) :: qadv(im,km),del(im,km), & qmicro(im,km),tmf(im,km),dbyo1(im,km),zdqca(im,km), & omega_u(im,km),zeta(im,km) logical, intent(in) :: flag_init,flag_restart,cnvflg(im),flag_shallow @@ -34,14 +34,13 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & ! intent out real(kind=kind_phys), intent(out) :: sigmaout(im,km) real(kind=kind_phys), intent(out) :: sigmab(im) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg + ! Local variables integer :: i,k,km1 real(kind=kind_phys) :: termA(im),termB(im),termC(im),termD(im) real(kind=kind_phys) :: mcons(im),fdqa(im),form(im,km), & - qadv(im,km),dp(im,km),inbu(im,km) + dp(im,km),inbu(im,km) real(kind=kind_phys) :: gcvalmx,epsilon,ZZ,cvg,mcon,buy2, & @@ -77,21 +76,6 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & mcons(i)=0. enddo - !Initial computations, dynamic q-tendency - if(flag_init .and. .not.flag_restart)then - do k = 1,km - do i = 1,im - qadv(i,k)=0. - enddo - enddo - else - do k = 1,km - do i = 1,im - qadv(i,k)=(q(i,k) - prevsq(i,k))*invdelt - enddo - enddo - endif - do k = 2,km1 do i = 1,im if(cnvflg(i))then @@ -133,7 +117,7 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & mcon = (hvap*(qadv(i,k)+tmf(i,k)+qmicro(i,k))*dp(i,k)) buy2 = termD(i)+mcon+mcons(i) ! Do the integral over buoyant layers with positive mcon acc from surface - if(k > kbcon1(i) .and. k < ktcon(i) .and. buy2 > 0.)then + if(dbyo1(i,k)>0 .and. buy2 > 0.)then inbu(i,k)=1. endif inbu(i,k-1)=MAX(inbu(i,k-1),inbu(i,k)) diff --git a/physics/samfdeepcnv.f b/physics/samfdeepcnv.f index 2a3c256a9..cd130dfd0 100644 --- a/physics/samfdeepcnv.f +++ b/physics/samfdeepcnv.f @@ -102,7 +102,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & real(kind=kind_phys), intent(in) :: nthresh real(kind=kind_phys), intent(in) :: ca_deep(:) real(kind=kind_phys), intent(in) :: sigmain(:,:),qmicro(:,:), & - & tmf(:,:),q(:,:), prevsq(:,:) + & tmf(:,:,:),q(:,:), prevsq(:,:) real(kind=kind_phys), intent(out) :: rainevap(:) real(kind=kind_phys), intent(out) :: sigmaout(:,:) logical, intent(in) :: do_ca,ca_closure,ca_entr,ca_trigger @@ -209,9 +209,9 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & & bb1, bb2, wucb ! ! parameters for prognostic sigma closure - real(kind=kind_phys) omega_u(im,km),zdqca(im,km),qlks(im,km), - & omegac(im),zeta(im,km),dbyo1(im,km),sigmab(im) - real(kind=kind_phys) gravinv + real(kind=kind_phys) omega_u(im,km),zdqca(im,km),tmfq(im,km), + & omegac(im),zeta(im,km),dbyo1(im,km),sigmab(im),qadv(im,km) + real(kind=kind_phys) gravinv,invdelt logical flag_shallow c physical parameters ! parameter(grav=grav,asolfac=0.958) @@ -306,6 +306,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & errflg = 0 gravinv = 1./grav + invdelt = 1./delt elocp = hvap/cp el2orc = hvap*hvap/(rv*cp) @@ -585,7 +586,6 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & do i = 1, im dbyo1(i,k)=0. zdqca(i,k)=0. - qlks(i,k)=0. omega_u(i,k)=0. zeta(i,k)=1.0 enddo @@ -1515,7 +1515,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & pwavo(i) = pwavo(i) + pwo(i,k) ! cnvwt(i,k) = (etah*qlk + pwo(i,k)) * grav / dp cnvwt(i,k) = etah * qlk * grav / dp - qlks(i,k)=qlk + zdqca(i,k)=dq/eta(i,k) endif ! ! compute buoyancy and drag for updraft velocity @@ -1690,7 +1690,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & pwavo(i) = pwavo(i) + pwo(i,k) ! cnvwt(i,k) = (etah*qlk + pwo(i,k)) * grav / dp cnvwt(i,k) = etah * qlk * grav / dp - qlks(i,k)=qlk + zdqca(i,k)=dq/eta(i,k) endif endif endif @@ -1860,28 +1860,13 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & if(dq > 0.) then qlko_ktcon(i) = dq qcko(i,k) = qrch - qlks(i,k) = qlko_ktcon(i) + zdqca(i,k) = dq endif endif enddo endif c -c store term needed for "termC" in prognostic area fraction closure - if(progsigma)then - do k = 2, km1 - do i = 1, im - dp = 1000. * del(i,k) - if (cnvflg(i)) then - if(k > kbcon(i) .and. k < ktcon(i)) then - zdqca(i,k)=((qlks(i,k)-qlks(i,k-1)) + - & pwo(i,k)+dellal(i,k)) - endif - endif - enddo - enddo - endif - ccccc if(lat.==.latd.and.lon.==.lond.and.cnvflg(i)) then ccccc print *, ' aa1(i) before dwndrft =', aa1(i) ccccc endif @@ -2885,11 +2870,33 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & !> - From Bengtsson et al. (2022) \cite Bengtsson_2022 prognostic closure scheme, equation 8, call progsigma_calc() to compute updraft area fraction based on a moisture budget if(progsigma)then + +!Initial computations, dynamic q-tendency + if(first_time_step .and. .not.restart)then + do k = 1,km + do i = 1,im + qadv(i,k)=0. + enddo + enddo + else + do k = 1,km + do i = 1,im + qadv(i,k)=(q(i,k) - prevsq(i,k))*invdelt + enddo + enddo + endif + + do k = 1,km + do i = 1,im + tmfq(i,k)=tmf(i,k,1) + enddo + enddo + flag_shallow = .false. call progsigma_calc(im,km,first_time_step,restart,flag_shallow, - & del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,hvap,delt, - & prevsq,q,kbcon1,ktcon,cnvflg, - & sigmain,sigmaout,sigmab,errmsg,errflg) + & del,tmfq,qmicro,dbyo1,zdqca,omega_u,zeta,hvap,delt, + & qadv,kbcon1,ktcon,cnvflg, + & sigmain,sigmaout,sigmab) endif !> - From Han et al.'s (2017) \cite han_et_al_2017 equation 6, calculate cloud base mass flux as a function of the mean updraft velcoity for the grid sizes where the quasi-equilibrium assumption of Arakawa-Schubert is not valid any longer. diff --git a/physics/samfdeepcnv.meta b/physics/samfdeepcnv.meta index 3f28035b6..bed4d655d 100644 --- a/physics/samfdeepcnv.meta +++ b/physics/samfdeepcnv.meta @@ -70,10 +70,10 @@ type = logical intent = in [tmf] - standard_name = instantaneous_tendency_of_specific_humidity_due_to_PBL - long_name = instantaneous_tendency_of_specific_humidity_due_to_PBL + standard_name = tendency_of_vertically_diffused_tracer_concentration + long_name = updated tendency of the tracers due to vertical diffusion in PBL scheme units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_vertical_diffusion_tracers) type = real kind = kind_phys intent = in diff --git a/physics/samfshalcnv.f b/physics/samfshalcnv.f index 645024536..ab25e9922 100644 --- a/physics/samfshalcnv.f +++ b/physics/samfshalcnv.f @@ -70,7 +70,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & real(kind=kind_phys), intent(in) :: delt real(kind=kind_phys), intent(in) :: psp(:), delp(:,:), & & prslp(:,:), garea(:), hpbl(:), dot(:,:), phil(:,:), & - & qmicro(:,:),tmf(:,:),prevsq(:,:),q(:,:) + & qmicro(:,:),tmf(:,:,:),prevsq(:,:),q(:,:) real(kind=kind_phys), intent(in) :: sigmain(:,:) ! @@ -156,10 +156,10 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & cc ! parameters for prognostic sigma closure - real(kind=kind_phys) omega_u(im,km),zdqca(im,km),qlks(im,km), + real(kind=kind_phys) omega_u(im,km),zdqca(im,km),tmfq(im,km), & omegac(im),zeta(im,km),dbyo1(im,km), - & sigmab(im) - real(kind=kind_phys) gravinv,dxcrtas + & sigmab(im),qadv(im,km) + real(kind=kind_phys) gravinv,dxcrtas,invdelt logical flag_shallow c physical parameters ! parameter(g=grav,asolfac=0.89) @@ -247,6 +247,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & errflg = 0 gravinv = 1./grav + invdelt = 1./delt elocp = hvap/cp el2orc = hvap*hvap/(rv*cp) @@ -524,7 +525,6 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & do i = 1, im dbyo1(i,k)=0. zdqca(i,k)=0. - qlks(i,k)=0. omega_u(i,k)=0. zeta(i,k)=1.0 enddo @@ -1270,7 +1270,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & qcko(i,k)= qlk + qrch pwo(i,k) = etah * c0t(i,k) * dz * qlk cnvwt(i,k) = etah * qlk * grav / dp - qlks(i,k)=qlk + zdqca(i,k)=dq/eta(i,k) endif ! ! compute buoyancy and drag for updraft velocity @@ -1435,7 +1435,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & qcko(i,k) = qlk + qrch pwo(i,k) = etah * c0t(i,k) * dz * qlk cnvwt(i,k) = etah * qlk * grav / dp - qlks(i,k)=qlk + zdqca(i,k)=dq/eta(i,k) endif endif endif @@ -1601,24 +1601,13 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & if(dq > 0.) then qlko_ktcon(i) = dq qcko(i,k) = qrch - qlks(i,k) = qlko_ktcon(i) + zdqca(i,k) = dq endif endif enddo endif c - do k = 2, km1 - do i = 1, im - if (cnvflg(i)) then - if(k > kbcon(i) .and. k < ktcon(i)) then - zdqca(i,k)=((qlks(i,k)-qlks(i,k-1)) + - & pwo(i,k)+dellal(i,k)) - endif - endif - enddo - enddo - c--- compute precipitation efficiency in terms of windshear c !! - Calculate the wind shear and precipitation efficiency according to equation 58 in Fritsch and Chappell (1980) \cite fritsch_and_chappell_1980 : @@ -1935,11 +1924,32 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & c !> - From Bengtsson et al. (2022) \cite Bengtsson_2022 prognostic closure scheme, equation 8, call progsigma_calc() to compute updraft area fraction based on a moisture budget if(progsigma)then +! Initial computations, dynamic q-tendency + if(first_time_step .and. .not.restart)then + do k = 1,km + do i = 1,im + qadv(i,k)=0. + enddo + enddo + else + do k = 1,km + do i = 1,im + qadv(i,k)=(q(i,k) - prevsq(i,k))*invdelt + enddo + enddo + endif + + do k = 1,km + do i = 1,im + tmfq(i,k)=tmf(i,k,1) + enddo + enddo + flag_shallow = .true. call progsigma_calc(im,km,first_time_step,restart,flag_shallow, - & del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,hvap,delt, - & prevsq,q,kbcon1,ktcon,cnvflg, - & sigmain,sigmaout,sigmab,errmsg,errflg) + & del,tmfq,qmicro,dbyo1,zdqca,omega_u,zeta,hvap,delt, + & qadv,kbcon1,ktcon,cnvflg, + & sigmain,sigmaout,sigmab) endif !> - From Han et al.'s (2017) \cite han_et_al_2017 equation 6, calculate cloud base mass flux as a function of the mean updraft velcoity. diff --git a/physics/samfshalcnv.meta b/physics/samfshalcnv.meta index 8c9735c32..c1fffef58 100644 --- a/physics/samfshalcnv.meta +++ b/physics/samfshalcnv.meta @@ -70,10 +70,10 @@ type = logical intent = in [tmf] - standard_name = instantaneous_tendency_of_specific_humidity_due_to_PBL - long_name = instantaneous_tendency_of_specific_humidity_due_to_PBL + standard_name = tendency_of_vertically_diffused_tracer_concentration + long_name = updated tendency of the tracers due to vertical diffusion in PBL scheme units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_vertical_diffusion_tracers) type = real kind = kind_phys intent = in diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index 08876f8f0..0387185e4 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -73,9 +73,9 @@ end subroutine satmedmfvdifq_init !! -# A mass-flux approach is also used to represent the stratocumulus-top-induced turbulence !! (mfscuq.f). !! \section detail_satmedmfvidfq GFS satmedmfvdifq Detailed Algorithm - subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & + subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & & ntiw,ntke,grav,rd,cp,rv,hvap,hfus,fv,eps,epsm1, & - & dv,du,tdt,rtg,tmf,u1,v1,t1,q1,swh,hlw,xmu,garea,zvfun, & + & dv,du,tdt,rtg,u1,v1,t1,q1,swh,hlw,xmu,garea,zvfun, & & psk,rbsoil,zorl,u10m,v10m,fm,fh, & & tsea,heat,evap,stress,spd1,kpbl, & & prsi,del,prsl,prslk,phii,phil,delt, & @@ -98,7 +98,7 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & integer, intent(in) :: tc_pbl integer, intent(in) :: kinver(:) integer, intent(out) :: kpbl(:) - logical, intent(in) :: gen_tend,ldiag3d,progsigma + logical, intent(in) :: gen_tend,ldiag3d ! real(kind=kind_phys), intent(in) :: grav,rd,cp,rv,hvap,hfus,fv, & & eps,epsm1 @@ -106,7 +106,7 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & real(kind=kind_phys), intent(in) :: dspfac, bl_upfr, bl_dnfr real(kind=kind_phys), intent(in) :: rlmx, elmx real(kind=kind_phys), intent(inout) :: dv(:,:), du(:,:), & - & tdt(:,:), rtg(:,:,:), tmf(:,:) + & tdt(:,:), rtg(:,:,:) real(kind=kind_phys), intent(in) :: & & u1(:,:), v1(:,:), & & t1(:,:), q1(:,:,:), & @@ -331,14 +331,6 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & zm(i,k) = zi(i,k+1) enddo enddo -!> - Initialize variables needed for prognostic cumulus closure - if(progsigma)then - do k=1,km - do i=1,im - tmf(i,k) = 0. - enddo - enddo - endif !> - Compute horizontal grid size (\p gdx) do i=1,im gdx(i) = sqrt(garea(i)) @@ -2206,14 +2198,6 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & enddo enddo - if(progsigma)then - do k = 1,km - do i = 1,im - tmf(i,k)=(f2(i,k)-q1(i,k,1))*rdt - enddo - enddo - endif - do i = 1,im dtsfc(i) = rho_a(i) * cp * heat(i) dqsfc(i) = rho_a(i) * hvap * evap(i) diff --git a/physics/satmedmfvdifq.meta b/physics/satmedmfvdifq.meta index d9ab8c859..d0b11656a 100644 --- a/physics/satmedmfvdifq.meta +++ b/physics/satmedmfvdifq.meta @@ -62,13 +62,6 @@ dimensions = () type = integer intent = in -[progsigma] - standard_name = do_prognostic_updraft_area_fraction - long_name = flag for prognostic sigma in cumuls scheme - units = flag - dimensions = () - type = logical - intent = in [ntrac] standard_name = number_of_vertical_diffusion_tracers long_name = number of tracers to diffuse vertically @@ -208,14 +201,6 @@ type = real kind = kind_phys intent = inout -[tmf] - standard_name = instantaneous_tendency_of_specific_humidity_due_to_PBL - long_name = instantaneous_tendency_of_specific_humidity_due_to_PBL - units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout [u1] standard_name = x_wind long_name = x component of layer wind From a1fe46d936f094f6201c1041716d183e91ff6226 Mon Sep 17 00:00:00 2001 From: "Haiqin.Li" Date: Fri, 24 Mar 2023 02:24:03 +0000 Subject: [PATCH 196/380] "to address the comments from the ccpp reviewer" --- physics/GFS_rrtmg_pre.F90 | 16 +++++++++------- physics/GFS_rrtmg_pre.meta | 12 ++++++++++-- physics/smoke_dust/rrfs_smoke_postpbl.meta | 4 ++-- physics/smoke_dust/rrfs_smoke_wrapper.F90 | 18 +++++++++--------- physics/smoke_dust/rrfs_smoke_wrapper.meta | 20 ++++++++++++++------ 5 files changed, 44 insertions(+), 26 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index d43e182db..53e1d29b3 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -44,7 +44,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& gasvmr_ccl4, gasvmr_cfc113, aerodp,ext550, clouds6, clouds7, clouds8, & clouds9, cldsa, cldfra, cldfra2d, lwp_ex,iwp_ex, lwp_fc,iwp_fc, & faersw1, faersw2, faersw3, faerlw1, faerlw2, faerlw3, alpha, & - aero_dir_fdb, spp_wts_rad, spp_rad, ico2, errmsg, errflg) + aero_dir_fdb, fdb_coef, spp_wts_rad, spp_rad, ico2, errmsg, errflg) use machine, only: kind_phys @@ -155,6 +155,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& clouds2, clouds3, & clouds4, clouds5 real(kind=kind_phys), dimension(:,:), intent(in) :: qci_conv + real(kind=kind_phys), dimension(:), intent(in) :: fdb_coef real(kind=kind_phys), dimension(:), intent(out) :: lwp_ex,iwp_ex, & lwp_fc,iwp_fc @@ -640,12 +641,13 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& if (aero_dir_fdb) then do k=1,lmk do i=1,im - aer_nm(i,k,1 )=aer_nm(i,k,1 )+qgrs(i,k,ntdust)*0.33*1.e-9 ! dust bin1 - aer_nm(i,k,2 )=aer_nm(i,k,2 )+(qgrs(i,k,ntdust)*0.67+qgrs(i,k,ntcoarsepm)*0.02)*1.e-9 - aer_nm(i,k,3 )=aer_nm(i,k,3 )+qgrs(i,k,ntcoarsepm)*0.13*1.e-9 ! dust bin3 - aer_nm(i,k,4 )=aer_nm(i,k,4 )+qgrs(i,k,ntcoarsepm)*0.85*1.e-9 ! dust bin4 - aer_nm(i,k,12)=aer_nm(i,k,12)+qgrs(i,k,ntsmoke)*1.e-9*0.05 !Smoke BC - aer_nm(i,k,14)=aer_nm(i,k,14)+qgrs(i,k,ntsmoke)*1.e-9*0.95 !Smoke OA, we may need to revise later for OA vs. OC + aer_nm(i,k,1 )=aer_nm(i,k,1 )+ qgrs(i,k,ntdust)*fdb_coef(1)*1.e-9 ! dust bin1 + aer_nm(i,k,2 )=aer_nm(i,k,2 )+(qgrs(i,k,ntdust)*fdb_coef(2) & + +qgrs(i,k,ntcoarsepm)*fdb_coef(3))*1.e-9 ! dust bin2 + aer_nm(i,k,3 )=aer_nm(i,k,3 )+qgrs(i,k,ntcoarsepm)*fdb_coef(4)*1.e-9 ! dust bin3 + aer_nm(i,k,4 )=aer_nm(i,k,4 )+qgrs(i,k,ntcoarsepm)*fdb_coef(5)*1.e-9 ! dust bin4 + aer_nm(i,k,12)=aer_nm(i,k,12)+qgrs(i,k,ntsmoke)*fdb_coef(6)*1.e-9 ! Smoke BC + aer_nm(i,k,14)=aer_nm(i,k,14)+qgrs(i,k,ntsmoke)*fdb_coef(7)*1.e-9 ! Smoke OA enddo enddo endif diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index a8b549bce..82ffd07c2 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -234,8 +234,8 @@ type = integer intent = in [ntcoarsepm] - standard_name = index_for_coarse_pm_in_tracer_concentration_array - long_name = tracer index for coarse pm + standard_name = index_for_coarse_particulate_matter_in_tracer_concentration_array + long_name = tracer index for coarse particulate matter units = index dimensions = () type = integer @@ -1466,6 +1466,14 @@ dimensions = () type = logical intent = in +[fdb_coef] + standard_name = smoke_dust_direct_fdb_coef + long_name = smoke dust direct feedback coefficents + units = none + dimensions = (7) + type = real + kind = kind_phys + intent = in [spp_wts_rad] standard_name = spp_weights_for_radiation_scheme long_name = spp weights for radiation scheme diff --git a/physics/smoke_dust/rrfs_smoke_postpbl.meta b/physics/smoke_dust/rrfs_smoke_postpbl.meta index dab56cddc..50f7afae7 100755 --- a/physics/smoke_dust/rrfs_smoke_postpbl.meta +++ b/physics/smoke_dust/rrfs_smoke_postpbl.meta @@ -36,8 +36,8 @@ type = integer intent = in [ntcoarsepm] - standard_name = index_for_coarse_pm_in_tracer_concentration_array - long_name = tracer index for coarse pm + standard_name = index_for_coarse_particulate_matter_in_tracer_concentration_array + long_name = tracer index for coarse particulate matter units = index dimensions = () type = integer diff --git a/physics/smoke_dust/rrfs_smoke_wrapper.F90 b/physics/smoke_dust/rrfs_smoke_wrapper.F90 index 80c43360b..1f9ef6340 100755 --- a/physics/smoke_dust/rrfs_smoke_wrapper.F90 +++ b/physics/smoke_dust/rrfs_smoke_wrapper.F90 @@ -41,8 +41,8 @@ module rrfs_smoke_wrapper subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, & u10m, v10m, ustar, rlat, rlon, tskin, pb2d, t2m, dpt2m, & pr3d, ph3d,phl3d, prl3d, tk3d, us3d, vs3d, spechum, w, & - nsoil, smc, vegtype, soiltyp, sigmaf, dswsfc, zorl,snow, & - julian, idat, rain_cpl, rainc_cpl, exch, hf2d, g, pi, con_cp, con_rd, & + nsoil, smc, vegtype, soiltyp, sigmaf, dswsfc, zorl, snow, julian, & + idat, rain_cpl, rainc_cpl, exch, hf2d, g, pi, con_cp, con_rd, con_fv, & dust12m_in, emi_in, smoke_RRFS, ntrac, qgrs, gq0, chem3d, tile_num, & ntsmoke, ntdust, ntcoarsepm, imp_physics, imp_physics_thompson, & nwfa, nifa, emanoc, emdust, emseas, & @@ -60,7 +60,7 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, integer, intent(in) :: im,kte,kme,ktau,nsoil,tile_num,jdate(8),idat(8) integer, intent(in) :: ntrac, ntsmoke, ntdust, ntcoarsepm, ndvel - real(kind_phys),intent(in) :: dt, julian, g, pi, con_cp, con_rd + real(kind_phys),intent(in) :: dt, julian, g, pi, con_cp, con_rd, con_fv logical, intent(in) :: aero_ind_fdb_in,dbg_opt_in integer, intent(in) :: smoke_forecast_in @@ -228,7 +228,7 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, !>- get ready for chemistry run call rrfs_smoke_prep( & - current_month, current_hour, gmt, & + current_month, current_hour, gmt, con_rd, con_fv, & u10m,v10m,ustar,land,garea,rlat,rlon,tskin, & pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,exch,w, & nsoil,smc,vegtype,soiltyp,sigmaf,dswsfc,zorl, & @@ -418,8 +418,8 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, do k=kts,kte do i=its,ite gq0(i,k,ntsmoke ) = min(5000.,max(epsilc,chem(i,k,1,p_smoke ))) - gq0(i,k,ntdust ) = min(100.,max(epsilc,chem(i,k,1,p_dust_1))) - gq0(i,k,ntcoarsepm)= min(1000.,max(epsilc,chem(i,k,1,p_coarse_pm))) + gq0(i,k,ntdust ) = min(200.,max(epsilc,chem(i,k,1,p_dust_1))) + gq0(i,k,ntcoarsepm)= min(5000.,max(epsilc,chem(i,k,1,p_coarse_pm))) enddo enddo @@ -482,7 +482,7 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, end subroutine rrfs_smoke_wrapper_run subroutine rrfs_smoke_prep( & - current_month,current_hour,gmt, & + current_month,current_hour,gmt,con_rd,con_fv, & u10m,v10m,ustar,land,garea,rlat,rlon,ts2d, & pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,exch,w, & nsoil,smc,vegtype,soiltyp,sigmaf,dswsfc,zorl, & @@ -510,7 +510,7 @@ subroutine rrfs_smoke_prep( & integer, intent(in) :: nsoil integer, dimension(ims:ime), intent(in) :: land, vegtype, soiltyp integer, intent(in) :: ntrac - real(kind=kind_phys), intent(in) :: g, pi, gmt + real(kind=kind_phys), intent(in) :: g, pi, gmt, con_rd, con_fv real(kind=kind_phys), dimension(ims:ime), intent(in) :: & u10m, v10m, ustar, garea, rlat, rlon, ts2d, sigmaf, dswsfc, & zorl, snow_cpl, pb2d, hf2d @@ -671,7 +671,7 @@ subroutine rrfs_smoke_prep( & p_phy(i,k,j)=prl3d(i,kkp) u_phy(i,k,j)=us3d(i,kkp) v_phy(i,k,j)=vs3d(i,kkp) - rho_phy(i,k,j)=p_phy(i,k,j)/(287.04*t_phy(i,k,j)*(1.+.608*spechum(i,kkp))) + rho_phy(i,k,j)=p_phy(i,k,j)/(con_rd*t_phy(i,k,j)*(1.+con_fv*spechum(i,kkp))) rri(i,k,j)=1./rho_phy(i,k,j) vvel(i,k,j)=-w(i,kkp)*rri(i,k,j)/g moist(i,k,j,:)=0. diff --git a/physics/smoke_dust/rrfs_smoke_wrapper.meta b/physics/smoke_dust/rrfs_smoke_wrapper.meta index 2b2be03b6..bf2fddd60 100755 --- a/physics/smoke_dust/rrfs_smoke_wrapper.meta +++ b/physics/smoke_dust/rrfs_smoke_wrapper.meta @@ -349,6 +349,14 @@ type = real kind = kind_phys intent = in +[con_fv] + standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one + long_name = (rv/rd) - 1 (rv = ideal gas constant for water vapor) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in [dust12m_in] standard_name = fengsha_dust12m_input long_name = fengsha dust input @@ -426,8 +434,8 @@ type = integer intent = in [ntcoarsepm] - standard_name = index_for_coarse_pm_in_tracer_concentration_array - long_name = tracer index for coarse pm + standard_name = index_for_coarse_particulate_matter_in_tracer_concentration_array + long_name = tracer index for coarse particulate matter units = index dimensions = () type = integer @@ -463,8 +471,8 @@ kind = kind_phys intent = inout [emanoc] - standard_name = emission_of_anoc_for_thompson_mp - long_name = emission of anoc for thompson mp + standard_name = emission_of_anothropogenic_for_mp_indir_fdb + long_name = emission of anothropogenic for mp indirect feedabck units = ug m-2 s-1 dimensions = (horizontal_loop_extent) type = real @@ -479,8 +487,8 @@ kind = kind_phys intent = inout [emseas] - standard_name = emission_of_seas_for_smoke - long_name = emission of seas for smoke + standard_name = emission_of_sea_salt_for_mp_indir_fdb + long_name = emission of sea salt for mp indirect feedabck units = ug m-2 s-1 dimensions = (horizontal_loop_extent) type = real From 48e092fb529cd8fed83db3bba44ac3d13b6da909 Mon Sep 17 00:00:00 2001 From: joeolson42 Date: Fri, 24 Mar 2023 19:06:26 +0000 Subject: [PATCH 197/380] Updates to the MYNN surface-layer scheme --- physics/module_sf_mynn.F90 | 864 ++++++++++++++++++------------------ physics/mynnsfc_wrapper.F90 | 56 +-- 2 files changed, 443 insertions(+), 477 deletions(-) diff --git a/physics/module_sf_mynn.F90 b/physics/module_sf_mynn.F90 index 33678fa3a..c60247cf6 100644 --- a/physics/module_sf_mynn.F90 +++ b/physics/module_sf_mynn.F90 @@ -61,62 +61,50 @@ MODULE module_sf_mynn !NOTE: This code was primarily tested in combination with the RUC LSM. ! Performance with the Noah (or other) LSM is relatively unknown. !------------------------------------------------------------------- -!For WRF -! USE module_model_constants, only: & -! & p1000mb, ep_2 -! -!For non-WRF - use physcons, only : cp => con_cp, & - & g => con_g, & - & r_d => con_rd, & - & r_v => con_rv, & - & cpv => con_cvap, & - & cliq => con_cliq, & - & Cice => con_csol, & - & rcp => con_rocp, & - & XLV => con_hvap, & - & XLF => con_hfus, & - & EP_1 => con_fvirt, & - & EP_2 => con_eps - -!use subroutines from sfc_diff: -! USE sfc_diff, only: znot_t_v6, znot_t_v7, znot_m_v6, znot_m_v7 - -!use kind=kind_phys for real-types +!Include host model constants + use physcons, only : cp => con_cp, & !=7*Rd/2 + & grav => con_g, & !=9.81 + & Rd => con_rd, & !=287. + & Rv => con_rv, & !=461.6 +! & cpv => con_cvap, & !=4*Rv + & rovcp => con_rocp, & !=Rd/cp + & xlv => con_hvap, & !2.5e6 + & xlf => con_hfus, & !3.5e5 + & ep1 => con_fvirt, & !Rv/Rd - 1 + & ep2 => con_eps !Rd/Rv + +!use kind_phys for real-types use machine , only : kind_phys !------------------------------------------------------------------- IMPLICIT NONE !------------------------------------------------------------------- -!For non-WRF -! REAL(kind=kind_phys), PARAMETER :: g = 9.81 -! REAL(kind=kind_phys), PARAMETER :: r_d = 287. -! REAL(kind=kind_phys), PARAMETER :: cp = 7.*r_d/2. -! REAL(kind=kind_phys), PARAMETER :: r_v = 461.6 -! REAL(kind=kind_phys), PARAMETER :: cpv = 4.*r_v -! REAL(kind=kind_phys), PARAMETER :: rcp = r_d/cp -! REAL(kind=kind_phys), PARAMETER :: XLV = 2.5E6 -! REAL(kind=kind_phys), PARAMETER :: XLF = 3.50E5 - REAL(kind=kind_phys), PARAMETER :: p1000mb = 100000. -! REAL(kind=kind_phys), PARAMETER :: EP_2 = r_d/r_v - - REAL(kind=kind_phys), PARAMETER :: xlvcp=xlv/cp, ep_3=1.-ep_2 - REAL(kind=kind_phys), PARAMETER :: wmin=0.1 ! Minimum wind speed - REAL(kind=kind_phys), PARAMETER :: VCONVC=1.25 - REAL(kind=kind_phys), PARAMETER :: onethird = 1./3. - REAL(kind=kind_phys), PARAMETER :: sqrt3 = 1.7320508075688773 - REAL(kind=kind_phys), PARAMETER :: atan1 = 0.785398163397 !in radians - REAL(kind=kind_phys), PARAMETER :: log01=log(0.01) - REAL(kind=kind_phys), PARAMETER :: log05=log(0.05) - REAL(kind=kind_phys), PARAMETER :: log07=log(0.07) - REAL(kind=kind_phys), PARAMETER :: SNOWZ0=0.011 - REAL(kind=kind_phys), PARAMETER :: COARE_OPT=3.0 ! 3.0 or 3.5 +!Drive and/or define more constant: + real(kind_phys), parameter :: ep3 = 1.-ep2 + real(kind_phys), parameter :: g_inv = 1.0/grav + real(kind_phys), parameter :: rvovrd = Rv/Rd + real(kind_phys), parameter :: wmin = 0.1 ! Minimum wind speed + real(kind_phys), parameter :: karman = 0.4 + real(kind_phys), parameter :: SVP1 = 0.6112 + real(kind_phys), parameter :: SVP2 = 17.67 + real(kind_phys), parameter :: SVP3 = 29.65 + real(kind_phys), parameter :: SVPT0 = 273.15 + real(kind_phys), parameter :: VCONVC = 1.25 + real(kind_phys), parameter :: onethird = 1./3. + real(kind_phys), parameter :: sqrt3 = 1.7320508075688773 + real(kind_phys), parameter :: atan1 = 0.785398163397 !in radians + real(kind_phys), parameter :: log01 = log(0.01) + real(kind_phys), parameter :: log05 = log(0.05) + real(kind_phys), parameter :: log07 = log(0.07) + real(kind_phys), parameter :: SNOWZ0 = 0.011 + real(kind_phys), parameter :: COARE_OPT = 3.0 ! 3.0 or 3.5 + !For debugging purposes: INTEGER, PARAMETER :: debug_code = 0 !0: no extra ouput !1: check input !2: everything - heavy I/O - REAL(kind=kind_phys), DIMENSION(0:1000 ),SAVE :: psim_stab,psim_unstab, & + REAL(kind_phys), DIMENSION(0:1000 ),SAVE :: psim_stab,psim_unstab, & psih_stab,psih_unstab CONTAINS @@ -129,8 +117,6 @@ SUBROUTINE SFCLAY_mynn( & U3D,V3D,T3D,QV3D,P3D,dz8w, & !in th3d,pi3d,qc3d, & !in PSFCPA,PBLH,MAVAIL,XLAND,DX, & !in - CP,G,ROVCP,R,XLV, & !in - SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN, & !in ISFFLX,isftcflx,lsm,lsm_ruc, & !in compute_flux,compute_diag, & !in iz0tlnd,psi_opt, & !in @@ -138,6 +124,7 @@ SUBROUTINE SFCLAY_mynn( & z0pert,ztpert, & !intent(in) redrag,sfc_z0_type, & !intent(in) itimestep,iter,flag_iter, & !in + flag_restart, & !in wet, dry, icy, & !intent(in) tskin_wat, tskin_lnd, tskin_ice, & !intent(in) tsurf_wat, tsurf_lnd, tsurf_ice, & !intent(in) @@ -177,9 +164,9 @@ SUBROUTINE SFCLAY_mynn( & !-- P3D 3D pressure (Pa) !-- dz8w 3D dz between full levels (m) !-- CP heat capacity at constant pressure for dry air (J/kg/K) -!-- G acceleration due to gravity (m/s^2) +!-- grav acceleration due to gravity (m/s^2) !-- ROVCP R/CP -!-- R gas constant for dry air (J/kg/K) +!-- Rd gas constant for dry air (J/kg/K) !-- XLV latent heat of vaporization for water (J/kg) !-- PSFCPA surface pressure (Pa) !-- ZNT roughness length (m) @@ -269,26 +256,24 @@ SUBROUTINE SFCLAY_mynn( & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte INTEGER, INTENT(IN) :: itimestep,iter - REAL(kind=kind_phys), INTENT(IN) :: SVP1,SVP2,SVP3,SVPT0 - REAL(kind=kind_phys), INTENT(IN) :: EP1,EP2,KARMAN - REAL(kind=kind_phys), INTENT(IN) :: CP,G,ROVCP,R,XLV !,DX !NAMELIST/CONFIGURATION OPTIONS: - INTEGER, INTENT(IN) :: ISFFLX, LSM, LSM_RUC - INTEGER, OPTIONAL, INTENT(IN) :: ISFTCFLX, IZ0TLND - INTEGER, OPTIONAL, INTENT(IN) :: spp_sfc, psi_opt - logical, intent(in) :: compute_flux,compute_diag + integer, intent(in) :: ISFFLX, LSM, LSM_RUC + INTEGER, OPTIONAL, INTENT(IN) :: ISFTCFLX, IZ0TLND + INTEGER, OPTIONAL, INTENT(IN) :: spp_sfc, psi_opt + logical, intent(in) :: compute_flux,compute_diag integer, intent(in) :: ivegsrc integer, intent(in) :: sfc_z0_type ! option for calculating surface roughness length over ocean logical, intent(in) :: redrag ! reduced drag coeff. flag for high wind over sea (j.han) + logical, intent(in) :: flag_restart !Input data integer, dimension(ims:ime), intent(in) :: vegtype - real(kind=kind_phys), dimension(ims:ime), intent(in) :: & + real(kind_phys), dimension(ims:ime), intent(in) :: & & sigmaf,shdmax,z0pert,ztpert !=================================== ! 3D VARIABLES !=================================== - REAL(kind=kind_phys), DIMENSION( ims:ime, kms:kme ) , & + REAL(kind_phys), DIMENSION( ims:ime, kms:kme ) , & INTENT(IN ) :: dz8w, & QV3D, & P3D, & @@ -298,24 +283,24 @@ SUBROUTINE SFCLAY_mynn( & th3d,pi3d !GJF: This array must be assumed-shape since it is conditionally-allocated - REAL(kind=kind_phys), DIMENSION( :,: ), & + REAL(kind_phys), DIMENSION( :,: ), & INTENT(IN) :: pattern_spp_sfc !=================================== ! 2D VARIABLES !=================================== - REAL(kind=kind_phys), DIMENSION( ims:ime ) , & + REAL(kind_phys), DIMENSION( ims:ime ) , & INTENT(IN ) :: MAVAIL, & PBLH, & XLAND, & PSFCPA, & DX - REAL(kind=kind_phys), DIMENSION( ims:ime ) , & + REAL(kind_phys), DIMENSION( ims:ime ) , & INTENT(OUT ) :: U10,V10, & TH2,T2,Q2 - REAL(kind=kind_phys), DIMENSION( ims:ime ) , & + REAL(kind_phys), DIMENSION( ims:ime ) , & INTENT(INOUT) :: HFLX,HFX, & QFLX,QFX, & LH, & @@ -338,12 +323,12 @@ SUBROUTINE SFCLAY_mynn( & LOGICAL, DIMENSION( ims:ime ), INTENT(IN) :: & & wet, dry, icy, flag_iter - REAL(kind=kind_phys), DIMENSION( ims:ime ), INTENT(IN) :: & + REAL(kind_phys), DIMENSION( ims:ime ), INTENT(IN) :: & & tskin_wat, tskin_lnd, tskin_ice, & & tsurf_wat, tsurf_lnd, tsurf_ice, & & snowh_wat, snowh_lnd, snowh_ice - REAL(kind=kind_phys), DIMENSION( ims:ime), INTENT(INOUT) :: & + REAL(kind_phys), DIMENSION( ims:ime), INTENT(INOUT) :: & & ZNT_wat, ZNT_lnd, ZNT_ice, & & UST_wat, UST_lnd, UST_ice, & & cm_wat, cm_lnd, cm_ice, & @@ -364,12 +349,12 @@ SUBROUTINE SFCLAY_mynn( & !ADDITIONAL OUTPUT !JOE-begin - REAL(kind=kind_phys), DIMENSION( ims:ime ) :: qstar + REAL(kind_phys), DIMENSION( ims:ime ) :: qstar !JOE-end !=================================== ! 1D LOCAL ARRAYS !=================================== - REAL(kind=kind_phys), DIMENSION( its:ite ) :: U1D,V1D, & !level1 winds + REAL(kind_phys), DIMENSION( its:ite ) :: U1D,V1D, & !level1 winds U1D2,V1D2, & !level2 winds QV1D, & P1D, & @@ -377,7 +362,7 @@ SUBROUTINE SFCLAY_mynn( & dz8w1d, & !level 1 height dz2w1d !level 2 height - REAL(kind=kind_phys), DIMENSION( its:ite ) :: rstoch1D + REAL(kind_phys), DIMENSION( its:ite ) :: rstoch1D INTEGER :: I,J,K,itf,ktf !----------------------------------------------------------- @@ -388,11 +373,10 @@ SUBROUTINE SFCLAY_mynn( & IF (debug_code >= 1) THEN write(*,*)"======= printing of constants:" - write(*,*)"cp=", cp," g=", g - write(*,*)"Rd=", r_d," Rv=", r_v, " cpc=", cpv - write(*,*)"cliq=", cliq," cice=", Cice," rcp=", rcp - write(*,*)"xlv=", XLV," xlf=", XLF - write(*,*)"ep1=", EP_1, " ep2=", EP_2 + write(*,*)"cp=", cp," g=", grav + write(*,*)"Rd=", Rd," ep1=", ep1 + write(*,*)"xlv=", XLV," xlf=", XLF + write(*,*)"ep2=", ep2 ENDIF itf=ite !MIN0(ite,ide-1) @@ -420,11 +404,19 @@ SUBROUTINE SFCLAY_mynn( & IF (itimestep==1 .AND. iter==1) THEN DO i=its,ite - !Everything here is used before calculated - UST_WAT(i)=MAX(0.04*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.001_kind_phys) - UST_LND(i)=MAX(0.04*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.001_kind_phys) - UST_ICE(i)=MAX(0.04*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.001_kind_phys) - MOL(i)=0.0 + IF (.not. flag_restart) THEN + !Everything here is used before calculated + if (ust_wat(i) .lt. 1e-4 .or. ust_wat(i) .gt. 3.0) then + UST_WAT(i)=MAX(0.04*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.001_kind_phys) + endif + if (ust_lnd(i) .lt. 1e-4 .or. ust_lnd(i) .gt. 3.0) then + UST_LND(i)=MAX(0.04*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.001_kind_phys) + endif + if (ust_ice(i) .lt. 1e-4 .or. ust_ice(i) .gt. 3.0) then + UST_ICE(i)=MAX(0.04*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.001_kind_phys) + endif + MOL(i)=0.0 + ENDIF ! restart QFLX(i)=0. HFLX(i)=0. if ( LSM == LSM_RUC ) then @@ -444,14 +436,12 @@ SUBROUTINE SFCLAY_mynn( & J,U1D,V1D,T1D,QV1D,P1D,dz8w1d, & U1D2,V1D2,dz2w1d, & PSFCPA,PBLH,MAVAIL,XLAND,DX, & - CP,G,ROVCP,R,XLV,SVP1,SVP2,SVP3,SVPT0, & - EP1,EP2,KARMAN, & ISFFLX,isftcflx,iz0tlnd,psi_opt, & compute_flux,compute_diag, & sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) z0pert,ztpert, & !intent(in) redrag,sfc_z0_type, & !intent(in) - itimestep,iter,lsm,lsm_ruc, & + itimestep,iter,flag_restart,lsm,lsm_ruc, & wet, dry, icy, & !intent(in) tskin_wat, tskin_lnd, tskin_ice, & !intent(in) tsurf_wat, tsurf_lnd, tsurf_ice, & !intent(in) @@ -492,14 +482,12 @@ END SUBROUTINE SFCLAY_MYNN SUBROUTINE SFCLAY1D_mynn(flag_iter, & J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,U1D2,V1D2,dz2w1d, & PSFCPA,PBLH,MAVAIL,XLAND,DX, & - CP,G,ROVCP,R,XLV,SVP1,SVP2,SVP3,SVPT0, & - EP1,EP2,KARMAN, & ISFFLX,isftcflx,iz0tlnd,psi_opt, & compute_flux,compute_diag, & sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) z0pert,ztpert, & !intent(in) redrag,sfc_z0_type, & !intent(in) - itimestep,iter,lsm,lsm_ruc, & + itimestep,iter,flag_restart,lsm,lsm_ruc, & wet, dry, icy, & !intent(in) tskin_wat, tskin_lnd, tskin_ice, & !intent(in) tsurf_wat, tsurf_lnd, tsurf_ice, & !intent(in) @@ -535,44 +523,43 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !------------------------------------------------------------------- ! SCALARS !----------------------------- - INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde, & + INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & J, itimestep, iter, lsm, lsm_ruc + LOGICAL, INTENT(IN) :: flag_restart - REAL(kind=kind_phys), PARAMETER :: XKA=2.4E-5 !molecular diffusivity - REAL(kind=kind_phys), PARAMETER :: PRT=1. !prandlt number - REAL(kind=kind_phys), PARAMETER :: snowh_thresh = 50. !mm - REAL(kind=kind_phys), INTENT(IN) :: SVP1,SVP2,SVP3,SVPT0,EP1,EP2 - REAL(kind=kind_phys), INTENT(IN) :: KARMAN,CP,G,ROVCP,R,XLV !,DX + REAL(kind_phys), PARAMETER :: XKA=2.4E-5 !molecular diffusivity + REAL(kind_phys), PARAMETER :: PRT=1. !prandlt number + REAL(kind_phys), PARAMETER :: snowh_thresh = 50. !mm !----------------------------- ! NAMELIST OPTIONS !----------------------------- - INTEGER, INTENT(IN) :: ISFFLX - INTEGER, OPTIONAL, INTENT(IN ) :: ISFTCFLX, IZ0TLND - logical, intent(in) :: compute_flux,compute_diag - INTEGER, INTENT(IN) :: spp_sfc, psi_opt + integer, intent(in) :: ISFFLX + integer, optional, intent(in) :: ISFTCFLX, IZ0TLND + logical, intent(in) :: compute_flux,compute_diag + integer, intent(in) :: spp_sfc, psi_opt integer, intent(in) :: ivegsrc integer, intent(in) :: sfc_z0_type ! option for calculating surface roughness length over ocean logical, intent(in) :: redrag ! reduced drag coeff. flag for high wind over sea (j.han) !Input data integer, dimension(ims:ime), intent(in) :: vegtype - real(kind=kind_phys), dimension(ims:ime), intent(in) :: & - & sigmaf,shdmax,z0pert,ztpert + real(kind_phys), dimension(ims:ime), intent(in) :: & + & sigmaf,shdmax,z0pert,ztpert !----------------------------- ! 1D ARRAYS !----------------------------- - REAL(kind=kind_phys), DIMENSION( ims:ime ), & + REAL(kind_phys), DIMENSION( ims:ime ), & INTENT(IN) :: MAVAIL, & PBLH, & XLAND, & PSFCPA, & DX - REAL(kind=kind_phys), DIMENSION( its:ite ), & + REAL(kind_phys), DIMENSION( its:ite ), & INTENT(IN) :: U1D,V1D, & U1D2,V1D2, & QV1D,P1D, & @@ -580,10 +567,10 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & dz8w1d, & dz2w1d - REAL(kind=kind_phys), DIMENSION( ims:ime ), & + REAL(kind_phys), DIMENSION( ims:ime ), & INTENT(OUT) :: QFX,HFX, & RMOL - REAL(kind=kind_phys), DIMENSION( ims:ime ), & + REAL(kind_phys), DIMENSION( ims:ime ), & INTENT(INOUT) :: HFLX,QFLX, & LH,MOL, & QGH,QSFC, & @@ -602,12 +589,12 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & LOGICAL, DIMENSION( ims:ime ), INTENT(IN) :: & & wet, dry, icy, flag_iter - REAL(kind=kind_phys), DIMENSION( ims:ime ), INTENT(in) :: & + REAL(kind_phys), DIMENSION( ims:ime ), INTENT(in) :: & & tskin_wat, tskin_lnd, tskin_ice, & & tsurf_wat, tsurf_lnd, tsurf_ice, & & snowh_wat, snowh_lnd, snowh_ice - REAL(kind=kind_phys), DIMENSION( ims:ime ), INTENT(inout) :: & + REAL(kind_phys), DIMENSION( ims:ime ), INTENT(inout) :: & & ZNT_wat, ZNT_lnd, ZNT_ice, & & UST_wat, UST_lnd, UST_ice, & & cm_wat, cm_lnd, cm_ice, & @@ -622,18 +609,18 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & & QFLX_wat, QFLX_lnd, QFLX_ice, & & qsfc_wat, qsfc_lnd, qsfc_ice - REAL(kind=kind_phys), DIMENSION( its:ite ), & + REAL(kind_phys), DIMENSION( its:ite ), & & INTENT(IN) :: rstoch1D ! DIAGNOSTIC OUTPUT - REAL(kind=kind_phys), DIMENSION( ims:ime ), & + REAL(kind_phys), DIMENSION( ims:ime ), & & INTENT(OUT) :: U10, V10, & & TH2, T2, & & Q2 !-------------------------------------------- !JOE-additinal output - REAL(kind=kind_phys), DIMENSION( ims:ime ), & + REAL(kind_phys), DIMENSION( ims:ime ), & & INTENT(OUT) :: wstar, & & qstar !JOE-end @@ -645,7 +632,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !---------------------------------------------------------------- ! LOCAL VARS !---------------------------------------------------------------- - REAL(kind=kind_phys), DIMENSION(its:ite) :: & + REAL(kind_phys), DIMENSION(its:ite) :: & ZA, & !Height of lowest 1/2 sigma level(m) ZA2, & !Height of 2nd lowest 1/2 sigma level(m) THV1D, & !Theta-v at lowest 1/2 sigma (K) @@ -658,7 +645,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & PSIM10, & !M-O stability functions at z=10 m PSIH10, & !M-O stability functions at z=10 m WSPDI, & - GOVRTH, & !g/theta + GOVRTH, & !grav/theta PSFC, & !press at surface (Pa/1000) QSFCMR, & !qv at surface (mixing ratio, kg/kg) THCON, & !conversion from temp to theta @@ -681,12 +668,12 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & INTEGER :: N,I,K,L,yesno - REAL(kind=kind_phys) :: PL,E1,TABS - REAL(kind=kind_phys) :: WSPD_lnd, WSPD_ice, WSPD_wat - REAL(kind=kind_phys) :: DTHVDZ,DTHVM,VCONV,ZOL2,ZOL10,ZOLZA,ZOLZ0,ZOLZT - REAL(kind=kind_phys) :: DTG,DTTHX,PSIQ,PSIQ2,PSIQ10,PSIT10 - REAL(kind=kind_phys) :: FLUXC,VSGD - REAL(kind=kind_phys) :: restar,VISC,DQG,OLDUST,OLDTST + REAL(kind_phys) :: PL,E1,TABS + REAL(kind_phys) :: WSPD_lnd, WSPD_ice, WSPD_wat + REAL(kind_phys) :: DTHVDZ,DTHVM,VCONV,ZOL2,ZOL10,ZOLZA,ZOLZ0,ZOLZT + REAL(kind_phys) :: DTG,DTTHX,PSIQ,PSIQ2,PSIQ10,PSIT10 + REAL(kind_phys) :: FLUXC,VSGD + REAL(kind_phys) :: restar,VISC,DQG,OLDUST,OLDTST ! Initialize error-handling errflg = 0 @@ -711,7 +698,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !SATURATION VAPOR PRESSURE WRT WATER (Bolton 1980) E1=SVP1*EXP(SVP2*(TSK_wat(I)-SVPT0)/(TSK_wat(i)-SVP3)) ENDIF - QSFC_wat(I)=EP2*E1/(PSFC(I)-ep_3*E1) !specific humidity + QSFC_wat(I)=EP2*E1/(PSFC(I)-ep3*E1) !specific humidity QSFCMR_wat(I)=EP2*E1/(PSFC(I)-E1) !mixing ratio IF(QSFC_wat(I)>1..or.QSFC_wat(I)<0.) print *,' QSFC_wat(I)',itimestep,i,QSFC_wat(I),TSK_wat(i) ENDIF @@ -729,7 +716,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !SATURATION VAPOR PRESSURE WRT WATER (Bolton 1980) E1=SVP1*EXP(SVP2*(TABS-SVPT0)/(TABS-SVP3)) ENDIF - QSFC_lnd(I)=EP2*E1/(PSFC(I)-ep_3*E1) !specific humidity + QSFC_lnd(I)=EP2*E1/(PSFC(I)-ep3*E1) !specific humidity QSFC_lnd(I)=0.5*(QSFC_lnd(I) + QSFC(I)) QSFCMR_lnd(I)=QSFC_lnd(I)/(1.-QSFC_lnd(I)) !mixing ratio endif ! lsm @@ -738,7 +725,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & IF (icy(i)) THEN TSK_ice(I) = tskin_ice(i) if( lsm == lsm_ruc) then - QSFCMR_ice(I)=QSFC_ice(I)/(1.-QSFC_ice(I)) !mixing ratio + QSFCMR_ice(I)=QSFC_ice(I)/(1.-QSFC_ice(I)) !mixing ratio else IF (TSK_ice(I) .LT. 273.15) THEN !SATURATION VAPOR PRESSURE WRT ICE (SVP1=.6112; 10*mb) @@ -748,7 +735,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !SATURATION VAPOR PRESSURE WRT WATER (Bolton 1980) E1=SVP1*EXP(SVP2*(TSK_ice(I)-SVPT0)/(TSK_ice(i)-SVP3)) ENDIF - QSFC_ice(I)=EP2*E1/(PSFC(I)-ep_3*E1) !specific humidity + QSFC_ice(I)=EP2*E1/(PSFC(I)-ep3*E1) !specific humidity QSFCMR_ice(I)=EP2*E1/(PSFC(I)-E1) !mixing ratio endif ! lsm IF(QSFC_ice(I)>1..or.QSFC_ice(I)<0.) print *,' QSFC_ice(I)',itimestep,i,QSFC_ice(I),TSK_ice(i) @@ -767,7 +754,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !SATURATION VAPOR PRESSURE WRT WATER (Bolton 1980) E1=SVP1*EXP(SVP2*(TSK_wat(I)-SVPT0)/(TSK_wat(i)-SVP3)) ENDIF - QSFC_wat(I)=EP2*E1/(PSFC(I)-ep_3*E1) !specific humidity + QSFC_wat(I)=EP2*E1/(PSFC(I)-ep3*E1) !specific humidity ENDIF IF (dry(i).and.(QSFC_lnd(I)>1..or.QSFC_lnd(I)<0.)) then !print *,'bad QSFC_lnd(I)',itimestep,iter,i,QSFC_lnd(I),TSKin_lnd(I) @@ -780,7 +767,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !SATURATION VAPOR PRESSURE WRT WATER (Bolton 1980) E1=SVP1*EXP(SVP2*(TABS-SVPT0)/(TABS-SVP3)) ENDIF - QSFC_lnd(I)=EP2*E1/(PSFC(I)-ep_3*E1) !specific humidity + QSFC_lnd(I)=EP2*E1/(PSFC(I)-ep3*E1) !specific humidity QSFC_lnd(I)=0.5*(QSFC_lnd(I) + QSFC(I)) ENDIF IF (icy(i).and.(QSFC_ice(I)>1..or.QSFC_ice(I)<0.)) then @@ -793,7 +780,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !SATURATION VAPOR PRESSURE WRT WATER (Bolton 1980) E1=SVP1*EXP(SVP2*(TSKin_ice(I)-SVPT0)/(TSKin_ice(i)-SVP3)) ENDIF - QSFC_ice(I)=EP2*E1/(PSFC(I)-ep_3*E1) !specific humidity + QSFC_ice(I)=EP2*E1/(PSFC(I)-ep3*E1) !specific humidity ENDIF IF (wet(i)) QSFCMR_wat(I)=QSFC_wat(I)/(1.-QSFC_wat(I)) @@ -879,10 +866,10 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ENDDO DO I=its,ite - RHO1D(I)=P1D(I)/(R*TV1D(I)) !now using value calculated in sfc driver - ZA(I)=0.5*dz8w1d(I) !height of first half-sigma level - ZA2(I)=dz8w1d(I) + 0.5*dz2w1d(I) !height of 2nd half-sigma level - GOVRTH(I)=G/TH1D(I) + RHO1D(I)=P1D(I)/(Rd*TV1D(I)) !now using value calculated in sfc driver + ZA(I)=0.5*dz8w1d(I) !height of first half-sigma level + ZA2(I)=dz8w1d(I) + 0.5*dz2w1d(I) !height of 2nd half-sigma level + GOVRTH(I)=grav/TH1D(I) ENDDO !tgs - should QFX and HFX be separate for land, ice and water? @@ -916,7 +903,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & E1=SVP1*EXP(SVP2*(T1D(I)-SVPT0)/(T1D(I)-SVP3)) ENDIF PL=P1D(I)/1000. - !QGH(I)=EP2*E1/(PL-ep_3*E1) !specific humidity + !QGH(I)=EP2*E1/(PL-ep3*E1) !specific humidity QGH(I)=EP2*E1/(PL-E1) !mixing ratio CPM(I)=CP*(1.+0.84*QV1D(I)) ENDDO @@ -962,8 +949,8 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !fluxc = max(hflx_wat(i) + ep1*THVSK_wat(I)*qflx_wat(i),0.) fluxc = max(hfx(i)/RHO1D(i)/cp & & + ep1*THVSK_wat(I)*qfx(i)/RHO1D(i),0._kind_phys) - !WSTAR(I) = vconvc*(g/TSK(i)*pblh(i)*fluxc)**onethird - WSTAR(I) = vconvc*(g/TSK_wat(i)*pblh(i)*fluxc)**onethird + !WSTAR(I) = vconvc*(grav/TSK(i)*pblh(i)*fluxc)**onethird + WSTAR(I) = vconvc*(grav/TSK_wat(i)*pblh(i)*fluxc)**onethird !-------------------------------------------------------- ! Mahrt and Sun low-res correction - modified for water points (halved) ! (for 13 km ~ 0.18 m/s; for 3 km == 0 m/s) @@ -976,13 +963,8 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ! ACCORDING TO AKB(1976), EQ(12). !-------------------------------------------------------- rb_wat(I)=GOVRTH(I)*ZA(I)*DTHVDZ/(WSPD_wat*WSPD_wat) - IF (ITIMESTEP == 1) THEN - rb_wat(I)=MAX(rb_wat(I),-2.0_kind_phys) - rb_wat(I)=MIN(rb_wat(I), 2.0_kind_phys) - ELSE - rb_wat(I)=MAX(rb_wat(I),-4.0_kind_phys) - rb_wat(I)=MIN(rb_wat(I), 4.0_kind_phys) - ENDIF + rb_wat(I)=MAX(rb_wat(I),-2.0_kind_phys) + rb_wat(I)=MIN(rb_wat(I), 2.0_kind_phys) ENDIF ! end water point IF (dry(i)) THEN @@ -1000,7 +982,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ! WSTAR(I) = vconvc*(g/TSK(i)*pblh(i)*fluxc)**onethird ! increase height scale, assuming that the non-local transoport ! from the mass-flux (plume) mixing exceedsd the PBLH. - WSTAR(I) = vconvc*(g/TSK_lnd(i)*MIN(1.5*pblh(i),4000._kind_phys)*fluxc)**onethird + WSTAR(I) = vconvc*(grav/TSK_lnd(i)*MIN(1.5*pblh(i),4000._kind_phys)*fluxc)**onethird !-------------------------------------------------------- ! Mahrt and Sun low-res correction ! (for 13 km ~ 0.37 m/s; for 3 km == 0 m/s) @@ -1019,13 +1001,8 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !ELSE ! ust_lnd(i)=WSPD_lnd*0.1*(1.0 - 10.0*rb_lnd(I))**onethird !ENDIF - IF (ITIMESTEP == 1) THEN - rb_lnd(I)=MAX(rb_lnd(I),-2.0_kind_phys) - rb_lnd(I)=MIN(rb_lnd(I), 2.0_kind_phys) - ELSE - rb_lnd(I)=MAX(rb_lnd(I),-4.0_kind_phys) - rb_lnd(I)=MIN(rb_lnd(I), 4.0_kind_phys) - ENDIF + rb_lnd(I)=MAX(rb_lnd(I),-2.0_kind_phys) + rb_lnd(I)=MIN(rb_lnd(I), 2.0_kind_phys) ENDIF ! end land point IF (icy(i)) THEN @@ -1043,7 +1020,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ! WSTAR(I) = vconvc*(g/TSK(i)*pblh(i)*fluxc)**onethird ! increase height scale, assuming that the non-local transport ! from the mass-flux (plume) mixing exceedsd the PBLH. - WSTAR(I) = vconvc*(g/TSK_ice(i)*MIN(1.5*pblh(i),4000._kind_phys)*fluxc)**onethird + WSTAR(I) = vconvc*(grav/TSK_ice(i)*MIN(1.5*pblh(i),4000._kind_phys)*fluxc)**onethird !-------------------------------------------------------- ! Mahrt and Sun low-res correction ! (for 13 km ~ 0.37 m/s; for 3 km == 0 m/s) @@ -1056,13 +1033,8 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ! ACCORDING TO AKB(1976), EQ(12). !-------------------------------------------------------- rb_ice(I)=GOVRTH(I)*ZA(I)*DTHVDZ/(WSPD_ice*WSPD_ice) - IF (ITIMESTEP == 1) THEN - rb_ice(I)=MAX(rb_ice(I),-2.0_kind_phys) - rb_ice(I)=MIN(rb_ice(I), 2.0_kind_phys) - ELSE - rb_ice(I)=MAX(rb_ice(I),-4.0_kind_phys) - rb_ice(I)=MIN(rb_ice(I), 4.0_kind_phys) - ENDIF + rb_ice(I)=MAX(rb_ice(I),-2.0_kind_phys) + rb_ice(I)=MIN(rb_ice(I), 2.0_kind_phys) ENDIF ! end ice point !NOW CONDENSE THE POSSIBLE WSPD VALUES BY TAKING THE MAXIMUM @@ -1175,7 +1147,6 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & CALL fairall_etal_2003(ZT_wat(i),ZQ_wat(i),restar,UST_wat(i),visc,& rstoch1D(i),spp_sfc) ELSE - !presumably, this will be published soon, but hasn't yet CALL fairall_etal_2014(ZT_wat(i),ZQ_wat(i),restar,UST_wat(i),visc,& rstoch1D(i),spp_sfc) ENDIF @@ -1345,27 +1316,29 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & IF (wet(i)) THEN IF (rb_wat(I) .GT. 0.0) THEN - !COMPUTE z/L first guess: - CALL Li_etal_2010(ZOL(I),rb_wat(I),ZA(I)/ZNTstoch_wat(I),zratio_wat(I)) - !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_wat(I)*UST_wat(I),0.0001)) - ZOL(I)=MAX(ZOL(I),0.0_kind_phys) - ZOL(I)=MIN(ZOL(I),20._kind_phys) - - IF (debug_code >= 1) THEN - IF (ZNTstoch_wat(i) < 1E-8 .OR. Zt_wat(i) < 1E-10) THEN - write(0,*)"===(wet) capture bad input in mynn sfc layer, i=:",i - write(0,*)"rb=", rb_wat(I)," ZNT=", ZNTstoch_wat(i)," ZT=",Zt_wat(i) - write(0,*)" tsk=", tskin_wat(i)," prev z/L=",ZOL(I),& - " tsurf=", tsurf_wat(i)," qsfc=", qsfc_wat(i)," znt=", znt_wat(i),& - " ust=", ust_wat(i)," snowh=", snowh_wat(i),"psfcpa=",PSFCPA(i), & - " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) - ENDIF - ENDIF + IF (.not. flag_restart .or. (flag_restart .and. itimestep > 1) ) THEN + !COMPUTE z/L first guess: + CALL Li_etal_2010(ZOL(I),rb_wat(I),ZA(I)/ZNTstoch_wat(I),zratio_wat(I)) + !ZOL(I)=ZA(I)*KARMAN*grav*MOL(I)/(TH1D(I)*MAX(UST_wat(I)*UST_wat(I),0.0001)) + ZOL(I)=MAX(ZOL(I),0.0_kind_phys) + ZOL(I)=MIN(ZOL(I),20._kind_phys) + + IF (debug_code >= 1) THEN + IF (ZNTstoch_wat(i) < 1E-8 .OR. Zt_wat(i) < 1E-10) THEN + write(0,*)"===(wet) capture bad input in mynn sfc layer, i=:",i + write(0,*)"rb=", rb_wat(I)," ZNT=", ZNTstoch_wat(i)," ZT=",Zt_wat(i) + write(0,*)" tsk=", tskin_wat(i)," prev z/L=",ZOL(I),& + " tsurf=", tsurf_wat(i)," qsfc=", qsfc_wat(i)," znt=", znt_wat(i),& + " ust=", ust_wat(i)," snowh=", snowh_wat(i),"psfcpa=",PSFCPA(i), & + " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) + ENDIF + ENDIF - !Use Pedros iterative function to find z/L - !zol(I)=zolri(rb_wat(I),ZA(I),ZNTstoch_wat(I),ZT_wat(I),ZOL(I),psi_opt) - !Use brute-force method - zol(I)=zolrib(rb_wat(I),ZA(I),ZNTstoch_wat(I),zt_wat(I),GZ1OZ0_wat(I),GZ1OZt_wat(I),ZOL(I),psi_opt) + !Use Pedros iterative function to find z/L + !zol(I)=zolri(rb_wat(I),ZA(I),ZNTstoch_wat(I),ZT_wat(I),ZOL(I),psi_opt) + !Use brute-force method + zol(I)=zolrib(rb_wat(I),ZA(I),ZNTstoch_wat(I),zt_wat(I),GZ1OZ0_wat(I),GZ1OZt_wat(I),ZOL(I),psi_opt) + ENDIF ! restart ZOL(I)=MAX(ZOL(I),0.0_kind_phys) ZOL(I)=MIN(ZOL(I),20._kind_phys) @@ -1411,26 +1384,28 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !========================================================== !COMPUTE z/L first guess: - CALL Li_etal_2010(ZOL(I),rb_wat(I),ZA(I)/ZNTstoch_wat(I),zratio_wat(I)) - !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_wat(I)*UST_wat(I),0.001)) - ZOL(I)=MAX(ZOL(I),-20.0_kind_phys) - ZOL(I)=MIN(ZOL(I),0.0_kind_phys) - - IF (debug_code >= 1) THEN - IF (ZNTstoch_wat(i) < 1E-8 .OR. Zt_wat(i) < 1E-10) THEN - write(0,*)"===(wet) capture bad input in mynn sfc layer, i=:",i - write(0,*)"rb=", rb_wat(I)," ZNT=", ZNTstoch_wat(i)," ZT=",Zt_wat(i) - write(0,*)" tsk=", tskin_wat(i)," wstar=",wstar(i)," prev z/L=",ZOL(I),& - " tsurf=", tsurf_wat(i)," qsfc=", qsfc_wat(i)," znt=", znt_wat(i),& - " ust=", ust_wat(i)," snowh=", snowh_wat(i),"psfcpa=",PSFCPA(i), & - " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) - ENDIF - ENDIF + IF (.not. flag_restart .or. (flag_restart .and. itimestep > 1) ) THEN + CALL Li_etal_2010(ZOL(I),rb_wat(I),ZA(I)/ZNTstoch_wat(I),zratio_wat(I)) + !ZOL(I)=ZA(I)*KARMAN*grav*MOL(I)/(TH1D(I)*MAX(UST_wat(I)*UST_wat(I),0.001)) + ZOL(I)=MAX(ZOL(I),-20.0_kind_phys) + ZOL(I)=MIN(ZOL(I),0.0_kind_phys) + + IF (debug_code >= 1) THEN + IF (ZNTstoch_wat(i) < 1E-8 .OR. Zt_wat(i) < 1E-10) THEN + write(0,*)"===(wet) capture bad input in mynn sfc layer, i=:",i + write(0,*)"rb=", rb_wat(I)," ZNT=", ZNTstoch_wat(i)," ZT=",Zt_wat(i) + write(0,*)" tsk=", tskin_wat(i)," wstar=",wstar(i)," prev z/L=",ZOL(I),& + " tsurf=", tsurf_wat(i)," qsfc=", qsfc_wat(i)," znt=", znt_wat(i),& + " ust=", ust_wat(i)," snowh=", snowh_wat(i),"psfcpa=",PSFCPA(i), & + " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) + ENDIF + ENDIF - !Use Pedros iterative function to find z/L - !zol(I)=zolri(rb_wat(I),ZA(I),ZNTstoch_wat(I),ZT_wat(I),ZOL(I),psi_opt) - !Use brute-force method - zol(I)=zolrib(rb_wat(I),ZA(I),ZNTstoch_wat(I),zt_wat(I),GZ1OZ0_wat(I),GZ1OZt_wat(I),ZOL(I),psi_opt) + !Use Pedros iterative function to find z/L + !zol(I)=zolri(rb_wat(I),ZA(I),ZNTstoch_wat(I),ZT_wat(I),ZOL(I),psi_opt) + !Use brute-force method + zol(I)=zolrib(rb_wat(I),ZA(I),ZNTstoch_wat(I),zt_wat(I),GZ1OZ0_wat(I),GZ1OZt_wat(I),ZOL(I),psi_opt) + ENDIF ! restart ZOL(I)=MAX(ZOL(I),-20.0_kind_phys) ZOL(I)=MIN(ZOL(I),0.0_kind_phys) @@ -1478,27 +1453,29 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & IF (dry(i)) THEN IF (rb_lnd(I) .GT. 0.0) THEN - !COMPUTE z/L first guess: - CALL Li_etal_2010(ZOL(I),rb_lnd(I),ZA(I)/ZNTstoch_lnd(I),zratio_lnd(I)) - !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_lnd(I)*UST_lnd(I),0.0001)) - ZOL(I)=MAX(ZOL(I),0.0_kind_phys) - ZOL(I)=MIN(ZOL(I),20._kind_phys) - - IF (debug_code >= 1) THEN - IF (ZNTstoch_lnd(i) < 1E-8 .OR. Zt_lnd(i) < 1E-10) THEN - write(0,*)"===(land) capture bad input in mynn sfc layer, i=:",i - write(0,*)"rb=", rb_lnd(I)," ZNT=", ZNTstoch_lnd(i)," ZT=",Zt_lnd(i) - write(0,*)" tsk=", tskin_lnd(i)," prev z/L=",ZOL(I),& - " tsurf=", tsurf_lnd(i)," qsfc=", qsfc_lnd(i)," znt=", znt_lnd(i),& - " ust=", ust_lnd(i)," snowh=", snowh_lnd(i),"psfcpa=",PSFCPA(i), & - " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) - ENDIF - ENDIF + IF (.not. flag_restart .or. (flag_restart .and. itimestep > 1) ) THEN + !COMPUTE z/L first guess: + CALL Li_etal_2010(ZOL(I),rb_lnd(I),ZA(I)/ZNTstoch_lnd(I),zratio_lnd(I)) + !ZOL(I)=ZA(I)*KARMAN*grav*MOL(I)/(TH1D(I)*MAX(UST_lnd(I)*UST_lnd(I),0.0001)) + ZOL(I)=MAX(ZOL(I),0.0_kind_phys) + ZOL(I)=MIN(ZOL(I),20._kind_phys) + + IF (debug_code >= 1) THEN + IF (ZNTstoch_lnd(i) < 1E-8 .OR. Zt_lnd(i) < 1E-10) THEN + write(0,*)"===(land) capture bad input in mynn sfc layer, i=:",i + write(0,*)"rb=", rb_lnd(I)," ZNT=", ZNTstoch_lnd(i)," ZT=",Zt_lnd(i) + write(0,*)" tsk=", tskin_lnd(i)," prev z/L=",ZOL(I),& + " tsurf=", tsurf_lnd(i)," qsfc=", qsfc_lnd(i)," znt=", znt_lnd(i),& + " ust=", ust_lnd(i)," snowh=", snowh_lnd(i),"psfcpa=",PSFCPA(i), & + " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) + ENDIF + ENDIF - !Use Pedros iterative function to find z/L - !zol(I)=zolri(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),ZT_lnd(I),ZOL(I),psi_opt) - !Use brute-force method - zol(I)=zolrib(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),zt_lnd(I),GZ1OZ0_lnd(I),GZ1OZt_lnd(I),ZOL(I),psi_opt) + !Use Pedros iterative function to find z/L + !zol(I)=zolri(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),ZT_lnd(I),ZOL(I),psi_opt) + !Use brute-force method + zol(I)=zolrib(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),zt_lnd(I),GZ1OZ0_lnd(I),GZ1OZt_lnd(I),ZOL(I),psi_opt) + ENDIF ! restart ZOL(I)=MAX(ZOL(I),0.0_kind_phys) ZOL(I)=MIN(ZOL(I),20._kind_phys) @@ -1542,27 +1519,29 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !-----CLASS 4; FREE CONVECTION: !========================================================== - !COMPUTE z/L first guess: - CALL Li_etal_2010(ZOL(I),rb_lnd(I),ZA(I)/ZNTstoch_lnd(I),zratio_lnd(I)) - !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_lnd(I)*UST_lnd(I),0.001)) - ZOL(I)=MAX(ZOL(I),-20.0_kind_phys) - ZOL(I)=MIN(ZOL(I),0.0_kind_phys) - - IF (debug_code >= 1) THEN - IF (ZNTstoch_lnd(i) < 1E-8 .OR. Zt_lnd(i) < 1E-10) THEN - write(0,*)"===(land) capture bad input in mynn sfc layer, i=:",i - write(0,*)"rb=", rb_lnd(I)," ZNT=", ZNTstoch_lnd(i)," ZT=",Zt_lnd(i) - write(0,*)" tsk=", tskin_lnd(i)," wstar=",wstar(i)," prev z/L=",ZOL(I),& - " tsurf=", tsurf_lnd(i)," qsfc=", qsfc_lnd(i)," znt=", znt_lnd(i),& - " ust=", ust_lnd(i)," snowh=", snowh_lnd(i),"psfcpa=",PSFCPA(i), & - " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) - ENDIF - ENDIF + IF (.not. flag_restart .or. (flag_restart .and. itimestep > 1) ) THEN + !COMPUTE z/L first guess: + CALL Li_etal_2010(ZOL(I),rb_lnd(I),ZA(I)/ZNTstoch_lnd(I),zratio_lnd(I)) + !ZOL(I)=ZA(I)*KARMAN*grav*MOL(I)/(TH1D(I)*MAX(UST_lnd(I)*UST_lnd(I),0.001)) + ZOL(I)=MAX(ZOL(I),-20.0_kind_phys) + ZOL(I)=MIN(ZOL(I),0.0_kind_phys) + + IF (debug_code >= 1) THEN + IF (ZNTstoch_lnd(i) < 1E-8 .OR. Zt_lnd(i) < 1E-10) THEN + write(0,*)"===(land) capture bad input in mynn sfc layer, i=:",i + write(0,*)"rb=", rb_lnd(I)," ZNT=", ZNTstoch_lnd(i)," ZT=",Zt_lnd(i) + write(0,*)" tsk=", tskin_lnd(i)," wstar=",wstar(i)," prev z/L=",ZOL(I),& + " tsurf=", tsurf_lnd(i)," qsfc=", qsfc_lnd(i)," znt=", znt_lnd(i),& + " ust=", ust_lnd(i)," snowh=", snowh_lnd(i),"psfcpa=",PSFCPA(i), & + " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) + ENDIF + ENDIF - !Use Pedros iterative function to find z/L - !zol(I)=zolri(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),ZT_lnd(I),ZOL(I),psi_opt) - !Use brute-force method - zol(I)=zolrib(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),zt_lnd(I),GZ1OZ0_lnd(I),GZ1OZt_lnd(I),ZOL(I),psi_opt) + !Use Pedros iterative function to find z/L + !zol(I)=zolri(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),ZT_lnd(I),ZOL(I),psi_opt) + !Use brute-force method + zol(I)=zolrib(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),zt_lnd(I),GZ1OZ0_lnd(I),GZ1OZt_lnd(I),ZOL(I),psi_opt) + ENDIF ! restart ZOL(I)=MAX(ZOL(I),-20.0_kind_phys) ZOL(I)=MIN(ZOL(I),0.0_kind_phys) @@ -1609,27 +1588,29 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & IF (icy(i)) THEN IF (rb_ice(I) .GT. 0.0) THEN - !COMPUTE z/L first guess: - CALL Li_etal_2010(ZOL(I),rb_ice(I),ZA(I)/ZNTstoch_ice(I),zratio_ice(I)) - !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_ice(I)*UST_ice(I),0.0001)) - ZOL(I)=MAX(ZOL(I),0.0_kind_phys) - ZOL(I)=MIN(ZOL(I),20._kind_phys) - - IF (debug_code >= 1) THEN - IF (ZNTstoch_ice(i) < 1E-8 .OR. Zt_ice(i) < 1E-10) THEN - write(0,*)"===(ice) capture bad input in mynn sfc layer, i=:",i - write(0,*)"rb=", rb_ice(I)," ZNT=", ZNTstoch_ice(i)," ZT=",Zt_ice(i) - write(0,*)" tsk=", tskin_ice(i)," prev z/L=",ZOL(I),& - " tsurf=", tsurf_ice(i)," qsfc=", qsfc_ice(i)," znt=", znt_ice(i),& - " ust=", ust_ice(i)," snowh=", snowh_ice(i),"psfcpa=",PSFCPA(i), & - " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) - ENDIF - ENDIF + IF (.not. flag_restart .or. (flag_restart .and. itimestep > 1) ) THEN + !COMPUTE z/L first guess: + CALL Li_etal_2010(ZOL(I),rb_ice(I),ZA(I)/ZNTstoch_ice(I),zratio_ice(I)) + !ZOL(I)=ZA(I)*KARMAN*grav*MOL(I)/(TH1D(I)*MAX(UST_ice(I)*UST_ice(I),0.0001)) + ZOL(I)=MAX(ZOL(I),0.0_kind_phys) + ZOL(I)=MIN(ZOL(I),20._kind_phys) + + IF (debug_code >= 1) THEN + IF (ZNTstoch_ice(i) < 1E-8 .OR. Zt_ice(i) < 1E-10) THEN + write(0,*)"===(ice) capture bad input in mynn sfc layer, i=:",i + write(0,*)"rb=", rb_ice(I)," ZNT=", ZNTstoch_ice(i)," ZT=",Zt_ice(i) + write(0,*)" tsk=", tskin_ice(i)," prev z/L=",ZOL(I),& + " tsurf=", tsurf_ice(i)," qsfc=", qsfc_ice(i)," znt=", znt_ice(i),& + " ust=", ust_ice(i)," snowh=", snowh_ice(i),"psfcpa=",PSFCPA(i), & + " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) + ENDIF + ENDIF - !Use Pedros iterative function to find z/L - !zol(I)=zolri(rb_ice(I),ZA(I),ZNTstoch_ice(I),ZT_ice(I),ZOL(I),psi_opt) - !Use brute-force method - zol(I)=zolrib(rb_ice(I),ZA(I),ZNTstoch_ice(I),zt_ice(I),GZ1OZ0_ice(I),GZ1OZt_ice(I),ZOL(I),psi_opt) + !Use Pedros iterative function to find z/L + !zol(I)=zolri(rb_ice(I),ZA(I),ZNTstoch_ice(I),ZT_ice(I),ZOL(I),psi_opt) + !Use brute-force method + zol(I)=zolrib(rb_ice(I),ZA(I),ZNTstoch_ice(I),zt_ice(I),GZ1OZ0_ice(I),GZ1OZt_ice(I),ZOL(I),psi_opt) + ENDIF ! restart ZOL(I)=MAX(ZOL(I),0.0_kind_phys) ZOL(I)=MIN(ZOL(I),20._kind_phys) @@ -1673,27 +1654,29 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !-----CLASS 4; FREE CONVECTION: !========================================================== - !COMPUTE z/L first guess: - CALL Li_etal_2010(ZOL(I),rb_ice(I),ZA(I)/ZNTstoch_ice(I),zratio_ice(I)) - !ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST_ice(I)*UST_ice(I),0.001)) - ZOL(I)=MAX(ZOL(I),-20.0_kind_phys) - ZOL(I)=MIN(ZOL(I),0.0_kind_phys) - - IF (debug_code >= 1) THEN - IF (ZNTstoch_ice(i) < 1E-8 .OR. Zt_ice(i) < 1E-10) THEN - write(0,*)"===(ice) capture bad input in mynn sfc layer, i=:",i - write(0,*)"rb=", rb_ice(I)," ZNT=", ZNTstoch_ice(i)," ZT=",Zt_ice(i) - write(0,*)" tsk=", tskin_ice(i)," wstar=",wstar(i)," prev z/L=",ZOL(I),& - " tsurf=", tsurf_ice(i)," qsfc=", qsfc_ice(i)," znt=", znt_ice(i),& - " ust=", ust_ice(i)," snowh=", snowh_ice(i),"psfcpa=",PSFCPA(i), & - " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) - ENDIF - ENDIF + IF (.not. flag_restart .or. (flag_restart .and. itimestep > 1) ) THEN + !COMPUTE z/L first guess: + CALL Li_etal_2010(ZOL(I),rb_ice(I),ZA(I)/ZNTstoch_ice(I),zratio_ice(I)) + !ZOL(I)=ZA(I)*KARMAN*grav*MOL(I)/(TH1D(I)*MAX(UST_ice(I)*UST_ice(I),0.001)) + ZOL(I)=MAX(ZOL(I),-20.0_kind_phys) + ZOL(I)=MIN(ZOL(I),0.0_kind_phys) + + IF (debug_code >= 1) THEN + IF (ZNTstoch_ice(i) < 1E-8 .OR. Zt_ice(i) < 1E-10) THEN + write(0,*)"===(ice) capture bad input in mynn sfc layer, i=:",i + write(0,*)"rb=", rb_ice(I)," ZNT=", ZNTstoch_ice(i)," ZT=",Zt_ice(i) + write(0,*)" tsk=", tskin_ice(i)," wstar=",wstar(i)," prev z/L=",ZOL(I),& + " tsurf=", tsurf_ice(i)," qsfc=", qsfc_ice(i)," znt=", znt_ice(i),& + " ust=", ust_ice(i)," snowh=", snowh_ice(i),"psfcpa=",PSFCPA(i), & + " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) + ENDIF + ENDIF - !Use Pedros iterative function to find z/L - !zol(I)=zolri(rb_ice(I),ZA(I),ZNTstoch_ice(I),ZT_ice(I),ZOL(I),psi_opt) - !Use brute-force method - zol(I)=zolrib(rb_ice(I),ZA(I),ZNTstoch_ice(I),zt_ice(I),GZ1OZ0_ice(I),GZ1OZt_ice(I),ZOL(I),psi_opt) + !Use Pedros iterative function to find z/L + !zol(I)=zolri(rb_ice(I),ZA(I),ZNTstoch_ice(I),ZT_ice(I),ZOL(I),psi_opt) + !Use brute-force method + zol(I)=zolrib(rb_ice(I),ZA(I),ZNTstoch_ice(I),zt_ice(I),GZ1OZ0_ice(I),GZ1OZt_ice(I),ZOL(I),psi_opt) + ENDIF ! restart ZOL(I)=MAX(ZOL(I),-20.0_kind_phys) ZOL(I)=MIN(ZOL(I),0.0_kind_phys) @@ -1744,9 +1727,9 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & IF (wet(I)) THEN ! TO PREVENT OSCILLATIONS AVERAGE WITH OLD VALUE OLDUST = UST_wat(I) - !UST_wat(I)=0.5*UST_wat(I)+0.5*KARMAN*WSPD(I)/PSIX_wat(I) + UST_wat(I)=0.5*UST_wat(I)+0.5*KARMAN*WSPD(I)/PSIX_wat(I) !NON-AVERAGED: - UST_wat(I)=KARMAN*WSPD(I)/PSIX_wat(I) + !UST_wat(I)=KARMAN*WSPD(I)/PSIX_wat(I) stress_wat(i)=ust_wat(i)**2 ! Compute u* without vconv for use in HFX calc when isftcflx > 0 @@ -2290,14 +2273,14 @@ SUBROUTINE zilitinkevich_1995(Z_0,Zt,Zq,restar,ustar,KARMAN,& & landsea,IZ0TLND2,spp_sfc,rstoch) IMPLICIT NONE - REAL(kind=kind_phys), INTENT(IN) :: Z_0,restar,ustar,KARMAN,landsea + REAL(kind_phys), INTENT(IN) :: Z_0,restar,ustar,KARMAN,landsea INTEGER, OPTIONAL, INTENT(IN) :: IZ0TLND2 - REAL(kind=kind_phys), INTENT(OUT) :: Zt,Zq - REAL(kind=kind_phys) :: CZIL !=0.100 in Chen et al. (1997) + REAL(kind_phys), INTENT(OUT) :: Zt,Zq + REAL(kind_phys) :: CZIL !=0.100 in Chen et al. (1997) !=0.075 in Zilitinkevich (1995) !=0.500 in Lemone et al. (2008) INTEGER, INTENT(IN) :: spp_sfc - REAL(kind=kind_phys), INTENT(IN) :: rstoch + REAL(kind_phys), INTENT(IN) :: rstoch IF (landsea-1.5 .GT. 0) THEN !WATER @@ -2359,16 +2342,16 @@ SUBROUTINE davis_etal_2008(Z_0,ustar) !corrects a small-bias in Z_0 (AHW real-time 2012). IMPLICIT NONE - REAL(kind=kind_phys), INTENT(IN) :: ustar - REAL(kind=kind_phys), INTENT(OUT) :: Z_0 - REAL(kind=kind_phys) :: ZW, ZN1, ZN2 - REAL(kind=kind_phys), PARAMETER :: G=9.81, OZO=1.59E-5 + REAL(kind_phys), INTENT(IN) :: ustar + REAL(kind_phys), INTENT(OUT) :: Z_0 + REAL(kind_phys) :: ZW, ZN1, ZN2 + REAL(kind_phys), PARAMETER :: OZO=1.59E-5 !OLD FORM: Z_0 = 10.*EXP(-10./(ustar**onethird)) !NEW FORM: ZW = MIN((ustar/1.06)**(0.3),1.0_kind_phys) - ZN1 = 0.011*ustar*ustar/G + OZO + ZN1 = 0.011*ustar*ustar*g_inv + OZO ZN2 = 10.*exp(-9.5*ustar**(-onethird)) + & 0.11*1.5E-5/MAX(ustar,0.01_kind_phys) !0.11*1.5E-5/AMAX1(ustar,0.01) @@ -2387,17 +2370,17 @@ END SUBROUTINE davis_etal_2008 SUBROUTINE Taylor_Yelland_2001(Z_0,ustar,wsp10) IMPLICIT NONE - REAL(kind=kind_phys), INTENT(IN) :: ustar,wsp10 - REAL(kind=kind_phys), INTENT(OUT) :: Z_0 - REAL(kind=kind_phys), parameter :: g=9.81, pi=3.14159265 - REAL(kind=kind_phys) :: hs, Tp, Lp + REAL(kind_phys), INTENT(IN) :: ustar,wsp10 + REAL(kind_phys), INTENT(OUT) :: Z_0 + REAL(kind_phys), parameter :: pi=3.14159265 + REAL(kind_phys) :: hs, Tp, Lp !hs is the significant wave height hs = 0.0248*(wsp10**2.) !Tp dominant wave period Tp = 0.729*MAX(wsp10,0.1_kind_phys) !Lp is the wavelength of the dominant wave - Lp = g*Tp**2/(2*pi) + Lp = grav*Tp**2/(2*pi) Z_0 = 1200.*hs*(hs/Lp)**4.5 Z_0 = MAX( Z_0, 1.27e-7_kind_phys) !These max/mins were suggested by @@ -2415,16 +2398,16 @@ END SUBROUTINE Taylor_Yelland_2001 SUBROUTINE charnock_1955(Z_0,ustar,wsp10,visc,zu) IMPLICIT NONE - REAL(kind=kind_phys), INTENT(IN) :: ustar, visc, wsp10, zu - REAL(kind=kind_phys), INTENT(OUT) :: Z_0 - REAL(kind=kind_phys), PARAMETER :: G=9.81, CZO2=0.011 - REAL(kind=kind_phys) :: CZC ! variable charnock "constant" - REAL(kind=kind_phys) :: wsp10m ! logarithmically calculated 10 m + REAL(kind_phys), INTENT(IN) :: ustar, visc, wsp10, zu + REAL(kind_phys), INTENT(OUT) :: Z_0 + REAL(kind_phys), PARAMETER :: CZO2=0.011 + REAL(kind_phys) :: CZC ! variable charnock "constant" + REAL(kind_phys) :: wsp10m ! logarithmically calculated 10 m wsp10m = wsp10*log(10./1e-4)/log(zu/1e-4) CZC = CZO2 + 0.007*MIN(MAX((wsp10m-10.)/8., 0._kind_phys), 1.0_kind_phys) - Z_0 = CZC*ustar*ustar/G + (0.11*visc/MAX(ustar,0.05_kind_phys)) + Z_0 = CZC*ustar*ustar*g_inv + (0.11*visc/MAX(ustar,0.05_kind_phys)) Z_0 = MAX( Z_0, 1.27e-7_kind_phys) !These max/mins were suggested by Z_0 = MIN( Z_0, 2.85e-3_kind_phys) !Davis et al. (2008) @@ -2440,19 +2423,18 @@ END SUBROUTINE charnock_1955 SUBROUTINE edson_etal_2013(Z_0,ustar,wsp10,visc,zu) IMPLICIT NONE - REAL(kind=kind_phys), INTENT(IN) :: ustar, visc, wsp10, zu - REAL(kind=kind_phys), INTENT(OUT) :: Z_0 - REAL(kind=kind_phys), PARAMETER :: G=9.81 - REAL(kind=kind_phys), PARAMETER :: m=0.0017, b=-0.005 - REAL(kind=kind_phys) :: CZC ! variable charnock "constant" - REAL(kind=kind_phys) :: wsp10m ! logarithmically calculated 10 m + REAL(kind_phys), INTENT(IN) :: ustar, visc, wsp10, zu + REAL(kind_phys), INTENT(OUT) :: Z_0 + REAL(kind_phys), PARAMETER :: m=0.0017, b=-0.005 + REAL(kind_phys) :: CZC ! variable charnock "constant" + REAL(kind_phys) :: wsp10m ! logarithmically calculated 10 m wsp10m = wsp10*log(10/1e-4)/log(zu/1e-4) wsp10m = MIN(19._kind_phys, wsp10m) CZC = m*wsp10m + b CZC = MAX(CZC, 0.0_kind_phys) - Z_0 = CZC*ustar*ustar/G + (0.11*visc/MAX(ustar,0.07_kind_phys)) + Z_0 = CZC*ustar*ustar*g_inv + (0.11*visc/MAX(ustar,0.07_kind_phys)) Z_0 = MAX( Z_0, 1.27e-7_kind_phys) !These max/mins were suggested by Z_0 = MIN( Z_0, 2.85e-3_kind_phys) !Davis et al. (2008) @@ -2470,10 +2452,10 @@ END SUBROUTINE edson_etal_2013 SUBROUTINE garratt_1992(Zt,Zq,Z_0,Ren,landsea) IMPLICIT NONE - REAL(kind=kind_phys), INTENT(IN) :: Ren, Z_0,landsea - REAL(kind=kind_phys), INTENT(OUT) :: Zt,Zq - REAL(kind=kind_phys) :: Rq - REAL(kind=kind_phys), PARAMETER :: e=2.71828183 + REAL(kind_phys), INTENT(IN) :: Ren, Z_0,landsea + REAL(kind_phys), INTENT(OUT) :: Zt,Zq + REAL(kind_phys) :: Rq + REAL(kind_phys), PARAMETER :: e=2.71828183 IF (landsea-1.5 .GT. 0) THEN !WATER @@ -2506,9 +2488,9 @@ END SUBROUTINE garratt_1992 SUBROUTINE fairall_etal_2003(Zt,Zq,Ren,ustar,visc,rstoch,spp_sfc) IMPLICIT NONE - REAL(kind=kind_phys), INTENT(IN) :: Ren,ustar,visc,rstoch - INTEGER, INTENT(IN):: spp_sfc - REAL(kind=kind_phys), INTENT(OUT) :: Zt,Zq + REAL(kind_phys), INTENT(IN) :: Ren,ustar,visc,rstoch + INTEGER, INTENT(IN) :: spp_sfc + REAL(kind_phys), INTENT(OUT) :: Zt,Zq IF (Ren .le. 2.) then @@ -2545,14 +2527,14 @@ END SUBROUTINE fairall_etal_2003 !> This formulation for thermal and moisture roughness length (Zt and Zq) !! as a function of the roughness Reynolds number (Ren) comes from the !! COARE 3.5/4.0 formulation, empirically derived from COARE and HEXMAX data -!! [Fairall et al. (2014? coming soon, not yet published as of July 2014)]. -!! This is for use over water only. +!! The actual reference is unknown. This was passed along by Jim Edson (personal communication). +!! This is for use over water only, preferably open ocean. SUBROUTINE fairall_etal_2014(Zt,Zq,Ren,ustar,visc,rstoch,spp_sfc) IMPLICIT NONE - REAL(kind=kind_phys), INTENT(IN) :: Ren,ustar,visc,rstoch - INTEGER, INTENT(IN):: spp_sfc - REAL(kind=kind_phys), INTENT(OUT) :: Zt,Zq + REAL(kind_phys), INTENT(IN) :: Ren,ustar,visc,rstoch + INTEGER, INTENT(IN) :: spp_sfc + REAL(kind_phys), INTENT(OUT) :: Zt,Zq !Zt = (5.5e-5)*(Ren**(-0.60)) Zt = MIN(1.6E-4_kind_phys, 5.8E-5/(Ren**0.72)) @@ -2597,17 +2579,17 @@ END SUBROUTINE fairall_etal_2014 SUBROUTINE Yang_2008(Z_0,Zt,Zq,ustar,tstar,qst,Ren,visc) IMPLICIT NONE - REAL(kind=kind_phys), INTENT(IN) :: Z_0, Ren, ustar, tstar, qst, visc - REAL(kind=kind_phys) :: ht, &! roughness height at critical Reynolds number + REAL(kind_phys), INTENT(IN) :: Z_0, Ren, ustar, tstar, qst, visc + REAL(kind_phys) :: ht, &! roughness height at critical Reynolds number tstar2, &! bounded T*, forced to be non-positive qstar2, &! bounded q*, forced to be non-positive Z_02, &! bounded Z_0 for variable Renc2 calc Renc2 ! variable Renc, function of Z_0 - REAL(kind=kind_phys), INTENT(OUT) :: Zt,Zq - REAL(kind=kind_phys), PARAMETER :: Renc=300., & !old constant Renc - beta=1.5, & !important for diurnal variation - m=170., & !slope for Renc2 function - b=691. !y-intercept for Renc2 function + REAL(kind_phys), INTENT(OUT) :: Zt,Zq + REAL(kind_phys), PARAMETER :: Renc=300., & !old constant Renc + beta=1.5, & !important for diurnal variation + m=170., & !slope for Renc2 function + b=691. !y-intercept for Renc2 function Z_02 = MIN(Z_0,0.5_kind_phys) Z_02 = MAX(Z_02,0.04_kind_phys) @@ -2631,10 +2613,10 @@ END SUBROUTINE Yang_2008 !>\ingroup mynn_sfc SUBROUTINE GFS_z0_lnd(z0max,shdmax,z1,vegtype,ivegsrc,z0pert) - REAL(kind=kind_phys), INTENT(OUT) :: z0max - REAL(kind=kind_phys), INTENT(IN) :: shdmax,z1,z0pert - INTEGER, INTENT(IN) :: vegtype,ivegsrc - REAL(kind=kind_phys) :: tem1, tem2 + REAL(kind_phys), INTENT(OUT) :: z0max + REAL(kind_phys), INTENT(IN) :: shdmax,z1,z0pert + INTEGER, INTENT(IN) :: vegtype,ivegsrc + REAL(kind_phys) :: tem1, tem2 ! z0max = max(1.0e-6, min(0.01 * z0max, z1)) !already converted into meters in the wrapper @@ -2691,10 +2673,10 @@ END SUBROUTINE GFS_z0_lnd !>\ingroup mynn_sfc SUBROUTINE GFS_zt_lnd(ztmax,z0max,sigmaf,ztpert,ustar_lnd) - REAL(kind=kind_phys), INTENT(OUT) :: ztmax - REAL(kind=kind_phys), INTENT(IN) :: z0max,sigmaf,ztpert,ustar_lnd - REAL(kind=kind_phys) :: czilc, tem1, tem2 - REAL(kind=kind_phys), PARAMETER :: ca = 0.4 + REAL(kind_phys), INTENT(OUT) :: ztmax + REAL(kind_phys), INTENT(IN) :: z0max,sigmaf,ztpert,ustar_lnd + REAL(kind_phys) :: czilc, tem1, tem2 + REAL(kind_phys), PARAMETER :: ca = 0.4 ! czilc = 10.0 ** (- (0.40/0.07) * z0) ! fei's canopy height dependance of czil czilc = 0.8 @@ -2719,25 +2701,25 @@ END SUBROUTINE GFS_zt_lnd !>\ingroup mynn_sfc SUBROUTINE GFS_z0_wat(z0rl_wat,ustar_wat,WSPD,z1,sfc_z0_type,redrag) - REAL(kind=kind_phys), INTENT(OUT) :: z0rl_wat - REAL(kind=kind_phys), INTENT(INOUT):: ustar_wat - REAL(kind=kind_phys), INTENT(IN) :: wspd,z1 - LOGICAL, INTENT(IN):: redrag - INTEGER, INTENT(IN):: sfc_z0_type - REAL(kind=kind_phys) :: z0,z0max,wind10m - REAL(kind=kind_phys), PARAMETER :: charnock = 0.014, z0s_max=.317e-2 + REAL(kind_phys), INTENT(OUT) :: z0rl_wat + REAL(kind_phys), INTENT(INOUT):: ustar_wat + REAL(kind_phys), INTENT(IN) :: wspd,z1 + LOGICAL, INTENT(IN) :: redrag + INTEGER, INTENT(IN) :: sfc_z0_type + REAL(kind_phys) :: z0,z0max,wind10m + REAL(kind_phys), PARAMETER :: charnock = 0.014, z0s_max=.317e-2 ! z0 = 0.01 * z0rl_wat !Already converted to meters in the wrapper z0 = z0rl_wat z0max = max(1.0e-6_kind_phys, min(z0,z1)) - ustar_wat = sqrt(g * z0 / charnock) + ustar_wat = sqrt(grav * z0 / charnock) wind10m = wspd*log(10./1e-4)/log(z1/1e-4) !wind10m = sqrt(u10m(i)*u10m(i)+v10m(i)*v10m(i)) ! if (sfc_z0_type >= 0) then if (sfc_z0_type == 0) then - z0 = (charnock / g) * ustar_wat * ustar_wat + z0 = (charnock / grav) * ustar_wat * ustar_wat ! mbek -- toga-coare flux algorithm ! z0 = (charnock / g) * ustar(i)*ustar(i) + arnu/ustar(i) @@ -2772,13 +2754,13 @@ END SUBROUTINE GFS_z0_wat !>\ingroup mynn_sfc SUBROUTINE GFS_zt_wat(ztmax,z0rl_wat,restar,WSPD,z1,sfc_z0_type,errmsg,errflg) - REAL(kind=kind_phys), INTENT(OUT) :: ztmax - REAL(kind=kind_phys), INTENT(IN) :: wspd,z1,z0rl_wat,restar - INTEGER, INTENT(IN):: sfc_z0_type + real(kind_phys), INTENT(OUT) :: ztmax + real(kind_phys), INTENT(IN) :: wspd,z1,z0rl_wat,restar + INTEGER, INTENT(IN) :: sfc_z0_type character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg - REAL(kind=kind_phys) :: z0,z0max,wind10m,rat,ustar_wat - REAL(kind=kind_phys), PARAMETER :: charnock = 0.014, z0s_max=.317e-2 + real(kind_phys) :: z0,z0max,wind10m,rat,ustar_wat + real(kind_phys), PARAMETER :: charnock = 0.014, z0s_max=.317e-2 ! Initialize error-handling errflg = 0 @@ -2788,7 +2770,7 @@ SUBROUTINE GFS_zt_wat(ztmax,z0rl_wat,restar,WSPD,z1,sfc_z0_type,errmsg,errflg) !Already converted to meters in the wrapper z0 = z0rl_wat z0max = max(1.0e-6_kind_phys, min(z0,z1)) - ustar_wat = sqrt(g * z0 / charnock) + ustar_wat = sqrt(grav * z0 / charnock) wind10m = wspd*log(10./1e-4)/log(z1/1e-4) !** test xubin's new z0 @@ -2837,9 +2819,9 @@ SUBROUTINE znot_m_v6(uref, znotm) ! znotm(meter): areodynamical roughness scale over water ! - REAL(kind=kind_phys), INTENT(IN) :: uref - REAL(kind=kind_phys), INTENT(OUT):: znotm - REAL(kind=kind_phys), PARAMETER :: p13 = -1.296521881682694e-02,& + REAL(kind_phys), INTENT(IN) :: uref + REAL(kind_phys), INTENT(OUT):: znotm + REAL(kind_phys), PARAMETER :: p13 = -1.296521881682694e-02, & & p12 = 2.855780863283819e-01, p11 = -1.597898515251717e+00,& & p10 = -8.396975715683501e+00, & @@ -2884,9 +2866,9 @@ SUBROUTINE znot_t_v6(uref, znott) ! uref(m/s) : wind speed at 10-m height ! znott(meter): scalar roughness scale over water ! - REAL(kind=kind_phys), INTENT(IN) :: uref - REAL(kind=kind_phys), INTENT(OUT):: znott - REAL(kind=kind_phys), PARAMETER :: p00 = 1.100000000000000e-04,& + REAL(kind_phys), INTENT(IN) :: uref + REAL(kind_phys), INTENT(OUT):: znott + REAL(kind_phys), PARAMETER :: p00 = 1.100000000000000e-04,& & p15 = -9.144581627678278e-10, p14 = 7.020346616456421e-08,& & p13 = -2.155602086883837e-06, p12 = 3.333848806567684e-05,& & p11 = -2.628501274963990e-04, p10 = 8.634221567969181e-04,& @@ -2952,12 +2934,12 @@ SUBROUTINE znot_m_v7(uref, znotm) ! znotm(meter): areodynamical roughness scale over water ! - REAL(kind=kind_phys), INTENT(IN) :: uref - REAL(kind=kind_phys), INTENT(OUT):: znotm + REAL(kind_phys), INTENT(IN) :: uref + REAL(kind_phys), INTENT(OUT):: znotm - REAL(kind=kind_phys), PARAMETER :: p13 = -1.296521881682694e-02,& + REAL(kind_phys), PARAMETER :: p13 = -1.296521881682694e-02,& & p12 = 2.855780863283819e-01, p11 = -1.597898515251717e+00,& - & p10 = -8.396975715683501e+00,& + & p10 = -8.396975715683501e+00, & & p25 = 3.790846746036765e-10, p24 = 3.281964357650687e-09,& & p23 = 1.962282433562894e-07, p22 = -1.240239171056262e-06,& @@ -3001,11 +2983,9 @@ SUBROUTINE znot_t_v7(uref, znott) ! znott(meter): scalar roughness scale over water ! - REAL(kind=kind_phys), INTENT(IN) :: uref - REAL(kind=kind_phys), INTENT(OUT):: znott - - REAL(kind=kind_phys), PARAMETER :: p00 = 1.100000000000000e-04,& - + REAL(kind_phys), INTENT(IN) :: uref + REAL(kind_phys), INTENT(OUT):: znott + REAL(kind_phys), PARAMETER :: p00 = 1.100000000000000e-04,& & p15 = -9.193764479895316e-10, p14 = 7.052217518653943e-08,& & p13 = -2.163419217747114e-06, p12 = 3.342963077911962e-05,& & p11 = -2.633566691328004e-04, p10 = 8.644979973037803e-04,& @@ -3061,23 +3041,23 @@ END SUBROUTINE znot_t_v7 SUBROUTINE Andreas_2002(Z_0,bvisc,ustar,Zt,Zq) IMPLICIT NONE - REAL(kind=kind_phys), INTENT(IN) :: Z_0, bvisc, ustar - REAL(kind=kind_phys), INTENT(OUT) :: Zt, Zq - REAL(kind=kind_phys) :: Ren2, zntsno + REAL(kind_phys), INTENT(IN) :: Z_0, bvisc, ustar + REAL(kind_phys), INTENT(OUT) :: Zt, Zq + REAL(kind_phys) :: Ren2, zntsno - REAL(kind=kind_phys), PARAMETER :: & + REAL(kind_phys), PARAMETER :: & bt0_s=1.25, bt0_t=0.149, bt0_r=0.317, & bt1_s=0.0, bt1_t=-0.55, bt1_r=-0.565, & bt2_s=0.0, bt2_t=0.0, bt2_r=-0.183 - REAL(kind=kind_phys), PARAMETER :: & + REAL(kind_phys), PARAMETER :: & bq0_s=1.61, bq0_t=0.351, bq0_r=0.396, & bq1_s=0.0, bq1_t=-0.628, bq1_r=-0.512, & bq2_s=0.0, bq2_t=0.0, bq2_r=-0.180 !Calculate zo for snow (Andreas et al. 2005, BLM) - zntsno = 0.135*bvisc/ustar + & - (0.035*(ustar*ustar)/9.8) * & + zntsno = 0.135*bvisc/ustar + & + (0.035*(ustar*ustar)*g_inv) * & (5.*exp(-1.*(((ustar - 0.18)/0.1)*((ustar - 0.18)/0.1))) + 1.) Ren2 = ustar*zntsno/bvisc @@ -3112,9 +3092,9 @@ END SUBROUTINE Andreas_2002 SUBROUTINE PSI_Hogstrom_1996(psi_m, psi_h, zL, Zt, Z_0, Za) IMPLICIT NONE - REAL(kind=kind_phys), INTENT(IN) :: zL, Zt, Z_0, Za - REAL(kind=kind_phys), INTENT(OUT) :: psi_m, psi_h - REAL(kind=kind_phys) :: x, x0, y, y0, zmL, zhL + REAL(kind_phys), INTENT(IN) :: zL, Zt, Z_0, Za + REAL(kind_phys), INTENT(OUT) :: psi_m, psi_h + REAL(kind_phys) :: x, x0, y, y0, zmL, zhL zmL = Z_0*zL/Za zhL = Zt*zL/Za @@ -3131,7 +3111,7 @@ SUBROUTINE PSI_Hogstrom_1996(psi_m, psi_h, zL, Zt, Z_0, Za) y = (1.-11.6*zL)**0.5 y0= (1.-11.6*zhL)**0.5 - psi_m = 2.*LOG((1.+x)/(1.+x0)) + & + psi_m = 2.*LOG((1.+x)/(1.+x0)) + & &LOG((1.+x**2.)/(1.+x0**2.)) - & &2.0*ATAN(x) + 2.0*ATAN(x0) psi_h = 2.*LOG((1.+y)/(1.+y0)) @@ -3150,9 +3130,9 @@ END SUBROUTINE PSI_Hogstrom_1996 SUBROUTINE PSI_DyerHicks(psi_m, psi_h, zL, Zt, Z_0, Za) IMPLICIT NONE - REAL(kind=kind_phys), INTENT(IN) :: zL, Zt, Z_0, Za - REAL(kind=kind_phys), INTENT(OUT) :: psi_m, psi_h - REAL(kind=kind_phys) :: x, x0, y, y0, zmL, zhL + REAL(kind_phys), INTENT(IN) :: zL, Zt, Z_0, Za + REAL(kind_phys), INTENT(OUT) :: psi_m, psi_h + REAL(kind_phys) :: x, x0, y, y0, zmL, zhL zmL = Z_0*zL/Za !Zo/L zhL = Zt*zL/Za !Zt/L @@ -3170,7 +3150,7 @@ SUBROUTINE PSI_DyerHicks(psi_m, psi_h, zL, Zt, Z_0, Za) y = (1.-16.*zL)**0.5 y0= (1.-16.*zhL)**0.5 - psi_m = 2.*LOG((1.+x)/(1.+x0)) + & + psi_m = 2.*LOG((1.+x)/(1.+x0)) + & &LOG((1.+x**2.)/(1.+x0**2.)) - & &2.0*ATAN(x) + 2.0*ATAN(x0) psi_h = 2.*LOG((1.+y)/(1.+y0)) @@ -3188,9 +3168,9 @@ END SUBROUTINE PSI_DyerHicks SUBROUTINE PSI_Beljaars_Holtslag_1991(psi_m, psi_h, zL) IMPLICIT NONE - REAL(kind=kind_phys), INTENT(IN) :: zL - REAL(kind=kind_phys), INTENT(OUT) :: psi_m, psi_h - REAL(kind=kind_phys), PARAMETER :: a=1., b=0.666, c=5., d=0.35 + REAL(kind_phys), INTENT(IN) :: zL + REAL(kind_phys), INTENT(OUT) :: psi_m, psi_h + REAL(kind_phys), PARAMETER :: a=1., b=0.666, c=5., d=0.35 IF (zL .lt. 0.) THEN !UNSTABLE @@ -3220,9 +3200,9 @@ END SUBROUTINE PSI_Beljaars_Holtslag_1991 SUBROUTINE PSI_Zilitinkevich_Esau_2007(psi_m, psi_h, zL) IMPLICIT NONE - REAL(kind=kind_phys), INTENT(IN) :: zL - REAL(kind=kind_phys), INTENT(OUT) :: psi_m, psi_h - REAL(kind=kind_phys), PARAMETER :: Cm=3.0, Ct=2.5 + REAL(kind_phys), INTENT(IN) :: zL + REAL(kind_phys), INTENT(OUT) :: psi_m, psi_h + REAL(kind_phys), PARAMETER :: Cm=3.0, Ct=2.5 IF (zL .lt. 0.) THEN !UNSTABLE @@ -3249,10 +3229,10 @@ END SUBROUTINE PSI_Zilitinkevich_Esau_2007 SUBROUTINE PSI_Businger_1971(psi_m, psi_h, zL) IMPLICIT NONE - REAL(kind=kind_phys), INTENT(IN) :: zL - REAL(kind=kind_phys), INTENT(OUT) :: psi_m, psi_h - REAL(kind=kind_phys) :: x, y - REAL(kind=kind_phys), PARAMETER :: Pi180 = 3.14159265/180. + REAL(kind_phys), INTENT(IN) :: zL + REAL(kind_phys), INTENT(OUT) :: psi_m, psi_h + REAL(kind_phys) :: x, y + REAL(kind_phys), PARAMETER :: Pi180 = 3.14159265/180. IF (zL .lt. 0.) THEN !UNSTABLE @@ -3285,9 +3265,9 @@ END SUBROUTINE PSI_Businger_1971 SUBROUTINE PSI_Suselj_Sood_2010(psi_m, psi_h, zL) IMPLICIT NONE - REAL(kind=kind_phys), INTENT(IN) :: zL - REAL(kind=kind_phys), INTENT(OUT) :: psi_m, psi_h - REAL(kind=kind_phys), PARAMETER :: Rfc=0.19, Ric=0.183, PHIT=0.8 + REAL(kind_phys), INTENT(IN) :: zL + REAL(kind_phys), INTENT(OUT) :: psi_m, psi_h + REAL(kind_phys), PARAMETER :: Rfc=0.19, Ric=0.183, PHIT=0.8 IF (zL .gt. 0.) THEN !STABLE @@ -3315,10 +3295,10 @@ END SUBROUTINE PSI_Suselj_Sood_2010 SUBROUTINE PSI_CB2005(psim1,psih1,zL,z0L) IMPLICIT NONE - REAL(kind=kind_phys), INTENT(IN) :: zL,z0L - REAL(kind=kind_phys), INTENT(OUT) :: psim1,psih1 + REAL(kind_phys), INTENT(IN) :: zL,z0L + REAL(kind_phys), INTENT(OUT) :: psim1,psih1 - psim1 = -6.1*LOG(zL + (1.+ zL**2.5)**0.4) & + psim1 = -6.1*LOG(zL + (1.+ zL**2.5)**0.4) & -6.1*LOG(z0L + (1.+ z0L**2.5)**0.4) psih1 = -5.5*log(zL + (1.+ zL**1.1)**0.90909090909) & -5.5*log(z0L + (1.+ z0L**1.1)**0.90909090909) @@ -3334,18 +3314,18 @@ END SUBROUTINE PSI_CB2005 SUBROUTINE Li_etal_2010(zL, Rib, zaz0, z0zt) IMPLICIT NONE - REAL(kind=kind_phys), INTENT(OUT) :: zL - REAL(kind=kind_phys), INTENT(IN) :: Rib, zaz0, z0zt - REAL(kind=kind_phys) :: alfa, beta, zaz02, z0zt2 - REAL(kind=kind_phys), PARAMETER :: & + REAL(kind_phys), INTENT(OUT) :: zL + REAL(kind_phys), INTENT(IN) :: Rib, zaz0, z0zt + REAL(kind_phys) :: alfa, beta, zaz02, z0zt2 + REAL(kind_phys), PARAMETER :: & & au11=0.045, bu11=0.003, bu12=0.0059, & & bu21=-0.0828, bu22=0.8845, bu31=0.1739, & & bu32=-0.9213, bu33=-0.1057 - REAL(kind=kind_phys), PARAMETER :: & + REAL(kind_phys), PARAMETER :: & & aw11=0.5738, aw12=-0.4399, aw21=-4.901, & & aw22=52.50, bw11=-0.0539, bw12=1.540, & & bw21=-0.669, bw22=-3.282 - REAL(kind=kind_phys), PARAMETER :: & + REAL(kind_phys), PARAMETER :: & & as11=0.7529, as21=14.94, bs11=0.1569, & & bs21=-0.3091, bs22=-1.303 @@ -3392,7 +3372,7 @@ SUBROUTINE Li_etal_2010(zL, Rib, zaz0, z0zt) END SUBROUTINE Li_etal_2010 !------------------------------------------------------------------- !>\ingroup mynn_sfc - REAL(kind=kind_phys) function zolri(ri,za,z0,zt,zol1,psi_opt) + REAL(kind_phys) function zolri(ri,za,z0,zt,zol1,psi_opt) !> This iterative algorithm was taken from the revised surface layer !! scheme in WRF-ARW, written by Pedro Jimenez and Jimy Dudhia and @@ -3401,12 +3381,12 @@ REAL(kind=kind_phys) function zolri(ri,za,z0,zt,zol1,psi_opt) !! estimate of z/L. IMPLICIT NONE - REAL(kind=kind_phys), INTENT(IN) :: ri,za,z0,zt,zol1 + REAL(kind_phys), INTENT(IN) :: ri,za,z0,zt,zol1 INTEGER, INTENT(IN) :: psi_opt - REAL(kind=kind_phys) :: x1,x2,fx1,fx2 + REAL(kind_phys) :: x1,x2,fx1,fx2 INTEGER :: n INTEGER, PARAMETER :: nmax = 20 - !REAL(kind=kind_phys), DIMENSION(nmax):: zLhux + !REAL(kind_phys), DIMENSION(nmax):: zLhux if (ri.lt.0.)then x1=zol1 - 0.02 !-5. @@ -3447,7 +3427,7 @@ REAL(kind=kind_phys) function zolri(ri,za,z0,zt,zol1,psi_opt) return end function !------------------------------------------------------------------- - REAL(kind=kind_phys) function zolri2(zol2,ri2,za,z0,zt,psi_opt) + REAL(kind_phys) function zolri2(zol2,ri2,za,z0,zt,psi_opt) ! INPUT: ================================= ! zol2 - estimated z/L @@ -3459,10 +3439,10 @@ REAL(kind=kind_phys) function zolri2(zol2,ri2,za,z0,zt,psi_opt) ! zolri2 - delta Ri IMPLICIT NONE - INTEGER, INTENT(IN) :: psi_opt - REAL(kind=kind_phys), INTENT(IN) :: ri2,za,z0,zt - REAL(kind=kind_phys), INTENT(INOUT) :: zol2 - REAL(kind=kind_phys) :: zol20,zol3,psim1,psih1,psix2,psit2,zolt + INTEGER, INTENT(IN) :: psi_opt + REAL(kind_phys), INTENT(IN) :: ri2,za,z0,zt + REAL(kind_phys), INTENT(INOUT) :: zol2 + REAL(kind_phys) :: zol20,zol3,psim1,psih1,psix2,psit2,zolt if(zol2*ri2 .lt. 0.)zol2=0. ! limit zol2 - must be same sign as ri2 @@ -3489,19 +3469,19 @@ REAL(kind=kind_phys) function zolri2(zol2,ri2,za,z0,zt,psi_opt) end function !==================================================================== - REAL(kind=kind_phys) function zolrib(ri,za,z0,zt,logz0,logzt,zol1,psi_opt) + REAL(kind_phys) function zolrib(ri,za,z0,zt,logz0,logzt,zol1,psi_opt) ! This iterative algorithm to compute z/L from bulk-Ri IMPLICIT NONE - REAL(kind=kind_phys), INTENT(IN) :: ri,za,z0,zt,logz0,logzt - INTEGER, INTENT(IN) :: psi_opt - REAL(kind=kind_phys), INTENT(INOUT) :: zol1 - REAL(kind=kind_phys) :: zol20,zol3,zolt,zolold + REAL(kind_phys), INTENT(IN) :: ri,za,z0,zt,logz0,logzt + INTEGER, INTENT(IN) :: psi_opt + REAL(kind_phys), INTENT(INOUT) :: zol1 + REAL(kind_phys) :: zol20,zol3,zolt,zolold INTEGER :: n INTEGER, PARAMETER :: nmax = 20 - REAL(kind=kind_phys), DIMENSION(nmax):: zLhux - REAL(kind=kind_phys) :: psit2,psix2 + REAL(kind_phys), DIMENSION(nmax):: zLhux + REAL(kind_phys) :: psit2,psix2 !print*,"+++++++INCOMING: z/L=",zol1," ri=",ri if (zol1*ri .lt. 0.) THEN @@ -3569,7 +3549,7 @@ REAL(kind=kind_phys) function zolrib(ri,za,z0,zt,logz0,logzt,zol1,psi_opt) SUBROUTINE psi_init(psi_opt,errmsg,errflg) integer :: N,psi_opt - real(kind=kind_phys) :: zolf + real(kind_phys) :: zolf character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -3614,8 +3594,8 @@ END SUBROUTINE psi_init ! ... integrated similarity functions from MYNN... ! !>\ingroup mynn_sfc - REAL(kind=kind_phys) function psim_stable_full(zolf) - REAL(kind=kind_phys) :: zolf + real(kind_phys) function psim_stable_full(zolf) + real(kind_phys) :: zolf !psim_stable_full=-6.1*log(zolf+(1+zolf**2.5)**(1./2.5)) psim_stable_full=-6.1*log(zolf+(1+zolf**2.5)**0.4) @@ -3624,8 +3604,8 @@ REAL(kind=kind_phys) function psim_stable_full(zolf) end function !>\ingroup mynn_sfc - REAL(kind=kind_phys) function psih_stable_full(zolf) - REAL(kind=kind_phys) :: zolf + real(kind_phys) function psih_stable_full(zolf) + real(kind_phys) :: zolf !psih_stable_full=-5.3*log(zolf+(1+zolf**1.1)**(1./1.1)) psih_stable_full=-5.3*log(zolf+(1+zolf**1.1)**0.9090909090909090909) @@ -3634,8 +3614,8 @@ REAL(kind=kind_phys) function psih_stable_full(zolf) end function !>\ingroup mynn_sfc - REAL(kind=kind_phys) function psim_unstable_full(zolf) - REAL(kind=kind_phys) :: zolf,x,ym,psimc,psimk + real(kind_phys) function psim_unstable_full(zolf) + real(kind_phys) :: zolf,x,ym,psimc,psimk x=(1.-16.*zolf)**.25 !psimk=2*ALOG(0.5*(1+X))+ALOG(0.5*(1+X*X))-2.*ATAN(X)+2.*ATAN(1.) @@ -3652,8 +3632,8 @@ REAL(kind=kind_phys) function psim_unstable_full(zolf) end function !>\ingroup mynn_sfc - REAL(kind=kind_phys) function psih_unstable_full(zolf) - REAL(kind=kind_phys) :: zolf,y,yh,psihc,psihk + real(kind_phys) function psih_unstable_full(zolf) + real(kind_phys) :: zolf,y,yh,psihc,psihk y=(1.-16.*zolf)**.5 !psihk=2.*log((1+y)/2.) @@ -3673,10 +3653,10 @@ REAL(kind=kind_phys) function psih_unstable_full(zolf) ! !>\ingroup mynn_sfc !! - REAL(kind=kind_phys) function psim_stable_full_gfs(zolf) - REAL(kind=kind_phys) :: zolf - REAL(kind=kind_phys), PARAMETER :: alpha4 = 20. - REAL(kind=kind_phys) :: aa + REAL(kind_phys) function psim_stable_full_gfs(zolf) + REAL(kind_phys) :: zolf + REAL(kind_phys), PARAMETER :: alpha4 = 20. + REAL(kind_phys) :: aa aa = sqrt(1. + alpha4 * zolf) psim_stable_full_gfs = -1.*aa + log(aa + 1.) @@ -3686,10 +3666,10 @@ REAL(kind=kind_phys) function psim_stable_full_gfs(zolf) !>\ingroup mynn_sfc !! - REAL(kind=kind_phys) function psih_stable_full_gfs(zolf) - REAL(kind=kind_phys) :: zolf - REAL(kind=kind_phys), PARAMETER :: alpha4 = 20. - REAL(kind=kind_phys) :: bb + real(kind_phys) function psih_stable_full_gfs(zolf) + real(kind_phys) :: zolf + real(kind_phys), PARAMETER :: alpha4 = 20. + real(kind_phys) :: bb bb = sqrt(1. + alpha4 * zolf) psih_stable_full_gfs = -1.*bb + log(bb + 1.) @@ -3699,10 +3679,10 @@ REAL(kind=kind_phys) function psih_stable_full_gfs(zolf) !>\ingroup mynn_sfc !! - REAL(kind=kind_phys) function psim_unstable_full_gfs(zolf) - REAL(kind=kind_phys) :: zolf - REAL(kind=kind_phys) :: hl1,tem1 - REAL(kind=kind_phys), PARAMETER :: a0=-3.975, a1=12.32, & + real(kind_phys) function psim_unstable_full_gfs(zolf) + real(kind_phys) :: zolf + real(kind_phys) :: hl1,tem1 + real(kind_phys), PARAMETER :: a0=-3.975, a1=12.32, & b1=-7.755, b2=6.041 if (zolf .ge. -0.5) then @@ -3719,10 +3699,10 @@ REAL(kind=kind_phys) function psim_unstable_full_gfs(zolf) !>\ingroup mynn_sfc !! - REAL(kind=kind_phys) function psih_unstable_full_gfs(zolf) - REAL(kind=kind_phys) :: zolf - REAL(kind=kind_phys) :: hl1,tem1 - REAL(kind=kind_phys), PARAMETER :: a0p=-7.941, a1p=24.75, & + real(kind_phys) function psih_unstable_full_gfs(zolf) + real(kind_phys) :: zolf + real(kind_phys) :: hl1,tem1 + real(kind_phys), PARAMETER :: a0p=-7.941, a1p=24.75, & b1p=-8.705, b2p=7.899 if (zolf .ge. -0.5) then @@ -3739,9 +3719,9 @@ REAL(kind=kind_phys) function psih_unstable_full_gfs(zolf) !>\ingroup mynn_sfc !! look-up table functions - or, if beyond -10 < z/L < 10, recalculate - REAL(kind=kind_phys) function psim_stable(zolf,psi_opt) + real(kind_phys) function psim_stable(zolf,psi_opt) integer :: nzol,psi_opt - real(kind=kind_phys) :: rzol,zolf + real(kind_phys) :: rzol,zolf nzol = int(zolf*100.) rzol = zolf*100. - nzol @@ -3759,9 +3739,9 @@ REAL(kind=kind_phys) function psim_stable(zolf,psi_opt) end function !>\ingroup mynn_sfc - REAL(kind=kind_phys) function psih_stable(zolf,psi_opt) + real(kind_phys) function psih_stable(zolf,psi_opt) integer :: nzol,psi_opt - real(kind=kind_phys) :: rzol,zolf + real(kind_phys) :: rzol,zolf nzol = int(zolf*100.) rzol = zolf*100. - nzol @@ -3779,9 +3759,9 @@ REAL(kind=kind_phys) function psih_stable(zolf,psi_opt) end function !>\ingroup mynn_sfc - REAL(kind=kind_phys) function psim_unstable(zolf,psi_opt) + real(kind_phys) function psim_unstable(zolf,psi_opt) integer :: nzol,psi_opt - real(kind=kind_phys) :: rzol,zolf + real(kind_phys) :: rzol,zolf nzol = int(-zolf*100.) rzol = -zolf*100. - nzol @@ -3799,9 +3779,9 @@ REAL(kind=kind_phys) function psim_unstable(zolf,psi_opt) end function !>\ingroup mynn_sfc - REAL(kind=kind_phys) function psih_unstable(zolf,psi_opt) + real(kind_phys) function psih_unstable(zolf,psi_opt) integer :: nzol,psi_opt - real(kind=kind_phys) :: rzol,zolf + real(kind_phys) :: rzol,zolf nzol = int(-zolf*100.) rzol = -zolf*100. - nzol diff --git a/physics/mynnsfc_wrapper.F90 b/physics/mynnsfc_wrapper.F90 index 4be912ab7..1a970c9f4 100644 --- a/physics/mynnsfc_wrapper.F90 +++ b/physics/mynnsfc_wrapper.F90 @@ -87,15 +87,14 @@ SUBROUTINE mynnsfc_wrapper_run( & & FLHC, FLQC, & & U10, V10, TH2, T2, Q2, & & wstar, CHS2, CQS2, & - & spp_wts_sfc, spp_sfc, & -! & CP, G, ROVCP, R, XLV, & -! & SVP1, SVP2, SVP3, SVPT0, & -! & EP1,EP2,KARMAN, & - & lprnt, errmsg, errflg ) + & spp_wts_sfc, spp_sfc, & + & lprnt, errmsg, errflg ) ! should be moved to inside the mynn: use machine , only : kind_phys + use physcons, only : cp => con_cp, & + & grav => con_g ! USE module_sf_mynn, only : SFCLAY_mynn !tgs - info on iterations: @@ -111,22 +110,11 @@ SUBROUTINE mynnsfc_wrapper_run( & !------------------------------------------------------------------- implicit none !------------------------------------------------------------------- -! --- constant parameters: -! real(kind=kind_phys), parameter :: rvovrd = r_v/r_d - real(kind=kind_phys), parameter :: karman = 0.4 -! real(kind=kind_phys), parameter :: XLS = 2.85E6 -! real(kind=kind_phys), parameter :: p1000mb = 100000. - real(kind=kind_phys), parameter :: SVP1 = 0.6112 - real(kind=kind_phys), parameter :: SVP2 = 17.67 - real(kind=kind_phys), parameter :: SVP3 = 29.65 - real(kind=kind_phys), parameter :: SVPT0 = 273.15 +! --- derive more constant parameters: + real(kind_phys), parameter :: g_inv=1./grav - REAL(kind=kind_phys), PARAMETER :: xlvcp=xlv/cp, xlscp=(xlv+xlf)/cp, ev=xlv,& - &rd=r_d, rk=cp/rd, svp11=svp1*1.e3, p608=ep_1, ep_3=1.-ep_2, g_inv=1./g - - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg !MISC CONFIGURATION OPTIONS INTEGER, PARAMETER :: isfflx = 1 @@ -141,29 +129,29 @@ SUBROUTINE mynnsfc_wrapper_run( & logical, intent(in) :: redrag ! reduced drag coeff. flag for high wind over sea (j.han) integer, intent(in) :: spp_sfc ! flag for using SPP perturbations - real(kind=kind_phys), intent(in) :: delt + real(kind_phys), intent(in) :: delt !Input data integer, dimension(:), intent(in) :: vegtype - real(kind=kind_phys), dimension(:), intent(in) :: & + real(kind_phys), dimension(:), intent(in) :: & & sigmaf,shdmax,z0pert,ztpert - real(kind=kind_phys), dimension(:,:), intent(in) :: & + real(kind_phys), dimension(:,:), intent(in) :: & & spp_wts_sfc - real(kind=kind_phys), dimension(:,:), & + real(kind_phys), dimension(:,:), & & intent(in) :: phii - real(kind=kind_phys), dimension(:,:), & + real(kind_phys), dimension(:,:), & & intent(in) :: exner, PRSL, & & u, v, t3d, qvsh, qc logical, dimension(:), intent(in) :: wet, dry, icy - real(kind=kind_phys), dimension(:), intent(in) :: & + real(kind_phys), dimension(:), intent(in) :: & & tskin_wat, tskin_lnd, tskin_ice, & & tsurf_wat, tsurf_lnd, tsurf_ice, & & snowh_lnd, snowh_ice - real(kind=kind_phys), dimension(:), intent(inout) :: & + real(kind_phys), dimension(:), intent(inout) :: & & znt_wat, znt_lnd, znt_ice, & & ust_wat, ust_lnd, ust_ice, & & cm_wat, cm_lnd, cm_ice, & @@ -179,22 +167,22 @@ SUBROUTINE mynnsfc_wrapper_run( & & qsfc_wat, qsfc_lnd, qsfc_ice !MYNN-2D - real(kind=kind_phys), dimension(:), intent(in) :: & + real(kind_phys), dimension(:), intent(in) :: & & dx, pblh, slmsk, ps, & & qsfc_lnd_ruc, qsfc_ice_ruc - real(kind=kind_phys), dimension(:), intent(inout) :: & + real(kind_phys), dimension(:), intent(inout) :: & & ustm, hflx, qflx, wspd, qsfc, & & FLHC, FLQC, U10, V10, TH2, T2, Q2, & & CHS2, CQS2, rmol, zol, mol, ch, & & lh, wstar !LOCAL - real(kind=kind_phys), dimension(im) :: & + real(kind_phys), dimension(im) :: & & hfx, znt, psim, psih, & & chs, ck, cd, mavail, xland, GZ1OZ0, & & cpm, qgh, qfx, snowh_wat - real(kind=kind_phys), dimension(im,levs) :: & + real(kind_phys), dimension(im,levs) :: & & dz, th, qv !MYNN-1D @@ -291,9 +279,6 @@ SUBROUTINE mynnsfc_wrapper_run( & u3d=u,v3d=v,t3d=t3d,qv3d=qv,p3d=prsl,dz8w=dz, & th3d=th,pi3d=exner,qc3d=qc, & PSFCPA=ps,PBLH=pblh,MAVAIL=mavail,XLAND=xland,DX=dx, & - CP=cp,G=g,ROVCP=rcp,R=r_d,XLV=xlv, & - SVP1=svp1,SVP2=svp2,SVP3=svp3,SVPT0=svpt0, & - EP1=ep_1,EP2=ep_2,KARMAN=karman, & ISFFLX=isfflx,isftcflx=isftcflx,LSM=lsm,LSM_RUC=lsm_ruc, & iz0tlnd=iz0tlnd,psi_opt=psi_opt, & compute_flux=sfclay_compute_flux,compute_diag=sfclay_compute_diag,& @@ -301,6 +286,7 @@ SUBROUTINE mynnsfc_wrapper_run( & z0pert=z0pert,ztpert=ztpert, & !intent(in) redrag=redrag,sfc_z0_type=sfc_z0_type, & !intent(in) itimestep=itimestep,iter=iter,flag_iter=flag_iter, & + flag_restart=flag_restart, & wet=wet, dry=dry, icy=icy, & !intent(in) tskin_wat=tskin_wat, tskin_lnd=tskin_lnd, tskin_ice=tskin_ice, & !intent(in) tsurf_wat=tsurf_wat, tsurf_lnd=tsurf_lnd, tsurf_ice=tsurf_ice, & !intent(in) @@ -322,7 +308,7 @@ SUBROUTINE mynnsfc_wrapper_run( & ZNT=znt,USTM=ustm,ZOL=zol,MOL=mol,RMOL=rmol, & psim=psim,psih=psih, & HFLX=hflx,HFX=hfx,QFLX=qflx,QFX=qfx,LH=lh,FLHC=flhc,FLQC=flqc, & - QGH=qgh,QSFC=qsfc, & + QGH=qgh,QSFC=qsfc, & U10=u10,V10=v10,TH2=th2,T2=t2,Q2=q2, & GZ1OZ0=GZ1OZ0,WSPD=wspd,wstar=wstar, & spp_sfc=spp_sfc,pattern_spp_sfc=spp_wts_sfc, & From 46bcac5d18eb7311b2e9a7201d2471530dd017f3 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Fri, 24 Mar 2023 20:15:46 +0000 Subject: [PATCH 198/380] Modifications to 2-m diagnostics will affect the results only with the use of RUC LSM. --- physics/sfc_diag.f | 232 ++++++++++++++++++++++----------------------- 1 file changed, 113 insertions(+), 119 deletions(-) diff --git a/physics/sfc_diag.f b/physics/sfc_diag.f index 7a3defa62..ad132f20e 100644 --- a/physics/sfc_diag.f +++ b/physics/sfc_diag.f @@ -1,21 +1,13 @@ !> \file sfc_diag.f !! This file contains the land surface diagnose calculation scheme. -!> \defgroup Sfc_diag Land Surface Diagnose Calculation -!! @{ - module sfc_diag contains - - subroutine sfc_diag_init - end subroutine sfc_diag_init - - subroutine sfc_diag_finalize - end subroutine sfc_diag_finalize - -!> \brief Brief description of the subroutine -!! -!! \section arg_table_sfc_diag_run Arguments + +!> \defgroup sfc_diag_mod GFS sfc_diag module +!! This module contains the land surface diagose calculation. +!> @{ +!! \section arg_table_sfc_diag_run Argument Table !! \htmlinclude sfc_diag_run.html !! !! \section general General Algorithm @@ -34,10 +26,6 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & use funcphys, only : fpvs use physcons, only : con_t0c implicit none - - real (kind_phys), parameter :: zero = 0._kind_dbl_prec - real (kind_phys), parameter :: one = 1._kind_dbl_prec - real (kind_phys), parameter :: qmin = 1.0e-8_kind_dbl_prec ! integer, intent(in) :: im, lsm, lsm_ruc logical, intent(in) :: thsfc_loc ! Flag for reference pot. temp. @@ -56,13 +44,17 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & ! ! locals ! + real (kind_phys), parameter :: zero = 0._kind_dbl_prec + real (kind_phys), parameter :: one = 1._kind_dbl_prec + real (kind_phys), parameter :: qmin=1.0e-8 + integer :: k,i + logical :: debug_print real(kind=kind_phys) :: q1c, qv, tem, qv1, th2m, x2m, rho real(kind=kind_phys) :: dT, dQ, qsfcmr, qsfcprox, ff, fac, dz1 real(kind=kind_phys) :: t2_alt, q2_alt real(kind=kind_phys) :: thcon, cqs, chs, chs2, cqs2 real(kind=kind_phys) :: testptlat, testptlon - integer :: k,i ! real(kind=kind_phys) :: fhi, qss, wrk ! real(kind=kind_phys) sig2k, fhi, qss @@ -94,117 +86,119 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & u10m(i) = f10m(i) * u1(i) v10m(i) = f10m(i) * v1(i) fhi = fh2(i) / fh(i) - wrk = one - fhi - - thcon = (1.e5_kind_dbl_prec/ps(i))**con_rocp - !-- make sure 1st level q is not higher than saturated value - qss = fpvs(t1(i)) - qss = eps * qss / (ps(i) + epsm1 * qss) - q1c = min(q1(i),qss) ! lev 1 spec. humidity - - qv1 = q1c / (one - q1c) ! lev 1 mixing ratio - qsfcmr = qsurf(i)/(one - qsurf(i)) ! surface mixing ratio - chs = cdq(i) * wind(i) - cqs = chs - chs2 = ust(i)*con_karman/fh2(i) - cqs2 = chs2 - qsfcprox = max(qmin,qv1 + evap(i)/cqs) ! surface mix. ratio computed from the flux - - if(.not. diag_flux) then + wrk = 1. - fhi + + if(lsm /= lsm_ruc) then !-- original method - if(lsm /= lsm_ruc) then - if(thsfc_loc) then ! Use local potential temperature - t2m(i)=tskin(i)*wrk + t1(i)*prslki(i)*fhi - (grav+grav)/cp - else ! Use potential temperature referenced to 1000 hPa - t2m(i) = tskin(i)*wrk + t1(i)*fhi - (grav+grav)/cp - endif - if(evap(i) >= zero) then ! for evaporation>0, use inferred qsurf to deduce q2m - q2m(i) = qsurf(i)*wrk + max(qmin,q1c)*fhi - else ! for dew formation, use saturated q at tskin - qss = fpvs(tskin(i)) - qss = eps * qss/(ps(i) + epsm1 * qss) - q2m(i) = qss*wrk + max(qmin,q1c)*fhi - endif - else - t2m(i) = tskin(i)*wrk + t1(i)*fhi - (grav+grav)/cp + if(thsfc_loc) then ! Use local potential temperature + t2m(i)=tskin(i)*wrk + t1(i)*prslki(i)*fhi - (grav+grav)/cp + else ! Use potential temperature referenced to 1000 hPa + t2m(i) = tskin(i)*wrk + t1(i)*fhi - (grav+grav)/cp + endif + if(evap(i) >= zero) then ! for evaporation>0, use inferred qsurf to deduce q2m q2m(i) = qsurf(i)*wrk + max(qmin,q1c)*fhi - endif ! RUC lsm - + else ! for dew formation, use saturated q at tskin + qss = fpvs(tskin(i)) + qss = eps * qss/(ps(i) + epsm1 * qss) + q2m(i) = qss*wrk + max(qmin,q1c)*fhi + endif + qss = fpvs(t2m(i)) + qss = eps * qss / (ps(i) + epsm1 * qss) + q2m(i) = min(q2m(i),qss) else - !-- flux method + !RUC lsm + thcon = (1.e5_kind_phys/ps(i))**con_rocp + !-- make sure 1st level q is not higher than saturated value + qss = fpvs(t1(i)) + qss = eps * qss / (ps(i) + epsm1 * qss) + q1c = min(q1(i),qss) ! lev 1 spec. humidity + + qv1 = q1c / (one - q1c) ! lev 1 mixing ratio + qsfcmr = qsurf(i)/(one - qsurf(i)) ! surface mixing ratio + chs = cdq(i) * wind(i) + cqs = chs + chs2 = ust(i)*con_karman/fh2(i) + cqs2 = chs2 + qsfcprox = max(qmin,qv1 + evap(i)/cqs) ! surface mix. ratio computed from the flux + + if(diag_flux) then + !-- flux method th2m = tskin(i)*thcon - shflx(i)/chs2 t2m(i) = th2m/thcon - x2m = max(qmin,qsfcprox - evap(i)/cqs2) ! mix. ratio q2m(i) = x2m/(one + x2m) ! spec. humidity - endif ! flux method - - if(diag_log) then - !-- Alternative logarithmic diagnostics: - dT = t1(i) - tskin(i) - dQ = qv1 - qsfcmr - dz1= zf(i) ! level of atm. forcing - IF (dT > zero) THEN - ff = MIN(MAX(one-dT/10._kind_phys,0.01_kind_phys), one) - !for now, set zt = 0.05 - fac = LOG((2._kind_phys + .05_kind_phys)/(0.05_kind_phys + & + else + t2m(i) = tskin(i)*wrk + t1(i)*fhi - (grav+grav)/cp + q2m(i) = qsurf(i)*wrk + max(qmin,q1c)*fhi + endif ! flux method + + if(diag_log) then + !-- Alternative logarithmic diagnostics: + dT = t1(i) - tskin(i) + dQ = qv1 - qsfcmr + dz1= zf(i) ! level of atm. forcing + IF (dT > zero) THEN + ff = MIN(MAX(one-dT/10._kind_phys,0.01_kind_phys), one) + !for now, set zt = 0.05 + fac = LOG((2._kind_phys +.05_kind_phys)/(0.05_kind_phys + & & ff))/LOG((dz1 + .05_kind_phys)/(0.05_kind_phys + ff)) - T2_alt = tskin(i) + fac * dT - ELSE - !no alternatives (yet) for unstable conditions - T2_alt = t2m(i) - ENDIF - - IF (dQ > zero) THEN - ff = MIN(MAX(one-dQ/0.003_kind_phys,0.01_kind_phys), one) - !-- for now, set zt = 0.05 - fac = LOG((2._kind_phys + .05_kind_phys)/(0.05_kind_phys + & + T2_alt = tskin(i) + fac * dT + ELSE + !no alternatives (yet) for unstable conditions + T2_alt = t2m(i) + ENDIF + + IF (dQ > zero) THEN + ff = MIN(MAX(one-dQ/0.003_kind_phys,0.01_kind_phys), one) + !-- for now, set zt = 0.05 + fac = LOG((2._kind_phys +.05_kind_phys)/(0.05_kind_phys + & & ff))/LOG((dz1 + .05_kind_phys)/(0.05_kind_phys + ff)) - Q2_alt = qsfcmr + fac * dQ ! mix. ratio - Q2_alt = Q2_alt/(one + Q2_alt) ! spec. humidity - ELSE + Q2_alt = qsfcmr + fac * dQ ! mix. ratio + Q2_alt = Q2_alt/(one + Q2_alt) ! spec. humidity + ELSE !no alternatives (yet) for unstable conditions - Q2_alt = q2m(i) - ENDIF - !-- Note: use of alternative diagnostics will make - ! it cooler and drier with stable stratification - t2m(i) = T2_alt - q2m(i) = Q2_alt - endif ! log method for stable regime - - !-- check that T2m values lie in the range between tskin and t1 - x2m = max(min(tskin(i),t1(i)) , t2m(i)) - t2m(i) = min(max(tskin(i),t1(i)) , x2m) - !-- check that Q2m values lie in the range between qsurf and q1 - x2m = max(min(qsurf(i),q1c) , q2m(i)) - q2m(i) = min(max(qsurf(i),q1c) , x2m) - - !-- make sure q2m is not oversaturated - qss = fpvs(t2m(i)) - qss = eps * qss/(ps(i) + epsm1 * qss) - q2m(i) = min(q2m(i),qss) - - if(diag_flux) then - !-- from WRF, applied in HRRR - Jimy Dudhia - ! Limit Q2m diagnostic to no more than 5 percent higher than lowest level value - ! This prevents unrealistic values when QFX is not mostly surface - ! flux because calculation is based on surface flux only. - ! Problems occurred in transition periods and weak winds and vegetation source - q2m(i) = min(q2m(i),1.05_kind_dbl_prec*q1c) ! works if qsurf > q1c, evaporation - endif - - - !-- Compute dew point, using vapor pressure - qv = max(qmin,(q2m(i)/(1.-q2m(i)))) - tem = max(ps(i) * qv/( eps - epsm1 *qv), qmin) - dpt2m(i) = 243.5_kind_dbl_prec/( ( 17.67_kind_dbl_prec / & + Q2_alt = q2m(i) + ENDIF + !-- Note: use of alternative diagnostics will make + ! it cooler and drier with stable stratification + t2m(i) = T2_alt + q2m(i) = Q2_alt + endif ! log method for stable regime + + !-- check that T2m values lie in the range between tskin and t1 + x2m = max(min(tskin(i),t1(i)) , t2m(i)) + t2m(i) = min(max(tskin(i),t1(i)) , x2m) + !-- check that Q2m values lie in the range between qsurf and q1 + x2m = max(min(qsurf(i),q1c) , q2m(i)) + q2m(i) = min(max(qsurf(i),q1c) , x2m) + + + !-- make sure q2m is not oversaturated + qss = fpvs(t2m(i)) + qss = eps * qss/(ps(i) + epsm1 * qss) + q2m(i) = min(q2m(i),qss) + + if(diag_flux) then + !-- from WRF, applied in HRRR - Jimy Dudhia + ! Limit Q2m diagnostic to no more than 5 percent higher than lowest level value + ! This prevents unrealistic values when QFX is not mostly surface + ! flux because calculation is based on surface flux only. + ! Problems occurred in transition periods and weak winds and vegetation source + q2m(i) = min(q2m(i),1.05_kind_dbl_prec*q1c) ! works if qsurf > q1c, evaporation + endif + + + !-- Compute dew point, using vapor pressure + qv = max(qmin,(q2m(i)/(1.-q2m(i)))) + tem = max(ps(i) * qv/( eps - epsm1 *qv), qmin) + dpt2m(i) = 243.5_kind_dbl_prec/( ( 17.67_kind_dbl_prec / & & log(tem/611.2_kind_dbl_prec) ) - one) + con_t0c - dpt2m(i) = min(dpt2m(i),t2m(i)) + dpt2m(i) = min(dpt2m(i),t2m(i)) - if (debug_print) then - !-- diagnostics for a test point with known lat/lon - if (abs(xlat_d(i)-testptlat).lt.0.2 .and. & + if (debug_print) then + !-- diagnostics for a test point with known lat/lon + if (abs(xlat_d(i)-testptlat).lt.0.2 .and. & & abs(xlon_d(i)-testptlon).lt.0.2)then print 100,'(ruc_lsm_diag) i=',i, & & ' lat,lon=',xlat_d(i),xlon_d(i),'zf ',zf(i), & @@ -212,9 +206,10 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & & 'qsurf ',qsurf(i),'qsfcprox ',qsfcprox,'q2m ',q2m(i), & & 'q1 ',q1(i),'evap ',evap(i),'dpt2m ',dpt2m(i), & & 'chs2 ',chs2,'cqs2 ',cqs2,'cqs ',cqs,'cdq',cdq(i) - endif - endif + endif + endif 100 format (";;; ",a,i4,a,2f14.7/(4(a10,'='es11.4))) + endif ! RUC LSM enddo @@ -223,4 +218,3 @@ end subroutine sfc_diag_run !> @} end module sfc_diag -!> @} From 1804b5f0140059ee6e691ac148cc5d22521f3a75 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Fri, 24 Mar 2023 20:35:48 +0000 Subject: [PATCH 199/380] Use q1(i) instead of q1c in original diagnostics. --- physics/sfc_diag.f | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/sfc_diag.f b/physics/sfc_diag.f index ad132f20e..88305652d 100644 --- a/physics/sfc_diag.f +++ b/physics/sfc_diag.f @@ -96,11 +96,11 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & t2m(i) = tskin(i)*wrk + t1(i)*fhi - (grav+grav)/cp endif if(evap(i) >= zero) then ! for evaporation>0, use inferred qsurf to deduce q2m - q2m(i) = qsurf(i)*wrk + max(qmin,q1c)*fhi + q2m(i) = qsurf(i)*wrk + max(qmin,q1(i))*fhi else ! for dew formation, use saturated q at tskin qss = fpvs(tskin(i)) qss = eps * qss/(ps(i) + epsm1 * qss) - q2m(i) = qss*wrk + max(qmin,q1c)*fhi + q2m(i) = qss*wrk + max(qmin,q1(i))*fhi endif qss = fpvs(t2m(i)) qss = eps * qss / (ps(i) + epsm1 * qss) From 03cbe6fccd029490ea2bc862a1cbd73c38c7f3e0 Mon Sep 17 00:00:00 2001 From: drnimbusrain Date: Fri, 24 Mar 2023 21:50:05 +0000 Subject: [PATCH 200/380] Updated canopy effect to use interface levels, zi. --- physics/satmedmfvdifq.F | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index f908845e2..67fb133ed 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -1316,20 +1316,20 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & enddo !PCC_CANOPY------------------------------------ if (do_canopy) then - do k = 1, km1 + do k = 1, km1-1 do i = 1, im FCH = hvt_table(vegtype(i)) !top of canopy - IF (k .EQ. 1) THEN !first model layer + IF (k .EQ. 1) THEN !use model layer interfaces KCAN = 1 ELSE - IF (FCH .GT. zl(i,k-1) - & .AND. FCH .LE. zl(i,k) ) THEN + IF (FCH .GT. zi(i,k) + & .AND. FCH .LE. zi(i,k+1) ) THEN KCAN = 1 ELSE KCAN = 0 END IF END IF - IF (KCAN .EQ. 1) THEN !canopy could be inside model layer + IF (KCAN .EQ. 1) THEN !canopy inside model layer ! Check for other Contiguous Canopy Grid Cell Conditions IF ( lai(i) .LT. 0.1 !from LSM & .OR. FCH .LT. 0.5 ) THEN @@ -1347,16 +1347,17 @@ subroutine satmedmfvdifq_run(im,km,progsigma,ntrac,ntcw,ntrw, & !concentrations to ! source distributions in vegetation canopies. Q. J. R. Meteor. Soc. ! (1989), 115, pp 609-632 - MOL = zol(i)/zl(i,k) !Monin-Obukhov Length + MOL = zol(i)/zl(i,k) !Monin-Obukhov Length in layer HOL = FCH/MOL !local canopy stability parameter (hc/MOL) - ZCAN = zl(i,k) ! Initialize canopy top (m) = Each model layer that contains canopy + ZCAN = zi(i,k+1) ! Initialize each model layer top that contains canopy (m) + ! Integrate across total model interface ZFL = ZCAN ! Set ZFL = ZCAN COUNTCAN = 0 ! Initialize canopy layers IF (k .EQ. 1) THEN !Find bottom in each model layer BOTCAN = 0.5 ELSE - BOTCAN = zl(i,k-1) + BOTCAN = zi(i,k) END IF DO WHILE (ZCAN.GE.BOTCAN) From fe94d71c0b72174eebb3e50fd4c1b50a037e0e13 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Fri, 24 Mar 2023 23:41:54 +0000 Subject: [PATCH 201/380] Replaced double precision zero with 0. as it was in the original version. --- physics/sfc_diag.f | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/sfc_diag.f b/physics/sfc_diag.f index 88305652d..169b8493a 100644 --- a/physics/sfc_diag.f +++ b/physics/sfc_diag.f @@ -86,7 +86,7 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & u10m(i) = f10m(i) * u1(i) v10m(i) = f10m(i) * v1(i) fhi = fh2(i) / fh(i) - wrk = 1. - fhi + wrk = 1.0 - fhi if(lsm /= lsm_ruc) then !-- original method @@ -95,7 +95,7 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & else ! Use potential temperature referenced to 1000 hPa t2m(i) = tskin(i)*wrk + t1(i)*fhi - (grav+grav)/cp endif - if(evap(i) >= zero) then ! for evaporation>0, use inferred qsurf to deduce q2m + if(evap(i) >= 0.) then ! for evaporation>0, use inferred qsurf to deduce q2m q2m(i) = qsurf(i)*wrk + max(qmin,q1(i))*fhi else ! for dew formation, use saturated q at tskin qss = fpvs(tskin(i)) From b6337e6f08f69e1d7b4f21f3470534128d806b6d Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Tue, 28 Mar 2023 21:40:06 +0000 Subject: [PATCH 202/380] Removed mosaic_lu and mosaic_soil from namelist_soilveg_ruc and set_soilveg_ruc as they are moved to the namelist options in GFS_typedefs.F90. --- physics/namelist_soilveg_ruc.F90 | 2 -- physics/set_soilveg_ruc.F90 | 9 +-------- 2 files changed, 1 insertion(+), 10 deletions(-) diff --git a/physics/namelist_soilveg_ruc.F90 b/physics/namelist_soilveg_ruc.F90 index d71d2ebfd..d93dc5c64 100644 --- a/physics/namelist_soilveg_ruc.F90 +++ b/physics/namelist_soilveg_ruc.F90 @@ -45,7 +45,6 @@ module namelist_soilveg_ruc INTEGER DEFINED_VEG INTEGER DEFINED_SOIL INTEGER DEFINED_SLOPE - INTEGER MOSAIC_LU !> -- soils real(kind_phys) BB(MAX_SOILTYP) real(kind_phys) DRYSMC(MAX_SOILTYP) @@ -63,5 +62,4 @@ module namelist_soilveg_ruc real(kind_phys) SATDKnoah(MAX_SOILTYP) real(kind_phys) SATPSInoah(MAX_SOILTYP) real(kind_phys) MAXSMCnoah(MAX_SOILTYP) - INTEGER MOSAIC_SOIL end module namelist_soilveg_ruc diff --git a/physics/set_soilveg_ruc.F90 b/physics/set_soilveg_ruc.F90 index f04a49648..7c4f0ffdf 100644 --- a/physics/set_soilveg_ruc.F90 +++ b/physics/set_soilveg_ruc.F90 @@ -36,8 +36,7 @@ subroutine set_soilveg_ruc(me,isot,ivet,nlunit,errmsg,errflg) & RSMAX_DATA, BARE, GLACIER, NATURAL, CROP, URBAN, & & DEFINED_VEG, DEFINED_SOIL, DEFINED_SLOPE, & & BB, DRYSMC, HC, MAXSMC, REFSMC, SATPSI, SATDK, SATDW, & - & WLTSMC, QTZ, mosaic_soil, mosaic_lu, & - & REFSMCnoah, WLTSMCnoah, MAXSMCnoah + & WLTSMC, QTZ, REFSMCnoah, WLTSMCnoah, MAXSMCnoah ! Initialize error-handling errflg = 0 @@ -235,9 +234,6 @@ subroutine set_soilveg_ruc(me,isot,ivet,nlunit,errmsg,errflg) endif ! end if veg table -! - set mosaic_lu=1 when info for fractional landuse is available - mosaic_lu = 0 - topt_data =298.0 cmcmax_data =0.2e-3 cfactr_data =0.5 @@ -440,9 +436,6 @@ subroutine set_soilveg_ruc(me,isot,ivet,nlunit,errmsg,errflg) endif END DO -! - set mosaic_soil=1 when info for fractional landuse is available - mosaic_soil = 0 - ! PT 5/18/2015 - changed to FALSE to match atm_namelist setting ! PT LPARAM is not used anywhere LPARAM =.FALSE. From a33db441e58e2530cfd61ba60df1ec67308aac2b Mon Sep 17 00:00:00 2001 From: Helin Wei Date: Fri, 31 Mar 2023 13:52:55 -0400 Subject: [PATCH 203/380] the raw soil color data --- physics/sfcsub.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/sfcsub.F b/physics/sfcsub.F index 4a247a1a7..3ac7df7c5 100644 --- a/physics/sfcsub.F +++ b/physics/sfcsub.F @@ -660,7 +660,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & data fnalbc2/'global_albedo4.1x1.grb'/ data fntsfc/'global_sstclim.2x2.grb'/ data fnsotc/'global_soiltype.1x1.grb'/ - data fnsocc/'C96.soil_color.tileX.nc'/ + data fnsocc/'soil_color.clm.0.05.nc'/ data fnvegc/'global_vegfrac.1x1.grb'/ data fnvetc/'global_vegtype.1x1.grb'/ data fnglac/'global_glacier.2x2.grb'/ From cbf3802e3d7c2218c6d7d15b5762576a4a218a9b Mon Sep 17 00:00:00 2001 From: Helin Wei Date: Mon, 3 Apr 2023 14:04:03 -0400 Subject: [PATCH 204/380] add iopt_diag for 2m t/q diagnostic option --- physics/module_sf_noahmplsm.F90 | 91 ++++++++++++++++++++++++++++++--- physics/noahmpdrv.F90 | 11 ++-- physics/noahmpdrv.meta | 7 +++ physics/sfc_diag_post.F90 | 6 ++- physics/sfc_diag_post.meta | 7 +++ 5 files changed, 107 insertions(+), 15 deletions(-) diff --git a/physics/module_sf_noahmplsm.F90 b/physics/module_sf_noahmplsm.F90 index 7807ee475..08632fea7 100644 --- a/physics/module_sf_noahmplsm.F90 +++ b/physics/module_sf_noahmplsm.F90 @@ -167,6 +167,10 @@ module module_sf_noahmplsm ! 2 -> czil ! 3 -> ec style ! 4 -> kb inversed + integer :: opt_diag !< options for surface 2m/q diagnostic approach + ! 1 -> external GFS sfc_diag + ! **2 -> original NoahMP 2-title + ! 3 -> NoahMP 2-title + internal GFS sfc_diag !------------------------------------------------------------------------------------------! ! physical constants: ! !------------------------------------------------------------------------------------------! @@ -416,7 +420,7 @@ subroutine noahmp_sflx (parameters, & pblhx , iz0tlnd , itime ,psi_opt ,& prcpconv, prcpnonc, prcpshcv, prcpsnow, prcpgrpl, prcphail, & ! in : forcing tbot , co2air , o2air , foln , ficeold , zlvl , & ! in : forcing - ep_1 , ep_2 , cp , & ! in : constants + ep_1 , ep_2 , epsm1 , cp , & ! in : constants albold , sneqvo , & ! in/out : stc , sh2o , smc , tah , eah , fwet , & ! in/out : canliq , canice , tv , tg , qsfc, qsnow, qrain, & ! in/out : @@ -464,6 +468,7 @@ subroutine noahmp_sflx (parameters, & integer , intent(in) :: jloc !< grid index real (kind=kind_phys) , intent(in) :: ep_1 !< real (kind=kind_phys) , intent(in) :: ep_2 !< + real (kind=kind_phys) , intent(in) :: epsm1 !< real (kind=kind_phys) , intent(in) :: cp !< real (kind=kind_phys) , intent(in) :: dt !< time step [sec] real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: zsoil !< layer-bottom depth from soil surf (m) @@ -818,7 +823,7 @@ subroutine noahmp_sflx (parameters, & fveg ,shdfac, pahv ,pahg ,pahb , & !in qsnow ,dzsnso ,lat ,canliq ,canice ,iloc, jloc , & !in thsfc_loc, prslkix,prsik1x,prslk1x,garea1, & !in - pblhx ,iz0tlnd, itime ,psi_opt, ep_1, ep_2, cp, & + pblhx ,iz0tlnd, itime ,psi_opt, ep_1, ep_2, epsm1,cp, & z0wrf ,z0hwrf , & !out imelt ,snicev ,snliqv ,epore ,t2m ,fsno , & !out sav ,sag ,qmelt ,fsa ,fsr ,taux , & !out @@ -1658,7 +1663,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in fveg ,shdfac, pahv ,pahg ,pahb , & !in qsnow ,dzsnso ,lat ,canliq ,canice ,iloc , jloc, & !in thsfc_loc, prslkix,prsik1x,prslk1x,garea1, & !in - pblhx , iz0tlnd, itime,psi_opt,ep_1, ep_2, cp, & + pblhx , iz0tlnd, itime,psi_opt,ep_1, ep_2, epsm1, cp, & z0wrf ,z0hwrf , & !out imelt ,snicev ,snliqv ,epore ,t2m ,fsno , & !out sav ,sag ,qmelt ,fsa ,fsr ,taux , & !out @@ -1742,6 +1747,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in real (kind=kind_phys) , intent(in) :: pblhx !< pbl height real (kind=kind_phys) , intent(in) :: ep_1 !< real (kind=kind_phys) , intent(in) :: ep_2 !< + real (kind=kind_phys) , intent(in) :: epsm1 !< real (kind=kind_phys) , intent(in) :: cp !< integer , intent(in) :: iz0tlnd !< integer , intent(in) :: itime !< @@ -2205,7 +2211,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in foln ,co2air ,o2air ,btran ,sfcprs , & !in rhsur ,iloc ,jloc ,q2 ,pahv ,pahg , & !in thsfc_loc, prslkix,prsik1x,prslk1x, garea1, & !in - pblhx ,iz0tlnd ,itime ,psi_opt ,ep_1, ep_2, cp, & + pblhx ,iz0tlnd ,itime ,psi_opt ,ep_1, ep_2, epsm1, cp, & eah ,tah ,tv ,tgv ,cmv, ustarx , & !inout #ifdef CCPP chv ,dx ,dz8w ,errmsg ,errflg , & !inout @@ -2242,7 +2248,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in emg ,stc ,df ,rsurf ,latheag , & !in gammag ,rhsur ,iloc ,jloc ,q2 ,pahb , & !in thsfc_loc, prslkix,prsik1x,prslk1x,vegtyp,fveg,shdfac,garea1, & !in - pblhx ,iz0tlnd ,itime ,psi_opt ,ep_1, ep_2, cp, & + pblhx ,iz0tlnd ,itime ,psi_opt ,ep_1, ep_2, epsm1, cp, & #ifdef CCPP tgb ,cmb ,chb, ustarx,errmsg ,errflg , & !inout #else @@ -3653,7 +3659,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & foln ,co2air ,o2air ,btran ,sfcprs , & !in rhsur ,iloc ,jloc ,q2 ,pahv ,pahg , & !in thsfc_loc, prslkix,prsik1x,prslk1x, garea1, & !in - pblhx ,iz0tlnd ,itime ,psi_opt ,ep_1, ep_2, cp, & + pblhx ,iz0tlnd ,itime ,psi_opt ,ep_1, ep_2, epsm1, cp, & eah ,tah ,tv ,tg ,cm,ustarx,& !inout #ifdef CCPP ch ,dx ,dz8w ,errmsg ,errflg , & !inout @@ -3675,6 +3681,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & ! -sav + irc[tv] + shc[tv] + evc[tv] + tr[tv] + canhs[tv] = 0 ! -sag + irg[tg] + shg[tg] + evg[tg] + gh[tg] = 0 ! -------------------------------------------------------------------------------------------------- + use funcphys, only : fpvs implicit none ! -------------------------------------------------------------------------------------------------- ! input @@ -3704,6 +3711,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys) , intent(in) :: pblhx !< pbl height real (kind=kind_phys) , intent(in) :: ep_1 !< real (kind=kind_phys) , intent(in) :: ep_2 !< + real (kind=kind_phys) , intent(in) :: epsm1 !< real (kind=kind_phys) , intent(in) :: cp !< integer , intent(in) :: iz0tlnd !< integer , intent(in) :: itime !< @@ -3915,6 +3923,9 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys) :: t, tdc !kelvin to degree celsius with limit -50 to +50 + real(kind=kind_phys) :: fhi, qss, wrk + real(kind=kind_phys), parameter :: qmin=1.0e-8 + character(len=80) :: message tdc(t) = min( 50., max(-50.,(t-tfrz)) ) @@ -4321,6 +4332,34 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & q2v = qsfc - ((evc+tr)/fveg+evg)/(latheav*rhoair) * 1./cq2v endif +! use sfc_diag to calculate t2mv and q2v for opt_sfc=1&3 + if(opt_diag ==3) then + if(opt_stc == 1 .or. opt_stc == 3) then + + fhi = fh2/fh + wrk = 1.0 - fhi + if(thsfc_loc) then ! Use local potential temperature + t2mv = tv*wrk + sfctmp*prslkix*fhi - (grav+grav)/cp + else ! Use potential temperature referenced to 1000 hPa + t2mv = tv*wrk + sfctmp*fhi - (grav+grav)/cp + endif + + if(evg >= 0.) then ! for evaporation>0, use inferred qsurf to deduce q2v + q2v = qsfc*wrk + max(qmin,qair)*fhi + else ! for dew formation, use saturated q at tskin + qss = fpvs(tv) + qss = ep_2 * qss / (psfc + epsm1 * qss) + q2v= qss*wrk + max(qmin,qair)*fhi + endif + qss = fpvs(t2mv) + qss = ep_2 * qss / (psfc + epsm1 * qss) + q2v = min(q2v,qss) + else + errmsg = 'Problem :opt_diag=3 is only applied for opt_sfc=1&3' + errflg = 1 + return + endif + endif ! update ch for output ch = cah chleaf = cvh @@ -4340,7 +4379,7 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & emg ,stc ,df ,rsurf ,lathea , & !in gamma ,rhsur ,iloc ,jloc ,q2 ,pahb , & !in thsfc_loc, prslkix,prsik1x,prslk1x,vegtyp,fveg,shdfac,garea1, & !in - pblhx , iz0tlnd , itime ,psi_opt,ep_1,ep_2,cp ,& + pblhx , iz0tlnd , itime ,psi_opt,ep_1,ep_2,epsm1,cp ,& #ifdef CCPP tgb ,cm ,ch,ustarx,errmsg ,errflg , & !inout #else @@ -4359,6 +4398,7 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & ! bare soil: ! -sab + irb[tg] + shb[tg] + evb[tg] + ghb[tg] = 0 ! ---------------------------------------------------------------------- + use funcphys, only : fpvs implicit none ! ---------------------------------------------------------------------- ! input @@ -4396,6 +4436,7 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & real (kind=kind_phys), intent(in) :: pblhx !< pbl height (m) real (kind=kind_phys), intent(in) :: ep_1 !< real (kind=kind_phys), intent(in) :: ep_2 !< + real (kind=kind_phys), intent(in) :: epsm1 !< real (kind=kind_phys), intent(in) :: cp !< integer, intent(in) :: iz0tlnd !< integer, intent(in) :: itime !< @@ -4544,6 +4585,10 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & real (kind=kind_phys) :: temptrs real (kind=kind_phys) :: t, tdc !kelvin to degree celsius with limit -50 to +50 + + real(kind=kind_phys) :: fhi, qss, wrk + real(kind=kind_phys), parameter :: qmin=1.0e-8 + tdc(t) = min( 50., max(-50.,(t-tfrz)) ) ! ----------------------------------------------------------------- @@ -4794,6 +4839,34 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & end if endif ! 4 +! use sfc_diag to calculate t2mv and q2v for opt_sfc=1&3 + if(opt_diag ==3) then + if(opt_stc == 1 .or. opt_stc == 3) then + + fhi = fh2/fh + wrk = 1.0 - fhi + if(thsfc_loc) then ! Use local potential temperature + t2mb = tgb*wrk + sfctmp*prslkix*fhi - (grav+grav)/cp + else ! Use potential temperature referenced to 1000 hPa + t2mb = tgb*wrk + sfctmp*fhi - (grav+grav)/cp + endif + + if(evb >= 0.) then ! for evaporation>0, use inferred qsurf to deduce q2v + q2b = qsfc*wrk + max(qmin,qair)*fhi + else ! for dew formation, use saturated q at tskin + qss = fpvs(tgb) + qss = ep_2 * qss / (psfc + epsm1 * qss) + q2b= qss*wrk + max(qmin,qair)*fhi + endif + qss = fpvs(t2mb) + qss = ep_2 * qss / (psfc + epsm1 * qss) + q2b = min(q2b,qss) + else + errmsg = 'Problem :opt_diag=3 is only applied for opt_sfc=1&3' + errflg = 1 + return + endif + endif if (parameters%urban_flag) q2b = qsfc ! update ch @@ -10025,7 +10098,7 @@ end subroutine psn_crop !! subroutine noahmp_options(idveg ,iopt_crs ,iopt_btr ,iopt_run ,iopt_sfc ,iopt_frz , & iopt_inf ,iopt_rad ,iopt_alb ,iopt_snf ,iopt_tbot, iopt_stc, & - iopt_rsf , iopt_soil, iopt_pedo, iopt_crop ,iopt_trs ) + iopt_rsf , iopt_soil, iopt_pedo, iopt_crop ,iopt_trs, iopt_diag ) implicit none @@ -10048,6 +10121,7 @@ subroutine noahmp_options(idveg ,iopt_crs ,iopt_btr ,iopt_run ,iopt_sfc integer, intent(in) :: iopt_pedo !< pedo-transfer function (1->saxton and rawls) integer, intent(in) :: iopt_crop !< crop model option (0->none; 1->liu et al.) integer, intent(in) :: iopt_trs !< thermal roughness scheme option (1->z0h=z0; 2->rb reversed) + integer, intent(in) :: iopt_diag !< surface 2m t/q diagnostic approach ! ------------------------------------------------------------------------------------------------- @@ -10069,6 +10143,7 @@ subroutine noahmp_options(idveg ,iopt_crs ,iopt_btr ,iopt_run ,iopt_sfc opt_pedo = iopt_pedo opt_crop = iopt_crop opt_trs = iopt_trs + opt_diag = iopt_diag end subroutine noahmp_options diff --git a/physics/noahmpdrv.F90 b/physics/noahmpdrv.F90 index 17927027e..7b42f6197 100644 --- a/physics/noahmpdrv.F90 +++ b/physics/noahmpdrv.F90 @@ -126,11 +126,11 @@ subroutine noahmpdrv_run & ! --- inputs: ( im, km, lsnowl, itime, ps, u1, v1, t1, q1, soiltyp,soilcol,& vegtype, sigmaf, dlwflx, dswsfc, snet, delt, tg3, cm, ch, & - prsl1, prslk1, prslki, prsik1, zf,pblh, dry, wind, slopetyp, & + prsl1, prslk1, prslki, prsik1, zf,pblh, dry, wind, slopetyp,& shdmin, shdmax, snoalb, sfalb, flag_iter,con_g, & idveg, iopt_crs, iopt_btr, iopt_run, iopt_sfc, iopt_frz, & - iopt_inf, iopt_rad, iopt_alb, iopt_snf, iopt_tbot, & - iopt_stc, iopt_trs,xlatin, xcoszin, iyrlen, julian, garea, & + iopt_inf, iopt_rad, iopt_alb, iopt_snf, iopt_tbot,iopt_stc,& + iopt_trs,iopt_diag,xlatin, xcoszin, iyrlen, julian, garea, & rainn_mp, rainc_mp, snow_mp, graupel_mp, ice_mp, rhonewsn1,& con_hvap, con_cp, con_jcal, rhoh2o, con_eps, con_epsm1, & con_fvirt, con_rd, con_hfus, thsfc_loc, & @@ -247,6 +247,7 @@ subroutine noahmpdrv_run & integer , intent(in) :: iopt_tbot ! option for lower boundary condition of soil temperature integer , intent(in) :: iopt_stc ! option for snow/soil temperature time scheme (only layer 1) integer , intent(in) :: iopt_trs ! option for thermal roughness scheme + integer , intent(in) :: iopt_diag ! option for surface diagnose approach real(kind=kind_phys), dimension(:) , intent(in) :: xlatin ! latitude real(kind=kind_phys), dimension(:) , intent(in) :: xcoszin ! cosine of zenith angle integer , intent(in) :: iyrlen ! year length [days] @@ -763,7 +764,7 @@ subroutine noahmpdrv_run & call noahmp_options(idveg ,iopt_crs, iopt_btr , iopt_run, iopt_sfc, & iopt_frz, iopt_inf , iopt_rad, iopt_alb, & iopt_snf, iopt_tbot, iopt_stc, iopt_rsf, & - iopt_soil,iopt_pedo, iopt_crop,iopt_trs ) + iopt_soil,iopt_pedo, iopt_crop,iopt_trs,iopt_diag) if ( vegetation_category == isice_table ) then @@ -877,7 +878,7 @@ subroutine noahmpdrv_run & precip_graupel ,precip_hail ,temperature_soil_bot , & co2_air ,o2_air ,foliage_nitrogen , & snow_ice_frac_old ,forcing_height , & - con_fvirt ,con_eps ,con_cp , & + con_fvirt ,con_eps, con_epsm1 ,con_cp , & snow_albedo_old ,snow_water_equiv_old , & temperature_snow_soil ,soil_liquid_vol ,soil_moisture_vol , & temperature_canopy_air,vapor_pres_canopy_air ,canopy_wet_fraction , & diff --git a/physics/noahmpdrv.meta b/physics/noahmpdrv.meta index 7722e3db3..820da5740 100644 --- a/physics/noahmpdrv.meta +++ b/physics/noahmpdrv.meta @@ -460,6 +460,13 @@ dimensions = () type = integer intent = in +[iopt_diag] + standard_name = control_for_land_surface_scheme_surface_diagnose_approach + long_name = choice for surface diagnose approach option (see noahmp module for definition) + units = index + dimensions = () + type = integer + intent = in [xlatin] standard_name = latitude long_name = latitude diff --git a/physics/sfc_diag_post.F90 b/physics/sfc_diag_post.F90 index 139f30137..c1a43f170 100644 --- a/physics/sfc_diag_post.F90 +++ b/physics/sfc_diag_post.F90 @@ -13,7 +13,7 @@ module sfc_diag_post !! \htmlinclude sfc_diag_post_run.html !! #endif - subroutine sfc_diag_post_run (im, lsm, lsm_noahmp, dry, lssav, dtf, con_eps, con_epsm1, pgr,& + subroutine sfc_diag_post_run (im, lsm, lsm_noahmp, opt_diag, dry, lssav, dtf, con_eps, con_epsm1, pgr,& t2mmp,q2mp, t2m, q2m, u10m, v10m, tmpmin, tmpmax, spfhmin, spfhmax, & wind10mmax, u10mmax, v10mmax, dpt2m, errmsg, errflg) @@ -21,7 +21,7 @@ subroutine sfc_diag_post_run (im, lsm, lsm_noahmp, dry, lssav, dtf, con_eps, con implicit none - integer, intent(in) :: im, lsm, lsm_noahmp + integer, intent(in) :: im, lsm, lsm_noahmp,opt_diag logical, intent(in) :: lssav real(kind=kind_phys), intent(in) :: dtf, con_eps, con_epsm1 logical , dimension(:), intent(in) :: dry @@ -41,12 +41,14 @@ subroutine sfc_diag_post_run (im, lsm, lsm_noahmp, dry, lssav, dtf, con_eps, con errflg = 0 if (lsm == lsm_noahmp) then + if (opt_diag == 2 .or. opt_diag == 3)then do i=1,im if(dry(i)) then t2m(i) = t2mmp(i) q2m(i) = q2mp(i) endif enddo + endif endif if (lssav) then diff --git a/physics/sfc_diag_post.meta b/physics/sfc_diag_post.meta index 56534d71b..c50d3c4dc 100644 --- a/physics/sfc_diag_post.meta +++ b/physics/sfc_diag_post.meta @@ -28,6 +28,13 @@ dimensions = () type = integer intent = in +[opt_diag] + standard_name = control_for_land_surface_scheme_surface_diagnose_approach + long_name = choice for surface diagnose approach option (see noahmp module for definition) + units = index + dimensions = () + type = integer + intent = in [dry] standard_name = flag_nonzero_land_surface_fraction long_name = flag indicating presence of some land surface area fraction From 40e1e266557410c17e29409e1089d9aa93e73356 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Mon, 3 Apr 2023 21:13:02 +0000 Subject: [PATCH 205/380] con_tpp => con_ttp --- physics/GFS_radiation_surface.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/GFS_radiation_surface.F90 b/physics/GFS_radiation_surface.F90 index 903566864..f6067a86c 100644 --- a/physics/GFS_radiation_surface.F90 +++ b/physics/GFS_radiation_surface.F90 @@ -68,7 +68,7 @@ subroutine GFS_radiation_surface_run ( & integer, intent(in) :: im, nf_albd, ialb logical, intent(in) :: frac_grid, lslwr, lsswr, use_cice_alb, cplice integer, intent(in) :: lsm, lsm_noahmp, lsm_ruc, lndp_type, n_var_lndp - real(kind=kind_phys), intent(in) :: min_seaice, min_lakeice, con_tpp + real(kind=kind_phys), intent(in) :: min_seaice, min_lakeice, con_ttp integer, dimension(:), intent(in) :: use_lake_model real(kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, slmsk, & From 6424df169766cc8c7916a6023149f50f7478db8f Mon Sep 17 00:00:00 2001 From: Michael Toy Date: Tue, 4 Apr 2023 01:42:04 +0000 Subject: [PATCH 206/380] Fixed issue with level of dividing streamline (rdxzb) being overwritten and affecting stochastic physics in ugwp --- physics/drag_suite.F90 | 11 +++-------- physics/drag_suite.meta | 2 +- 2 files changed, 4 insertions(+), 9 deletions(-) diff --git a/physics/drag_suite.F90 b/physics/drag_suite.F90 index 5cb49acff..eb51a30c5 100644 --- a/physics/drag_suite.F90 +++ b/physics/drag_suite.F90 @@ -9,12 +9,6 @@ module drag_suite !> \defgroup gfs_drag_suite_mod GSL drag_suite Module !> This module contains the CCPP-compliant GSL orographic gravity wave drag scheme. !> @{ -!! -!> \brief This subroutine initializes the orographic gravity wave drag scheme. -!! -!> \section arg_table_drag_suite_init Argument Table -!! \htmlinclude drag_suite_init.html -!! subroutine drag_suite_init(gwd_opt, errmsg, errflg) integer, intent(in) :: gwd_opt @@ -342,7 +336,7 @@ subroutine drag_suite_run( & real(kind=kind_phys), intent(inout) :: & & dudt(:,:),dvdt(:,:), & & dtdt(:,:) - real(kind=kind_phys), intent(out) :: rdxzb(:) + real(kind=kind_phys), intent(inout) :: rdxzb(:) real(kind=kind_phys), intent(in) :: & & u1(:,:),v1(:,:), & & t1(:,:),q1(:,:), & @@ -605,7 +599,6 @@ subroutine drag_suite_run( & else xland(i)=2.0 endif - RDXZB(i) = 0.0 enddo !--- calculate scale-aware tapering factors @@ -818,6 +811,8 @@ subroutine drag_suite_run( & do i=its,im + RDXZB(i) = 0.0 + if ( ls_taper(i).GT.1.E-02 ) then ! diff --git a/physics/drag_suite.meta b/physics/drag_suite.meta index ff60290ae..66f320b98 100644 --- a/physics/drag_suite.meta +++ b/physics/drag_suite.meta @@ -536,7 +536,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout [dx] standard_name = characteristic_grid_lengthscale long_name = size of the grid cell From fe1d5845d6a965f6b93e4214c6fa02300e02b4af Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Tue, 4 Apr 2023 01:50:30 +0000 Subject: [PATCH 207/380] fix syntax error --- physics/sfc_diag.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/sfc_diag.f b/physics/sfc_diag.f index f5ca4a283..60917553f 100644 --- a/physics/sfc_diag.f +++ b/physics/sfc_diag.f @@ -92,7 +92,7 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & u10m(i) = f10m(i) * u1(i) v10m(i) = f10m(i) * v1(i) have_2m = use_lake_model(i)>0 .and. use_lake2m .and. & - & iopt_lake==iopt_lake_clm) then + & iopt_lake==iopt_lake_clm if(have_2m) then t2m(i) = lake_t2m(i) q2m(i) = lake_q2m(i) From 1a2be70f9c7a940413dc38fa3a5f8755d9cf00a8 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Tue, 4 Apr 2023 04:42:50 +0000 Subject: [PATCH 208/380] use integer constant for integer comparison --- physics/GFS_surface_composites_pre.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/GFS_surface_composites_pre.F90 b/physics/GFS_surface_composites_pre.F90 index 7152f3166..98b9fecd2 100644 --- a/physics/GFS_surface_composites_pre.F90 +++ b/physics/GFS_surface_composites_pre.F90 @@ -73,7 +73,7 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, iopt_lake, iopt_l errflg = 0 do i=1,im - if(use_lake_model(i) > 0.0) then + if(use_lake_model(i) > 0) then wet(i) = .true. endif enddo From b9f1087747d3f4b775605649691c405236ae723e Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Tue, 4 Apr 2023 04:43:12 +0000 Subject: [PATCH 209/380] skip clm_lake_run if there are no lake points in the thread --- physics/clm_lake.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90 index b5a39b557..170df035b 100644 --- a/physics/clm_lake.f90 +++ b/physics/clm_lake.f90 @@ -472,7 +472,7 @@ SUBROUTINE clm_lake_run( & errmsg = ' ' errflg = 0 - if(iopt_lake/=iopt_lake_clm .or. lkm==0) then + if(iopt_lake/=iopt_lake_clm .or. lkm==0 .or. all(.not.use_lake_model)) then return ! nothing to do endif From b7cb04a7d9b7ecc7c3b4fa74b5f1b58f6a3e14ee Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Tue, 4 Apr 2023 05:07:10 +0000 Subject: [PATCH 210/380] integer, not logical --- physics/clm_lake.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90 index 170df035b..b720c6bda 100644 --- a/physics/clm_lake.f90 +++ b/physics/clm_lake.f90 @@ -472,7 +472,7 @@ SUBROUTINE clm_lake_run( & errmsg = ' ' errflg = 0 - if(iopt_lake/=iopt_lake_clm .or. lkm==0 .or. all(.not.use_lake_model)) then + if(iopt_lake/=iopt_lake_clm .or. lkm==0 .or. all(use_lake_model==0)) then return ! nothing to do endif From eb816e3c49ea94cb45dd0da00f099864bec8c66e Mon Sep 17 00:00:00 2001 From: Michael Toy Date: Wed, 5 Apr 2023 03:31:09 +0000 Subject: [PATCH 211/380] Added back CCPP header --- physics/drag_suite.F90 | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/physics/drag_suite.F90 b/physics/drag_suite.F90 index eb51a30c5..22f122e71 100644 --- a/physics/drag_suite.F90 +++ b/physics/drag_suite.F90 @@ -9,6 +9,12 @@ module drag_suite !> \defgroup gfs_drag_suite_mod GSL drag_suite Module !> This module contains the CCPP-compliant GSL orographic gravity wave drag scheme. !> @{ +!! +!> \brief This subroutine initializes the orographic gravity wave drag scheme. +!! +!> \section arg_table_drag_suite_init Argument Table +!! \htmlinclude drag_suite_init.html +!! subroutine drag_suite_init(gwd_opt, errmsg, errflg) integer, intent(in) :: gwd_opt From 59c64cdb7f616676651fba648261c0823881a741 Mon Sep 17 00:00:00 2001 From: Lisa Bengtsson Date: Fri, 7 Apr 2023 16:09:06 +0000 Subject: [PATCH 212/380] syntax error after merge conflict --- physics/sgscloud_radpre.F90 | 4 ---- 1 file changed, 4 deletions(-) diff --git a/physics/sgscloud_radpre.F90 b/physics/sgscloud_radpre.F90 index c61b57bbb..07f74714a 100644 --- a/physics/sgscloud_radpre.F90 +++ b/physics/sgscloud_radpre.F90 @@ -364,9 +364,6 @@ subroutine sgscloud_radpre_run( & endif ! qci_conv enddo enddo -<<<<<<< HEAD - endif ! imfdeepcnv -======= elseif (imfdeepcnv == imfdeepcnv_sas) then @@ -462,7 +459,6 @@ subroutine sgscloud_radpre_run( & enddo endif ! convection scheme check ->>>>>>> 57c444f6535bf34cbe8e75a52a74ea3bec2f8f50 endif ! timestep > 1 From fd4eaf34bfe0c55d8a4938766be9f561d579aa58 Mon Sep 17 00:00:00 2001 From: Lisa Bengtsson Date: Fri, 7 Apr 2023 21:44:28 +0000 Subject: [PATCH 213/380] make progsigma_calc a module so it can be used referenced by several convection schemes --- physics/cu_unified_deep.F90 | 1 + physics/cu_unified_driver.F90 | 3 ++- physics/cu_unified_driver.meta | 2 +- physics/cu_unified_sh.F90 | 2 ++ physics/progsigma_calc.f90 | 10 ++++++++++ physics/samfdeepcnv.f | 3 ++- physics/samfshalcnv.f | 1 + 7 files changed, 19 insertions(+), 3 deletions(-) diff --git a/physics/cu_unified_deep.F90 b/physics/cu_unified_deep.F90 index 5781f7abf..a6be5c450 100644 --- a/physics/cu_unified_deep.F90 +++ b/physics/cu_unified_deep.F90 @@ -3,6 +3,7 @@ module cu_unified_deep use machine , only : kind_phys + use progsigma, only : progsigma_calc real(kind=kind_phys), parameter::g=9.81 real(kind=kind_phys), parameter:: cp=1004. diff --git a/physics/cu_unified_driver.F90 b/physics/cu_unified_driver.F90 index 2ccf197ac..0e76af979 100644 --- a/physics/cu_unified_driver.F90 +++ b/physics/cu_unified_driver.F90 @@ -9,12 +9,13 @@ module cu_unified_driver use machine , only: kind_phys use cu_unified_deep, only: cu_unified_deep_run,neg_check,fct1d3 use cu_unified_sh , only: cu_unified_sh_run + use progsigma , only: progsigma_calc implicit none private - public :: cu_unified_driver_init, cu_unified_driver_run + public :: cu_unified_driver_init, cu_unified_driver_run, progsigma_calc contains diff --git a/physics/cu_unified_driver.meta b/physics/cu_unified_driver.meta index 31f4b0ab7..3a2e28c66 100644 --- a/physics/cu_unified_driver.meta +++ b/physics/cu_unified_driver.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = cu_unified_driver type = scheme - dependencies = cu_unified_deep.F90,cu_unified_sh.F90,machine.F,physcons.F90 + dependencies = cu_unified_deep.F90,cu_unified_sh.F90,machine.F,physcons.F90,progsigma_calc.f90 ######################################################################## [ccpp-arg-table] diff --git a/physics/cu_unified_sh.F90 b/physics/cu_unified_sh.F90 index 2dc9279b9..84e5cc6da 100644 --- a/physics/cu_unified_sh.F90 +++ b/physics/cu_unified_sh.F90 @@ -3,6 +3,8 @@ module cu_unified_sh use machine , only : kind_phys + use progsigma, only : progsigma_calc + !real(kind=kind_phys), parameter:: c1_shal=0.0015! .0005 real(kind=kind_phys), parameter:: c1_shal=0. !0.005! .0005 real(kind=kind_phys), parameter:: g =9.81 diff --git a/physics/progsigma_calc.f90 b/physics/progsigma_calc.f90 index 4bbd305ae..c87308602 100644 --- a/physics/progsigma_calc.f90 +++ b/physics/progsigma_calc.f90 @@ -1,3 +1,11 @@ + module progsigma + + implicit none + + public progsigma_calc + + contains + !>\file progsigma_calc.f90 !! This file contains the subroutine that calculates the prognostic !! updraft area fraction that is used for closure computations in @@ -211,3 +219,5 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & endif end subroutine progsigma_calc + +end module progsigma diff --git a/physics/samfdeepcnv.f b/physics/samfdeepcnv.f index cd130dfd0..0d4f9fd0f 100644 --- a/physics/samfdeepcnv.f +++ b/physics/samfdeepcnv.f @@ -7,7 +7,8 @@ module samfdeepcnv use samfcnv_aerosols, only : samfdeepcnv_aerosols - + use progsigma, only : progsigma_calc + contains subroutine samfdeepcnv_init(imfdeepcnv,imfdeepcnv_samf, & diff --git a/physics/samfshalcnv.f b/physics/samfshalcnv.f index ab25e9922..2f8b188a5 100644 --- a/physics/samfshalcnv.f +++ b/physics/samfshalcnv.f @@ -4,6 +4,7 @@ module samfshalcnv use samfcnv_aerosols, only : samfshalcnv_aerosols + use progsigma, only : progsigma_calc contains From 0a71797cac0a52a9b50bd28ab39baae5dfb79772 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Mon, 10 Apr 2023 13:21:54 -0500 Subject: [PATCH 214/380] Adds support for 3-moment rain/graupel/hail in NSSL microphysics scheme Also other various bug fixes etc. --- physics/module_mp_nssl_2mom.F90 | 4774 +++++++++++++++++++++++++++---- physics/mp_nssl.F90 | 78 +- physics/mp_nssl.meta | 38 + 3 files changed, 4371 insertions(+), 519 deletions(-) diff --git a/physics/module_mp_nssl_2mom.F90 b/physics/module_mp_nssl_2mom.F90 index d190e94b4..f2f9707fb 100644 --- a/physics/module_mp_nssl_2mom.F90 +++ b/physics/module_mp_nssl_2mom.F90 @@ -1,7 +1,14 @@ !> \file module_mp_nssl_2mom.F90 + + + + + + + !--------------------------------------------------------------------- -! code snapshot: "Feb 24 2022" at "14:27:57" +! code snapshot: "Apr 10 2023" at "13:17:29" !--------------------------------------------------------------------- !--------------------------------------------------------------------- ! IMPORTANT: Best results are attained using the 5th-order WENO (Weighted Essentially Non-Oscillatory) advection option (4) for scalars: @@ -19,17 +26,14 @@ ! WENO references: Jiang and Shu, 1996, J. Comp. Phys. v. 126, 202-223; Shu 2003, Int. J. Comp. Fluid Dyn. v. 17 107-118; ! !>\ingroup mod_mp_nssl2m -!! This module provides a 2-moment bulk microphysics scheme described by -!! Mansell, Zeigler, and Bruning (2010, JAS) -!! -!! This module provides a 2-moment bulk microphysics scheme based on a combination of -!! Straka and Mansell (2005, JAM) and Zeigler (1985, JAS) and modified/upgraded in -!! in Mansell, Zeigler, and Bruning (2010, JAS). Two-moment adaptive sedimentation +!! This module provides a 1/2/3-moment bulk microphysics scheme based on a combination of +!! Straka and Mansell (2005, JAM) and Zeigler (1985, JAS) and modified/upgraded in +!! in Mansell, Zeigler, and Bruning (2010, JAS). Two-moment adaptive sedimentation !! follows Mansell (2010, JAS), using parameter infall = 4. !! !! Added info on graupel density and soaking is in Mansell and Ziegler (2013, JAS) !! -!! Average graupel particle density is predicted, which affects fall speed as well. +!! Average graupel particle density is predicted, which affects fall speed as well. !! Hail density prediction is by default disabled in this version, but may be enabled !! at some point if there is interest. !! @@ -37,19 +41,19 @@ !! !! Microphysics References: !! -!! Mansell, E. R., C. L. Ziegler, and E. C. Bruning, 2010: Simulated electrification of a small +!! Mansell, E. R., C. L. Ziegler, and E. C. Bruning, 2010: Simulated electrification of a small !! thunderstorm with two-moment bulk microphysics. J. Atmos. Sci., 67, 171-194, doi:10. 1175/2009JAS2965.1. !! -!! Mansell, E. R. and C. L. Ziegler, 2013: Aerosol effects on simulated storm electrification and -!! precipitation in a two-moment bulk microphysics model. J. Atmos. Sci., 70 (7), 2032-2050, +!! Mansell, E. R. and C. L. Ziegler, 2013: Aerosol effects on simulated storm electrification and +!! precipitation in a two-moment bulk microphysics model. J. Atmos. Sci., 70 (7), 2032-2050, !! doi:10.1175/JAS-D-12-0264.1. !! -!! Ziegler, C. L., 1985: Retrieval of thermal and microphysical variables in observed convective storms. +!! Ziegler, C. L., 1985: Retrieval of thermal and microphysical variables in observed convective storms. !! Part I: Model development and preliminary testing. J. Atmos. Sci., 42, 1487-1509. !! !! Sedimentation reference: !! -!! Mansell, E. R., 2010: On sedimentation and advection in multimoment bulk microphysics. +!! Mansell, E. R., 2010: On sedimentation and advection in multimoment bulk microphysics. !! J. Atmos. Sci., 67, 3084-3094, doi:10.1175/2010JAS3341.1. ! ! Possible parameters to adjust: @@ -63,9 +67,9 @@ ! Fierro, A. O., E.R. Mansell, C. Ziegler and D. R. MacGorman 2013: The ! implementation of an explicit charging and discharge lightning scheme ! within the WRF-ARW model: Benchmark simulations of a continental squall line, a -! tropical cyclone and a winter storm. Monthly Weather Review, Volume 141, 2390-2415 +! tropical cyclone and a winter storm. Monthly Weather Review, Volume 141, 2390-2415 ! -! Mansell et al. 2005: Charge structure and lightning sensitivity in a simulated +! Mansell et al. 2005: Charge structure and lightning sensitivity in a simulated ! multicell thunderstorm. J. Geophys. Res., 110, D12101, doi:10.1029/2004JD005287 ! ! Note: Some parameters below apply to unreleased features. @@ -74,7 +78,7 @@ !--------------------------------------------------------------------- ! Sept. 2021: ! Fixes: -! Restored previous formulation of snow reflectivity, as it was realized that the last change incorrectly assumed a fixed +! Restored previous formulation of snow reflectivity, as it was realized that the last change incorrectly assumed a fixed ! density independent of size. Generally lower snow reflectivity values as a result (no effect on microphysics) ! Other: ! Generic fall speed coeffecients (axx,bxx) to accomodate future frozen drops category (no effect) @@ -234,8 +238,9 @@ MODULE module_mp_nssl_2mom real , private :: qcmincwrn = 2.0e-3 ! qc threshold for autonconversion (LFO; for 10ICE use qminrncw for ircnw != 5) real , private :: cwdiap = 20.0e-6 ! threshold diameter of cloud drops (Ferrier 1994 autoconversion) real , private :: cwdisp = 0.15 ! assume droplet dispersion parameter (can be 0.3 for maritime) - real , private :: ccn = 0.6e+09 ! set in namelist!! Central plains CCN value - real , public :: qccn ! ccn "mixing ratio" + real , private :: ccn = 0.6e+09 ! set in namelist!! Central plains CCN value + real , private :: ccnuf = 0 ! set in namelist!! Central plains CCN value + real , public :: qccn, qccnuf ! ccn "mixing ratio" real , private :: old_qccn = -1.0 integer, private :: iauttim = 1 ! 10-ice rain delay flag real , private :: auttim = 300. ! 10-ice rain delay time @@ -245,12 +250,17 @@ MODULE module_mp_nssl_2mom ! NMM WRF core does not have special boundary conditions for CCN, therefore set invertccn to true logical, parameter :: invertccn = .true. ! =true for base state of ccn=0, =false for ccn initialized in the base state #else - logical, parameter :: invertccn = .false. ! =true for base state of ccn=0, =false for ccn initialized in the base state + logical, private :: invertccn = .false. ! =true for base state of ccn=0, =false for ccn initialized in the base state #endif logical :: switchccn = .false. real :: old_cccn = -1.0 logical :: restoreccn = .true. ! whether or not to nudge CCN back to base state (qccn) (only applies if CCNA is NOT predicted) real :: ccntimeconst = 3600. ! time constant for CCN restore (either for CCNA or when restoreccn = true) + real, private :: restoreccnfrac = 1.0 ! fraction of evaporated droplets that restore CCN + real :: ufccntimeconst = 6.*3600. ! time constant for UFCCN decay (Blossey et al. 2018) + real :: ufbackground = 0.1e9 ! background ccnuf value (Blossey et al.) + logical :: decayufccn = .false. + integer :: i_uf_or_ccn = 0 ! 0 = ship adds UF; 1 = treat UF as regular ccn (add to qccn) ! sedimentation flags ! itfall -> 0 = 1st order fallout (other options removed) @@ -259,6 +269,7 @@ MODULE module_mp_nssl_2mom integer, private :: itfall = 0 integer, private :: iscfall = 1 integer, private :: irfall = -1 + integer, private :: isfall = 2 ! default limit with method II (more restrictive) logical, private :: do_accurate_sedimentation = .true. ! if true, recalculate fall speeds on sub time steps; (more expensive) ! if false, reuse fall speeds on multiple steps (can have a noticeable speedup) ! Mainly is an issue for small dz near the surface. @@ -269,6 +280,7 @@ MODULE module_mp_nssl_2mom ! 3 -> uses number-wgt for N and Z-weighted correction for N (Method I in Mansell, 2010 JAS) ! 4 -> Hybrid of 2 and 3: Uses minimum N from each method (z-wgt and m-wgt corrections) (Method I+II in Mansell, 2010 JAS) ! 5 -> uses number-wgt for N and uses average of N-wgt and q-wgt instead of Max. + integer :: imydiagalpha = 0 ! apply MY diagnostic shape parameter for fall speeds (1=for fall speed only; 2=also for microphysics rates) real, private :: rainfallfac = 1.0 ! factor to adjust rain fall speed (single moment only) real, private :: icefallfac = 1.5 ! factor to adjust ice fall speed real, private :: snowfallfac = 1.25 ! factor to adjust snow fall speed @@ -277,6 +289,9 @@ MODULE module_mp_nssl_2mom integer, private :: icefallopt = 3 ! 1= default, 2 = Ferrier ice fall speed; 3 = adjusted Ferrier (slightly high Vt) integer, private :: icdx = 3 ! (graupel) 0=Ferrier; 1=leave drag coef. cd fixed; 2=vary by density, 4=set by user with cdxmin,cdxmax,etc. integer, private :: icdxhl = 3 ! (hail) 0=Ferrier; 1=leave drag coef. cd fixed; 2=vary by density, 4=set by user with cdxmin,cdxmax,etc. + real :: axh = 75.7149, bxh = 0.5 + real :: axf = 75.7149, bxf = 0.5 + real :: axhl = 206.984, bxhl = 0.6384 real , private :: cdhmin = 0.45, cdhmax = 0.8 ! defaults for graupel (icdx=4) real , private :: cdhdnmin = 500., cdhdnmax = 800.0 ! defaults for graupel (icdx=4) real , private :: cdhlmin = 0.45, cdhlmax = 0.6 ! defaults for hail (icdx=4) @@ -310,7 +325,7 @@ MODULE module_mp_nssl_2mom integer, private :: irimtim = 0 ! future use ! integer, private :: infdo = 1 ! 1 = calculate number-weighted fall speeds - integer, private :: irimdenopt = 1 ! = 1 for default Macklin; = 2 for experimental Cober and List (1993) + integer, private :: irimdenopt = 1 ! = 1 for default Heymsfield and Pflaum (1985); = 2 for experimental Cober and List (1993); = 3 Macklin real , private :: rimc1 = 300.0, rimc2 = 0.44 ! rime density coeff. and power (Default Heymsfield and Pflaum, 1985) real , private :: rimc3 = 170.0 ! minimum rime density real :: rimc4 = 900.0 ! maximum rime density @@ -347,6 +362,7 @@ MODULE module_mp_nssl_2mom ! 0,2, 5.00e-10, 1, 0, 0, 0 : itype1,itype2,cimas0,icfn,ihrn,ibfc,iacr integer, private :: itype1 = 0, itype2 = 2 ! controls Hallett-Mossop process + integer, private :: in_freeze_rain_first = 0 ! =1 use IN to freezed rain drops (if none, then freeze droplets) integer, private :: icenucopt = 1 ! =1 Meyers/Ferrier primary ice nucleation; =2 Thompson/Cooper, =3 Phillips (Meyers/Demott), =4 DeMott (2010) real, private :: naer = 1.0e6 ! background large aerosol conc. for DeMott integer, private :: icfn = 2 ! contact freezing: 0 = off; 1 = hack (ok for single moment); 2 = full Cotton/Meyers version @@ -357,7 +373,9 @@ MODULE module_mp_nssl_2mom integer, private :: iremoveqwfrz = 1 ! Whether to remove (=1) or not (=0) the newly-frozen cloud droplets (ibfc=1) from the CWC used for charge separation integer, private :: iacr = 2 ! Flag for drop contact freezing with crytals ! (0=off; 1=drops > 500micron diameter; 2 = > 300micron) + integer, private :: icrcev = 1 ! 1 = old crcev; 2 = crcev scaled by vtrain ratio (num/mass); 3 = set to zero integer, private :: icracr = 1 ! Flag to turn rain self-collection on/off (=0 to turn off) + integer, private :: icracrthresh = 1 ! For rain self-coll. thresh. use: 1 = mean diam of 2mm; 2 = rain median volume diam of 1.9mm integer, private :: ibfr = 2 ! Flag for Bigg freezing conversion of freezing drops to graupel ! (1=min graupel size is vr1mm; 2=use min size of dfrz, 5= as for 2 and apply dbz conservation) integer, private :: ibiggopt = 2 ! 1 = old Bigg; 2 = experimental Bigg (only for imurain = 1, however) @@ -413,11 +431,14 @@ MODULE module_mp_nssl_2mom ! set eii1 = 0 to get a constant value of eii0 real , private :: eii0hl = 0.2 ,eii1hl = 0.0 ! hail-crystal coll. eff. parameters: eii0hl*exp(eii1hl*min(temcg(mgs),0.0)) ! set eii1hl = 0 to get a constant value of eii0hl + real, private :: ewi_dcmin = 15.0e-06 ! minimum droplet diameter for nonzero ewi + real, private :: ewi_dimin = 30.0e-06 ! minimum ice crystal diameter for nonzero ewi real , private :: eri0 = 0.1 ! rain efficiency to collect ice crystals real , private :: eri_cimin = 10.e-6 ! minimum ice crystal diameter for collection by rain real , private :: esi0 = 0.1 ! linear factor in snow-ice collection efficiency real , private :: ehs0 = 0.1, ehs1 = 0.1 ! graupel-snow coll. eff. parameters: ehs0*exp(ehs1*min(temcg(mgs),0.0)) ! set ehs1 = 0 to get a constant value of ehs0 + integer :: iessopt = 1 ! 1 = Original (no factor); 2 = factor based on wvel; 3 = factor based on SSI real , private :: ess0 = 0.5, ess1 = 0.05 ! snow aggregation coefficients: ess0*exp(ess1*min(temcg(mgs),0.0)) ! set ess1 = 0 to get a constant value of ess0 real , private :: esstem1 = -15. ! lower temperature where snow aggregation turns on @@ -452,11 +473,13 @@ MODULE module_mp_nssl_2mom ! 0 = no condensation on rain; 1 = bulk condensation on rain integer, parameter, private :: icond = 1 ! (Z only) icond = 1 calculates ice deposition (crystals and snow) BEFORE droplet condensation ! icond = 2 does not work (intended to calc. dep in loop with droplet cond.) + integer, private :: iqis0 = 2 ! = 1 for normal qis; = 2 to set qis to use T = 0C when T > 0C real , private :: dfrz = 0.15e-3 ! 0.25e-3 ! minimum diameter of frozen drops from Bigg freezing (used for vfrz) for iacr > 1 ! and for ciacrf for iacr=4 real , private :: dmlt = 3.0e-3 ! maximum diameter for rain melting from graupel and hail real , private :: dshd = 1.0e-3 ! nominal diameter for rain drops shed from graupel/hail + integer, private :: ivshdgs = 1 ! 0 = use 1mm for all shedding (non-mixedphase); 1 = use vshdgs with sheddiam integer, private :: ished2cld = 0 ! 1: Send shed liquid (from wet growth) to cloud droplets integer, private :: ihmlt = 2 ! 1=old melting with vmlt; 2=new melting using mean volume diam of graupel/hail @@ -480,6 +503,7 @@ MODULE module_mp_nssl_2mom real, private :: qhdpvdn = -1. real, private :: qhacidn = -1. + integer, private :: iraintypes = 0 logical, private :: mixedphase = .false. ! .false.=off, true=on to include mixed phase graupel integer, private :: imixedphase = 0 logical, private :: qsdenmod = .false. ! true = modify snow density by linear interpolation of snow and rain density @@ -514,14 +538,19 @@ MODULE module_mp_nssl_2mom integer, private :: ihlcnh = 1 ! which graupel -> hail conversion to use ! 1 = Milbrandt and Yau (2005) using Ziegler 1985 wet growth diameter ! 2 = Straka and Mansell (2005) conversion using size threshold + ! 3 = Conversion using wet growth diameter real, private :: hlcnhdia = 1.e-3 ! threshold diameter for graupel -> hail conversion for ihlcnh = 1 option. real, private :: hlcnhqmin = 0.1e-3 ! minimum graupel mass content for graupel -> hail conversion (ihlcnh = 1) real , private :: hldia1 = 20.0e-3 ! threshold diameter for graupel -> hail conversion for ihlcnh = 2 option. + integer :: incwet = 0 ! flag to do wet growth only on D > D_wet integer, private :: iusedw = 0 ! flag to use experimental wet growth ice diameter for gr -> hl conversion (=1 turns on) - real , private :: dwmin = 0.0 ! Minimum diameter with iusedw (can stay at 0 or be set to something larger) + real , private :: dwmin = 5.0e-3 ! Minimum diameter with iusedw (can stay at 0 or be set to something larger) + real , private :: dwetmin = 5.0e-3 ! Minimum diameter with iusedw (can stay at 0 or be set to something larger) real , private :: dwtempmin = 242. ! lowest temperature to allow wet growth conversion to hail real , private :: dwehwmin = 0. ! Minimum ehw to use to find wet growth diameter (if > ehw0, then wet growth diam becomes smaller) real , private :: dg0thresh = 0.15 ! graupel wet growth diameter above which we say do not bother + integer :: ifddenfac = 0 ! = 1 to use density threshold to count FD as GR when converting to HL + real :: fddenthresh = 500. ! if ifddenfac > 0, then hail from FD with lower density are considered to come from graupel integer :: icvhl2h = 0 ! allow conversion of hail back to graupel when hail density gets close to minimum allowed integer, private :: imurain = 1 ! 3 for gamma-volume, 1 for gamma-diameter DSD for rain. @@ -538,6 +567,8 @@ MODULE module_mp_nssl_2mom ! = 1 use mean diameter for breakup ! = 2 use maximum mass diameter for breakup ! = 3 use mass-weighted diameter for breakup + integer :: iraintailbreak = 0 ! 1 = on + real :: draintail = 8.e-3 ! starting size for rain breakup integer, private :: dmrauto = 0 ! = -1 no limiter on crcnw ! = 0 limit crcnw when qr > 1.2*L (Cohard-Pinty 2002) @@ -595,9 +626,12 @@ MODULE module_mp_nssl_2mom integer, private :: ibinnum = 2 ! number of bins for melting of smaller ice (for ibinhmlr = 1) integer, private :: iqhacrmlr = 1 ! turn on/off qhacrmlr integer, private :: iqhlacrmlr = 1 ! turn on/off qhlacrmlr + integer, private :: iqhacwshr = 1 ! turn on/off qhacw for T > 0 + integer, private :: iqhlacwshr = 1 ! turn on/off qhlacw for T > 0 real, private :: binmlrmxdia = 40.e-3 ! threshold diameter (graupel/hail) to switch bin-bulk melting to use standard chmlr real, private :: binmlrzrrfac = 1.0 ! factor for reflectivity change ice that sheds while melting real, private :: snowmeltdia = 0 ! If nonzero, sets the size of rain drops from melting snow. + real, private :: alphasmlr0 = 14.0 ! shape parameter for drops formed from melting/shedding snow real, private :: delta_alphamlr = 0.5 ! offset from alphamax at which melting does not further collapse the shape parameter integer :: iqvsopt = 0 ! =0 use old default for tabqvs; =1 use Bolton formulation (Rogers and Yau) @@ -739,6 +773,7 @@ MODULE module_mp_nssl_2mom real da1 (lc:lqmx) ! collection coefficients from Seifert 2005 real bb (lc:lqmx) + ! put ipelec here for now.... integer :: ipelec = 0 integer :: isaund = 0 @@ -764,7 +799,7 @@ MODULE module_mp_nssl_2mom double precision, parameter :: dgam = 0.01, dgami = 100. double precision gmoi(0:ngm0) ! ,gmod(0:ngm1,0:ngm2),gmdi(0:ngm1,0:ngm2) - integer, parameter :: nqiacralpha = 240 !480 ! 240 ! 120 ! 15 + integer, parameter :: nqiacralpha = 300 !480 ! 240 ! 120 ! 15 integer, parameter :: nqiacrratio = 100 ! 500 !50 ! 25 ! real, parameter :: maxratiolu = 25. real, parameter :: maxratiolu = 100. ! 25. @@ -782,6 +817,10 @@ MODULE module_mp_nssl_2mom ! real :: ziacrratio(0:nqiacrratio,0:nqiacralpha) ! double precision :: gamxinflu(0:nqiacrratio,0:nqiacralpha,12,2) ! last index for graupel (1) or hail (2) +! for 3-moment collection coefficients + real, save :: dab0lu(ialpstart:nqiacralpha,ialpstart:nqiacralpha,lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005 + real, save :: dab1lu(ialpstart:nqiacralpha,ialpstart:nqiacralpha,lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005 + integer, parameter :: ngdnmm = 9 real :: mmgraupvt(ngdnmm,3) ! Milbrandt and Morrison (2013) fall speed coefficients for graupel/hail @@ -914,6 +953,7 @@ MODULE module_mp_nssl_2mom real :: tfrcbw real :: tfrcbi real :: rovcp + real, public :: rdorv = 0.622 real, parameter :: poo = 1.0e+05 real, parameter :: advisc0 = 1.832e-05 ! reference dynamic viscosity (SMT; see Beard & Pruppacher 71) @@ -955,7 +995,7 @@ MODULE module_mp_nssl_2mom ! Note to users: Many of these options are for development and not guaranteed to perform well. ! Some may not be functional depending on the version of the code. -! Some may be useful for ensemble physics diversity. Feel free to contact me if you have questions +! Some may be useful for ensemble physics diversity. Feel free to contact Ted Mansell if you have questions ! in that regard. NAMELIST /nssl_mp_params/ & ndebug, ncdebug,& @@ -965,7 +1005,7 @@ MODULE module_mp_nssl_2mom idbzci, & vtmaxsed, & itfall,iscfall, & - infall, & + infall,irfall,isfall, & rssflg, & sssflg, & hssflg, & @@ -976,13 +1016,15 @@ MODULE module_mp_nssl_2mom icnuclimit, & irenuc, & restoreccn, ccntimeconst, cck, & + decayufccn, ufccntimeconst, & switchccn, old_cccn, & ciintmx, & itype1, itype2, & - icenucopt, & + icenucopt, in_freeze_rain_first, & naer, & icfn, & ibfc, iacr, icracr, & + icracrthresh, & cwfrz2snowfrac, cwfrz2snowratio, & ibfr, & ibiggopt, & @@ -998,7 +1040,7 @@ MODULE module_mp_nssl_2mom eri_cimin, & eii0hl, eii1hl, & ehs0, ehs1, & - ess0, ess1, & + ess0, ess1, iessopt, & esstem1,esstem2, & ircnw, qminrncw,& ! single-moment only iglcnvi, & @@ -1024,6 +1066,7 @@ MODULE module_mp_nssl_2mom hailfallfac, & icefallopt, & icdx,icdxhl, & + axh,bxh,axf,bxf,axhl,bxhl, & cdhmin, cdhmax, & cdhdnmin, cdhdnmax, & cdhlmin, cdhlmax, & @@ -1133,12 +1176,12 @@ SUBROUTINE nssl_2mom_init_const( & real, intent(in) :: con_g, con_rd, con_cp, con_rv, & con_t0c, con_cliq, con_csol, con_eps - cp608 = con_eps ! 0.608 ! constant used in conversion of T to Tv gr = con_g tfr = con_t0c cp = con_cp rd = con_rd rw = con_rv + rdorv = con_eps cpl = con_cliq ! 4190.0 cpigb = con_csol ! 2106.0 cpi = 1./cp @@ -1157,6 +1200,7 @@ END SUBROUTINE nssl_2mom_init_const !! NSSL MP setup routine (sets local options and array indices) SUBROUTINE nssl_2mom_init( & & ims,ime, jms,jme, kms,kme, nssl_params, ipctmp, mixphase,ihvol,idoniconlytmp, & + & igvol, & & nssl_graupelfallfac, & & nssl_hailfallfac, & & nssl_ehw0, & @@ -1165,7 +1209,13 @@ SUBROUTINE nssl_2mom_init( & & nssl_icdxhl, & & nssl_icefallfac, & & nssl_snowfallfac, & + & nssl_cccn, & + & nssl_ufccn, & + & nssl_alphah, & + & nssl_alphahl, & + & nssl_alphar, & & errmsg, errflg, & + & infileunit, & & myrank, mpiroot & ) @@ -1177,22 +1227,30 @@ SUBROUTINE nssl_2mom_init( & & nssl_ehw0, & & nssl_ehlw0, & & nssl_icefallfac, & - & nssl_snowfallfac + & nssl_snowfallfac, & + & nssl_cccn, & + & nssl_alphah, & + & nssl_alphahl, & + & nssl_alphar integer, intent(in), optional :: & - & nssl_icdx, & - & nssl_icdxhl, myrank, mpiroot + & nssl_icdx, igvol, & + & nssl_icdxhl, myrank, mpiroot, & + & nssl_ufccn + + integer, intent(in),optional :: infileunit ! CCPP error handling character(len=*), intent( out) :: errmsg integer, intent( out) :: errflg - integer, intent(in) :: ims,ime, jms,jme, kms,kme - real, intent(in), dimension(20) :: nssl_params + integer, intent(in), optional :: ims,ime, jms,jme, kms,kme + real, intent(in), dimension(20), optional :: nssl_params integer, intent(in) :: ipctmp,mixphase,ihvol logical, optional, intent(in) :: idoniconlytmp + integer :: igvol_local = 1 logical :: wrote_namelist = .false. logical :: wrf_dm_on_monitor @@ -1202,22 +1260,31 @@ SUBROUTINE nssl_2mom_init( & integer :: i,il,j,l integer :: ltmp integer :: isub - real :: bxh,bxhl + real :: bxh1,bxhl1 real :: alp,ratio double precision :: x,y,y2,y7 logical :: turn_on_ccna, turn_on_cina + integer :: iufccn = 0 integer :: istat + + real :: alpjj, alpii, xnuii, xnujj + integer :: ii, jj errmsg = '' errflg = 0 turn_on_ccna = .false. turn_on_cina = .false. + + IF ( present( igvol ) ) THEN + igvol_local = igvol + ENDIF ! ! set some global values from namelist input ! + IF ( present( nssl_params ) ) THEN ccn = Abs( nssl_params(1) ) alphah = nssl_params(2) alphahl = nssl_params(3) @@ -1228,8 +1295,16 @@ SUBROUTINE nssl_2mom_init( & rho_qh = nssl_params(8) rho_qhl = nssl_params(9) rho_qs = nssl_params(10) - alphar = nssl_params(14) - + IF ( Nint(nssl_params(13)) == 1 ) THEN + ! hack to switch CCN field to CCNA (activated ccn) +! invertccn = .true. + turn_on_ccna = .true. + irenuc = 7 + ENDIF + ccnuf = Abs( nssl_params(14) ) + IF ( present(nssl_ufccn) ) iufccn = nssl_ufccn + + ENDIF ! ipelec = Nint(nssl_params(11)) ! isaund = Nint(nssl_params(12)) IF ( present(nssl_graupelfallfac) ) graupelfallfac = nssl_graupelfallfac @@ -1240,14 +1315,12 @@ SUBROUTINE nssl_2mom_init( & IF ( present(nssl_icdxhl) ) icdxhl = nssl_icdxhl IF ( present(nssl_icefallfac) ) icefallfac = nssl_icefallfac IF ( present(nssl_snowfallfac) ) snowfallfac = nssl_snowfallfac + IF ( present(nssl_cccn) ) ccn = nssl_cccn + IF ( present(nssl_alphah) ) alphah = nssl_alphah + IF ( present(nssl_alphahl) ) alphahl = nssl_alphahl + IF ( present(nssl_alphar) ) alphar = nssl_alphar - IF ( Nint(nssl_params(13)) == 1 ) THEN - ! hack to switch CCN field to CCNA (activated ccn) -! invertccn = .true. - turn_on_ccna = .true. - irenuc = 7 - ENDIF @@ -1275,6 +1348,15 @@ SUBROUTINE nssl_2mom_init( & + IF ( iufccn > 0 ) THEN ! make sure to use option that uses UF ccn + irenuc = 7 + IF ( ccnuf <= 0.0 ) decayufccn = .true. ! assume surface emission and need decay + IF ( i_uf_or_ccn > 0 ) THEN + ufbackground = 0.0 + ccntimeconst = ufccntimeconst + ENDIF + ENDIF + IF ( irenuc >= 5 ) THEN turn_on_ccna = .true. ENDIF @@ -1300,7 +1382,7 @@ SUBROUTINE nssl_2mom_init( & ! dfrz = Max( dfrz, 0.5e-3 ) ENDIF IF ( ihvol == -2 .or. ihvol == 2 ) THEN ! ice crystals are turned off - ! a value of -3 means to turn off ice crystals but turn on hail + ! a value of 2? means to turn off ice crystals but turn on hail renucfrac = 1.0 ffrzs = 1.0 ! idoci = 0 ! try this later @@ -1335,29 +1417,42 @@ SUBROUTINE nssl_2mom_init( & bx(lr) = 0.85 ax(lr) = 1647.81 fx(lr) = 135.477 + IF ( icdx == 6 ) THEN bx(lh) = 0.6 ! Milbrandt and Morrison (2013) for density of 550. ax(lh) = 157.71 - ELSEIF ( icdx > 0 ) THEN +! ELSEIF ( icdx == 1 ) THEN +! bx(lh) = bxh +! ax(lh) = axh + ELSEIF ( icdx > 1 ) THEN bx(lh) = 0.5 ax(lh) = 75.7149 - ELSE - bx(lh) = 0.37 ! 0.6 ! Ferrier 1994 + ELSEIF ( icdx == 0 ) THEN + bx(lh) = 0.37 ! 0.6 ! Ferrier 1994 graupel ax(lh) = 19.3 + ELSE ! icdx < 0 +! ax(lh) = 206.984 ! Ferrier 1994 hail/frozen drops +! bx(lh) = 0.6384 + bx(lh) = bxh + ax(lh) = axh ENDIF + ! bx(lh) = 0.6 IF ( lhl .gt. 1 ) THEN IF ( icdxhl == 6 ) THEN bx(lhl) = 0.593 ! Milbrandt and Morrison (2013) for density of 750. ax(lhl) = 179.36 + ELSEIF (icdxhl == 0 ) THEN + ax(lhl) = 206.984 ! Ferrier 1994 + bx(lhl) = 0.6384 ELSEIF (icdxhl > 0 ) THEN - bx(lhl) = 0.5 - ax(lhl) = 75.7149 + bx(lhl) = 0.5 + ax(lhl) = 75.7149 ELSE - ax(lhl) = 206.984 ! Ferrier 1994 - bx(lhl) = 0.6384 + bx(lhl) = bxhl + ax(lhl) = axhl ENDIF ENDIF @@ -1373,8 +1468,8 @@ SUBROUTINE nssl_2mom_init( & ! Uses incomplete gamma functions ! The terms with bxh or bxhl will be off if the actual bxh or bxhl is different from the base value (icdx=6 option) - bxh = bx(lh) - bxhl = bx(Max(lh,lhl)) + bxh1 = bx(lh) + bxhl1 = bx(Max(lh,lhl)) ! DO j = 0,nqiacralpha DO j = ialpstart,nqiacralpha @@ -1390,9 +1485,9 @@ SUBROUTINE nssl_2mom_init( & ! graupel (.,.,.,1) gamxinflu(i,j,1,1) = x/y gamxinflu(i,j,2,1) = gamxinfdp( 2.0+alp, ratio )/y - gamxinflu(i,j,3,1) = gamxinfdp( 2.5+alp+0.5*bxh, ratio )/y + gamxinflu(i,j,3,1) = gamxinfdp( 2.5+alp+0.5*bxh1, ratio )/y gamxinflu(i,j,5,1) = (gamma_dpr(5.0+alp) - gamxinfdp( 5.0+alp, ratio ))/y - gamxinflu(i,j,6,1) = (gamma_dpr(5.5+alp+0.5*bxh) - gamxinfdp( 5.5+alp+0.5*bxh, ratio ))/y + gamxinflu(i,j,6,1) = (gamma_dpr(5.5+alp+0.5*bxh1) - gamxinfdp( 5.5+alp+0.5*bxh1, ratio ))/y gamxinflu(i,j,9,1) = gamxinfdp( 1.0+alp, ratio )/y gamxinflu(i,j,10,1)= gamxinfdp( 4.0+alp, ratio )/y @@ -1401,9 +1496,9 @@ SUBROUTINE nssl_2mom_init( & ! hail (.,.,.,2) gamxinflu(i,j,1,2) = gamxinflu(i,j,1,1) gamxinflu(i,j,2,2) = gamxinflu(i,j,2,1) - gamxinflu(i,j,3,2) = gamxinfdp( 2.5+alp+0.5*bxhl, ratio )/y + gamxinflu(i,j,3,2) = gamxinfdp( 2.5+alp+0.5*bxhl1, ratio )/y gamxinflu(i,j,5,2) = gamxinflu(i,j,5,1) - gamxinflu(i,j,6,2) = (gamma_dpr(5.5+alp+0.5*bxhl) - gamxinfdp( 5.5+alp+0.5*bxhl, ratio ))/y + gamxinflu(i,j,6,2) = (gamma_dpr(5.5+alp+0.5*bxhl1) - gamxinfdp( 5.5+alp+0.5*bxhl1, ratio ))/y gamxinflu(i,j,9,2) = gamxinflu(i,j,9,1) gamxinflu(i,j,10,2)= gamxinflu(i,j,10,1) @@ -1411,16 +1506,16 @@ SUBROUTINE nssl_2mom_init( & ! gamxinflu(i,j,7,1) = gamxinfdp( alp - 1., ratio )/y gamxinflu(i,j,7,1) = (gamma_dpr(alp - 1.) - gamxinfdp( alp - 1., ratio ))/y ! gamxinflu(i,j,8,1) = gamxinfdp( alp - 0.5 + 0.5*bxh, ratio )/y - gamxinflu(i,j,8,1) = (gamma_dpr(alp - 0.5 + 0.5*bxh) - gamxinfdp( alp - 0.5 + 0.5*bxh, ratio ))/y -! gamxinflu(i,j,8,2) = gamxinfdp( alp - 0.5 + 0.5*bxhl, ratio )/y - gamxinflu(i,j,8,2) = (gamma_dpr(alp - 0.5 + 0.5*bxhl) - gamxinfdp( alp - 0.5 + 0.5*bxhl, ratio ))/y + gamxinflu(i,j,8,1) = (gamma_dpr(alp - 0.5 + 0.5*bxh1) - gamxinfdp( alp - 0.5 + 0.5*bxh1, ratio ))/y +! gamxinflu(i,j,8,2) = gamxinfdp( alp - 0.5 + 0.5*bxhl1, ratio )/y + gamxinflu(i,j,8,2) = (gamma_dpr(alp - 0.5 + 0.5*bxhl1) - gamxinfdp( alp - 0.5 + 0.5*bxhl1, ratio ))/y ELSE ! gamxinflu(i,j,7,1) = gamxinfdp( .1, ratio )/y gamxinflu(i,j,7,1) = (gamma_dpr(0.1) - gamxinfdp( 0.1, ratio ) )/y -! gamxinflu(i,j,8,1) = gamxinfdp( 1.1 - 0.5 + 0.5*bxh, ratio )/y -! gamxinflu(i,j,8,2) = gamxinfdp( 1.1 - 0.5 + 0.5*bxhl, ratio )/y - gamxinflu(i,j,8,1) = (gamma_dpr(1.1 - 0.5 + 0.5*bxh) - gamxinfdp( 1.1 - 0.5 + 0.5*bxh, ratio ) )/y - gamxinflu(i,j,8,2) = (gamma_dpr(1.1 - 0.5 + 0.5*bxhl) - gamxinfdp( 1.1 - 0.5 + 0.5*bxhl, ratio ) )/y +! gamxinflu(i,j,8,1) = gamxinfdp( 1.1 - 0.5 + 0.5*bxh1, ratio )/y +! gamxinflu(i,j,8,2) = gamxinfdp( 1.1 - 0.5 + 0.5*bxhl1, ratio )/y + gamxinflu(i,j,8,1) = (gamma_dpr(1.1 - 0.5 + 0.5*bxh1) - gamxinfdp( 1.1 - 0.5 + 0.5*bxh1, ratio ) )/y + gamxinflu(i,j,8,2) = (gamma_dpr(1.1 - 0.5 + 0.5*bxhl1) - gamxinfdp( 1.1 - 0.5 + 0.5*bxhl1, ratio ) )/y ENDIF gamxinflu(i,j,7,2) = gamxinflu(i,j,7,1) @@ -1457,6 +1552,7 @@ SUBROUTINE nssl_2mom_init( & isub = Min( 0, Max(-1,ihvol) ) ! is -1 or 0 lccn = 0 + lccnuf = 0 lccna = 0 lnc = 0 lnr = 0 @@ -1490,21 +1586,29 @@ SUBROUTINE nssl_2mom_init( & lhl = 0 ENDIF ELSEIF ( ipconc == 5 ) THEN - lccn = lhab+1 ! 9 - lnc = lhab+2 ! 10 - lnr = lhab+3 ! 11 - lni = lhab+4 !12 - lns = lhab+5 !13 - lnh = lhab+6 !14 + ltmp = lhab + IF ( iufccn > 0 ) THEN + ltmp = ltmp+1 + lccnuf = ltmp + denscale(lccnuf) = 1 + ENDIF + lccn= ltmp+1 ! 9 + lnc = ltmp+2 ! 10 + lnr = ltmp+3 ! 11 + lni = ltmp+4 !12 + lns = ltmp+5 !13 + lnh = ltmp+6 !14 ltmp = lnh IF ( ihvol >= 0 ) THEN ltmp = ltmp + 1 lnhl = ltmp ! lhab+7 ! 15 ENDIF + IF ( igvol_local >= 1 ) THEN ltmp = ltmp + 1 lvh = ltmp ! lhab+8 + isub ! 16 + isub ! isub adjusts to 15 if hail is off ! ltmp = lvh - denscale(lccn:lvh) = 1 + ENDIF + denscale(lccn:ltmp) = 1 IF ( ihvol >= 1 ) THEN ltmp = ltmp + 1 lvhl = ltmp @@ -1523,24 +1627,30 @@ SUBROUTINE nssl_2mom_init( & ! ltmp = lhlw ENDIF ELSEIF ( ipconc >= 6 ) THEN - errmsg = 'NSSL microphysics has not been compiled for 3-moment. Sorry.' - errflg = 1 - return - lccn = lhab+1 ! 9 - lnc = lhab+2 ! 10 - lnr = lhab+3 ! 11 - lni = lhab+4 !12 - lns = lhab+5 !13 - lnh = lhab+6 !14 + ltmp = lhab + IF ( iufccn > 0 ) THEN + ltmp = ltmp+1 + lccnuf = ltmp + denscale(lccnuf) = 1 + ENDIF + write(0,*) 'nsslwrf: lccnuf = ',lccnuf + lccn= ltmp+1 ! 9 + lnc = ltmp+2 ! 10 + lnr = ltmp+3 ! 11 + lni = ltmp+4 !12 + lns = ltmp+5 !13 + lnh = ltmp+6 !14 ltmp = lnh IF ( lhl > 0 ) THEN ltmp = ltmp + 1 lnhl = ltmp ! lhab+7 ! 15 ENDIF + IF ( igvol_local >= 1 ) THEN ltmp = ltmp + 1 lvh = ltmp ! lhab+8 + isub ! 16 + isub ! isub adjusts to 15 if hail is off + ENDIF ! ltmp = lvh - denscale(lccn:lvh) = 1 + denscale(lccn:ltmp) = 1 IF ( ihvol >= 1 ) THEN ltmp = ltmp + 1 lvhl = ltmp @@ -1825,9 +1935,11 @@ SUBROUTINE nssl_2mom_init( & IF ( lhl .gt. 1 ) ido(lhl) = idohl IF ( irfall .lt. 0 ) irfall = infall + IF ( isfall .lt. 0 ) isfall = infall IF ( lzr > 0 ) irfall = 0 qccn = ccn/rho00 + qccnuf = ccnuf/rho00 IF ( old_cccn > 0.0 ) THEN old_qccn = old_cccn/rho00 ELSE @@ -1981,6 +2093,33 @@ SUBROUTINE nssl_2mom_init( & ENDDO ENDDO + dab0lu(:,:,:,:) = 0.0 + dab1lu(:,:,:,:) = 0.0 + + IF ( ipconc >= 6 ) THEN + DO il = lc,lhab ! collector + DO j = lc,lhab ! collected + IF ( il .ne. j ) THEN + + DO jj = ialpstart,nqiacralpha + alpjj = float(jj)*dqiacralpha + xnujj = (alpjj - 2.)/3. + DO ii = ialpstart,nqiacralpha + alpii = float(ii)*dqiacralpha + xnuii = (alpii - 2.)/3. + + dab0lu(ii,jj,il,j) = delabk(bb(il), bb(j), xnuii, xnujj, xmu(il), xmu(j), 0) + dab1lu(ii,jj,il,j) = delabk(bb(il), bb(j), xnuii, xnujj, xmu(il), xmu(j), 1) + + ENDDO + ENDDO +! write(0,*) 'il, j, dab0, dab1 = ',il, j, dab0(il,j), dab1(il,j) + ENDIF + ENDDO + ENDDO + + ENDIF + gf4br = gamma_sp(4.0+br) gf4ds = gamma_sp(4.0+ds) gf4p5 = gamma_sp(4.0+0.5) @@ -2029,10 +2168,12 @@ END SUBROUTINE nssl_2mom_init !>\ingroup mod_nsslmp !! Driver subroutine that copies state data to local 2D arrays for microphysics calls SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw, chl, & - cn, vhw, vhl, cna, cni, f_cn, f_cna, f_cina, & - zrw, zhw, zhl, & + cn, vhw, vhl, cna, cni, f_cn, f_cna, f_cina, & + cnuf, f_cnuf, & + zrw, zhw, zhl, f_zrw, f_zhw, f_zhl, f_vhw, f_vhl, & qsw, qhw, qhlw, & tt, th, pii, p, w, dn, dz, dtp, itimestep, & + ntmul, ntcnt, lastloop, & RAINNC,RAINNCV, & dx, dy, & axtra, & @@ -2091,7 +2232,8 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw zrw, zhw, zhl, & qsw, qhw, qhlw, & qi,qhl,ccw,crw,cci,csw,chw,chl,vhw,vhl - real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: dbz, vzf, cn, cna, cni + logical, optional, intent(in) :: f_zrw, f_zhw, f_zhl, f_vhw, f_vhl ! not used yet + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: dbz, vzf, cn, cna, cni, cnuf real, dimension(ims:ime, jms:jme), optional, intent(inout):: compdbz real, dimension(ims:ime, jms:jme), optional, intent(inout):: rscghis_2d, & ! 2D accumulation arrays for vertically-integrated charging rate rscghis_2dp, & ! 2D accumulation arrays for vertically-integrated charging rate (positive only) @@ -2102,8 +2244,8 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw scr,scw,sci,scs,sch,schl,sciona,sctot ! space charge real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & induc,noninduc,noninducp,noninducn ! charging rates: inductive, noninductive (all, positive, negative to graupel) - real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(in) :: elecz ! elecsave = Ez - real, dimension(ims:ime, kms:kme, jms:jme,2),optional, intent(inout) :: scion + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(in) :: elecz ! elecsave = Ez + real, dimension(ims:ime, kms:kme, jms:jme,2),optional, intent(inout) :: scion real, dimension(ims:ime, kms:kme, jms:jme), intent(in):: p,w,dz,dn real, dimension(ims:ime, kms:kme, jms:jme), intent(in):: pii @@ -2139,7 +2281,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw real, optional, intent(in) :: dx,dy real, intent(in):: dtp integer, intent(in):: itimestep !, ccntype - logical, optional, intent(in) :: diagflag, f_cna, f_cn, f_cina + integer, intent(in), optional :: ntmul, ntcnt + logical, optional, intent(in) :: lastloop + logical, optional, intent(in) :: diagflag, f_cna, f_cn, f_cina, f_cnuf integer, optional, intent(in) :: ipelectmp, ke_diag ! CCPP error handling @@ -2151,6 +2295,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional,INTENT(INOUT):: qndrop LOGICAL :: flag_qndrop ! wrf-chem LOGICAL :: flag_qnifa , flag_qnwfa + logical :: flag_cnuf = .false. logical :: flag real :: cinchange, t7max,testmax,wmax @@ -2223,6 +2368,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw real :: fach(kts:kte) logical, parameter :: debugdriver = .false. + + integer :: loopcnt, loopmax, outerloopcnt + logical :: lastlooptmp #ifdef MPI @@ -2246,12 +2394,21 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw flag_qndrop = .false. flag_qnifa = .false. flag_qnwfa = .false. + flag_cnuf = .false. IF ( PRESENT ( nssl_progn ) ) flag_qndrop = nssl_progn + IF ( present ( f_cnuf ) ) flag_cnuf = f_cnuf - - + loopmax = 1 + outerloopcnt = 1 + lastlooptmp = .true. + IF ( present( ntmul ) .and. present( ntcnt ) .and. present( lastloop ) ) THEN + loopmax = ntmul + outerloopcnt = ntcnt + lastlooptmp = lastloop + ENDIF + ! --- IF ( present( f_cna ) ) THEN @@ -2365,6 +2522,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ancuten(its:ite,1,kts:kte,:) = 0.0 thproclocal(:,:) = 0.0 + DO jy = jts,jye xfall(:,:,:) = 0.0 @@ -2408,6 +2566,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ELSE an(ix,1,kz,lccn) = cn(ix,kz,jy) ENDIF + IF ( i_uf_or_ccn > 0 .and. lccnuf > 1 ) THEN ! UF ccn are extra regular ccn + an(ix,1,kz,lccn) = an(ix,1,kz,lccn) + cnuf(ix,kz,jy) + ENDIF ELSE IF ( lccna == 0 .and. ( .not. f_cnatmp ) ) THEN an(ix,1,kz,lccn) = qccn - ccw(ix,kz,jy) @@ -2418,6 +2579,14 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDIF ENDIF + IF ( lccnuf > 0 .and. flag_cnuf ) THEN + IF ( i_uf_or_ccn == 0 ) THEN ! UF are UF + an(ix,1,kz,lccnuf) = Max(0.0, cnuf(ix,kz,jy) ) + ELSE ! UF were added to lccn + an(ix,1,kz,lccnuf) = 0.0 + ENDIF + ENDIF + IF ( lccna > 1 ) THEN IF ( present( cna ) .and. f_cnatmp ) THEN an(ix,1,kz,lccna) = cna(ix,kz,jy) @@ -2448,9 +2617,19 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( lvh > 0 ) an(ix,1,kz,lvh) = vhw(ix,kz,jy) IF ( lvhl > 0 .and. present( vhl ) ) an(ix,1,kz,lvhl) = vhl(ix,kz,jy) + IF ( ipconc >= 6 ) THEN + IF ( lzr > 0 ) an(ix,1,kz,lzr) = zrw(ix,kz,jy)*zscale + IF ( lzh > 0 ) an(ix,1,kz,lzh) = zhw(ix,kz,jy)*zscale + IF ( lzhl > 0 ) an(ix,1,kz,lzhl) = zhl(ix,kz,jy)*zscale + ENDIF + ENDDO + ENDDO + + DO kz = kts,kte + DO ix = its,ite IF ( present( tt ) ) THEN @@ -2458,6 +2637,26 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ELSE t0(ix,1,kz) = th(ix,kz,jy)*pii(ix,kz,jy) ! temperature (Kelvin) ENDIF + t00(ix,1,kz) = 380.0/p(ix,kz,jy) + t77(ix,1,kz) = pii(ix,kz,jy) + dbz2d(ix,1,kz) = 0.0 + vzf2d(ix,1,kz) = 0.0 + ENDDO + ENDDO + + DO ix = its,ite + RAINNCV(ix,jy) = 0.0 + IF ( present( GRPLNCV ) ) GRPLNCV(ix,jy) = 0.0 + IF ( present( HAILNCV ) ) HAILNCV(ix,jy) = 0.0 + IF ( present( SNOWNCV ) ) SNOWNCV(ix,jy) = 0.0 + ENDDO + + DO loopcnt = 1,loopmax + + DO kz = kts,kte + DO ix = its,ite + + t1(ix,1,kz) = 0.0 t2(ix,1,kz) = 0.0 t3(ix,1,kz) = 0.0 @@ -2467,14 +2666,11 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw t7(ix,1,kz) = 0.0 t8(ix,1,kz) = 0.0 t9(ix,1,kz) = 0.0 - t00(ix,1,kz) = 380.0/p(ix,kz,jy) - t77(ix,1,kz) = pii(ix,kz,jy) - dbz2d(ix,1,kz) = 0.0 - vzf2d(ix,1,kz) = 0.0 - dn1(ix,1,kz) = dn(ix,kz,jy) pn(ix,1,kz) = p(ix,kz,jy) wn(ix,1,kz) = w(ix,kz,jy) +! calculate dn1 in case we are substepping: rho = con_eps*prsl/(con_rd*tgrs*(qv_mp+con_eps)) + dn1(ix,1,kz) = rdorv*pn(ix,1,kz)/(rd*t0(ix,1,kz)*(an(ix,1,kz,lv) + rdorv)) ! wmax = Max(wmax,wn(ix,1,kz)) dz2d(ix,1,kz) = dz(ix,kz,jy) dz2dinv(ix,1,kz) = 1./dz(ix,kz,jy) @@ -2544,19 +2740,19 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ELSEIF ( icenucopt == 4 ) THEN ! DeMott 2010 - IF ( t0(ix,jy,kz) < 268.16 .and. t0(ix,jy,kz) > 223.15 .and. ssival > 1.001 ) THEN ! + IF ( t0(ix,1,kz) < 268.16 .and. t0(ix,1,kz) > 223.15 .and. ssival > 1.001 ) THEN ! ! a = 0.0000594, b = 3.33, c = 0.0264, d = 0.0033, ! nint = a*(-Tc)**b * naer**(c*(-Tc) + d) ! nint has units of per (standard) liter, so mult by 1.e3 and scale by dn/rho00 ! naer needs units of cm**-3, so mult by 1.e-6 - ! dp1 = 1.e3*0.0000594*(273.16 - t0(ix,jy,kz))**3.33 * (1.e-6*cin*dn(ix,jy,kz))**(0.0264*(273.16 - t0(ix,jy,kz)) + 0.0033) - dp1 = 1.e3*dn(ix,jy,kz)/rho00*0.0000594*(273.16 - t0(ix,jy,kz))**3.33 * (1.e-6*naer)**(0.0264*(273.16 - t0(ix,jy,kz)) + 0.0033) - t7(ix,jy,kz) = Min(dp1, 1.0d30) + ! dp1 = 1.e3*0.0000594*(273.16 - t0(ix,1,kz))**3.33 * (1.e-6*cin*dn(ix,1,kz))**(0.0264*(273.16 - t0(ix,1,kz)) + 0.0033) + dp1 = 1.e3*dn1(ix,1,kz)/rho00*0.0000594*(273.16 - t0(ix,1,kz))**3.33 * (1.e-6*naer)**(0.0264*(273.16 - t0(ix,1,kz)) + 0.0033) + t7(ix,1,kz) = Min(dp1, 1.0d30) ELSE - t7(ix,jy,kz) = 0.0 + ! t7(ix,1,kz) = 0.0 ENDIF ENDIF ! icenucopt @@ -2583,25 +2779,29 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! transform from number mixing ratios to number conc. + IF ( loopcnt == 1 ) THEN DO il = lnb,na IF ( denscale(il) == 1 ) THEN DO kz = kts,kte DO ix = its,ite - an(ix,1,kz,il) = an(ix,1,kz,il)*dn(ix,kz,jy) + an(ix,1,kz,il) = an(ix,1,kz,il)*dn1(ix,1,kz) ! dn(ix,kz,jy) ENDDO ENDDO ENDIF ENDDO ! il + ENDIF + ! sedimentation xfall(:,:,:) = 0.0 - IF ( .true. ) THEN + +! IF ( .true. ) THEN ! #ifndef CM1 ! for real cases when hydrometeor mixing ratios have been initialized without concentrations - IF ( itimestep == 1 .and. ipconc > 0 ) THEN + IF ( itimestep == 1 .and. ipconc > 0 .and. loopcnt == 1 ) THEN call calcnfromq(nx,ny,nz,an,na,nor,nor,dn1) ENDIF ! IF ( itimestep == 3 .and. ipconc > 0 ) THEN @@ -2611,9 +2811,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( present(cu_used) .and. & ( present( qrcuten ) .or. present( qscuten ) .or. & - present( qicuten ) .or. present( qccuten ) ) ) THEN + present( qicuten ) .or. present( qccuten ) ) ) THEN !{ - IF ( cu_used == 1 ) THEN + IF ( cu_used == 1 ) THEN !{ DO kz = kts,kte DO ix = its,ite @@ -2627,10 +2827,22 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw call calcnfromcuten(nx,ny,nz,ancuten,an,na,nor,nor,dn1) + DO kz = kts,kte + DO ix = its,ite + + + IF ( ipconc >= 6 ) THEN +! IF ( lzr > 0 ) an(ix,1,kz,lzr) = an(ix,1,kz,lzr) + ancuten(ix,1,kz,lzr) + ENDIF + + ENDDO + ENDDO - ENDIF + ENDIF !} - ENDIF + ENDIF !} + + call sediment1d(dtp,nx,ny,nz,an,na,nor,nor,xfall,dn1,dz2d,dz2dinv, & @@ -2644,10 +2856,12 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw DO ix = its,ite IF ( lhl > 1 ) THEN - RAINNCV(ix,jy) = dtp*dn1(ix,1,1)*(xfall(ix,1,lr) + xfall(ix,1,ls)*1000./xdn0(lr) + & + RAINNCV(ix,jy) = RAINNCV(ix,jy) + & + dtp*dn1(ix,1,1)*(xfall(ix,1,lr) + xfall(ix,1,ls)*1000./xdn0(lr) + & & xfall(ix,1,lh)*1000./xdn0(lr) + xfall(ix,1,lhl)*1000./xdn0(lr) ) ELSE - RAINNCV(ix,jy) = dtp*dn1(ix,1,1)*(xfall(ix,1,lr) + xfall(ix,1,ls)*1000./xdn0(lr) + & + RAINNCV(ix,jy) = RAINNCV(ix,jy) + & + dtp*dn1(ix,1,1)*(xfall(ix,1,lr) + xfall(ix,1,ls)*1000./xdn0(lr) + & & xfall(ix,1,lh)*1000./xdn0(lr) ) ENDIF IF ( present ( rainncw2 ) ) THEN ! rain only @@ -2662,17 +2876,19 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw & xfall(ix,1,lh)*1000./xdn0(lr) ) ENDIF ENDIF - IF ( present( SNOWNCV ) ) SNOWNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,ls)*1000./xdn0(lr) + IF ( present( SNOWNCV ) ) SNOWNCV(ix,jy) = SNOWNCV(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,ls)*1000./xdn0(lr) IF ( present( GRPLNCV ) ) THEN IF ( lhl > 1 .and. .not. present( HAILNC) ) THEN ! if no separate hail accum, then add to graupel - GRPLNCV(ix,jy) = dtp*dn1(ix,1,1)*(xfall(ix,1,lh) + xfall(ix,1,lhl)) *1000./xdn0(lr) + GRPLNCV(ix,jy) = GRPLNCV(ix,jy) + dtp*dn1(ix,1,1)*(xfall(ix,1,lh) + xfall(ix,1,lhl)) *1000./xdn0(lr) ELSE - GRPLNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lh)*1000./xdn0(lr) + GRPLNCV(ix,jy) = GRPLNCV(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,lh)*1000./xdn0(lr) ENDIF ENDIF - RAINNC(ix,jy) = RAINNC(ix,jy) + RAINNCV(ix,jy) + IF ( loopcnt == loopmax ) RAINNC(ix,jy) = RAINNC(ix,jy) + RAINNCV(ix,jy) - IF ( present (SNOWNC) .and. present (SNOWNCV) ) SNOWNC(ix,jy) = SNOWNC(ix,jy) + SNOWNCV(ix,jy) + IF ( present (SNOWNC) .and. present (SNOWNCV) .and. loopcnt == loopmax ) THEN + SNOWNC(ix,jy) = SNOWNC(ix,jy) + SNOWNCV(ix,jy) + ENDIF IF ( lhl > 1 ) THEN !#ifdef CM1 ! IF ( .true. ) THEN @@ -2680,13 +2896,15 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( present( HAILNC ) ) THEN !#endif HAILNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lhl)*1000./xdn0(lr) - HAILNC(ix,jy) = HAILNC(ix,jy) + HAILNCV(ix,jy) + IF ( loopcnt == loopmax ) HAILNC(ix,jy) = HAILNC(ix,jy) + HAILNCV(ix,jy) ! ELSEIF ( present( GRPLNCV ) ) THEN ! if no separate hail accum, then add to graupel ! GRPLNCV(ix,jy) = GRPLNCV(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,lhl)*1000./xdn0(lr) ENDIF ENDIF - IF ( present( GRPLNCV ) ) GRPLNC(ix,jy) = GRPLNC(ix,jy) + GRPLNCV(ix,jy) - IF ( present( SR ) .and. present (SNOWNCV) .and. present(GRPLNCV) ) THEN + IF ( present( GRPLNCV ) .and. loopcnt == loopmax ) THEN + GRPLNC(ix,jy) = GRPLNC(ix,jy) + GRPLNCV(ix,jy) + ENDIF + IF ( present( SR ) .and. present (SNOWNCV) .and. present(GRPLNCV) .and. loopcnt == loopmax ) THEN IF ( present( HAILNC ) ) THEN SR(ix,jy) = (SNOWNCV(ix,jy)+HAILNCV(ix,jy)+GRPLNCV(ix,jy))/(RAINNCV(ix,jy)+1.e-12) ELSE @@ -2695,7 +2913,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDIF ENDDO - ENDIF ! .false. +! ENDIF ! .false. IF ( isedonly /= 1 ) THEN ! call nssl_2mom_gs: main gather-scatter routine to calculate microphysics @@ -2726,6 +2944,13 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw +! recalculate dn1 after temperature changes: rho = con_eps*prsl/(con_rd*tgrs*(qv_mp+con_eps)) + DO kz = kts,kte + DO ix = its,ite + dn1(ix,1,kz) = rdorv*pn(ix,1,kz)/(rd*t0(ix,1,kz)*(an(ix,1,kz,lv) + rdorv)) + ENDDO + ENDDO + ENDIF ! isedonly /= 1 @@ -2741,11 +2966,21 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw & ,axtra2d, makediag & & ,ssat,t00,t77,flag_qndrop) +! recalculate dn1 after temperature changes + DO kz = kts,kte + DO ix = its,ite + dn1(ix,1,kz) = rdorv*pn(ix,1,kz)/(rd*t0(ix,1,kz)*(an(ix,1,kz,lv) + rdorv)) + ENDDO + ENDDO + ENDIF + + ENDDO ! loopcnt=1,loopmax + IF ( present( pcc2 ) .and. makediag ) THEN DO kz = kts,kte DO ix = its,ite @@ -2759,7 +2994,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! compute diagnostic S-band reflectivity if needed - IF ( present( dbz ) .and. makediag ) THEN + IF ( present( dbz ) .and. makediag .and. lastlooptmp ) THEN ! calc dbz IF ( .true. ) THEN @@ -2797,7 +3032,8 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! Following Greg Thompson, calculation for effective radii. Used by RRTMG LW/SW schemes if enabled in module_physics_init.F IF ( present( has_reqc ).and. present( has_reqi ) .and. present( has_reqs ) .and. & - present( re_cloud ).and. present( re_ice ) .and. present( re_snow ) ) THEN + present( re_cloud ).and. present( re_ice ) .and. present( re_snow ) .and. & + lastlooptmp) THEN IF ( has_reqc.ne.0 .or. has_reqi.ne.0 .or. has_reqs.ne.0) THEN DO kz = kts,kte DO ix = its,ite @@ -2821,10 +3057,10 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw DO kz = kts,kte DO ix = its,ite re_cloud(ix,kz,jy) = MAX(2.51E-6, MIN(t1(ix,1,kz), 50.E-6)) - re_ice(ix,kz,jy) = MAX(10.01E-6, MIN(t2(ix,1,kz), 200.E-6)) + re_ice(ix,kz,jy) = MAX(10.01E-6, MIN(t2(ix,1,kz), 125.E-6)) re_snow(ix,kz,jy) = MAX(25.E-6, MIN(t3(ix,1,kz), 999.E-6)) ! check for case where snow needs to be treated as cloud ice (for rrtmg radiation) - IF ( .not. present(qi) ) re_ice(ix,kz,jy) = MAX(10.E-6, MIN(t3(ix,1,kz), 200.E-6)) + IF ( .not. present(qi) ) re_ice(ix,kz,jy) = MAX(10.E-6, MIN(t3(ix,1,kz), 125.E-6)) ENDDO ENDDO @@ -2849,7 +3085,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( denscale(il) == 1 ) THEN DO kz = kts,kte DO ix = its,ite - an(ix,1,kz,il) = an(ix,1,kz,il)/dn(ix,kz,jy) + an(ix,1,kz,il) = an(ix,1,kz,il)/dn1(ix,1,kz) ! dn(ix,kz,jy) ENDDO ENDDO ENDIF @@ -2896,6 +3132,21 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDIF ENDIF + IF ( lccnuf > 0 .and. flag_cnuf ) THEN + IF ( i_uf_or_ccn > 0 ) THEN ! UF are ccn and lccnuf is zero, so put cnuf into lccnuf to do decay + an(ix,1,kz,lccnuf) = Max(0.0, cnuf(ix,kz,jy) ) + ENDIF + IF ( decayufccn ) THEN + IF ( an(ix,1,kz,lccnuf) > ufbackground ) THEN + an(ix,1,kz,lccnuf) = an(ix,1,kz,lccnuf) - (an(ix,1,kz,lccnuf) - & + ufbackground)*(1.0 - exp(-dtp/ufccntimeconst)) + ENDIF + ENDIF + cnuf(ix,kz,jy) = an(ix,1,kz,lccnuf) + ENDIF + + + IF ( ipconc >= 5 ) THEN ccw(ix,kz,jy) = an(ix,1,kz,lnc) @@ -2906,6 +3157,11 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( lhl > 1 ) chl(ix,kz,jy) = an(ix,1,kz,lnhl) ENDIF + IF ( ipconc >= 6 ) THEN + IF ( lzr > 0 ) zrw(ix,kz,jy) = an(ix,1,kz,lzr) *zscaleinv + IF ( lzh > 0 ) zhw(ix,kz,jy) = an(ix,1,kz,lzh) *zscaleinv + IF ( lzhl > 0 ) zhl(ix,kz,jy) = an(ix,1,kz,lzhl)*zscaleinv + ENDIF @@ -2914,6 +3170,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw #if ( WRF_CHEM == 1 ) IF ( has_wetscav ) THEN + IF ( loopmax > 1 ) THEN + ! wrferror not supported + ENDIF IF ( PRESENT( rainprod ) ) rainprod(ix,kz,jy) = rainprod2d(ix,kz) IF ( PRESENT( evapprod ) ) evapprod(ix,kz,jy) = evapprod2d(ix,kz) ENDIF @@ -2923,6 +3182,8 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDDO ENDDO ! jy + + @@ -3217,7 +3478,7 @@ END FUNCTION GAML02 ! ********************************************************** !>\ingroup mod_nsslmp !! Function calculates fraction of drops larger than 300 microns ( imurain == 3 ) - real FUNCTION GAML02d300(x) + real FUNCTION GAML02d300(x) implicit none integer ig, i, ii, n, np real x @@ -3825,7 +4086,8 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & IF ( il >= lr .and. ( infall .eq. 3 .or. infall .eq. 4 ) .and. ln(il) > 0 ) THEN - IF ( (il .eq. lr .and. irfall .eq. infall .and. lzr < 1) .or. (il .ge. lh .and. lz(il) .lt. 1 ) ) THEN + IF ( (il .eq. lr .and. irfall .eq. infall .and. lzr < 1) .or. & + (il .ge. lh .and. lz(il) .lt. 1 ) .or. (il == ls .and. isfall == infall ) ) THEN call calczgr1d(nx,ny,nz,nor,na,an,ixe,kze, & & z,db1,jgs,ipconc, dnu(il), il, ln(il), qxmin(il), xvmn(il), xvmx(il), lvol(il), xdn0(il), ix ) ENDIF @@ -3850,6 +4112,14 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ENDIF ENDIF +! reflectivity + + IF ( ipconc .ge. 6 ) THEN + IF ( lz(il) .gt. 1 ) THEN + call fallout1d(nx,ny,nz,nor,na,dtptmp,dtfrac,jgs,xvt(1,1,3,il), & + & an,db1,lz(il),0,xfall,dtz1,ix) + ENDIF + ENDIF if (ndebug .gt. 0 ) write(0,*) 'dbg = 3d' @@ -3863,9 +4133,11 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ! to put a lower bound on number conc. ! - IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. ( il .eq. lh .or. il .eq. lhl .or. & + IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. ( (il == ls .and. isfall .eq. infall ) & + & .or. il .eq. lh .or. il .eq. lhl .or. il == lf .or. & & ( il .eq. lr .and. irfall .eq. infall) ) ) THEN + ! set up for method I+II DO kz = kzb,kze ! DO ix = ixb,ixe tmpn2(ix,jy,kz) = z(ix,kz,il) @@ -3878,7 +4150,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ENDDO ELSE - + ! set up for method II only DO kz = kzb,kze ! DO ix = ixb,ixe tmpn(ix,jy,kz) = an(ix,jy,kz,ln(il)) @@ -3907,7 +4179,8 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & xfall0(:,jgs) = 0.0 IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. & - & ( il .ge. lh .or. (il .eq. lr .and. irfall .eq. infall) ) ) THEN + & ( il .ge. lh .or. (il .eq. lr .and. irfall .eq. infall) & + .or. (il .eq. ls .and. isfall .eq. infall) ) ) THEN call fallout1d(nx,ny,nz,nor,1,dtptmp,dtfrac,jgs,xvt(1,1,3,il), & & tmpn2,db1,1,0,xfall0,dtz1,ix) call fallout1d(nx,ny,nz,nor,1,dtptmp,dtfrac,jgs,xvt(1,1,1,il), & @@ -3918,12 +4191,12 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ENDIF IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. ( (il .eq. lr .and. irfall .eq. infall) & - & .or. il .ge. lh ) ) THEN + & .or. il .ge. lh .or. (il == ls .and. isfall .eq. infall ) ) ) THEN ! "Method I" - dbz correction call calcnfromz1d(nx,ny,nz,nor,na,an,tmpn2,ixe,kze, & & z,db1,jgs,ipconc, dnu(il), il, ln(il), qxmin(il), xvmn(il), xvmx(il),tmpn, & - & lvol(il), rho_qh, infall, ix) + & lvol(il), xdn0(il), infall, ix) ELSEIF ( infall .eq. 5 .and. il .ge. lh .or. ( il == lr .and. irfall == 5 ) ) THEN @@ -3934,7 +4207,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ! ENDDO ENDDO - ELSEIF ( .not. (il .eq. lr .and. irfall .eq. 0) ) THEN + ELSEIF ( .not. (il .eq. lr .and. irfall .eq. 0) .and. .not. (il .eq. ls .and. isfall .eq. 0) ) THEN ! "Method II" M-wgt N-fallout correction DO kz = kzb,kze @@ -4120,13 +4393,14 @@ subroutine calczgr1d(nx,ny,nz,nor,na,a,ixe,kze, & integer ix,jy,kz - real vr,qr,nrx,rd,xv,g1,zx,chw,xdn + real vr,qr,nrx,rd,xv,g1,zx,chw,xdn,ynu jy = jgs ix = ixcol - IF ( l .eq. lh .or. l .eq. lhl .or. ( l .eq. lr .and. imurain == 1 ) ) THEN + IF ( l .eq. lh .or. l .eq. lhl .or. ( l .eq. lr .and. imurain == 1 ) & + .or. ( l .eq. ls .and. imusnow == 1 ) ) THEN DO kz = 1,kze @@ -4176,16 +4450,19 @@ subroutine calczgr1d(nx,ny,nz,nor,na,a,ixe,kze, & ENDDO - ELSEIF ( l .eq. lr .and. imurain == 3) THEN + ELSEIF ( (l == ls .and. imusnow == 3) .or. ( l .eq. lr .and. imurain == 3 ) ) THEN - xdn = 1000. + xdn = rho_qx ! 1000. + IF ( l == ls ) ynu = snu + IF ( l == lr ) ynu = rnu DO kz = 1,kze + IF ( a(ix,jy,kz,l) .gt. qmin .and. a(ix,jy,kz,ln) .gt. 1.e-15 ) THEN vr = db(ix,kz)*a(ix,jy,kz,l)/(xdn*a(ix,jy,kz,ln)) -! z(ix,kz,l) = 3.6e18*(rnu+2.0)*a(ix,jy,kz,ln)*vr**2/(rnu+1.0) - z(ix,kz,l) = 3.6*(rnu+2.0)*a(ix,jy,kz,ln)*vr**2/(rnu+1.0) +! z(ix,kz,l) = 3.6e18*(ynu+2.0)*a(ix,jy,kz,ln)*vr**2/(ynu+1.0) + z(ix,kz,l) = 3.6*(ynu+2.0)*a(ix,jy,kz,ln)*vr**2/(ynu+1.0) ! qr = a(ix,jy,kz,lr) ! nrx = a(ix,jy,kz,lnr) @@ -4590,6 +4867,9 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & an(ix,jy,kz,lnr) = nrx ! *dninv ! convert to number mixing ratio + IF ( lzr > 1 ) THEN ! set reflectivity moment + an(ix,jy,kz,lzr) = 36.*g1r*dn(ix,kz)**2*q**2/(pi**2*xdnr**2*nrx) ! *dninv + ENDIF ELSEIF ( an(ix,jy,kz,lr) <= qxmin(lr) .or. & ( an(ix,jy,kz,lnr) <= cxmin .and. an(ix,jy,kz,lr) <= qxmin_init(lr)) ) THEN an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lr) @@ -4651,6 +4931,9 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & an(ix,jy,kz,lvh) = 0.0 ENDIF + IF ( lzh > 1 ) THEN ! set reflectivity moment + an(ix,jy,kz,lzh) = 36.*g1h*dn(ix,kz)**2*q**2/(pi**2*xdnh**2*nrx) ! *dninv + ENDIF ELSEIF ( an(ix,jy,kz,lh) <= qxmin(lh) .or. & ( an(ix,jy,kz,lnh) <= cxmin .and. an(ix,jy,kz,lh) <= qxmin_init(lh)) ) THEN @@ -4680,6 +4963,9 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & an(ix,jy,kz,lnhl) = nrx ! *dninv ! convert to number mixing ratio + IF ( lzhl > 1 ) THEN ! set reflectivity moment + an(ix,jy,kz,lzhl) = 36.*g1hl*dn(ix,kz)**2*q**2/(pi**2*xdnhl**2*nrx) ! *dninv + ENDIF ELSEIF ( an(ix,jy,kz,lhl) <= qxmin(lhl) .or. & ( an(ix,jy,kz,lnhl) <= cxmin .and. an(ix,jy,kz,lhl) <= qxmin_init(lhl)) ) THEN @@ -4859,6 +5145,9 @@ subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn) anold(ix,jy,kz,lnr) = anold(ix,jy,kz,lnr) + an(ix,jy,kz,lr)/xmass ENDIF + IF ( lzr > 1 ) THEN ! set reflectivity moment + an(ix,jy,kz,lzr) = 36.*g1r*dn(ix,kz)**2*q**2/(pi**2*xdnr**2*nrx) ! *dninv + ENDIF ENDIF ENDIF @@ -4909,6 +5198,9 @@ subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn) ! ! an(ix,jy,kz,lnh) = nrx ! *dninv ! convert to number mixing ratio ! +! IF ( lzh > 1 ) THEN ! set reflectivity moment +! an(ix,jy,kz,lzh) = 36.*g1h*dn(ix,kz)**2*q**2/(pi**2*xdnh**2*nrx) ! *dninv +! ENDIF ! ENDIF ! ENDIF ! @@ -4932,6 +5224,9 @@ subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn) ! ! an(ix,jy,kz,lnhl) = nrx ! *dninv ! convert to number mixing ratio ! +! IF ( lzhl > 1 ) THEN ! set reflectivity moment +! an(ix,jy,kz,lzhl) = 36.*g1hl*dn(ix,kz)**2*q**2/(pi**2*xdnhl**2*nrx) ! *dninv +! ENDIF ! ENDIF ! ENDIF @@ -6490,6 +6785,9 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ELSEIF ( icdxhl .eq. 6 ) THEN ! Milbrandt and Morrison (2013) aax = axx(mgs,lhl) bbx = bxx(mgs,lhl) + ELSEIF ( icdxhl <= 0 ) THEN ! + aax = ax(lhl) + bbx = bx(lhl) ENDIF ENDIF ! } @@ -6798,7 +7096,11 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & real vtmax real xvbarmax - + + real, parameter :: c1r=19.0, c2r=0.6, c3r=1.8, c4r=17.0 ! rain + real, parameter :: c1h=5.5, c2h=0.7, c3h=4.5, c4h=8.5 ! Graupel + real, parameter :: c1hl=3.7, c2hl=0.3, c3hl=9.0, c4hl=6.5, c5hl=1.0, c6hl=6.5 ! Hail + integer l1, l2 double precision :: dpt1, dpt2 @@ -7074,83 +7376,564 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ELSEIF ( imurain == 3 ) THEN alpha(:,lr) = xnu(lr) ENDIF - - - + IF ( ipconc == 5 .and. imydiagalpha > 0 ) THEN + DO mgs = 1,ngscnt + IF ( qx(mgs,lr) .gt. qxmin(lr) .and. cx(mgs,lr) > cxmin ) THEN + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) ! + xdia(mgs,lr,3) = (xv(mgs,lr)*6.0*cwc1)**(1./3.) + alpha(mgs,lr) = Min(alphamax, c1r*tanh(c2r*(xdia(mgs,lr,3)*1000. - c3r)) + c4r) + ENDIF + IF ( qx(mgs,lh) .gt. qxmin(lh) .and. cx(mgs,lh) > cxmin ) THEN + xv(mgs,lh) = rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) ! + xdia(mgs,lh,3) = (xv(mgs,lh)*6.*piinv)**(1./3.) ! mwfac*xdia(mgs,lh,1) ! (xv(mgs,lh)*cwc0*6.0)**(1./3.) + alpha(mgs,lh) = Min(alphamax, c1h*tanh(c2h*(xdia(mgs,lh,3)*1000. - c3h)) + c4h) + ENDIF +! alpha(:,lr) = 0. ! 10. +! alpha(:,lh) = 0. ! 10. + IF ( lhl > 0 ) THEN + IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. cx(mgs,lhl) > cxmin ) THEN + xv(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/(xdn(mgs,lhl)*cx(mgs,lhl)) ! + xdia(mgs,lhl,3) = (xv(mgs,lhl)*6.*piinv)**(1./3.) + IF ( xdia(mgs,lhl,3) < 0.008 ) THEN + alpha(mgs,lhl) = Min(alphamax, c1hl*tanh(c2hl*(xdia(mgs,lhl,3)*1000. - c3hl)) + c4hl) + ELSE + alpha(mgs,lhl) = Min(alphamax, c5hl*xdia(mgs,lhl,3)*1000. + c6hl) + ENDIF + ENDIF + ENDIF + ENDDO + ENDIF ! -! Set density -! - if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: call setvtz' +! Set 6th moments ! + IF ( ipconc .ge. 6 .or. lzr > 1) THEN - call setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & - & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx,cdxgs, & - & ipconc,ndebugzf,ngs,nz,kgs,fadvisc, & - & cwmasn,cwmasx,cwradn,cnina,cimn,cimx, & - & itype1,itype2,temcg,infdo,alpha,ildo,axx,bxx) -! & itype1,itype2,temcg,infdo,alpha,ildo,axh,bxh,axhl,bxhl) - - - -! -! put fall speeds into the x-z arrays -! - DO il = l1,l2 - do mgs = 1,ngscnt - - vtmax = 150.0 - - - IF ( vtxbar(mgs,il,2) .gt. vtxbar(mgs,il,1) .or. & - & ( vtxbar(mgs,il,1) .gt. vtxbar(mgs,il,3) .and. vtxbar(mgs,il,3) > 0.0) ) THEN - - - - vtxbar(mgs,il,1) = Max( vtxbar(mgs,il,1), vtxbar(mgs,il,2) ) - vtxbar(mgs,il,3) = Max( vtxbar(mgs,il,3), vtxbar(mgs,il,1) ) + zx(:,:) = 0.0 + +! DO il = lr,lhab + DO il = l1,l2 + + IF ( lz(il) .ge. 1 ) THEN + + DO mgs = 1,ngscnt + zx(mgs,il) = Max(an(igs(mgs),jy,kgs(mgs),lz(il)), 0.0) + ENDDO - ENDIF - - - IF ( vtxbar(mgs,il,1) .gt. vtmax .or. vtxbar(mgs,il,2) .gt. vtmax .or. & - & vtxbar(mgs,il,3) .gt. vtmax ) THEN - - vtxbar(mgs,il,1) = Min(vtmax,vtxbar(mgs,il,1) ) - vtxbar(mgs,il,2) = Min(vtmax,vtxbar(mgs,il,2) ) - vtxbar(mgs,il,3) = Min(vtmax,vtxbar(mgs,il,3) ) -! call commasmpi_abort() - ENDIF + ENDIF + + ENDDO + + ENDIF + - xvt(kgs(mgs),igs(mgs),1,il) = vtxbar(mgs,il,1) - xvt(kgs(mgs),igs(mgs),2,il) = vtxbar(mgs,il,2) - IF ( infdo .ge. 2 ) THEN - xvt(kgs(mgs),igs(mgs),3,il) = vtxbar(mgs,il,3) - ELSE - xvt(kgs(mgs),igs(mgs),3,il) = 0.0 - ENDIF -! xvt(kgs(mgs),igs(mgs),2,il) = xvt(kgs(mgs),igs(mgs),1,il) + +! Find shape parameter rain - enddo - ENDDO + IF ( lz(lr) > 1 .and. (ildo == 0 .or. ildo == lr ) .and. imurain == 3 ) THEN ! { RAIN SHAPE PARAM + il = lr + DO mgs = 1,ngscnt + + IF ( iresetmoments == 1 .or. iresetmoments == il ) THEN +! IF ( .false. .and. zx(mgs,lr) <= zxmin ) THEN + IF ( zx(mgs,lr) <= zxmin ) THEN + qx(mgs,lr) = 0.0 + cx(mgs,lr) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),lr) + an(igs(mgs),jgs,kgs(mgs),lr) = qx(mgs,lr) + an(igs(mgs),jgs,kgs(mgs),ln(lr)) = cx(mgs,lr) +! ELSEIF ( zx(mgs,lr) <= 0.0 .and. cx(mgs,lr) > 0.0 .and. qx(mgs,il) .gt. qxmin(il)) THEN +! write(91,*) 'ZF: overdepletion of Zr: z,c,q = ',zx(mgs,il),cx(mgs,il),qx(mgs,il) + ELSEIF ( cx(mgs,lr) <= cxmin ) THEN + zx(mgs,lr) = 0.0 + qx(mgs,lr) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),lr) + an(igs(mgs),jgs,kgs(mgs),lr) = qx(mgs,lr) + an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr) + ENDIF + ENDIF + + + + IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN - if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: COPIED FALL SPEEDS' + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-11,cx(mgs,lr))) + IF ( xv(mgs,lr) .gt. xvmx(lr) ) THEN +! tmp = cx(mgs,lr) +! xv(mgs,lr) = xvmx(lr) +! cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmx(lr)*xdn(mgs,lr)) +! an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) +! IF ( tmp < cx(mgs,il) ) THEN ! breakup +! g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) +!! zx(mgs,lr) = zx(mgs,lr) + g1*(rho0(mgs)/(1000.))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) ) +!! an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr) +! ENDIF + ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN + xv(mgs,lr) = xvmn(lr) + cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr)) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ENDIF + IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN +! have mass and reflectivity but no concentration, so set concentration, using default alpha + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + z = zx(mgs,il) + qr = qx(mgs,il) + + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*1000.*1000) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + + ELSEIF ( zx(mgs,il) <= 0.0 .and. cx(mgs,il) > 0.0 ) THEN +! have mass and concentration but no reflectivity, so set reflectivity, using default alpha + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + chw = cx(mgs,il) + qr = qx(mgs,il) + +! xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(1000.*Max(1.0e-9,cx(mgs,lr))) +! vr = xv(mgs,lr) + +! z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2) +! zx(mgs,il) = z +! an(igs(mgs),jy,kgs(mgs),lz(il)) = z + + zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(xdn(mgs,lr)**2*chw) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + ELSEIF ( zx(mgs,il) <= 0.0 .and. cx(mgs,il) <= 0.0 ) THEN +! How did this happen? + ! set values according to dBZ of -10, or Z = 0.1 +! write(91,*) 'alpha = ',alpha(mgs,il) + IF ( qx(mgs,il) < 1.e-8 ) THEN + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + ELSE +! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 + zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2 + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + z = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*1000.*1000) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ENDIF + ENDIF + + IF ( zx(mgs,lr) > 0.0 ) THEN + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(1000.*Max(1.0e-9,cx(mgs,lr))) + vr = xv(mgs,lr) +! z = 36.*(alpha(kz)+2.0)*a(ix,jy,kz,lnr)*vr**2/((alpha(kz)+1.0)*pi**2) + qr = qx(mgs,lr) + nrx = cx(mgs,lr) + z = zx(mgs,lr) + +! xv = (db(1,kz)*a(1,1,kz,lr))**2/(a(1,1,kz,lnr)) +! rd = z*(pi/6.*1000.)**2/xv + +! determine shape parameter alpha by iteration + IF ( z .gt. 0.0 ) THEN +! alpha(mgs,lr) = 3. + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. + DO i = 1,20 +! IF ( 100.*Abs(alp - alpha(mgs,lr))/Abs(alpha(mgs,lr)) .lt. 1. ) EXIT + IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT + alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) ) + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. +! write(0,*) 'i,alp = ',i,alp + alp = Max( rnumin, Min( rnumax, alp ) ) + ENDDO +! write(0,*) 'kz, alp, alpha(kz) = ',kz,alp,alpha(mgs,lr),qr*1000,z*1.e18,vr,nrx + + +! check for artificial breakup (rain larger than allowed max size) + IF ( xv(mgs,il) .gt. xvmx(il) ) THEN + tmp = cx(mgs,il) + xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) ) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) + IF ( tmp < cx(mgs,il) ) THEN ! breakup + + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) ) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + vr = xv(mgs,lr) + qr = qx(mgs,lr) + nrx = cx(mgs,lr) + z = zx(mgs,lr) + + +! determine shape parameter alpha by iteration + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. + DO i = 1,20 + IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT + alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) ) + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. + alp = Max( rnumin, Min( rnumax, alp ) ) + ENDDO + + ENDIF + ENDIF - 9998 continue +! +! Check whether the shape parameter is at or less than the minimum, and if it is, reset the +! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N) +! +! IF ( alpha(mgs,il) <= rnumin .or. alp == rnumin .or. alp == rnumax ) THEN + IF ( .true. .and. (alpha(mgs,il) <= rnumin .or. alp == rnumin .or. alp == rnumax) ) THEN - if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: DONE WITH LOOP' + IF ( rescale_high_alpha .and. alp >= rnumax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(1./(xdn(mgs,il)))**2 + an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il) + + ELSEIF ( rescale_low_alphar .and. alp <= rnumin ) THEN - if ( kz .gt. nz-1 ) then - go to 1200 + z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2) + zx(mgs,il) = z + an(igs(mgs),jy,kgs(mgs),lz(il)) = z + + ENDIF + ENDIF + + ENDIF + ENDIF + + ELSE + + zx(mgs,lr) = 0.0 + cx(mgs,lr) = 0.0 + an(igs(mgs),jgs,kgs(mgs),ln(lr)) = cx(mgs,lr) + an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr) + + ENDIF + + ENDDO + ENDIF ! } + + + IF ( ipconc .ge. 6 ) THEN + +! Find shape parameters for graupel,hail + + DO il = lr,lhab + + IF ( lz(il) .gt. 1 .and. (ildo == 0 .or. ildo == il ) .and. ( .not. ( il == lr .and. imurain == 3 )) ) THEN + + DO mgs = 1,ngscnt + + IF ( iresetmoments == 1 .or. iresetmoments == il .or. iresetmoments == -1 ) THEN + IF ( zx(mgs,il) <= zxmin ) THEN ! .and. qx(mgs,il) > 0.05e-3 ) THEN + qx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ELSEIF ( iresetmoments == -1 .and. qx(mgs,il) < qxmin(il) ) THEN + zx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + ELSEIF ( cx(mgs,il) <= cxmin .and. iresetmoments /= -1 ) THEN ! .and. qx(mgs,il) > 0.05e-3 ) THEN +!! write(91,*) 'cx=0; qx,zx = ',1000.*qx(mgs,il),1.e18*zx(mgs,il) + zx(mgs,il) = 0.0 + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + ENDIF + ENDIF + + IF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= cxmin ) THEN + zx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + ENDIF + + IF ( qx(mgs,il) .gt. qxmin(il) ) THEN + + xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(1.0e-9,cx(mgs,il))) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + + IF ( xv(mgs,il) .lt. xvmn(il) ) THEN +! tmp = cx(mgs,il) + xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) ) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) +! IF ( tmp < cx(mgs,il) ) THEN ! breakup +! g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & +! & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2) +! zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) ) +! an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) +! +! ENDIF + ENDIF + + IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN +! have mass and reflectivity but no concentration, so set concentration, using default alpha + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + z = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(z*(pi*xdn(mgs,il))**2) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > cxmin ) THEN +! have mass and concentration but no reflectivity, so set reflectivity, using default alpha + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + chw = cx(mgs,il) + qr = qx(mgs,il) +! zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw + zx(mgs,il) = Min(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(chw*(pi*xdn(mgs,il))**2) ) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + ELSEIF ( zx(mgs,il) <= 0.0 .and. cx(mgs,il) <= 0.0 ) THEN +! How did this happen? +! write(91,*) 'ziegfall: something screwy with moments: il = ',il +! write(91,*) 'q,n,z = ', 1.e3*qx(mgs,il),cx(mgs,il),zx(mgs,il) +! write(91,*) 'alpha = ',alpha(mgs,il) + + IF ( qx(mgs,il) < 1.e-8 ) THEN + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + ELSE +! write(0,*) 'alpha = ',alpha(mgs,il) + ! set values according to dBZ of -10 +! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 + zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2 + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + z = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(z*(pi*xdn(mgs,il))**2) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ENDIF + ENDIF + ENDIF + + IF ( qx(mgs,il) .gt. qxmin(il) .and. cx(mgs,il) .gt. 0.0 ) THEN + chw = cx(mgs,il) + qr = qx(mgs,il) + z = zx(mgs,il) + + IF ( zx(mgs,il) .gt. 0. ) THEN + +! rd = z*(pi/6.*1000.)**2*chw/(0.224*(dn(igs(mgs),jy,kgs(mgs))*qr)**2) + rd = z*(pi/6.*xdn(mgs,il))**2*chw/((dn(igs(mgs),jy,kgs(mgs))*qr)**2) + + alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd) - 1.0 + DO i = 1,10 + IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT + alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) ) + alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd) - 1.0 +! write(0,*) 'i,alp = ',i,alp + alp = Max( alphamin, Min( alphamax, alp ) ) + ENDDO + + + +! check for artificial breakup (graupel/hail larger than allowed max size) + + IF ( imaxdiaopt == 1 ) THEN + xvbarmax = xvmx(il) + ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter + xvbarmax = xvmx(il) /((3. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il)))) + ELSEIF ( imaxdiaopt == 3 ) THEN ! test against mass-weighted diameter + xvbarmax = xvmx(il) /((4. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il)))) + ENDIF + + IF ( xv(mgs,il) .gt. xvbarmax ) THEN + tmp = cx(mgs,il) + xv(mgs,il) = Min( xvbarmax, Max( xvmn(il),xv(mgs,il) ) ) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) + IF ( tmp < cx(mgs,il) ) THEN ! breakup + g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2) + zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) ) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + chw = cx(mgs,il) + qr = qx(mgs,il) + z = zx(mgs,il) + + rd = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2) + alp = (6.0+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd) - 1.0 + DO i = 1,10 + IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT + alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) ) + alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd) - 1.0 + alp = Max( alphamin, Min( alphamax, alp ) ) + ENDDO + + + ENDIF + ENDIF + +! +! Check whether the shape parameter is at or less than the minimum, and if it is, reset the +! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N) +! + IF ( (rescale_low_alpha .or. rescale_high_alpha ) .and. & + & ( alpha(mgs,il) <= alphamin .or. alp == alphamin .or. alp == alphamax ) ) THEN + + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + + IF ( rescale_high_alpha .and. alp >= alphamax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2 + an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il) + + ELSEIF ( rescale_low_alpha .and. alp <= alphamin .and. .not. (il == lh .and. icvhl2h > 0 ) ) THEN + +!! z1 = g1*dn(igs(mgs),jy,kgs(mgs))**2*( 0.224*qr)*qr/chw + z1 = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw + z = z1*(6./(pi*xdn(mgs,il)))**2 + zx(mgs,il) = z + an(igs(mgs),jy,kgs(mgs),lz(il)) = z + ENDIF + ENDIF + ELSE + ENDIF + ENDIF + ENDDO ! mgs + + ENDIF ! lz(il) .gt. 1 + + ENDDO ! il + +! CALL cld_cpu('Z-MOMENT-ZFAll') + + ENDIF + + IF ( lzhl > 1 ) THEN + IF ( lhl .gt. 1 ) THEN + + ENDIF + ENDIF + + + +! +! Set density +! + if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: call setvtz' +! + + call setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & + & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx,cdxgs, & + & ipconc,ndebugzf,ngs,nz,kgs,fadvisc, & + & cwmasn,cwmasx,cwradn,cnina,cimn,cimx, & + & itype1,itype2,temcg,infdo,alpha,ildo,axx,bxx) +! & itype1,itype2,temcg,infdo,alpha,ildo,axh,bxh,axhl,bxhl) + + + +! +! put fall speeds into the x-z arrays +! + DO il = l1,l2 + do mgs = 1,ngscnt + + vtmax = 150.0 + + + IF ( vtxbar(mgs,il,2) .gt. vtxbar(mgs,il,1) .or. & + & ( vtxbar(mgs,il,1) .gt. vtxbar(mgs,il,3) .and. vtxbar(mgs,il,3) > 0.0) ) THEN + + +! IF ( qx(mgs,il) > 1.e-4 .and. & +! & .not. ( il == lr .and. 1.e3*xdia(mgs,il,3) > 5.0 ) ) THEN +! write(0,*) 'infdo,mgs = ',infdo,lzr,mgs +! write(0,*) 'Moment problem with vtxbar for il at i,j,k = ',il,igs(mgs),jy,kgs(mgs) +! write(0,*) 'nx,ny,nz,ng = ',nx,ny,nz,nor +! write(0,*) 'cwmasn,cwmasx = ',cwmasn,cwmasx +! write(0,*) 'vt1,2,3 = ',vtxbar(mgs,il,1),vtxbar(mgs,il,2),vtxbar(mgs,il,3) +! write(0,*) 'q,n,d = ', 1.e3*qx(mgs,il),cx(mgs,il),1.e3*xdia(mgs,il,3) +! IF ( il .ge. lr .and. lz(il) > 1 ) write(0,*) 'z = ', zx(mgs,il) +! IF ( il .ge. lg .or. il == lr ) THEN +! write(0,*) 'alpha = ',alpha(mgs,il) +! ENDIF +! ENDIF + + vtxbar(mgs,il,1) = Max( vtxbar(mgs,il,1), vtxbar(mgs,il,2) ) + vtxbar(mgs,il,3) = Max( vtxbar(mgs,il,3), vtxbar(mgs,il,1) ) + + ENDIF + + + IF ( vtxbar(mgs,il,1) .gt. vtmax .or. vtxbar(mgs,il,2) .gt. vtmax .or. & + & vtxbar(mgs,il,3) .gt. vtmax ) THEN + +! IF ( ndebugzf >= 0 .and. 1.e3*qx(mgs,il) > 0.1 ) THEN +! write(0,*) 'infdo = ',infdo +! write(0,*) 'Problem with vtxbar for il at i,j,k = ',il,igs(mgs),jy,kgs(mgs) +! write(0,*) 'nx,ny,nz,ng = ',nx,ny,nz,nor +! write(0,*) 'cwmasn,cwmasx = ',cwmasn,cwmasx +! write(0,*) 'vt1,2,3 = ',vtxbar(mgs,il,1),vtxbar(mgs,il,2),vtxbar(mgs,il,3) +! write(0,*) 'q,n,d = ', 1.e3*qx(mgs,il),cx(mgs,il),1.e3*xdia(mgs,il,3) +! IF ( il .ge. lr .and. lz(il) > 1 ) write(0,*) 'z = ', zx(mgs,il) +! IF ( il .ge. lg ) THEN +! write(0,*) 'alpha = ',alpha(mgs,il) +! ENDIF +! ENDIF + vtxbar(mgs,il,1) = Min(vtmax,vtxbar(mgs,il,1) ) + vtxbar(mgs,il,2) = Min(vtmax,vtxbar(mgs,il,2) ) + vtxbar(mgs,il,3) = Min(vtmax,vtxbar(mgs,il,3) ) + +! call commasmpi_abort() + ENDIF + + + xvt(kgs(mgs),igs(mgs),1,il) = vtxbar(mgs,il,1) + xvt(kgs(mgs),igs(mgs),2,il) = vtxbar(mgs,il,2) + IF ( infdo .ge. 2 ) THEN + xvt(kgs(mgs),igs(mgs),3,il) = vtxbar(mgs,il,3) + ELSE + xvt(kgs(mgs),igs(mgs),3,il) = 0.0 + ENDIF + +! xvt(kgs(mgs),igs(mgs),2,il) = xvt(kgs(mgs),igs(mgs),1,il) + + enddo + ENDDO + + + if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: COPIED FALL SPEEDS' + + + + 9998 continue + + if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: DONE WITH LOOP' + + if ( kz .gt. nz-1 ) then + go to 1200 else nzmpb = kz end if @@ -7630,6 +8413,8 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & IF ( ipconc .le. 2 ) THEN gtmp(ix,kz) = dadr*an(ix,jy,kz,lr)**(0.25) dtmp(ix,kz) = zrc*gtmp(ix,kz)**7 + ELSEIF ( lzr .gt. 1 ) THEN + dtmp(ix,kz) = 1e18*an(ix,jy,kz,lzr) ELSEIF ( an(ix,jy,kz,lnr) .gt. 1.e-3 ) THEN IF ( imurain == 3 ) THEN vr = db(ix,jy,kz)*an(ix,jy,kz,lr)/(1000.*an(ix,jy,kz,lnr)) @@ -7822,7 +8607,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ELSE ! new form using a mass relationship m = p d^2 (instead of d^3 -- Cox 1988 QJRMS) so that density depends on size ! p = 0.106214 for m = p v^(2/3) - dnsnow = 0.346159*sqrt(an(ix,jy,kz,lns)/(an(ix,jy,kz,ls)*db(ix,jy,kz)) ) + dnsnow = 0.0346159*sqrt(an(ix,jy,kz,lns)/(an(ix,jy,kz,ls)*db(ix,jy,kz)) ) IF ( .true. .or. dnsnow < 900. ) THEN gtmp(ix,kz) = 1.e18*323.3226* 0.106214**2*(ksq*an(ix,jy,kz,ls) + & & (1.-ksq)*qxw)*an(ix,jy,kz,ls)*db(ix,jy,kz)**2*gsnow73/ & @@ -7898,6 +8683,10 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & IF ( izieg .ge. 1 .and. ipconc .ge. 5 ) THEN ltest = .false. + IF ( lzh > 1 ) THEN + IF ( an(ix,jy,kz,lzh) > 0.0 .and. an(ix,jy,kz,lh) > qhmin .and. & + an(ix,jy,kz,lnh) >= cxmin ) ltest = .true. + ENDIF IF ( ltest .or. (an(ix,jy,kz,lh) .ge. qhmin .and. an(ix,jy,kz,lnh) .ge. cxmin )) THEN @@ -7943,6 +8732,9 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ENDIF IF ( lzh .gt. 1 ) THEN + x = (0.224*qh + 0.776*qxw)/an(ix,jy,kz,lh) ! weighted average of dielectric const + dtmph = 1.e18*x*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 + dtmp(ix,kz) = dtmp(ix,kz) + dtmph ELSE g1 = (6.0 + alphah)*(5.0 + alphah)*(4.0 + alphah)/((3.0 + alphah)*(2.0 + alphah)*(1.0 + alphah)) ! zx = g1*(db(ix,jy,kz)*an(ix,jy,kz,lh))**2/chw @@ -8015,6 +8807,10 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & IF ( ipconc .ge. 5 ) THEN ltest = .false. + IF ( lzhl > 1 ) THEN + IF ( an(ix,jy,kz,lzhl) > 0.0 .and. an(ix,jy,kz,lhl) > qhlmin .and. & + an(ix,jy,kz,lnhl) > 0.0 ) ltest = .true. + ENDIF IF ( ltest .or. ( an(ix,jy,kz,lhl) .ge. qhlmin .and. an(ix,jy,kz,lnhl) .gt. 0.) ) THEN !{ chl = an(ix,jy,kz,lnhl) @@ -8038,6 +8834,9 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ENDIF IF ( lzhl .gt. 1 ) THEN !{ + x = (0.224*an(ix,jy,kz,lhl) + 0.776*qxw)/an(ix,jy,kz,lhl) ! weighted average of dielectric const + dtmphl = 1.e18*x*an(ix,jy,kz,lzhl)*(hldn/rwdn)**2 + dtmp(ix,kz) = dtmp(ix,kz) + dtmphl ELSE !} g1 = (6.0 + alphahl)*(5.0 + alphahl)*(4.0 + alphahl)/((3.0 + alphahl)*(2.0 + alphahl)*(1.0 + alphahl)) @@ -8118,8 +8917,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ! write(0,*) 'Hail,snow c: ',an(ix,jy,kz,lnh),an(ix,jy,kz,lns) ! write(0,*) 'dtmps,dtmph = ',dtmps,dtmph ! ENDIF - - IF ( ndebug>1 .and. .not. dtmp(ix,kz) .lt. 1.e30 .or. dbz(ix,jy,kz) > 190.0 ) THEN + IF ( .not. dtmp(ix,kz) .lt. 1.e30 .or. dbz(ix,jy,kz) > 190.0 ) THEN ! IF ( ix == 31 .and. kz == 20 .and. jy == 23 ) THEN ! write(0,*) 'my_rank = ',my_rank write(0,*) 'ix,jy,kz = ',ix,jy,kz @@ -8190,6 +8988,8 @@ END subroutine radardd02 ! ##################################################################### ! ! Subroutine for explicit cloud condensation and droplet nucleation +! +! 11/30/2022: Fixed droplet evaporation heating term for CM1 eqtset=2 (was only doing eqtset=1) ! SUBROUTINE NUCOND & & (nx,ny,nz,na,jyslab & @@ -8543,6 +9343,7 @@ SUBROUTINE NUCOND & qx(:,:) = 0.0 cx(:,:) = 0.0 + zx(:,:) = 0.0 xv(:,:) = 0.0 xmas(:,:) = 0.0 @@ -8602,6 +9403,7 @@ SUBROUTINE NUCOND & ELSE ! equation set 2 in cm1 tmp = qx(mgs,li)+qx(mgs,ls)+qx(mgs,lh) IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl) + IF ( lf > 1 ) tmp = tmp + qx(mgs,lf) cvm = cv+cvv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & +cpigb*(tmp) cpm = cp+cpv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & @@ -8716,6 +9518,237 @@ SUBROUTINE NUCOND & ventrxn(:) = ventrn +! Find shape parameter rain + + IF ( lzr > 1 .and. rcond == 2 ) THEN ! { RAIN SHAPE PARAM + DO mgs = 1,ngscnt + zx(mgs,lr) = Max(an(igs(mgs),jy,kgs(mgs),lzr), 0.0) + ENDDO + +! CALL cld_cpu('Z-MOMENT-1r2') + il = lr + DO mgs = 1,ngscnt + + IF ( zx(mgs,il) <= 0.0 ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il) + qx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ELSEIF ( cx(mgs,il) <= 0.0 ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il) + zx(mgs,il) = 0.0 + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + ENDIF + + IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN + + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-11,cx(mgs,lr))) + IF ( xv(mgs,lr) .gt. xvmx(lr) ) THEN + xv(mgs,lr) = xvmx(lr) + cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmx(lr)*xdn(mgs,lr)) + ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN + xv(mgs,lr) = xvmn(lr) + cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr)) + ENDIF + + IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN +! have mass and reflectivity but no concentration, so set concentration, using default alpha + IF ( imurain == 3 ) THEN + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + z1 = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z1*1000.*1000) + ELSE + g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2) + z1 = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z1*1000.*1000) + + ENDIF +! an(igs(mgs),jgs,kgs(mgs),ln(il)) = zx(mgs,il) + ELSEIF ( zx(mgs,il) <= 0.0 .and. cx(mgs,il) > 0.0 ) THEN +! have mass and concentration but no reflectivity, so set reflectivity, using default alpha + IF ( imurain == 3 ) THEN + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + chw = cx(mgs,il) + qr = qx(mgs,il) + zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(chw*1000.*1000) + ELSE + g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2) + chw = cx(mgs,il) + qr = qx(mgs,il) + zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(chw*1000.*1000) + + ENDIF + + ELSEIF ( zx(mgs,il) <= 0.0 .and. cx(mgs,il) <= 0.0 ) THEN +! How did this happen? + ! set values according to dBZ of -10, or Z = 0.1 +! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 + zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2 + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + IF ( imurain == 3 ) THEN + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + z1 = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z1*1000.*1000) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ELSEIF ( imurain == 1 ) THEN + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + z1 = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(z1*(pi*xdn(mgs,il))**2) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + + ENDIF + ENDIF + + IF ( zx(mgs,lr) > 0.0 ) THEN + vr = rho0(mgs)*qx(mgs,lr)/(1000.*cx(mgs,lr)) +! z1 = 36.*(alpha(kz)+2.0)*a(ix,jy,kz,lnr)*vr**2/((alpha(kz)+1.0)*pi**2) + qr = qx(mgs,lr) + nrx = cx(mgs,lr) + z1 = zx(mgs,lr) + +! xv = (db(1,kz)*a(1,1,kz,lr))**2/(a(1,1,kz,lnr)) +! rd = z1*(pi/6.*1000.)**2/xv + + +! determine shape parameter alpha by iteration + IF ( z1 .gt. 0.0 ) THEN + + IF ( imurain == 3 ) THEN + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z1*pi**2) - 1. +! write(0,*) 'kz, alp, alpha(kz) = ',kz,alp,alpha(kz),rd,z1,xv + DO i = 1,20 + IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT + alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) ) + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z1*pi**2) - 1. +! write(0,*) 'i,alp = ',i,alp + alp = Max( rnumin, Min( rnumax, alp ) ) + ENDDO + + ELSE ! imurain == 1 + g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2) + + rd1 = z1*(pi/6.*xdn(mgs,il))**2*nrx/(rho0(mgs)*qr)**2 + + alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd1) - 1.0 + + DO i = 1,10 + IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT + alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) ) + + alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd1) - 1.0 + + alp = Max( alphamin, Min( alphamax, alp ) ) + ENDDO + + + ENDIF +! ENDIF + +! +! Check whether the shape parameter is at or less than the minimum, and if it is, reset the +! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N) +! + IF ( imurain == 3 ) THEN + IF ( .true. .and. (alpha(mgs,il) <= rnumin .or. alp == rnumin .or. alp == rnumax) ) THEN + + IF ( rescale_high_alpha .and. alp >= rnumax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z1*(1./(xdn(mgs,il)))**2 + an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il) + + ELSEIF ( rescale_low_alphar .and. alp <= rnumin ) THEN + + z1 = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2) + zx(mgs,il) = z1 + ENDIF + ENDIF + + ELSEIF ( imurain == 1 ) THEN + + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + + IF ( (rescale_low_alpha .or. rescale_high_alpha ) .and. & + & ( alpha(mgs,il) <= alphamin .or. alp == alphamin .or. alp == alphamax ) ) THEN + + + + IF ( rescale_high_alpha .and. alp >= alphamax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z + cx(mgs,il) = g1*rho0(mgs)**2*(qr)*qr/zx(mgs,lr)*(6./(pi*xdn(mgs,il)))**2 + an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il) + + ELSEIF ( rescale_low_alpha .and. alp <= alphamin ) THEN ! alpha = alphamin, so reset Z to prevent growth in C + z1 = g1*rho0(mgs)**2*(qr)*qr/nrx + z2 = z1*(6./(pi*xdn(mgs,il)))**2 + zx(mgs,il) = z2 + an(igs(mgs),jy,kgs(mgs),lz(il)) = z2 + ENDIF + ENDIF ! imurain + + ENDIF ! z > 0 + + tmp = alpha(mgs,lr) + 4./3. + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = alpha(mgs,lr) + 1. + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! ventrx(mgs) = Gamma(alpha(mgs,lr) + 4./3.)/(alpha(mgs,lr) + 1.)**(1./3.)/Gamma(alpha(mgs,lr) + 1.) + ventrx(mgs) = x/(y*(alpha(mgs,lr) + 1.)**(1./3.)) + + IF ( imurain == 3 .and. izwisventr == 2 ) THEN + + tmp = alpha(mgs,lr) + 1.5 + br/6. + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! ventrx(mgs) = Gamma(alpha(mgs,lr) + 1.5 + br/6.)/Gamma(alpha(mgs,lr) + 1.) + ventrxn(mgs) = x/(y*(alpha(mgs,lr) + 1.)**((1.+br)/6. + 1./3.)) + + ELSEIF ( imurain == 1 .and. iferwisventr == 2 ) THEN + + tmp = alpha(mgs,lr) + 2.5 + br/2. + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! ventrx(mgs) = Gamma(alpha(mgs,lr) + 1.5 + br/6.)/Gamma(alpha(mgs,lr) + 1.) + ventrxn(mgs) = x/y + + + ENDIF + + + ENDIF + ENDIF + + ENDIF + + ENDDO +! CALL cld_cpu('Z-MOMENT-1r2') + ENDIF ! } + ! write(0,*) 'NUCOND: Set ssf variables, ssmxinit =',ssmxinit ssmx = 0.0 @@ -8868,9 +9901,9 @@ SUBROUTINE NUCOND & QEVAP= Min( qx(mgs,lc), R1*(qss(mgs)-qvap(mgs)) ) - IF ( qx(mgs,lc) .LT. QEVAP ) THEN ! GO TO 63 + IF ( qx(mgs,lc) <= QEVAP ) THEN ! GO TO 63 qwvp(mgs) = qwvp(mgs) + qx(mgs,lc) - thetap(mgs) = thetap(mgs) - felv(mgs)*qx(mgs,lc)/(cp*pi0(mgs)) + thetap(mgs) = thetap(mgs) - felvcp(mgs)*qx(mgs,lc)/(pi0(mgs)) IF ( io_flag .and. nxtra > 1 ) THEN axtra(igs(mgs),jy,kgs(mgs),1) = -qx(mgs,lc)/dtp ENDIF @@ -8878,13 +9911,13 @@ SUBROUTINE NUCOND & IF ( restoreccn ) THEN IF ( irenuc <= 2 ) THEN IF ( .not. invertccn ) THEN - ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) ) + ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + restoreccnfrac*cx(mgs,lc) ) ) ELSE - ccnc(mgs) = ccnc(mgs) + cx(mgs,lc) + ccnc(mgs) = ccnc(mgs) + restoreccnfrac*cx(mgs,lc) ENDIF ENDIF IF ( lccna > 1 ) THEN - ccna(mgs) = ccna(mgs) - cx(mgs,lc) + ccna(mgs) = ccna(mgs) - restoreccnfrac*cx(mgs,lc) ENDIF ENDIF cx(mgs,lc) = 0. @@ -8898,13 +9931,13 @@ SUBROUTINE NUCOND & ! ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) ) ! ccnc(mgs) = ccnc(mgs) + cx(mgs,lc) IF ( .not. invertccn ) THEN - ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) ) + ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + restoreccnfrac*cx(mgs,lc) ) ) ELSE - ccnc(mgs) = ccnc(mgs) + cx(mgs,lc) + ccnc(mgs) = ccnc(mgs) + restoreccnfrac*cx(mgs,lc) ENDIF ENDIF IF ( lccna > 1 ) THEN - ccna(mgs) = ccna(mgs) - cx(mgs,lc) + ccna(mgs) = ccna(mgs) - restoreccnfrac*cx(mgs,lc) ENDIF ENDIF cx(mgs,lc) = 0. @@ -8915,18 +9948,18 @@ SUBROUTINE NUCOND & ! ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + tmp ) ) ! ccnc(mgs) = ccnc(mgs) + tmp IF ( .not. invertccn ) THEN - ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + tmp ) ) + ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + restoreccnfrac*tmp ) ) ELSE - ccnc(mgs) = ccnc(mgs) + tmp + ccnc(mgs) = ccnc(mgs) + restoreccnfrac*tmp ENDIF ENDIF IF ( lccna > 1 ) THEN - ccna(mgs) = ccna(mgs) - tmp + ccna(mgs) = ccna(mgs) - restoreccnfrac*tmp ENDIF ENDIF cx(mgs,lc) = cx(mgs,lc) - tmp ENDIF - thetap(mgs) = thetap(mgs) - felv(mgs)*QEVAP/(CP*pi0(mgs)) + thetap(mgs) = thetap(mgs) - felvcp(mgs)*QEVAP/(pi0(mgs)) IF ( io_flag .and. nxtra > 1 ) THEN axtra(igs(mgs),jy,kgs(mgs),1) = -QEVAP/dtp ENDIF @@ -9208,6 +10241,19 @@ SUBROUTINE NUCOND & !! & dx*dy*dz3d(igs(mgs),jy,kgs(mgs)) + IF ( lzr > 1 .and. rcond == 2 .and. qx(mgs,lr) .gt. qxmin(lr) & + & .and. cx(mgs,lr) .gt. 1.e-9 ) THEN + tmp = qx(mgs,lr)/cx(mgs,lr) + IF ( imurain == 3 ) THEN + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + ELSE + g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2) + + ENDIF + zx(mgs,lr) = zx(mgs,lr) + g1*(rho0(mgs)/(xdn(mgs,lr)))**2*( 2.*( tmp ) * dqr ) + ENDIF + theta(mgs) = thetap(mgs) + theta0(mgs) temg(mgs) = theta(mgs)*f1 ltemq = (temg(mgs)-163.15)/fqsat+1.5 @@ -9468,15 +10514,143 @@ SUBROUTINE NUCOND & ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) - ELSEIF ( irenuc == 5 ) THEN !} { - - ! modification of Phillips Donner Garner 2007 + ELSEIF ( irenuc == 3 ) THEN !} { + ! Phillips Donner Garner 2007 ! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) -! CN(mgs) = Min( 0.91*cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465 - CN(mgs) = Min( cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp ) +! CN(mgs) = cwccn*Min(ssf(mgs),ssfcut)**cck - - IF ( ccna(mgs) >= cnuc(mgs) ) THEN ! apply limit after all "base" CCN have been depleted +! Need to calculate new ssf since condensation has happened: + temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz) + ltemq = Int( (temp1-163.15)/fqsat+1.5 ) + ltemq = Min( nqsat, Max(1,ltemq) ) + + c1= pqs(mgs)*tabqvs(ltemq) + + ssf(mgs) = 0.0 + IF ( c1 > 0. ) THEN + ssf(mgs) = 100.*(qx(mgs,lv)/c1 - 1.0) ! from "new" values + ENDIF + CN(mgs) = cnuc(mgs)*Min(1.0, (ssf(mgs))**cck ) ! + + CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from + ! Philips, Donner et al. 2007, but results in too much limitation of + ! nucleation + CN(mgs) = Min(cn(mgs), ccnc(mgs)) + cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass + + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + + ! 6/13/2016: Phillips et al. appears not to decrement CCN, but only increments CCNa. + ! This would allow an initially non-homogeneous (vertically, e.g.) initial value of CCN/rho_air + ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + + ELSEIF ( irenuc == 4 ) THEN !} { + ! modification of Phillips Donner Garner 2007 +! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) +! CN(mgs) = CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp +! cn(mgs) = Min( cn(mgs), cnuc(mgs) ) +! Need to calculate new ssf since condensation has happened: + temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz) + ltemq = Int( (temp1-163.15)/fqsat+1.5 ) + ltemq = Min( nqsat, Max(1,ltemq) ) + + c1= pqs(mgs)*tabqvs(ltemq) + IF ( c1 > 0. ) THEN + ssf(mgs) = Max(0.0, 100.*((qv0(mgs) + qwvp(mgs))/c1 - 1.0) ) ! from "new" values + ELSE + ssf(mgs) = 0.0 + ENDIF + CN(mgs) = cnuc(mgs)*Min(ssf2kmax, ssf(mgs)**cck) ! this allows cn(mgs) > cnuc(mgs) + + CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from + ! Philips, Donner et al. 2007, but results in too much limitation of + ! nucleation +! CN(mgs) = Min(cn(mgs), ccnc(mgs)) + cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass + + IF ( cn(mgs) > 0.0 ) THEN + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + + dcrit = 2.0*2.5e-7 + + dcloud = 1000.*dcrit**3*Pi/6.*cn(mgs) + qx(mgs,lc) = qx(mgs,lc) + DCLOUD + thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) + qwvp(mgs) = qwvp(mgs) - DCLOUD + ENDIF + ! 6/13/2016: Phillips et al. appears not to decrement CCN, but only increments CCNa. + ! This would allow an initially non-homogeneous (vertically, e.g.) initial value of CCN/rho_air +! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + + + + ELSEIF ( irenuc == 6 ) THEN !} { + + ! simple Twomey scheme but limit activation to try to do most activation near cloud base, but keep some CCN available for renuclation +! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) + cn(mgs) = 0.0 +! IF ( ccna(mgs) < 0.7*cnuc(mgs) .and. ccnc(mgs) > 0.69*cnuc(mgs) - ccna(mgs)) THEN ! here, assume we are near cloud base and use Twomey formulation + IF ( ccna(mgs) < 0.7*cnuc(mgs) ) THEN ! here, assume we are near cloud base and use Twomey formulation + CN(mgs) = Min( 0.9*cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465 +! IF ( cn(mgs) + ccna(mgs) > 0.71*cnuc ) THEN + ! prevent this branch from activating more than 70% of CCN + CN(mgs) = Min( CN(mgs), Max(0.0, (0.7*cnuc(mgs) - ccna(mgs) )) ) +! CN(mgs) = Min( CN(mgs), Max(0.0, 0.71*ccnc(mgs) - ccna(mgs) ) ) + + ELSE + ! if a large fraction of CCN have been activated, then assume we are in the cloud interior and use local SSw as in Phillips et al. 2007. + + temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz) +! t0(ix,jy,kz) = temp1 + ltemq = Int( (temp1-163.15)/fqsat+1.5 ) + ltemq = Min( nqsat, Max(1,ltemq) ) + +! c1 = t00(igs(mgs),jy,kgs(mgs))*tabqvs(ltemq) + c1= pqs(mgs)*tabqvs(ltemq) + IF ( c1 > 0. ) THEN + ssf(mgs) = Max(0.0, 100.*((qv0(mgs) + qwvp(mgs))/c1 - 1.0) ) ! from "new" values + ELSE + ssf(mgs) = 0.0 + ENDIF + +! CN(mgs) = cnuc(mgs)*Min(0.99, Min(ssf(mgs),ssfcut)**cck ) ! + CN(mgs) = cnuc(mgs)*Min(2.0, Max(0.0,ssf(mgs))**cck ) ! +! CN(mgs) = cnuc(mgs)*Min(ssf(mgs),ssfcut)**cck ! + + + CN(mgs) = Min(0.01*cnuc(mgs), Max( 0.0, CN(mgs) - ccna(mgs) ) ) ! this was from +! cn(mgs) = 0.0 + ENDIF +! ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck)) +!!! CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from + ! Philips, Donner et al. 2007, but results in too much limitation of + ! nucleation +! CN(mgs) = Min(cn(mgs), ccnc(mgs)) +! cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass + + IF ( cn(mgs) > 0.0 ) THEN + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + + ! create some small droplets at minimum size (CP 2000), although it adds very little liquid + + dcrit = 2.0*2.5e-7 + + dcloud = 1000.*dcrit**3*Pi/6.*cn(mgs) + qx(mgs,lc) = qx(mgs,lc) + DCLOUD + thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) + qwvp(mgs) = qwvp(mgs) - DCLOUD + ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + ENDIF + ELSEIF ( irenuc == 5 ) THEN !} { + + ! modification of Phillips Donner Garner 2007 +! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) +! CN(mgs) = Min( 0.91*cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465 + CN(mgs) = Min( cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp ) + + + IF ( ccna(mgs) >= cnuc(mgs) ) THEN ! apply limit after all "base" CCN have been depleted temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz) ltemq = Int( (temp1-163.15)/fqsat+1.5 ) ltemq = Min( nqsat, Max(1,ltemq) ) @@ -9573,7 +10747,7 @@ SUBROUTINE NUCOND & ! write(0,*) 'k,cn = ',kgs(mgs),cn(mgs),ssf(mgs) ! write(0,*) 'ccn-ccna = ',cnuc(mgs) - ccna(mgs),ccnc(mgs) - ccna(mgs) ! IF ( ccncuf(mgs) > 0.0 .and. cn(mgs) < 1.e-3 .and. ssmax(mgs) > 1.0 ) THEN - IF ( ccncuf(mgs) > 0.0 .and. ssf(mgs) > ssmxuf .and. ssmax(mgs) > ssmxuf ) THEN + IF ( ccncuf(mgs) > 0.0 .and. ssf(mgs) > ssmxuf .and. ( ssmax(mgs) > ssmxuf .or. lss < 1 ) ) THEN CNuf(mgs) = Min( ccncuf(mgs), CCNE0*ccncuf(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465 ! IF ( cnuf(mgs) >= 0.0 ) write(0,*) 'cnuf, k = ',cnuf(mgs),ccncuf(mgs),kgs(mgs) ENDIF @@ -9853,6 +11027,10 @@ SUBROUTINE NUCOND & ! qx(mgs,lr) = an(igs(mgs),jy,kgs(mgs),lr) end if + IF ( lzr > 1 .and. rcond == 2 ) THEN + an(igs(mgs),jy,kgs(mgs),lzr) = zx(mgs,lr) + & + & min( an(igs(mgs),jy,kgs(mgs),lzr), 0.0 ) + ENDIF IF ( ipconc .ge. 2 ) THEN @@ -9938,6 +11116,42 @@ SUBROUTINE NUCOND & IF ( lhl .gt. 1 ) THEN + IF ( lzhl .gt. 1 ) THEN + + an(ix,jy,kz,lzhl) = Max(0.0, an(ix,jy,kz,lzhl) ) + + IF ( an(ix,jy,kz,lhl) .ge. frac*qxmin(lhl) .and. rescale_low_alpha ) THEN ! check 6th moment + + IF ( an(ix,jy,kz,lnhl) .gt. 0.0 ) THEN + + IF ( lvhl .gt. 1 ) THEN + IF ( an(ix,jy,kz,lvhl) .gt. 0.0 ) THEN + hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl) + ELSE + hwdn = xdn0(lhl) + ENDIF + hwdn = Max( xdnmn(lhl), hwdn ) + ELSE + hwdn = xdn0(lhl) + ENDIF + + chw = an(ix,jy,kz,lnhl) + g1 = (6.0+alphamin)*(5.0+alphamin)*(4.0+alphamin)/ & + & ((3.0+alphamin)*(2.0+alphamin)*(1.0+alphamin)) + z1 = g1*dn(ix,jy,kz)**2*( an(ix,jy,kz,lhl) )*an(ix,jy,kz,lhl)/chw + z1 = z1*(6./(pi*hwdn))**2 + ELSE + z1 = 0.0 + ENDIF + + an(ix,jy,kz,lzhl) = Min( z1, an(ix,jy,kz,lzhl) ) + + IF ( an(ix,jy,kz,lnhl) .lt. 1.e-5 ) THEN +! an(ix,jy,kz,lzhl) = 0.9*an(ix,jy,kz,lzhl) + ENDIF + ENDIF + + ENDIF !lzhl if ( an(ix,jy,kz,lhl) .lt. frac*qxmin(lhl) .or. zerocx(lhl) ) then @@ -10038,6 +11252,42 @@ SUBROUTINE NUCOND & + IF ( lzh .gt. 1 ) THEN + + an(ix,jy,kz,lzh) = Max(0.0, an(ix,jy,kz,lzh) ) + + IF ( .false. .and. an(ix,jy,kz,lh) .ge. frac*qxmin(lh) .and. rescale_low_alpha ) THEN + + IF ( an(ix,jy,kz,lnh) .gt. 0.0 ) THEN + + IF ( lvh .gt. 1 ) THEN + IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN + hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) + ELSE + hwdn = xdn0(lh) + ENDIF + hwdn = Max( xdnmn(lh), hwdn ) + ELSE + hwdn = xdn0(lh) + ENDIF + + chw = an(ix,jy,kz,lnh) + g1 = (6.0+alphamin)*(5.0+alphamin)*(4.0+alphamin)/ & + & ((3.0+alphamin)*(2.0+alphamin)*(1.0+alphamin)) + z1 = g1*dn(ix,jy,kz)**2*( an(ix,jy,kz,lh) )*an(ix,jy,kz,lh)/chw + z1 = z1*(6./(pi*hwdn))**2 + ELSE + z1 = 0.0 + ENDIF + + an(ix,jy,kz,lzh) = Min( z1, an(ix,jy,kz,lzh) ) + + IF ( an(ix,jy,kz,lnh) .lt. 1.e-5 ) THEN +! an(ix,jy,kz,lzh) = 0.9*an(ix,jy,kz,lzh) + ENDIF + ENDIF + + ENDIF if ( an(ix,jy,kz,lh) .lt. frac*qxmin(lh) .or. zerocx(lh) ) then @@ -10198,6 +11448,9 @@ SUBROUTINE NUCOND & end if + IF ( lzr > 1 ) THEN + an(ix,jy,kz,lzr) = Max(0.0, an(ix,jy,kz,lzr) ) + ENDIF if ( an(ix,jy,kz,lr) .lt. frac*qxmin(lr) .or. zerocx(lr) & & ) then @@ -10208,6 +11461,10 @@ SUBROUTINE NUCOND & an(ix,jy,kz,lnr) = 0.0 ENDIF + IF ( lzr > 1 ) THEN + an(ix,jy,kz,lzr) = 0.0 + ENDIF + end if ! @@ -10265,12 +11522,14 @@ SUBROUTINE NUCOND & & an(ix,jy,kz,lccn) + Max(0.0,an(ix,jy,kz,lnc)) ENDIF an(ix,jy,kz,lnc) = 0.0 + IF ( lccn > 1 ) an(ix,jy,kz,lccn) = Max( 0.0, an(ix,jy,kz,lccn) ) IF ( lccna > 0 ) THEN ! apply exponential decay to activated CCN to restore to environmental value + IF ( restoreccn ) THEN tmp = an(ix,jy,kz,li) + an(ix,jy,kz,ls) IF ( an(ix,jy,kz,lccna) > 1. .and. tmp < qxmin(li) ) an(ix,jy,kz,lccna) = an(ix,jy,kz,lccna)*Exp(-dtp/ccntimeconst) - + ENDIF ELSEIF ( lccn > 1 .and. restoreccn ) THEN ! in this case, we are treating the ccn field as ccna tmp = an(ix,jy,kz,li) + an(ix,jy,kz,ls) @@ -10425,6 +11684,7 @@ subroutine nssl_2mom_gs & real rainprod2d(-nor+1:nx+nor,-norz+ng1:nz+norz) real evapprod2d(-nor+1:nx+nor,-norz+ng1:nz+norz) + logical lrescalelow(lc:lhab) real tkediss(-nor+1:nx+nor,-norz+ng1:nz+norz) real axtra(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz,nxtra) @@ -10633,7 +11893,8 @@ subroutine nssl_2mom_gs & real ex1, ft, rhoinv(ngs) double precision ec0(ngs) - real ac1,bc, taus, c1,d1,e1,f1,p380,tmp,tmp1,tmp2,tmp3,tmp4,tmp5,temp3 ! , sstdy, super + real ac1,bc, taus, c1,d1,e1,f1,p380,tmp,tmp1,tmp2,tmp3,tmp4,tmp5,tmp6,temp3 ! , sstdy, super + real :: flim real dw,dwr double precision :: tmpz, tmpzmlt real ratio, delx, dely @@ -10714,7 +11975,7 @@ subroutine nssl_2mom_gs & real temgx(ngs),temcgx(ngs) real qvs(ngs),qis(ngs),qss(ngs),pqs(ngs) real elv(ngs),elf(ngs),els(ngs) - real tsqr(ngs),ssi(ngs),ssw(ngs) + real tsqr(ngs),ssi(ngs),ssw(ngs),ssi0(ngs) real qcwtmp(ngs),qtmp,qtot(ngs) real qcond(ngs) real ctmp, sctmp @@ -10729,6 +11990,7 @@ subroutine nssl_2mom_gs & parameter ( rwradmn = 50.e-6 ) real dh0 real dg0(ngs),df0(ngs) + real dhwet(ngs),dhlwet(ngs),dfwet(ngs) real clionpmx,clionnmx parameter (clionpmx=1.e9,clionnmx=1.e9) ! Takahashi 84 @@ -10736,7 +11998,7 @@ subroutine nssl_2mom_gs & ! other arrays real fwet1(ngs),fwet2(ngs) - real fmlt1(ngs),fmlt2(ngs) + real fmlt1(ngs),fmlt2(ngs),fmlt1e(ngs) real fvds(ngs),fvce(ngs),fiinit(ngs) real fvent(ngs),fraci(ngs),fracl(ngs) ! @@ -10760,6 +12022,7 @@ subroutine nssl_2mom_gs & ! real :: sfm1(ngs),sfm2(ngs) real :: gfm1(ngs),gfm2(ngs) + real :: ffm1(ngs),ffm2(ngs) real :: hfm1(ngs),hfm2(ngs) logical :: wetsfc(ngs),wetsfchl(ngs),wetsfcf(ngs) @@ -10800,6 +12063,10 @@ subroutine nssl_2mom_gs & real :: alpha(ngs,lc:lhab) real :: dab0lh(ngs,lc:lhab,lc:lhab) real :: dab1lh(ngs,lc:lhab,lc:lhab) + real :: zx(ngs,lr:lhab) + real :: zxmxd(ngs,lr:lhab) + real :: g1x(ngs,lr:lhab) + real :: qsimxdep(ngs) ! max sublimation of qi+qs+qis real :: qsimxsub(ngs) ! max depositionof qi+qs+qis @@ -10815,6 +12082,7 @@ subroutine nssl_2mom_gs & real ventrxn(ngs) real g1shr, alphashr real g1mlr, alphamlr + real g1smlr, alphasmlr real massfacshr, massfacmlr real :: qhgt8mm ! ice mass greater than 8mm @@ -10827,6 +12095,8 @@ subroutine nssl_2mom_gs & real, parameter :: srasheym = 0.1389 ! slope fraction from Rasmussen and Heymsfield ! real swvent(ngs),hwvent(ngs),rwvent(ngs),hlvent(ngs),hwventy(ngs),hlventy(ngs),rwventz(ngs) + real hxventtmp + real hlventinc(ngs),hwventinc(ngs) integer, parameter :: ndiam = 10 integer :: numdiam real hwvent0(ndiam+4),hlvent0 ! 0 to d1 @@ -10946,9 +12216,10 @@ subroutine nssl_2mom_gs & real qsacw(ngs) ! ,qwacs(ngs), real qhacw(ngs) ! qwach(ngs), - real :: qhlacw(ngs) ! + real :: qhlacw(ngs), qxacwtmp, qxacrtmp ! real vhacw(ngs), vsacw(ngs), vhlacw(ngs), vhlacr(ngs) + real qfcev(ngs) real qfmul1(ngs),cfmul1(ngs) ! real qsacws(ngs) @@ -10957,7 +12228,7 @@ subroutine nssl_2mom_gs & ! arrays for x-ac-r and r-ac-x; ! real qsacr(ngs),qracs(ngs) - real qhacr(ngs),qhacrmlr(ngs) ! ,qrach(ngs) + real qhacr(ngs),qhacrmlr(ngs),qhacwmlr(ngs) ! ,qrach(ngs) real vhacr(ngs), zhacr(ngs), zhacrf(ngs), zrach(ngs), zrachl(ngs) real qiacr(ngs),qraci(ngs) @@ -10965,7 +12236,7 @@ subroutine nssl_2mom_gs & real qracif(ngs),qiacrf(ngs),qiacrs(ngs),ciacrs(ngs) - real :: qhlacr(ngs),qhlacrmlr(ngs) + real :: qhlacr(ngs),qhlacrmlr(ngs), qhlacwmlr(ngs) real qsacrs(ngs) !,qracss(ngs) ! ! ice - ice interactions @@ -11011,7 +12282,7 @@ subroutine nssl_2mom_gs & real zfmlr(ngs), zfdsv(ngs), zfsbv(ngs), zhlcnf(ngs), zfshr(ngs), zfshrr(ngs) real zhmlrtmp,zhmlr0inf,zhlmlr0inf real zhmlrr(ngs),zhlmlrr(ngs),zhshrr(ngs),zhlshrr(ngs),zfmlrr(ngs) - real zsmlr(ngs), zsmlrr(ngs), zsshr(ngs) + real zsmlr(ngs), zsmlrr(ngs), zsshr(ngs), zsshrr(ngs) real zhcns(ngs), zhcni(ngs) real zhwdn(ngs), zfwdn(ngs) ! change in Z due to density changes real zhldn(ngs) ! change in Z due to density changes @@ -11052,9 +12323,10 @@ subroutine nssl_2mom_gs & ! real :: qhldpv(ngs), qhlsbv(ngs) ! qhlcnv(ngs),qhlevv(ngs), real :: qhlmlr(ngs), qhldsv(ngs), qhlmlrsave(ngs) - real :: qhlwet(ngs), qhldry(ngs), qhlshr(ngs) + real :: qhlwet(ngs), qhldry(ngs), qhlshr(ngs), qxwettmp ! real :: qrfz(ngs),qsfz(ngs),qhfz(ngs),qhlfz(ngs) + real :: qffz(ngs) ! real qhdpv(ngs),qhsbv(ngs) ! qhcnv(ngs),qhevv(ngs), real qhmlr(ngs),qhdsv(ngs),qhcev(ngs),qhcndv(ngs),qhevv(ngs) @@ -11064,6 +12336,7 @@ subroutine nssl_2mom_gs & real qhshh(ngs) !accreted water that remains on graupel real qhmlh(ngs) !melt water that remains on graupel real qhfzh(ngs) !water that freezes on mixed-phase graupel + real qffzf(ngs) !water that freezes on mixed-phase FD real qhlfzhl(ngs) !water that freezes on mixed-phase hail real qhmlrlg(ngs),qhlmlrlg(ngs) ! melting from the larger diameters @@ -11115,6 +12388,7 @@ subroutine nssl_2mom_gs & real qrshr(ngs) real fsw(ngs),fhw(ngs),fhlw(ngs),ffw(ngs) !liquid water fractions real fswmax(ngs),fhwmax(ngs),fhlwmax(ngs) !liquid water fractions + real ffwmax(ngs) real qhcnf(ngs) real :: qhlcnh(ngs) real qhcngh(ngs),qhcngm(ngs),qhcngl(ngs) @@ -11128,7 +12402,7 @@ subroutine nssl_2mom_gs & real ehxr(ngs),ehlr(ngs),egmr(ngs) real eri(ngs),esi(ngs),egli(ngs),eghi(ngs),efi(ngs),efis(ngs) real ehxi(ngs),ehli(ngs),egmi(ngs),ehi(ngs),ehis(ngs),ehlis(ngs) - real ers(ngs),ess(ngs),egls(ngs),eghs(ngs),efs(ngs),ehs(ngs) + real ers(ngs),ess(ngs),egls(ngs),eghs(ngs),efs(ngs),ehs(ngs),ehsfac(ngs) real ehscnv(ngs) real ehxs(ngs),ehls(ngs),egms(ngs),egmip(ngs) @@ -11187,12 +12461,13 @@ subroutine nssl_2mom_gs & real pqgli(ngs),pqghi(ngs),pqfwi(ngs) real pqgmi(ngs),pqhli(ngs) ! ,pqhxi(ngs) real pqiri(ngs),pqipi(ngs) ! pqwai(ngs), - real pqlwsi(ngs),pqlwhi(ngs),pqlwhli(ngs) + real pqlwsi(ngs),pqlwhi(ngs),pqlwhli(ngs),pqlwfi(ngs) real pqlwlghi(ngs),pqlwlghli(ngs) real pqlwlghd(ngs),pqlwlghld(ngs) + real pvhwi(ngs), pvhwd(ngs) real pvfwi(ngs), pvfwd(ngs) @@ -11204,7 +12479,7 @@ subroutine nssl_2mom_gs & real pqgld(ngs),pqghd(ngs),pqfwd(ngs) real pqgmd(ngs),pqhld(ngs) ! ,pqhxd(ngs) real pqird(ngs),pqipd(ngs) ! pqwad(ngs), - real pqlwsd(ngs),pqlwhd(ngs),pqlwhld(ngs) + real pqlwsd(ngs),pqlwhd(ngs),pqlwhld(ngs),pqlwfd(ngs) ! ! real pqxii(ngs,nhab),pqxid(ngs,nhab) ! @@ -11352,7 +12627,7 @@ subroutine nssl_2mom_gs & real frcrglgm, frcrglgh, frcrglfw, frcrglgl1 real frcgmrgl, frcgmrgm, frcgmrgh, frcgmrfw, frcgmrgm1 real frcrgmgl, frcrgmgm, frcrgmgh, frcrgmfw, frcrgmgm1 - real sum, qweps, gf2a, gf4a, dqldt, dqidt, dqdt + real total, qweps, gf2a, gf4a, dqldt, dqidt, dqdt real frcghrgl, frcghrgm, frcghrgh, frcghrfw, frcghrgh1, frcrghgl real frcrghgm, frcrghgh, frcrghfw, frcrghgh1 real a1,a2,a3,a4,a5,a6 @@ -11385,8 +12660,20 @@ subroutine nssl_2mom_gs & real :: term1,term2,term3,term4 real :: qaacw ! combined qsacw-qhacw for WSM6 variation + real, parameter :: c1r=19.0, c2r=0.6, c3r=1.8, c4r=17.0 ! rain + real, parameter :: c1h=5.5, c2h=0.7, c3h=4.5, c4h=8.5 ! Graupel + real, parameter :: c1hl=3.7, c2hl=0.3, c3hl=9.0, c4hl=6.5, c5hl=1.0, c6hl=6.5 ! Hail + +! inline functions for Newton method + real :: galpha, dgalpha + real :: a_in + logical, parameter :: newton = .false. + + galpha(a_in) = ((4. + a_in)*(5. + a_in)*(6. + a_in))/((1. + a_in)*(2. + a_in)*(3. + a_in)) + dgalpha(a_in) = (876. + 1260.*a_in + 621.*a_in**2 + 126.*a_in**3 + 9.*a_in**4)/ & + & (36. + 132.*a_in + 193.*a_in**2 + 144.*a_in**3 + 58.*a_in**4 + 12.*a_in**5 + a_in**6) ! ! #################################################################### ! @@ -11416,6 +12703,11 @@ subroutine nssl_2mom_gs & jstag = 0 kstag = 1 + lrescalelow(:) = rescale_low_alpha + lrescalelow(lr) = rescale_low_alphar .and. rescale_low_alpha + lrescalelow(lh) = rescale_low_alphah .and. rescale_low_alpha + IF ( lf > 1 ) lrescalelow(lf) = rescale_low_alphah .and. rescale_low_alpha + IF ( lhl > 1 ) lrescalelow(lhl) = rescale_low_alphahl .and. rescale_low_alpha ! @@ -11533,11 +12825,18 @@ subroutine nssl_2mom_gs & vmlt = Min(xvmx(lr), 0.523599*(dmlt)**3 ) vshd = Min(xvmx(lr), 0.523599*(dshd)**3 ) - snowmeltmass = pi/6.0 * 1000. * snowmeltdia**3 ! maximum rain particle mass from melting snow (if snowmeltdia > 0) + IF ( snowmeltdia > 0.0 ) THEN + snowmeltmass = pi/6.0 * 1000. * snowmeltdia**3 ! maximum rain particle mass from melting snow (if snowmeltdia > 0) + ENDIF tdtol = 1.0e-05 tfrcbw = tfr - cbw tfrcbi = tfr - cbi + + IF ( mixedphase ) THEN + ibinhmlr = 0 + ibinhlmlr = 0 + ENDIF ! ! ! #ifdef COMMAS @@ -11695,10 +12994,15 @@ subroutine nssl_2mom_gs & temg(1) = t0(ix,jy,kz) temcg(1) = temg(1) - tfr tqvcon = temg(1)-cbw - ltemq = (temg(1)-163.15)/fqsat+1.5 + ltemq = (temg(1)-163.15)/fqsat + 1.5 ltemq = Min( nqsat, Max(1,ltemq) ) qvs(1) = pqs(1)*tabqvs(ltemq) - qis(1) = pqs(1)*tabqis(ltemq) + IF ( iqis0 == 1 .or. temg(1) <= tfr+0.5 ) THEN + qis(1) = pqs(1)*tabqis(ltemq) + ELSE + ltemq = (tfr - 163.15)/fqsat + 1.5 + qis(1) = pqs(1)*tabqis(ltemq) + ENDIF qss(1) = qvs(1) @@ -11793,7 +13097,12 @@ subroutine nssl_2mom_gs & ltemq = (temg(mgs)-163.15)/fqsat+1.5 ltemq = Min( nqsat, Max(1,ltemq) ) qvs(mgs) = pqs(mgs)*tabqvs(ltemq) - qis(mgs) = pqs(mgs)*tabqis(ltemq) + IF ( iqis0 == 1 .or. temg(mgs) <= tfr+0.5 ) THEN + qis(mgs) = pqs(mgs)*tabqis(ltemq) + ELSE + ltemq = (tfr - 163.15)/fqsat + 1.5 + qis(mgs) = pqs(mgs)*tabqis(ltemq) + ENDIF qss(mgs) = qvs(mgs) ! es(mgs) = 6.1078e2*tabqvs(ltemq) ! eis(mgs) = 6.1078e2*tabqis(ltemq) @@ -11834,78 +13143,6 @@ subroutine nssl_2mom_gs & - scx(:,:) = 0.0 -! -! set shape parameters -! - IF ( imurain == 1 ) THEN - alpha(:,lr) = alphar - ELSEIF ( imurain == 3 ) THEN - alpha(:,lr) = xnu(lr) - ENDIF - - alpha(:,li) = xnu(li) - alpha(:,lc) = xnu(lc) - - IF ( imusnow == 1 ) THEN - alpha(:,ls) = alphas - ELSEIF ( imusnow == 3 ) THEN - alpha(:,ls) = xnu(ls) - ENDIF - - DO il = lr,lhab - do mgs = 1,ngscnt - IF ( il .ge. lg ) alpha(mgs,il) = dnu(il) - - - DO ic = lc,lhab - dab0lh(mgs,il,ic) = dab0(il,ic) ! dab0(ic,il) - dab1lh(mgs,il,ic) = dab1(il,ic) ! dab1(ic,il) - ENDDO - ENDDO - end do - - -! DO mgs = 1,ngscnt - DO il = lr,lhab - da0lx(:,il) = da0(il) - ENDDO - da0lh(:) = da0(lh) - da0lr(:) = da0(lr) - da1lr(:) = da1(lr) - da0lc(:) = da0(lc) - da1lc(:) = da1(lc) - - - IF ( lzh < 1 .or. lzhl < 1 ) THEN - rzxhlh(:) = rzhl/rz - ELSEIF ( lzh > 1 .and. lzhl > 1 ) THEN - rzxhlh(:) = 1. - ENDIF - IF ( lzr > 1 ) THEN - rzxh(:) = 1. - rzxhl(:) = 1. - ELSE - rzxh(:) = rz - rzxhl(:) = rzhl - ENDIF - - IF ( imurain == 1 .and. imusnow == 3 .and. lzr < 1 ) THEN - rzxs(:) = rzs - ELSEIF ( imurain == imusnow .or. lzr > 1 ) THEN - rzxs(:) = 1. - ENDIF - ! ENDDO - - IF ( lhl .gt. 1 ) THEN - DO mgs = 1,ngscnt - da0lhl(mgs) = da0(lhl) - ENDDO - ENDIF - - ventrx(:) = ventr - ventrxn(:) = ventrn - gf1palp(:) = gamma_sp(1.0 + alphar) ! ! set concentrations @@ -12076,17 +13313,136 @@ subroutine nssl_2mom_gs & ! -! set factors -! - do mgs = 1,ngscnt -! - ssi(mgs) = qx(mgs,lv)/qis(mgs) - ssw(mgs) = qx(mgs,lv)/qvs(mgs) +! 6th moments ! - tsqr(mgs) = temg(mgs)**2 -! - temgx(mgs) = min(temg(mgs),313.15) - temgx(mgs) = max(temgx(mgs),233.15) + + IF ( ipconc .ge. 6 ) THEN + zx(:,:) = 0.0 + DO il = lr,lhab + IF ( lz(il) .gt. 1 ) THEN + DO mgs = 1,ngscnt + zx(mgs,il) = Max( an(igs(mgs),jy,kgs(mgs),lz(il)), 0.0 ) + ENDDO + ENDIF + ENDDO + + ENDIF + + IF ( ipconc .ge. 6 ) THEN + + IF ( lz(lr) .lt. 1 ) THEN + g1x(:,lr) = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/ & + & ((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar)) + + + DO mgs = 1,ngscnt + IF ( cx(mgs,lr) .gt. 0.0 .and. qx(mgs,lr) .gt. qxmin(lr) ) THEN + + vr = rho0(mgs)*qx(mgs,lr)/(1000.*cx(mgs,lr)) + IF ( lzr < 1 ) THEN + IF ( imurain == 3 ) THEN + zx(mgs,lr) = 3.6476*(rnu+2.0)*cx(mgs,lr)*vr**2/(rnu+1.0) + ELSE ! imurain == 1 + zx(mgs,lr) = 3.6476*g1x(mgs,lr)*cx(mgs,lr)*vr**2 + ENDIF + ENDIF + + ENDIF + ENDDO + ENDIF + + ENDIF + + + scx(:,:) = 0.0 +! +! set shape parameters +! + if ( ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'ICEZVD_GS: dbg = set alpha' + IF ( imurain == 1 ) THEN + alpha(:,lr) = alphar + ELSEIF ( imurain == 3 ) THEN + alpha(:,lr) = xnu(lr) + ENDIF + + alpha(:,li) = xnu(li) + alpha(:,lc) = xnu(lc) + + IF ( imusnow == 1 ) THEN + alpha(:,ls) = alphas + ELSEIF ( imusnow == 3 ) THEN + alpha(:,ls) = xnu(ls) + ENDIF + + if ( ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'ICEZVD_GS: dbg = set dab' + + DO il = lr,lhab + do mgs = 1,ngscnt + IF ( il .ge. lg ) alpha(mgs,il) = dnu(il) + + + DO ic = lc,lhab + dab0lh(mgs,il,ic) = dab0(il,ic) ! dab0(ic,il) + dab1lh(mgs,il,ic) = dab1(il,ic) ! dab1(ic,il) + ENDDO + end do + ENDDO + + +! DO mgs = 1,ngscnt + DO il = lr,lhab + da0lx(:,il) = da0(il) + ENDDO + da0lh(:) = da0(lh) + da0lr(:) = da0(lr) + da1lr(:) = da1(lr) + da0lc(:) = da0(lc) + da1lc(:) = da1(lc) + + if ( ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'ICEZVD_GS: dbg = set rz' + + IF ( lzh < 1 .or. lzhl < 1 ) THEN + rzxhlh(:) = rzhl/rz + ELSEIF ( lzh > 1 .and. lzhl > 1 ) THEN + rzxhlh(:) = 1. + ENDIF + IF ( lzr > 1 ) THEN + rzxh(:) = 1. + rzxhl(:) = 1. + ELSE + rzxh(:) = rz + rzxhl(:) = rzhl + ENDIF + + IF ( imurain == 1 .and. imusnow == 3 .and. lzr < 1 ) THEN + rzxs(:) = rzs + ELSEIF ( imurain == imusnow .or. lzr > 1 ) THEN + rzxs(:) = 1. + ENDIF + ! ENDDO + + IF ( lhl .gt. 1 ) THEN + DO mgs = 1,ngscnt + da0lhl(mgs) = da0(lhl) + ENDDO + ENDIF + + ventrx(:) = ventr + ventrxn(:) = ventrn + gf1palp(:) = gamma_sp(1.0 + alphar) + +! +! set factors +! + do mgs = 1,ngscnt +! + ssi(mgs) = qx(mgs,lv)/qis(mgs) + ssw(mgs) = qx(mgs,lv)/qvs(mgs) +! + tsqr(mgs) = temg(mgs)**2 +! + temgx(mgs) = min(temg(mgs),313.15) + temgx(mgs) = max(temgx(mgs),233.15) felv(mgs) = 2500837.367 * (273.15/temgx(mgs))**((0.167)+(3.67e-4)*temgx(mgs)) ! temcgx(mgs) = min(temg(mgs),273.15) @@ -12112,6 +13468,7 @@ subroutine nssl_2mom_gs & tmp = qx(mgs,li)+qx(mgs,ls)+qx(mgs,lh) IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl) + IF ( lf > 1 ) tmp = tmp + qx(mgs,lf) cvm = cv+cvv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & +cpigb*(tmp) @@ -12260,14 +13617,86 @@ subroutine nssl_2mom_gs & end do + IF ( ipconc == 5 .and. imydiagalpha > 1 ) THEN + + DO mgs = 1,ngscnt + !IF ( igs(mgs) == 19 ) write(0,*) 'k,qr,qh,cr,ch = ',kgs(mgs),qx(mgs,lr),cx(mgs,lr),qx(mgs,lh),cx(mgs,lh) + IF ( qx(mgs,lr) .gt. qxmin(lr) .and. cx(mgs,lr) > cxmin ) THEN + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) ! + xdia(mgs,lr,3) = (xv(mgs,lr)*6.0*cwc1)**(1./3.) + alpha(mgs,lr) = Min(alphamax, c1r*tanh(c2r*(xdia(mgs,lr,3)*1000. - c3r)) + c4r) + ! IF ( igs(mgs) == 19 ) write(0,*) 'imy: i,k,alpr,xdia = ',igs(mgs),kgs(mgs),alpha(mgs,lr),xdia(mgs,lr,3)*1000. + ENDIF + IF ( qx(mgs,lh) .gt. qxmin(lh) .and. cx(mgs,lh) > cxmin ) THEN + xv(mgs,lh) = rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) ! + xdia(mgs,lh,3) = (xv(mgs,lh)*6.*piinv)**(1./3.) ! mwfac*xdia(mgs,lh,1) ! (xv(mgs,lh)*cwc0*6.0)**(1./3.) + alpha(mgs,lh) = Min(alphamax, c1h*tanh(c2h*(xdia(mgs,lh,3)*1000. - c3h)) + c4h) + + ! IF ( igs(mgs) == 19 ) write(0,*) 'imy: i,k,alph,xdia = ',igs(mgs),kgs(mgs),alpha(mgs,lh),xdia(mgs,lh,3)*1000. + il = lh + DO ic = lc,lh-1 ! lhab + i = Nint( alpha(mgs,il)*dqiacralphainv ) + IF ( ic == lc .or. ic == li .or. ic == ls .or. (ic == lr .and. imurain == 3) ) THEN + alp = (3.*alpha(mgs,ic) + 2.) + j = Nint( (3.*alpha(mgs,ic) + 2.)*dqiacralphainv ) + ELSE ! IF ( ic == lr .and. imurain == 1 ) ! rain + alp = alpha(mgs,ic) + j = Nint( alpha(mgs,ic)*dqiacralphainv ) + ENDIF + + dab0lh(mgs,ic,il) = dab0lu(j,i,ic,il) + dab1lh(mgs,ic,il) = dab1lu(j,i,ic,il) + dab0lh(mgs,il,ic) = dab0lu(i,j,il,ic) + dab1lh(mgs,il,ic) = dab1lu(i,j,il,ic) + ENDDO + ENDIF +! alpha(:,lr) = 0. ! 10. +! alpha(:,lh) = 0. ! 10. + IF ( lhl > 0 ) THEN + IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. cx(mgs,lhl) > cxmin ) THEN + xv(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/(xdn(mgs,lhl)*cx(mgs,lhl)) ! + xdia(mgs,lhl,3) = (xv(mgs,lhl)*6.*piinv)**(1./3.) + IF ( xdia(mgs,lhl,3) < 0.008 ) THEN + alpha(mgs,lhl) = Min(alphamax, c1hl*tanh(c2hl*(xdia(mgs,lhl,3)*1000. - c3hl)) + c4hl) + ELSE + alpha(mgs,lhl) = Min(alphamax, c5hl*xdia(mgs,lhl,3)*1000. + c6hl) + ENDIF + + il = lhl + DO ic = lc,lh-1 ! lhab + i = Nint( alpha(mgs,il)*dqiacralphainv ) + IF ( ic == lc .or. ic == li .or. ic == ls .or. (ic == lr .and. imurain == 3) ) THEN + alp = (3.*alpha(mgs,ic) + 2.) + j = Nint( (3.*alpha(mgs,ic) + 2.)*dqiacralphainv ) + ELSE ! IF ( ic == lr .and. imurain == 1 ) ! rain + alp = alpha(mgs,ic) + j = Nint( alpha(mgs,ic)*dqiacralphainv ) + ENDIF + + dab0lh(mgs,ic,il) = dab0lu(j,i,ic,il) + dab1lh(mgs,ic,il) = dab1lu(j,i,ic,il) + dab0lh(mgs,il,ic) = dab0lu(i,j,il,ic) + dab1lh(mgs,il,ic) = dab1lu(i,j,il,ic) + ENDDO + + ENDIF + ENDIF + + + + ENDDO + ENDIF + IF ( imurain == 3 ) THEN IF ( lzr > 1 ) THEN alphashr = 0.0 alphamlr = -2.0/3.0 + alphasmlr = -2.0/3.0 ELSE alphashr = xnu(lr) alphamlr = xnu(lr) + alphasmlr = xnu(lr) ENDIF ! massfacshr = ( (2. + 3.*(1. +alphashr) )/( 3.*(1. + alphashr) ) )**(1./3.) ! this is the diameter factor ! massfacmlr = ( (2. + 3.*(1. +alphamlr) )/( 3.*(1. + alphamlr) ) )**(1./3.) @@ -12277,9 +13706,11 @@ subroutine nssl_2mom_gs & IF ( lzr > 1 ) THEN alphashr = 4.0 alphamlr = 4.0 + alphasmlr = alphasmlr0 ELSE alphashr = alphar alphamlr = alphar + alphasmlr = alphar ENDIF ! massfacshr = (3.0 + alphashr)*((3.+alphashr)*(2.+alphashr)*(1. + alphashr) )**(-1./3.) ! this is the diameter factor ! massfacmlr = (3.0 + alphamlr)*((3.+alphamlr)*(2.+alphamlr)*(1. + alphamlr) )**(-1./3.) @@ -12287,110 +13718,819 @@ subroutine nssl_2mom_gs & massfacmlr = (3.0 + alphamlr)**3/((3.+alphamlr)*(2.+alphamlr)*(1. + alphamlr) ) ENDIF +! Find shape parameter rain -! -! set some values for ice nucleation -! - do mgs = 1,ngscnt - kp1 = Min(nz, kgs(mgs)+1 ) -! wvel(mgs) = (0.5)*(w(igs(mgs),jgs,kp1) & -! & +w(igs(mgs),jgs,kgs(mgs))) + g1shr = 1.0 + g1mlr = 1.0 + g1smlr = 1.0 + +! CALL cld_cpu('Z-MOMENT-1') + + ! set base g1x in case rain is not 3-moment + IF ( ipconc >= 6 .and. imurain == 3 ) THEN + il = lr + DO mgs = 1,ngscnt +! g1x(mgs,il) = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + g1x(mgs,il) = (alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)) + ENDDO + ENDIF + IF (lzr > 1 ) THEN + IF ( imurain == 3 ) THEN + g1shr = (alphashr+2.0)/((alphashr+1.0)) + g1mlr = (alphamlr+2.0)/((alphamlr+1.0)) + g1smlr = (alphasmlr+2.0)/((alphasmlr+1.0)) + ELSEIF ( imurain == 1 ) THEN +! g1shr = 36.*(6.0 + alphashr)*(5.0 + alphashr)*(4.0 + alphashr)/ & +! & (pi**2*(3.0 + alphashr)*(2.0 + alphashr)*(1.0 + alphashr)) + g1shr = (6.0 + alphashr)*(5.0 + alphashr)*(4.0 + alphashr)/ & + & ((3.0 + alphashr)*(2.0 + alphashr)*(1.0 + alphashr)) +! g1mlr = 36.*(6.0 + alphamlr)*(5.0 + alphamlr)*(4.0 + alphamlr)/ & +! & (pi**2*(3.0 + alphamlr)*(2.0 + alphamlr)*(1.0 + alphamlr)) + g1mlr = (6.0 + alphamlr)*(5.0 + alphamlr)*(4.0 + alphamlr)/ & + & ((3.0 + alphamlr)*(2.0 + alphamlr)*(1.0 + alphamlr)) + g1smlr = (6.0 + alphasmlr)*(5.0 + alphasmlr)*(4.0 + alphasmlr)/ & + & ((3.0 + alphasmlr)*(2.0 + alphasmlr)*(1.0 + alphasmlr)) + ENDIF + ENDIF + + IF ( lzr > 1 .and. imurain == 3 ) THEN ! { RAIN SHAPE PARAM - wvelkm1(mgs) = (0.5)*(w(igs(mgs),jgs,kgs(mgs)) & - & +w(igs(mgs),jgs,kgsm(mgs))) - cninm(mgs) = t7(igs(mgs),jgs,kgsm(mgs)) - cnina(mgs) = t7(igs(mgs),jgs,kgs(mgs)) - cninp(mgs) = t7(igs(mgs),jgs,kgsp(mgs)) - end do + +! CALL cld_cpu('Z-MOMENT-1r') + il = lr + DO mgs = 1,ngscnt + -! -! Set a couple of cloud variables... -! + IF ( iresetmoments == 1 .or. iresetmoments == il .or. iresetmoments == -1 ) THEN ! .or. qx(mgs,il) <= qxmin(il) THEN + IF ( zx(mgs,il) <= zxmin ) THEN ! .and. qx(mgs,il) > 0.05e-3 THEN +!! write(91,*) 'zx=0; qx,cx = ',1000.*qx(mgs,il),cx(mgs,il) + qx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ELSEIF ( iresetmoments == -1 .and. qx(mgs,il) < qxmin(il) ) THEN + zx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + ELSEIF ( cx(mgs,il) <= cxmin .and. iresetmoments /= -1 ) THEN ! .and. qx(mgs,il) > 0.05e-3 THEN + + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il) + zx(mgs,lr) = 0.0 + qx(mgs,lr) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),lr) + an(igs(mgs),jgs,kgs(mgs),lr) = qx(mgs,lr) + an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr) + ENDIF + ENDIF -! SUBROUTINE setvt(ngscnt,qx,qxmin,cx,rho0,rhovt,xdia,cno, -! : xmas,xdn,xvmn,xvmx,xv,cdx, -! : ipconc,ndebug) -! SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno, & -! & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx, & -! & ipconc1,ndebug1,ngs,nz,kgs,cwnccn,fadvisc, & -! & cwmasn,cwmasx,cwradn,cnina,cimna,cimxa, & -! & itype1a,itype2a,temcg,infdo,alpha) + IF ( .false. .and. zx(mgs,il) <= zxmin .and. cx(mgs,il) <= cxmin ) THEN + zx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + ENDIF + + IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN - infdo = 0 - IF ( rimdenvwgt > 0 ) infdo = 1 + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-11,cx(mgs,lr))) + IF ( xv(mgs,lr) .gt. xvmx(lr) ) THEN +! xv(mgs,lr) = xvmx(lr) +! cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmx(lr)*xdn(mgs,lr)) + ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN + xv(mgs,lr) = xvmn(lr) + cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr)) + ENDIF - call setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & - & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx,cdxgs, & - & ipconc,ndebug,ngs,nz,kgs,fadvisc, & - & cwmasn,cwmasx,cwradn,cnina,cimn,cimx, & - & itype1,itype2,temcg,infdo,alpha,0,axx,bxx) ! ,cdh,cdhl) -! & itype1,itype2,temcg,infdo,alpha,0,axh,bxh,axhl,bxhl) ! ,cdh,cdhl) + IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN +! have mass and reflectivity but no concentration, so set concentration, using default alpha + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + z = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*xdn(mgs,lr)**2) +! an(igs(mgs),jgs,kgs(mgs),ln(il)) = zx(mgs,il) + ELSEIF ( zx(mgs,il) <= 0.0 .and. cx(mgs,il) > 0.0 ) THEN +! have mass and concentration but no reflectivity, so set reflectivity, using default alpha + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + chw = cx(mgs,il) + qr = qx(mgs,il) + zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(xdn(mgs,lr)**2*chw) + an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr) + + ELSEIF ( zx(mgs,il) <= 0.0 .and. cx(mgs,il) <= 0.0 ) THEN +! How did this happen? + ! set values according to dBZ of -10, or Z = 0.1 +! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 + zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2 + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + z = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*1000.*1000) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ENDIF + + IF ( zx(mgs,lr) > 0.0 ) THEN + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(1000.*cx(mgs,lr)) + vr = xv(mgs,lr) +! z = 36.*(alpha(kz)+2.0)*a(ix,jy,kz,lnr)*vr**2/((alpha(kz)+1.0)*pi**2) + qr = qx(mgs,lr) + nrx = cx(mgs,lr) + z = zx(mgs,lr) + +! xv = (db(1,kz)*a(1,1,kz,lr))**2/(a(1,1,kz,lnr)) +! rd = z*(pi/6.*1000.)**2/xv + +! determine shape parameter alpha by iteration + IF ( z .gt. 0.0 ) THEN +! alpha(mgs,lr) = 3. + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. +! print*,'kz, alp, alpha(kz) = ',kz,alp,alpha(kz),rd,z,xv + DO i = 1,20 + IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT + alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) ) + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. + alp = Max( rnumin, Min( rnumax, alp ) ) + ENDDO +! check for artificial breakup (rain larger than allowed max size) + IF ( (xv(mgs,il) .gt. xvmx(il) .or. (ioldlimiter >= 2 .and. xv(mgs,il) .gt. xvmx(il)/8.) )) THEN + tmp = cx(mgs,il) + IF ( ioldlimiter >= 2 ) THEN ! MY-style active breakup + x = (6.*rho0(mgs)*qx(mgs,il)/(pi*xdn(mgs,il)*cx(mgs,il)))**(1./3.) + x1 = Max(0.0e-3, x - 3.0e-3) + x2 = Max(0.5, x/6.0e-3) + x3 = x2**3 + cx(mgs,il) = cx(mgs,il)*Max((1.+2.222e3*x1**2), x3) + xv(mgs,il) = xv(mgs,il)/Max((1.+2.222e3*x1**2), x3) + ELSE ! simple cutoff + xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) ) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) + ENDIF + !xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + !cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) - IF ( lwsm6 .and. ipconc == 0 ) THEN - tmp = Max(qxmin(lh), qxmin(ls)) - DO mgs = 1,ngscnt - sum = qx(mgs,lh) + qx(mgs,ls) - IF ( sum > tmp ) THEN - vt2ave(mgs) = (qx(mgs,lh)*vtxbar(mgs,lh,1) + qx(mgs,ls)*vtxbar(mgs,ls,1))/sum - ELSE - vt2ave(mgs) = 0.0 - ENDIF - ENDDO - ENDIF + IF ( tmp < cx(mgs,il) ) THEN ! breakup + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) ) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) -! -! Set number concentrations (need xdia from setvt) -! - if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: Set concentration' - IF ( ipconc .lt. 1 ) THEN - cina(1:ngscnt) = cx(1:ngscnt,li) - ENDIF - if ( ipconc .lt. 5 ) then - do mgs = 1,ngscnt + vr = xv(mgs,lr) + qr = qx(mgs,lr) + nrx = cx(mgs,lr) + z = zx(mgs,lr) - IF ( ipconc .lt. 3 ) THEN -! cx(mgs,lr) = 0.0 - if ( qx(mgs,lr) .gt. qxmin(lh) ) then -! cx(mgs,lr) = cno(lr)*xdia(mgs,lr,1) -! xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) - end if - ENDIF +! determine shape parameter alpha by iteration + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. + DO i = 1,20 + IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT + alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) ) + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. + alp = Max( rnumin, Min( rnumax, alp ) ) + ENDDO - IF ( ipconc .lt. 4 ) THEN -! tmp = cx(mgs,ls) -! cx(mgs,ls) = 0.0 - if ( qx(mgs,ls) .gt. qxmin(ls) ) then -! cx(mgs,ls) = cno(ls)*xdia(mgs,ls,1) -! xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*cx(mgs,ls)) - end if - ENDIF ! ( ipconc .lt. 4 ) + + ENDIF + ENDIF - IF ( ipconc .lt. 5 ) THEN +! +! Check whether the shape parameter is at or less than the minimum, and if it is, reset the +! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N) +! + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + IF ( .true. .and. (alpha(mgs,il) <= rnumin .or. alp == rnumin .or. alp == rnumax) ) THEN + IF ( rescale_high_alpha .and. alp >= rnumax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(1./(xdn(mgs,il)))**2 + an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il) + + ELSEIF ( rescale_low_alphar .and. alp <= rnumin ) THEN + z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2) + zx(mgs,il) = z + an(igs(mgs),jy,kgs(mgs),lz(il)) = zx(mgs,il) + ENDIF + ENDIF + + ! set g1x to use as G factor later. If alpha is in the range ( rnumin < alpha < rnumax ), then + ! this will be the same as computing G from alpha. If alpha = rnumax, however, it probably means that + ! the moments are not matched correctly, so we compute G from the moments instead so that the dZ/dt rates + ! stay consistent with dN/dt and dq/dt. + IF ( alp >= rnumax - 0.01 ) THEN +! g1x(mgs,il) = 6**2*zx(mgs,il)/(cx(mgs,il)*(pi*xv(mgs,lr))**2) +! g1x(mgs,il) = xdn(mgs,il)*zx(mgs,il)*cx(mgs,il)/((rho0(mgs)*qx(mgs,lr))**2) + g1x(mgs,il) = (pi*xdn(mgs,il))**2*zx(mgs,il)*cx(mgs,il)/((6.*rho0(mgs)*qx(mgs,il))**2) + ELSE + g1x(mgs,il) = g1 + ENDIF + + tmp = alpha(mgs,lr) + 4./3. + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = alpha(mgs,lr) + 1. + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + gf1palp(mgs) = y -! cx(mgs,lh) = 0.0 - if ( qx(mgs,lh) .gt. qxmin(lh) ) then -! cx(mgs,lh) = cno(lh)*xdia(mgs,lh,1) -! xv(mgs,lh) = Max(xvmn(lh), rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) ) -! xdia(mgs,lh,3) = (xv(mgs,lh)*6./pi)**(1./3.) - end if +! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 4./3.)/(alpha(mgs,lr) + 1.)**(1./3.)/Gamma_sp(alpha(mgs,lr) + 1.) + ventrx(mgs) = x/(y*(alpha(mgs,lr) + 1.)**(1./3.)) - ENDIF ! ( ipconc .lt. 5 ) + IF ( imurain == 3 .and. izwisventr == 2 ) THEN - end do - end if - - IF ( ipconc .ge. 2 ) THEN - DO mgs = 1,ngscnt - - rb(mgs) = 0.5*xdia(mgs,lc,1)*(1./(1.+alpha(mgs,lc)))**(1./6.) - xl2p(mgs) = Max(0.0d0, 2.7e-2*xdn(mgs,lc)*cx(mgs,lc)*xv(mgs,lc)* & - & ((0.5e20*rb(mgs)**3*xdia(mgs,lc,1))-0.4) ) + tmp = alpha(mgs,lr) + 1.5 + br/6. + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 1.5 + br/6.)/Gamma_sp(alpha(mgs,lr) + 1.) + ventrxn(mgs) = x/(y*(alpha(mgs,lr) + 1.)**((1.+br)/6. + 1./3.)) + +! This whole section is imurain == 3, so this branch never runs +! ELSEIF ( imurain == 1 .and. iferwisventr == 2 ) THEN +! +! tmp = alpha(mgs,lr) + 2.5 + br/2. +! i = Int(dgami*(tmp)) +! del = tmp - dgam*i +! x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami +! +!! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 1.5 + br/6.)/Gamma_sp(alpha(mgs,lr) + 1.) +! ventrxn(mgs) = x/y + + + ENDIF + + ENDIF + ENDIF + + ENDIF + + ENDDO +! CALL cld_cpu('Z-MOMENT-1r') + ENDIF ! } + + +! Find shape parameters for graupel and hail + IF ( ipconc .ge. 6 ) THEN + + DO il = lr,lhab + + ! set base values of g1x + IF ( (.not. ( il == lr .and. imurain == 3 )) .and. ( il == lr .or. il == lh .or. il == lhl .or. il == lf ) ) THEN + DO mgs = 1,ngscnt + g1x(mgs,il) = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + ENDDO + ENDIF + + IF ( lz(il) .gt. 1 .and. ( .not. ( il == lr .and. imurain == 3 )) ) THEN + + DO mgs = 1,ngscnt + + + IF ( iresetmoments == 1 .or. iresetmoments == il .or. iresetmoments == -1 ) THEN ! .or. qx(mgs,il) <= qxmin(il) ) THEN + IF ( zx(mgs,il) <= zxmin ) THEN ! .and. qx(mgs,il) > 0.05e-3 ) THEN +!! write(91,*) 'zx=0; qx,cx = ',1000.*qx(mgs,il),cx(mgs,il) + qx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + zx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + ELSEIF ( iresetmoments == -1 .and. qx(mgs,il) < qxmin(il) ) THEN + zx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + ELSEIF ( cx(mgs,il) <= cxmin .and. iresetmoments /= -1 ) THEN ! .and. qx(mgs,il) > 0.05e-3 ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il) + zx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ENDIF + ENDIF + + IF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= cxmin ) THEN + zx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + ENDIF + + IF ( qx(mgs,il) .gt. qxmin(il) ) THEN + + xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(1.0e-9,cx(mgs,il))) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + + IF ( xv(mgs,il) .lt. xvmn(il) ) THEN + xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) ) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) + ENDIF + + IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN +! have mass and reflectivity but no concentration, so set concentration, using default alpha + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + z = zx(mgs,il) + qr = qx(mgs,il) +! cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(z*(pi*xdn(mgs,il))**2) + + ELSEIF ( zx(mgs,il) <= 0.0 .and. cx(mgs,il) > cxmin ) THEN +! have mass and concentration but no reflectivity, so set reflectivity, using default alpha +! g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & +! & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + chw = cx(mgs,il) + qr = qx(mgs,il) +! zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw +! zx(mgs,il) = Min(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(chw*(pi*xdn(mgs,il))**2) ) + g1 = (6.0 + alphamax)*(5.0 + alphamax)*(4.0 + alphamax)/ & + & ((3.0 + alphamax)*(2.0 + alphamax)*(1.0 + alphamax)) + zx(mgs,il) = Max(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(chw*(pi*xdn(mgs,il))**2) ) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + ELSEIF ( zx(mgs,il) <= 0.0 .and. cx(mgs,il) <= 0.0 ) THEN +! How did this happen? + ! set values according to dBZ of -10, or Z = 0.1 +! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 + zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2 + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + z = zx(mgs,il) + qr = qx(mgs,il) +! cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(z*(pi*xdn(mgs,il))**2) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ELSE + + chw = cx(mgs,il) + qr = qx(mgs,il) + z = zx(mgs,il) + + IF ( zx(mgs,il) .gt. 0. ) THEN + +! rdi = z*(pi/6.*1000.)**2*chw/((rho0(mgs)*qr)**2) + rdi = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2) + +! alp = 1.e18*(6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ +! : ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 + alp = (6.0+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 +! print*,'kz, alp, alpha(mgs,il) = ',kz,alp,alpha(mgs,il),rdi,z,xv + alp = Max( alphamin, Min( alphamax, alp ) ) + + IF ( newton ) THEN + DO i = 1,10 + IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT + alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) ) + alp = alp + ( galpha(alp) - rdi )/dgalpha(alp) + alp = Max( alphamin, Min( alphamax, alp ) ) + ENDDO + + ELSE + DO i = 1,10 +! IF ( 100.*Abs(alp - alpha(mgs,il))/(Abs(alpha(mgs,il))+1.e-5) .lt. 1. ) EXIT + IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT + alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) ) +! alp = 1.e18*(6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ +! : ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 + alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 +! print*,'i,alp = ',i,alp + alp = Max( alphamin, Min( alphamax, alp ) ) + ENDDO + ENDIF + + +! check for artificial breakup (graupel/hail larger than allowed max size) + IF ( imaxdiaopt == 1 ) THEN + xvbarmax = xvmx(il) + ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter + xvbarmax = xvmx(il) /((3. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il)))) + ELSEIF ( imaxdiaopt == 3 ) THEN ! test against mass-weighted diameter + xvbarmax = xvmx(il) /((4. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il)))) + ELSE + xvbarmax = xvmx(il) + ENDIF + + IF ( xv(mgs,il) .gt. xvbarmax .or. (il == lr .and. ioldlimiter >= 2 .and. xv(mgs,il) .gt. xvmx(il)/8.)) THEN + tmp = cx(mgs,il) + IF( ioldlimiter >= 2 .and. il == lr) THEN ! MY-style drop limiter for rain + x = (6.*rho0(mgs)*qx(mgs,il)/(pi*xdn(mgs,il)*cx(mgs,il)))**(1./3.) + x1 = Max(0.0e-3, x - 3.0e-3) + x2 = Max(0.5, x/6.0e-3) + x3 = x2**3 + cx(mgs,il) = cx(mgs,il)*Max((1.+2.222e3*x1**2), x3) + xv(mgs,il) = xv(mgs,il)/Max((1.+2.222e3*x1**2), x3) + ELSE + xv(mgs,il) = Min( xvbarmax, Max( xvmn(il),xv(mgs,il) ) ) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) + ENDIF + IF ( tmp < cx(mgs,il) ) THEN ! artificial breakup has happened, so need to adjust reflectivity and find new shape parameter + g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2) + zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) ) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + chw = cx(mgs,il) + qr = qx(mgs,il) + z = zx(mgs,il) + + rdi = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2) + alp = (6.0+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 + DO i = 1,10 + IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT + alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) ) + alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 + alp = Max( alphamin, Min( alphamax, alp ) ) + ENDDO + + + ENDIF + ENDIF + +! +! Check whether the shape parameter is at or less than the minimum, and if it is, reset the +! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N) +! + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + + IF ( ( lrescalelow(il) .or. rescale_high_alpha ) .and. & + & ( alpha(mgs,il) <= alphamin .or. alp == alphamin .or. alp == alphamax ) ) THEN + + + + IF ( rescale_high_alpha .and. alp >= alphamax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2 + an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il) + + ELSEIF ( lrescalelow(il) .and. alp <= alphamin .and. .not. (il == lh .and. icvhl2h > 0 ) .and. & + .not. ( il == lr .and. .not. rescale_low_alphar ) ) THEN ! alpha = alphamin, so reset Z to prevent growth in C + wtest = .false. + IF ( irescalerainopt == 0 ) THEN + wtest = .false. + ELSEIF ( irescalerainopt == 1 ) THEN + wtest = qx(mgs,lc) > qxmin(lc) + ELSEIF ( irescalerainopt == 2 ) THEN + wtest = qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < rescale_wthresh + ELSEIF ( irescalerainopt == 3 ) THEN + wtest = temcg(mgs) > rescale_tempthresh .and. qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < rescale_wthresh + ENDIF + + IF ( il == lr .and. ( wtest ) ) THEN +! IF ( temcg(mgs) > 0.0 .and. il == lr .and. qx(mgs,lc) > qxmin(lc) ) THEN + ! certain situations where rain number is adjusted instead of Z. Helps avoid rain being 'zapped' by autoconverted + ! drops (i.e., favor preserving Z when alpha tries to go negative) + chw = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2 ! g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z1 + cx(mgs,il) = chw + an(igs(mgs),jy,kgs(mgs),ln(il)) = chw + ELSE + + ! Usual resetting of reflectivity moment to force consisntency between Q, N, Z, and alpha when alpha = alphamin + z1 = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw + z = z1*(6./(pi*xdn(mgs,il)))**2 + zx(mgs,il) = z + an(igs(mgs),jy,kgs(mgs),lz(il)) = z + ENDIF + ENDIF + ENDIF + + + ! set g1x to use as G factor later. If alpha is in the range ( rnumin < alpha < rnumax ), then + ! this will be the same as computing G from alpha. If alpha = rnumax, however, it probably means that + ! the moments are not matched correctly, so we compute G from the moments instead so that the dZ/dt rates + ! stay consistent with dN/dt and dq/dt. +! g1x(mgs,il) = zx(mgs,il)*chw*(pi*xdn(mgs,il))**2/(6.*qr*dn(igs(mgs),jy,kgs(mgs)))**2 +! g1x(mgs,il) = g1 ! zx(mgs,il)*cx(mgs,il)/(qr)**2 + IF ( alp >= alphamax - 0.5 ) THEN +! g1x(mgs,il) = 6**2*zx(mgs,il)/(cx(mgs,il)*(pi*xv(mgs,lr))**2) +! g1x(mgs,il) = (xdn(mgs,il))**2*zx(mgs,il)*cx(mgs,il)/((rho0(mgs)*qx(mgs,il))**2) + g1x(mgs,il) = (pi*xdn(mgs,il))**2*zx(mgs,il)*cx(mgs,il)/((6.*rho0(mgs)*qx(mgs,il))**2) + ELSE + g1x(mgs,il) = g1 + ENDIF + + ENDIF + +! IF ( ny .eq. 2 ) THEN +! IF ( qr .gt. 1.e-3 ) THEN +! write(0,*) 'alphah at nstep,i,k = ',dtp*(nstep-1),igs(mgs),kgs(mgs),alpha(mgs,il),qr*1000. +! ENDIF +! ENDIF + + + ENDIF ! .true. + + IF ( il == lr ) THEN + +! tmp = alpha(mgs,lr) + 4./3. +! i = Int(dgami*(tmp)) +! del = tmp - dgam*i +! x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami +! +! tmp = alpha(mgs,lr) + 1. +! i = Int(dgami*(tmp)) +! del = tmp - dgam*i +! y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami +! +!! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 4./3.)/(alpha(mgs,lr) + 1.)**(1./3.)/Gamma_sp(alpha(mgs,lr) + 1.) +! ventrx(mgs) = x/(y*(alpha(mgs,lr) + 1.)**(1./3.)) + + + tmp = alpha(mgs,lr) + 1. + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + gf1palp(mgs) = y + + IF ( iferwisventr == 2 ) THEN + tmp = alpha(mgs,lr) + 2.5 + br/2. + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 1.5 + br/6.)/Gamma_sp(alpha(mgs,lr) + 1.) + + ventrxn(mgs) = x/y + + ENDIF + + ENDIF ! il==lr + + + ELSE ! below mass threshold +! g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ +! & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) +! z1 = g1*rho0(mgs)**2*(qr)*qr/chw +! z = 1.e18*z1*(6./(pi*1000.))**2 +! z = z1*(6./(pi*1000.))**2 +! zx(mgs,il) = z +! an(igs(mgs),jy,kgs(mgs),lz(il)) = z + ENDIF ! ( qx(mgs,il) .gt. qxmin(il) ) + + + +! ENDIF + ENDDO ! mgs + +! CALL cld_cpu('Z-DELABK') + +! IF ( il == lr ) THEN +! xnutmp = (alpha(mgs,il) - 2.)/3. +! da0lr(mgs) = delbk(bb(il), xnutmp, xmu(il), 0) +! ENDIF + + IF ( .not. ( il == lr .and. imurain == 3 ) ) THEN +! CALL cld_cpu('Z-DELABK') + DO mgs = 1,ngscnt + IF ( qx(mgs,il) > qxmin(il) ) THEN + xnutmp = (alpha(mgs,il) - 2.)/3. + +! IF ( .true. ) THEN + DO ic = lc,lh-1 ! lhab + IF ( il .ne. ic .and. qx(mgs,ic) .gt. qxmin(ic)) THEN + xnuc = xnu(ic) + IF ( ic == lc .and. idiagnosecnu > 0 ) xnuc = alpha(mgs,lc) ! alpha for droplets is actually nu + IF ( il /= lr .and. ic == lr .and. lzr > 1 ) THEN + IF ( imurain == 3 ) THEN + xnuc = alpha(mgs,lr) ! alpha is nu already + ELSE + xnuc = ( alpha(mgs,lr) - 2. )/3. ! convert alpha to nu + ENDIF + ENDIF + ! delabk(ba,bb,nua,nub,mua,mub,k), where a (il) is collector and b (ic) is collected + IF ( .false. ) THEN + dab0lh(mgs,ic,il) = delabk(bb(ic), bb(il), xnuc, xnutmp, xmu(ic), xmu(il), 0) !dab0(il,ic) + dab1lh(mgs,ic,il) = delabk(bb(ic), bb(il), xnuc, xnutmp, xmu(ic), xmu(il), 1) !dab1(il,ic) + dab0lh(mgs,il,ic) = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic), 0) !dab0(il,ic) + dab1lh(mgs,il,ic) = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic), 1) !dab1(il,ic) + ELSE ! use lookup table -- not interpolating yet because table resolution of 0.05 is good enough + i = Nint( alpha(mgs,il)*dqiacralphainv ) + IF ( ic == lc .or. ic == li .or. ic == ls .or. (ic == lr .and. imurain == 3) ) THEN + alp = (3.*alpha(mgs,ic) + 2.) + j = Nint( (3.*alpha(mgs,ic) + 2.)*dqiacralphainv ) + ELSE ! IF ( ic == lr .and. imurain == 1 ) ! rain + alp = alpha(mgs,ic) + j = Nint( alpha(mgs,ic)*dqiacralphainv ) + ENDIF + + dab0lh(mgs,ic,il) = dab0lu(j,i,ic,il) + dab1lh(mgs,ic,il) = dab1lu(j,i,ic,il) + dab0lh(mgs,il,ic) = dab0lu(i,j,il,ic) + dab1lh(mgs,il,ic) = dab1lu(i,j,il,ic) + +! tmp1 = dab0lu(j,i,ic,il) +! tmp2 = dab1lu(j,i,ic,il) +! tmp3 = dab0lu(i,j,il,ic) +! tmp4 = dab1lu(i,j,il,ic) +! tmp5 = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(ic), xmu(il), 0) !dab0(il,ic) +! tmp6 = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(ic), xmu(il), 1) !dab1(il,ic) +! tmp5 = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic), 0) !dab0(il,ic) +! tmp6 = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic), 1) !dab1(il,ic) + + IF ( .false. .and. ny <= 2 ) THEN + write(0,*) + write(0,*) 'bb: ', bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic) + write(0,*) 'il,ic = ',il,ic,alpha(mgs,il),i,xnuc,alp,j + write(0,*) 'dab0lh,tmp1 = ',dab0lh(mgs,ic,il),tmp1 + write(0,*) 'dab1lh,tmp2 = ',dab1lh(mgs,ic,il),tmp2 + write(0,*) 'dab0lh,tmp3 = ',dab0lh(mgs,il,ic),tmp3,tmp5 + write(0,*) 'dab1lh,tmp4 = ',dab1lh(mgs,il,ic),tmp4,tmp6 + + ENDIF + + ENDIF + + ENDIF + ENDDO + +! ENDIF + + da0lx(mgs,il) = delbk(bb(il), xnutmp, xmu(il), 0) + IF ( il .eq. lh ) THEN + da0lh(mgs) = delbk(bb(il), xnutmp, xmu(il), 0) + IF ( lzr > 1 ) THEN + rzxh(mgs) = 1. + ELSE + rzxh(mgs) = ((4. + alpha(mgs,il))*(5. + alpha(mgs,il))*(6. + alpha(mgs,il))*(1. + xnu(lr)))/ & + & ((1. + alpha(mgs,il))*(2. + alpha(mgs,il))*(3. + alpha(mgs,il))*(2. + xnu(lr))) + ENDIF + + IF ( lzhl < 1 ) THEN + rzxhlh(mgs) = rzxhl(mgs)/(((4. + alpha(mgs,il))*(5. + alpha(mgs,il))*(6. + alpha(mgs,il))*(1. + xnu(lr)))/ & + & ((1. + alpha(mgs,il))*(2. + alpha(mgs,il))*(3. + alpha(mgs,il))*(2. + xnu(lr)))) + ENDIF + ELSEIF ( il .eq. lhl ) THEN + da0lhl(mgs) = delbk(bb(il), xnutmp, xmu(il), 0) + IF ( lzr > 1 ) THEN + rzxhl(mgs) = 1. + ELSE + rzxhl(mgs) = ((4.0 + alpha(mgs,il))*(5. + alpha(mgs,il))*(6. + alpha(mgs,il))*(1. + xnu(lr)))/ & + & ((1. + alpha(mgs,il))*(2. + alpha(mgs,il))*(3. + alpha(mgs,il))*(2. + xnu(lr))) + ENDIF + ELSEIF ( il == lr ) THEN + xnutmp = (alpha(mgs,il) - 2.)/3. + da0lr(mgs) = delbk(bb(il), xnutmp, xmu(il), 0) + da1lr(mgs) = delbk(bb(il), xnutmp, xmu(il), 1) + ENDIF + + ENDIF ! ( qx(mgs,il) > qxmin(il) ) + ENDDO ! mgs +! CALL cld_cpu('Z-DELABK') + ENDIF ! il /= lr + +! CALL cld_cpu('Z-DELABK') + + ENDIF ! lz(il) .gt. 1 + + ENDDO ! il + + ENDIF ! ipconc .ge. 6 + +! CALL cld_cpu('Z-MOMENT-1') + +! +! set some values for ice nucleation +! + do mgs = 1,ngscnt + kp1 = Min(nz, kgs(mgs)+1 ) +! wvel(mgs) = (0.5)*(w(igs(mgs),jgs,kp1) & +! & +w(igs(mgs),jgs,kgs(mgs))) + + + wvelkm1(mgs) = (0.5)*(w(igs(mgs),jgs,kgs(mgs)) & + & +w(igs(mgs),jgs,kgsm(mgs))) + cninm(mgs) = t7(igs(mgs),jgs,kgsm(mgs)) + cnina(mgs) = t7(igs(mgs),jgs,kgs(mgs)) + cninp(mgs) = t7(igs(mgs),jgs,kgsp(mgs)) + end do + +! +! Set a couple of cloud variables... +! + +! SUBROUTINE setvt(ngscnt,qx,qxmin,cx,rho0,rhovt,xdia,cno, +! : xmas,xdn,xvmn,xvmx,xv,cdx, +! : ipconc,ndebug) +! SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno, & +! & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx, & +! & ipconc1,ndebug1,ngs,nz,kgs,cwnccn,fadvisc, & +! & cwmasn,cwmasx,cwradn,cnina,cimna,cimxa, & +! & itype1a,itype2a,temcg,infdo,alpha) + + + infdo = 1 + IF ( rimdenvwgt > 0 ) infdo = 1 + + call setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & + & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx,cdxgs, & + & ipconc,ndebug,ngs,nz,kgs,fadvisc, & + & cwmasn,cwmasx,cwradn,cnina,cimn,cimx, & + & itype1,itype2,temcg,infdo,alpha,0,axx,bxx) ! ,cdh,cdhl) +! & itype1,itype2,temcg,infdo,alpha,0,axh,bxh,axhl,bxhl) ! ,cdh,cdhl) + + + IF ( lwsm6 .and. ipconc == 0 ) THEN + tmp = Max(qxmin(lh), qxmin(ls)) + DO mgs = 1,ngscnt + total = qx(mgs,lh) + qx(mgs,ls) + IF ( total > tmp ) THEN + vt2ave(mgs) = (qx(mgs,lh)*vtxbar(mgs,lh,1) + qx(mgs,ls)*vtxbar(mgs,ls,1))/total + ELSE + vt2ave(mgs) = 0.0 + ENDIF + ENDDO + ENDIF + + +! +! Set number concentrations (need xdia from setvt) +! + if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: Set concentration' + IF ( ipconc .lt. 1 ) THEN + cina(1:ngscnt) = cx(1:ngscnt,li) + ENDIF + if ( ipconc .lt. 5 ) then + do mgs = 1,ngscnt + + + IF ( ipconc .lt. 3 ) THEN +! cx(mgs,lr) = 0.0 + if ( qx(mgs,lr) .gt. qxmin(lh) ) then +! cx(mgs,lr) = cno(lr)*xdia(mgs,lr,1) +! xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) + end if + ENDIF + + IF ( ipconc .lt. 4 ) THEN +! tmp = cx(mgs,ls) +! cx(mgs,ls) = 0.0 + if ( qx(mgs,ls) .gt. qxmin(ls) ) then +! cx(mgs,ls) = cno(ls)*xdia(mgs,ls,1) +! xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*cx(mgs,ls)) + end if + ENDIF ! ( ipconc .lt. 4 ) + + IF ( ipconc .lt. 5 ) THEN + + +! cx(mgs,lh) = 0.0 + if ( qx(mgs,lh) .gt. qxmin(lh) ) then +! cx(mgs,lh) = cno(lh)*xdia(mgs,lh,1) +! xv(mgs,lh) = Max(xvmn(lh), rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) ) +! xdia(mgs,lh,3) = (xv(mgs,lh)*6./pi)**(1./3.) + end if + + ENDIF ! ( ipconc .lt. 5 ) + + end do + end if + + IF ( ipconc .ge. 2 ) THEN + DO mgs = 1,ngscnt + + rb(mgs) = 0.5*xdia(mgs,lc,1)*(1./(1.+alpha(mgs,lc)))**(1./6.) + xl2p(mgs) = Max(0.0d0, 2.7e-2*xdn(mgs,lc)*cx(mgs,lc)*xv(mgs,lc)* & + & ((0.5e20*rb(mgs)**3*xdia(mgs,lc,1))-0.4) ) IF ( rb(mgs) .gt. 3.51e-6 ) THEN ! rh(mgs) = Max( 0.5d0*xdia(mgs,lc,1), 6.3d-4/(1.d6*(rb(mgs) - 3.5d-6)) ) rh(mgs) = Max( 41.d-6, 6.3d-4/(1.d6*(rb(mgs) - 3.5d-6)) ) @@ -12480,6 +14620,17 @@ subroutine nssl_2mom_gs & + IF ( ipconc >= 6 ) THEN + frac = 0.4d0 + zxmxd(:,:) = 0.0 + DO il = lr,lhab + IF ( lz(il) > 0 .or. ( il == lr ) ) THEN + DO mgs = 1,ngscnt + zxmxd(mgs,il) = frac*zx(mgs,il)*dtpinv + ENDDO + ENDIF + ENDDO + ENDIF @@ -12517,10 +14668,10 @@ subroutine nssl_2mom_gs & vshdgs(mgs,il) = vshd ! base value - IF ( qx(mgs,il) > qxmin(il) ) THEN + IF ( qx(mgs,il) > qxmin(il) .and. ivshdgs > 0 ) THEN ! tmpdiam is weighted diameter of d^(shedalp-1), so for shedalp=3, this is the area-weighted diameter or maximum mass diameter. - tmpdiam = (shedalp+alpha(mgs,il))*xdia(mgs,il,1)*( xdn(mgs,il)/917. )**(1./3.) ! erm added density factor for equiv. solid ice sphere 10.12.2015 + tmpdiam = (shedalp+alpha(mgs,il))*xdia(mgs,il,1) ! *( xdn(mgs,il)/917. )**(1./3.) ! erm added density factor for equiv. solid ice sphere 10.12.2015 IF ( tmpdiam > sheddiam0 ) THEN vshdgs(mgs,il) = 0.523599*(1.5e-3)**3/massfacshr ! 1.5mm drops from very large ice @@ -12577,6 +14728,7 @@ subroutine nssl_2mom_gs & ers(mgs) = 0.0 ess(mgs) = 0.0 ehs(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehs*ehsclsn + ehsfac(mgs) = 1.0 ! factor based on ice saturation ehls(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehls*ehlsclsn ehscnv(mgs) = 0.0 ! ehxs(mgs) = 0.0 @@ -12678,7 +14830,7 @@ subroutine nssl_2mom_gs & if ( qx(mgs,li).gt.qxmin(li) .and. qx(mgs,lc).gt.qxmin(lc) ) then - if (xdia(mgs,lc,1).gt.15.0e-06 .and. xdia(mgs,li,1).gt.30.0e-06) then + if (xdia(mgs,lc,1).gt.ewi_dcmin .and. xdia(mgs,li,1).gt.ewi_dimin) then ! erm 5/10/2007 test following change: ! if (xdia(mgs,lc,1).gt.12.0e-06 .and. xdia(mgs,li,1).gt.50.0e-06) then eiw(mgs) = 0.5 @@ -12802,7 +14954,7 @@ subroutine nssl_2mom_gs & ELSE fac = Abs(ess0) - IF ( .true. .and. ess0 < 0.0 ) THEN + IF ( iessopt == 2 ) THEN ! experimental code ! IF ( wvel(mgs) > 2.0 .or. wvel(mgs) < -0.5 .or. ssi(mgs) < 1.0 ) THEN IF ( wvel(mgs) > 2.0 ) THEN ! assume convective cell or downdraft @@ -12810,9 +14962,25 @@ subroutine nssl_2mom_gs & ELSEIF ( wvel(mgs) > 1.0 ) THEN ! transition to stratiform range of values fac = Max(0.0, 2.0 - wvel(mgs))*fac ENDIF + ELSEIF ( iessopt == 3 ) THEN ! factor based on ice supersat + IF ( ssi(mgs) <= 1.0 ) THEN + fac = 0.0 + ehsfac(mgs) = 0.0 + ELSEIF ( ssi(mgs) <= 1.02 ) THEN + fac = fac*(ssi(mgs) - 1.0)/0.02 + ehsfac(mgs) = (ssi(mgs) - 1.0)/0.02 + ENDIF + ELSEIF ( iessopt == 4 ) THEN ! factor based on ice supersat + IF ( ssi(mgs) <= 1.0 ) THEN + fac = 0.1 + ehsfac(mgs) = 0.1 + ELSEIF ( ssi(mgs) <= 1.005 ) THEN + fac = Max(0.1, fac*(ssi(mgs) - 1.0)/0.005) + ehsfac(mgs) = Max(0.1, (ssi(mgs) - 1.0)/0.005) + ENDIF ENDIF - IF ( temcg(mgs) > esstem1 .and. temcg(mgs) < esstem2 ) THEN ! only nonzero for T > -25 + IF ( temcg(mgs) > esstem1 .and. temcg(mgs) < esstem2 ) THEN ! only nonzero for T > esstem1 ess(mgs) = fac*Exp(ess1*(esstem2) )*(temcg(mgs) - esstem1)/(esstem2 - esstem1) ! linear ramp up from zero at esstem1 to value at esstem2 ELSEIF ( temcg(mgs) >= esstem2 ) THEN ess(mgs) = fac*Exp(ess1*Min( temcg(mgs), 0.0 ) ) @@ -12923,7 +15091,11 @@ subroutine nssl_2mom_gs & ELSE ehscnv(mgs) = exp(0.09*min(temcg(mgs),0.0)) ENDIF - if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lc) > qxmin(lc) ) then + + IF ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lc) >= qxmin(lc) ) THEN +! ehsclsn(mgs) = ehs_collsn +! ehs(mgs) = ehscnv(mgs)*ehsfac(mgs)*Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. ) +! ELSEIF ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lc) >= qxmin(lc) ) then ehsclsn(mgs) = ehs_collsn IF ( xdia(mgs,ls,3) < 40.e-6 ) THEN ehsclsn(mgs) = 0.0 @@ -12933,10 +15105,9 @@ subroutine nssl_2mom_gs & ehsclsn(mgs) = ehs_collsn ENDIF ! ehs(mgs) = ehscnv(mgs)*Min(1.0, Max(0., xdn(mgs,lh) - xdnmn(lh)*1.2)/xdnmn(lh) ) ! shut off qhacs as graupel goes to lowest density - ehs(mgs) = ehscnv(mgs)*Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. ) ! shut off qhacs as graupel goes to low density + ehs(mgs) = ehscnv(mgs)*Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. ) ! shut off qhacs as graupel goes to low density; limits scavenging of snow in bright band ! ehs(mgs) = ehscnv(mgs) ! *Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. ) ! shut off qhacs as graupel goes to low density ehs(mgs) = Min(ehs(mgs),ehsmax) - IF ( qx(mgs,lc) < qxmin(lc) ) ehs(mgs) = 0.0 end if ENDIF ! @@ -12944,7 +15115,7 @@ subroutine nssl_2mom_gs & ehiclsn(mgs) = ehi_collsn ehi(mgs)=eii0*exp(eii1*min(temcg(mgs),0.0)) ehi(mgs) = Min( ehimax, Max( ehi(mgs), ehimin ) ) - if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehi(mgs) = 0.0 +! if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehi(mgs) = 0.0 end if IF ( lis > 1 ) THEN @@ -12952,7 +15123,7 @@ subroutine nssl_2mom_gs & ehisclsn(mgs) = ehi_collsn ehis(mgs)=eii0*exp(eii1*min(temcg(mgs),0.0)) ehis(mgs) = Min( ehimax, Max( ehis(mgs), ehimin ) ) - if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehis(mgs) = 0.0 +! if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehis(mgs) = 0.0 end if ENDIF @@ -13089,6 +15260,7 @@ subroutine nssl_2mom_gs & end do + ! ! ! @@ -13207,6 +15379,7 @@ subroutine nssl_2mom_gs & ENDIF end do ! + IF ( ipconc < 3 ) THEN do mgs = 1,ngscnt qracs(mgs) = 0.0 IF ( ers(mgs) .gt. 0.0 .and. ipconc < 3 ) THEN @@ -13225,6 +15398,7 @@ subroutine nssl_2mom_gs & & , qsmxd(mgs)) ENDIF end do + ENDIF ! ! @@ -13371,6 +15545,7 @@ subroutine nssl_2mom_gs & ! do mgs = 1,ngscnt qhacw(mgs) = 0.0 + qhacwmlr(mgs) = 0.0 rarx(mgs,lh) = 0.0 vhacw(mgs) = 0.0 vhsoak(mgs) = 0.0 @@ -13437,6 +15612,11 @@ subroutine nssl_2mom_gs & ENDIF + qhacwmlr(mgs) = qhacw(mgs) + IF ( temg(mgs) > tfr .and. iqhacwshr == 0 ) THEN + qhacw(mgs) = 0.0 + ENDIF + IF ( lvol(lh) .gt. 1 .or. lhl .gt. 1 ) THEN ! calculate rime density for graupel volume and/or for graupel conversion to hail IF ( temg(mgs) .lt. 273.15) THEN @@ -13466,14 +15646,18 @@ subroutine nssl_2mom_gs & rimdn(mgs,lh) = 1000.*(0.051 + 0.114*tmp - 0.0055*tmp**2) - ELSEIF ( irimdenopt == 3 ) THEN ! Macklin + ELSEIF ( irimdenopt == 3 .or. irimdenopt == 4) THEN ! Macklin (3) or Saunders and Hosseini 2001 tmp = (-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & & *( (1.0-rimdenvwgt)*vtxbar(mgs,lh,1) + rimdenvwgt*vtxbar(mgs,lh,2) ) & & /(temg(mgs)-273.15)) ! tmp = Min( 5.5/0.6, Max( 0.3/0.6, tmp ) ) - rimdn(mgs,lh) = Min(900., Max( 170., 110.*tmp**0.76 ) ) + IF ( irimdenopt == 3 ) THEN + rimdn(mgs,lh) = Min(900., Max( 170., 110.*tmp**0.76 ) ) + ELSEIF ( irimdenopt == 4 ) THEN ! Saunders and Hosseini + rimdn(mgs,lh) = Min(917., Max( 10., 900.0*(1.0 - 0.905**tmp ) ) ) + ENDIF ENDIF ELSE @@ -13687,6 +15871,7 @@ subroutine nssl_2mom_gs & do mgs = 1,ngscnt qhlacw(mgs) = 0.0 + qhlacwmlr(mgs) = 0.0 vhlacw(mgs) = 0.0 vhlsoak(mgs) = 0.0 IF ( lhl > 1 .and. .true.) THEN @@ -13715,10 +15900,15 @@ subroutine nssl_2mom_gs & qhlacw(mgs) = Min( qhlacw(mgs), 0.5*qx(mgs,lc)*dtpinv ) + qhlacwmlr(mgs) = qhlacw(mgs) + IF ( temg(mgs) > tfr .and. iqhlacwshr == 0 ) THEN + qhlacw(mgs) = 0.0 + ENDIF + IF ( lvol(lhl) .gt. 1 ) THEN IF ( temg(mgs) .lt. 273.15) THEN - IF ( irimdenopt == 1 ) THEN ! Rasmussen and Heymsfeld (1985) + IF ( irimdenopt == 1 ) THEN ! Heymsfeld and Pflaum (1985) rimdn(mgs,lhl) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & & *((0.60)*( (1.0-rimdenvwgt)*vtxbar(mgs,lhl,1) + rimdenvwgt*vtxbar(mgs,lhl,2) )) & & /(temg(mgs)-273.15))**(rimc2) @@ -13732,13 +15922,17 @@ subroutine nssl_2mom_gs & rimdn(mgs,lhl) = 1000.*(0.051 + 0.114*tmp - 0.005*tmp**2) - ELSEIF ( irimdenopt == 3 ) THEN ! Macklin + ELSEIF ( irimdenopt == 3 .or. irimdenopt == 4) THEN ! Macklin (3) or Saunders and Hosseini 2001 tmp = -0.5*(1.e+06)*xdia(mgs,lc,1) & & *( (1.0-rimdenvwgt)*vtxbar(mgs,lhl,1) + rimdenvwgt*vtxbar(mgs,lhl,2) ) & & /(temg(mgs)-273.15) ! tmp = Min( 5.5/0.6, Max( 0.3/0.6, tmp ) ) - rimdn(mgs,lhl) = Min(900., Max( 170., 110.*tmp**0.76 ) ) + IF ( irimdenopt == 3 ) THEN + rimdn(mgs,lhl) = Min(900., Max( 170., 110.*tmp**0.76 ) ) + ELSEIF ( irimdenopt == 4 ) THEN ! Saunders and Hosseini + rimdn(mgs,lhl) = Min(917., Max( 10., 900.0*(1.0 - 0.905**tmp ) ) ) + ENDIF ENDIF ELSE @@ -14053,7 +16247,7 @@ subroutine nssl_2mom_gs & frach = 0.5 *(1. + Tanh(0.2e12 *( xvfrz - 1.15*xvbiggsnow))) qiacrs(mgs) = (1.-frach)*qiacr(mgs) - ciacrs(mgs) = (1.-frach)*ciacr(mgs) ! *rzxh(mgs) + ciacrs(mgs) = (1.-frach)*ciacrf(mgs) ! *rzxh(mgs) ENDIF ENDIF @@ -14083,7 +16277,7 @@ subroutine nssl_2mom_gs & tmp = xv(mgs,ls)/(xvmx(ls)*Max(1.,100./Min(100.,xdn(mgs,ls)))) ! fraction of max snow mass IF ( tmp .lt. essfrac1 ) THEN ec0(mgs) = 1.0 - ELSEIF ( tmp .gt. essfrac2 ) THEN + ELSEIF ( tmp .ge. essfrac2 ) THEN ec0(mgs) = 0.0 ELSE ec0(mgs) = (essfrac2 - tmp)/(essfrac2 - essfrac1) @@ -14160,7 +16354,21 @@ subroutine nssl_2mom_gs & ec0(mgs) = 2.e9 IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN rwrad = 0.5*xdia(mgs,lr,3) - IF ( xdia(mgs,lr,3) .gt. 2.0e-3 .or. icracr <= 0 ) THEN + + + ! check median volume diameter + IF ( icracrthresh > 1 ) THEN + IF ( imurain == 1 ) THEN + tmp = (3.67+alpha(mgs,lr))*xdia(mgs,lr,1) ! median volume diameter; units of mm (Ulbrich 1983, JCAM) + ELSE ! imurain == 3, + tmp = (1.678+alpha(mgs,lr))**(1./3.)*xdia(mgs,lr,1) ! units of mm (using method of Ulbrich 1983. See ventillation_stuff.nb) + ENDIF + ELSE + tmp = xdia(mgs,lr,3) - 0.1e-3 + ENDIF + +! IF ( xdia(mgs,lr,3) .gt. 2.0e-3 .or. icracr <= 0 ) THEN + IF ( tmp .gt. 1.9e-3 .or. icracr <= 0 ) THEN ec0(mgs) = 0.0 cracr(mgs) = 0.0 ELSE @@ -14242,6 +16450,7 @@ subroutine nssl_2mom_gs & ! if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22kk' chaci(:) = 0.0 + chaci0(:) = 0.0 if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then do mgs = 1,ngscnt IF ( ehi(mgs) .gt. 0.0 .or. ( ehiclsn(mgs) > 0.0 .and. ipelec > 0 )) THEN @@ -14292,6 +16501,7 @@ subroutine nssl_2mom_gs & ! if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22nn' chacs(:) = 0.0 + chacs0(:) = 0.0 if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then do mgs = 1,ngscnt IF ( ehs(mgs) .gt. 0 ) THEN @@ -14534,6 +16744,45 @@ subroutine nssl_2mom_gs & IF ( crcnw(mgs) < 1.e-30 ) qrcnw(mgs) = 0.0 + IF ( lzr > 1 .and. qrcnw(mgs) > 0.0 ) THEN +! vr = rho0(mgs)*qrcnw(mgs)/(1000.*crcnw(mgs)) +! zrcnw(mgs) = 36.*(xnu(lr)+2.0)*crcnw(mgs)*vr**2/((xnu(lr)+1.0)*pi**2) + ! DTD: If rain exists at a grid point already either use the alpha-preserving Z-rate eqn. (dmrauto == 1) + ! or a mass-weighted average of the alpha-preserving Z-rate eqn. and the init. rate eqn. (dmrauto == 2) + ! or the original initiation rate equation (dmrauto == 0). Not sure if this is the correct way to go but seems to work ok. + IF (qx(mgs,lr) .gt. qxmin(lr) .and. ( dmrauto == 1 .or. dmrauto ==2 ) ) THEN + tmp3 = qx(mgs,lr)/cx(mgs,lr) + tmp4 = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2* & + & ( 2.*tmp3 * qrcnw(mgs) - tmp3**2 * crcnw(mgs) ) + if (imurain == 3) then + vr = rho0(mgs)*qrcnw(mgs)/(1000.) + tmp3 = 36.*(xnu(lc)+2.0)*vr**2/(crcnw(mgs)*(xnu(lc)+1.0)*pi**2) + else + tmp3 = galpharaut*(6.*rho0(mgs)*qrcnw(mgs)/(pi*xdn0(lr)))**2/crcnw(mgs) + endif + IF ( dmrauto == 1 ) THEN ! Preserve alpha + zrcnw(mgs) = tmp4 + ELSEIF ( dmrauto == 2 ) THEN ! Mass-weighted average + zrcnw(mgs) = (tmp3*qrcnw(mgs)+tmp4*qx(mgs,lr))/(qrcnw(mgs)+qx(mgs,lr)) + ENDIF + else ! original formulation + IF ( imurain == 3 ) THEN + vr = rho0(mgs)*qrcnw(mgs)/(1000.) ! crcnw(mgs) not divided here but is in next line, cancels one factor in the numerator + zrcnw(mgs) = 36.*(xnu(lc)+2.0)*vr**2/(crcnw(mgs)*(xnu(lc)+1.0)*pi**2) + ELSE ! rain in gamma of diameter + IF ( dmropt <= 1 .or. dmropt >= 4 .or. ( qx(mgs,lr) < qxmin(lr) .and. cx(mgs,lr) < cxmin ) ) THEN + zrcnw(mgs) = galpharaut*(6.*rho0(mgs)*qrcnw(mgs)/(pi*xdn0(lr)))**2/crcnw(mgs) + ELSE + tmp3 = qx(mgs,lr)/cx(mgs,lr) + zrcnw(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2* & + & ( 2.*tmp3 * qrcnw(mgs) - tmp3**2 * crcnw(mgs) ) + ENDIF +! vr = rho0(mgs)*qrcnw(mgs)/(1000.) ! crcnw(mgs) not divided here but is in next line, cancels one factor in the numerator +! zrcnw(mgs) = 36.*(xnu(lc)+2.0)*vr**2/(crcnw(mgs)*(xnu(lc)+1.0)*pi**2) + ENDIF + endif +! z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2) + ENDIF ! IF ( crcnw(mgs) .gt. cautn(mgs) .and. crcnw(mgs) .gt. 1.0 ) ! : THEN ! write(0,*) 'crcnw,cautn ',crcnw(mgs)/cautn(mgs), @@ -14744,6 +16993,15 @@ subroutine nssl_2mom_gs & ELSE !{ + IF ( lzr > 1 ) THEN + ! interpolate along x, i.e., ratio; + tmp1 = ziacrratio(i,j) + delx*dqiacrratioinv*(ziacrratio(ip1,j) - ziacrratio(i,j)) + tmp2 = ziacrratio(i,jp1) + delx*dqiacrratioinv*(ziacrratio(ip1,jp1) - ziacrratio(i,jp1)) + + ! interpolate along alpha; + + zrfrz(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*zx(mgs,lr)*dtpinv + ENDIF IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < 2.*xvmn(lr) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN ! IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < xvbiggsnow .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN @@ -14753,6 +17011,10 @@ subroutine nssl_2mom_gs & crfrzs(mgs) = crfrz(mgs) qrfrzs(mgs) = qrfrz(mgs) + IF ( lzr > 1 ) THEN + zrfrzs(mgs) = zrfrz(mgs) + zrfrzf(mgs) = 0. + ENDIF ELSEIF ( dbigg < Max( biggsnowdiam, Max(dfrz,dhmn)) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN ! { convert some to snow or ice crystals ! temporarily store qrfrz and crfrz in snow terms and caclulate new crfrzf, qrfrzf, and zrfrzf. Leave crfrz etc. alone! @@ -14764,6 +17026,10 @@ subroutine nssl_2mom_gs & crfrzf(mgs) = 0.0 qrfrzf(mgs) = 0.0 + IF ( lzr > 1 ) THEN + zrfrzs(mgs) = zrfrz(mgs) + zrfrzf(mgs) = 0. + ENDIF ELSE !{ ! recalculate using dhmn for ratio @@ -14803,10 +17069,23 @@ subroutine nssl_2mom_gs & crfrzs(mgs) = crfrzs(mgs) - crfrzf(mgs) qrfrzs(mgs) = qrfrzs(mgs) - qrfrzf(mgs) + IF ( lzr > 1 ) THEN + zrfrzs(mgs) = zrfrz(mgs) + ! interpolate along x, i.e., ratio; + tmp1 = ziacrratio(i,j) + delx*dqiacrratioinv*(ziacrratio(ip1,j) - ziacrratio(i,j)) + tmp2 = ziacrratio(i,jp1) + delx*dqiacrratioinv*(ziacrratio(ip1,jp1) - ziacrratio(i,jp1)) + + ! interpolate along alpha; + + zrfrzf(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*zx(mgs,lr)*dtpinv + zrfrzs(mgs) = zrfrzs(mgs) - zrfrzf(mgs) + zrfrzf(mgs) = (1000./900.)**2*zrfrzf(mgs) + ENDIF ENDIF ! } ELSE crfrzs(mgs) = 0.0 qrfrzs(mgs) = 0.0 + zrfrzs(mgs) = 0.0 ENDIF ! } ENDIF !} @@ -14819,6 +17098,10 @@ subroutine nssl_2mom_gs & crfrz(mgs) = fac*crfrz(mgs) crfrzs(mgs) = fac*crfrzs(mgs) crfrzf(mgs) = fac*crfrzf(mgs) + IF ( lzr > 1 ) THEN + zrfrz(mgs) = fac*zrfrz(mgs) + zrfrzf(mgs) = fac*zrfrzf(mgs) + ENDIF ENDIF ENDIF !} @@ -15364,7 +17647,15 @@ subroutine nssl_2mom_gs & x = 1. + alpha(mgs,lr) IF ( lzr > 1 ) THEN ! 3 moment -! + tmp = 1. + alpr ! alpha(mgs,lr) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 2.5 + alpha(mgs,lr) + 0.5*bx(lr) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp ! ratio of gamma functions ELSE y = ventrxn(mgs) ENDIF @@ -15381,6 +17672,12 @@ subroutine nssl_2mom_gs & & Sqrt(ax(lr)*rhovt(mgs))*(vent1/vent2) +! rwventz(mgs) = & +! & 0.78*x + & +! & 0.308*fvent(mgs)*y* & +! & Sqrt(ax(lr)*rhovt(mgs))*(vent1/vent2) + + ELSEIF ( iferwisventr == 2 ) THEN ! Following Wisner et al. (1972) but using gamma of volume. Note that Ferrier rain fall speed does not integrate with gamma of volume, so using Vr = ar*d^br @@ -15392,6 +17689,22 @@ subroutine nssl_2mom_gs & & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) + alpr = Min(alpharmax,alpha(mgs,lr) ) + + tmp = alpr + 5.5 + br/2. + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! rwventz(mgs) = & +! & 0.78*(4. + alpha(mgs,lr))*(3. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(1. + alpha(mgs,lr)) + & + rwventz(mgs) = & + & 0.78*(4. + alpr)*(3. + alpr)*(2. + alpr)*(1. + alpr) + & + & 0.308*fvent(mgs)* & + & Sqrt(ax(lr)*rhovt(mgs))*(y/gf1palp(mgs))*(xdia(mgs,lr,1)**((1.0+br)/2.0)) + + + ENDIF ! iferwisventr @@ -15554,6 +17867,8 @@ subroutine nssl_2mom_gs & & -ftka(mgs)*temcg(mgs)/rho0(mgs) ) & & / (felf(mgs)) fmlt2(mgs) = -fcw(mgs)*temcg(mgs)/felf(mgs) + fmlt1e(mgs) = (2.0*pi)* & + & ( felv(mgs)*fwvdf(mgs)*(qss0(mgs)-qx(mgs,lv)) ) / (felf(mgs)) end do ! ! Vapor Deposition constants @@ -15581,6 +17896,7 @@ subroutine nssl_2mom_gs & qhlmlrlg(:) = 0.0 ENDIF qhfzh(:) = 0.0 + qffzf(:) = 0.0 qhlfzhl(:) = 0.0 qhfzhlg(:) = 0.0 qhlfzhllg(:) = 0.0 @@ -15591,6 +17907,7 @@ subroutine nssl_2mom_gs & zsmlr(:) = 0.0 zhmlr(:) = 0.0 zhmlrr(:) = 0.0 + zsmlrr(:) = 0.0 zhshr(:) = 0.0 zhlmlr(:) = 0.0 zhlshr(:) = 0.0 @@ -15642,7 +17959,7 @@ subroutine nssl_2mom_gs & qhmlr(mgs) = & & meltfac*min( & & fmlt1(mgs)*cx(mgs,lh)*hwvent(mgs)*xdia(mgs,lh,1) & - & + fmlt2(mgs)*(qhacrmlr(mgs)+qhacw(mgs)) & + & + fmlt2(mgs)*(qhacrmlr(mgs)+qhacwmlr(mgs)) & & , 0.0 ) ELSEIF ( ibinhmlr == 1 ) THEN ! use incomplete gamma functions to approximate the bin results @@ -15674,13 +17991,13 @@ subroutine nssl_2mom_gs & qhlmlr(mgs) = & & meltfac*min( & & fmlt1(mgs)*cx(mgs,lhl)*hlvent(mgs)*xdia(mgs,lhl,1) & - & + fmlt2(mgs)*(qhlacrmlr(mgs)+qhlacw(mgs)) & + & + fmlt2(mgs)*(qhlacrmlr(mgs)+qhlacwmlr(mgs)) & & , 0.0 ) ELSEIF ( ibinhlmlr == 1 ) THEN ! use incomplete gamma functions to approximate the bin results -! #ifdef Z3MOM -! #if (defined Z3MOM) && defined( COMMAS ) || defined( COMMASTMP ) +! #ifdef 1 +! #if (defined 1) && defined( COMMAS ) || defined( COMMASTMP ) ELSEIF ( ibinhlmlr == -1 ) THEN ! OLD VERSION use incomplete gamma functions to approximate the bin results @@ -15711,7 +18028,7 @@ subroutine nssl_2mom_gs & chmlr(mgs) = max( chmlr(mgs), Min( -chmxd(mgs), -0.95*cx(mgs,lh)*dtpinv ) ) ENDIF ! qhmlr(mgs) = max( max( qhmlr(mgs), -qhmxd(mgs) ) , -0.5*qx(mgs,lh)*dtpinv ) !limits to 1/2 qh or max depletion - qhmlh(mgs) = 0. + qhmlh(mgs) = 0. ! not used ! Rasmussen and Heymsfield say melt water remains on graupel up to 9 mm before shedding @@ -15789,7 +18106,26 @@ subroutine nssl_2mom_gs & + IF ( lzr .gt. 1 .and. qx(mgs,ls) > qxmin(ls) ) THEN + tmp = qx(mgs,ls)/cx(mgs,ls) +! alp = Max( -0.8, alpha(mgs,lh) ) + alp = xnu(ls) + g1 = 36.*(alp+2.0)/((alp+1.0)*pi**2) + + zsmlr(mgs) = g1*(rho0(mgs)/(xdn(mgs,ls)))**2*( tmp * qsmlr(mgs) ) +! zhmlr(mgs) = (xdn0(lr)/(xdn(mgs,lh)))**2*( zx(mgs,lh) * qhmlr(mgs) ) + + ENDIF + IF ( chmlr(mgs) < 0.0 .and. (ibinhmlr < 1 .or. lzh < 1) ) THEN ! { already done if ibinhmlr > 0 + IF ( lzr .gt. 1 .and. lzh < 1 .and. qx(mgs,lh) > qxmin(lh) ) THEN ! Only compute if rain is 3-moment but graupel is not, otherwise is computed later + tmp = qx(mgs,lh)/cx(mgs,lh) + alp = alpha(mgs,lh) + g1 = g1x(mgs,lh) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + + zhmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*tmp * qhmlr(mgs) - tmp**2 * chmlr(mgs) ) + + ENDIF IF ( ibinhmlr == 0 .or. lzh < 1 ) THEN IF ( ihmlt .eq. 1 ) THEN @@ -15895,6 +18231,17 @@ subroutine nssl_2mom_gs & ENDIF !} + IF ( lzhl .gt. 1 .and. ibinhlmlr <= 0 ) THEN + IF ( cx(mgs,lhl) > 0.0 ) THEN + + tmp = qx(mgs,lhl)/cx(mgs,lhl) + alp = alpha(mgs,lhl) +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + g1 = g1x(mgs,lhl) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + + zhlmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( tmp * qhlmlr(mgs) ) + ENDIF + ENDIF ENDIF ! } ENDIF ! }.not. mixedphase @@ -15932,6 +18279,7 @@ subroutine nssl_2mom_gs & ENDDO ! ! + qhdsv(:) = 0.0 qhldsv(:) = 0.0 do mgs = 1,ngscnt @@ -15941,6 +18289,7 @@ subroutine nssl_2mom_gs & & fvds(mgs)*cx(mgs,li)*civent(mgs)*cicap(mgs)*depfac qsdsv(mgs) = & & fvds(mgs)*cx(mgs,ls)*swvent(mgs)*swcap(mgs)*depfac + ! IF ( ny .eq. 2 .and. igs(mgs) .eq. 302 .and. temg(mgs) .le. tfrh+10 .and. qx(mgs,lv) .gt. qis(mgs) ! : .and. qx(mgs,li) .gt. qxmin(li) ) THEN ! write(0,*) 'qidsv = ',nstep,kgs(mgs),qidsv(mgs),temg(mgs)-tfrh,100.*(qx(mgs,lv)/qis(mgs) - 1.),1.e6*xdia(mgs,li,1), @@ -16177,20 +18526,41 @@ subroutine nssl_2mom_gs & ! end of qlimit + qhcev(:) = 0.0 + chcev(:) = 0.0 + qhlcev(:) = 0.0 + chlcev(:) = 0.0 + qfcev(:) = 0.0 + do mgs = 1,ngscnt qisbv(mgs) = 0.0 qssbv(mgs) = 0.0 qidpv(mgs) = 0.0 qsdpv(mgs) = 0.0 + qhsbv(mgs) = 0.0 + qscev(mgs) = 0.0 + cscev(mgs) = 0.0 IF ( icond .eq. 1 .or. temg(mgs) .le. tfrh & - & .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN + & .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN ! last condition (qr qxmin(lhl) ) THEN + IF ( temg(mgs) < tfr .or. .not. qhlmlr(mgs) < 0.0 ) THEN qhlsbv(mgs) = max( min(qhldsv(mgs), 0.0), -qxmxd(mgs,lhl) ) qhldpv(mgs) = Max(qhldsv(mgs), 0.0) + ENDIF + IF ( qhlmlr(mgs) < 0.0 .and. .not. mixedphase ) THEN + ! Liquid is forming, so find the evaporation that was subtracted from melting (if it is not condensing) + qhlcev(mgs) = evapfac* & + & 2.0*pi*(qx(mgs,lv)-qss0(mgs))*cx(mgs,lhl)*xdia(mgs,lhl,1)*hlvent(mgs)/(qss0(mgs)*(fav(mgs)+fbv(mgs))) + + qhlcev(mgs) = max(qhlcev(mgs), -qhlmxd(mgs)) + + ENDIF + ENDIF ENDIF temp1 = qidpv(mgs) + qsdpv(mgs) + qhdpv(mgs) + qhldpv(mgs) @@ -16345,6 +18742,10 @@ subroutine nssl_2mom_gs & end if end do + + + + ! ! ! compute dry growth rate of snow, graupel, and hail @@ -16382,19 +18783,27 @@ subroutine nssl_2mom_gs & ! IF ( dnu(lh) .ne. 0. ) THEN ! qhwet(mgs) = qhdry(mgs) ! ELSE + IF ( incwet == 0 ) THEN qhwet(mgs) = & & ( xdia(mgs,lh,1)*hwvent(mgs)*cx(mgs,lh)*fwet1(mgs) & & + fwet2(mgs)*(qhaci(mgs) + qhacs(mgs)) ) qhwet(mgs) = max( 0.0, qhwet(mgs)) + ELSE + ENDIF + ! ENDIF qhlwet(mgs) = 0.0 IF ( lhl .gt. 1 ) THEN - qhlwet(mgs) = & - & ( xdia(mgs,lhl,1)*hlvent(mgs)*cx(mgs,lhl)*fwet1(mgs) & - & + fwet2(mgs)*(qhlaci(mgs) + qhlacs(mgs)) ) - qhlwet(mgs) = max( 0.0, qhlwet(mgs)) + IF ( incwet == 0 ) THEN + qhlwet(mgs) = & + & ( xdia(mgs,lhl,1)*hlvent(mgs)*cx(mgs,lhl)*fwet1(mgs) & + & + fwet2(mgs)*(qhlaci(mgs) + qhlacs(mgs)) ) + qhlwet(mgs) = max( 0.0, qhlwet(mgs)) + + ELSE + ENDIF ! incwet ENDIF ELSE @@ -16407,6 +18816,7 @@ subroutine nssl_2mom_gs & ! qhlwet(mgs) = qhldry(mgs) end do + ! ! shedding rate ! @@ -16466,7 +18876,7 @@ subroutine nssl_2mom_gs & qhshr(mgs) = -qhdry(mgs) qhlshr(mgs) = -qhldry(mgs) ELSE ! new and correct - + ! note that the qxacr terms should be zero here, so shedding at T > 0 is all from the droplets qsshr(mgs) = - qsacr(mgs) - qsacw(mgs) ! -qsdry(mgs) qhlshr(mgs) = - qhlacw(mgs) - qhlacr(mgs) ! -qhldry(mgs) qhshr(mgs) = - qhacw(mgs) - qhacr(mgs) ! -qhdry(mgs) @@ -16802,7 +19212,94 @@ subroutine nssl_2mom_gs & ltest = xdia(mgs,lh,1)*(4. + alpha(mgs,lh)) > Abs( hlcnhdia ) ! test on mass-weighted diameter ENDIF - dg0(mgs) = -1. + IF ( iusedw == 0 .and. ihlcnh == 1 ) THEN + dg0(mgs) = -1. + ELSE + IF (((qhacw(mgs) + qhacr(mgs))*dtp > qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin .and. temg(mgs) .le. tfr-2.0 & + .and. temg(mgs) .gt. dwtempmin ) .or. ( wetgrowth(mgs) .and. qx(mgs,lh) > hlcnhqmin ) ) THEN + dw = 0.01*( Exp( -temcg(mgs)/( 1.1e4 * rho0(mgs)*ehw(mgs)*qx(mgs,lc) - 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0 ) ) - 1.0 ) + dwr = 0.01*( Exp( -temcg(mgs)/( 1.1e4 * rho0(mgs)*(ehw(mgs)*qx(mgs,lc)+ehr(mgs)*qx(mgs,lr)) - & + 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0 ) ) - 1.0 ) + d = dwr + IF ( dwr < 0.2 .and. dwr > 0.0 ) THEN + fventh = sqrtrhovt*(fpndl(mgs)**(1./3.)) * (fakvisc(mgs))**(-0.5) + fventm = sqrtrhovt*(fschm(mgs)**(1./3.)) * (fakvisc(mgs))**(-0.5) + sqrtrhovt = Sqrt( rhovt(mgs) ) + ltemq = (tfr-163.15)/fqsat+1.5 + qvs0 = pqs(mgs)*tabqvs(ltemq) + denomdp = felf(mgs) + fcw(mgs)*temcg(mgs) + denominvdp = 1.d0/(felf(mgs) + fcw(mgs)*temcg(mgs)) + +! write(91,*) 'dw,dwr,temcg = ',100.*dw,100.*dwr,temcg(mgs) + h1 = ( -ftka(mgs)*temcg(mgs) - felv(mgs)*fwvdf(mgs)*rho0(mgs)*(qx(mgs,lv) - qvs0) ) + h2 = ehi(mgs)*qx(mgs,li)*rho0(mgs)*fci(mgs)*temcg(mgs) + h3 = Max(dwehwmin, ehw(mgs))*qx(mgs,lc) + h4 = ehr(mgs)* qx(mgs,lr) + ! iterate to find minimum diameter for wet growth. Start with value of dwr + DO n = 1,10 + dold = d + vth = axx(mgs,lh)*d**bxx(mgs,lh) + x2 = fventh*sqrtrhovt*Sqrt(d*vth) + IF ( x2 > 1.4 ) THEN + ah = 0.78 + 0.308*x2 ! heat ventillation + ELSE + ah = 1.0 + 0.108*x2**2 ! mass ventillation (Beard and Pruppacher 1971, eq. 9) + ENDIF + + IF ( .false. ) THEN ! this option includes 'am' separate from ah, which makes only small differences. Otherwise equivalent to second option + x1 = fventm*sqrtrhovt*Sqrt(d*vth) + IF ( x1 > 1.4 ) THEN + am = 0.78 + 0.308*x1 ! mass ventillation (Beard and Pruppacher 1971, eq. 8) + ELSE + am = 1.0 + 0.108*x1**2 ! mass ventillation (Beard and Pruppacher 1971, eq. 9) + ENDIF + + d = 8.*denominvdp*( am*felv(mgs)*fwvdf(mgs)*rho0(mgs)*(qvs0 - qx(mgs,lv)) - ah*ftka(mgs)*temcg(mgs) )/ & + (dtp* ( ( Max(0.001,vth - vtxbar(mgs,lc,1))*h3 + & + Max(0.001,vth - vtxbar(mgs,lr,1))*h4) *rho0(mgs) + & + Max(0.001,vth - vtxbar(mgs,li,1))*h2*denominvdp)) + + ELSE + + d = 8.*ah*h1*dtpinv/ & + ( ( Max(0.001,vth - vtxbar(mgs,lc,1))*h3 + & + Max(0.001,vth - vtxbar(mgs,lr,1))*h4) *rho0(mgs)*denomdp + & + Max(0.001,vth - vtxbar(mgs,li,1))*h2) + ENDIF +! write(0,*) 'iter,d,dwr = ',n,d,dwr +! write(91,*) 'parts = ',( -ah*ftka*temcg - ah*felv*fwvdf*dn(i,j,k)*(qvamb - qvs0) ),( Max(0.001,vth - 0.01*vwmw)*ehw* qcmks*dn(i,j,k)/denominv + Max(0.001,vth - 0.01*vimw)*ehi*qimks*dn(i,j,k)*fci*temcg) +!! write(91,*) 'partsr = ',( -ah*ftka*temcg - ah*felv*fwvdf*dn(i,j,k)*(qvamb - qvs0) ),( ( Max(0.001,vth - 0.01*vwmw)*ehw* qcmks + Max(0.001,vth - 0.01*vrmw)*ehr* qrmks) *dn(i,j,k)/denominv + & +!! Max(0.001,vth - 0.01*vimw)*ehi*qimks*dn(i,j,k)*fci*temcg) +! write(91,*) 'parts2 = ',vth + + IF ( Abs(dold - d)/dold < 0.05 .or. ( n > 3 .and. d > dg0thresh ) ) EXIT + + ENDDO + ENDIF + + dg0(mgs) = Max( d, dwmin ) +! IF ( .false. .and. ny == 2 .and. dwr < 0.5 .and. dwr > 0. ) THEN +! write(0,*) 'i,k,dg0 = ',igs(mgs), kgs(mgs), dg0(mgs) +! write(0,*) 'h1,h2,h3,h4 = ',h1,h2,h3,h4 +! write(0,*) 'dw,dwr = ',dw,dwr +! write(0,*) 'wetgrowth = ',wetgrowth(mgs) +! write(0,*) 'temc,Dh, Dhl = ',temcg(mgs),xdia(mgs,lh,3),xdia(mgs,lhl,3) +! ENDIF + ELSE + dg0(mgs) = dg0thresh + 0.0001 + ENDIF + + IF ( ihlcnh == 3 .and. (qhacw(mgs) + qhacr(mgs))*dtp > qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin & + .and. temg(mgs) .le. tfr-2.0 ) THEN + ! set a secondary condition on to capture large graupel that is riming but not in wet growth + dg0(mgs) = Min( dg0(mgs), dg0thresh - 0.0001 ) + ENDIF + + ENDIF +! write(0,*) 'notwet growth graupel,hail,Dw,Dwr = ',wetgrowth(mgs) , wetgrowthhl(mgs), dh0 ,tmp,tmp1 +! write(0,*) 'temc,Dh, Dhl = ',temcg(mgs),xdia(mgs,lh,3),xdia(mgs,lhl,3) +! write(0,*) 'qc,qi = ', qx(mgs,lc) , qx(mgs,li) + wtest = (dg0(mgs) > 0.0 .and. dg0(mgs) < dg0thresh ) @@ -16874,12 +19371,142 @@ subroutine nssl_2mom_gs & ELSEIF ( ihlcnh == 3 ) THEN !{ + IF ( wtest .and. & + ( qhacw(mgs)*dtp > qxmin(lh) .and. temg(mgs) .lt. tfr-2. .and. qx(mgs,lh) > hlcnhqmin ) ) THEN + ! convert number, mass, and reflectivity for d > dw + IF ( ipconc == 5 ) THEN + ! dg0(mgs) = Min( dg0(mgs), hldia1 ) + !dg0(mgs) = hldia1 + ENDIF + + ratio = Min( maxratiolu, dg0(mgs)/xdia(mgs,lh,1) ) + + + ! mass + tmp2 = gaminterp(ratio,alpha(mgs,lh),4,1) + IF ( ipconc == 5 ) THEN + ! tmp2 = Min( 0.25, tmp2 ) + ENDIF + qxd1 = qx(mgs,lh)*(tmp2) + qhlcnh(mgs) = dtpinv*qxd1 + flim = 1.0 +! tmp3 = Min( dtp*(qfacw(mgs) + qfacr(mgs) ), qxmxd(mgs,lf) ) + tmp3 = qxmxd(mgs,lh) + IF (qxd1 > tmp3 ) THEN + flim = tmp3/(qxd1) + qhlcnh(mgs) = flim*qhlcnh(mgs) + ENDIF + + + + IF ( ( qxd1 > qxmin(lhl) .and. ipconc > 5 ) .or. ( qxd1 > 10.*qxmin(lhl) .and. ipconc == 5) ) THEN + + ! number + tmp = gaminterp(ratio,alpha(mgs,lh),1,1) + IF ( ipconc == 5 ) THEN + ! tmp = Min( 0.2, tmp ) + ENDIF + cxd1 = flim*cx(mgs,lh)*( tmp) + chlcnh(mgs) = dtpinv*cxd1 + chlcnhhl(mgs) = chlcnh(mgs) + + IF ( qx(mgs,lhl) > qxmin(lhl) .and. dmhlopt > 0 ) THEN + dh0 = rho0(mgs)*qhlcnh(mgs)/chlcnhhl(mgs) + IF ( dh0 < xmas(mgs,lhl) ) THEN + ! dh0 = ( qxd1*dh0 + qx(mgs,lhl)*xmas(mgs,lhl))/( qxd1 + qx(mgs,lhl)) ! weighted average + dh0 = (( qxd1*dh0**(1./3.) + qx(mgs,lhl)*xmas(mgs,lhl)**(1./3.))/( qxd1 + qx(mgs,lhl)))**3 ! weighted average + chlcnhhl(mgs) = Min( chlcnhhl(mgs), rho0(mgs)*qhlcnh(mgs)/dh0 ) + ELSE +! dh0 = Max( dh0, xmas(mgs,lhl) ) ! when enough hail is established, do not dilute the size + ENDIF + ENDIF + + + ! reflectivity + IF ( lzh > 1 .and. lzhl > 1 ) THEN + tmp3 = gaminterp(ratio,alpha(mgs,lh),11,1) + zxd1 = flim*zx(mgs,lh)*(tmp3) + zhlcnh(mgs) = dtpinv*zxd1 + ELSE + zxd1 = 0 + ENDIF + + ELSE + qhlcnh(mgs) = 0.0 + ENDIF + +! IF ( cxd1 < 0.0 .or. qxd1 < 0.0 ) THEN +! write(0,*) 'cxd1,qxd1 = ',cxd1,qxd1 +! write(0,*) 'dw,temcg = ',dw,temcg(mgs),ratio +! ENDIF + +! write(0,*) 'dw,temcg = ',dw,temcg(mgs),ratio +! write(0,*) 'qhlcnh,qh = ',qhlcnh(mgs),qx(mgs,lh),qxd1 +! write(0,*) 'chlcnh,ch = ',chlcnh(mgs),cx(mgs,lh),cxd1 +! write(0,*) 'zhlcnh,zh = ',zhlcnh(mgs),zx(mgs,lh),zxd1 +! write(0,*) 'tmp1,2,3 = ',tmp,tmp2,tmp3 + + vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh) + vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh)) + + ENDIF + + ENDIF !} ENDDO ELSEIF ( ihlcnh == 2 ) THEN ! 10-ice type conversion +! +! Staka and Mansell (2005) type conversion +! +! hldia1 is set in micro_module and namelist +! IF ( .true. ) THEN + + ! convert number, mass, and reflectivity for d > hldia1, + ! regardless of wet growth status, but as long as riming > 0 + DO mgs = 1,ngscnt + IF ( qhacw(mgs)*dtp > qxmin(lh) .and. temg(mgs) .lt. tfr-2. .and. qx(mgs,lh) > qxmin(lh) ) THEN + ratio = Min( maxratiolu, hldia1/xdia(mgs,lh,1) ) + + ! number + tmp = gaminterp(ratio,alpha(mgs,lh),1,1) + cxd1 = cx(mgs,lh)*( tmp) + chlcnh(mgs) = dtpinv*cxd1 + chlcnhhl(mgs) = chlcnh(mgs) + + ! mass + tmp2 = gaminterp(ratio,alpha(mgs,lh),4,1) + qxd1 = qx(mgs,lh)*(tmp2) + qhlcnh(mgs) = dtpinv*qxd1 + + ! reflectivity + IF ( lzh > 1 .and. lzhl > 1 ) THEN + tmp3 = gaminterp(ratio,alpha(mgs,lh),11,1) + zxd1 = zx(mgs,lh)*(tmp3) + zhlcnh(mgs) = dtpinv*zxd1 + ELSE + zxd1 = 0 + ENDIF +! IF ( cxd1 < 0.0 .or. qxd1 < 0.0 ) THEN +! write(0,*) 'cxd1,qxd1 = ',cxd1,qxd1 +! write(0,*) 'dw,temcg = ',dw,temcg(mgs),ratio +! ENDIF + +! write(0,*) 'dw,temcg = ',dw,temcg(mgs),ratio +! write(0,*) 'qhlcnh,qh = ',qhlcnh(mgs),qx(mgs,lh),qxd1 +! write(0,*) 'chlcnh,ch = ',chlcnh(mgs),cx(mgs,lh),cxd1 +! write(0,*) 'zhlcnh,zh = ',zhlcnh(mgs),zx(mgs,lh),zxd1 +! write(0,*) 'tmp1,2,3 = ',tmp,tmp2,tmp3 + + vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh) + vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh)) + + ENDIF + + ENDDO +! ENDIF ELSEIF ( ihlcnh == 0 ) THEN do mgs = 1,ngscnt @@ -17115,6 +19742,10 @@ subroutine nssl_2mom_gs & ciacrf(mgs) = qrzfac(mgs)*ciacrf(mgs) ciacrs(mgs) = qrzfac(mgs)*ciacrs(mgs) +! IF ( lzh .gt. 1 ) THEN +! zrfrzf(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,lr)+2.)/(xdn0(lr)**2*(alpha(mgs,lr)+1.)) * & +! ( 2.*tmp * qrfrzf(mgs) - tmp**2 * crfrzf(mgs) ) +! ENDIF vrfrzf(mgs) = qrzfac(mgs)*vrfrzf(mgs) viacrf(mgs) = qrzfac(mgs)*viacrf(mgs) @@ -17154,7 +19785,13 @@ subroutine nssl_2mom_gs & IF ( qrcev(mgs) .lt. 0. .and. lnr > 1 ) THEN ! qrcev(mgs) = -qrmxd(mgs) ! crcev(mgs) = (rho0(mgs)/(xmas(mgs,lr)+1.e-20))*qrcev(mgs) - crcev(mgs) = (cx(mgs,lr)/(qx(mgs,lr)))*qrcev(mgs) + IF ( icrcev == 1 ) THEN + crcev(mgs) = (cx(mgs,lr)/(qx(mgs,lr)))*qrcev(mgs) + ELSEIF ( icrcev == 2 ) THEN + crcev(mgs) = (cx(mgs,lr)/(qx(mgs,lr)))*qrcev(mgs)*vtxbar(mgs,lr,2)/vtxbar(mgs,lr,1) + ELSE + crcev(mgs) = 0.0 + ENDIF ELSE crcev(mgs) = 0.0 ENDIF @@ -17166,12 +19803,6 @@ subroutine nssl_2mom_gs & ! ! evaporation/condensation of wet graupel and snow ! - qscev(:) = 0.0 - cscev(:) = 0.0 - qhcev(:) = 0.0 - chcev(:) = 0.0 - qhlcev(:) = 0.0 - chlcev(:) = 0.0 IF ( lhwlg > 1 ) THEN qhcevlg(:) = 0.0 chcevlg(:) = 0.0 @@ -17181,6 +19812,7 @@ subroutine nssl_2mom_gs & chlcevlg(:) = 0.0 ENDIF + ! ! ! @@ -18140,6 +20772,7 @@ subroutine nssl_2mom_gs & pqwvi(mgs) = & & -Min(0.0, qrcev(mgs)) & & -Min(0.0, qhcev(mgs)) & + & -Min(0.0, qfcev(mgs)) & & -Min(0.0, qhlcev(mgs)) & & -Min(0.0, qscev(mgs)) & ! > +il5(mgs)*(-qhsbv(mgs) - qhlsbv(mgs) ) & @@ -18150,6 +20783,7 @@ subroutine nssl_2mom_gs & pqwvd(mgs) = & & -Max(0.0, qrcev(mgs)) & & -Max(0.0, qhcev(mgs)) & + & -Max(0.0, qfcev(mgs)) & & -Max(0.0, qhlcev(mgs)) & & -Max(0.0, qscev(mgs)) & & +il5(mgs)*(-qiint(mgs) & @@ -18366,7 +21000,8 @@ subroutine nssl_2mom_gs & qrcev(mgs) = frac*qrcev(mgs) qhlacr(mgs) = frac*qhlacr(mgs) vhlacr(mgs) = frac*vhlacr(mgs) -! qhcev(mgs) = frac*qhcev(mgs) + qhcev(mgs) = frac*qhcev(mgs) + qhlcev(mgs) = frac*qhlcev(mgs) IF ( warmonly < 0.5 ) THEN @@ -18412,6 +21047,8 @@ subroutine nssl_2mom_gs & ! STOP ENDIF + + end do IF ( warmonly < 0.5 ) THEN @@ -18440,7 +21077,7 @@ subroutine nssl_2mom_gs & & -qhcns(mgs) & & +(1-il5(mgs))*qsmlr(mgs) + qsshr(mgs) & !null at this point when wet snow included ! > +il5(mgs)*(qssbv(mgs)) & - & + (qssbv(mgs)) & + & + qssbv(mgs) & & + Min(0.0, qscev(mgs)) & & -qsmul(mgs) @@ -18534,74 +21171,656 @@ subroutine nssl_2mom_gs & ENDIF - end do - - ENDIF ! lhl + end do + + ENDIF ! lhl + + ELSEIF ( warmonly < 0.8 ) THEN +! +! Graupel +! + do mgs = 1,ngscnt + pqhwi(mgs) = & + & +il5(mgs)*ifrzg*(qrfrzf(mgs) ) & + & +il5(mgs)*(qhdpv(mgs)) & + & +qhacr(mgs)+qhacw(mgs) + pqhwd(mgs) = & + & qhshr(mgs) & !null at this point when wet graupel included + & - qhlcnh(mgs) & + & - qhmul1(mgs) & + & - qsplinter(mgs) - qsplinter2(mgs) & + & +(1-il5(mgs))*qhmlr(mgs) !null at this point when wet graupel included + end do + +! +! Hail +! + IF ( lhl .gt. 1 ) THEN + + do mgs = 1,ngscnt + pqhli(mgs) = & + & +il5(mgs)*(qhldpv(mgs) ) & ! + (1.0-ifrzg)*(qiacrf(mgs)+qrfrzf(mgs) + qracif(mgs))) & + & +il5(mgs)*(1.0-ifrzg)*(qrfrzf(mgs) ) & + & +qhlacr(mgs)+qhlacw(mgs) & +! & +qhlacs(mgs)+qhlaci(mgs) & + & + qhlcnh(mgs) + pqhld(mgs) = & + & qhlshr(mgs) & + & +(1-il5(mgs))*qhlmlr(mgs) & +! > +il5(mgs)*qhlsbv(mgs) & + & + qhlsbv(mgs) & + & -qhlmul1(mgs) - qhcnhl(mgs) + + end do + + ENDIF ! lhl + + ENDIF ! warmonly + +! +! Liquid water on snow and graupel +! + + vhmlr(:) = 0.0 + vhlmlr(:) = 0.0 + vhfzh(:) = 0.0 + vhlfzhl(:) = 0.0 + + IF ( mixedphase ) THEN + ELSE ! set arrays for non-mixedphase graupel + +! vhshdr(:) = 0.0 + vhmlr(:) = qhmlr(:) ! not actually volume, but treated as q in rate equation +! vhsoak(:) = 0.0 + +! vhlshdr(:) = 0.0 + vhlmlr(:) = qhlmlr(:) ! not actually volume, but treated as q in rate equation +! vhlmlr(:) = rho0(:)*qhlmlr(:)/xdn(:,lhl) +! vhlsoak(:) = 0.0 + + ENDIF ! mixedphase + + + +! +! Graupel reflectivity +! + if (ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'graupel reflectivity' + + do mgs = 1,ngscnt + +! zhmlr(mgs) = 0.0 +! zhshr(mgs) = 0.0 +! zhmlrr(mgs) = 0.0 +! zhshrr(mgs) = 0.0 + zhdsv(mgs) = 0.0 +! IF ( lf < 1 ) THEN + IF ( ffrzh > 0.0 ) THEN + ziacr(mgs) = 0.0 + ziacrf(mgs) = 0.0 + ENDIF +! ENDIF + zhcns(mgs) = 0.0 + zhcni(mgs) = 0.0 + zhacs(mgs) = 0.0 + zhaci(mgs) = 0.0 + + ENDDO + + IF ( lzh .gt. 1 ) THEN ! + do mgs = 1,ngscnt + + + IF ( qx(mgs,lh) .gt. qxmin(lh) .and. cx(mgs,lh) .gt. 0.0 ) THEN + tmp = qx(mgs,lh)/cx(mgs,lh) + alp = Max( alphamin, alpha(mgs,lh) ) +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + g1 = g1x(mgs,lh) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) +! g1r = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + + zhaci(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qhaci(mgs) ) + zhacs(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qhacs(mgs) ) + + IF ( .not. mixedphase .and. ibinhmlr < 1 ) THEN + zhmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*tmp * qhmlr(mgs) - tmp**2 * chmlr(mgs) ) + ENDIF + + zhshr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshr(mgs) ) + +! IF ( lzr > 0 .and. qhshr(mgs) /= 0.0 .and. chshrr(mgs) /= 0.0 .and. ibinhmlr < 1 ) THEN + IF ( lzr > 0 .and. qhshr(mgs) /= 0.0 .and. chshrr(mgs) /= 0.0 ) THEN +! IF ( temg(mgs) > tfr + 2.0 ) THEN +! zhshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshrr(mgs) ) +! IF ( zhshrr(mgs) > 0. ) THEN +! zhshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshr(mgs) ) +! ENDIF +! z1 = g1shr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) ) ! should this be g1shr? +! zhshrr(mgs) = Max( z1, zhshrr(mgs)) +! ELSE +! zhshrr(mgs) = g1shr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) ) + + + IF ( temg(mgs) >= tfr ) THEN + ! zhshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn0(lr)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshrr(mgs) ) + ! IF ( zhshrr(mgs) > 0.0 ) THEN + ! zhshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn0(lr)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshr(mgs) ) + ! ENDIF + IF ( (shedalp + alpha(mgs,lh))*xdia(mgs,lh,1) < sheddiam ) THEN ! if not shedding small drops, then use alpha of hail + z1 = g1*(6.0*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) ) + ELSE + z1 = g1shr*(6.0*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) ) ! should this be g1shr? + ENDIF + zhshrr(mgs) = z1 +! z1 = g1mlr*(rho0(mgs)/(xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) ) ! should this be g1shr? +! zhshrr(mgs) = Max( z1, zhshrr(mgs)) + ELSE + zhshrr(mgs) = g1shr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) ) + ENDIF + + zhshrr(mgs) = Min( 0.0, zhshrr(mgs) ) + ENDIF + + IF ( zhshr(mgs) > 0.0 ) THEN + write(0,*) 'Problem with zhshr! zhshr,qhshr,chshr = ',zhshr(mgs),qhshr(mgs),chshr(mgs) + write(0,*) 'g1,tmp, qx,cx,zx = ',g1,tmp,qx(mgs,lh),cx(mgs,lh),zx(mgs,lh) + write(0,*) ( 2.*tmp * qhshr(mgs) - tmp**2 * chshr(mgs) ), 2.*tmp * qhshr(mgs), - tmp**2 * chshr(mgs) + write(0,*) 'temcg = ',temcg(mgs),'chshr recalc = ',(cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhshr(mgs) + + STOP + ENDIF + + +! zhshr(mgs) = (xdn0(lr)/(xdn(mgs,lh)))**2*( zx(mgs,lh) * qhshr(mgs) ) + + qtmp = qhdpv(mgs) + qhcev(mgs) + ctmp = chdpv(mgs) + chcev(mgs) + + zhdsv(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qtmp - tmp**2 * ctmp ) + + alp = Max( alphahacx, alpha(mgs,lh) ) +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + g1 = g1x(mgs,lh) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + + IF ( .true. ) THEN ! { + IF ( qhacr(mgs) .gt. 0.0 ) THEN +! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacr(mgs) ) + +! g1r = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) +! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacr(mgs) ) + zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacr(mgs) ) +! zhacrf(mgs) = g1*zhacr + + +! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lh)+dtp*qhacr(mgs))**2)/(cx(mgs,lh)) + + IF ( z > zx(mgs,lh) ) THEN +! zhacr(mgs) = (z - zx(mgs,lh))*dtpinv + ELSE +! zhacr(mgs) = 0.0 + ENDIF + ENDIF + +! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) ) +! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) - tmp**2 * chacr(mgs) ) + +! alp = Max( 1.0, alpha(mgs,lh)+1. ) +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/ +! : ((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + IF ( qhacw(mgs) .gt. 0.0 ) THEN +! zhacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacw(mgs) ) + zhacw(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacw(mgs) ) + +! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lh)+dtp*(qhacw(mgs)-qhmul1(mgs)))**2)/(cx(mgs,lh)) + IF ( z > zx(mgs,lh) ) THEN +! zhacw(mgs) = (z - zx(mgs,lh))*dtpinv + ENDIF + ENDIF + + ELSE ! } { ! this is not used because of the 'true' above + + IF ( qhacw(mgs) .gt. 0.0 .or. qhacr(mgs) .gt. 0.0 ) THEN + z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lh)+dtp*(qhacr(mgs) + qhacw(mgs)-qhmul1(mgs)))**2)/(cx(mgs,lh)) +! zhacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacw(mgs) ) + IF ( z > zx(mgs,lh) ) THEN + zhacw(mgs) = (z - zx(mgs,lh))*dtpinv + ENDIF + ENDIF + + ENDIF ! } + + IF ( qhlcnh(mgs) .gt. 0.0 .and. ihlcnh < 2 ) THEN + zhlcnh(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qhlcnh(mgs) - tmp**2 * chlcnh(mgs) ) + ENDIF + ENDIF +! qsplinter(mgs) + IF ( ffrzh*qiacrf(mgs) .gt. 0.0 .and. cx(mgs,lr) .gt. 0.0 .and. qx(mgs,lr) .gt. qxmin(lr) ) THEN + tmp = qx(mgs,lr)/cx(mgs,lr) +! alp = 3.0 +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + IF ( imurain == 3 ) THEN + ! note that 3.6476 = (6/pi)**2 + ziacr(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,lr)+2.)/(xdn0(lr)**2*(alpha(mgs,lr)+1.))* & + & ( 2.*tmp * qiacrf(mgs) - tmp**2 * ciacrf(mgs) ) + ELSE ! imurain == 1 + ziacr(mgs) = 3.6476*rho0(mgs)**2*g1x(mgs,lr)/(xdn0(lr)**2)* & + & ( 2.*tmp * qiacrf(mgs) - tmp**2 * ciacrf(mgs) ) + ENDIF + ziacr(mgs) = Min( ziacr(mgs), zxmxd(mgs,lr) ) +! ziacrf(mgs) = (xdn(mgs,lr)/xdn(mgs,lh))**2 * ziacr(mgs) + ziacrf(mgs) = (xdn(mgs,lr)/xdnmx(lh))**2 * ziacr(mgs) +! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*tmp * (qiacrf(mgs) - qsplinter(mgs)) - tmp**2 * ciacrf(mgs) ) +! ziacrf(mgs) = Min( ziacrf(mgs), z ) + ENDIF + + + + IF ( ffrzh*qrfrzf(mgs) .gt. 0.0 .and. cx(mgs,lr) .gt. 0.0 ) THEN + tmp = qx(mgs,lr)/cx(mgs,lr) +! alp = 3.0 +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + IF ( imurain == 3 ) THEN + zrfrz(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,lr)+2.)/(xdn0(lr)**2*(alpha(mgs,lr)+1.)) * & + & ( 2.*tmp * qrfrzf(mgs) - tmp**2 * crfrzf(mgs) ) + zrfrzf(mgs) = (xdn(mgs,lr)/xdn(mgs,lh))**2 * zrfrz(mgs) + ELSEIF ( imurain == 1 .and. ibiggopt /= 2 ) THEN +! zrfrz(mgs) = 3.6476*rho0(mgs)**2*g1x(mgs,lr)/(xdn0(lr)**2) * & +! & ( 2.*tmp * qrfrzf(mgs) - tmp**2 * crfrz(mgs) ) + zrfrz(mgs) = 3.6476*rho0(mgs)**2*g1x(mgs,lr)/(xdn0(lr)**2) * & + & ( 2.*tmp * qrfrz(mgs) - tmp**2 * crfrz(mgs) ) + zrfrzf(mgs) = 3.6476*rho0(mgs)**2*g1x(mgs,lr)/(rhofrz**2) * & + & ( 2.*tmp * qrfrzf(mgs) - tmp**2 * crfrzf(mgs) ) + ENDIF + zrfrz(mgs) = Min( zrfrz(mgs), Max(0.4,qrfrz(mgs)/qx(mgs,lr))*zx(mgs,lr)*dtpinv ) +! zrfrzf(mgs) = (xdn(mgs,lr)/xdn(mgs,lh))**2 * zrfrz(mgs) +! zrfrzf(mgs) = (xdn(mgs,lr)/xdnmx(lh))**2 * zrfrz(mgs) +! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*tmp * (qrfrzf(mgs)-qsplinter2(mgs)) - tmp**2 * crfrzf(mgs) ) +! zrfrzf(mgs) = Min( zrfrzf(mgs), z ) + ! change this to be alpha=0? + ENDIF + + IF ( lhl > 1 .and. qhcnhl(mgs) .gt. 0.0 ) THEN + tmp = qx(mgs,lhl)/cx(mgs,lhl) + zhcnhl(mgs) = g1x(mgs,lhl)*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*( tmp ) * qhcnhl(mgs) - tmp**2 * chcnhl(mgs) ) + + ENDIF + + IF ( qhcns(mgs) > 0.0 .and. chcns(mgs) > 0.0 .and. cx(mgs,ls) > cxmin .and. vhcns(mgs) > 0 ) THEN + tmp = qx(mgs,ls)/cx(mgs,ls) + r = rho0(mgs)*qhcns(mgs)/vhcns(mgs) ! density of new graupel particles + IF ( imusnow == 3 ) THEN + zhcns(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,ls)+2.)/(r**2*(alpha(mgs,ls)+1.)) * & + & ( 2.*tmp * qhcns(mgs) - tmp**2 * chcns(mgs) ) + ELSE + write(0,*) 'Value of imusnow not valid. Must be 3 (fix me for =1). imusnow = ',imusnow + STOP + ENDIF + ENDIF + + IF ( qhcni(mgs) > 0.0 .and. chcni(mgs) > 0.0 .and. cx(mgs,li) > cxmin .and. vhcni(mgs) > 0 ) THEN + tmp = qx(mgs,li)/cx(mgs,li) + r = rho0(mgs)*qhcni(mgs)/vhcni(mgs) ! density of new graupel particles + zhcni(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,li)+2.)/(r**2*(alpha(mgs,li)+1.)) * & + & ( 2.*tmp * qhcni(mgs) - tmp**2 * chcni(mgs) ) + ENDIF + + + pzhwi(mgs) = & + & +ifrzg*ffrzh*(zrfrzf(mgs) & + & +il5(mgs)*ifiacrg*(ziacrf(mgs) ) ) & +! : + zhcnsh(mgs) + zhcnih(mgs) & + & + zhacw(mgs) & + & + zhacr(mgs) & + & + zhcnhl(mgs) & + & + zhacs(mgs) & + & + zhaci(mgs) & + & + f2h*zhcni(mgs) + f2h*zhcns(mgs) & + & + Max( 0.0, zhdsv(mgs) ) + + pzhwd(mgs) = 0.0 & + & + (1-il5(mgs))*zhmlr(mgs) & + & + zhshr(mgs) & +! > + il5(mgs)*chsbv(mgs) & + & + Min( 0.0, zhdsv(mgs) ) & + & - il5(mgs)*zhlcnh(mgs) + + + IF ( igs(mgs) == 44 .and. kgs(mgs) == 23 .or. dtp*( pqhwi(mgs) + pqhwd(mgs) ) > qxmin(lh) ) THEN +! write(0,*) 'i,k,time = ',igs(mgs),kgs(mgs),time_real +! write(0,*) 'pzhwi,d = ',pzhwi(mgs),pzhwd(mgs),dtp*( pzhwi(mgs) + pzhwd(mgs) ),zx(mgs,lh) +! write(0,*) 'pqhwi,d = ',pqhwi(mgs),pqhwd(mgs),dtp*( pqhwi(mgs) + pqhwd(mgs) ),qx(mgs,lh) +! write(0,*) 'pchwi,d = ',pchwi(mgs),pchwd(mgs),dtp*( pchwi(mgs) + pchwd(mgs) ),cx(mgs,lh) + ENDIF + + +! IF ( zhcnhl(mgs) < 0.0 ) THEN +! write(0,*) 'Problem with zhcnhl! zhcnhl,qhcnhl,chcnhl = ',zhcnhl(mgs),qhcnhl(mgs),chcnhl(mgs) +! write(0,*) 'g1,tmp = ',g1x(mgs,lhl),tmp +! write(0,*) ( 2.*( tmp ) * qhcnhl(mgs) - tmp**2 * chcnhl(mgs) ) +! +!! STOP +! ENDIF + end do + + if (ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'end graupel reflectivity' + + ENDIF + +! +! Hail reflectivity +! + + do mgs = 1,ngscnt + + zhldsv(mgs) = 0.0 + zhlacr(mgs) = 0.0 + zhlacw(mgs) = 0.0 + + ENDDO + + IF ( lzhl .gt. 1 .or. ( lzr > 1 .and. lnhl > 1 ) ) THEN ! also run for 2-moment hail for 3-moment rain sources + + if (ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'hail reflectivity' + + do mgs = 1,ngscnt + + IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. cx(mgs,lhl) .gt. 0.0 ) THEN + tmp = qx(mgs,lhl)/cx(mgs,lhl) + alp = Max( alphamin, alpha(mgs,lhl) ) +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + g1 = g1x(mgs,lhl) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + + IF ( .not. mixedphase .and. qhlmlr(mgs) /= 0.0 .and. chlmlr(mgs) /= 0.0 .and. ibinhlmlr < 1 ) THEN + zhlmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*tmp * qhlmlr(mgs) - tmp**2 * chlmlr(mgs) ) + ENDIF + + zhlshr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*tmp * qhlshr(mgs) - tmp**2 * chlshr(mgs) ) + IF ( lzr > 1 .and. qhlshr(mgs) /= 0.0 .and. chlshrr(mgs) /= 0.0 ) THEN + IF ( temg(mgs) >= tfr ) THEN + ! zhlshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn0(lr)))**2*( 2.*tmp * qhlshr(mgs) - tmp**2 * chlshrr(mgs) ) + ! IF ( zhlshrr(mgs) > 0.0 ) THEN + ! zhlshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn0(lr)))**2*( 2.*tmp * qhlshr(mgs) - tmp**2 * chlshr(mgs) ) + ! ENDIF + IF ( (shedalp + alpha(mgs,lhl))*xdia(mgs,lhl,1) < sheddiam ) THEN ! if not shedding small drops, then use alpha of hail + z1 = g1*(6.0*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlshr(mgs)**2/ chlshrr(mgs) ) + ELSE + z1 = g1shr*(6.0*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlshr(mgs)**2/ chlshrr(mgs) ) ! should this be g1shr? + ENDIF + zhlshrr(mgs) = z1 +! z1 = g1mlr*(rho0(mgs)/(xdn(mgs,lr)))**2*( qhlshr(mgs)**2/ chlshrr(mgs) ) ! should this be g1shr? +! zhlshrr(mgs) = Max( z1, zhlshrr(mgs)) + ELSE + zhlshrr(mgs) = g1shr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlshr(mgs)**2/ chlshrr(mgs) ) + ENDIF + + zhlshrr(mgs) = Min( 0.0, zhlshrr(mgs) ) + ENDIF + + IF ( zhlshr(mgs) > 0.0 ) THEN + write(0,*) 'Problem with zhlshr! zhlshr,qhlshr,chlshr = ',zhlshr(mgs),qhlshr(mgs),chlshr(mgs) + write(0,*) 'g1,tmp, qx,cx,zx = ',g1,tmp,qx(mgs,lhl),cx(mgs,lhl),zx(mgs,lhl) + write(0,*) ( 2.*tmp * qhlshr(mgs) - tmp**2 * chlshr(mgs) ), 2.*tmp * qhlshr(mgs), - tmp**2 * chlshr(mgs) + write(0,*) 'temcg = ',temcg(mgs),'chlshr recalc = ',(cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlshr(mgs) + + STOP + ENDIF +! zhlshr(mgs) = Min( 0.0, zhlshr(mgs) ) + +! zhlshr(mgs) = (xdn0(lr)/(xdn(mgs,lhl)))**2*( zx(mgs,lhl) * qhlshr(mgs) ) + + qtmp = qhldpv(mgs) + qhlcev(mgs) + ctmp = chldpv(mgs) + chlcev(mgs) + + zhldsv(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*( tmp ) * qtmp - tmp**2 * ctmp ) + + alp = Max( alphahacx, alpha(mgs,lhl) ) +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + g1 = g1x(mgs,lhl) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + + IF ( .true. ) THEN ! { + IF ( qhlacr(mgs) .gt. 0.0 ) THEN +! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lhl)+dtp*qhlacr(mgs))**2)/(cx(mgs,lhl)) + zhlacr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*( tmp ) * qhlacr(mgs) ) +! zhlacr(mgs) = Min( zxmxd(mgs,lr), zhlacr(mgs) ) + +! IF ( z > zx(mgs,lhl) ) THEN +! zhlacr(mgs) = (z - zx(mgs,lhl))*dtpinv +! ELSE +! zhlacr(mgs) = 0.0 +! ENDIF + ENDIF + +! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) ) +! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) - tmp**2 * chacr(mgs) ) + + IF ( qhlacw(mgs) .gt. 0.0 ) THEN + alp = Max( 3.0, alpha(mgs,lhl)+1. ) + g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + +! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lhl)+dtp*(qhlacw(mgs)-qhlmul1(mgs)))**2)/(cx(mgs,lhl)) +! zhlacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lhl)/cx(mgs,lhl)) * qhlacw(mgs) ) + zhlacw(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*tmp * qhlacw(mgs) ) + +! IF ( z > zx(mgs,lhl) ) THEN +! zhlacw(mgs) = (z - zx(mgs,lhl))*dtpinv +! ENDIF + g1 = g1x(mgs,lhl) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) + ENDIF + + ELSE ! } .false. { + + IF ( qhlacw(mgs) .gt. 0.0 .or. qhlacr(mgs) .gt. 0.0 ) THEN + z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lhl)+dtp*(qhlacr(mgs) + qhlacw(mgs)-qhlmul1(mgs)))**2)/(cx(mgs,lhl)) +! zhlacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lhl)/cx(mgs,lhl)) * qhlacw(mgs) ) + IF ( z > zx(mgs,lhl) ) THEN + zhlacw(mgs) = (z - zx(mgs,lhl))*dtpinv + ENDIF + ENDIF + + ENDIF ! } + + ENDIF +! qsplinter(mgs) + + IF ( lzhl > 1 ) THEN + pzhli(mgs) = ffrzh*(((1.0-ifrzg)*zrfrzf(mgs) & + & +il5(mgs)*(1.0-ifiacrg)*ziacrf(mgs) )) & + & + il5(mgs)*zhlcnh(mgs) & + & + zhlacw(mgs) & + & + zhlacr(mgs) & +! : + zhlacs(mgs) & + & + Max( 0.0, zhldsv(mgs) ) + + pzhld(mgs) = 0.0 & + & + (1-il5(mgs))*zhlmlr(mgs) & + & + zhlshr(mgs) & + & - zhcnhl(mgs) & + & + Min( 0.0, zhldsv(mgs) ) + + + IF ( .not. ( -1.0 < pzhli(mgs) .and. pzhli(mgs) < 1.e20 ) ) THEN + write(iunit,*) 'Problem with pzhli!' + write(iunit,*) 'zhlcnh,zhlacw,zhlacr,zhldsv = ',zhlcnh(mgs),zhlacw(mgs),zhlacr(mgs),zhldsv(mgs) + ENDIF + + IF ( .not. ( -1.0e20 < pzhld(mgs) .and. pzhld(mgs) < 1. ) ) THEN + write(iunit,*) 'Problem with pzhld!' + write(iunit,*) 'zhlmlr,zhlshr,zhldsv = ',zhlmlr(mgs),zhlshr(mgs),zhldsv(mgs) + ENDIF + + ENDIF ! lzhl > 1 + + end do + + ENDIF + +! +! rain reflectivity +! + if (ndebug .gt. 0 ) write(0,*) 'WARMZIEG: dbg = 11' + + IF ( lzr .gt. 1 ) THEN ! + + DO mgs = 1,ngscnt + + zracw(mgs) = 0.0 + zracr(mgs) = 0.0 + zrcev(mgs) = 0.0 + zrach(mgs) = 0.0 + zrachl(mgs) = 0.0 + zsshr(mgs) = 0.0 + zsshrr(mgs) = 0.0 + zsmlr(mgs) = 0.0 + zsmlrr(mgs) = 0.0 + + IF ( qx(mgs,ls) .gt. qxmin(ls) .and. ( csmlr(mgs) /= 0.0 .or. csshr(mgs) /= 0.0 .or. & + csmlrr(mgs) /= 0.0 .or. csshrr(mgs) /= 0.0) ) THEN !{ + tmp = qx(mgs,ls)/cx(mgs,ls) + g1 = 36.*(xnu(ls)+2.0)/((xnu(ls)+1.0)*pi**2) + IF ( .not. mixedphase ) THEN + zsmlr(mgs) = (xdn(mgs,ls)/xdn(mgs,lr))**2*g1*(rho0(mgs)/(xdn(mgs,ls)))**2* & + & ( 2.*tmp * qsmlr(mgs) - tmp**2 * csmlr(mgs) ) + + IF ( csmlrr(mgs) /= 0.0 ) THEN + z1 = g1smlr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qsmlr(mgs)**2/ csmlrr(mgs) ) + zsmlrr(mgs) = z1 + ENDIF + ENDIF + +! zsshr(mgs) = (xdn(mgs,ls)/xdn(mgs,lr))**2*g1*(rho0(mgs)/(xdn(mgs,ls)))**2* & +! & ( 2.*tmp * qsshr(mgs) - tmp**2 * csshr(mgs) ) + + IF ( csshrr(mgs) /= 0.0 ) THEN + z1 = g1smlr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qsshr(mgs)**2/ csshrr(mgs) ) + zsshrr(mgs) = z1 + ENDIF + + ENDIF !} + + IF ( .not. mixedphase ) THEN !{ + IF ( zhmlr(mgs) < 0.0 .and. chmlrr(mgs) /= 0.0 .and. ibinhmlr == 0 ) THEN !{ + tmp = qx(mgs,lh)/cx(mgs,lh) +! zhmlrr(mgs) = Min(0.0, (xdn(mgs,lh)/xdn(mgs,lr))**2 * & +! & g1x(mgs,lh)*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*tmp * qhmlr(mgs) - tmp**2 * chmlrr(mgs) ) ) + +! IF ( zhmlrr(mgs) >= 0. ) THEN +! zhmlrr(mgs) = (xdn(mgs,lh)/xdn(mgs,lr))**2 * zhmlr(mgs) +! ENDIF + IF ( (shedalp + alpha(mgs,lh))*xdia(mgs,lh,1) < sheddiam ) THEN ! if not shedding small drops, then use alpha of graupel + z1 = g1x(mgs,lh)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhmlr(mgs)**2/ chmlrr(mgs) ) + ELSE ! assume drops are shed off, so use either alpha for shedding or graupel alpha, whichever gives the lower g-factor (i.e., larger alpha) + z1 = Min(g1x(mgs,lh),g1shr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhmlr(mgs)**2/ chmlrr(mgs) ) + ENDIF + zhmlrr(mgs) = z1 +! z1 = g1mlr*(rho0(mgs)/(xdn(mgs,lr)))**2*( qhmlr(mgs)**2/ chmlrr(mgs) ) +! zhmlrr(mgs) = Max( z1, zhmlrr(mgs)) + ENDIF !} + + +! zhshrr(mgs) = (xdn(mgs,lh)/xdn(mgs,lr))**2 * zhshr(mgs) + + IF ( lhl > 1 .and. qhlmlr(mgs) /= 0 .and. ibinhlmlr == 0) THEN + tmp = qx(mgs,lhl)/cx(mgs,lhl) +! zhlmlrr(mgs) = Min(0.0, (xdn(mgs,lhl)/xdn(mgs,lr))**2 * & +! & g1x(mgs,lhl)*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*tmp * qhlmlr(mgs) - tmp**2 * chlmlrr(mgs) ) ) + +! IF ( zhlmlrr(mgs) >= 0. ) THEN ! should be negative, if not, then use alternate calculation +! zhlmlrr(mgs) = (xdn(mgs,lhl)/xdn(mgs,lr))**2 * zhlmlr(mgs) +! ENDIF + + IF ( (shedalp + alpha(mgs,lhl))*xdia(mgs,lhl,1) < sheddiam ) THEN ! if not shedding small drops, then use alpha of hail + z1 = g1x(mgs,lhl)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlmlr(mgs)**2/ chlmlrr(mgs) ) + ELSE ! assume drops are shed off, so use either alpha for shedding or graupel alpha, whichever gives the lower g-factor (i.e., larger alpha) + z1 = Min(g1x(mgs,lhl),g1shr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlmlr(mgs)**2/ chlmlrr(mgs) ) +! z1 = g1shr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlmlr(mgs)**2/ chlmlrr(mgs) ) + ENDIF + zhlmlrr(mgs) = z1 + +! z1 = g1mlr*(rho0(mgs)/(xdn(mgs,lr)))**2*( qhlmlr(mgs)**2/ chlmlrr(mgs) ) +! zhlmlrr(mgs) = Max( z1, zhlmlrr(mgs)) +! zhlmlr(mgs) = +! zhlshrr(mgs) = (xdn(mgs,lhl)/xdn(mgs,lr))**2 * zhlshr(mgs) + ENDIF + + ENDIF ! } + + IF ( qx(mgs,lr) .gt. qxmin(lr) .and. cx(mgs,lr) .gt. 0.0 ) THEN + + tmp = qx(mgs,lr)/cx(mgs,lr) + g1 = g1x(mgs,lr) ! 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + + + IF ( qracw(mgs) > 0.0 .and. cx(mgs,lr) > 0.0 ) THEN + zracw(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*tmp * qracw(mgs) ) + ENDIF + + IF ( cracr(mgs) > 0.0 .and. cx(mgs,lr) > 0.0 ) THEN + zracr(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*1000.))**2*( tmp**2 * cracr(mgs) ) + ENDIF + + qtmp = qrcev(mgs) + ctmp = crcev(mgs) + +! IF ( .false. .or. iferwisventr == 2 ) THEN +! zrcev(mgs) = Min(0.0, (12./(pii*xdn(mgs,lr)))*xdia(mgs,lr,1)**3*fvce(mgs)*rwcap(mgs)*rwventz(mgs) ) +! ELSE + zrcev(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( 2.*( tmp ) * qtmp - tmp**2 * ctmp ) + + + IF ( iferwisventr == 2 ) THEN + vent1 = Min(0.0, (12./(pii*xdn(mgs,lr)))*xdia(mgs,lr,1)**3*fvce(mgs)*rwcap(mgs)*rwventz(mgs)) + zrcev(mgs) = Max( zrcev(mgs), vent1 ) + ENDIF +! IF ( ny == 2 .and. igs(mgs) == 20 ) THEN +! write(0,*) 'k,zrcevold,new,maxdep : ',kgs(mgs),zrcev(mgs),vent1,-zxmxd(mgs,lr),alpha(mgs,lr),cx(mgs,lr) +! ENDIF + + +! ENDIF + zrcev(mgs) = Max( zrcev(mgs), -zxmxd(mgs,lr) ) - ELSEIF ( warmonly < 0.8 ) THEN -! -! Graupel -! - do mgs = 1,ngscnt - pqhwi(mgs) = & - & +il5(mgs)*ifrzg*(qrfrzf(mgs) ) & - & +il5(mgs)*(qhdpv(mgs)) & - & +qhacr(mgs)+qhacw(mgs) - pqhwd(mgs) = & - & qhshr(mgs) & !null at this point when wet graupel included - & - qhlcnh(mgs) & - & - qhmul1(mgs) & - & - qsplinter(mgs) - qsplinter2(mgs) & - & +(1-il5(mgs))*qhmlr(mgs) !null at this point when wet graupel included - end do + IF ( qhacr(mgs) > 0.0 ) THEN + zrach(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2* & + & ( 2.*( qx(mgs,lr)/cx(mgs,lr)) * qhacr(mgs) - tmp**2 * chacr(mgs) ) + zrach(mgs) = Min( zrach(mgs), zxmxd(mgs,lr) ) + + ENDIF -! -! Hail -! - IF ( lhl .gt. 1 ) THEN + IF ( lhl > 1 .and. qhlacr(mgs) > 0.0 ) THEN + zrachl(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2* & + & ( 2.*( qx(mgs,lr)/cx(mgs,lr)) * qhlacr(mgs) - tmp**2 * chlacr(mgs) ) + zrachl(mgs) = Min( zrachl(mgs), zxmxd(mgs,lr) ) + ENDIF - do mgs = 1,ngscnt - pqhli(mgs) = & - & +il5(mgs)*(qhldpv(mgs) ) & ! + (1.0-ifrzg)*(qiacrf(mgs)+qrfrzf(mgs) + qracif(mgs))) & - & +il5(mgs)*(1.0-ifrzg)*(qrfrzf(mgs) ) & - & +qhlacr(mgs)+qhlacw(mgs) & -! & +qhlacs(mgs)+qhlaci(mgs) & - & + qhlcnh(mgs) - pqhld(mgs) = & - & qhlshr(mgs) & - & +(1-il5(mgs))*qhlmlr(mgs) & -! > +il5(mgs)*qhlsbv(mgs) & - & + qhlsbv(mgs) & - & -qhlmul1(mgs) - qhcnhl(mgs) - end do + + ENDIF - ENDIF ! lhl + pzrwi(mgs) = zrcnw(mgs) + zracw(mgs) + zracr(mgs) & + & + Max( 0.,zrcev(mgs) ) & + & - (1-il5(mgs))*zsmlrr(mgs) & + & - zsshrr(mgs) & + & - (1-il5(mgs))*zhmlrr(mgs) & + & - zhshrr(mgs) & + & - (1-il5(mgs))*zhlmlrr(mgs) & + & - zhlshrr(mgs) - ENDIF ! warmonly -! -! Liquid water on snow and graupel -! + pzrwd(mgs) = 0.0 & + & + Min(0.,zrcev(mgs) ) & + & - zrach(mgs) & + & - zrachl(mgs) & + & - zrfrz(mgs) & + & - il5(mgs)*(ziacr(mgs) ) - vhmlr(:) = 0.0 - vhlmlr(:) = 0.0 - vhfzh(:) = 0.0 - vhlfzhl(:) = 0.0 - IF ( mixedphase ) THEN - ELSE ! set arrays for non-mixedphase graupel - -! vhshdr(:) = 0.0 - vhmlr(:) = qhmlr(:) ! not actually volume, but treated as q in rate equation -! vhsoak(:) = 0.0 + IF ( zx(mgs,lr) + dtp*(pzrwi(mgs)+pzrwd(mgs)) <= 0.0 & + .and. qx(mgs,lr) > qxmin(lr) ) THEN + pzrwd(mgs) = -zx(mgs,lr)*dtpinv - pzrwi(mgs) + ENDIF -! vhlshdr(:) = 0.0 - vhlmlr(:) = qhlmlr(:) ! not actually volume, but treated as q in rate equation -! vhlmlr(:) = rho0(:)*qhlmlr(:)/xdn(:,lhl) -! vhlsoak(:) = 0.0 + ENDDO - ENDIF ! mixedphase + ENDIF @@ -18678,6 +21897,33 @@ subroutine nssl_2mom_gs & ! > + rho0(mgs)*qhshr(mgs)/xdn(mgs,lh) !xdn(mgs,lr) ! ENDIF + IF ( lzh > 1 .and. qx(mgs,lh) > qxmin(lh) ) THEN +! Calculate change in reflectivity due to density changes + + xdn_new = rho0(mgs)*(qx(mgs,lh) + dtp*(pqhwi(mgs) + pqhwd(mgs) ))/ & + & (vx(mgs,lh) + dtp*(pvhwi(mgs) + pvhwd(mgs)) ) + + IF ( mixedphase ) THEN + IF ( qxw(mgs,lh) .gt. 0.0 ) THEN + dnmx = xdnmx(lr) + ELSE + dnmx = xdnmx(lh) + ENDIF + ELSE + dnmx = xdnmx(lh) + ENDIF + + xdn_new = Max( Min( xdn_new, dnmx ), xdnmn(lh) ) + + drhodt = (xdn_new - xdn(mgs,lh))*dtpinv + + zhwdn(mgs) = -2.*g1x(mgs,lh)*(rho0(mgs)*qx(mgs,lh)*6.*pii )**2/(cx(mgs,lh)*xdn(mgs,lh)**3)*drhodt + + pzhwi(mgs) = pzhwi(mgs) + Max(0.0, zhwdn(mgs)) + pzhwd(mgs) = pzhwd(mgs) + Min(0.0, zhwdn(mgs)) + + + ENDIF IF ( .false. .and. ny .eq. 2 .and. kgs(mgs) .eq. 9 .and. igs(mgs) .eq. 19 ) THEN write(iunit,*) @@ -18760,6 +22006,32 @@ subroutine nssl_2mom_gs & & + rho0(mgs)*(1-il5(mgs))*vhlmlr(mgs)/xdn(mgs,lhl) & & + vhlshdr(mgs) - vhlsoak(mgs) + IF ( lzhl > 1 .and. qx(mgs,lhl) > qxmin(lhl) ) THEN +! Calculate change in reflectivity due to density changes + + xdn_new = rho0(mgs)*(qx(mgs,lhl) + dtp*(pqhli(mgs) + pqhld(mgs) ))/ & + & (vx(mgs,lhl) + dtp*(pvhli(mgs) + pvhld(mgs)) ) + + IF ( mixedphase ) THEN + IF ( qxw(mgs,lhl) .gt. 0.0 ) THEN + dnmx = xdnmx(lr) + ELSE + dnmx = xdnmx(lhl) + ENDIF + ELSE + dnmx = xdnmx(lhl) + ENDIF + xdn_new = Max( Min( xdn_new, dnmx ), xdnmn(lhl) ) + + drhodt = (xdn_new - xdn(mgs,lhl))*dtpinv + + zhldn(mgs) = -2.*g1x(mgs,lhl)*(rho0(mgs)*qx(mgs,lhl)*6.*pii )**2/(cx(mgs,lhl)*xdn(mgs,lhl)**3)*drhodt + + pzhli(mgs) = pzhli(mgs) + Max(0.0, zhldn(mgs)) + pzhld(mgs) = pzhld(mgs) + Min(0.0, zhldn(mgs)) + + + ENDIF ENDDO @@ -18989,7 +22261,7 @@ subroutine nssl_2mom_gs & write(iunit,*) -qracs(mgs)*(1-il2(mgs)) , qhacs(mgs) , qhlacs(mgs) write(iunit,*) -qhcns(mgs) write(iunit,*) +(1-il5(mgs))*qsmlr(mgs) , qsshr(mgs) - write(iunit,*) (qssbv(mgs)) + write(iunit,*) qssbv(mgs) write(iunit,*) Min(0.0, qscev(mgs)) write(iunit,*) -qsmul(mgs) ! @@ -19061,33 +22333,37 @@ subroutine nssl_2mom_gs & IF ( warmonly < 0.5 ) THEN pfrz(mgs) = & & (1-il5(mgs))* & - & (qhmlr(mgs)+qsmlr(mgs)+qhlmlr(mgs)) & !+qhmlh(mgs)) & - & +il5(mgs)*(qhfzh(mgs)+qsfzs(mgs)+qhlfzhl(mgs)) & + & (qhmlr(mgs)+ & + & qsmlr(mgs)+qhlmlr(mgs)) & !+qhmlh(mgs)) & & +il5(mgs)*(1-imixedphase)*( & & qsacw(mgs)+qhacw(mgs) + qhlacw(mgs) & & +qsacr(mgs)+qhacr(mgs) + qhlacr(mgs) & & +qsshr(mgs) & & +qhshr(mgs) & - & +qhlshr(mgs) +qrfrz(mgs)+qiacr(mgs) & + & +qhlshr(mgs) & + & +qrfrz(mgs)+qiacr(mgs) & & ) & & +il5(mgs)*(qwfrz(mgs) & & +qwctfz(mgs)+qiihr(mgs) & & +qiacw(mgs)) pmlt(mgs) = & & (1-il5(mgs))* & - & (qhmlr(mgs)+qsmlr(mgs)+qhlmlr(mgs)) !+qhmlh(mgs)) + & (qhmlr(mgs)+qsmlr(mgs)+ & + & qhlmlr(mgs)) !+qhmlh(mgs)) ! NOTE: psub is sum of sublimation and deposition psub(mgs) = & & il5(mgs)*( & & + qsdpv(mgs) + qhdpv(mgs) & & + qhldpv(mgs) & & + qidpv(mgs) + qisbv(mgs) ) & - & + qssbv(mgs) + qhsbv(mgs) + qhlsbv(mgs) & + & + qssbv(mgs) + qhsbv(mgs) & + & + qhlsbv(mgs) & & +il5(mgs)*(qiint(mgs)) pvap(mgs) = & - & qrcev(mgs) + qhcev(mgs) + qscev(mgs) + qhlcev(mgs) + & qrcev(mgs) + qhcev(mgs) + qscev(mgs) + qhlcev(mgs) + qfcev(mgs) pevap(mgs) = & - & Min(0.0,qrcev(mgs)) + Min(0.0,qhcev(mgs)) + Min(0.0,qscev(mgs)) + Min(0.0,qhlcev(mgs)) + & Min(0.0,qrcev(mgs)) + Min(0.0,qhcev(mgs)) + Min(0.0,qscev(mgs)) + Min(0.0,qhlcev(mgs)) & + + Min(0.0,qfcev(mgs)) ! NOTE: pdep is the deposition part only pdep(mgs) = & & il5(mgs)*( & @@ -19115,7 +22391,7 @@ subroutine nssl_2mom_gs & & + qidpv(mgs) + qisbv(mgs) ) & & +il5(mgs)*(qiint(mgs)) pvap(mgs) = & - & qrcev(mgs) + qhcev(mgs) + qhlcev(mgs) ! + qscev(mgs) + & qrcev(mgs) + qhcev(mgs) + qhlcev(mgs) + qfcev(mgs) ELSE pfrz(mgs) = 0.0 psub(mgs) = 0.0 @@ -19143,6 +22419,8 @@ subroutine nssl_2mom_gs & ! ! do mgs = 1,ngscnt + + qwvp(mgs) = qwvp(mgs) + & & dtp*(pqwvi(mgs)+pqwvd(mgs)) qx(mgs,lc) = qx(mgs,lc) + & @@ -19155,6 +22433,7 @@ subroutine nssl_2mom_gs & & dtp*(pqswi(mgs)+pqswd(mgs)) qx(mgs,lh) = qx(mgs,lh) + & & dtp*(pqhwi(mgs)+pqhwd(mgs)) + IF ( lhl .gt. 1 ) THEN qx(mgs,lhl) = qx(mgs,lhl) + & & dtp*(pqhli(mgs)+pqhld(mgs)) @@ -19224,6 +22503,27 @@ subroutine nssl_2mom_gs & + ENDIF + ENDIF + IF ( ipconc .ge. 6 ) THEN + IF ( lzr .gt. 1 ) THEN + zx(mgs,lr) = zx(mgs,lr) + & + & dtp*(pzrwi(mgs)+pzrwd(mgs)) + ENDIF + IF ( lzs .gt. 1 ) THEN + zx(mgs,ls) = zx(mgs,ls) + & + & dtp*(pzswi(mgs)+pzswd(mgs)) + ENDIF + IF ( lzh .gt. 1 ) THEN + zx(mgs,lh) = zx(mgs,lh) + & + & dtp*(pzhwi(mgs)+pzhwd(mgs)) + ENDIF + IF ( lzhl .gt. 1 ) THEN + zx(mgs,lhl) = zx(mgs,lhl) + & + & dtp*(pzhli(mgs)+pzhld(mgs)) +! IF ( pchli(mgs) .ne. 0. .or. pchld(mgs) .ne. 0 ) THEN +! write(0,*) 'dr: cx,pchli,pchld = ', cx(mgs,lhl),pchli(mgs),pchld(mgs), igs(mgs),kgs(mgs) +! ENDIF ENDIF ENDIF end do @@ -19775,6 +23075,29 @@ subroutine nssl_2mom_gs & ENDIF + + + +! +! 6th moments +! + + IF ( ipconc .ge. 6 ) THEN + DO il = lr,lhab + IF ( lz(il) .gt. 1 ) THEN + IF ( lf > 1 .and. il == lf ) THEN + lfsave(mgs,3) = an(igs(mgs),jy,kgs(mgs),lz(il)) + lfsave(mgs,4) = zx(mgs,il) + ENDIF + + an(igs(mgs),jy,kgs(mgs),lz(il)) = zx(mgs,il) + & + & min( an(igs(mgs),jy,kgs(mgs),lz(il)), 0.0 ) + zx(mgs,il) = an(igs(mgs),jy,kgs(mgs),lz(il)) + + ENDIF + ENDDO + + ENDIF ! end do ! @@ -19839,6 +23162,447 @@ subroutine nssl_2mom_gs & ENDIF !} ENDDO ! mgs + ELSE ! } { is three-moment, so have to adjust Z if size is too large + IF ( il == lr .and. imurain == 3 ) THEN ! { { RAIN + +! rdmx = +! rdmn = + + DO mgs = 1,ngscnt + + + IF ( iresetmoments == 1 .or. iresetmoments == il ) THEN + IF ( zx(mgs,lr) <= zxmin ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il) + qx(mgs,lr) = 0.0 + cx(mgs,lr) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),lr) + an(igs(mgs),jgs,kgs(mgs),lr) = qx(mgs,lr) + an(igs(mgs),jgs,kgs(mgs),ln(lr)) = cx(mgs,lr) + ELSEIF ( cx(mgs,lr) <= cxmin ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il) + zx(mgs,lr) = 0.0 + qx(mgs,lr) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),lr) + an(igs(mgs),jgs,kgs(mgs),lr) = qx(mgs,lr) + an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr) + ENDIF + ENDIF + + IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN + + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-11,cx(mgs,lr))) + IF ( xv(mgs,lr) .gt. xvmx(lr) ) THEN +! xv(mgs,lr) = xvmx(lr) +! cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmx(lr)*xdn(mgs,lr)) + ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN + xv(mgs,lr) = xvmn(lr) + cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr)) + ENDIF + + IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN +! have mass and reflectivity but no concentration, so set concentration, using default alpha + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + z = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*xdn(mgs,lr)**2) +! an(igs(mgs),jgs,kgs(mgs),ln(il)) = zx(mgs,il) + ELSEIF ( zx(mgs,il) <= 0.0 .and. cx(mgs,il) > 0.0 ) THEN +! have mass and concentration but no reflectivity, so set reflectivity, using default alpha + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + chw = cx(mgs,il) + qr = qx(mgs,il) + zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(xdn(mgs,lr)**2*chw) + an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr) + + ELSEIF ( zx(mgs,il) <= 0.0 .and. cx(mgs,il) <= 0.0 ) THEN +! How did this happen? + ! set values according to dBZ of -10, or Z = 0.1 +! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 + zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2 + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + z = zx(mgs,il) + qr = qx(mgs,il) + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*1000.*1000) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ENDIF + + IF ( zx(mgs,lr) > 0.0 ) THEN + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(1000.*cx(mgs,lr)) + vr = xv(mgs,lr) +! z = 36.*(alpha(kz)+2.0)*a(ix,jy,kz,lnr)*vr**2/((alpha(kz)+1.0)*pi**2) + qr = qx(mgs,lr) + nrx = cx(mgs,lr) + z = zx(mgs,lr) + +! xv = (db(1,kz)*a(1,1,kz,lr))**2/(a(1,1,kz,lnr)) +! rd = z*(pi/6.*1000.)**2/xv + +! determine shape parameter alpha by iteration + IF ( z .gt. 0.0 ) THEN +! alpha(mgs,lr) = 3. + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. +! write(0,*) 'kz, alp, alpha(kz) = ',kz,alp,alpha(kz),rd,z,xv + DO i = 1,20 + IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT + alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) ) + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. + alp = Max( rnumin, Min( rnumax, alp ) ) + ENDDO + +! check for artificial breakup (rain larger than allowed max size) + IF ( xv(mgs,il) .gt. xvmx(il) .or. (ioldlimiter == 2 .and. xv(mgs,il) .gt. xvmx(il)/8.) ) THEN + tmp = cx(mgs,il) +! write(0,*) 'MY limiter: xv: ',xv(mgs,il), xv(mgs,il)/(xvmx(il)/8.) +! STOP + IF ( ioldlimiter == 2 ) THEN ! MY-style active breakup + x = (6.*rho0(mgs)*qx(mgs,il)/(pi*xdn(mgs,il)*cx(mgs,il)))**(1./3.) + x1 = Max(0.0e-3, x - 3.0e-3) + x2 = Max(0.5, x/6.0e-3) + x3 = x2**3 + cx(mgs,il) = cx(mgs,il)*Max((1.+2.222e3*x1**2), x3) + xv(mgs,il) = xv(mgs,il)/Max((1.+2.222e3*x1**2), x3) + ELSE ! simple cutoff + xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) ) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) + ENDIF + !xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + !cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) + + + IF ( tmp < cx(mgs,il) ) THEN ! breakup + + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) ) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + vr = xv(mgs,lr) + qr = qx(mgs,lr) + nrx = cx(mgs,lr) + z = zx(mgs,lr) + + +! determine shape parameter alpha by iteration + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. + DO i = 1,20 + IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT + alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) ) + alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. + alp = Max( rnumin, Min( rnumax, alp ) ) + ENDDO + + + ENDIF + ENDIF + +! +! Check whether the shape parameter is at or less than the minimum, and if it is, reset the +! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N) +! + g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) + IF ( .true. .and. (alpha(mgs,il) <= rnumin .or. alp == rnumin .or. alp == rnumax) ) THEN + + IF ( rescale_high_alpha .and. alp >= rnumax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(1./(xdn(mgs,il)))**2 + an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il) + + ELSEIF ( rescale_low_alphar .and. alp <= rnumin ) THEN + z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2) + zx(mgs,il) = z + an(igs(mgs),jy,kgs(mgs),lz(il)) = zx(mgs,il) + ENDIF + ENDIF + + + + ENDIF + ENDIF + + ENDIF + + ENDDO +! CALL cld_cpu('Z-MOMENT-1r') + + + ELSEIF ( il == lh .or. il == lhl .or. il == lf .or. (il == lr .and. imurain == 1 )) THEN ! } { Rain, GRAUPEL OR HAIL + + + + DO mgs = 1,ngscnt + + IF ( lf > 1 .and. il == lf ) THEN + lfsave(mgs,5) = an(igs(mgs),jy,kgs(mgs),ln(il)) + lfsave(mgs,6) = cx(mgs,il) + ENDIF + + IF ( il == lhl .and. lnhlf > 1 ) THEN + IF ( cx(mgs,lhl) > cxmin ) THEN + frac = chxf(mgs,lhl)/cx(mgs,lhl) + ELSE + frac = 0.0 + ENDIF + ENDIF + + IF ( il == lh .and. lnhf > 1 ) THEN + IF ( cx(mgs,lh) > cxmin ) THEN + frach = chxf(mgs,lh)/cx(mgs,lh) + ELSE + frach = 0.0 + ENDIF + ENDIF + + + + IF ( iresetmoments == 1 .or. iresetmoments == il .or. iresetmoments == -1 ) THEN ! { .or. qx(mgs,il) <= qxmin(il) + IF ( zx(mgs,il) <= zxmin ) THEN ! .and. qx(mgs,il) > 0.05e-3 +!! write(91,*) 'zx=0; qx,cx = ',1000.*qx(mgs,il),cx(mgs,il) + qx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ELSEIF ( iresetmoments == -1 .and. qx(mgs,il) < qxmin(il) ) THEN + zx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + ELSEIF ( cx(mgs,il) <= cxmin .and. iresetmoments /= -1 ) THEN ! .and. qx(mgs,il) > 0.05e-3 + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il) + zx(mgs,il) = 0.0 + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + ENDIF + ELSE + IF ( zx(mgs,il) < 0.0 ) THEN ! .and. qx(mgs,il) > 0.05e-3 + zx(mgs,il) = 0.0 + ENDIF + ENDIF !} + + + IF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= cxmin ) THEN + zx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + ENDIF + + IF ( qx(mgs,il) .gt. qxmin(il) ) THEN !{ + + xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(1.0e-9,cx(mgs,il))) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + + IF ( xv(mgs,il) .lt. xvmn(il) ) THEN + xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) ) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) + ENDIF + + IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN !{ +! have mass and reflectivity but no concentration, so set concentration, using default alpha + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + z = zx(mgs,il) + qr = qx(mgs,il) +! cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(z*(pi*xdn(mgs,il))**2) + + + ELSEIF ( zx(mgs,il) <= 0.0 .and. cx(mgs,il) > 0.0 ) THEN +! have mass and concentration but no reflectivity, so set reflectivity, using default alpha +! g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & +! & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + chw = cx(mgs,il) + qr = qx(mgs,il) +! zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw +! zx(mgs,il) = Min(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(chw*(pi*xdn(mgs,il))**2) ) + g1 = (6.0 + alphamax)*(5.0 + alphamax)*(4.0 + alphamax)/ & + & ((3.0 + alphamax)*(2.0 + alphamax)*(1.0 + alphamax)) + zx(mgs,il) = Max(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(chw*(pi*xdn(mgs,il))**2) ) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + ELSEIF ( zx(mgs,il) <= 0.0 .and. cx(mgs,il) <= 0.0 ) THEN +! How did this happen? + ! set values according to dBZ of -10, or Z = 0.1 +! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 + +! write(0,*) 'GS: moment problem! il,c,z,q = ',il,cx(mgs,il),zx(mgs,il),qx(mgs,il) + + zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2 + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + z = zx(mgs,il) + qr = qx(mgs,il) +! cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(z*(pi*xdn(mgs,il))**2) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + +! write(0,*) 'GS: moment problem! reset il,c,z,q = ',il,cx(mgs,il),zx(mgs,il),qx(mgs,il) + + ELSE + ! have all valid moments, so find shape parameter + chw = cx(mgs,il) + qr = qx(mgs,il) + z = zx(mgs,il) + + IF ( zx(mgs,il) .gt. 0. ) THEN !{ + +! rdi = z*(pi/6.*1000.)**2*chw/((rho0(mgs)*qr)**2) + rdi = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2) + +! alp = 1.e18*(6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ +! : ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 + alp = (6.0+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 +! print*,'kz, alp, alpha(mgs,il) = ',kz,alp,alpha(mgs,il),rdi,z,xv + DO i = 1,10 +! IF ( 100.*Abs(alp - alpha(mgs,il))/(Abs(alpha(mgs,il))+1.e-5) .lt. 1. ) EXIT + IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT + alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) ) +! alp = 1.e18*(6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ +! : ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 + alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 +! print*,'i,alp = ',i,alp + alp = Max( alphamin, Min( alphamax, alp ) ) + ENDDO + + +! check for artificial breakup (graupel/hail larger than allowed max size) + IF ( xv(mgs,il) .gt. xvmx(il) ) THEN !{ + tmp = cx(mgs,il) + + + xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) ) + xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) + cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) + IF ( tmp < cx(mgs,il) ) THEN ! breakup + g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2) + zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) ) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + chw = cx(mgs,il) + qr = qx(mgs,il) + z = zx(mgs,il) + + rdi = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2) + alp = (6.0+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 + DO i = 1,10 + IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT + alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) ) + alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & + & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0 + alp = Max( alphamin, Min( alphamax, alp ) ) + ENDDO + + + ENDIF + ENDIF !} + +! +! Check whether the shape parameter is at or less than the minimum, and if it is, reset the +! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N) +! + g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & + & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) + + IF ( ( lrescalelow(il) .or. rescale_high_alpha ) .and. & + & ( alpha(mgs,il) <= alphamin .or. alp == alphamin .or. alp == alphamax ) ) THEN !{ + + IF ( rescale_high_alpha .and. alp >= alphamax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z + cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2 + an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il) + + ELSEIF ( lrescalelow(il) .and. alp <= alphamin .and. .not. (il == lh .and. icvhl2h > 0 ) .and. & + .not. ( il == lr .and. .not. rescale_low_alphar ) ) THEN ! alpha = alphamin, so reset Z to prevent growth in C + + wtest = .false. + IF ( irescalerainopt == 0 ) THEN + wtest = .false. + ELSEIF ( irescalerainopt == 1 ) THEN + wtest = qx(mgs,lc) > qxmin(lc) + ELSEIF ( irescalerainopt == 2 ) THEN + wtest = qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < rescale_wthresh + ELSEIF ( irescalerainopt == 3 ) THEN + wtest = temcg(mgs) > rescale_tempthresh .and. qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < rescale_wthresh + ENDIF + + IF ( il == lr .and. ( wtest .or. .not. rescale_low_alphar ) ) THEN + ! certain situations where rain number is adjusted instead of Z. Helps avoid rain being 'zapped' by autoconverted + ! drops (i.e., favor preserving Z when alpha tries to go negative) + chw = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2 ! g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z1 + cx(mgs,il) = chw + an(igs(mgs),jy,kgs(mgs),ln(il)) = chw + ELSE + ! Usual resetting of reflectivity moment to force consisntency between Q, N, Z, and alpha when alpha = alphamin + z1 = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw + z = z1*(6./(pi*xdn(mgs,il)))**2 + zx(mgs,il) = z + an(igs(mgs),jy,kgs(mgs),lz(il)) = z + ENDIF + +! z1 = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw +! z = z1*(6./(pi*xdn(mgs,il)))**2 +! zx(mgs,il) = z +! an(igs(mgs),jy,kgs(mgs),lz(il)) = z + ENDIF + + ENDIF !} + + + ENDIF !} + + + ENDIF ! !} + + + + ENDIF !} + + IF ( il == lhl .and. lnhlf > 1 ) THEN + ! update chxf in case cx has changed + chxf(mgs,lhl) = frac*cx(mgs,lhl) + ENDIF + IF ( il == lh .and. lnhf > 1 ) THEN + ! update chxf in case cx has changed + chxf(mgs,lh) = frach*cx(mgs,lh) + ENDIF + + +! IF ( lf > 0 .and. il == lf .and. kgs(mgs) <= 20 .and. ( cx(mgs,lf) + dtp*( pcfwi(mgs) + pcfwd(mgs) ) > 200. .or. cx(mgs,lf) > 400. )) THEN +! write(0,*) 'ix,jy, kz, cf = ',igs(mgs)+ixbeg,jy+jybeg,kgs(mgs), an(igs(mgs),jy,kgs(mgs),ln(lf)),lfsave(mgs,5),lfsave(mgs,6) +! write(0,*) 'qold,qxold,zold,zxold = ',lfsave(mgs,1),lfsave(mgs,2),lfsave(mgs,3),lfsave(mgs,4) +! write(0,*) 'cf_new,pcfwi,pcfwd = ',cx(mgs,lf),cx(mgs,lf) + dtp*( pcfwi(mgs) + pcfwd(mgs) ),pcfwi(mgs) + pcfwd(mgs) +! +! ENDIF + + ENDDO ! mgs + +! CALL cld_cpu('Z-DELABK') + + +! CALL cld_cpu('Z-DELABK') + + + + + ENDIF ! } } ENDIF ! }} ENDIF ! } diff --git a/physics/mp_nssl.F90 b/physics/mp_nssl.F90 index 4e0e323ce..9c7951542 100644 --- a/physics/mp_nssl.F90 +++ b/physics/mp_nssl.F90 @@ -32,7 +32,7 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & imp_physics, imp_physics_nssl, & nssl_cccn, nssl_alphah, nssl_alphahl, & nssl_alphar, nssl_ehw0_in, nssl_ehlw0_in, & - nssl_ccn_on, nssl_hail_on, nssl_invertccn ) + nssl_ccn_on, nssl_hail_on, nssl_invertccn, nssl_3moment ) use module_mp_nssl_2mom, only: nssl_2mom_init, nssl_2mom_init_const @@ -54,12 +54,12 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & integer, intent(in) :: imp_physics_nssl real(kind_phys), intent(in) :: nssl_cccn, nssl_alphah, nssl_alphahl real(kind_phys), intent(in) :: nssl_alphar, nssl_ehw0_in, nssl_ehlw0_in - logical, intent(in) :: nssl_ccn_on, nssl_hail_on, nssl_invertccn + logical, intent(in) :: nssl_ccn_on, nssl_hail_on, nssl_invertccn, nssl_3moment ! Local variables: dimensions used in nssl_init integer :: ims,ime, jms,jme, kms,kme, nx, nz, i,k real :: nssl_params(20) - integer :: ihailv + integer :: ihailv,ipc ! Initialize the CCPP error handling variables @@ -104,9 +104,9 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & nssl_params(:) = 0.0 - nssl_params(1) = nssl_cccn - nssl_params(2) = nssl_alphah - nssl_params(3) = nssl_alphahl + ! nssl_params(1) = nssl_cccn ! use direct interface instead + ! nssl_params(2) = nssl_alphah ! use direct interface instead + ! nssl_params(3) = nssl_alphahl ! use direct interface instead nssl_params(4) = 4.e5 ! nssl_cnoh -- not used for 2-moment nssl_params(5) = 4.e4 ! nssl_cnohl-- not used for 2-moment nssl_params(6) = 4.e5 ! nssl_cnor-- not used for 2-moment @@ -114,10 +114,6 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & nssl_params(8) = 500. ! nssl_rho_qh nssl_params(9) = 800. ! nssl_rho_qhl nssl_params(10) = 100. ! nssl_rho_qs - nssl_params(11) = 0 ! nssl_ipelec_tmp - nssl_params(12) = 11 ! nssl_isaund - nssl_params(13) = 0 ! 1= turn on cccna; 0 = turn off - nssl_params(14) = nssl_alphar nssl_qccn = nssl_cccn/1.225 ! if (mpirank==mpiroot) then @@ -129,10 +125,21 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & ELSE ihailv = -1 ENDIF + + IF ( nssl_3moment ) THEN + ipc = 8 + ELSE + ipc = 5 + ENDIF ! write(0,*) 'call nssl_2mom_init' - CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0, & - ihvol=ihailv,nssl_ehw0=nssl_ehw0_in,nssl_ehlw0=nssl_ehlw0_in,errmsg=errmsg,errflg=errflg,myrank=mpirank,mpiroot=mpiroot) + CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=ipc,mixphase=0, & + ihvol=ihailv,nssl_ehw0=nssl_ehw0_in,nssl_ehlw0=nssl_ehlw0_in,errmsg=errmsg, & + nssl_alphar=nssl_alphar, & + nssl_alphah=nssl_alphah, & + nssl_alphahl=nssl_alphahl, & + nssl_cccn=nssl_cccn, & + errflg=errflg,myrank=mpirank,mpiroot=mpiroot) ! For restart runs, the init is done here if (restart) then @@ -161,6 +168,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & ! spechum, cccn, qc, qr, qi, qs, qh, qhl, & spechum, cccn, cccna, qc, qr, qi, qs, qh, qhl, & ccw, crw, cci, csw, chw, chl, vh, vhl, & + zrw, zhw, zhl, & tgrs, prslk, prsl, phii, omega, dtp, & prcp, rain, graupel, ice, snow, sr, & refl_10cm, do_radar_ref, first_time_step, restart, & @@ -168,7 +176,8 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & nleffr, nieffr, nseffr, nreffr, & imp_physics, convert_dry_rho, & imp_physics_nssl, nssl_ccn_on, & - nssl_hail_on, nssl_invertccn, ntccn, ntccna, & + nssl_hail_on, nssl_invertccn, nssl_3moment, & + ntccn, ntccna, & errflg, errmsg) use module_mp_nssl_2mom, only: calcnfromq, na @@ -197,6 +206,9 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & real(kind_phys), intent(inout) :: chl(:,:) !(1:ncol,1:nlev) hail number real(kind_phys), intent(inout) :: vh (:,:) !(1:ncol,1:nlev) graupel volume real(kind_phys), intent(inout) :: vhl(:,:) !(1:ncol,1:nlev) hail volume + real(kind_phys), intent(inout) :: zrw(:,:) !(1:ncol,1:nlev) rain reflectivity + real(kind_phys), intent(inout) :: zhw(:,:) !(1:ncol,1:nlev) graupel reflectivity + real(kind_phys), intent(inout) :: zhl(:,:) !(1:ncol,1:nlev) hail reflectivity ! State variables and timestep information real(kind_phys), intent(inout) :: tgrs (:,:) !(1:ncol,1:nlev) real(kind_phys), intent(in ) :: prsl (:,:) !(1:ncol,1:nlev) @@ -223,7 +235,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & integer, intent(in) :: nleffr, nieffr, nseffr, nreffr integer, intent(in) :: imp_physics integer, intent(in) :: imp_physics_nssl - logical, intent(in) :: nssl_ccn_on, nssl_hail_on, nssl_invertccn + logical, intent(in) :: nssl_ccn_on, nssl_hail_on, nssl_invertccn, nssl_3moment integer, intent(in) :: ntccn, ntccna integer, intent(out) :: errflg @@ -256,6 +268,9 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & ! create temporaries for hail in case it does not exist !real(kind_phys) :: chl_mp(1:ncol,1:nlev) !< kg-1 (number mixing ratio) real(kind_phys) :: vhl_mp(1:ncol,1:nlev) !< m3 kg-1 (volume mixing ratio) + real(kind_phys) :: zrw_mp(1:ncol,1:nlev) !< m6 kg-1 (reflectivity) + real(kind_phys) :: zhw_mp(1:ncol,1:nlev) !< m6 kg-1 (reflectivity) + real(kind_phys) :: zhl_mp(1:ncol,1:nlev) !< m6 kg-1 (reflectivity) ! Vertical velocity and level width real(kind_phys) :: w(1:ncol,1:nlev) !< m s-1 real(kind_phys) :: dz(1:ncol,1:nlev) !< m @@ -342,10 +357,17 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & ns_mp = csw/(1.0_kind_phys-spechum) nh_mp = chw/(1.0_kind_phys-spechum) vh_mp = vh/(1.0_kind_phys-spechum) + IF ( nssl_3moment ) THEN + zrw_mp = zrw/(1.0_kind_phys-spechum) + zhw_mp = zhw/(1.0_kind_phys-spechum) + ENDIF IF ( nssl_hail_on ) THEN qhl_mp = qhl/(1.0_kind_phys-spechum) nhl_mp = chl/(1.0_kind_phys-spechum) vhl_mp = vhl/(1.0_kind_phys-spechum) + IF ( nssl_3moment ) THEN + zhl_mp = zhl/(1.0_kind_phys-spechum) + ENDIF ENDIF ELSE ! qv_mp = spechum ! /(1.0_kind_phys-spechum) @@ -361,10 +383,18 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & ni_mp = cci ns_mp = csw nh_mp = chw + vh_mp = vh + IF ( nssl_3moment ) THEN + zrw_mp = zrw + zhw_mp = zhw + ENDIF IF ( nssl_hail_on ) THEN qhl_mp = qhl ! /(1.0_kind_phys-spechum) nhl_mp = chl vhl_mp = vhl + IF ( nssl_3moment ) THEN + zhl_mp = zhl + ENDIF ENDIF ENDIF @@ -593,6 +623,9 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & VHW=vh_mp, & VHL=vhl_mp, & cn=cn_mp, & + ZRW=zrw_mp, & + ZHW=zhw_mp, & + ZHL=zhl_mp, & ! cna=cna_mp, f_cna=( ntccna > 0 ), & ! for future use cna=cna_mp, f_cna=.false. , & PII=prslk, & @@ -645,6 +678,9 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & CHL=nhl_mp, & VHW=vh_mp, & VHL=vhl_mp, & + ZRW=zrw_mp, & + ZHW=zhw_mp, & + ZHL=zhl_mp, & ! cn=cccn, & PII=prslk, & P=prsl, & @@ -750,10 +786,17 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & csw = ns_mp/(1.0_kind_phys+qv_mp) chw = nh_mp/(1.0_kind_phys+qv_mp) vh = vh_mp/(1.0_kind_phys+qv_mp) + IF ( nssl_3moment ) THEN + zrw = zrw_mp/(1.0_kind_phys+qv_mp) + zhw = zhw_mp/(1.0_kind_phys+qv_mp) + ENDIF IF ( nssl_hail_on ) THEN qhl = qhl_mp/(1.0_kind_phys+qv_mp) chl = nhl_mp/(1.0_kind_phys+qv_mp) vhl = vhl_mp/(1.0_kind_phys+qv_mp) + IF ( nssl_3moment ) THEN + zhl = zhl_mp/(1.0_kind_phys+qv_mp) + ENDIF ENDIF ELSE ! spechum = qv_mp ! /(1.0_kind_phys+qv_mp) @@ -770,10 +813,17 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & csw = ns_mp chw = nh_mp vh = vh_mp + IF ( nssl_3moment ) THEN + zrw = zrw_mp + zhw = zhw_mp + ENDIF IF ( nssl_hail_on ) THEN qhl = qhl_mp ! /(1.0_kind_phys+qv_mp) chl = nhl_mp vhl = vhl_mp + IF ( nssl_3moment ) THEN + zhl = zhl_mp + ENDIF ENDIF ENDIF diff --git a/physics/mp_nssl.meta b/physics/mp_nssl.meta index c7e398f0a..e628b0ff0 100644 --- a/physics/mp_nssl.meta +++ b/physics/mp_nssl.meta @@ -210,6 +210,13 @@ dimensions = () type = logical intent = in +[nssl_3moment] + standard_name = nssl_3moment + long_name = 3-moment activation flag in NSSL microphysics scheme + units = flag + dimensions = () + type = logical + intent = in ######################################################################## [ccpp-arg-table] name = mp_nssl_run @@ -387,6 +394,30 @@ type = real kind = kind_phys intent = inout +[zrw] + standard_name = reflectivity_of_rain_of_new_state + long_name = rain reflectivity + units = m6 kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[zhw] + standard_name = reflectivity_of_graupel_of_new_state + long_name = graupel reflectivity + units = m6 kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[zhl] + standard_name = reflectivity_of_hail_of_new_state + long_name = hail reflectivity + units = m6 kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout [tgrs] standard_name = air_temperature_of_new_state long_name = model layer mean temperature @@ -614,6 +645,13 @@ dimensions = () type = logical intent = in +[nssl_3moment] + standard_name = nssl_3moment + long_name = 3-moment activation flag in NSSL microphysics scheme + units = flag + dimensions = () + type = logical + intent = in [ntccn] standard_name = index_of_cloud_condensation_nuclei_number_concentration_in_tracer_concentration_array long_name = tracer index for cloud condensation nuclei number concentration From 1d9cdbe935e07dc5a9f844c7cfd65c95ad3d3ff3 Mon Sep 17 00:00:00 2001 From: Helin Wei Date: Wed, 12 Apr 2023 08:25:15 -0400 Subject: [PATCH 215/380] move noahmp table reading to noahmpdrv_ini --- physics/noahmp_tables.f90 | 2 +- physics/noahmpdrv.F90 | 8 +++----- 2 files changed, 4 insertions(+), 6 deletions(-) diff --git a/physics/noahmp_tables.f90 b/physics/noahmp_tables.f90 index f43ea8608..0e44b3cfc 100644 --- a/physics/noahmp_tables.f90 +++ b/physics/noahmp_tables.f90 @@ -308,7 +308,7 @@ module noahmp_tables contains - subroutine read_mp_table_parameters(dataset_identifier) + subroutine read_mp_table_parameters implicit none diff --git a/physics/noahmpdrv.F90 b/physics/noahmpdrv.F90 index 7b42f6197..c2743e15a 100644 --- a/physics/noahmpdrv.F90 +++ b/physics/noahmpdrv.F90 @@ -37,6 +37,7 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, me, isot, ivegsrc, & use machine, only: kind_phys use set_soilveg_mod, only: set_soilveg use namelist_soilveg + use noahmp_tables implicit none integer, intent(in) :: lsm @@ -88,6 +89,8 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, me, isot, ivegsrc, & !--- initialize soil vegetation call set_soilveg(me, isot, ivegsrc, nlunit, errmsg, errflg) + !--- read in noahmp table + call read_mp_table_parameters ! initialize psih and psim @@ -162,10 +165,6 @@ subroutine noahmpdrv_run & use sfc_diff, only : stability ! use module_sf_noahmplsm use module_sf_noahmp_glacier -! use noahmp_tables, only : isice_table, co2_table, o2_table, & -! isurban_table, smcref_table, smcdry_table, & -! smcmax_table, co2_table, o2_table, & -! saim_table, laim_table use noahmp_tables implicit none @@ -756,7 +755,6 @@ subroutine noahmpdrv_run & soil_color_category = soilcol(i) ! soil_color_category = 4 - call read_mp_table_parameters(dataset_identifier) call transfer_mp_parameters(vegetation_category, soil_category, & slope_category, soil_color_category, crop_type,parameters) From 3d226e748f73258d70b2799d714aa05e15b810b3 Mon Sep 17 00:00:00 2001 From: Helin Wei Date: Wed, 12 Apr 2023 08:41:20 -0400 Subject: [PATCH 216/380] keep the current NoahMP table values --- physics/noahmptable.tbl | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/physics/noahmptable.tbl b/physics/noahmptable.tbl index e9952c754..02e59b37a 100644 --- a/physics/noahmptable.tbl +++ b/physics/noahmptable.tbl @@ -224,8 +224,8 @@ ! c. he 12/17/2020: optimized mfsno values dependent on land type based on evaluation with snotel swe and modis scf, surface albedo mfsno = 1.00, 1.00, 1.00, 1.00, 1.00, 2.00, 2.00, 2.00, 2.00, 2.00, 3.00, 3.00, 4.00, 4.00, 2.50, 3.00, 3.00, 3.50, 3.50, 3.50, ! c. he 12/17/2020: optimized snow cover factor (m) in scf formulation to replace original constant 2.5*z0,z0=0.002m, based on evaluation with snotel swe and modis scf, surface albedo - scffac = 0.008, 0.008, 0.008, 0.008, 0.008, 0.016, 0.016, 0.020, 0.020, 0.020, 0.020, 0.014, 0.042, 0.026, 0.030, 0.016, 0.030, 0.030, 0.030, 0.030, - +! scffac = 0.008, 0.008, 0.008, 0.008, 0.008, 0.016, 0.016, 0.020, 0.020, 0.020, 0.020, 0.014, 0.042, 0.026, 0.030, 0.016, 0.030, 0.030, 0.030, 0.030, + scffac = 0.005, 0.005, 0.005, 0.005, 0.005, 0.008, 0.008, 0.010, 0.010, 0.010, 0.010, 0.007, 0.021, 0.013, 0.015, 0.008, 0.015, 0.015, 0.015, 0.015, ! row 1: vis ! row 2: near ir rhol_vis=0.07, 0.10, 0.07, 0.10, 0.10, 0.07, 0.07, 0.07, 0.10, 0.11, 0.105, 0.11, 0.00, 0.11, 0.00, 0.00, 0.00, 0.10, 0.10, 0.10, @@ -248,7 +248,8 @@ xl = 0.010, 0.010, 0.010, 0.250, 0.250, 0.010, 0.010, 0.010, 0.010, -0.30, -0.025, -0.30, 0.000, -0.30, 0.000, 0.000, 0.000, 0.250, 0.250, 0.250, ! make cwpvt vegetation dependent according to j. goudriaan, crop micrometeorology: a simulation study (simulation monographs), 1977). c. he, 12/17/2020 - cwpvt = 0.18, 0.67, 0.18, 0.67, 0.29, 1.0, 2.0, 1.3, 1.0, 5.0, 1.17, 1.67, 1.67, 1.67, 0.18, 0.18, 0.18, 0.67, 1.0, 0.18, +! cwpvt = 0.18, 0.67, 0.18, 0.67, 0.29, 1.0, 2.0, 1.3, 1.0, 5.0, 1.17, 1.67, 1.67, 1.67, 0.18, 0.18, 0.18, 0.67, 1.0, 0.18, + cwpvt = 0.09, 0.335, 0.09, 0.335, 0.145, 0.5, 1.0, 0.65, 0.5, 2.5, 0.585, 0.835, 0.835, 0.835, 0.09, 0.09, 0.09, 0.335, 0.5, 0.09, c3psn = 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, kc25 = 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, akc = 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, From bec07e2029c716ad072f1403da5c330b05a37097 Mon Sep 17 00:00:00 2001 From: Helin Wei Date: Thu, 13 Apr 2023 09:14:52 -0400 Subject: [PATCH 217/380] fixed a typo --- physics/module_sf_noahmplsm.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/module_sf_noahmplsm.F90 b/physics/module_sf_noahmplsm.F90 index 08632fea7..5d20a9e18 100644 --- a/physics/module_sf_noahmplsm.F90 +++ b/physics/module_sf_noahmplsm.F90 @@ -4334,7 +4334,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & ! use sfc_diag to calculate t2mv and q2v for opt_sfc=1&3 if(opt_diag ==3) then - if(opt_stc == 1 .or. opt_stc == 3) then + if(opt_sfc == 1 .or. opt_sfc == 3) then fhi = fh2/fh wrk = 1.0 - fhi @@ -4841,7 +4841,7 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & ! use sfc_diag to calculate t2mv and q2v for opt_sfc=1&3 if(opt_diag ==3) then - if(opt_stc == 1 .or. opt_stc == 3) then + if(opt_sfc == 1 .or. opt_sfc == 3) then fhi = fh2/fh wrk = 1.0 - fhi From 87cb6b56f061bff476c446c1dc323028999493ed Mon Sep 17 00:00:00 2001 From: Michael Barlage Date: Thu, 13 Apr 2023 12:49:16 -0400 Subject: [PATCH 218/380] add canopy heat and optional to noahmpdrv --- physics/module_sf_noahmplsm.F90 | 4 +- physics/noahmpdrv.F90 | 127 +++++++++++++++++++++++++++++++- 2 files changed, 125 insertions(+), 6 deletions(-) diff --git a/physics/module_sf_noahmplsm.F90 b/physics/module_sf_noahmplsm.F90 index 5d20a9e18..65b3d77b3 100644 --- a/physics/module_sf_noahmplsm.F90 +++ b/physics/module_sf_noahmplsm.F90 @@ -442,7 +442,7 @@ subroutine noahmp_sflx (parameters, & shg , shc , shb , evg , evb , ghv , & ! out : ghb , irg , irc , irb , tr , evc , & ! out : chleaf , chuc , chv2 , chb2 , fpice , pahv , & - pahg , pahb , pah , esnow , laisun , laisha , rb & + pahg , pahb , pah , esnow , canhs , laisun , laisha , rb & #ifdef CCPP ,errmsg, errflg) #else @@ -724,7 +724,7 @@ subroutine noahmp_sflx (parameters, & logical :: dveg_active !< flag to run dynamic vegetation logical :: crop_active !< flag to run crop model ! add canopy heat storage (C.He added based on GY Niu's communication) - real (kind=kind_phys) :: canhs ! canopy heat storage change w/m2 + real (kind=kind_phys) , intent(out) :: canhs ! canopy heat storage change w/m2 ! intent (out) variables need to be assigned a value. these normally get assigned values ! only if dveg == 2. diff --git a/physics/noahmpdrv.F90 b/physics/noahmpdrv.F90 index c2743e15a..85d3363b4 100644 --- a/physics/noahmpdrv.F90 +++ b/physics/noahmpdrv.F90 @@ -157,7 +157,45 @@ subroutine noahmpdrv_run & sncovr1, qsurf, gflux, drain, evap, hflx, ep, runoff, & cmm, chh, evbs, evcw, sbsno, pah, ecan, etran, edir, snowc,& stm, snohf,smcwlt2, smcref2, wet1, t2mmp, q2mp,zvfun, & - ztmax, errmsg, errflg) + ztmax, errmsg, errflg, & + canopy_heat_storage_ccpp, & + rainfall_ccpp, & + sw_absorbed_total_ccpp, & + sw_reflected_total_ccpp, & + lw_absorbed_total_ccpp, & + temperature_bare_grd_ccpp, & + temperature_veg_grd_ccpp, & + temperature_veg_2m_ccpp, & + temperature_bare_2m_ccpp, & + spec_humidity_veg_2m_ccpp, & + spec_humidity_bare_2m_ccpp, & + sw_absorbed_veg_ccpp, & + sw_absorbed_ground_ccpp, & + snowmelt_out_ccpp, & + snowmelt_shallow_ccpp, & + albedo_direct_snow_ccpp, & + albedo_diffuse_snow_ccpp, & + ch_vegetated_ccpp, & + ch_bare_ground_ccpp, & + sensible_heat_grd_veg_ccpp, & + sensible_heat_leaf_ccpp, & + sensible_heat_grd_bar_ccpp, & + latent_heat_grd_veg_ccpp, & + latent_heat_grd_bare_ccpp, & + ground_heat_veg_ccpp, & + ground_heat_bare_ccpp, & + lw_absorbed_grd_veg_ccpp, & + lw_absorbed_leaf_ccpp, & + lw_absorbed_grd_bare_ccpp, & + latent_heat_trans_ccpp, & + latent_heat_leaf_ccpp, & + ch_leaf_ccpp, & + ch_below_canopy_ccpp, & + ch_vegetated_2m_ccpp, & + ch_bare_ground_2m_ccpp, & + precip_adv_heat_veg_ccpp, & + precip_adv_heat_grd_v_ccpp, & + precip_adv_heat_grd_b_ccpp ) use machine , only : kind_phys use funcphys, only : fpvs @@ -360,6 +398,45 @@ subroutine noahmpdrv_run & character(len=*) , intent(out) :: errmsg integer , intent(out) :: errflg + real(kind=kind_phys), dimension(:) , intent(out), optional :: canopy_heat_storage_ccpp ! within-canopy heat [W/m2] + real(kind=kind_phys), dimension(:) , intent(out), optional :: rainfall_ccpp + real(kind=kind_phys), dimension(:) , intent(out), optional :: sw_absorbed_total_ccpp + real(kind=kind_phys), dimension(:) , intent(out), optional :: sw_reflected_total_ccpp + real(kind=kind_phys), dimension(:) , intent(out), optional :: lw_absorbed_total_ccpp + real(kind=kind_phys), dimension(:) , intent(out), optional :: temperature_bare_grd_ccpp + real(kind=kind_phys), dimension(:) , intent(out), optional :: temperature_veg_grd_ccpp + real(kind=kind_phys), dimension(:) , intent(out), optional :: temperature_veg_2m_ccpp + real(kind=kind_phys), dimension(:) , intent(out), optional :: temperature_bare_2m_ccpp + real(kind=kind_phys), dimension(:) , intent(out), optional :: spec_humidity_veg_2m_ccpp + real(kind=kind_phys), dimension(:) , intent(out), optional :: spec_humidity_bare_2m_ccpp + real(kind=kind_phys), dimension(:) , intent(out), optional :: sw_absorbed_veg_ccpp + real(kind=kind_phys), dimension(:) , intent(out), optional :: sw_absorbed_ground_ccpp + real(kind=kind_phys), dimension(:) , intent(out), optional :: snowmelt_out_ccpp + real(kind=kind_phys), dimension(:) , intent(out), optional :: snowmelt_shallow_ccpp + real(kind=kind_phys), dimension(:,:), intent(out), optional :: albedo_direct_snow_ccpp + real(kind=kind_phys), dimension(:,:), intent(out), optional :: albedo_diffuse_snow_ccpp + real(kind=kind_phys), dimension(:) , intent(out), optional :: ch_vegetated_ccpp + real(kind=kind_phys), dimension(:) , intent(out), optional :: ch_bare_ground_ccpp + real(kind=kind_phys), dimension(:) , intent(out), optional :: sensible_heat_grd_veg_ccpp + real(kind=kind_phys), dimension(:) , intent(out), optional :: sensible_heat_leaf_ccpp + real(kind=kind_phys), dimension(:) , intent(out), optional :: sensible_heat_grd_bar_ccpp + real(kind=kind_phys), dimension(:) , intent(out), optional :: latent_heat_grd_veg_ccpp + real(kind=kind_phys), dimension(:) , intent(out), optional :: latent_heat_grd_bare_ccpp + real(kind=kind_phys), dimension(:) , intent(out), optional :: ground_heat_veg_ccpp + real(kind=kind_phys), dimension(:) , intent(out), optional :: ground_heat_bare_ccpp + real(kind=kind_phys), dimension(:) , intent(out), optional :: lw_absorbed_grd_veg_ccpp + real(kind=kind_phys), dimension(:) , intent(out), optional :: lw_absorbed_leaf_ccpp + real(kind=kind_phys), dimension(:) , intent(out), optional :: lw_absorbed_grd_bare_ccpp + real(kind=kind_phys), dimension(:) , intent(out), optional :: latent_heat_trans_ccpp + real(kind=kind_phys), dimension(:) , intent(out), optional :: latent_heat_leaf_ccpp + real(kind=kind_phys), dimension(:) , intent(out), optional :: ch_leaf_ccpp + real(kind=kind_phys), dimension(:) , intent(out), optional :: ch_below_canopy_ccpp + real(kind=kind_phys), dimension(:) , intent(out), optional :: ch_vegetated_2m_ccpp + real(kind=kind_phys), dimension(:) , intent(out), optional :: ch_bare_ground_2m_ccpp + real(kind=kind_phys), dimension(:) , intent(out), optional :: precip_adv_heat_veg_ccpp + real(kind=kind_phys), dimension(:) , intent(out), optional :: precip_adv_heat_grd_v_ccpp + real(kind=kind_phys), dimension(:) , intent(out), optional :: precip_adv_heat_grd_b_ccpp + ! ! --- some new options, hard code for now ! @@ -535,6 +612,8 @@ subroutine noahmpdrv_run & real (kind=kind_phys) :: lai_shaded ! out | shaded leaf area index [m2/m2] real (kind=kind_phys) :: leaf_air_resistance ! out | leaf boundary layer resistance [s/m] + real (kind=kind_phys) :: canopy_heat_storage ! out | within-canopy heat [W/m2] + real (kind=kind_phys) :: ustarx ! inout |surface friction velocity real (kind=kind_phys) :: prslkix ! in exner function real (kind=kind_phys) :: prsik1x ! in exner function @@ -852,6 +931,7 @@ subroutine noahmpdrv_run & vegetation_fraction = vegetation_frac ch_vegetated = 0.0 ch_bare_ground = ch_noahmp + canopy_heat_storage = 0.0 else ! not glacier @@ -916,12 +996,12 @@ subroutine noahmpdrv_run & latent_heat_leaf ,ch_leaf ,ch_below_canopy , & ch_vegetated_2m ,ch_bare_ground_2m ,precip_frozen_frac , & precip_adv_heat_veg ,precip_adv_heat_grd_v ,precip_adv_heat_grd_b , & - precip_adv_heat_total ,snow_sublimation ,lai_sunlit , & + precip_adv_heat_total ,snow_sublimation ,canopy_heat_storage , & #ifdef CCPP - lai_shaded ,leaf_air_resistance , & + lai_sunlit ,lai_shaded ,leaf_air_resistance , & errmsg ,errflg ) #else - lai_shaded ,leaf_air_resistance ) + lai_sunlit ,lai_shaded ,leaf_air_resistance ) #endif #ifdef CCPP @@ -1011,6 +1091,45 @@ subroutine noahmpdrv_run & zsnsoxy (i,:) = interface_depth + if(present(canopy_heat_storage_ccpp )) canopy_heat_storage_ccpp (i) = canopy_heat_storage + if(present(rainfall_ccpp )) rainfall_ccpp (i) = rainfall + if(present(sw_absorbed_total_ccpp )) sw_absorbed_total_ccpp (i) = sw_absorbed_total + if(present(sw_reflected_total_ccpp )) sw_reflected_total_ccpp (i) = sw_reflected_total + if(present(lw_absorbed_total_ccpp )) lw_absorbed_total_ccpp (i) = lw_absorbed_total + if(present(temperature_bare_grd_ccpp )) temperature_bare_grd_ccpp (i) = temperature_bare_grd + if(present(temperature_veg_grd_ccpp )) temperature_veg_grd_ccpp (i) = temperature_veg_grd + if(present(temperature_veg_2m_ccpp )) temperature_veg_2m_ccpp (i) = temperature_veg_2m + if(present(temperature_bare_2m_ccpp )) temperature_bare_2m_ccpp (i) = temperature_bare_2m + if(present(spec_humidity_veg_2m_ccpp )) spec_humidity_veg_2m_ccpp (i) = spec_humidity_veg_2m + if(present(spec_humidity_bare_2m_ccpp)) spec_humidity_bare_2m_ccpp(i) = spec_humidity_bare_2m + if(present(sw_absorbed_veg_ccpp )) sw_absorbed_veg_ccpp (i) = sw_absorbed_veg + if(present(sw_absorbed_ground_ccpp )) sw_absorbed_ground_ccpp (i) = sw_absorbed_ground + if(present(snowmelt_out_ccpp )) snowmelt_out_ccpp (i) = snowmelt_out + if(present(snowmelt_shallow_ccpp )) snowmelt_shallow_ccpp (i) = snowmelt_shallow + if(present(albedo_direct_snow_ccpp )) albedo_direct_snow_ccpp (i,:) = albedo_direct_snow + if(present(albedo_diffuse_snow_ccpp )) albedo_diffuse_snow_ccpp (i,:) = albedo_diffuse_snow + if(present(ch_vegetated_ccpp )) ch_vegetated_ccpp (i) = ch_vegetated + if(present(ch_bare_ground_ccpp )) ch_bare_ground_ccpp (i) = ch_bare_ground + if(present(sensible_heat_grd_veg_ccpp)) sensible_heat_grd_veg_ccpp(i) = sensible_heat_grd_veg + if(present(sensible_heat_leaf_ccpp )) sensible_heat_leaf_ccpp (i) = sensible_heat_leaf + if(present(sensible_heat_grd_bar_ccpp)) sensible_heat_grd_bar_ccpp(i) = sensible_heat_grd_bar + if(present(latent_heat_grd_veg_ccpp )) latent_heat_grd_veg_ccpp (i) = latent_heat_grd_veg + if(present(latent_heat_grd_bare_ccpp )) latent_heat_grd_bare_ccpp (i) = latent_heat_grd_bare + if(present(ground_heat_veg_ccpp )) ground_heat_veg_ccpp (i) = ground_heat_veg + if(present(ground_heat_bare_ccpp )) ground_heat_bare_ccpp (i) = ground_heat_bare + if(present(lw_absorbed_grd_veg_ccpp )) lw_absorbed_grd_veg_ccpp (i) = lw_absorbed_grd_veg + if(present(lw_absorbed_leaf_ccpp )) lw_absorbed_leaf_ccpp (i) = lw_absorbed_leaf + if(present(lw_absorbed_grd_bare_ccpp )) lw_absorbed_grd_bare_ccpp (i) = lw_absorbed_grd_bare + if(present(latent_heat_trans_ccpp )) latent_heat_trans_ccpp (i) = latent_heat_trans + if(present(latent_heat_leaf_ccpp )) latent_heat_leaf_ccpp (i) = latent_heat_leaf + if(present(ch_leaf_ccpp )) ch_leaf_ccpp (i) = ch_leaf + if(present(ch_below_canopy_ccpp )) ch_below_canopy_ccpp (i) = ch_below_canopy + if(present(ch_vegetated_2m_ccpp )) ch_vegetated_2m_ccpp (i) = ch_vegetated_2m + if(present(ch_bare_ground_2m_ccpp )) ch_bare_ground_2m_ccpp (i) = ch_bare_ground_2m + if(present(precip_adv_heat_veg_ccpp )) precip_adv_heat_veg_ccpp (i) = precip_adv_heat_veg + if(present(precip_adv_heat_grd_v_ccpp)) precip_adv_heat_grd_v_ccpp(i) = precip_adv_heat_grd_v + if(present(precip_adv_heat_grd_b_ccpp)) precip_adv_heat_grd_b_ccpp(i) = precip_adv_heat_grd_b + wslakexy (i) = lake_water ! not active fwetxy (i) = canopy_wet_fraction taussxy (i) = snow_age From 9aed23f91cea354f8cb6c6691c471a285026a54c Mon Sep 17 00:00:00 2001 From: "Haiqin.Li" Date: Thu, 13 Apr 2023 20:26:20 +0000 Subject: [PATCH 219/380] "update to run RRFS with GF" --- physics/cu_gf_deep.F90 | 107 +++++++++++++++++++-------------- physics/cu_gf_driver.F90 | 84 ++++++++++++++------------ physics/cu_gf_driver.meta | 16 +++++ physics/cu_gf_driver_post.F90 | 29 ++++++++- physics/cu_gf_driver_post.meta | 47 +++++++++++++++ physics/set_soilveg_ruc.F90 | 20 +++--- 6 files changed, 207 insertions(+), 96 deletions(-) diff --git a/physics/cu_gf_deep.F90 b/physics/cu_gf_deep.F90 index 5abb990de..2368dc05a 100644 --- a/physics/cu_gf_deep.F90 +++ b/physics/cu_gf_deep.F90 @@ -560,6 +560,7 @@ subroutine cu_gf_deep_run( & c1d(i,:)= 0. !c1 ! 0. ! c1 ! max(.003,c1+float(csum(i))*.0001) entr_rate(i)=7.e-5 - min(20.,float(csum(i))) * 3.e-6 if(xland1(i) == 0)entr_rate(i)=7.e-5 + if(dx(i)<6500.) entr_rate(i)=2.e-4 if(imid.eq.1)entr_rate(i)=3.e-4 ! if(imid.eq.1)c1d(i,:)=c1 ! comment to test warm bias 08/14/17 radius=.2/entr_rate(i) @@ -571,6 +572,7 @@ subroutine cu_gf_deep_run( & endif sig(i)=(1.-frh)**2 frh_out(i) = frh + if((dx(i)<6500.).and.(forcing(i,7).eq.0.))sig(i)=1. enddo !$acc end kernels sig_thresh = (1.-frh_thresh)**2 @@ -606,14 +608,15 @@ subroutine cu_gf_deep_run( & ! !$acc kernels edtmax(:)=1. - if(imid.eq.1)edtmax(:)=.15 +! if(imid.eq.1)edtmax(:)=.15 edtmin(:)=.1 - if(imid.eq.1)edtmin(:)=.05 +! if(imid.eq.1)edtmin(:)=.05 !$acc end kernels ! !--- minimum depth (m), clouds must have ! depth_min=3000. + if(dx(its)<6500.)depth_min=5000. if(imid.eq.1)depth_min=2500. ! !--- maximum depth (mb) of capping @@ -1323,9 +1326,9 @@ subroutine cu_gf_deep_run( & do i=its,itf if(ierr(i)/=0)cycle beta=max(.025,.055-float(csum(i))*.0015) !.02 - if(imid.eq.0 .and. xland1(i) == 0)then - edtmax(i)=max(0.1,.4-float(csum(i))*.015) !.3) - endif +! if(imid.eq.0 .and. xland1(i) == 0)then +! edtmax(i)=max(0.1,.4-float(csum(i))*.015) !.3) +! endif if(imid.eq.1)beta=.025 bud(i)=0. cdd(i,1:jmin(i))=.1*entr_rate(i) @@ -1508,8 +1511,8 @@ subroutine cu_gf_deep_run( & tau_ecmwf (:) = 0. !$acc end kernels !- way to calculate the fraction of cape consumed by shallow convection - iversion=1 ! ecmwf - !iversion=0 ! orig + !iversion=1 ! ecmwf + iversion=0 ! orig ! ! betchold et al 2008 time-scale of cape removal ! @@ -1549,6 +1552,29 @@ subroutine cu_gf_deep_run( & endif enddo !$acc end kernels +!$acc kernels + !-get the profiles modified only by bl tendencies + do i=its,itf + tn_bl(i,:)=0.;qo_bl(i,:)=0. + if ( ierr(i) == 0 )then + !below kbcon -> modify profiles + tn_bl(i,1:kbcon(i)) = tn(i,1:kbcon(i)) + qo_bl(i,1:kbcon(i)) = qo(i,1:kbcon(i)) + !above kbcon -> keep environment profiles + tn_bl(i,kbcon(i)+1:ktf) = t(i,kbcon(i)+1:ktf) + qo_bl(i,kbcon(i)+1:ktf) = q(i,kbcon(i)+1:ktf) + endif + enddo +!$acc end kernels + !> - Call cup_env() to calculate moist static energy, heights, qes, ... only by bl tendencies + call cup_env(zo,qeso_bl,heo_bl,heso_bl,tn_bl,qo_bl,po,z1, & + psur,ierr,tcrit,-1, & + itf,ktf, its,ite, kts,kte) + !> - Call cup_env_clev() to calculate environmental values on cloud levels only by bl tendencies + call cup_env_clev(tn_bl,qeso_bl,qo_bl,heo_bl,heso_bl,zo,po,qeso_cup_bl,qo_cup_bl, & + heo_cup_bl,heso_cup_bl,zo_cup,po_cup,gammao_cup_bl,tn_cup_bl,psur, & + ierr,z1, & + itf,ktf,its,ite, kts,kte) if(iversion == 1) then !-- version ecmwf @@ -1581,29 +1607,6 @@ subroutine cu_gf_deep_run( & !- version for real cloud-work function -!$acc kernels - !-get the profiles modified only by bl tendencies - do i=its,itf - tn_bl(i,:)=0.;qo_bl(i,:)=0. - if ( ierr(i) == 0 )then - !below kbcon -> modify profiles - tn_bl(i,1:kbcon(i)) = tn(i,1:kbcon(i)) - qo_bl(i,1:kbcon(i)) = qo(i,1:kbcon(i)) - !above kbcon -> keep environment profiles - tn_bl(i,kbcon(i)+1:ktf) = t(i,kbcon(i)+1:ktf) - qo_bl(i,kbcon(i)+1:ktf) = q(i,kbcon(i)+1:ktf) - endif - enddo -!$acc end kernels - !> - Call cup_env() to calculate moist static energy, heights, qes, ... only by bl tendencies - call cup_env(zo,qeso_bl,heo_bl,heso_bl,tn_bl,qo_bl,po,z1, & - psur,ierr,tcrit,-1, & - itf,ktf, its,ite, kts,kte) - !> - Call cup_env_clev() to calculate environmental values on cloud levels only by bl tendencies - call cup_env_clev(tn_bl,qeso_bl,qo_bl,heo_bl,heso_bl,zo,po,qeso_cup_bl,qo_cup_bl, & - heo_cup_bl,heso_cup_bl,zo_cup,po_cup,gammao_cup_bl,tn_cup_bl,psur, & - ierr,z1, & - itf,ktf,its,ite, kts,kte) !$acc kernels do i=its,itf if(ierr(i).eq.0)then @@ -1661,7 +1664,7 @@ subroutine cu_gf_deep_run( & aa1_bl(i) = aa1_bl(i)* tau_bl(i)/ dtime !endif #ifndef _OPENACC - print*,'aa0,aa1bl=',aa0(i),aa1_bl(i),aa0(i)-aa1_bl(i),tau_bl(i)!,dtime,xland(i) +! print*,'aa0,aa1bl=',aa0(i),aa1_bl(i),aa0(i)-aa1_bl(i),tau_bl(i)!,dtime,xland(i) #endif endif enddo @@ -2116,6 +2119,9 @@ subroutine cu_gf_deep_run( & imid,ipr,itf,ktf, & its,ite, kts,kte, & dicycle,tau_ecmwf,aa1_bl,xf_dicycle) + do i=its,itf + if((dx(i)<6500.).and.(forcing(i,3).le.0.))sig(i)=1. + enddo ! !$acc kernels do k=kts,ktf @@ -2157,6 +2163,8 @@ subroutine cu_gf_deep_run( & xff_mid(i,1)=min(0.1,xff_mid(i,1)) endif xff_mid(i,2)=min(0.1,.03*zws(i)) + forcing(i,1)=xff_mid(i,1) + forcing(i,2)=xff_mid(i,2) endif enddo !$acc end kernels @@ -2181,6 +2189,7 @@ subroutine cu_gf_deep_run( & !$acc kernels do i=its,itf if(ierr(i).eq.0 .and.pre(i).gt.0.) then + forcing(i,6)=sig(i) pre(i)=max(pre(i),0.) xmb_out(i)=xmb(i) outu(i,1)=dellu(i,1)*xmb(i) @@ -3308,11 +3317,11 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 xff_ens3(4)=betajb*xff_ens3(4) xff_ens3(5)=xff_ens3(4) xff_ens3(6)=xff_ens3(4) + forcing(i,2)=xff_ens3(4) if(xff_ens3(4).lt.0.)xff_ens3(4)=0. if(xff_ens3(5).lt.0.)xff_ens3(5)=0. if(xff_ens3(6).lt.0.)xff_ens3(6)=0. xff_ens3(14)=xff_ens3(4) - forcing(i,2)=xff_ens3(4) ! !--- more like krishnamurti et al.; pick max and average values ! @@ -3328,7 +3337,8 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 xff_ens3(11)=aa1(i)/tau_ecmwf(i) xff_ens3(12)=aa1(i)/tau_ecmwf(i) xff_ens3(13)=(aa1(i))/tau_ecmwf(i) !(60.*15.) !tau_ecmwf(i) -! forcing(i,4)=xff_ens3(10) + forcing(i,4)=xff_ens3(10) +! forcing(i,5)= aa1_bl(i)/tau_ecmwf(i) !!- more like bechtold et al. (jas 2014) !! if(dicycle == 1) xff_dicycle = max(0.,aa1_bl(i)/tau_ecmwf(i)) !(60.*30.) !tau_ecmwf(i) @@ -3349,13 +3359,16 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 endif ! ichoice xk(1)=(xaa0(i,1)-aa1(i))/mbdt - forcing(i,4)=aa0(i) - forcing(i,5)=aa1(i) - forcing(i,6)=xaa0(i,1) - forcing(i,7)=xk(1) - if(xk(1).le.0.and.xk(1).gt.-.01*mbdt) & + forcing(i,8)=mbdt*xk(1)/aa1(i) +! if(forcing(i,1).lt.0. .or. forcing(i,8).gt.-4.)ierr(i)=333 +! if(forcing(i,2).lt.-0.05)ierr(i)=333 +! forcing(i,4)=aa0(i) +! forcing(i,5)=aa1(i) +! forcing(i,6)=xaa0(i,1) +! forcing(i,7)=xk(1) + if(xk(1).lt.0.and.xk(1).gt.-.01*mbdt) & xk(1)=-.01*mbdt - if(xk(1).gt.0.and.xk(1).lt.1.e-2) & + if(xk(1).ge.0.and.xk(1).lt.1.e-2) & xk(1)=1.e-2 ! enddo ! @@ -3446,13 +3459,13 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 xf_ens(i,11)=xf_ens(i,11)+xf_ens(i,11)*rand_clos(i,4) xf_ens(i,12)=xf_ens(i,12)+xf_ens(i,12)*rand_clos(i,4) xf_ens(i,13)=xf_ens(i,13)+xf_ens(i,13)*rand_clos(i,4) - forcing(i,8)=xf_ens(i,11) +! forcing(i,8)=xf_ens(i,11) else xf_ens(i,10)=0. xf_ens(i,11)=0. xf_ens(i,12)=0. xf_ens(i,13)=0. - forcing(i,8)=0. + !forcing(i,8)=0. endif !srf-begin !! if(xk(1).lt.0.)then @@ -3504,13 +3517,16 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 if(ierr(i) /= 0)cycle xk(1)=(xaa0(i,1)-aa1(i))/mbdt - if(xk(1).le.0.and.xk(1).gt.-.01*mbdt) xk(1)=-.01*mbdt - if(xk(1).gt.0.and.xk(1).lt.1.e-2) xk(1)=1.e-2 - +! forcing(i,8)=xk(1) + if(xk(1).lt.0.and.xk(1).gt.-.01*mbdt) xk(1)=-.01*mbdt + if(xk(1).ge.0.and.xk(1).lt.1.e-2) xk(1)=1.e-2 + xff_dicycle = (aa1(i)-aa1_bl(i))/tau_ecmwf(i) +! forcing(i,8)=xff_dicycle if(xk(1).lt.0) xf_dicycle(i)= max(0.,-xff_dicycle/xk(1)) - + xf_dicycle(i)= xf_ens(i,10)-xf_dicycle(i) +! forcing(i,6)=xf_dicycle(i) enddo !$acc end kernels else @@ -4146,6 +4162,7 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & ! used in cup_forcing_ens (including screening of some ! closures over water) to properly normalize xmb clos_wei=16./max(1.,closure_n(i)) + clos_wei=1. xmb_ave(i)=min(xmb_ave(i),100.) xmb(i)=clos_wei*sig(i)*xmb_ave(i) diff --git a/physics/cu_gf_driver.F90 b/physics/cu_gf_driver.F90 index 61abb29a9..ca9f0bec2 100644 --- a/physics/cu_gf_driver.F90 +++ b/physics/cu_gf_driver.F90 @@ -66,7 +66,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& index_of_y_wind,index_of_process_scnv,index_of_process_dcnv, & fhour,fh_dfi_radar,ix_dfi_radar,num_dfi_radar,cap_suppress, & dfi_radar_max_intervals,ldiag3d,qci_conv,do_cap_suppress, & - errmsg,errflg) + maxupmf,maxMF,errmsg,errflg) !------------------------------------------------------------- implicit none integer, parameter :: maxiens=1 @@ -74,12 +74,12 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& integer, parameter :: maxens2=1 integer, parameter :: maxens3=16 integer, parameter :: ensdim=16 - integer, parameter :: imid_gf=1 ! testgf2 turn on middle gf conv. + integer :: imid_gf=1 ! gf congest conv. integer, parameter :: ideep=1 - integer, parameter :: ichoice=0 ! 0 2 5 13 8 + integer :: ichoice=0 ! 0 2 5 13 8 !integer, parameter :: ichoicem=5 ! 0 2 5 13 - integer, parameter :: ichoicem=13 ! 0 2 5 13 - integer, parameter :: ichoice_s=3 ! 0 1 2 3 + integer, parameter :: ichoicem=13 ! 0 2 5 13 + integer, parameter :: ichoice_s=3 ! 0 1 2 3 logical, intent(in) :: do_cap_suppress real(kind=kind_phys), parameter :: aodc0=0.14 @@ -121,7 +121,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& integer, dimension (:), intent(out) :: hbot,htop,kcnv integer, dimension (:), intent(in) :: xland - real(kind=kind_phys), dimension (:), intent(in) :: pbl + real(kind=kind_phys), dimension (:), intent(in) :: pbl,maxMF !$acc declare copyout(hbot,htop,kcnv) !$acc declare copyin(xland,pbl) integer, dimension (im) :: tropics @@ -129,7 +129,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ! ruc variable real(kind=kind_phys), dimension (:), intent(in) :: hfx2,qfx2,psuri real(kind=kind_phys), dimension (:,:), intent(out) :: ud_mf,dd_mf,dt_mf - real(kind=kind_phys), dimension (:), intent(out) :: raincv,cld1d + real(kind=kind_phys), dimension (:), intent(out) :: raincv,cld1d,maxupmf real(kind=kind_phys), dimension (:,:), intent(in) :: t2di,p2di !$acc declare copyin(hfx2,qfx2,psuri,t2di,p2di) !$acc declare copyout(ud_mf,dd_mf,dt_mf,raincv,cld1d) @@ -228,7 +228,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ! gf needs them in w/m2. define hfx and qfx after simple unit conversion real(kind=kind_phys), dimension (im) :: hfx,qfx !$acc declare create(hfx,qfx) - real(kind=kind_phys) tem,tem1,tf,tcr,tcrf + real(kind=kind_phys) tem,tem1,tf,tcr,tcrf,psum real(kind=kind_phys) :: cliw_shal,clcw_shal,tem_shal, cliw_both, weight_sum real(kind=kind_phys) :: cliw_deep,clcw_deep,tem_deep, clcw_both integer :: cliw_deep_idx, clcw_deep_idx, cliw_shal_idx, clcw_shal_idx @@ -537,6 +537,9 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& subm(:,:)=0. dhdt(:,:)=0. + frhm(:)=0. + frhd(:)=0. + do k=kts,ktf do i=its,itf p2d(i,k)=0.01*p2di(i,k) @@ -601,17 +604,34 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& endif enddo enddo + do i = its,itf + psum=0. + do k=kts,ktf-3 + if (clcw(i,k) .gt. -999.0 .and. clcw(i,k+1) .gt. -999.0 )then + dp=(p2d(i,k)-p2d(i,k+1)) + psum=psum+dp + clwtot = cliw(i,k) + clcw(i,k) + if(clwtot.lt.1.e-32)clwtot=0. + forcing(i,7)=forcing(i,7)+clwtot*dp + endif + enddo + if(psum.gt.0)forcing(i,7)=forcing(i,7)/psum + forcing2(i,7)=forcing(i,7) + enddo do k=kts,ktf-1 do i = its,itf omeg(i,k)= w(i,k) !-g*rhoi(i,k)*w(i,k) -! dq=(q2d(i,k+1)-q2d(i,k)) -! mconv(i)=mconv(i)+omeg(i,k)*dq/g enddo enddo do i = its,itf if(mconv(i).lt.0.)mconv(i)=0. + if(maxMF(i).gt.0.)ierr(i)=555 enddo !$acc end kernels + if (dx(its)<6500.) then + ichoice=10 + imid_gf=0 + endif ! !---- call cumulus parameterization ! @@ -654,8 +674,8 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& if(imid_gf == 1)then call cu_gf_deep_run( & itf,ktf,its,ite, kts,kte & - ,dicycle_m & - ,ichoicem & + ,dicycle_m & + ,ichoicem & ,ipr & ,ccn_m & ,ccnclean & @@ -664,25 +684,23 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,kpbli & ,dhdt & ,xlandi & - ,zo & - ,forcing2 & + ,forcing & ,t2d & ,q2d & ,ter11 & ,tshall & ,qshall & - ,p2d & + ,p2d & ,psur & ,us & ,vs & ,rhoi & ,hfx & ,qfx & - ,dx & !hj dx(im) + ,dx & ,mconv & ,omeg & - ,cactiv_m & ,cnvwtm & ,zum & @@ -748,7 +766,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,xlandi & ,zo & - ,forcing & + ,forcing2 & ,t2d & ,q2d & ,ter11 & @@ -761,7 +779,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,rhoi & ,hfx & ,qfx & - ,dx & !hj replace dx(im) + ,dx & ,mconv & ,omeg & @@ -815,25 +833,6 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& outqc,pret,its,ite,kts,kte,itf,ktf,ktop) ! endif -! do i=its,itf -! kcnv(i)=0 -! if(pret(i).gt.0.)then -! cuten(i)=1. -! kcnv(i)= 1 !jmin(i) -! else -! kbcon(i)=0 -! ktop(i)=0 -! cuten(i)=0. -! endif ! pret > 0 -! if(pretm(i).gt.0.)then -! kcnv(i)= 1 !jmin(i) -! cutenm(i)=1. -! else -! kbconm(i)=0 -! ktopm(i)=0 -! cutenm(i)=0. -! endif ! pret > 0 -! enddo !$acc kernels do i=its,itf kcnv(i)=0 @@ -880,6 +879,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& endif dtime_max=dt + forcing2(i,3)=0. do k=kts,kstop cnvc(i,k) = 0.04 * log(1. + 675. * zu(i,k) * xmb(i)) + & 0.04 * log(1. + 675. * zum(i,k) * xmbm(i)) + & @@ -954,6 +954,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& -(xmbm(i)*(zdm(i,k)-edtm(i)*zdm(i,k))) & -(xmbs(i)*zus(i,k)) trcflx_in1(k)=massflx(k)*.5*(clwtot+clwtot1) + forcing2(i,3)=forcing2(i,3)+clwtot endif enddo @@ -991,6 +992,13 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& gdc(i,13,10)=hfx(i) gdc(i,15,10)=qfx(i) gdc(i,16,10)=pret(i)*3600. + + if(forcing(i,6).gt.0.)then + maxupmf(i)=maxval(xmb(i)*zu(i,kts:ktf)/forcing(i,6)) + else + maxupmf(i)=0. + endif + if(ktop(i).gt.2 .and.pret(i).gt.0.)dt_mf(i,ktop(i)-1)=ud_mf(i,ktop(i)) endif enddo diff --git a/physics/cu_gf_driver.meta b/physics/cu_gf_driver.meta index 311a9cb3e..adcf49f2f 100644 --- a/physics/cu_gf_driver.meta +++ b/physics/cu_gf_driver.meta @@ -553,6 +553,22 @@ type = real kind = kind_phys intent = in +[maxupmf] + standard_name = maximum_conv_up_draft_mass_flux + long_name = maximum convective up draft mass flux within a column + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[maxMF] + standard_name = maximum_mass_flux + long_name = maximum mass flux within a column + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/cu_gf_driver_post.F90 b/physics/cu_gf_driver_post.F90 index 4015fed35..71877c5f4 100644 --- a/physics/cu_gf_driver_post.F90 +++ b/physics/cu_gf_driver_post.F90 @@ -15,28 +15,36 @@ module cu_gf_driver_post !> \section arg_table_cu_gf_driver_post_run Argument Table !! \htmlinclude cu_gf_driver_post_run.html !! - subroutine cu_gf_driver_post_run (im, t, q, prevst, prevsq, cactiv, cactiv_m, conv_act, conv_act_m, errmsg, errflg) + subroutine cu_gf_driver_post_run (im, km, t, q, prevst, prevsq, cactiv, cactiv_m, conv_act, conv_act_m,dt, garea, raincv, maxupmf, refl_10cm, errmsg, errflg) use machine, only: kind_phys implicit none ! Interface variables - integer, intent(in) :: im + integer, intent(in) :: im, km real(kind_phys), intent(in) :: t(:,:) real(kind_phys), intent(in) :: q(:,:) + real(kind_phys), dimension(:),intent(in) :: garea real(kind_phys), intent(out) :: prevst(:,:) real(kind_phys), intent(out) :: prevsq(:,:) integer, intent(in) :: cactiv(:) integer, intent(in) :: cactiv_m(:) real(kind_phys), intent(out) :: conv_act(:) real(kind_phys), intent(out) :: conv_act_m(:) + ! for Radar reflectivity + real(kind_phys), intent(in) :: dt + real(kind_phys), intent(in) :: raincv(:), maxupmf(:) + real(kind_phys), intent(inout) :: refl_10cm(:,:) character(len=*), intent(out) :: errmsg !$acc declare copyin(t,q,cactiv,cactiv_m) copyout(prevst,prevsq,conv_act,conv_act_m) integer, intent(out) :: errflg ! Local variables - integer :: i + real, parameter :: dbzmin=-10.0 ! dcd + real :: cuprate ! dcd + real :: ze, ze_conv, dbz_sum ! dcd + integer :: i, k ! Initialize CCPP error handling variables errmsg = '' @@ -57,6 +65,21 @@ subroutine cu_gf_driver_post_run (im, t, q, prevst, prevsq, cactiv, cactiv_m, co else conv_act_m(i)=0.0 endif + ! reflectivity parameterization for parameterized convection (reference:Unipost MDLFLD.f) + if(sqrt(garea(i)).lt.6500.)then + ze = 0.0 + ze_conv = 0.0 + dbz_sum = 0.0 + cuprate = raincv(i) * 3600.0 / dt ! cu precip rate (mm/h) + ze_conv = 300.0 * cuprate**1.4 + if (maxupmf(i).gt.0.05) then + do k = 1, km + ze = 10.0 ** (0.1 * refl_10cm(i,k)) + dbz_sum = max(dbzmin, 10.0 * log10(ze + ze_conv)) + refl_10cm(i,k) = dbz_sum + enddo + endif + endif enddo !$acc end kernels diff --git a/physics/cu_gf_driver_post.meta b/physics/cu_gf_driver_post.meta index b50c2ab40..18f062b2d 100644 --- a/physics/cu_gf_driver_post.meta +++ b/physics/cu_gf_driver_post.meta @@ -14,6 +14,13 @@ dimensions = () type = integer intent = in +[km] + standard_name = vertical_layer_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in [t] standard_name = air_temperature_of_new_state long_name = temperature updated by physics @@ -76,6 +83,46 @@ type = real kind = kind_phys intent = out +[dt] + standard_name = timestep_for_physics + long_name = physics time step + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[garea] + standard_name = cell_area + long_name = grid cell area + units = m2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[raincv] + standard_name = lwe_thickness_of_deep_convective_precipitation_amount + long_name = deep convective rainfall amount on physics timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[maxupmf] + standard_name = maximum_conv_up_draft_mass_flux + long_name = maximum convective up draft mass flux within a column + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[refl_10cm] + standard_name = radar_reflectivity_10cm + long_name = instantaneous refl_10cm + units = dBZ + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/set_soilveg_ruc.F90 b/physics/set_soilveg_ruc.F90 index 7c4f0ffdf..db56fb8a4 100644 --- a/physics/set_soilveg_ruc.F90 +++ b/physics/set_soilveg_ruc.F90 @@ -338,63 +338,63 @@ subroutine set_soilveg_ruc(me,isot,ivet,nlunit,errmsg,errflg) ! SOIL TEXTURE-RELATED ARRAYS. ! ---------------------------------------------------------------------- BB =(/4.05, 4.38, 4.90, 5.30, 5.30, 5.39, & - & 7.12, 7.75, 8.52, 10.40, 10.40, 11.40, & + & 7.12, 7.75, 5.39, 10.40, 10.40, 11.40, & & 5.39, 0.00, 4.05, 4.90, 11.40, 4.05, & & 4.05, 0.00, 0.00, 0.00, 0.00, 0.00, & & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00/) DRYSMC =(/0.002, 0.035, 0.041, 0.034, 0.034, 0.050, & - & 0.068, 0.060, 0.085, 0.100, 0.070, 0.068, & + & 0.068, 0.060, 0.050, 0.070, 0.070, 0.068, & & 0.027, 0.000, 0.004, 0.065, 0.030, 0.006, & & 0.010, 0.000, 0.000, 0.000, 0.000, 0.000, & & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/) HC =(/1.47, 1.41, 1.34, 1.27, 1.27, 1.21, 1.18, & - & 1.32, 1.23, 1.18, 1.15, 1.09, 1.21, 4.18, & + & 1.32, 1.21, 1.18, 1.15, 1.09, 1.21, 4.18, & & 2.03, 2.10, 1.41, 1.41, 1.47, 0.00, 0.00, & & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, & & 0.00, 0.00/) MAXSMC =(/0.395, 0.410, 0.435, 0.485, 0.485, 0.451, & - & 0.420, 0.477, 0.476, 0.426, 0.492, 0.482, & + & 0.420, 0.477, 0.451, 0.426, 0.492, 0.482, & & 0.451, 1.000, 0.200, 0.435, 0.468, 0.200, & & 0.339, 0.000, 0.000, 0.000, 0.000, 0.000, & & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/) REFSMC =(/0.174, 0.179, 0.249, 0.369, 0.369, 0.314, & - & 0.299, 0.357, 0.391, 0.316, 0.409, 0.400, & + & 0.299, 0.357, 0.314, 0.316, 0.409, 0.400, & & 0.314, 1.000, 0.100, 0.249, 0.454, 0.170, & & 0.236, 0.000, 0.000, 0.000, 0.000, 0.000, & & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/) SATPSI =(/0.121, 0.090, 0.218, 0.786, 0.786, 0.478, & - & 0.299, 0.356, 0.630, 0.153, 0.490, 0.405, & + & 0.299, 0.356, 0.478, 0.153, 0.490, 0.405, & & 0.478, 0.000, 0.121, 0.218, 0.468, 0.069, & & 0.069, 0.00, 0.00, 0.00, 0.00, 0.00, & & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00/) SATDK =(/1.76e-4, 1.56e-4, 3.47e-5, 7.20e-6, 7.20e-6, & - & 6.95e-6, 6.30e-6, 1.70e-6, 2.45e-6, 2.17e-6, & + & 6.95e-6, 6.30e-6, 1.70e-6, 6.95e-6, 2.17e-6, & & 1.03e-6, 1.28e-6, 6.95e-6, 0.0, 1.41e-4, & & 3.47e-5, 9.74e-7, 1.41e-4, 1.76e-4, 0.00, & & 0.00 , 0.00 , 0.00 , 0.00 , 0.00, & & 0.00 , 0.00 , 0.00 , 0.00 , 0.00/) SATDW =(/0.608e-6, 0.514e-5, 0.805e-5, 0.239e-4, 0.239e-4, & - & 0.143e-4, 0.990e-5, 0.237e-4, 0.113e-4, 0.187e-4, & + & 0.143e-4, 0.990e-5, 0.237e-4, 0.143e-4, 0.187e-4, & & 0.964e-5, 0.112e-4, 0.143e-4, 0.0, 0.136e-03, & & 0.514e-5, 0.112e-4, 0.136e-3, 0.608e-6, 0.00, & & 0.00 , 0.00 , 0.00 , 0.00 , 0.00, & & 0.00 , 0.00 , 0.00 , 0.00 , 0.00/) WLTSMC =(/0.033, 0.055, 0.095, 0.143, 0.143, 0.137, & - & 0.148, 0.208, 0.230, 0.210, 0.250, 0.268, & + & 0.148, 0.170, 0.137, 0.158, 0.190, 0.198, & & 0.117, 0.000, 0.006, 0.114, 0.030, 0.006, & & 0.060, 0.000, 0.000, 0.000, 0.000, 0.000, & & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/) QTZ =(/0.92, 0.82, 0.60, 0.25, 0.10, 0.40, & - & 0.60, 0.10, 0.35, 0.52, 0.10, 0.25, & + & 0.60, 0.10, 0.40, 0.52, 0.10, 0.25, & & 0.05, 0.00, 0.60, 0.05, 0.60, 0.52, & & 0.92, 0.00, 0.00, 0.00, 0.00, 0.00, & & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00/) From 9e4e2cbddb5a634f8b010e4d1a9cd21c0d52e2c9 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Fri, 14 Apr 2023 13:52:47 -0400 Subject: [PATCH 220/380] update CODEOWNERS to replace Chunxi with Qingfu --- CODEOWNERS | 372 ++++++++++++++++++++++++++--------------------------- 1 file changed, 186 insertions(+), 186 deletions(-) diff --git a/CODEOWNERS b/CODEOWNERS index 15821a791..4b7e45310 100644 --- a/CODEOWNERS +++ b/CODEOWNERS @@ -4,198 +4,198 @@ # Default codeowners for files that don't have specific owners: -* @grantfirl @ChunxiZhang-NOAA @dustinswales @mzhangw +* @grantfirl @Qingfu-Liu @dustinswales @mzhangw # The following lines are from the CCPP Primary Schemes Points of Contact # https://docs.google.com/spreadsheets/d/14y0Th_sSpCqlssEMNfSZ_Ni9wrpPqfpPY0kRG7jCZB8/edit#gid=0 # (Internal NOAA document.) -smoke/* @haiqinli @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/aerclm_def.F @AnningCheng-NOAA @andrewgettelman @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/aer_cloud.F @AnningCheng-NOAA @andrewgettelman @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/aerinterp.F90 @AnningCheng-NOAA @andrewgettelman @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/bl_mynn_common.f90 @joeolson42 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/calpreciptype.f90 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/cires_orowam2017.f @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/cires_tauamf_data.F90 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/cires_ugwp* @ValeryYudin-NOAA @mdtoyNOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/cldmacro.F @AnningCheng-NOAA @andrewgettelman @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/cldwat2m_micro.F @AnningCheng-NOAA @andrewgettelman @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/cnvc90.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/cs_conv_aw_adj.* @AnningCheng-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/cs_conv.* @AnningCheng-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/cu_gf* @hannahcbarnes @haiqinli @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/cu_ntiedtke* @ChunxiZhang-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/date_def.f @XuLi-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/dcyc2t3.* @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/drag_suite.* @mdtoyNOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/flake* @YihuaWu-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/funcphys.f90 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/fv_sat_adj.* @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/gcycle.F90 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/get_phi_fv3.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/get_prs_fv3.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/gfdl_cloud_microphys.* @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFDL_parse_tracers.F90 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/gfdl_sfc_layer.* @ZhanZhang-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_cloud_diagnostics.* @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_DCNV_generic_post.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_DCNV_generic_pre.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_debug.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_GWD_generic_post.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_GWD_generic_pre.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_MP_generic_post.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_MP_generic_pre.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_PBL_generic_common.F90 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_PBL_generic_post.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_PBL_generic_pre.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_phys_time_vary.fv3.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_phys_time_vary.scm.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/gfs_phy_tracer_config.F @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_radiation_surface.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_rad_time_vary.fv3.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_rad_time_vary.scm.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_rrtmgp_cloud_mp.* @dustinswales @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_rrtmgp_cloud_overlap.* @dustinswales @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_rrtmgp_lw_post.* @dustinswales @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_rrtmg_post.* @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_rrtmgp_pre.* @dustinswales @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_rrtmg_pre.* @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_rrtmgp_setup.* @dustinswales @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_rrtmgp_sw_post.* @dustinswales @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_rrtmgp_sw_pre.* @dustinswales @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_rrtmg_setup.* @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_SCNV_generic_post.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_SCNV_generic_pre.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_stochastics.* @pjpegion @lisa-bengtsson @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_suite_interstitial_1.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_suite_interstitial_2.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_suite_interstitial_3.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_suite_interstitial_4.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_suite_interstitial_5.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_suite_interstitial_phys_reset.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_suite_interstitial_rad_reset.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_suite_stateout_reset.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_suite_stateout_update.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_surface_composites_inter.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_surface_composites_post.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_surface_composites_pre.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_surface_generic_post.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_surface_generic_pre.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_surface_loop_control_part1.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_surface_loop_control_part2.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_time_vary_pre.fv3.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/GFS_time_vary_pre.scm.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/gocart_tracer_config_stub.f @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/gwdc.* @Songyou184 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/gwdps.* @Songyou184 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/h2o_def.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/h2ointerp.f90 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/h2ophys.* @SMoorthi-emc @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/hedmf.* @JongilHan66 @WeiguoWang-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/iccn_def.F @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/iccninterp.F90 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/iounitdef.f @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/lsm_noah.* @HelinWei-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/lsm_ruc.* @tanyasmirnova @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/machine.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/maximum_hourly_diagnostics.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/mersenne_twister.f @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/mfpbl.f @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/mfpblt.f @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/mfpbltq.f @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/mfscu.f @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/mfscuq.f @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/micro_mg* @AnningCheng-NOAA @andrewgettelman @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/m_micro* @AnningCheng-NOAA @andrewgettelman @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/module_bfmicrophysics.f @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/module_BL_MYJPBL.* @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/module_bl_mynn.* @joeolson42 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/module_gfdl_cloud_microphys.* @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/module_MP_FER_HIRES.* @ericaligo-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/module_mp_nssl_2mom.F90 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/module_mp_radar.* @gthompsnWRF @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/module_mp_thompson* @gthompsnWRF @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/module_nst* @XuLi-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/module_sf_exchcoef.f90 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/module_SF_JSFC.F90 @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/module_sf_mynn.F90 @joeolson42 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/module_sf_ruclsm.* @tanyasmirnova @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/module_soil_pre.* @tanyasmirnova @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/moninshoc.* @SMoorthi-emc @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/mp_fer_hires.* @ericaligo-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/mp_nssl.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/mp_thompson* @gthompsnWRF @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/multi_gases.F90 @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/myjpbl_wrapper.* @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/myjsfc_wrapper.* @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/mynnedmf_wrapper.* @joeolson42 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/mynnsfc_wrapper.* @joeolson42 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/namelist_soilveg.* @HelinWei-NOAA @barlage @cenlinhe @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/namelist_soilveg_ruc.* @tanyasmirnova @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/*noahmp* @barlage @cenlinhe @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/ozinterp.f90 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/ozne_def.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/ozphys* @SMoorthi-emc @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/physcons.F90 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/phys_tend.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/progsigma_calc.f90 @lisa-bengtsson @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/radcons.f90 @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/radiation_aerosols.f @Qingfu-Liu @dustinswales @AnningCheng-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/radiation_astronomy.f @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/radiation_cloud_overlap.F90 @dustinswales @mjiacono @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/radiation_clouds.f @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/radiation_gases.f @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/radiation_surface.* @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/radiation_tools.F90 @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/radlw_* @mjiacono @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/radsw_* @mjiacono @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/rad_sw_pre.* @dustinswales @Qingfu-Liu @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/rascnv.* @SMoorthi-emc @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/rayleigh_damp.* @yangfanglin @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/rrtmg_lw_cloud_optics.F90 @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/rrtmg_lw_post.* @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/rrtmg_lw_pre.* @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/rrtmgp_aerosol_optics.* @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/rrtmgp_lw_* @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/rrtmgp_sw_* @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/rrtmg_sw_cloud_optics.F90 @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/rrtmg_sw_post.* @Qingfu-Liu @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/rte-rrtmgp @RobertPincus @dustinswales @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/samfdeepcnv.* @JongilHan66 @lisa-bengtsson @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/samfshalcnv.* @JongilHan66 @lisa-bengtsson @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/samfaerosols.* @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/sascnvn.* @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/satmedmfvdif.* @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/satmedmfvdifq.* @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/scm_sfc_flux_spec.* @grantfirl @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/set_soilveg.* @HelinWei-NOAA @barlage @cenlinhe @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/set_soilveg_ruc.* @tanyasmirnova @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/sfc_cice.* @wd20xw @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/sfc_diag.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/sfc_diag_post.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/sfc_diff.* @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/sfc_nst* @XuLi-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/sfc_ocean.* @HelinWei-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/sfc_sice.* @wd20xw @grantfirl @ChunxiZhang-NOAA @dustinswales -#physics/sfcsub.F @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/sflx.f @HelinWei-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/sgscloud_radpost.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/sgscloud_radpre.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/shalcnv.* @JongilHan66 @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/shinhongvdif.* @ChunxiZhang-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/shoc.* @SMoorthi-emc @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/surface_perturbation.* @HelinWei-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/tridi.f @JongilHan66 @ChunxiZhang-NOAA @WeiguoWang-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/ugwp_driver_v0.F @mdtoyNOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/ugwpv1_gsldrag.* @mdtoyNOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/ugwpv1_gsldrag_post.* @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/unified_ugwp* @mdtoyNOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/wv_saturation.F @AnningCheng-NOAA @andrewgettelman @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/ysuvdif.* @ChunxiZhang-NOAA @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/zhaocarr_gscond.* @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales -physics/zhaocarr_precpd.* @RuiyuSun @grantfirl @ChunxiZhang-NOAA @dustinswales +smoke/* @haiqinli @grantfirl @Qingfu-Liu @dustinswales +physics/aerclm_def.F @AnningCheng-NOAA @andrewgettelman @grantfirl @Qingfu-Liu @dustinswales +physics/aer_cloud.F @AnningCheng-NOAA @andrewgettelman @grantfirl @Qingfu-Liu @dustinswales +physics/aerinterp.F90 @AnningCheng-NOAA @andrewgettelman @grantfirl @Qingfu-Liu @dustinswales +physics/bl_mynn_common.f90 @joeolson42 @grantfirl @Qingfu-Liu @dustinswales +physics/calpreciptype.f90 @grantfirl @Qingfu-Liu @dustinswales +physics/cires_orowam2017.f @grantfirl @Qingfu-Liu @dustinswales +physics/cires_tauamf_data.F90 @grantfirl @Qingfu-Liu @dustinswales +physics/cires_ugwp* @ValeryYudin-NOAA @mdtoyNOAA @grantfirl @Qingfu-Liu @dustinswales +physics/cldmacro.F @AnningCheng-NOAA @andrewgettelman @grantfirl @Qingfu-Liu @dustinswales +physics/cldwat2m_micro.F @AnningCheng-NOAA @andrewgettelman @grantfirl @Qingfu-Liu @dustinswales +physics/cnvc90.* @grantfirl @Qingfu-Liu @dustinswales +physics/cs_conv_aw_adj.* @AnningCheng-NOAA @grantfirl @Qingfu-Liu @dustinswales +physics/cs_conv.* @AnningCheng-NOAA @grantfirl @Qingfu-Liu @dustinswales +physics/cu_gf* @hannahcbarnes @haiqinli @grantfirl @Qingfu-Liu @dustinswales +physics/cu_ntiedtke* @grantfirl @Qingfu-Liu @dustinswales +physics/date_def.f @XuLi-NOAA @grantfirl @Qingfu-Liu @dustinswales +physics/dcyc2t3.* @Qingfu-Liu @dustinswales @grantfirl @Qingfu-Liu @dustinswales +physics/drag_suite.* @mdtoyNOAA @grantfirl @Qingfu-Liu @dustinswales +physics/flake* @YihuaWu-NOAA @grantfirl @Qingfu-Liu @dustinswales +physics/funcphys.f90 @grantfirl @Qingfu-Liu @dustinswales +physics/fv_sat_adj.* @RuiyuSun @grantfirl @Qingfu-Liu @dustinswales +physics/gcycle.F90 @grantfirl @Qingfu-Liu @dustinswales +physics/get_phi_fv3.* @grantfirl @Qingfu-Liu @dustinswales +physics/get_prs_fv3.* @grantfirl @Qingfu-Liu @dustinswales +physics/gfdl_cloud_microphys.* @RuiyuSun @grantfirl @Qingfu-Liu @dustinswales +physics/GFDL_parse_tracers.F90 @grantfirl @Qingfu-Liu @dustinswales +physics/gfdl_sfc_layer.* @ZhanZhang-NOAA @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_cloud_diagnostics.* @dustinswales @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_DCNV_generic_post.* @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_DCNV_generic_pre.* @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_debug.* @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_GWD_generic_post.* @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_GWD_generic_pre.* @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_MP_generic_post.* @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_MP_generic_pre.* @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_PBL_generic_common.F90 @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_PBL_generic_post.* @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_PBL_generic_pre.* @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_phys_time_vary.fv3.* @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_phys_time_vary.scm.* @grantfirl @Qingfu-Liu @dustinswales +physics/gfs_phy_tracer_config.F @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_radiation_surface.* @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_rad_time_vary.fv3.* @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_rad_time_vary.scm.* @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_rrtmgp_cloud_mp.* @dustinswales @Qingfu-Liu @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_rrtmgp_cloud_overlap.* @dustinswales @Qingfu-Liu @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_rrtmgp_lw_post.* @dustinswales @Qingfu-Liu @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_rrtmg_post.* @Qingfu-Liu @dustinswales @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_rrtmgp_pre.* @dustinswales @Qingfu-Liu @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_rrtmg_pre.* @Qingfu-Liu @dustinswales @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_rrtmgp_setup.* @dustinswales @Qingfu-Liu @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_rrtmgp_sw_post.* @dustinswales @Qingfu-Liu @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_rrtmgp_sw_pre.* @dustinswales @Qingfu-Liu @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_rrtmg_setup.* @Qingfu-Liu @dustinswales @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_SCNV_generic_post.* @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_SCNV_generic_pre.* @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_stochastics.* @pjpegion @lisa-bengtsson @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_suite_interstitial_1.* @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_suite_interstitial_2.* @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_suite_interstitial_3.* @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_suite_interstitial_4.* @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_suite_interstitial_5.* @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_suite_interstitial_phys_reset.* @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_suite_interstitial_rad_reset.* @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_suite_stateout_reset.* @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_suite_stateout_update.* @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_surface_composites_inter.* @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_surface_composites_post.* @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_surface_composites_pre.* @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_surface_generic_post.* @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_surface_generic_pre.* @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_surface_loop_control_part1.* @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_surface_loop_control_part2.* @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_time_vary_pre.fv3.* @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_time_vary_pre.scm.* @grantfirl @Qingfu-Liu @dustinswales +physics/gocart_tracer_config_stub.f @grantfirl @Qingfu-Liu @dustinswales +physics/gwdc.* @Songyou184 @grantfirl @Qingfu-Liu @dustinswales +physics/gwdps.* @Songyou184 @grantfirl @Qingfu-Liu @dustinswales +physics/h2o_def.* @grantfirl @Qingfu-Liu @dustinswales +physics/h2ointerp.f90 @grantfirl @Qingfu-Liu @dustinswales +physics/h2ophys.* @SMoorthi-emc @grantfirl @Qingfu-Liu @dustinswales +physics/hedmf.* @JongilHan66 @WeiguoWang-NOAA @grantfirl @Qingfu-Liu @dustinswales +physics/iccn_def.F @grantfirl @Qingfu-Liu @dustinswales +physics/iccninterp.F90 @grantfirl @Qingfu-Liu @dustinswales +physics/iounitdef.f @grantfirl @Qingfu-Liu @dustinswales +physics/lsm_noah.* @HelinWei-NOAA @grantfirl @Qingfu-Liu @dustinswales +physics/lsm_ruc.* @tanyasmirnova @grantfirl @Qingfu-Liu @dustinswales +physics/machine.* @grantfirl @Qingfu-Liu @dustinswales +physics/maximum_hourly_diagnostics.* @grantfirl @Qingfu-Liu @dustinswales +physics/mersenne_twister.f @grantfirl @Qingfu-Liu @dustinswales +physics/mfpbl.f @JongilHan66 @grantfirl @Qingfu-Liu @dustinswales +physics/mfpblt.f @JongilHan66 @grantfirl @Qingfu-Liu @dustinswales +physics/mfpbltq.f @JongilHan66 @grantfirl @Qingfu-Liu @dustinswales +physics/mfscu.f @JongilHan66 @grantfirl @Qingfu-Liu @dustinswales +physics/mfscuq.f @JongilHan66 @grantfirl @Qingfu-Liu @dustinswales +physics/micro_mg* @AnningCheng-NOAA @andrewgettelman @grantfirl @Qingfu-Liu @dustinswales +physics/m_micro* @AnningCheng-NOAA @andrewgettelman @grantfirl @Qingfu-Liu @dustinswales +physics/module_bfmicrophysics.f @grantfirl @Qingfu-Liu @dustinswales +physics/module_BL_MYJPBL.* @Qingfu-Liu @grantfirl @Qingfu-Liu @dustinswales +physics/module_bl_mynn.* @joeolson42 @grantfirl @Qingfu-Liu @dustinswales +physics/module_gfdl_cloud_microphys.* @RuiyuSun @grantfirl @Qingfu-Liu @dustinswales +physics/module_MP_FER_HIRES.* @ericaligo-NOAA @grantfirl @Qingfu-Liu @dustinswales +physics/module_mp_nssl_2mom.F90 @grantfirl @Qingfu-Liu @dustinswales +physics/module_mp_radar.* @gthompsnWRF @RuiyuSun @grantfirl @Qingfu-Liu @dustinswales +physics/module_mp_thompson* @gthompsnWRF @RuiyuSun @grantfirl @Qingfu-Liu @dustinswales +physics/module_nst* @XuLi-NOAA @grantfirl @Qingfu-Liu @dustinswales +physics/module_sf_exchcoef.f90 @grantfirl @Qingfu-Liu @dustinswales +physics/module_SF_JSFC.F90 @Qingfu-Liu @grantfirl @Qingfu-Liu @dustinswales +physics/module_sf_mynn.F90 @joeolson42 @grantfirl @Qingfu-Liu @dustinswales +physics/module_sf_ruclsm.* @tanyasmirnova @grantfirl @Qingfu-Liu @dustinswales +physics/module_soil_pre.* @tanyasmirnova @grantfirl @Qingfu-Liu @dustinswales +physics/moninshoc.* @SMoorthi-emc @grantfirl @Qingfu-Liu @dustinswales +physics/mp_fer_hires.* @ericaligo-NOAA @grantfirl @Qingfu-Liu @dustinswales +physics/mp_nssl.* @grantfirl @Qingfu-Liu @dustinswales +physics/mp_thompson* @gthompsnWRF @RuiyuSun @grantfirl @Qingfu-Liu @dustinswales +physics/multi_gases.F90 @RuiyuSun @grantfirl @Qingfu-Liu @dustinswales +physics/myjpbl_wrapper.* @Qingfu-Liu @grantfirl @Qingfu-Liu @dustinswales +physics/myjsfc_wrapper.* @Qingfu-Liu @grantfirl @Qingfu-Liu @dustinswales +physics/mynnedmf_wrapper.* @joeolson42 @grantfirl @Qingfu-Liu @dustinswales +physics/mynnsfc_wrapper.* @joeolson42 @grantfirl @Qingfu-Liu @dustinswales +physics/namelist_soilveg.* @HelinWei-NOAA @barlage @cenlinhe @grantfirl @Qingfu-Liu @dustinswales +physics/namelist_soilveg_ruc.* @tanyasmirnova @grantfirl @Qingfu-Liu @dustinswales +physics/*noahmp* @barlage @cenlinhe @grantfirl @Qingfu-Liu @dustinswales +physics/ozinterp.f90 @grantfirl @Qingfu-Liu @dustinswales +physics/ozne_def.* @grantfirl @Qingfu-Liu @dustinswales +physics/ozphys* @SMoorthi-emc @grantfirl @Qingfu-Liu @dustinswales +physics/physcons.F90 @grantfirl @Qingfu-Liu @dustinswales +physics/phys_tend.* @grantfirl @Qingfu-Liu @dustinswales +physics/progsigma_calc.f90 @lisa-bengtsson @grantfirl @Qingfu-Liu @dustinswales +physics/radcons.f90 @Qingfu-Liu @dustinswales @grantfirl @Qingfu-Liu @dustinswales +physics/radiation_aerosols.f @Qingfu-Liu @dustinswales @AnningCheng-NOAA @grantfirl @Qingfu-Liu @dustinswales +physics/radiation_astronomy.f @Qingfu-Liu @dustinswales @grantfirl @Qingfu-Liu @dustinswales +physics/radiation_cloud_overlap.F90 @dustinswales @mjiacono @grantfirl @Qingfu-Liu @dustinswales +physics/radiation_clouds.f @Qingfu-Liu @dustinswales @grantfirl @Qingfu-Liu @dustinswales +physics/radiation_gases.f @Qingfu-Liu @dustinswales @grantfirl @Qingfu-Liu @dustinswales +physics/radiation_surface.* @Qingfu-Liu @dustinswales @grantfirl @Qingfu-Liu @dustinswales +physics/radiation_tools.F90 @Qingfu-Liu @dustinswales @grantfirl @Qingfu-Liu @dustinswales +physics/radlw_* @mjiacono @Qingfu-Liu @grantfirl @Qingfu-Liu @dustinswales +physics/radsw_* @mjiacono @Qingfu-Liu @grantfirl @Qingfu-Liu @dustinswales +physics/rad_sw_pre.* @dustinswales @Qingfu-Liu @grantfirl @Qingfu-Liu @dustinswales +physics/rascnv.* @SMoorthi-emc @grantfirl @Qingfu-Liu @dustinswales +physics/rayleigh_damp.* @yangfanglin @grantfirl @Qingfu-Liu @dustinswales +physics/rrtmg_lw_cloud_optics.F90 @dustinswales @grantfirl @Qingfu-Liu @dustinswales +physics/rrtmg_lw_post.* @Qingfu-Liu @dustinswales @grantfirl @Qingfu-Liu @dustinswales +physics/rrtmg_lw_pre.* @Qingfu-Liu @dustinswales @grantfirl @Qingfu-Liu @dustinswales +physics/rrtmgp_aerosol_optics.* @dustinswales @grantfirl @Qingfu-Liu @dustinswales +physics/rrtmgp_lw_* @dustinswales @grantfirl @Qingfu-Liu @dustinswales +physics/rrtmgp_sw_* @dustinswales @grantfirl @Qingfu-Liu @dustinswales +physics/rrtmg_sw_cloud_optics.F90 @dustinswales @grantfirl @Qingfu-Liu @dustinswales +physics/rrtmg_sw_post.* @Qingfu-Liu @dustinswales @grantfirl @Qingfu-Liu @dustinswales +physics/rte-rrtmgp @RobertPincus @dustinswales @grantfirl @Qingfu-Liu @dustinswales +physics/samfdeepcnv.* @JongilHan66 @lisa-bengtsson @grantfirl @Qingfu-Liu @dustinswales +physics/samfshalcnv.* @JongilHan66 @lisa-bengtsson @grantfirl @Qingfu-Liu @dustinswales +physics/samfaerosols.* @JongilHan66 @grantfirl @Qingfu-Liu @dustinswales +physics/sascnvn.* @JongilHan66 @grantfirl @Qingfu-Liu @dustinswales +physics/satmedmfvdif.* @JongilHan66 @grantfirl @Qingfu-Liu @dustinswales +physics/satmedmfvdifq.* @JongilHan66 @grantfirl @Qingfu-Liu @dustinswales +physics/scm_sfc_flux_spec.* @grantfirl @grantfirl @Qingfu-Liu @dustinswales +physics/set_soilveg.* @HelinWei-NOAA @barlage @cenlinhe @grantfirl @Qingfu-Liu @dustinswales +physics/set_soilveg_ruc.* @tanyasmirnova @grantfirl @Qingfu-Liu @dustinswales +physics/sfc_cice.* @wd20xw @grantfirl @Qingfu-Liu @dustinswales +physics/sfc_diag.* @grantfirl @Qingfu-Liu @dustinswales +physics/sfc_diag_post.* @grantfirl @Qingfu-Liu @dustinswales +physics/sfc_diff.* @JongilHan66 @grantfirl @Qingfu-Liu @dustinswales +physics/sfc_nst* @XuLi-NOAA @grantfirl @Qingfu-Liu @dustinswales +physics/sfc_ocean.* @HelinWei-NOAA @grantfirl @Qingfu-Liu @dustinswales +physics/sfc_sice.* @wd20xw @grantfirl @Qingfu-Liu @dustinswales +#physics/sfcsub.F @grantfirl @Qingfu-Liu @dustinswales +physics/sflx.f @HelinWei-NOAA @grantfirl @Qingfu-Liu @dustinswales +physics/sgscloud_radpost.* @grantfirl @Qingfu-Liu @dustinswales +physics/sgscloud_radpre.* @grantfirl @Qingfu-Liu @dustinswales +physics/shalcnv.* @JongilHan66 @grantfirl @Qingfu-Liu @dustinswales +physics/shinhongvdif.* @grantfirl @Qingfu-Liu @dustinswales +physics/shoc.* @SMoorthi-emc @grantfirl @Qingfu-Liu @dustinswales +physics/surface_perturbation.* @HelinWei-NOAA @grantfirl @Qingfu-Liu @dustinswales +physics/tridi.f @JongilHan66 @WeiguoWang-NOAA @grantfirl @Qingfu-Liu @dustinswales +physics/ugwp_driver_v0.F @mdtoyNOAA @grantfirl @Qingfu-Liu @dustinswales +physics/ugwpv1_gsldrag.* @mdtoyNOAA @grantfirl @Qingfu-Liu @dustinswales +physics/ugwpv1_gsldrag_post.* @grantfirl @Qingfu-Liu @dustinswales +physics/unified_ugwp* @mdtoyNOAA @grantfirl @Qingfu-Liu @dustinswales +physics/wv_saturation.F @AnningCheng-NOAA @andrewgettelman @grantfirl @Qingfu-Liu @dustinswales +physics/ysuvdif.* @grantfirl @Qingfu-Liu @dustinswales +physics/zhaocarr_gscond.* @RuiyuSun @grantfirl @Qingfu-Liu @dustinswales +physics/zhaocarr_precpd.* @RuiyuSun @grantfirl @Qingfu-Liu @dustinswales ######################################################################## From cf604b5d9b1206c2c2e9497bedd2e8fc881823f9 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Fri, 14 Apr 2023 21:53:29 +0000 Subject: [PATCH 221/380] remove test code from clm_lake.f90 --- physics/clm_lake.f90 | 223 +------------------------------------------ 1 file changed, 4 insertions(+), 219 deletions(-) diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90 index b720c6bda..4e44c921a 100644 --- a/physics/clm_lake.f90 +++ b/physics/clm_lake.f90 @@ -325,22 +325,6 @@ SUBROUTINE clm_lake_run( & real(kind_phys), dimension( :,: ) ,INTENT(inout) :: t_lake3d, & lake_icefrac3d -! Quick education on CCPP and deferred shape arrays. - -! CCPP requires deferred shape arrays as a workaround for its design -! flaw: it needs an argument that can receive either a null pointer, -! or an automatic storage array (which is not guaranteed to exist in -! memory at all). Such a thing doesn't exist in Fortran, so the design -! of CCPP assumes a compiler will accept either as an argument to a -! deferred shape array. - -! Apparently there is a misunderstanding among developers of how a -! deferred shape array is declared. If the array dimensions do not -! have an UPPER bound, then it is deferred shape. A LOWER bound is -! acceptable; it does not cease to be a deferred shape array. - -! That is why these seven arrays fit the CCPP design. - real(kind_phys), dimension( :,-nlevsnow+1: ) ,INTENT(inout) :: t_soisno3d, & h2osoi_ice3d, & h2osoi_liq3d, & @@ -443,25 +427,6 @@ SUBROUTINE clm_lake_run( & character*255 :: message logical, parameter :: feedback_to_atmosphere = .true. ! FIXME: REMOVE - ! Functionality to print extra values at problematic points specified by user - logical :: was_unhappy,is_unhappy - - ! Points come from this file - character(*), parameter :: unhappy_txt = "unhappy.txt" - - ! Special values of the unhappy_count to indicate data is unavailable - integer, parameter :: HAVE_NOT_READ_UNHAPPY_POINTS_YET = -1 - integer, parameter :: FAILED_TO_READ_UNHAPPY_POINTS = -2 - - ! These "save" variables are protected by an OMP CRITICAL to - ! ensure they're only initialized once. - - ! Number of unhappy points - integer, save :: unhappy_count = HAVE_NOT_READ_UNHAPPY_POINTS_YET - - ! The latitude and longitude of unhappy points. - real(kind_lake), allocatable, save :: unhappy_lat(:),unhappy_lon(:) - real(kind_lake) :: to_radians, lat_d, lon_d, qss integer :: month,num1,num2,day_of_month @@ -478,34 +443,6 @@ SUBROUTINE clm_lake_run( & dtime=dtp - if(LAKEDEBUG) then - ! Have we read the unhappy points? - ! The first "if" ensures we don't initiate an OMP CRITICAL unless we have to. - if(unhappy_count==HAVE_NOT_READ_UNHAPPY_POINTS_YET) then - !$OMP CRITICAL - - ! Check unhappy_count again since it probably changed - ! during the setup of the omp critical, when another - ! thread read in the unhappy points. - if(unhappy_count==HAVE_NOT_READ_UNHAPPY_POINTS_YET) then - call read_unhappy_points - if(unhappy_count>0) then -1308 format("Read ",I0,' points from unhappy point list file "',A,'"!') - print 1308,unhappy_count,unhappy_txt -8031 format('Read unhappy xlat_d=',F20.12,' xlon_d=',F20.12) - do i=1,unhappy_count - print 8031,unhappy_lat(i),unhappy_lon(i) - enddo - endif - endif - !$OMP END CRITICAL - endif - ! At this point, at least one thread should have read in the unhappy points. - if(unhappy_count==FAILED_TO_READ_UNHAPPY_POINTS .and. kdt<2) then - write(0,'(A)') "Could not read unhappy points. Will not print unhappy point data." - endif - endif - ! Initialize any uninitialized lake points. call lakeini(kdt=kdt, ISLTYP=ISLTYP, gt0=gt0, snowd=snowd, weasd=weasd, & lakedepth_default=lakedepth_default, fhour=fhour, & @@ -656,13 +593,6 @@ SUBROUTINE clm_lake_run( & enddo enddo - if(LAKEDEBUG.and.kdt<3) then - was_unhappy = point_is_unhappy(xlat_d(i),xlon_d(i)) - if(was_unhappy) then - print *,'Unhappy point before LakeMain t_lake = ',t_lake(1,:) - print *,'Unhappy point before LakeMain t_soilsno = ',t_soisno(1,:) - endif - endif eflx_lwrad_net = -9999 eflx_gnet = -9999 @@ -678,7 +608,6 @@ SUBROUTINE clm_lake_run( & lat_d = xlat_d(i) lon_d = xlon_d(i) - is_unhappy=.false. CALL LakeMain(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, & !I forc_hgt_t,forc_hgt_u,forc_q, forc_u, & forc_v,forc_lwrad,prec, sabg,lat, & @@ -692,21 +621,7 @@ SUBROUTINE clm_lake_run( & t_ref2m,q_ref2m, dtime, & watsat, tksatu, tkmg, tkdry, csol, & taux,tauy,ram1,z0mg,ustar_out,errmsg,errflg, & - lat_d,lon_d,is_unhappy) - if(LAKEDEBUG) then - if((was_unhappy .or. is_unhappy) .and. kdt<3) then - print *,'Unhappy point after LakeMain t_lake = ',t_lake(1,:) - print *,'Unhappy point after LakeMain t_soilsno = ',t_soisno(1,:) - endif - if(is_unhappy .and. kdt<3) then -3081 format('UNHAPPY AT: lat=',F20.12,' lon=',F20.12) - print 3081,xlat_d(i),xlon_d(i) - endif - if(errflg/=0) then - errflg=0 ! Bad. Remove this - ! return ! should do this instead - endif - endif + lat_d,lon_d) ! Renew Lake State Variables:(14) do c = 1,column @@ -857,129 +772,6 @@ SUBROUTINE clm_lake_run( & print 3082,kdt,me,lake_points,snow_points,ice_points endif - CONTAINS - - logical function point_is_unhappy(xlat_d,xlon_d) - ! Is this point near one of the points read in from the unhappy_txt file? - ! If lakedebug is false, then it will return false immediately. - implicit none - integer :: j - real(kind_phys), intent(in) :: xlat_d,xlon_d - - if(lakedebug) then - do j=1,unhappy_count - if(abs(xlat_d-unhappy_lat(j))<.015 .and. abs(xlon_d-unhappy_lon(j))<.015) then - point_is_unhappy=.true. -1444 format('Now processing unhappy point ',I0,' location xlat_d=',F20.12,' xlon_d=',F20.12,' close to xlat_d=',F20.12,' xlon_d=',F20.12) - print 1444,j,xlat_d,xlon_d,unhappy_lat(j),unhappy_lon(j) - return - endif - enddo - endif - - ! No points matched or lakedebug is disabled. - point_is_unhappy=.false. - end function point_is_unhappy - - subroutine read_unhappy_points - ! Reads points from unhappy_txt file into unhappy_lat and unhappy lon. - ! Sets unhappy_count to the number of points read in. - ! On error, sets unhappy_count to FAILED_TO_READ_UNHAPPY_POINTS - ! - ! Also allocates unhappy_lat and unhappy_lon. Their size may - ! be larger than the number of unhappy points if the header - ! line with the point count has a higher count than the - ! number of data lines. - ! - ! File format is: - ! ------------------------------------------ - ! |5 | number of points to read in. - ! |12.34567890000000000 12.34567890000000000| Lat and lon, exactly 20 characters each, with one space between - ! | 18.70411 134.4567890000000000| Lat and lon, exactly 20 characters each, with one space between - ! |-19.8567890000000000 -134.05| Lat and lon, exactly 20 characters each, with one space between - ! |36.34567890000000000 28.34567890000000000| Lat and lon, exactly 20 characters each, with one space between - ! |-85.4567890000000000 -41.4567890000000000| Lat and lon, exactly 20 characters each, with one space between - ! ------------------------------------------- - ! - ! Longitudes must be between -180 and +180 degrees. - ! - ! If the lat and lon fields are not exactly 20 characters, - ! with one space between them, the code will not work. You - ! can space-pad them before the number or put lots of zeros - ! after the decimal point. - use ISO_FORTRAN_ENV, only: iostat_end, iostat_eor - implicit none - integer :: i,unhappy_iostat,unhappy_unit,expect_count,actual_count - - ! This uses GOTOs to mimics a try-catch construct. Do not - ! remove the GOTOs. They are the cleanest and most - ! maintainable way to implement error handlers in Fortran - ! when a long cleanup block is required in multiple places. - - ! Number of points actually read in is 0 since we haven't read yet. - actual_count=0 - - ! Open the unhappy points file - open(file=unhappy_txt,form='formatted',newunit=unhappy_unit,action='read',iostat=unhappy_iostat,status='old') - if(unhappy_iostat/=0) then - write(message,'(A,A,A)') 'Could not open "',unhappy_txt,'"!!' - goto 1001 ! Error handler without closing file - endif - - ! Determine how many points to read in. - expect_count=-1 - read(unit=unhappy_unit,fmt='(I12)',iostat=unhappy_iostat) expect_count - if(unhappy_iostat/=0 .or. expect_count<0) then - write(message,'(A,A,A)') 'Could not read unhappy point count from "',unhappy_txt,'"!!' - goto 1000 ! Error handler that also closes the file - endif - - ! Allocate enough data for the number of points we expect to read in - allocate(unhappy_lat(expect_count)) - allocate(unhappy_lon(expect_count)) - - unhappy_lat = -999 - unhappy_lon = -999 - - ! Read data, and determine the number of points actually in the file - do i=1,expect_count - read(unit=unhappy_unit,fmt='(F20.14,F20.14)',iostat=unhappy_iostat) & - unhappy_lat(actual_count+1),unhappy_lon(actual_count+1) - if(unhappy_iostat==iostat_end) then - exit - else if(unhappy_iostat==iostat_eor) then - continue ! Probably a blank line - else if(unhappy_iostat/=0) then - write(message,'(A,A,A)') 'Error reading from "',unhappy_txt,'"!!' - goto 1000 ! Error handler that also closes the file - else - actual_count=actual_count+1 - endif - enddo - - ! Indicate successful read by setting the unhappy_count to the number of points actually read in. - unhappy_count=actual_count - close(unhappy_iostat) - - return ! Success! - - ! Error handlers. - - ! Theses do not set errmsg or error flag because this is - ! just an error in setting up a diagnostic, not in the model - ! itself. - -1000 continue ! Error handler, after file is opened - close(unhappy_iostat) - -1001 continue ! Error handler, whether file was opened or not - write(0,'(A)') message - if(allocated(unhappy_lat)) deallocate(unhappy_lat) - if(allocated(unhappy_lon)) deallocate(unhappy_lon) - unhappy_count=FAILED_TO_READ_UNHAPPY_POINTS - - end subroutine read_unhappy_points - END SUBROUTINE clm_lake_run @@ -995,11 +787,10 @@ SUBROUTINE LakeMain(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, & !I eflx_sh_tot,eflx_lh_tot, & t_ref2m,q_ref2m, dtime, & watsat, tksatu, tkmg, tkdry, csol, & - taux,tauy,ram1,z0mg,ustar_out,errmsg,errflg, xlat_d,xlon_d,unhappy) + taux,tauy,ram1,z0mg,ustar_out,errmsg,errflg, xlat_d,xlon_d) implicit none !in: - logical :: unhappy integer, intent(inout) :: errflg character(*), intent(inout) :: errmsg real(kind_lake),intent(in) :: dtime ! timestep @@ -1146,7 +937,7 @@ SUBROUTINE LakeMain(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, & !I eflx_sh_grnd,eflx_lwrad_out,eflx_lwrad_net, & eflx_soil_grnd,eflx_sh_tot,eflx_lh_tot, & eflx_lh_grnd,t_veg,t_ref2m,q_ref2m,taux,tauy, & - ram1,ws,ks,eflx_gnet,z0mg,ustar_out,errmsg,errflg,xlat_d,xlon_d,unhappy) + ram1,ws,ks,eflx_gnet,z0mg,ustar_out,errmsg,errflg,xlat_d,xlon_d) if(errflg/=0) then return ! State is invalid now, so pass error to caller. endif @@ -1201,7 +992,7 @@ SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, eflx_sh_grnd,eflx_lwrad_out,eflx_lwrad_net, & eflx_soil_grnd,eflx_sh_tot,eflx_lh_tot, & eflx_lh_grnd,t_veg,t_ref2m,q_ref2m,taux,tauy, & - ram1,ws,ks,eflx_gnet,z0mg,ustar_out,errmsg,errflg,xlat_d,xlon_d,unhappy) + ram1,ws,ks,eflx_gnet,z0mg,ustar_out,errmsg,errflg,xlat_d,xlon_d) !============================================================================== ! DESCRIPTION: ! Calculates lake temperatures and surface fluxes for shallow lakes. @@ -1224,7 +1015,6 @@ SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, !in: integer, intent(inout) :: errflg - logical :: unhappy character(len=*), intent(inout) :: errmsg real(kind_lake),intent(in) :: xlat_d,xlon_d real(kind_lake),intent(in) :: forc_t(1) ! atmospheric temperature (Kelvin) @@ -1364,8 +1154,6 @@ SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, ! data eta /0.1_kind_lake, 0.5_kind_lake/ !----------------------------------------------------------------------- - unhappy=.false. - ! Begin calculations !dir$ concurrent @@ -1384,7 +1172,6 @@ SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, if (snl(c) > 0 .or. snl(c) < -5) then errmsg='snl is not defined in ShalLakeFluxesMod; snl: out of range value' errflg=1 - unhappy=.true. return ! Cannot continue end if ! if (snl(c) /= 0) then @@ -1699,7 +1486,6 @@ SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, if (abs(eflx_sh_tot(p)) > 1500 .or. abs(eflx_lh_tot(p)) > 1500) then 3018 format('CLM_Lake ShalLakeFluxes: WARNING: SH=',F12.4,' LH=',F12.4,' at xlat_d=',F10.3,' xlon_d=',F10.3) print 3018,eflx_sh_tot(p), eflx_lh_tot(p),xlat_d,xlon_d - unhappy = .true. end if if (abs(eflx_sh_tot(p)) > 10000 .or. abs(eflx_lh_tot(p)) > 10000 & .or. abs(t_grnd(c)-288)>200 ) then @@ -1708,7 +1494,6 @@ SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, ! errmsg=message ! errflg=1 write(0,'(A)') trim(message) - unhappy = .true. endif endif ! 2 m height air temperature From 3df601ead306f66c31c3c549bee165ffc9241654 Mon Sep 17 00:00:00 2001 From: "Haiqin.Li" Date: Sat, 15 Apr 2023 04:39:34 +0000 Subject: [PATCH 222/380] "update to address UFS code manager's comments" --- physics/cu_gf_deep.F90 | 196 +++------------------------------ physics/cu_gf_driver.meta | 4 +- physics/cu_gf_driver_post.F90 | 8 +- physics/cu_gf_driver_post.meta | 4 +- 4 files changed, 22 insertions(+), 190 deletions(-) diff --git a/physics/cu_gf_deep.F90 b/physics/cu_gf_deep.F90 index 2368dc05a..2335a2308 100644 --- a/physics/cu_gf_deep.F90 +++ b/physics/cu_gf_deep.F90 @@ -28,6 +28,7 @@ module cu_gf_deep integer, parameter :: autoconv=1 !2 integer, parameter :: aeroevap=1 !3 real(kind=kind_phys), parameter :: scav_factor = 0.5 + real(kind=kind_phys), parameter :: dx_thresh = 6500. !> still 16 ensembles for clousres integer, parameter:: maxens3=16 @@ -434,8 +435,6 @@ subroutine cu_gf_deep_run( & el2orc=xlv*xlv/(r_v*cp) evfact=0.25 ! .4 evfactl=0.25 ! .2 - !evfact=.0 ! for 4F5f - !evfactl=.4 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -499,10 +498,7 @@ subroutine cu_gf_deep_run( & zws(i) = zws(i)*rho(i,kpbl(i)) !check if zrho is correct enddo !$acc end kernels -! cap_maxs=225. -! if(imid.eq.1)cap_maxs=150. cap_maxs=75. ! 150. -! if(imid.eq.1)cap_maxs=100. !$acc kernels do i=its,itf edto(i)=0. @@ -510,13 +506,10 @@ subroutine cu_gf_deep_run( & xmb_out(i)=0. cap_max(i)=cap_maxs cap_max_increment(i)=20. -! if(imid.eq.1)cap_max_increment(i)=10. ! ! for water or ice ! if (xland1(i)==0) then -! if(imid.eq.0)cap_max(i)=cap_maxs-25. -! if(imid.eq.1)cap_max(i)=cap_maxs-50. cap_max_increment(i)=20. else if(ztexec(i).gt.0.)cap_max(i)=cap_max(i)+25. @@ -525,7 +518,6 @@ subroutine cu_gf_deep_run( & #ifndef _OPENACC ierrc(i)=" " #endif -! cap_max_increment(i)=1. enddo !$acc end kernels if(use_excess == 0 )then @@ -560,7 +552,7 @@ subroutine cu_gf_deep_run( & c1d(i,:)= 0. !c1 ! 0. ! c1 ! max(.003,c1+float(csum(i))*.0001) entr_rate(i)=7.e-5 - min(20.,float(csum(i))) * 3.e-6 if(xland1(i) == 0)entr_rate(i)=7.e-5 - if(dx(i)<6500.) entr_rate(i)=2.e-4 + if(dx(i) - Compute downdraft moist static energy + moisture budget do k=2,jmin(i)+1 @@ -1428,7 +1281,6 @@ subroutine cu_gf_deep_run( & dbydo(i,ki)=hcdo(i,ki)-heso_cup(i,ki) bud(i)=bud(i)+dbydo(i,ki)*dzo enddo - ! endif if(bud(i).gt.0)then ierr(i)=7 @@ -1448,25 +1300,6 @@ subroutine cu_gf_deep_run( & itf,ktf, & its,ite, kts,kte) ! -!---meltglac------------------------------------------------- -!--- calculate moisture properties of updraft -! -! if(imid.eq.1)then -! call cup_up_moisture('mid',ierr,zo_cup,qco,qrco,pwo,pwavo, & -! p_cup,kbcon,ktop,dbyo,clw_all,xland1, & -! qo,gammao_cup,zuo,qeso_cup,k22,qo_cup,c0, & -! zqexec,ccn,rho,c1d,tn_cup,up_massentr,up_massdetr,psum,psumh, & -! 1,itf,ktf, & -! its,ite, kts,kte) -! else -! call cup_up_moisture('deep',ierr,zo_cup,qco,qrco,pwo,pwavo, & -! p_cup,kbcon,ktop,dbyo,clw_all,xland1, & -! qo,gammao_cup,zuo,qeso_cup,k22,qo_cup,c0, & -! zqexec,ccn,rho,c1d,tn_cup,up_massentr,up_massdetr,psum,psumh, & -! 1,itf,ktf, & -! its,ite, kts,kte) -! endif -!---meltglac------------------------------------------------- !$acc kernels do i=its,itf if(ierr(i)/=0)cycle @@ -1868,16 +1701,12 @@ subroutine cu_gf_deep_run( & !-- take out cloud liquid water for detrainment detup=up_massdetro(i,k) dz=zo_cup(i,k)-zo_cup(i,k-1) -!! if(k.lt.ktop(i) .and. k.ge.jmin(i)) then -!! if(k.lt.ktop(i) .and. c1d(i,k).gt.0) then if(k.lt.ktop(i)) then dellaqc(i,k) = zuo(i,k)*c1d(i,k)*qrco(i,k)*dz/dp*g else dellaqc(i,k)= detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp endif -!! if(imid.eq.1) dellaqc(i,k)= detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp -! if(k.eq.ktop(i))dellaqc(i,k)= detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp -! !--- + !--- g_rain= 0.5*(pwo (i,k)+pwo (i,k+1))*g/dp e_dn = -0.5*(pwdo(i,k)+pwdo(i,k+1))*g/dp*edto(i) ! pwdo < 0 and e_dn must > 0 !-- condensation source term = detrained + flux divergence of @@ -2120,7 +1949,7 @@ subroutine cu_gf_deep_run( & its,ite, kts,kte, & dicycle,tau_ecmwf,aa1_bl,xf_dicycle) do i=its,itf - if((dx(i)<6500.).and.(forcing(i,3).le.0.))sig(i)=1. + if((dx(i) This subroutine calculates final output fields including !! physical tendencies, precipitation, and mass-flux. subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & - outtem,outq,outqc, & + outtem,outq,outqc,dx, & zu,pre,pw,xmb,ktop, & edt,pwd,name,ierr2,ierr3,p_cup,pr_ens, & maxens3, & @@ -4064,7 +3893,7 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & zu,pwd,p_cup real(kind=kind_phys), dimension (its:ite) & ,intent (in ) :: & - sig,xmbm_in,xmbs_in,edt + sig,xmbm_in,xmbs_in,edt,dx real(kind=kind_phys), dimension (its:ite,2) & ,intent (in ) :: & xff_mid @@ -4161,8 +3990,11 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & ! --- now use proper count of how many closures were actually ! used in cup_forcing_ens (including screening of some ! closures over water) to properly normalize xmb + if (dx(i).ge.dx_thresh)then clos_wei=16./max(1.,closure_n(i)) - clos_wei=1. + else + clos_wei=1. + endif xmb_ave(i)=min(xmb_ave(i),100.) xmb(i)=clos_wei*sig(i)*xmb_ave(i) diff --git a/physics/cu_gf_driver.meta b/physics/cu_gf_driver.meta index adcf49f2f..60c7e7fe5 100644 --- a/physics/cu_gf_driver.meta +++ b/physics/cu_gf_driver.meta @@ -554,8 +554,8 @@ kind = kind_phys intent = in [maxupmf] - standard_name = maximum_conv_up_draft_mass_flux - long_name = maximum convective up draft mass flux within a column + standard_name = maximum_convective_updraft_mass_flux + long_name = maximum convective updraft mass flux within a column units = m s-1 dimensions = (horizontal_loop_extent) type = real diff --git a/physics/cu_gf_driver_post.F90 b/physics/cu_gf_driver_post.F90 index 71877c5f4..56da0feba 100644 --- a/physics/cu_gf_driver_post.F90 +++ b/physics/cu_gf_driver_post.F90 @@ -41,9 +41,9 @@ subroutine cu_gf_driver_post_run (im, km, t, q, prevst, prevsq, cactiv, cactiv_m integer, intent(out) :: errflg ! Local variables - real, parameter :: dbzmin=-10.0 ! dcd - real :: cuprate ! dcd - real :: ze, ze_conv, dbz_sum ! dcd + real(kind_phys), parameter :: dbzmin=-10.0 + real(kind_phys) :: cuprate + real(kind_phys) :: ze, ze_conv, dbz_sum integer :: i, k ! Initialize CCPP error handling variables @@ -74,7 +74,7 @@ subroutine cu_gf_driver_post_run (im, km, t, q, prevst, prevsq, cactiv, cactiv_m ze_conv = 300.0 * cuprate**1.4 if (maxupmf(i).gt.0.05) then do k = 1, km - ze = 10.0 ** (0.1 * refl_10cm(i,k)) + ze = 10._kind_phys ** (0.1 * refl_10cm(i,k)) dbz_sum = max(dbzmin, 10.0 * log10(ze + ze_conv)) refl_10cm(i,k) = dbz_sum enddo diff --git a/physics/cu_gf_driver_post.meta b/physics/cu_gf_driver_post.meta index 18f062b2d..48e762cb4 100644 --- a/physics/cu_gf_driver_post.meta +++ b/physics/cu_gf_driver_post.meta @@ -108,8 +108,8 @@ kind = kind_phys intent = in [maxupmf] - standard_name = maximum_conv_up_draft_mass_flux - long_name = maximum convective up draft mass flux within a column + standard_name = maximum_convective_updraft_mass_flux + long_name = maximum convective updraft mass flux within a column units = m s-1 dimensions = (horizontal_loop_extent) type = real From 4e7ca4ebfd25441c67f8fe4c36c26ee76ffa6b09 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Sat, 15 Apr 2023 19:47:21 -0500 Subject: [PATCH 223/380] Added NSSL 3-moment variables to pre/post tracer arrays --- physics/GFS_DCNV_generic_post.F90 | 8 +++-- physics/GFS_DCNV_generic_post.meta | 21 +++++++++++++ physics/GFS_DCNV_generic_pre.F90 | 7 +++-- physics/GFS_DCNV_generic_pre.meta | 21 +++++++++++++ physics/GFS_PBL_generic_post.F90 | 29 +++++++++++++----- physics/GFS_PBL_generic_post.meta | 28 +++++++++++++++++ physics/GFS_PBL_generic_pre.F90 | 49 +++++++++++++++++++----------- physics/GFS_PBL_generic_pre.meta | 28 +++++++++++++++++ 8 files changed, 162 insertions(+), 29 deletions(-) diff --git a/physics/GFS_DCNV_generic_post.F90 b/physics/GFS_DCNV_generic_post.F90 index 51a228122..3b69849a7 100644 --- a/physics/GFS_DCNV_generic_post.F90 +++ b/physics/GFS_DCNV_generic_post.F90 @@ -15,7 +15,7 @@ subroutine GFS_DCNV_generic_post_run (im, levs, lssav, ldiag3d, qdiag3d, ras, & index_of_temperature, index_of_x_wind, index_of_y_wind, ntqv, gq0, save_q, & cnvw, cnvc, cnvw_phy_f3d, cnvc_phy_f3d, flag_for_dcnv_generic_tend, & ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl, & - ntgnc, nthl, nthnc, nthv, ntgv, ntsigma, ntrac,clw, & + ntgnc, nthl, nthnc, nthv, ntgv, ntrz, ntgz, nthz, ntsigma, ntrac,clw, & satmedmf, trans_trac, errmsg, errflg) @@ -44,8 +44,9 @@ subroutine GFS_DCNV_generic_post_run (im, levs, lssav, ldiag3d, qdiag3d, ras, & real(kind=kind_phys), dimension(:,:,:), intent(inout) :: dtend integer, intent(in) :: dtidx(:,:), index_of_process_dcnv, index_of_temperature, & index_of_x_wind, index_of_y_wind, ntqv - integer, intent(in) :: ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl, & - ntgnc, nthl, nthnc, nthv, ntgv, ntsigma, ntrac + integer, intent(in) :: ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl, & + ntgnc, nthl, nthnc, nthv, ntgv, ntrz, ntgz, nthz, & + ntsigma, ntrac real(kind=kind_phys), dimension(:,:,:), intent(in) :: clw @@ -112,6 +113,7 @@ subroutine GFS_DCNV_generic_post_run (im, levs, lssav, ldiag3d, qdiag3d, ras, & n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & n /= ntsnc .and. n /= ntgl .and. n /= ntgnc .and. & n /= nthl .and. n /= nthnc .and. n /= nthv .and. & + n /= ntrz .and. n /= ntgz .and. n /= nthz .and. & n /= ntgv .and. n /= ntsigma) then tracers = tracers + 1 idtend = dtidx(100+n,index_of_process_dcnv) diff --git a/physics/GFS_DCNV_generic_post.meta b/physics/GFS_DCNV_generic_post.meta index 8428752ce..191e83a3a 100644 --- a/physics/GFS_DCNV_generic_post.meta +++ b/physics/GFS_DCNV_generic_post.meta @@ -454,6 +454,27 @@ dimensions = () type = integer intent = in +[ntrz] + standard_name = index_of_reflectivity_of_rain_in_tracer_concentration_array + long_name = tracer index for rain reflectivity + units = index + dimensions = () + type = integer + intent = in +[ntgz] + standard_name = index_of_reflectivity_of_graupel_in_tracer_concentration_array + long_name = tracer index for graupel reflectivity + units = index + dimensions = () + type = integer + intent = in +[nthz] + standard_name = index_of_reflectivity_of_hail_in_tracer_concentration_array + long_name = tracer index for hail reflectivity + units = index + dimensions = () + type = integer + intent = in [clw] standard_name = convective_transportable_tracers long_name = array to contain cloud water and other convective trans. tracers diff --git a/physics/GFS_DCNV_generic_pre.F90 b/physics/GFS_DCNV_generic_pre.F90 index b31daf5d6..1dd3aafc7 100644 --- a/physics/GFS_DCNV_generic_pre.F90 +++ b/physics/GFS_DCNV_generic_pre.F90 @@ -13,7 +13,8 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc gu0, gv0, gt0, gq0, nsamftrac, ntqv, & save_u, save_v, save_t, save_q, clw, & ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl, & - ntgnc, nthl, nthnc, nthv, ntgv,ntsigma, & + ntgnc, nthl, nthnc, nthv, ntgv, & + ntrz, ntgz, nthz, ntsigma, & cscnv, satmedmf, trans_trac, ras, ntrac, & dtidx, index_of_process_dcnv, errmsg, errflg) @@ -22,7 +23,8 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc implicit none integer, intent(in) :: im, levs, nsamftrac, ntqv, index_of_process_dcnv, dtidx(:,:), & - ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntrac,ntgnc,nthl,nthnc,nthv,ntgv,ntsigma + ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntrac,ntgnc,nthl,nthnc,nthv,ntgv, & + ntrz, ntgz, nthz, ntsigma logical, intent(in) :: ldiag3d, qdiag3d, do_cnvgwd, cplchm real(kind=kind_phys), dimension(:,:), intent(in) :: gu0 real(kind=kind_phys), dimension(:,:), intent(in) :: gv0 @@ -68,6 +70,7 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & n /= ntsnc .and. n /= ntgl .and. n /= ntgnc .and. & n /= nthl .and. n /= nthnc .and. n /= nthv .and. & + n /= ntrz .and. n /= ntgz .and. n /= nthz .and. & n /= ntgv .and. n/= ntsigma) then tracers = tracers + 1 if(dtidx(100+n,index_of_process_dcnv)>0) then diff --git a/physics/GFS_DCNV_generic_pre.meta b/physics/GFS_DCNV_generic_pre.meta index ee2050926..a9008436e 100644 --- a/physics/GFS_DCNV_generic_pre.meta +++ b/physics/GFS_DCNV_generic_pre.meta @@ -267,6 +267,27 @@ dimensions = () type = integer intent = in +[ntrz] + standard_name = index_of_reflectivity_of_rain_in_tracer_concentration_array + long_name = tracer index for rain reflectivity + units = index + dimensions = () + type = integer + intent = in +[ntgz] + standard_name = index_of_reflectivity_of_graupel_in_tracer_concentration_array + long_name = tracer index for graupel reflectivity + units = index + dimensions = () + type = integer + intent = in +[nthz] + standard_name = index_of_reflectivity_of_hail_in_tracer_concentration_array + long_name = tracer index for hail reflectivity + units = index + dimensions = () + type = integer + intent = in [clw] standard_name = convective_transportable_tracers long_name = array to contain cloud water and other convective trans. tracers diff --git a/physics/GFS_PBL_generic_post.F90 b/physics/GFS_PBL_generic_post.F90 index 0d13dc5d8..a4e5f172a 100644 --- a/physics/GFS_PBL_generic_post.F90 +++ b/physics/GFS_PBL_generic_post.F90 @@ -10,9 +10,9 @@ module GFS_PBL_generic_post !! subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, & ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc, ntwa, ntia, ntgl, ntoz, ntke, ntkev,nqrimef, & - trans_aero, ntchs, ntchm, ntccn, nthl, nthnc, ntgv, nthv, & + trans_aero, ntchs, ntchm, ntccn, nthl, nthnc, ntgv, nthv, ntrz, ntgz, nthz, & imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, imp_physics_zhao_carr, imp_physics_mg, & - imp_physics_fer_hires, imp_physics_nssl, nssl_ccn_on, ltaerosol, mraerosol, nssl_hail_on, & + imp_physics_fer_hires, imp_physics_nssl, nssl_ccn_on, ltaerosol, mraerosol, nssl_hail_on, nssl_3moment, & cplflx, cplaqm, cplchm, lssav, flag_for_pbl_generic_tend, ldiag3d, lsidea, hybedmf, do_shoc, satmedmf, & shinhong, do_ysu, dvdftra, dusfc1, dvsfc1, dtsfc1, dqsfc1, dtf, dudt, dvdt, dtdt, htrsw, htrlw, xmu, & dqdt, dusfc_cpl, dvsfc_cpl, dtsfc_cpl, dtend, dtidx, index_of_temperature, index_of_x_wind, index_of_y_wind, & @@ -30,12 +30,12 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, integer, parameter :: kp = kind_phys integer, intent(in) :: im, levs, nvdiff, ntrac, ntchs, ntchm, kdt integer, intent(in) :: ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc, ntwa, ntia, ntgl, ntoz, ntke, ntkev, nqrimef - integer, intent(in) :: ntccn, nthl, nthnc, ntgv, nthv + integer, intent(in) :: ntccn, nthl, nthnc, ntgv, nthv, ntrz, ntgz, nthz logical, intent(in) :: trans_aero integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6 integer, intent(in) :: imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires integer, intent(in) :: imp_physics_nssl - logical, intent(in) :: nssl_ccn_on, nssl_hail_on + logical, intent(in) :: nssl_ccn_on, nssl_hail_on, nssl_3moment logical, intent(in) :: ltaerosol, cplflx, cplaqm, cplchm, lssav, ldiag3d, lsidea, use_med_flux, mraerosol logical, intent(in) :: hybedmf, do_shoc, satmedmf, shinhong, do_ysu @@ -270,8 +270,16 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, dqdt(i,k,ntgv) = dvdftra(i,k,14) dqdt(i,k,nthv) = dvdftra(i,k,15) dqdt(i,k,ntoz) = dvdftra(i,k,16) + n = 16 IF ( nssl_ccn_on ) THEN - dqdt(i,k,ntccn) = dvdftra(i,k,17) + dqdt(i,k,ntccn) = dvdftra(i,k,n+1) + n = n+1 + ENDIF + IF ( nssl_3moment ) THEN + dqdt(i,k,ntrz) = dvdftra(i,k,n+1) + dqdt(i,k,ntgz) = dvdftra(i,k,n+2) + dqdt(i,k,nthz) = dvdftra(i,k,n+3) + n = n+3 ENDIF enddo enddo @@ -292,9 +300,16 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, dqdt(i,k,ntsnc) = dvdftra(i,k,10) dqdt(i,k,ntgnc) = dvdftra(i,k,11) dqdt(i,k,ntgv) = dvdftra(i,k,12) - dqdt(i,k,ntoz) = dvdftra(i,k,13) + dqdt(i,k,ntoz) = dvdftra(i,k,13) + n = 13 IF ( nssl_ccn_on ) THEN - dqdt(i,k,ntccn) = dvdftra(i,k,14) + dqdt(i,k,ntccn) = dvdftra(i,k,n+1) + n = n+1 + ENDIF + IF ( nssl_3moment ) THEN + dqdt(i,k,ntrz) = dvdftra(i,k,n+1) + dqdt(i,k,ntgz) = dvdftra(i,k,n+2) + n = n+2 ENDIF enddo enddo diff --git a/physics/GFS_PBL_generic_post.meta b/physics/GFS_PBL_generic_post.meta index b20142991..a53acbc64 100644 --- a/physics/GFS_PBL_generic_post.meta +++ b/physics/GFS_PBL_generic_post.meta @@ -211,6 +211,27 @@ dimensions = () type = integer intent = in +[ntrz] + standard_name = index_of_reflectivity_of_rain_in_tracer_concentration_array + long_name = tracer index for rain reflectivity + units = index + dimensions = () + type = integer + intent = in +[ntgz] + standard_name = index_of_reflectivity_of_graupel_in_tracer_concentration_array + long_name = tracer index for graupel reflectivity + units = index + dimensions = () + type = integer + intent = in +[nthz] + standard_name = index_of_reflectivity_of_hail_in_tracer_concentration_array + long_name = tracer index for hail reflectivity + units = index + dimensions = () + type = integer + intent = in [imp_physics] standard_name = control_for_microphysics_scheme long_name = choice of microphysics scheme @@ -295,6 +316,13 @@ dimensions = () type = logical intent = in +[nssl_3moment] + standard_name = nssl_3moment + long_name = 3-moment activation flag in NSSL microphysics scheme + units = flag + dimensions = () + type = logical + intent = in [cplflx] standard_name = flag_for_surface_flux_coupling long_name = flag controlling cplflx collection (default off) diff --git a/physics/GFS_PBL_generic_pre.F90 b/physics/GFS_PBL_generic_pre.F90 index b9f7bb880..d8ed0f8fc 100644 --- a/physics/GFS_PBL_generic_pre.F90 +++ b/physics/GFS_PBL_generic_pre.F90 @@ -12,10 +12,10 @@ module GFS_PBL_generic_pre subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, rtg_ozone_index, & ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc, & ntwa, ntia, ntgl, ntoz, ntke, ntkev, nqrimef, trans_aero, ntchs, ntchm, & - ntccn, nthl, nthnc, ntgv, nthv, & + ntccn, nthl, nthnc, ntgv, nthv, ntrz, ntgz, nthz, & imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, & imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires, imp_physics_nssl, & - ltaerosol, mraerosol, nssl_ccn_on, nssl_hail_on, & + ltaerosol, mraerosol, nssl_ccn_on, nssl_hail_on, nssl_3moment, & hybedmf, do_shoc, satmedmf, qgrs, vdftra, save_u, save_v, save_t, save_q, & flag_for_pbl_generic_tend, ldiag3d, qdiag3d, lssav, ugrs, vgrs, tgrs, errmsg, errflg) @@ -29,13 +29,13 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, rtg_ozone_index, integer, intent(in) :: im, levs, nvdiff, ntrac integer, intent(in) :: ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc integer, intent(in) :: ntwa, ntia, ntgl, ntoz, ntke, ntkev, nqrimef,ntchs, ntchm - integer, intent(in) :: ntccn, nthl, nthnc, ntgv, nthv + integer, intent(in) :: ntccn, nthl, nthnc, ntgv, nthv, ntrz, ntgz, nthz logical, intent(in) :: trans_aero, ldiag3d, qdiag3d, lssav integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6 integer, intent(in) :: imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires logical, intent(in) :: ltaerosol, hybedmf, do_shoc, satmedmf, flag_for_pbl_generic_tend, mraerosol integer, intent(in) :: imp_physics_nssl - logical, intent(in) :: nssl_hail_on, nssl_ccn_on + logical, intent(in) :: nssl_hail_on, nssl_ccn_on, nssl_3moment real(kind=kind_phys), dimension(:,:,:), intent(in) :: qgrs real(kind=kind_phys), dimension(:,:), intent(in) :: ugrs, vgrs, tgrs @@ -215,15 +215,23 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, rtg_ozone_index, vdftra(i,k,7) = qgrs(i,k,nthl) vdftra(i,k,8) = qgrs(i,k,ntlnc) vdftra(i,k,9) = qgrs(i,k,ntinc) - vdftra(i,k,10) = qgrs(i,k,ntrnc) - vdftra(i,k,11) = qgrs(i,k,ntsnc) - vdftra(i,k,12) = qgrs(i,k,ntgnc) - vdftra(i,k,13) = qgrs(i,k,nthnc) - vdftra(i,k,14) = qgrs(i,k,ntgv) - vdftra(i,k,15) = qgrs(i,k,nthv) - vdftra(i,k,16) = qgrs(i,k,ntoz) + vdftra(i,k,10) = qgrs(i,k,ntrnc) + vdftra(i,k,11) = qgrs(i,k,ntsnc) + vdftra(i,k,12) = qgrs(i,k,ntgnc) + vdftra(i,k,13) = qgrs(i,k,nthnc) + vdftra(i,k,14) = qgrs(i,k,ntgv) + vdftra(i,k,15) = qgrs(i,k,nthv) + vdftra(i,k,16) = qgrs(i,k,ntoz) + n = 16 IF ( nssl_ccn_on ) THEN - vdftra(i,k,17) = qgrs(i,k,ntccn) + vdftra(i,k,n+1) = qgrs(i,k,ntccn) + n = n+1 + ENDIF + IF ( nssl_3moment ) THEN + vdftra(i,k,n+1) = qgrs(i,k,ntrz) + vdftra(i,k,n+2) = qgrs(i,k,ntgz) + vdftra(i,k,n+3) = qgrs(i,k,nthz) + n = n+3 ENDIF enddo enddo @@ -241,12 +249,19 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, rtg_ozone_index, vdftra(i,k,7) = qgrs(i,k,ntlnc) vdftra(i,k,8) = qgrs(i,k,ntinc) vdftra(i,k,9) = qgrs(i,k,ntrnc) - vdftra(i,k,10) = qgrs(i,k,ntsnc) - vdftra(i,k,11) = qgrs(i,k,ntgnc) - vdftra(i,k,12) = qgrs(i,k,ntgv) - vdftra(i,k,13) = qgrs(i,k,ntoz) + vdftra(i,k,10) = qgrs(i,k,ntsnc) + vdftra(i,k,11) = qgrs(i,k,ntgnc) + vdftra(i,k,12) = qgrs(i,k,ntgv) + vdftra(i,k,13) = qgrs(i,k,ntoz) + n = 13 IF ( nssl_ccn_on ) THEN - vdftra(i,k,14) = qgrs(i,k,ntccn) + vdftra(i,k,n+1) = qgrs(i,k,ntccn) + n = n+1 + ENDIF + IF ( nssl_3moment ) THEN + vdftra(i,k,n+1) = qgrs(i,k,ntrz) + vdftra(i,k,n+2) = qgrs(i,k,ntgz) + n = n+2 ENDIF enddo enddo diff --git a/physics/GFS_PBL_generic_pre.meta b/physics/GFS_PBL_generic_pre.meta index a09b34b48..995fac565 100644 --- a/physics/GFS_PBL_generic_pre.meta +++ b/physics/GFS_PBL_generic_pre.meta @@ -217,6 +217,27 @@ dimensions = () type = integer intent = in +[ntrz] + standard_name = index_of_reflectivity_of_rain_in_tracer_concentration_array + long_name = tracer index for rain reflectivity + units = index + dimensions = () + type = integer + intent = in +[ntgz] + standard_name = index_of_reflectivity_of_graupel_in_tracer_concentration_array + long_name = tracer index for graupel reflectivity + units = index + dimensions = () + type = integer + intent = in +[nthz] + standard_name = index_of_reflectivity_of_hail_in_tracer_concentration_array + long_name = tracer index for hail reflectivity + units = index + dimensions = () + type = integer + intent = in [imp_physics] standard_name = control_for_microphysics_scheme long_name = choice of microphysics scheme @@ -301,6 +322,13 @@ dimensions = () type = logical intent = in +[nssl_3moment] + standard_name = nssl_3moment + long_name = 3-moment activation flag in NSSL microphysics scheme + units = flag + dimensions = () + type = logical + intent = in [hybedmf] standard_name = flag_for_hybrid_edmf_pbl_scheme long_name = flag for hybrid edmf pbl scheme (moninedmf) From d98defadb2d13d64204188a6ebba2049a99de87c Mon Sep 17 00:00:00 2001 From: Michael Barlage Date: Mon, 17 Apr 2023 17:26:53 -0400 Subject: [PATCH 224/380] modify a few terms in vegetation diag3 --- physics/module_sf_noahmplsm.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/physics/module_sf_noahmplsm.F90 b/physics/module_sf_noahmplsm.F90 index 65b3d77b3..e28b5447e 100644 --- a/physics/module_sf_noahmplsm.F90 +++ b/physics/module_sf_noahmplsm.F90 @@ -4339,15 +4339,15 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & fhi = fh2/fh wrk = 1.0 - fhi if(thsfc_loc) then ! Use local potential temperature - t2mv = tv*wrk + sfctmp*prslkix*fhi - (grav+grav)/cp + t2mv = tah*wrk + sfctmp*prslkix*fhi - (grav+grav)/cp else ! Use potential temperature referenced to 1000 hPa - t2mv = tv*wrk + sfctmp*fhi - (grav+grav)/cp + t2mv = tah*wrk + sfctmp*fhi - (grav+grav)/cp endif - if(evg >= 0.) then ! for evaporation>0, use inferred qsurf to deduce q2v + if((evc+tr)/fveg+evg >= 0.) then ! for evaporation>0, use inferred qsurf to deduce q2v q2v = qsfc*wrk + max(qmin,qair)*fhi else ! for dew formation, use saturated q at tskin - qss = fpvs(tv) + qss = fpvs(tah) qss = ep_2 * qss / (psfc + epsm1 * qss) q2v= qss*wrk + max(qmin,qair)*fhi endif From a4058658d59533af8ed2065ab0c67d536379be65 Mon Sep 17 00:00:00 2001 From: Michael Barlage Date: Tue, 18 Apr 2023 13:46:21 -0400 Subject: [PATCH 225/380] add veg and bare qsfc to output --- physics/module_sf_noahmplsm.F90 | 9 +++++++-- physics/noahmpdrv.F90 | 16 +++++++++++++--- 2 files changed, 20 insertions(+), 5 deletions(-) diff --git a/physics/module_sf_noahmplsm.F90 b/physics/module_sf_noahmplsm.F90 index e28b5447e..db653c548 100644 --- a/physics/module_sf_noahmplsm.F90 +++ b/physics/module_sf_noahmplsm.F90 @@ -442,7 +442,8 @@ subroutine noahmp_sflx (parameters, & shg , shc , shb , evg , evb , ghv , & ! out : ghb , irg , irc , irb , tr , evc , & ! out : chleaf , chuc , chv2 , chb2 , fpice , pahv , & - pahg , pahb , pah , esnow , canhs , laisun , laisha , rb & + pahg , pahb , pah , esnow , canhs , laisun , & + laisha , rb , qsfcveg , qsfcbare & #ifdef CCPP ,errmsg, errflg) #else @@ -587,6 +588,8 @@ subroutine noahmp_sflx (parameters, & real (kind=kind_phys) , intent(out) :: rb !< leaf boundary layer resistance (s/m) real (kind=kind_phys) , intent(out) :: laisun !< sunlit leaf area index (m2/m2) real (kind=kind_phys) , intent(out) :: laisha !< shaded leaf area index (m2/m2) + real (kind=kind_phys) , intent(out) :: qsfcveg !< effective spec humid over vegetation + real (kind=kind_phys) , intent(out) :: qsfcbare !< effective spec humid over bare soil !jref:start; output real (kind=kind_phys) , intent(out) :: t2mv !< 2-m air temperature over vegetated part [k] @@ -847,7 +850,9 @@ subroutine noahmp_sflx (parameters, & emissi ,pah ,canhs, & shg,shc,shb,evg,evb,ghv,ghb,irg,irc,irb,tr,evc,chleaf,chuc,chv2,chb2 ) !out - qsfc = q1 ! + qsfcveg = eah*0.622/(sfcprs - 0.378*eah) + qsfcbare = qsfc + qsfc = q1 !jref:end #ifdef CCPP if (errflg /= 0) return diff --git a/physics/noahmpdrv.F90 b/physics/noahmpdrv.F90 index 85d3363b4..88e75637b 100644 --- a/physics/noahmpdrv.F90 +++ b/physics/noahmpdrv.F90 @@ -195,7 +195,10 @@ subroutine noahmpdrv_run & ch_bare_ground_2m_ccpp, & precip_adv_heat_veg_ccpp, & precip_adv_heat_grd_v_ccpp, & - precip_adv_heat_grd_b_ccpp ) + precip_adv_heat_grd_b_ccpp, & + spec_humid_sfc_veg_ccpp, & + spec_humid_sfc_bare_ccpp & + ) use machine , only : kind_phys use funcphys, only : fpvs @@ -436,6 +439,8 @@ subroutine noahmpdrv_run & real(kind=kind_phys), dimension(:) , intent(out), optional :: precip_adv_heat_veg_ccpp real(kind=kind_phys), dimension(:) , intent(out), optional :: precip_adv_heat_grd_v_ccpp real(kind=kind_phys), dimension(:) , intent(out), optional :: precip_adv_heat_grd_b_ccpp + real(kind=kind_phys), dimension(:) , intent(out), optional :: spec_humid_sfc_veg_ccpp + real(kind=kind_phys), dimension(:) , intent(out), optional :: spec_humid_sfc_bare_ccpp ! ! --- some new options, hard code for now @@ -613,6 +618,8 @@ subroutine noahmpdrv_run & real (kind=kind_phys) :: leaf_air_resistance ! out | leaf boundary layer resistance [s/m] real (kind=kind_phys) :: canopy_heat_storage ! out | within-canopy heat [W/m2] + real (kind=kind_phys) :: spec_humid_sfc_veg ! out | surface specific humidty over vegetation [kg/kg] + real (kind=kind_phys) :: spec_humid_sfc_bare ! out | surface specific humidty over bare soil [kg/kg] real (kind=kind_phys) :: ustarx ! inout |surface friction velocity real (kind=kind_phys) :: prslkix ! in exner function @@ -997,11 +1004,12 @@ subroutine noahmpdrv_run & ch_vegetated_2m ,ch_bare_ground_2m ,precip_frozen_frac , & precip_adv_heat_veg ,precip_adv_heat_grd_v ,precip_adv_heat_grd_b , & precip_adv_heat_total ,snow_sublimation ,canopy_heat_storage , & + lai_sunlit ,lai_shaded ,leaf_air_resistance , & #ifdef CCPP - lai_sunlit ,lai_shaded ,leaf_air_resistance , & + spec_humid_sfc_veg ,spec_humid_sfc_bare , & errmsg ,errflg ) #else - lai_sunlit ,lai_shaded ,leaf_air_resistance ) + spec_humid_sfc_veg ,spec_humid_sfc_bare ) #endif #ifdef CCPP @@ -1129,6 +1137,8 @@ subroutine noahmpdrv_run & if(present(precip_adv_heat_veg_ccpp )) precip_adv_heat_veg_ccpp (i) = precip_adv_heat_veg if(present(precip_adv_heat_grd_v_ccpp)) precip_adv_heat_grd_v_ccpp(i) = precip_adv_heat_grd_v if(present(precip_adv_heat_grd_b_ccpp)) precip_adv_heat_grd_b_ccpp(i) = precip_adv_heat_grd_b + if(present(spec_humid_sfc_veg_ccpp )) spec_humid_sfc_veg_ccpp (i) = spec_humid_sfc_veg + if(present(spec_humid_sfc_bare_ccpp )) spec_humid_sfc_bare_ccpp (i) = spec_humid_sfc_bare wslakexy (i) = lake_water ! not active fwetxy (i) = canopy_wet_fraction From 7956ada51d49617acc7f1e03c0381dfafbf2ba25 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Tue, 18 Apr 2023 16:48:30 -0500 Subject: [PATCH 226/380] Turn off unneeded print statement --- physics/module_mp_nssl_2mom.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/module_mp_nssl_2mom.F90 b/physics/module_mp_nssl_2mom.F90 index f2f9707fb..cac1218a9 100644 --- a/physics/module_mp_nssl_2mom.F90 +++ b/physics/module_mp_nssl_2mom.F90 @@ -1326,7 +1326,7 @@ SUBROUTINE nssl_2mom_init( & - IF ( .false. ) THEN ! set to true to enable internal namelist read + IF ( .true. ) THEN ! set to true to enable internal namelist read open(15,file='input.nml',status='old',form='formatted',action='read') rewind(15) read(15,NML=nssl_mp_params,iostat=istat) @@ -1633,7 +1633,7 @@ SUBROUTINE nssl_2mom_init( & lccnuf = ltmp denscale(lccnuf) = 1 ENDIF - write(0,*) 'nsslwrf: lccnuf = ',lccnuf + lccn= ltmp+1 ! 9 lnc = ltmp+2 ! 10 lnr = ltmp+3 ! 11 From 6a15a0a6185f821e90448221c2cbc51b41f50ef4 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Wed, 19 Apr 2023 18:22:03 +0000 Subject: [PATCH 227/380] remove repeated constants --- physics/clm_lake.f90 | 24 ++++++++++++++++-------- physics/clm_lake.meta | 16 ++++++++++++++++ physics/sfc_diff.f | 2 -- physics/sfc_diff.meta | 7 ------- 4 files changed, 32 insertions(+), 17 deletions(-) diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90 index 4e44c921a..c206b9af0 100644 --- a/physics/clm_lake.f90 +++ b/physics/clm_lake.f90 @@ -99,6 +99,9 @@ MODULE clm_lake real(kind_lake) :: invhsub !1/hsub [kg/J] real(kind_lake) :: rair !gas constant for dry air [J/kg/K] real(kind_lake) :: cpair !specific heat of dry air [J/kg/K] + real(kind_lake) :: con_eps !ratio of gas constants of air and water vapor [unitless] + real(kind_lake) :: one_minus_con_eps !1 - con_eps [unitless] + real(kind_lake) :: con_fvirt !1/con_eps - 1 [unitless] real(kind_lake), public, parameter :: spval = 1.e36 !special value for missing data (ocean) real(kind_lake), parameter :: depth_c = 50. !below the level t_lake3d will be 277.0 !mchen @@ -1159,8 +1162,8 @@ SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, !dir$ concurrent !cdir nodep forc_th(1) = forc_t(1) * (forc_psrf(1)/ forc_pbot(1))**(rair/cpair) - forc_vp(1) = forc_q(1) * forc_pbot(1)/ (0.622 + 0.378 * forc_q(1)) - forc_rho(1) = (forc_pbot(1) - 0.378 * forc_vp(1)) / (rair * forc_t(1)) + forc_vp(1) = forc_q(1) * forc_pbot(1)/ (con_eps + one_minus_con_eps * forc_q(1)) + forc_rho(1) = (forc_pbot(1) - one_minus_con_eps * forc_vp(1)) / (rair * forc_t(1)) do fc = 1, num_shlakec c = filter_shlakec(fc) @@ -1199,7 +1202,7 @@ SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, ! reference height thm(c) = forc_t(g) + 0.0098_kind_lake*forc_hgt_t(g) ! intermediate variable - thv(c) = forc_th(g)*(1._kind_lake+0.61_kind_lake*forc_q(g)) ! virtual potential T + thv(c) = forc_th(g)*(1._kind_lake+con_fvirt*forc_q(g)) ! virtual potential T end do !dir$ concurrent @@ -1278,7 +1281,7 @@ SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, ur(p) = max(1.0_kind_lake,sqrt(forc_u(g)*forc_u(g)+forc_v(g)*forc_v(g))) dth(p) = thm(c)-t_grnd(c) dqh(p) = forc_q(g)-qsatg(c) - dthv = dth(p)*(1._kind_lake+0.61_kind_lake*forc_q(g))+0.61_kind_lake*forc_th(g)*dqh(p) + dthv = dth(p)*(1._kind_lake+con_fvirt*forc_q(g))+con_fvirt*forc_th(g)*dqh(p) zldis(p) = forc_hgt_u(g) - 0._kind_lake ! Initialize Monin-Obukhov length and wind speed @@ -1380,7 +1383,7 @@ SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, tstar = temp1(p)*dth(p) qstar = temp2(p)*dqh(p) - thvstar=tstar*(1._kind_lake+0.61_kind_lake*forc_q(g)) + 0.61_kind_lake*forc_th(g)*qstar + thvstar=tstar*(1._kind_lake+con_fvirt*forc_q(g)) + con_fvirt*forc_th(g)*qstar zeta=zldis(p)*vkc * grav*thvstar/(ustar(p)**2*thv(c)) if (zeta >= 0._kind_lake) then !stable @@ -3742,7 +3745,7 @@ subroutine QSat (T, p, es, esdT, qs, qsdT) es = es * 100. ! pa esdT = esdT * 100. ! pa/K - vp = 1.0 / (p - 0.378*es) + vp = 1.0 / (p - one_minus_con_eps*es) vp1 = 0.622 * vp vp2 = vp1 * vp @@ -5133,10 +5136,12 @@ end subroutine MoninObukIni !! \htmlinclude clm_lake_init.html !! subroutine clm_lake_init(con_pi,karman,con_g,con_sbc,con_t0c,rhowater,con_csol,con_cliq, & - con_hfus,con_hvap,con_rd,con_cp,rholakeice,clm_lake_debug,errmsg,errflg) + con_hfus,con_hvap,con_rd,con_cp,rholakeice,clm_lake_debug, & + con_eps_model,con_fvirt_model,errmsg,errflg) implicit none real(kind_phys), intent(in) :: con_pi,karman,con_g,con_sbc,con_t0c, & - rhowater,con_csol,con_cliq, con_hfus,con_hvap,con_rd,con_cp,rholakeice + rhowater,con_csol,con_cliq, con_hfus,con_hvap,con_rd,con_cp, & + rholakeice,con_eps_model,con_fvirt_model INTEGER, INTENT(OUT) :: errflg CHARACTER(*), INTENT(OUT) :: errmsg logical, intent(in) :: clm_lake_debug @@ -5166,6 +5171,9 @@ subroutine clm_lake_init(con_pi,karman,con_g,con_sbc,con_t0c,rhowater,con_csol,c invhsub = 1._kind_lake/hsub rair = con_rd cpair = con_cp + con_eps = con_eps_model + con_fvirt = con_fvirt_model + one_minus_con_eps = 1.0_kind_lake - con_eps ! dzlak(1) = 0.1_kind_lake ! dzlak(2) = 1._kind_lake diff --git a/physics/clm_lake.meta b/physics/clm_lake.meta index 035787aff..bbaaded16 100644 --- a/physics/clm_lake.meta +++ b/physics/clm_lake.meta @@ -895,6 +895,22 @@ type = real kind = kind_phys intent = in +[con_eps_model] + standard_name = ratio_of_dry_air_to_water_vapor_gas_constants + long_name = rd/rv + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[con_fvirt_model] + standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one + long_name = (rv/rd) - 1 (rv = ideal gas constant for water vapor) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in [con_cp] standard_name = specific_heat_of_dry_air_at_constant_pressure long_name = specific heat of dry air at constant pressure diff --git a/physics/sfc_diff.f b/physics/sfc_diff.f index 0ca7ced16..6e834537a 100644 --- a/physics/sfc_diff.f +++ b/physics/sfc_diff.f @@ -78,7 +78,6 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) & fh2_wat, fh2_lnd, fh2_ice, & !intent(inout) & ztmax_wat, ztmax_lnd, ztmax_ice, & !intent(inout) & zvfun, & !intent(out) - & use_lake_model, & !intent(in) & errmsg, errflg) !intent(out) ! implicit none @@ -88,7 +87,6 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) integer, intent(in) :: sfc_z0_type ! option for calculating surface roughness length over ocean integer, dimension(:), intent(in) :: vegtype - integer, dimension(:), intent(in) :: use_lake_model logical, intent(in) :: redrag ! reduced drag coeff. flag for high wind over sea (j.han) logical, dimension(:), intent(in) :: flag_iter, dry, icy diff --git a/physics/sfc_diff.meta b/physics/sfc_diff.meta index e0fedfa45..eb30b8c50 100644 --- a/physics/sfc_diff.meta +++ b/physics/sfc_diff.meta @@ -565,13 +565,6 @@ type = real kind = kind_phys intent = inout -[use_lake_model] - standard_name = flag_for_using_lake_model - long_name = flag indicating lake points using a lake model - units = flag - dimensions = (horizontal_loop_extent) - type = integer - intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 783af0ef9ad228f0710d26d4a461f34731c7c280 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Wed, 19 Apr 2023 18:22:03 +0000 Subject: [PATCH 228/380] remove repeated constants and redundant variable --- physics/clm_lake.f90 | 24 ++++++++++++++++-------- physics/clm_lake.meta | 16 ++++++++++++++++ physics/sfc_diff.f | 2 -- physics/sfc_diff.meta | 7 ------- 4 files changed, 32 insertions(+), 17 deletions(-) diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90 index 4e44c921a..c206b9af0 100644 --- a/physics/clm_lake.f90 +++ b/physics/clm_lake.f90 @@ -99,6 +99,9 @@ MODULE clm_lake real(kind_lake) :: invhsub !1/hsub [kg/J] real(kind_lake) :: rair !gas constant for dry air [J/kg/K] real(kind_lake) :: cpair !specific heat of dry air [J/kg/K] + real(kind_lake) :: con_eps !ratio of gas constants of air and water vapor [unitless] + real(kind_lake) :: one_minus_con_eps !1 - con_eps [unitless] + real(kind_lake) :: con_fvirt !1/con_eps - 1 [unitless] real(kind_lake), public, parameter :: spval = 1.e36 !special value for missing data (ocean) real(kind_lake), parameter :: depth_c = 50. !below the level t_lake3d will be 277.0 !mchen @@ -1159,8 +1162,8 @@ SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, !dir$ concurrent !cdir nodep forc_th(1) = forc_t(1) * (forc_psrf(1)/ forc_pbot(1))**(rair/cpair) - forc_vp(1) = forc_q(1) * forc_pbot(1)/ (0.622 + 0.378 * forc_q(1)) - forc_rho(1) = (forc_pbot(1) - 0.378 * forc_vp(1)) / (rair * forc_t(1)) + forc_vp(1) = forc_q(1) * forc_pbot(1)/ (con_eps + one_minus_con_eps * forc_q(1)) + forc_rho(1) = (forc_pbot(1) - one_minus_con_eps * forc_vp(1)) / (rair * forc_t(1)) do fc = 1, num_shlakec c = filter_shlakec(fc) @@ -1199,7 +1202,7 @@ SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, ! reference height thm(c) = forc_t(g) + 0.0098_kind_lake*forc_hgt_t(g) ! intermediate variable - thv(c) = forc_th(g)*(1._kind_lake+0.61_kind_lake*forc_q(g)) ! virtual potential T + thv(c) = forc_th(g)*(1._kind_lake+con_fvirt*forc_q(g)) ! virtual potential T end do !dir$ concurrent @@ -1278,7 +1281,7 @@ SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, ur(p) = max(1.0_kind_lake,sqrt(forc_u(g)*forc_u(g)+forc_v(g)*forc_v(g))) dth(p) = thm(c)-t_grnd(c) dqh(p) = forc_q(g)-qsatg(c) - dthv = dth(p)*(1._kind_lake+0.61_kind_lake*forc_q(g))+0.61_kind_lake*forc_th(g)*dqh(p) + dthv = dth(p)*(1._kind_lake+con_fvirt*forc_q(g))+con_fvirt*forc_th(g)*dqh(p) zldis(p) = forc_hgt_u(g) - 0._kind_lake ! Initialize Monin-Obukhov length and wind speed @@ -1380,7 +1383,7 @@ SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, tstar = temp1(p)*dth(p) qstar = temp2(p)*dqh(p) - thvstar=tstar*(1._kind_lake+0.61_kind_lake*forc_q(g)) + 0.61_kind_lake*forc_th(g)*qstar + thvstar=tstar*(1._kind_lake+con_fvirt*forc_q(g)) + con_fvirt*forc_th(g)*qstar zeta=zldis(p)*vkc * grav*thvstar/(ustar(p)**2*thv(c)) if (zeta >= 0._kind_lake) then !stable @@ -3742,7 +3745,7 @@ subroutine QSat (T, p, es, esdT, qs, qsdT) es = es * 100. ! pa esdT = esdT * 100. ! pa/K - vp = 1.0 / (p - 0.378*es) + vp = 1.0 / (p - one_minus_con_eps*es) vp1 = 0.622 * vp vp2 = vp1 * vp @@ -5133,10 +5136,12 @@ end subroutine MoninObukIni !! \htmlinclude clm_lake_init.html !! subroutine clm_lake_init(con_pi,karman,con_g,con_sbc,con_t0c,rhowater,con_csol,con_cliq, & - con_hfus,con_hvap,con_rd,con_cp,rholakeice,clm_lake_debug,errmsg,errflg) + con_hfus,con_hvap,con_rd,con_cp,rholakeice,clm_lake_debug, & + con_eps_model,con_fvirt_model,errmsg,errflg) implicit none real(kind_phys), intent(in) :: con_pi,karman,con_g,con_sbc,con_t0c, & - rhowater,con_csol,con_cliq, con_hfus,con_hvap,con_rd,con_cp,rholakeice + rhowater,con_csol,con_cliq, con_hfus,con_hvap,con_rd,con_cp, & + rholakeice,con_eps_model,con_fvirt_model INTEGER, INTENT(OUT) :: errflg CHARACTER(*), INTENT(OUT) :: errmsg logical, intent(in) :: clm_lake_debug @@ -5166,6 +5171,9 @@ subroutine clm_lake_init(con_pi,karman,con_g,con_sbc,con_t0c,rhowater,con_csol,c invhsub = 1._kind_lake/hsub rair = con_rd cpair = con_cp + con_eps = con_eps_model + con_fvirt = con_fvirt_model + one_minus_con_eps = 1.0_kind_lake - con_eps ! dzlak(1) = 0.1_kind_lake ! dzlak(2) = 1._kind_lake diff --git a/physics/clm_lake.meta b/physics/clm_lake.meta index 035787aff..bbaaded16 100644 --- a/physics/clm_lake.meta +++ b/physics/clm_lake.meta @@ -895,6 +895,22 @@ type = real kind = kind_phys intent = in +[con_eps_model] + standard_name = ratio_of_dry_air_to_water_vapor_gas_constants + long_name = rd/rv + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[con_fvirt_model] + standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one + long_name = (rv/rd) - 1 (rv = ideal gas constant for water vapor) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in [con_cp] standard_name = specific_heat_of_dry_air_at_constant_pressure long_name = specific heat of dry air at constant pressure diff --git a/physics/sfc_diff.f b/physics/sfc_diff.f index 0ca7ced16..6e834537a 100644 --- a/physics/sfc_diff.f +++ b/physics/sfc_diff.f @@ -78,7 +78,6 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) & fh2_wat, fh2_lnd, fh2_ice, & !intent(inout) & ztmax_wat, ztmax_lnd, ztmax_ice, & !intent(inout) & zvfun, & !intent(out) - & use_lake_model, & !intent(in) & errmsg, errflg) !intent(out) ! implicit none @@ -88,7 +87,6 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) integer, intent(in) :: sfc_z0_type ! option for calculating surface roughness length over ocean integer, dimension(:), intent(in) :: vegtype - integer, dimension(:), intent(in) :: use_lake_model logical, intent(in) :: redrag ! reduced drag coeff. flag for high wind over sea (j.han) logical, dimension(:), intent(in) :: flag_iter, dry, icy diff --git a/physics/sfc_diff.meta b/physics/sfc_diff.meta index e0fedfa45..eb30b8c50 100644 --- a/physics/sfc_diff.meta +++ b/physics/sfc_diff.meta @@ -565,13 +565,6 @@ type = real kind = kind_phys intent = inout -[use_lake_model] - standard_name = flag_for_using_lake_model - long_name = flag indicating lake points using a lake model - units = flag - dimensions = (horizontal_loop_extent) - type = integer - intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 3929f9fe32d74e427a400041d1347466442177b5 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Wed, 19 Apr 2023 18:25:46 +0000 Subject: [PATCH 229/380] remove redundant .not.have_2m in sfc_diag.f --- physics/sfc_diag.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/sfc_diag.f b/physics/sfc_diag.f index 60917553f..768814e8c 100644 --- a/physics/sfc_diag.f +++ b/physics/sfc_diag.f @@ -149,7 +149,7 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & q2m(i) = qsurf(i)*wrk + max(qmin,q1c)*fhi endif ! flux method - if(.not. have_2m .and. diag_log) then + if(diag_log) then !-- Alternative logarithmic diagnostics: dT = t1(i) - tskin(i) dQ = qv1 - qsfcmr From 37dd7a570178904dd0032a655ae20ec23dadb361 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Wed, 19 Apr 2023 18:29:19 +0000 Subject: [PATCH 230/380] explain why kind_lake exists --- physics/clm_lake.f90 | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90 index c206b9af0..4fc4112ce 100644 --- a/physics/clm_lake.f90 +++ b/physics/clm_lake.f90 @@ -35,6 +35,10 @@ MODULE clm_lake public :: clm_lake_run, clm_lake_init, LAKEDEBUG + ! In WRF, the CLM Lake Model was hard-coded to use double precision, regardless of + ! precision of physics. For that reason, we retain double precision here. However, + ! we're not yet certain that all of CLM Lake needs to be double precision, so we + ! maintain a "kind_lake" to allow future experimentation in datatypes. integer, parameter, public :: kind_lake = kind_dbl_prec logical :: LAKEDEBUG = .false. ! Enable lots of checks and debug prints and errors From 8f2078ccbd85a47d81d1157e03db6c320bfbf7ac Mon Sep 17 00:00:00 2001 From: Zhichang Guo Date: Wed, 19 Apr 2023 18:57:48 +0000 Subject: [PATCH 231/380] include wet leaf contribution factor --- physics/module_sf_noahmplsm.F90 | 30 ++++++++++++++++++++---------- physics/rte-rrtmgp | 2 +- 2 files changed, 21 insertions(+), 11 deletions(-) diff --git a/physics/module_sf_noahmplsm.F90 b/physics/module_sf_noahmplsm.F90 index db653c548..4fe616a13 100644 --- a/physics/module_sf_noahmplsm.F90 +++ b/physics/module_sf_noahmplsm.F90 @@ -3928,6 +3928,10 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys) :: t, tdc !kelvin to degree celsius with limit -50 to +50 +! local variables + real(kind=kind_phys) :: cvw ! 0. .and. fwet > 0.) then + if (tv > tfrz) then + wlcf = min(fwet,canliq*latheav/dt/evpot) + else + wlcf = min(fwet,canice*latheav/dt/evpot) + endif + else + wlcf= fwet + endif + cvw = wlcf*cvw ctw = (1.-fwet)*(laisune/(rb+rssun) + laishae/(rb+rssha)) cgw = 1./(rawg+rsurf) - cond = caw + cew + ctw + cgw + cond = caw + cvw + ctw + cgw aea = (eair*caw + estg*cgw) / cond - bea = (cew+ctw)/cond - cev = (1.-bea)*cew*rhoair*cpair/gammav ! barlage: change to vegetation v3.6 + bea = (cvw+ctw)/cond + cev = (1.-bea)*cvw*rhoair*cpair/gammav ! barlage: change to vegetation v3.6 ctr = (1.-bea)*ctw*rhoair*cpair/gammav ! evaluate surface fluxes with current temperature and solve for dts @@ -4195,13 +4210,8 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & irc = fveg*(air + cir*tv**4) shc = fveg*rhoair*cpair*cvh * ( tv-tah) - evc = fveg*rhoair*cpair*cew * (estv-eah) / gammav ! barlage: change to v in v3.6 + evc = fveg*rhoair*cpair*cvw * (estv-eah) / gammav ! barlage: change to v in v3.6 tr = fveg*rhoair*cpair*ctw * (estv-eah) / gammav - if (tv > tfrz) then - evc = min(canliq*latheav/dt,evc) ! barlage: add if block for canice in v3.6 - else - evc = min(canice*latheav/dt,evc) - end if ! canopy heat capacity hcv = 0.02*vaie*cwat + canliq*cwat/denh2o + canice*cice/denice !j/m2/k diff --git a/physics/rte-rrtmgp b/physics/rte-rrtmgp index 0dc54f5ec..7f01618c9 160000 --- a/physics/rte-rrtmgp +++ b/physics/rte-rrtmgp @@ -1 +1 @@ -Subproject commit 0dc54f5ecaeb1e1e342efd1e02d0bcd41737bde2 +Subproject commit 7f01618c92409658bddd3afa9acb004c608f6a0d From 5edc13128252db440dea9f31c797499bc302e85a Mon Sep 17 00:00:00 2001 From: Zhichang Guo Date: Wed, 19 Apr 2023 19:33:42 +0000 Subject: [PATCH 232/380] include wet leaf contribution factor --- physics/module_sf_noahmplsm.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/module_sf_noahmplsm.F90 b/physics/module_sf_noahmplsm.F90 index 4fe616a13..a460e8426 100644 --- a/physics/module_sf_noahmplsm.F90 +++ b/physics/module_sf_noahmplsm.F90 @@ -4194,7 +4194,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & else wlcf= fwet endif - cvw = wlcf*cvw + cvw = wlcf*cew ctw = (1.-fwet)*(laisune/(rb+rssun) + laishae/(rb+rssha)) cgw = 1./(rawg+rsurf) cond = caw + cvw + ctw + cgw From c1ce88b1ecef8879cf225be82f121b1c7d6275f1 Mon Sep 17 00:00:00 2001 From: Michael Barlage Date: Thu, 20 Apr 2023 11:40:44 -0400 Subject: [PATCH 233/380] remove cvw and wlcf --- physics/module_sf_noahmplsm.F90 | 21 ++++++++------------- physics/rte-rrtmgp | 2 +- 2 files changed, 9 insertions(+), 14 deletions(-) diff --git a/physics/module_sf_noahmplsm.F90 b/physics/module_sf_noahmplsm.F90 index a460e8426..0473b43f9 100644 --- a/physics/module_sf_noahmplsm.F90 +++ b/physics/module_sf_noahmplsm.F90 @@ -3928,10 +3928,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real (kind=kind_phys) :: t, tdc !kelvin to degree celsius with limit -50 to +50 -! local variables - real(kind=kind_phys) :: cvw ! 0. .and. fwet > 0.) then if (tv > tfrz) then - wlcf = min(fwet,canliq*latheav/dt/evpot) + cew = min(fwet,canliq*latheav/dt/evpot) * vaie/rb else - wlcf = min(fwet,canice*latheav/dt/evpot) + cew = min(fwet,canice*latheav/dt/evpot) * vaie/rb endif else - wlcf= fwet + cew= fwet * vaie/rb endif - cvw = wlcf*cew ctw = (1.-fwet)*(laisune/(rb+rssun) + laishae/(rb+rssha)) cgw = 1./(rawg+rsurf) - cond = caw + cvw + ctw + cgw + cond = caw + cew + ctw + cgw aea = (eair*caw + estg*cgw) / cond - bea = (cvw+ctw)/cond - cev = (1.-bea)*cvw*rhoair*cpair/gammav ! barlage: change to vegetation v3.6 + bea = (cew+ctw)/cond + cev = (1.-bea)*cew*rhoair*cpair/gammav ! barlage: change to vegetation v3.6 ctr = (1.-bea)*ctw*rhoair*cpair/gammav ! evaluate surface fluxes with current temperature and solve for dts @@ -4210,7 +4205,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & irc = fveg*(air + cir*tv**4) shc = fveg*rhoair*cpair*cvh * ( tv-tah) - evc = fveg*rhoair*cpair*cvw * (estv-eah) / gammav ! barlage: change to v in v3.6 + evc = fveg*rhoair*cpair*cew * (estv-eah) / gammav ! barlage: change to v in v3.6 tr = fveg*rhoair*cpair*ctw * (estv-eah) / gammav ! canopy heat capacity diff --git a/physics/rte-rrtmgp b/physics/rte-rrtmgp index 7f01618c9..0dc54f5ec 160000 --- a/physics/rte-rrtmgp +++ b/physics/rte-rrtmgp @@ -1 +1 @@ -Subproject commit 7f01618c92409658bddd3afa9acb004c608f6a0d +Subproject commit 0dc54f5ecaeb1e1e342efd1e02d0bcd41737bde2 From 6b9c79a09583c9115cbfdeacd364fa6c6536ae3b Mon Sep 17 00:00:00 2001 From: Michael Barlage Date: Thu, 20 Apr 2023 11:48:52 -0400 Subject: [PATCH 234/380] add back second check --- physics/module_sf_noahmplsm.F90 | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/physics/module_sf_noahmplsm.F90 b/physics/module_sf_noahmplsm.F90 index 0473b43f9..ef6f99c44 100644 --- a/physics/module_sf_noahmplsm.F90 +++ b/physics/module_sf_noahmplsm.F90 @@ -4207,6 +4207,11 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & shc = fveg*rhoair*cpair*cvh * ( tv-tah) evc = fveg*rhoair*cpair*cew * (estv-eah) / gammav ! barlage: change to v in v3.6 tr = fveg*rhoair*cpair*ctw * (estv-eah) / gammav + if (tv > tfrz) then + evc = min(canliq*latheav/dt,evc) ! barlage: add if block for canice in v3.6 + else + evc = min(canice*latheav/dt,evc) + end if ! canopy heat capacity hcv = 0.02*vaie*cwat + canliq*cwat/denh2o + canice*cice/denice !j/m2/k From 109d7f36e7bcd46de4d0306d24adaf012238438d Mon Sep 17 00:00:00 2001 From: Qingfu Liu Date: Fri, 21 Apr 2023 13:42:59 -0400 Subject: [PATCH 235/380] PBL and Convection update for HR2 --- physics/mfpbltq.f | 43 ++++++--- physics/mfscuq.f | 43 ++++++--- physics/samfdeepcnv.f | 110 +++++++++++++++-------- physics/samfshalcnv.f | 73 ++++++++++----- physics/satmedmfvdifq.F | 176 ++++++++++++++++++++++--------------- physics/satmedmfvdifq.meta | 8 ++ 6 files changed, 298 insertions(+), 155 deletions(-) diff --git a/physics/mfpbltq.f b/physics/mfpbltq.f index fb775e2e1..a93862a41 100644 --- a/physics/mfpbltq.f +++ b/physics/mfpbltq.f @@ -11,7 +11,7 @@ module mfpbltq_mod !> @{ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, & cnvflg,zl,zm,q1,t1,u1,v1,plyr,pix,thlx,thvx, - & gdx,hpbl,kpbl,vpert,buo,xmf, + & gdx,hpbl,kpbl,vpert,buo,wush,tkemean,vez0fun,xmf, & tcko,qcko,ucko,vcko,xlamueq,a1) ! use machine , only : kind_phys @@ -33,7 +33,8 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, & plyr(im,km),pix(im,km),thlx(im,km), & thvx(im,km),zl(im,km), zm(im,km), & gdx(im), hpbl(im), vpert(im), - & buo(im,km), xmf(im,km), + & buo(im,km), wush(im,km), + & tkemean(im),vez0fun(im),xmf(im,km), & tcko(im,km),qcko(im,km,ntrac1), & ucko(im,km),vcko(im,km), & xlamueq(im,km-1) @@ -44,8 +45,8 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, integer kpblx(im), kpbly(im) ! real(kind=kind_phys) dt2, dz, ce0, - & cm, cq, - & factor, gocp, + & cm, cq, tkcrt, + & factor, gocp, cmxfac, & g, b1, f1, & bb1, bb2, & alp, vpertmax,a1, pgcon, @@ -59,7 +60,7 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, ! real(kind=kind_phys) rbdn(im), rbup(im), hpblx(im), & xlamue(im,km-1), xlamuem(im,km-1) - real(kind=kind_phys) delz(im), xlamax(im) + real(kind=kind_phys) delz(im), xlamax(im), ce0t(im) ! real(kind=kind_phys) wu2(im,km), thlu(im,km), & qtx(im,km), qtu(im,km) @@ -73,7 +74,7 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, parameter(g=grav) parameter(gocp=g/cp) parameter(elocp=hvap/cp,el2orc=hvap*hvap/(rv*cp)) - parameter(ce0=0.4,cm=1.0,cq=1.3) + parameter(ce0=0.4,cm=1.0,cq=1.0,tkcrt=2.,cmxfac=5.) parameter(qmin=1.e-8,qlmin=1.e-12) parameter(alp=1.5,vpertmax=3.0,pgcon=0.55) parameter(b1=0.5,f1=0.15) @@ -112,13 +113,27 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, enddo ! !> - Compute entrainment rate +! +! if tkemean>tkcrt, ce0t=sqrt(tkemean/tkcrt)*ce0 +! + do i=1,im + if(cnvflg(i)) then + ce0t(i) = ce0 * vez0fun(i) + if(tkemean(i) > tkcrt) then + tem = sqrt(tkemean(i)/tkcrt) + tem1 = min(tem, cmxfac) + tem2 = tem1 * ce0 + ce0t(i) = max(ce0t(i), tem2) + endif + endif + enddo ! do i=1,im if(cnvflg(i)) then k = kpbl(i) / 2 k = max(k, 1) delz(i) = zl(i,k+1) - zl(i,k) - xlamax(i) = ce0 / delz(i) + xlamax(i) = ce0t(i) / delz(i) endif enddo ! @@ -129,7 +144,7 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, ptem = 1./(zm(i,k)+delz(i)) tem = max((hpbl(i)-zm(i,k)+delz(i)) ,delz(i)) ptem1 = 1./tem - xlamue(i,k) = ce0 * (ptem+ptem1) + xlamue(i,k) = ce0t(i) * (ptem+ptem1) else xlamue(i,k) = xlamax(i) endif @@ -210,11 +225,13 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, do i = 1, im if(cnvflg(i)) then dz = zm(i,k) - zm(i,k-1) - tem = 0.25*bb1*(xlamue(i,k)+xlamue(i,k-1))*dz - tem1 = bb2 * buo(i,k) * dz + tem = 0.25*bb1*(xlamue(i,k-1)+xlamue(i,k))*dz + tem1 = max(wu2(i,k-1), 0.) + tem1 = bb2 * buo(i,k) - wush(i,k) * sqrt(tem1) + tem2 = tem1 * dz ptem = (1. - tem) * wu2(i,k-1) ptem1 = 1. + tem - wu2(i,k) = (ptem + tem1) / ptem1 + wu2(i,k) = (ptem + tem2) / ptem1 endif enddo enddo @@ -271,7 +288,7 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, k = kpbl(i) / 2 k = max(k, 1) delz(i) = zl(i,k+1) - zl(i,k) - xlamax(i) = ce0 / delz(i) + xlamax(i) = ce0t(i) / delz(i) endif enddo ! @@ -283,7 +300,7 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, ptem = 1./(zm(i,k)+delz(i)) tem = max((hpbl(i)-zm(i,k)+delz(i)) ,delz(i)) ptem1 = 1./tem - xlamue(i,k) = ce0 * (ptem+ptem1) + xlamue(i,k) = ce0t(i) * (ptem+ptem1) else xlamue(i,k) = xlamax(i) endif diff --git a/physics/mfscuq.f b/physics/mfscuq.f index cafa61b55..d690dce05 100644 --- a/physics/mfscuq.f +++ b/physics/mfscuq.f @@ -12,7 +12,7 @@ module mfscuq_mod subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, & cnvflg,zl,zm,q1,t1,u1,v1,plyr,pix, & thlx,thvx,thlvx,gdx,thetae, - & krad,mrad,radmin,buo,xmfd, + & krad,mrad,radmin,buo,wush,tkemean,vez0fun,xmfd, & tcdo,qcdo,ucdo,vcdo,xlamdeq,a1) ! use machine , only : kind_phys @@ -38,9 +38,10 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, & gdx(im), & zl(im,km), zm(im,km), & thetae(im,km), radmin(im), - & buo(im,km), xmfd(im,km), - & tcdo(im,km), qcdo(im,km,ntrac1), - & ucdo(im,km), vcdo(im,km), + & buo(im,km), wush(im,km), + & tkemean(im),vez0fun(im),xmfd(im,km), + & tcdo(im,km),qcdo(im,km,ntrac1), + & ucdo(im,km),vcdo(im,km), & xlamdeq(im,km-1) ! ! local variables and arrays @@ -51,6 +52,7 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, ! real(kind=kind_phys) dt2, dz, ce0, & cm, cq, + & tkcrt, cmxfac, & gocp, factor, g, tau, & b1, f1, bb1, bb2, & a1, a2, @@ -67,7 +69,7 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, & qtx(im,km), qtd(im,km), & thlvd(im), hrad(im), xlamde(im,km-1), & xlamdem(im,km-1), ra1(im) - real(kind=kind_phys) delz(im), xlamax(im) + real(kind=kind_phys) delz(im), xlamax(im), ce0t(im) ! real(kind=kind_phys) xlamavg(im), sigma(im), & scaldfunc(im), sumx(im) @@ -80,7 +82,8 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, parameter(g=grav) parameter(gocp=g/cp) parameter(elocp=hvap/cp,el2orc=hvap*hvap/(rv*cp)) - parameter(ce0=0.4,cm=1.0,cq=1.3,pgcon=0.55) + parameter(ce0=0.4,cm=1.0,cq=1.0,pgcon=0.55) + parameter(tkcrt=2.,cmxfac=5.) parameter(qmin=1.e-8,qlmin=1.e-12) parameter(b1=0.45,f1=0.15) parameter(a2=0.5) @@ -185,13 +188,27 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, !! ! !> - Compute entrainment rate +! +! if tkemean>tkcrt, ce0t=sqrt(tkemean/tkcrt)*ce0 +! + do i=1,im + if(cnvflg(i)) then + ce0t(i) = ce0 * vez0fun(i) + if(tkemean(i) > tkcrt) then + tem = sqrt(tkemean(i)/tkcrt) + tem1 = min(tem, cmxfac) + tem2 = tem1 * ce0 + ce0t(i) = max(ce0t(i), tem2) + endif + endif + enddo ! do i=1,im if(cnvflg(i)) then k = mrad(i) + (krad(i)-mrad(i)) / 2 k = max(k, mrad(i)) delz(i) = zl(i,k+1) - zl(i,k) - xlamax(i) = ce0 / delz(i) + xlamax(i) = ce0t(i) / delz(i) endif enddo ! @@ -206,7 +223,7 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, endif tem = max((hrad(i)-zm(i,k)+delz(i)) ,delz(i)) ptem1 = 1./tem - xlamde(i,k) = ce0 * (ptem+ptem1) + xlamde(i,k) = ce0t(i) * (ptem+ptem1) else xlamde(i,k) = xlamax(i) endif @@ -289,10 +306,12 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, if(cnvflg(i) .and. k < krad1(i)) then dz = zm(i,k+1) - zm(i,k) tem = 0.25*bb1*(xlamde(i,k)+xlamde(i,k+1))*dz - tem1 = bb2 * buo(i,k+1) * dz + tem1 = max(wd2(i,k+1), 0.) + tem1 = bb2*buo(i,k+1) - wush(i,k+1)*sqrt(tem1) + tem2 = tem1 * dz ptem = (1. - tem) * wd2(i,k+1) ptem1 = 1. + tem - wd2(i,k) = (ptem + tem1) / ptem1 + wd2(i,k) = (ptem + tem2) / ptem1 endif enddo enddo @@ -334,7 +353,7 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, k = mrad(i) + (krad(i)-mrad(i)) / 2 k = max(k, mrad(i)) delz(i) = zl(i,k+1) - zl(i,k) - xlamax(i) = ce0 / delz(i) + xlamax(i) = ce0t(i) / delz(i) endif enddo ! @@ -349,7 +368,7 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, endif tem = max((hrad(i)-zm(i,k)+delz(i)) ,delz(i)) ptem1 = 1./tem - xlamde(i,k) = ce0 * (ptem+ptem1) + xlamde(i,k) = ce0t(i) * (ptem+ptem1) else xlamde(i,k) = xlamax(i) endif diff --git a/physics/samfdeepcnv.f b/physics/samfdeepcnv.f index 0d4f9fd0f..b8d564728 100644 --- a/physics/samfdeepcnv.f +++ b/physics/samfdeepcnv.f @@ -191,7 +191,9 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & & pwavo(im), pwevo(im), mbdt(im), & qcdo(im,km), qcond(im), qevap(im), & rntot(im), vshear(im), xaa0(im), - & xlamd(im), xk(im), cina(im), + & xlamd(im), xlamdet(im),xlamddt(im), + & cxlamet(im), cxlamdt(im), + & xk(im), cina(im), & xmb(im), xmbmax(im), xpwav(im), & xpwev(im), xlamx(im), delebar(im,ntr), ! & xpwev(im), delebar(im,ntr), @@ -201,13 +203,12 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & cj real(kind=kind_phys) cinpcr, cinpcrmx, cinpcrmn, & cinacr, cinacrmx, cinacrmn, - & sfclfac, rhcrt + & sfclfac, rhcrt, + & tkcrt, cmxfac cj ! ! parameters for updraft velocity calculation - real(kind=kind_phys) bet1, cd1, f1, gam1, -! & bb1, bb2 - & bb1, bb2, wucb + real(kind=kind_phys) bb1, bb2, csmf, wucb ! ! parameters for prognostic sigma closure real(kind=kind_phys) omega_u(im,km),zdqca(im,km),tmfq(im,km), @@ -229,7 +230,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & ! Until a realistic Nccn is provided, Nccns are assumed ! as Nccn=100 for sea and Nccn=1000 for land ! - parameter(cm=1.0,cq=1.3) + parameter(cm=1.0,cq=1.0) ! parameter(fact1=(cvap-cliq)/rv,fact2=hvap/rv-fact1*t0c) parameter(clamd=0.03,tkemx=0.65,tkemn=0.05) parameter(clamca=0.03) @@ -238,7 +239,8 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & parameter(cinpcrmx=180.,cinpcrmn=120.) ! parameter(cinacrmx=-120.,cinacrmn=-120.) parameter(cinacrmx=-120.,cinacrmn=-80.) - parameter(bet1=1.875,cd1=.506,f1=2.0,gam1=.5) + parameter(bb1=4.0,bb2=0.8,csmf=0.2) + parameter(tkcrt=2.,cmxfac=15.) parameter(betaw=.03) ! @@ -254,7 +256,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & ! ! for updraft velocity calculation real(kind=kind_phys) wu2(im,km), buo(im,km), drag(im,km), - & wc(im) + & wush(im,km), wc(im) ! ! for updraft fraction & scale-aware function real(kind=kind_phys) scaldfunc(im), sigmagfm(im) @@ -577,6 +579,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & ! vo(i,k) = v1(i,k) * rcs(i) wu2(i,k) = 0. buo(i,k) = 0. + wush(i,k) = 0. drag(i,k) = 0. cnvwt(i,k)= 0. endif @@ -805,7 +808,8 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & ptem1= .5*(cinpcrmx-cinpcrmn) cinpcr = cinpcrmx - ptem * ptem1 tem1 = pfld(i,kb(i)) - pfld(i,kbcon(i)) - if(tem1 > cinpcr) then + if(tem1 > cinpcr .and. + & zi(i,kbcon(i)) > hpbl(i)) then cnvflg(i) = .false. endif endif @@ -975,7 +979,29 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & endif enddo endif - +! +! if tkemean>tkcrt, tem=1+tkemean/tkcrt, clamt=tem*clam +! xlamdet=tem*xlamde, xlamddt=tem*xlamdd +! cxlamet=tem*cxlame, cxlamdt=tem*cxlamd +! + do i=1,im + if(cnvflg(i)) then + xlamdet(i) = xlamde + xlamddt(i) = xlamdd + cxlamet(i) = cxlame + cxlamdt(i) = cxlamd + if(tkemean(i) > tkcrt) then + tem = 1. + tkemean(i)/tkcrt + tem1 = min(tem, cmxfac) + clamt(i) = tem1 * clam + xlamdet(i) = tem1 * xlamdet(i) + xlamddt(i) = tem1 * xlamddt(i) + cxlamet(i) = tem1 * cxlamet(i) + cxlamdt(i) = tem1 * cxlamdt(i) + endif + endif + enddo +! else ! if(do_ca .and. ca_entr)then @@ -995,6 +1021,15 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & endif enddo endif +! + do i=1,im + if(cnvflg(i)) then + xlamdet(i) = xlamde + xlamddt(i) = xlamdd + cxlamet(i) = cxlame + cxlamdt(i) = cxlamd + endif + enddo ! endif !(.not. hwrf_samfdeep .and. ntk > 0) ! @@ -1083,7 +1118,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & do i=1,im if(cnvflg(i) .and. & (k > kbcon(i) .and. k < kmax(i))) then - tem = cxlame * frh(i,k) * fent2(i,k) + tem = cxlamet(i) * frh(i,k) * fent2(i,k) xlamue(i,k) = xlamue(i,k)*fent1(i,k) + tem endif enddo @@ -1093,9 +1128,9 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & do i=1,im if(cnvflg(i) .and. & (k > kbcon(i) .and. k < kmax(i))) then - tem = cxlame * frh(i,k) * fent2(i,k) + tem = cxlamet(i) * frh(i,k) * fent2(i,k) xlamue(i,k) = xlamue(i,k)*fent1(i,k) + tem - tem1 = cxlamd * frh(i,k) + tem1 = cxlamdt(i) * frh(i,k) xlamud(i,k) = xlamud(i,k) + tem1 endif enddo @@ -1531,6 +1566,11 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & buo(i,k) = buo(i,k) + grav * fv * & max(val,(qeso(i,k) - qo(i,k))) drag(i,k) = max(xlamue(i,k),xlamud(i,k)) +! + tem = ((uo(i,k)-uo(i,k-1))/dz)**2 + tem = tem+((vo(i,k)-vo(i,k-1))/dz)**2 + wush(i,k) = csmf * sqrt(tem) +! endif ! endif @@ -1701,8 +1741,6 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & ! compute updraft velocity square(wu2) !> - Calculate updraft velocity square(wu2) according to Han et al.'s (2017) \cite han_et_al_2017 equation 7. ! - bb1 = 4.0 - bb2 = 0.8 if (hwrf_samfdeep) then do i = 1, im if (cnvflg(i)) then @@ -1723,11 +1761,13 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & if (cnvflg(i)) then if(k > kbcon1(i) .and. k < ktcon(i)) then dz = zi(i,k) - zi(i,k-1) - tem = 0.25 * bb1 * (drag(i,k)+drag(i,k-1)) * dz - tem1 = 0.5 * bb2 * (buo(i,k)+buo(i,k-1)) * dz + tem = 0.25 * bb1 * (drag(i,k-1)+drag(i,k)) * dz + tem1 = 0.5 * bb2 * (buo(i,k-1)+buo(i,k)) + tem2 = wush(i,k) * sqrt(wu2(i,k-1)) + tem2 = (tem1 - tem2) * dz ptem = (1. - tem) * wu2(i,k-1) ptem1 = 1. + tem - wu2(i,k) = (ptem + tem1) / ptem1 + wu2(i,k) = (ptem + tem2) / ptem1 wu2(i,k) = max(wu2(i,k), 0.) endif endif @@ -1953,11 +1993,11 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & if (cnvflg(i) .and. k <= kmax(i)-1) then if(k < jmin(i) .and. k >= kd94(i)) then dz = zi(i,k+1) - zi(i,k) - ptem = xlamdd - xlamde + ptem = xlamddt(i) - xlamdet(i) etad(i,k) = etad(i,k+1) * (1. - ptem * dz) else if(k < kd94(i)) then dz = zi(i,k+1) - zi(i,k) - ptem = xlamd(i) + xlamdd - xlamde + ptem = xlamd(i) + xlamddt(i) - xlamdet(i) etad(i,k) = etad(i,k+1) * (1. - ptem * dz) endif endif @@ -1996,11 +2036,11 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & if (cnvflg(i) .and. k < jmin(i)) then dz = zi(i,k+1) - zi(i,k) if(k >= kd94(i)) then - tem = xlamde * dz - tem1 = 0.5 * xlamdd * dz + tem = xlamdet(i) * dz + tem1 = 0.5 * xlamddt(i) * dz else - tem = xlamde * dz - tem1 = 0.5 * (xlamd(i)+xlamdd) * dz + tem = xlamdet(i) * dz + tem1 = 0.5 * (xlamd(i)+xlamddt(i)) * dz endif factor = 1. + tem - tem1 hcdo(i,k) = ((1.-tem1)*hcdo(i,k+1)+tem*0.5* @@ -2024,7 +2064,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & do i = 1, im if (cnvflg(i) .and. k < jmin(i)) then dz = zi(i,k+1) - zi(i,k) - tem = 0.5 * xlamde * dz + tem = 0.5 * xlamdet(i) * dz tem = cq * tem factor = 1. + tem ecdo(i,k,n) = ((1.-tem)*ecdo(i,k+1,n)+tem* @@ -2045,7 +2085,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & ! detad = etad(i,k+1) - etad(i,k) cj dz = zi(i,k+1) - zi(i,k) - tem = 0.5 * xlamde * dz + tem = 0.5 * xlamdet(i) * dz tem = cq * tem factor = 1. + tem qcdo(i,k) = ((1.-tem)*qrcdo(i,k+1)+tem* @@ -2184,11 +2224,11 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & tem1 = 0.5 * (xlamud(i,k)+xlamud(i,k-1)) c if(k <= kd94(i)) then - ptem = xlamde - ptem1 = xlamd(i)+xlamdd + ptem = xlamdet(i) + ptem1 = xlamd(i)+xlamddt(i) else - ptem = xlamde - ptem1 = xlamdd + ptem = xlamdet(i) + ptem1 = xlamddt(i) endif factor = grav / dp @@ -2670,11 +2710,11 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & if (asqecflg(i) .and. k < jmin(i)) then dz = zi(i,k+1) - zi(i,k) if(k >= kd94(i)) then - tem = xlamde * dz - tem1 = 0.5 * xlamdd * dz + tem = xlamdet(i) * dz + tem1 = 0.5 * xlamddt(i) * dz else - tem = xlamde * dz - tem1 = 0.5 * (xlamd(i)+xlamdd) * dz + tem = xlamdet(i) * dz + tem1 = 0.5 * (xlamd(i)+xlamddt(i)) * dz endif factor = 1. + tem - tem1 hcdo(i,k) = ((1.-tem1)*hcdo(i,k+1)+tem*0.5* @@ -2694,7 +2734,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & ! detad = etad(i,k+1) - etad(i,k) cj dz = zi(i,k+1) - zi(i,k) - tem = 0.5 * xlamde * dz + tem = 0.5 * xlamdet(i) * dz tem = cq * tem factor = 1. + tem qcdo(i,k) = ((1.-tem)*qrcd(i,k+1)+tem* diff --git a/physics/samfshalcnv.f b/physics/samfshalcnv.f index 2f8b188a5..6872b6e83 100644 --- a/physics/samfshalcnv.f +++ b/physics/samfshalcnv.f @@ -110,7 +110,8 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & & cm, cq, & es, etah, h1, shevf, ! & evfact, evfactl, - & fact1, fact2, factor, dthk, + & fact1, fact2, factor, + & cthk, cthkmn, dthk, & gamma, pprime, betaw, tauadv, & qlk, qrch, qs, & rfact, shear, tfac, @@ -122,7 +123,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & & ptem, ptem1 ! integer kb(im), kb1(im), kbcon(im), kbcon1(im), - & ktcon(im), ktcon1(im), ktconn(im), + & ktcon(im), ktcon1(im), & kbm(im), kmax(im) ! real(kind=kind_phys) aa1(im), cina(im), @@ -147,13 +148,11 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & ! real(kind=kind_phys) cinpcr, cinpcrmx, cinpcrmn, & cinacr, cinacrmx, cinacrmn, - & sfclfac, rhcrt + & sfclfac, rhcrt, + & tkcrt, cmxfac ! ! parameters for updraft velocity calculation - real(kind=kind_phys) bet1, cd1, f1, gam1, -! & bb1, bb2 - & bb1, bb2, wucb - + real(kind=kind_phys) bb1, bb2, csmf, wucb cc ! parameters for prognostic sigma closure @@ -179,16 +178,19 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & ! Until a realistic Nccn is provided, Nccns are assumed ! as Nccn=100 for sea and Nccn=1000 for land ! - parameter(cm=1.0,cq=1.3) + parameter(cm=1.0,cq=1.0) ! parameter(fact1=(cvap-cliq)/rv,fact2=hvap/rv-fact1*t0c) parameter(clamd=0.1,tkemx=0.65,tkemn=0.05) parameter(dtke=tkemx-tkemn) - parameter(dthk=25.,sfclfac=0.2,rhcrt=0.75) + parameter(cthk=200.,cthkmn=0.,dthk=25.) + parameter(sfclfac=0.2,rhcrt=0.75) parameter(cinpcrmx=180.,cinpcrmn=120.) ! shevf is an enhancing evaporation factor for shallow convection parameter(cinacrmx=-120.,shevf=2.0) parameter(dtmax=10800.,dtmin=600.) - parameter(bet1=1.875,cd1=.506,f1=2.0,gam1=.5) + parameter(bb1=4.0,bb2=0.8,csmf=0.2) + parameter(tkcrt=2.,cmxfac=15.) +! parameter(bet1=1.875,cd1=.506,f1=2.0,gam1=.5) parameter(betaw=.03,dxcrtc0=9.e3) parameter(h1=0.33333333) ! progsigma @@ -206,7 +208,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & ! ! for updraft velocity calculation real(kind=kind_phys) wu2(im,km), buo(im,km), drag(im,km), - & wc(im) + & wush(im,km), wc(im) ! ! for updraft fraction & scale-aware function real(kind=kind_phys) scaldfunc(im), sigmagfm(im) @@ -304,7 +306,6 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & rn(i)=0. kbcon(i)=km ktcon(i)=1 - ktconn(i)=1 kb(i)=km pdot(i) = 0. qlko_ktcon(i) = 0. @@ -331,7 +332,6 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & rn(i)=0. kbcon(i)=km ktcon(i)=1 - ktconn(i)=1 kb(i)=km pdot(i) = 0. qlko_ktcon(i) = 0. @@ -512,6 +512,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & ! vo(i,k) = v1(i,k) * rcs(i) wu2(i,k) = 0. buo(i,k) = 0. + wush(i,k) = 0. drag(i,k) = 0. cnvwt(i,k) = 0. endif @@ -746,7 +747,8 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & cinpcr = cinpcrmx - ptem * ptem1 tem1 = pfld(i,kb(i)) - pfld(i,kbcon(i)) - if(tem1 > cinpcr) then + if(tem1 > cinpcr .and. + & zi(i,kbcon(i)) > hpbl(i)) then cnvflg(i) = .false. endif endif @@ -893,6 +895,18 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & endif endif enddo +! +! if tkemean>tkcrt, clamt=(1+tkemean/tkcrt)*clam +! + do i=1,im + if(cnvflg(i)) then + if(tkemean(i) > tkcrt) then + tem = 1. + tkemean(i)/tkcrt + tem1 = min(tem, cmxfac) + clamt(i) = tem1 * clam + endif + endif + enddo ! else ! @@ -970,7 +984,6 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & eta(i,k) = eta(i,k-1) * (1 + ptem * dz) if(eta(i,k) <= 0.) then kmax(i) = k - ktconn(i) = k kbm(i) = min(kbm(i),kmax(i)) flg(i) = .false. endif @@ -1200,7 +1213,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & !> - Calculate the cloud top as the first level where parcel buoyancy becomes negative; the maximum possible value is at \f$p=0.7p_{sfc}\f$. do i = 1, im flg(i) = cnvflg(i) - if(flg(i)) ktcon(i) = kbm(i) + if(flg(i)) ktcon(i) = 1 enddo do k = 2, km1 do i=1,im @@ -1213,6 +1226,18 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & enddo enddo c +c turn off shallow convection if cloud depth is larger than cthk or less than cthkmn +c + do i = 1, im + if(cnvflg(i)) then + tem = pfld(i,kbcon(i))-pfld(i,ktcon(i)) + if(tem > cthk .or. tem < cthkmn) then + cnvflg(i) = .false. + endif + endif + enddo + +c c specify upper limit of mass flux at cloud base c !> - Calculate the maximum value of the cloud base mass flux using the CFL-criterion-based formula of Han and Pan (2011) \cite han_and_pan_2011, equation 7. @@ -1286,6 +1311,11 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & buo(i,k) = buo(i,k) + grav * fv * & max(val,(qeso(i,k) - qo(i,k))) drag(i,k) = max(xlamue(i,k),xlamud(i)) +! + tem = ((uo(i,k)-uo(i,k-1))/dz)**2 + tem = tem+((vo(i,k)-vo(i,k-1))/dz)**2 + wush(i,k) = csmf * sqrt(tem) +! endif ! endif @@ -1445,9 +1475,6 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & ! ! compute updraft velocity square(wu2) !> - Calculate updraft velocity square(wu2) according to Han et al.'s (2017) \cite han_et_al_2017 equation 7. -! - bb1 = 4.0 - bb2 = 0.8 ! if (hwrf_samfshal) then do i = 1, im @@ -1468,11 +1495,13 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & if (cnvflg(i)) then if(k > kbcon1(i) .and. k < ktcon(i)) then dz = zi(i,k) - zi(i,k-1) - tem = 0.25 * bb1 * (drag(i,k)+drag(i,k-1)) * dz - tem1 = 0.5 * bb2 * (buo(i,k)+buo(i,k-1)) * dz + tem = 0.25 * bb1 * (drag(i,k-1)+drag(i,k)) * dz + tem1 = 0.5 * bb2 * (buo(i,k-1)+buo(i,k)) + tem2 = wush(i,k) * sqrt(wu2(i,k-1)) + tem2 = (tem1 - tem2) * dz ptem = (1. - tem) * wu2(i,k-1) ptem1 = 1. + tem - wu2(i,k) = (ptem + tem1) / ptem1 + wu2(i,k) = (ptem + tem2) / ptem1 wu2(i,k) = max(wu2(i,k), 0.) endif endif diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index 0387185e4..761234304 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -75,7 +75,8 @@ end subroutine satmedmfvdifq_init !! \section detail_satmedmfvidfq GFS satmedmfvdifq Detailed Algorithm subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & & ntiw,ntke,grav,rd,cp,rv,hvap,hfus,fv,eps,epsm1, & - & dv,du,tdt,rtg,u1,v1,t1,q1,swh,hlw,xmu,garea,zvfun, & + & dv,du,tdt,rtg,u1,v1,t1,q1,swh,hlw,xmu, & + & garea,zvfun,sigmaf, & & psk,rbsoil,zorl,u10m,v10m,fm,fh, & & tsea,heat,evap,stress,spd1,kpbl, & & prsi,del,prsl,prslk,phii,phil,delt, & @@ -112,7 +113,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & & t1(:,:), q1(:,:,:), & & swh(:,:), hlw(:,:), & & xmu(:), garea(:), & - & zvfun(:), & + & zvfun(:), sigmaf(:), & & psk(:), rbsoil(:), & & zorl(:), tsea(:), & & u10m(:), v10m(:), & @@ -147,7 +148,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & integer lcld(im),kcld(im),krad(im),mrad(im) integer kx1(im), kb1(im), kpblx(im) ! - real(kind=kind_phys) tke(im,km), tkeh(im,km-1) + real(kind=kind_phys) tke(im,km), tkeh(im,km-1), e2(im,0:km) ! real(kind=kind_phys) theta(im,km),thvx(im,km), thlvx(im,km), & qlx(im,km), thetae(im,km),thlx(im,km), @@ -159,15 +160,16 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & & qstl(im,km) ! real(kind=kind_phys) dtdz1(im), gdx(im), - & phih(im), phim(im), prn(im,km-1), + & phih(im), phim(im), + & phims(im), prn(im,km-1), & rbdn(im), rbup(im), thermal(im), & ustar(im), wstar(im), hpblx(im), & ust3(im), wst3(im), rho_a(im), - & z0(im), crb(im), + & z0(im), crb(im), tkemean(im), & hgamt(im), hgamq(im), & wscale(im),vpert(im), & zol(im), sflux(im), - & tx1(im), tx2(im) + & sumx(im), tx1(im), tx2(im) ! real(kind=kind_phys) radmin(im) ! @@ -181,7 +183,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & real(kind=kind_phys) elm(im,km), ele(im,km), & ckz(im,km), chz(im,km), & diss(im,km-1),prod(im,km-1), - & bf(im,km-1), shr2(im,km-1), + & bf(im,km-1), shr2(im,km-1), wush(im,km), & xlamue(im,km-1), xlamde(im,km-1), & gotvx(im,km), rlam(im,km-1) ! @@ -205,7 +207,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & & q_diff(im,0:km-1,ntrac-1) real(kind=kind_phys) rrkp, phkp real(kind=kind_phys) tsumn(im), tsump(im), rtnp(im) - real(kind=kind_phys) sfcpbl(im) + real(kind=kind_phys) sfcpbl(im), vez0fun(im) ! logical pblflg(im), sfcflg(im), flg(im) logical scuflg(im), pcnvflg(im) @@ -238,11 +240,13 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & & zfac, zfmin, vk, spdk2, & tkmin, tkbmx, xkgdx, & xkinv1, xkinv2, - & zlup, zldn, bsum, cs0, + & zlup, zldn, cs0, csmf, & tem, tem1, tem2, tem3, & ptem, ptem0, ptem1, ptem2 ! real(kind=kind_phys) slfac +! + real(kind=kind_phys) vegflo, vegfup, z0lo, z0up, vc0, zc0 ! real(kind=kind_phys) ck0, ck1, ch0, ch1, ce0, rchck ! @@ -269,8 +273,10 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & parameter(qlcr=3.5e-5,zstblmax=2500.) parameter(xkinv1=0.15,xkinv2=0.3) parameter(h1=0.33333333,hcrinv=250.) + parameter(vegflo=0.1,vegfup=1.0,z0lo=0.1,z0up=1.0) + parameter(vc0=1.0,zc0=1.0) parameter(ck1=0.15,ch1=0.15) - parameter(cs0=0.2) + parameter(cs0=0.4,csmf=0.5) parameter(rchck=1.5,ndt=20) if (tc_pbl == 0) then @@ -318,6 +324,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & xmfd(i,k) = 0. buou(i,k) = 0. buod(i,k) = 0. + wush(i,k) = 0. ckz(i,k) = ck1 chz(i,k) = ch1 rlmnz(i,k) = rlmn0 @@ -435,7 +442,18 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & kcld(i) = km1 endif enddo - +! +! compute a function for green vegetation fraction and surface roughness +! + do i = 1,im + tem = (sigmaf(i) - vegflo) / (vegfup - vegflo) + tem = min(max(tem, 0.), 1.) + tem1 = sqrt(tem) + ptem = (z0(i) - z0lo) / (z0up - z0lo) + ptem = min(max(ptem, 0.), 1.) + vez0fun(i) = (1. + vc0 * tem1) * (1. + zc0 * ptem) + enddo +! !> - Compute \f$\theta\f$(theta), and \f$q_l\f$(qlx), \f$\theta_e\f$(thetae), !! \f$\theta_v\f$(thvx),\f$\theta_{l,v}\f$ (thlvx) including ice water do k=1,km @@ -461,7 +479,8 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & svx(i,k) = cp * tvx(i,k) ptem1 = elocp * pix(i,k) * max(q1(i,k,1),qmin) thetae(i,k)= theta(i,k) + ptem1 - gotvx(i,k) = g / tvx(i,k) +! gotvx(i,k) = g / tvx(i,k) + gotvx(i,k) = g / thvx(i,k) enddo enddo @@ -726,6 +745,40 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & endif enddo ! +! compute mean tke within pbl +! + do i = 1, im + sumx(i) = 0. + tkemean(i) = 0. + enddo + do k = 1, kmpbl + do i = 1, im + if(k < kpbl(i)) then + dz = zi(i,k+1) - zi(i,k) + tkemean(i) = tkemean(i) + tke(i,k) * dz + sumx(i) = sumx(i) + dz + endif + enddo + enddo + do i = 1, im + if(tkemean(i) > 0. .and. sumx(i) > 0.) then + tkemean(i) = tkemean(i) / sumx(i) + endif + enddo +! +! compute wind shear term as a sink term for updraft and downdraft +! velocity +! + kps = max(kmpbl, kmscu) + do k = 2, kps + do i = 1, im + dz = zi(i,k+1) - zi(i,k) + tem = (0.5*(u1(i,k-1)-u1(i,k+1))/dz)**2 + tem1 = tem+(0.5*(v1(i,k-1)-v1(i,k+1))/dz)**2 + wush(i,k) = csmf * sqrt(tem1) + enddo + enddo +! !> ## Compute Monin-Obukhov similarity parameters !! - Calculate the Monin-Obukhov nondimensional stability paramter, commonly !! referred to as \f$\zeta\f$ using the following equation from Businger et al.(1971) \cite businger_et_al_1971 @@ -758,9 +811,12 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & tem = 1.0 / (1. - aphi16*zol1) phih(i) = sqrt(tem) phim(i) = sqrt(phih(i)) + tem1 = 1.0 / (1. - aphi16*zol(i)) + phims(i) = sqrt(sqrt(tem1)) else phim(i) = 1. + aphi5*zol1 phih(i) = phim(i) + phims(i) = 1. + aphi5*zol(i) endif enddo ! @@ -952,14 +1008,14 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & !! to take into account nonlocal transport by large eddies. For details of the mfpbltq subroutine, step into its documentation ::mfpbltq call mfpbltq(im,im,km,kmpbl,ntcw,ntrac1,dt2, & pcnvflg,zl,zm,q1,t1,u1,v1,plyr,pix,thlx,thvx, - & gdx,hpbl,kpbl,vpert,buou,xmf, + & gdx,hpbl,kpbl,vpert,buou,wush,tkemean,vez0fun,xmf, & tcko,qcko,ucko,vcko,xlamue,bl_upfr) !> - Call mfscuq(), which is a new mass-flux parameterization for !! stratocumulus-top-induced turbulence mixing. For details of the mfscuq subroutine, step into its documentation ::mfscuq call mfscuq(im,im,km,kmscu,ntcw,ntrac1,dt2, & scuflg,zl,zm,q1,t1,u1,v1,plyr,pix, & thlx,thvx,thlvx,gdx,thetae, - & krad,mrad,radmin,buod,xmfd, + & krad,mrad,radmin,buod,wush,tkemean,vez0fun,xmfd, & tcdo,qcdo,ucdo,vcdo,xlamde,bl_dnfr) if (tc_pbl == 1) then @@ -1055,79 +1111,51 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & do k = 1, km1 do i = 1, im zlup = 0.0 - bsum = 0.0 mlenflg = .true. + e2(i,k) = max(2.*tke(i,k), 0.001) do n = k, km1 if(mlenflg) then dz = zl(i,n+1) - zl(i,n) -! tem1 = 0.5 * (thvx(i,n) + thvx(i,n+1)) -!! tem1 = 0.5 * (thlvx(i,n) + thlvx(i,n+1)) - tem3=((u1(i,n+1)-u1(i,n))/dz)**2 - tem3=tem3+((v1(i,n+1)-v1(i,n))/dz)**2 - tem3=cs0*sqrt(tem3)*sqrt(tke(i,k)) - if (tc_pbl == 0) then - ptem = (gotvx(i,n)*(thvx(i,n+1)-thvx(i,k))+tem3)*dz -! ptem = (gotvx(i,n)*(thlvx(i,n+1)-thlvx(i,k)+tem3)*dz -! ptem = (gotvx(i,n)*(tem1-thvx(i,k))+tem3)*dz -!! ptem = (gotvx(i,n)*(tem1-thlvx(i,k)+tem3)*dz - else if (tc_pbl == 1) then - tem1 = 0.5*(thvx(i,n+1)+thvx(i,n)) - ptem = (gotvx(i,n)*(tem1-thvx(i,k))+tem3)*dz - endif - bsum = bsum + ptem + tem1 = 2.*gotvx(i,n+1)*(thvx(i,k)-thvx(i,n+1)) + tem2 = cs0*sqrt(e2(i,n))*sqrt(shr2(i,n)) + e2(i,n+1) = e2(i,n) + (tem1 - tem2) * dz zlup = zlup + dz - if(bsum >= tke(i,k)) then - if(ptem >= 0.) then - tem2 = max(ptem, zfmin) - else - tem2 = min(ptem, -zfmin) - endif - ptem1 = (bsum - tke(i,k)) / tem2 - zlup = zlup - ptem1 * dz + if(e2(i,n+1) < 0.) then + ptem = e2(i,n+1) / (e2(i,n+1) - e2(i,n)) + zlup = zlup - ptem * dz zlup = max(zlup, 0.) mlenflg = .false. endif endif enddo zldn = 0.0 - bsum = 0.0 mlenflg = .true. do n = k, 1, -1 if(mlenflg) then if(n == 1) then dz = zl(i,1) - tem1 = tsea(i)*(1.+fv*max(q1(i,1,1),qmin)) -! tem1 = 0.5 * (tem1 + thvx(i,n)) -!! tem1 = 0.5 * (tem1 + thlvx(i,n)) - tem3 = (u1(i,1)/dz)**2 - tem3 = tem3+(v1(i,1)/dz)**2 - tem3 = cs0*sqrt(tem3)*sqrt(tke(i,1)) + tem = tsea(i)*(1.+fv*max(q1(i,1,1),qmin)) + tem1 = 2.*gotvx(i,n)*(tem-thvx(i,k)) +! e2(i,n-1) = e2(i,n) + tem1 * dz +! +! tem2 = (u1(i,1)/dz)**2 +! tem2 = tem2+(v1(i,1)/dz)**2 +! tem2 = cs0*sqrt(e2(i,n))*sqrt(tem2) +! + tem2 = ustar(i)*phims(i)/(vk*dz) + tem2 = cs0*sqrt(e2(i,n))*tem2 + e2(i,n-1) = e2(i,n) + (tem1 - tem2) * dz +! else dz = zl(i,n) - zl(i,n-1) - if (tc_pbl == 0) then - tem1 = thvx(i,n-1) -! tem1 = thlvx(i,n-1) -! tem1 = 0.5 * (thvx(i,n-1) + thvx(i,n)) -!! tem1 = 0.5 * (thlvx(i,n-1) + thlvx(i,n)) - else if (tc_pbl == 1) then - tem1 = 0.5*(thvx(i,n)+thvx(i,n-1)) - endif - tem3 = ((u1(i,n)-u1(i,n-1))/dz)**2 - tem3 = tem3+((v1(i,n)-v1(i,n-1))/dz)**2 - tem3 = cs0*sqrt(tem3)*sqrt(tke(i,k)) + tem1 = 2.*gotvx(i,n-1)*(thvx(i,n-1)-thvx(i,k)) + tem2 = cs0*sqrt(e2(i,n))*sqrt(shr2(i,n-1)) + e2(i,n-1) = e2(i,n) + (tem1 - tem2) * dz endif - ptem = (gotvx(i,n)*(thvx(i,k)-tem1)+tem3)*dz -! ptem = (gotvx(i,n)*(thlvx(i,k)-tem1)+tem3)*dz - bsum = bsum + ptem zldn = zldn + dz - if(bsum >= tke(i,k)) then - if(ptem >= 0.) then - tem2 = max(ptem, zfmin) - else - tem2 = min(ptem, -zfmin) - endif - ptem1 = (bsum - tke(i,k)) / tem2 - zldn = zldn - ptem1 * dz + if(e2(i,n-1) < 0.) then + ptem = e2(i,n-1) / (e2(i,n-1) - e2(i,n)) + zldn = zldn - ptem * dz zldn = max(zldn, 0.) mlenflg = .false. endif @@ -1192,6 +1220,9 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & elm(i,k) = sqrt( 1.0/( 1.0/(zk**2)+1.0/(rlam(i,k)**2) ) ) endif +! + if(k == 1) elm(i,k)=zk +! dz = zi(i,k+1) - zi(i,k) tem = max(gdx(i),dz) elm(i,k) = min(elm(i,k), tem) @@ -1336,7 +1367,8 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & ptem2 = ptem2 + ptem ! ! tem2 = stress(i)*spd1(i)/zl(i,1) - tem2 = stress(i)*ustar(i)*phim(i)/(vk*zl(i,1)) +! tem2 = stress(i)*ustar(i)*phim(i)/(vk*zl(i,1)) + tem2 = stress(i)*ustar(i)*phims(i)/(vk*zl(i,1)) shrp = 0.5 * (tem1 + ptem1 + ptem2 + tem2) else tem1 = -dkt(i,k-1) * bf(i,k-1) @@ -1664,8 +1696,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & endif if((pcnvflg(i) .or. scuflg(i)) .and. & (k >= kbx .and. k <= kmx)) then - dz = zi(i,k+1) - zi(i,k) - tem = f1(i,k) * dz + tem = f1(i,k) * del(i,k) / grav if(f1(i,k) < 0.) tsumn(i) = tsumn(i) + tem if(f1(i,k) > 0.) tsump(i) = tsump(i) + tem endif @@ -1720,8 +1751,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & enddo do k = 1,km do i = 1,im - dz = zi(i,k+1) - zi(i,k) - tem = f1(i,k) * dz + tem = f1(i,k) * del(i,k) / grav if(f1(i,k) < 0.) tsumn(i) = tsumn(i) + tem if(f1(i,k) > 0.) tsump(i) = tsump(i) + tem enddo @@ -2197,7 +2227,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & ! dqsfc(i) = dqsfc(i)+conq*del(i,k)*qtend enddo enddo - +! do i = 1,im dtsfc(i) = rho_a(i) * cp * heat(i) dqsfc(i) = rho_a(i) * hvap * evap(i) diff --git a/physics/satmedmfvdifq.meta b/physics/satmedmfvdifq.meta index d0b11656a..b6680dccb 100644 --- a/physics/satmedmfvdifq.meta +++ b/physics/satmedmfvdifq.meta @@ -273,6 +273,14 @@ type = real kind = kind_phys intent = in +[sigmaf] + standard_name = bounded_vegetation_area_fraction + long_name = areal fractional cover of green vegetation bounded on the bottom + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [psk] standard_name = surface_dimensionless_exner_function long_name = dimensionless Exner function at the surface interface From 8a4a70f47c3298da361e8527c325edba2fad5230 Mon Sep 17 00:00:00 2001 From: Qingfu Liu Date: Mon, 24 Apr 2023 07:33:34 -0400 Subject: [PATCH 236/380] PBL and Convection update for HR2 --- physics/satmedmfvdifq.F | 7 ------- 1 file changed, 7 deletions(-) diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index 761234304..c2703fd61 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -1136,16 +1136,9 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & dz = zl(i,1) tem = tsea(i)*(1.+fv*max(q1(i,1,1),qmin)) tem1 = 2.*gotvx(i,n)*(tem-thvx(i,k)) -! e2(i,n-1) = e2(i,n) + tem1 * dz -! -! tem2 = (u1(i,1)/dz)**2 -! tem2 = tem2+(v1(i,1)/dz)**2 -! tem2 = cs0*sqrt(e2(i,n))*sqrt(tem2) -! tem2 = ustar(i)*phims(i)/(vk*dz) tem2 = cs0*sqrt(e2(i,n))*tem2 e2(i,n-1) = e2(i,n) + (tem1 - tem2) * dz -! else dz = zl(i,n) - zl(i,n-1) tem1 = 2.*gotvx(i,n-1)*(thvx(i,n-1)-thvx(i,k)) From c9757285f8c77a5c89c26c5a15a54e1f6f38fafd Mon Sep 17 00:00:00 2001 From: Qingfu Liu Date: Mon, 24 Apr 2023 16:36:35 -0400 Subject: [PATCH 237/380] PBL and Convection u pdate for HR2 --- physics/samfdeepcnv.f | 4 ---- physics/samfshalcnv.f | 2 -- physics/satmedmfvdifq.F | 2 -- 3 files changed, 8 deletions(-) diff --git a/physics/samfdeepcnv.f b/physics/samfdeepcnv.f index b8d564728..8a36fe34c 100644 --- a/physics/samfdeepcnv.f +++ b/physics/samfdeepcnv.f @@ -979,10 +979,6 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & endif enddo endif -! -! if tkemean>tkcrt, tem=1+tkemean/tkcrt, clamt=tem*clam -! xlamdet=tem*xlamde, xlamddt=tem*xlamdd -! cxlamet=tem*cxlame, cxlamdt=tem*cxlamd ! do i=1,im if(cnvflg(i)) then diff --git a/physics/samfshalcnv.f b/physics/samfshalcnv.f index 6872b6e83..a7682342f 100644 --- a/physics/samfshalcnv.f +++ b/physics/samfshalcnv.f @@ -895,8 +895,6 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & endif endif enddo -! -! if tkemean>tkcrt, clamt=(1+tkemean/tkcrt)*clam ! do i=1,im if(cnvflg(i)) then diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index c2703fd61..d12852fe1 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -1359,8 +1359,6 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & endif ptem2 = ptem2 + ptem ! -! tem2 = stress(i)*spd1(i)/zl(i,1) -! tem2 = stress(i)*ustar(i)*phim(i)/(vk*zl(i,1)) tem2 = stress(i)*ustar(i)*phims(i)/(vk*zl(i,1)) shrp = 0.5 * (tem1 + ptem1 + ptem2 + tem2) else From 3a59acc09198604542b9d458493788025f506314 Mon Sep 17 00:00:00 2001 From: Qingfu Liu Date: Tue, 25 Apr 2023 14:43:02 -0400 Subject: [PATCH 238/380] Physics update for HR2 --- physics/radiation_clouds.f | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index 3029398e9..b9a9ec48d 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -2081,7 +2081,7 @@ subroutine progcld_thompson_wsm6 & ! --- constant values real (kind=kind_phys), parameter :: xrc3 = 100. - + real (kind=kind_phys), parameter :: snow2ice = 0.25 ! !===> ... begin here @@ -2097,7 +2097,7 @@ subroutine progcld_thompson_wsm6 & rei (i,k) = re_ice(i,k) rer (i,k) = rrain_def ! default rain radius to 1000 micron res (i,k) = re_snow(i,K) - tem2d (i,k) = min( 1.0, max( 0.0, (con_ttp-tlyr(i,k))*0.05 ) ) + tem2d (i,k) = min( 1.0, max( 0.0, (con_ttp-tlyr(i,k))*0.025 ) ) clwf(i,k) = 0.0 enddo enddo @@ -2138,12 +2138,14 @@ subroutine progcld_thompson_wsm6 & if(tem1 > 1.e-12 .and. clw(i,k,ntcw) < 1.e-12) & rew(i,k)=reliq_def tem2 = cnvw(i,k)*tem2d(i,k) - cip(i,k) = max(0.0, (clw(i,k,ntiw) + tem2 ) - & *gfac * delp(i,k)) + cip(i,k) = max(0.0, (clw(i,k,ntiw) + + & snow2ice*clw(i,k,ntsw) + tem2) * + & gfac * delp(i,k)) if(tem2 > 1.e-12 .and. clw(i,k,ntiw) < 1.e-12) & rei(i,k)=reice_def crp(i,k) = max(0.0, clw(i,k,ntrw) * gfac * delp(i,k)) - csp(i,k) = max(0.0, clw(i,k,ntsw) * gfac * delp(i,k)) + csp(i,k) = max(0.0, ((1.-snow2ice)*clw(i,k,ntsw) * + & gfac * delp(i,k)) enddo enddo From c989bdce7b368557902d66e06a11a35fe3b5a632 Mon Sep 17 00:00:00 2001 From: Qingfu Liu Date: Wed, 26 Apr 2023 06:43:49 -0400 Subject: [PATCH 239/380] PBL and Convection update for HR2 --- physics/radiation_clouds.f | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index b9a9ec48d..079218f5a 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -2082,6 +2082,7 @@ subroutine progcld_thompson_wsm6 & ! --- constant values real (kind=kind_phys), parameter :: xrc3 = 100. real (kind=kind_phys), parameter :: snow2ice = 0.25 + real (kind=kind_phys), parameter :: coef_t = 0.025 ! !===> ... begin here @@ -2097,7 +2098,7 @@ subroutine progcld_thompson_wsm6 & rei (i,k) = re_ice(i,k) rer (i,k) = rrain_def ! default rain radius to 1000 micron res (i,k) = re_snow(i,K) - tem2d (i,k) = min( 1.0, max( 0.0, (con_ttp-tlyr(i,k))*0.025 ) ) + tem2d (i,k) = min(1.0, max( 0.0, (con_ttp-tlyr(i,k))*coef_t)) clwf(i,k) = 0.0 enddo enddo @@ -2144,7 +2145,7 @@ subroutine progcld_thompson_wsm6 & if(tem2 > 1.e-12 .and. clw(i,k,ntiw) < 1.e-12) & rei(i,k)=reice_def crp(i,k) = max(0.0, clw(i,k,ntrw) * gfac * delp(i,k)) - csp(i,k) = max(0.0, ((1.-snow2ice)*clw(i,k,ntsw) * + csp(i,k) = max(0.0, (1.-snow2ice)*clw(i,k,ntsw) * & gfac * delp(i,k)) enddo enddo From 9108d5a8298abc596d5f9340b9820d71afa9e429 Mon Sep 17 00:00:00 2001 From: Qingfu Liu Date: Wed, 26 Apr 2023 08:44:22 -0400 Subject: [PATCH 240/380] PBL and Convection update for HR2 --- .github/workflows/ci_fv3_ccpp_prebuild.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci_fv3_ccpp_prebuild.yml b/.github/workflows/ci_fv3_ccpp_prebuild.yml index a5c2f8092..b042db2a6 100644 --- a/.github/workflows/ci_fv3_ccpp_prebuild.yml +++ b/.github/workflows/ci_fv3_ccpp_prebuild.yml @@ -53,4 +53,4 @@ jobs: run: | cd /home/runner/work/ccpp-physics/ccpp-physics/fv3atm/ccpp/ mkdir -p /home/runner/work/ccpp-physics/ccpp-physics/fv3atm/bin/ccpp/physics/physics/ - ./framework/scripts/ccpp_prebuild.py --config config/ccpp_prebuild_config.py \ No newline at end of file + ./framework/scripts/ccpp_prebuild.py --config config/ccpp_prebuild_config.py From 2979eb06daa54c56a239ed9fff90a69501691740 Mon Sep 17 00:00:00 2001 From: Qingfu Liu Date: Wed, 26 Apr 2023 09:57:54 -0400 Subject: [PATCH 241/380] PBL and Convection update for HR2 --- .github/workflows/ci_fv3_ccpp_prebuild.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci_fv3_ccpp_prebuild.yml b/.github/workflows/ci_fv3_ccpp_prebuild.yml index b042db2a6..a5c2f8092 100644 --- a/.github/workflows/ci_fv3_ccpp_prebuild.yml +++ b/.github/workflows/ci_fv3_ccpp_prebuild.yml @@ -53,4 +53,4 @@ jobs: run: | cd /home/runner/work/ccpp-physics/ccpp-physics/fv3atm/ccpp/ mkdir -p /home/runner/work/ccpp-physics/ccpp-physics/fv3atm/bin/ccpp/physics/physics/ - ./framework/scripts/ccpp_prebuild.py --config config/ccpp_prebuild_config.py + ./framework/scripts/ccpp_prebuild.py --config config/ccpp_prebuild_config.py \ No newline at end of file From f020a3a2ab44048bb9725639d1924a50c97a089c Mon Sep 17 00:00:00 2001 From: Greg Thompson Date: Thu, 27 Apr 2023 07:37:58 -0600 Subject: [PATCH 242/380] bug fix for rain evaporation due to inconsistent usage of air density on multiple lines --- physics/module_mp_thompson.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index b828c9ab0..3844498d1 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -3716,13 +3716,13 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & lamr = 1./ilamr(k) !> - Rapidly eliminate near zero values when low humidity (<95%) if (qv(k)/qvs(k) .lt. 0.95 .AND. rr(k)*orho.le.1.E-8) then - prv_rev(k) = rr(k)*orho*odts + prv_rev(k) = rr(k)*odts else prv_rev(k) = t1_evap*diffu(k)*(-ssatw(k))*N0_r(k)*rvs & * (t1_qr_ev*ilamr(k)**cre(10) & + t2_qr_ev*vsc2(k)*rhof2(k)*((lamr+0.5*fv_r)**(-cre(11)))) - rate_max = MIN((rr(k)*orho*odts), (qvs(k)-qv(k))*odts) - prv_rev(k) = MIN(DBLE(rate_max), prv_rev(k)*orho) + rate_max = MIN((rr(k)*odts), (qvs(k)-qv(k))*rho(k)*odts) + prv_rev(k) = MIN(DBLE(rate_max*orho), prv_rev(k)*orho) !..TEST: G. Thompson 10 May 2013 !> - Reduce the rain evaporation in same places as melting graupel occurs. From 054413acda906cf88772ab84d0512508d0af439d Mon Sep 17 00:00:00 2001 From: barlage Date: Fri, 28 Apr 2023 10:30:45 -0600 Subject: [PATCH 243/380] document thermalz0 scheme --- physics/module_sf_noahmplsm.F90 | 273 ++++++++++++++++++-------------- 1 file changed, 158 insertions(+), 115 deletions(-) diff --git a/physics/module_sf_noahmplsm.F90 b/physics/module_sf_noahmplsm.F90 index ef6f99c44..ae143587f 100644 --- a/physics/module_sf_noahmplsm.F90 +++ b/physics/module_sf_noahmplsm.F90 @@ -5487,143 +5487,186 @@ end subroutine sfcdif3 !>\ingroup NoahMP_LSM ! compute thermal roughness length based on option opt_trs. - subroutine thermalz0(parameters,fveg,z0m,z0mg,zlvl,zpd,ezpd,ustarx, & !in - vegtyp,vaie,ur,csigmaf0,csigmaf1,aone,cdmnv,cdmng,icom, & !in - z0mt,z0ht) !out + + subroutine thermalz0(parameters, fveg, z0m, z0mg, zlvl, zpd, ezpd, & !in + ustarx, vegtyp, vaie, ur, c_sigma_f0, c_sigma_f1, a1, & !in + cdmn_v, cdmn_g, surface_flag, & !in + z0m_out, z0h_out ) !out + ! compute thermal roughness length based on option opt_trs. ! ------------------------------------------------------------------------------------------------- implicit none ! ------------------------------------------------------------------------------------------------- ! inputs - type (noahmp_parameters), intent(in) :: parameters !< - integer , intent(in ) :: vegtyp !< vegetation type - integer , intent(in ) :: icom !< 0=bared 1=vege 2=composition - real (kind=kind_phys), intent(in ) :: fveg !< green vegetation fraction [0.0-1.0] - real (kind=kind_phys), intent(in ) :: z0m !< z0 momentum (m) - real (kind=kind_phys), intent(in ) :: z0mg !< z0 momentum, ground (m) - real (kind=kind_phys), intent(in ) :: zlvl !< reference height [m] - real (kind=kind_phys), intent(in ) :: zpd !< zero plane displacement (m) - real (kind=kind_phys), intent(in ) :: ezpd !< zero plane displacement (m) - real (kind=kind_phys), intent(in ) :: ustarx !< friction velocity (m/s) - real (kind=kind_phys), intent(in ) :: vaie !< reference height [m] - real (kind=kind_phys), intent(in ) :: ur !< wind speed [m/s] - real (kind=kind_phys), intent(inout) :: csigmaf0 !< - real (kind=kind_phys), intent(inout) :: csigmaf1 !< - real (kind=kind_phys), intent(in ) :: aone !< - real (kind=kind_phys), intent(in ) :: cdmnv !< - real (kind=kind_phys), intent(in ) :: cdmng !< - real (kind=kind_phys), intent(out ) :: z0mt !< composited z0 momentum (m) - real (kind=kind_phys), intent(out ) :: z0ht !< composited z0 momentum (m) + type (noahmp_parameters),intent(in ) :: parameters ! parameters data structure + integer , intent(in ) :: vegtyp ! vegetation type + integer , intent(in ) :: surface_flag ! 0=bare 1=vegetation 2=composite + real (kind=kind_phys), intent(in ) :: fveg ! vegetation fraction [0.0-1.0] + real (kind=kind_phys), intent(in ) :: z0m ! z0 momentum [m] + real (kind=kind_phys), intent(in ) :: z0mg ! z0 momentum, ground [m] + real (kind=kind_phys), intent(in ) :: zlvl ! reference height [m] + real (kind=kind_phys), intent(in ) :: zpd ! zero plane displacement [m] + real (kind=kind_phys), intent(in ) :: ezpd ! grid zero plane displacement [m] + real (kind=kind_phys), intent(in ) :: ustarx ! friction velocity [m/s] + real (kind=kind_phys), intent(in ) :: vaie ! exposed LAI + SAI [m2/m2] + real (kind=kind_phys), intent(in ) :: ur ! wind speed [m/s] + real (kind=kind_phys), intent(in ) :: a1 ! Blumel 99 eqn 43 + real (kind=kind_phys), intent(in ) :: cdmn_v ! neutral momentum drag coefficient for vegetation + real (kind=kind_phys), intent(in ) :: cdmn_g ! neutral momentum drag coefficient for bare ground + real (kind=kind_phys), intent(inout) :: c_sigma_f0 ! C factor for no vegetation Blumel99 eqn 35 + real (kind=kind_phys), intent(inout) :: c_sigma_f1 ! C factor for full vegetation Blumel99 eqn 39 + real (kind=kind_phys), intent(out ) :: z0m_out ! output z0 momentum [m] + real (kind=kind_phys), intent(out ) :: z0h_out ! output z0 heat [m] ! local - real (kind=kind_phys) :: czil1 ! canopy based czil - real (kind=kind_phys) :: coeffa - real (kind=kind_phys) :: coeffb - real (kind=kind_phys) :: csigmafveg - real (kind=kind_phys) :: gsigma - real (kind=kind_phys) :: sigmaa - real (kind=kind_phys) :: cdmn - real (kind=kind_phys) :: kbsigmafveg - real (kind=kind_phys) :: reyn - real (kind=kind_phys) :: kbsigmaf0 - real (kind=kind_phys) :: kbsigmaf1 + real (kind=kind_phys) :: czil ! Zilitinkevich factor + real (kind=kind_phys) :: coeff_a ! slope of Blumel99 eqn 40 Blumel99 eqn 41 + real (kind=kind_phys) :: coeff_b ! intercept of Blumel99 eqn 40 Blumel99 eqn 42 + real (kind=kind_phys) :: c_sigma_fveg ! estimated C factor Blumel99 eqn 40 + real (kind=kind_phys) :: g_sigma ! weighting function Blumel99 eqn 22 + real (kind=kind_phys) :: sigma_a ! momentum partition factor Blumel99 eqn 8 + real (kind=kind_phys) :: cdmn ! grid neutral momentum drag coefficient Blumel99 eqn 21 + real (kind=kind_phys) :: reyn ! roughness Reynolds number Blumel99 eqn 36c + real (kind=kind_phys) :: kb_sigma_f0 ! bare ground kb^-1 Blumel99 eqn 36ab + real (kind=kind_phys) :: kb_sigma_f1 ! vegetated kb^-1 Blumel99 eqn 38 + real (kind=kind_phys) :: kb_sigma_fveg! grid estimated kb^-1 Blumel99 eqn 34 + + integer, parameter :: bare_flag = 0, vegetated_flag = 1, composite_flag = 2 + integer, parameter :: z0heqz0m = 1, & + chen09 = 2, & + tessel = 3, & + blumel99 = 4 + real (kind=kind_phys), parameter :: blumel_gamma = 0.5, & + blumel_zeta = 1.0, & + viscosity = 1.5e-5 ! ------------------------------------------------------------------------------------------------- - czil1 = 0.5 - coeffa = 0.0 - coeffb = 0.0 - csigmafveg= 0.0 - gsigma = 0.0 - cdmn = 0.0 - reyn = 0.0 - sigmaa = 0.0 - kbsigmafveg = 0.0 - kbsigmaf0 = 0.0 - kbsigmaf1 = 0.0 - if( icom == 2 )then - if (opt_trs == 1) then - z0mt = fveg * z0m + (1.0 - fveg) * z0mg - z0ht = z0mt - elseif (opt_trs == 2) then - z0mt = fveg * z0m + (1.0 - fveg) * z0mg - czil1=10.0 ** (- 0.4 * parameters%hvt) - z0ht = fveg * z0m*exp(-czil1*0.4*258.2*sqrt(ustarx*z0m)) & - +(1.0 - fveg) * z0mg*exp(-czil1*0.4*258.2*sqrt(ustarx*z0mg)) - elseif (opt_trs == 3) then - z0mt = fveg * z0m + (1.0 - fveg) * z0mg - if (vegtyp.le.5) then - z0ht = fveg * z0m + (1.0 - fveg) * z0mg*0.1 + czil = 0.5 + coeff_a = 0.0 + coeff_b = 0.0 + c_sigma_fveg = 0.0 + g_sigma = 0.0 + cdmn = 0.0 + reyn = 0.0 + sigma_a = 0.0 + kb_sigma_fveg = 0.0 + kb_sigma_f0 = 0.0 + kb_sigma_f1 = 0.0 + + surface_flag_select : select case(surface_flag) + + case (composite_flag) ! calculate grid based z0m and z0h + + if (opt_trs == z0heqz0m) then + + z0m_out = fveg * z0m + (1.0 - fveg) * z0mg ! probably should be log + z0h_out = z0m_out + + elseif (opt_trs == chen09) then + + z0m_out = fveg * z0m + (1.0 - fveg) * z0mg ! probably should be log + czil = 10.0 ** (- 0.4 * parameters%hvt) + z0h_out = fveg * z0m * exp(-czil*0.4*258.2*sqrt(ustarx*z0m )) & + + (1.0 - fveg) * z0mg * exp(-czil*0.4*258.2*sqrt(ustarx*z0mg)) + + elseif (opt_trs == tessel) then + + z0m_out = fveg * z0m + (1.0 - fveg) * z0mg ! probably should be log + if (vegtyp <= 5) then + z0h_out = fveg * z0m + (1.0 - fveg) * z0mg * 0.1 else - z0ht = fveg * z0m*0.01 + (1.0 - fveg) * z0mg*0.1 + z0h_out = fveg * z0m * 0.01 + (1.0 - fveg) * z0mg * 0.1 endif - elseif (opt_trs == 4) then - coeffa = (csigmaf0 - csigmaf1)/(1.0 - exp(-1.0*aone)) - coeffb = csigmaf0 - coeffa - csigmafveg = coeffa * exp(-1.0*aone*fveg) + coeffb - gsigma = fveg**0.5 + fveg*(1.0-fveg)*1.0 -! -! 0.5 ~ 1.0 for the 0.5 place; 0 ~ 1.0 for the 1.0 place, adjustable empirical + elseif (opt_trs == blumel99) then + + coeff_a = (c_sigma_f0 - c_sigma_f1)/(1.0 - exp(-1.0*a1)) ! Blumel99 eqn 41 + coeff_b = c_sigma_f0 - coeff_a ! Blumel99 eqn 42 + c_sigma_fveg = coeff_a * exp(-1.0*a1*fveg) + coeff_b ! Blumel99 eqn 40 + +! blumel_gamma = 0.5 ~ 1.0 and blumel_zeta = 0 ~ 1.0, adjustable empirical ! canopy roughness geometry parameter; currently fveg = 0.78 has the largest ! momentum flux; can test the fveg-based average by setting 0.5 to 1.0 and 1.0 -! to 0.0 ! see Blumel; JAM,1998 -! +! to 0.0 ! see Blumel; JAM,1999 - cdmn = gsigma*cdmnv + (1.0-gsigma)*cdmng - z0mt = (zlvl - ezpd)*exp(-0.4/sqrt(cdmn)) + g_sigma = fveg**blumel_gamma + fveg*(1.0-fveg)*blumel_zeta ! Blumel99 eqn 22 + cdmn = g_sigma*cdmn_v + (1.0-g_sigma)*cdmn_g ! Blumel99 eqn 21 + z0m_out = (zlvl - ezpd)*exp(-0.4/sqrt(cdmn)) ! Blumel99 eqn 24 + kb_sigma_fveg = c_sigma_fveg/log((zlvl-ezpd)/z0m_out) - & + log((zlvl-ezpd)/z0m_out) ! Blumel99 eqn 34 + z0h_out = z0m_out/exp(kb_sigma_fveg) - kbsigmafveg = csigmafveg/log((zlvl-ezpd)/z0mt) - log((zlvl-ezpd)/z0mt) - z0ht = z0mt/exp(kbsigmafveg) - endif - - elseif( icom == 0 )then - - z0mt = z0mg - if (opt_trs == 1) then - z0ht = z0mt - elseif (opt_trs == 2) then - czil1=10.0 ** (- 0.4 * parameters%hvt) - z0ht =z0mt*exp(-czil1*0.4*258.2*sqrt(ustarx*z0mt)) - elseif (opt_trs == 3) then - if (vegtyp.le.5) then - z0ht = z0mt - else - z0ht = z0mt*0.01 endif - elseif (opt_trs == 4) then - reyn = ustarx*z0mt/(1.5e-05) - if (reyn .gt. 2.0) then - kbsigmaf0 = 2.46*reyn**0.25 - log(7.4) - else - kbsigmaf0 = - log(0.397) + + case (bare_flag) ! calculate z0m and z0h over bare tile + + z0m_out = z0mg + + if (opt_trs == z0heqz0m) then + + z0h_out = z0m_out + + elseif (opt_trs == chen09) then + + czil = 10.0 ** (- 0.4 * parameters%hvt) + z0h_out = z0m_out * exp(-czil*0.4*258.2*sqrt(ustarx*z0m_out)) + + elseif (opt_trs == tessel) then + + if (vegtyp <= 5) then + z0h_out = z0m_out + else + z0h_out = z0m_out * 0.01 + endif + + elseif (opt_trs == blumel99) then + + reyn = ustarx*z0m_out/viscosity ! Blumel99 eqn 36c + if (reyn > 2.0) then + kb_sigma_f0 = 2.46*reyn**0.25 - log(7.4) ! Blumel99 eqn 36a + else + kb_sigma_f0 = - log(0.397) ! Blumel99 eqn 36b + endif + + z0h_out = max(z0m_out/exp(kb_sigma_f0),1.0e-6) + c_sigma_f0 = log((zlvl-zpd)/z0m_out) * & + (log((zlvl-zpd)/z0m_out) + kb_sigma_f0) ! Blumel99 eqn 35 + endif - z0ht = max(z0mt/exp(kbsigmaf0),1.0e-6) - csigmaf0 = log((zlvl-zpd)/z0mt)*(log((zlvl-zpd)/z0mt) + kbsigmaf0) - endif + case (vegetated_flag) ! calculate z0m and z0h over vegetated tile - elseif( icom == 1 )then - - z0mt = z0m - if (opt_trs == 1) then - z0ht = z0mt - elseif (opt_trs == 2) then - czil1= 10.0 ** (- 0.4 * parameters%hvt) - z0ht = z0mt*exp(-czil1*0.4*258.2*sqrt(ustarx*z0mt)) - elseif (opt_trs == 3) then - if (vegtyp.le.5) then - z0ht = z0mt - else - z0ht = z0mt*0.01 - endif - elseif (opt_trs == 4) then - sigmaa = 1.0 - (0.5/(0.5+vaie))*exp(-vaie**2/8.0) - kbsigmaf1 = 16.4*(sigmaa*vaie**3)**(-0.25)*sqrt(parameters%dleaf*ur/log((zlvl-zpd)/z0mt)) - z0ht = z0mt/exp(kbsigmaf1) - csigmaf1 = log((zlvl-zpd)/z0mt)*(log((zlvl-zpd)/z0mt)+kbsigmaf1) ! for output for interpolation + z0m_out = z0m + + if (opt_trs == z0heqz0m) then + + z0h_out = z0m_out + + elseif (opt_trs == chen09) then + + czil = 10.0 ** (- 0.4 * parameters%hvt) + z0h_out = z0m_out * exp(-czil*0.4*258.2*sqrt(ustarx*z0m_out)) + + elseif (opt_trs == tessel) then + + if (vegtyp <= 5) then + z0h_out = z0m_out + else + z0h_out = z0m_out*0.01 endif - endif + + elseif (opt_trs == blumel99) then + + sigma_a = 1.0 - (0.5/(0.5+vaie)) * exp(-vaie**2/8.0) ! Blumel99 eqn 8 + kb_sigma_f1 = 16.4 * (sigma_a*vaie**3)**(-0.25) * & ! Blumel99 eqn 38 + sqrt(parameters%dleaf*ur/log((zlvl-zpd)/z0m_out)) + z0h_out = z0m_out/exp(kb_sigma_f1) + c_sigma_f1 = log((zlvl-zpd)/z0m_out)*(log((zlvl-zpd)/z0m_out)+kb_sigma_f1) ! Blumel99 eqn 39 + + endif + + end select surface_flag_select end subroutine thermalz0 From c39a6a50cb8791d0678a7e6bd3aa111f2ec75c32 Mon Sep 17 00:00:00 2001 From: barlage Date: Mon, 1 May 2023 09:09:04 -0600 Subject: [PATCH 244/380] add z0m option to account for phenology --- physics/module_sf_noahmplsm.F90 | 57 +++++++++++++++++++++++++++------ physics/noahmpdrv.F90 | 4 ++- 2 files changed, 50 insertions(+), 11 deletions(-) diff --git a/physics/module_sf_noahmplsm.F90 b/physics/module_sf_noahmplsm.F90 index ae143587f..afea081f3 100644 --- a/physics/module_sf_noahmplsm.F90 +++ b/physics/module_sf_noahmplsm.F90 @@ -163,14 +163,19 @@ module module_sf_noahmplsm ! 1 -> liu, et al. 2016 integer :: opt_trs !< options for thermal roughness scheme - ! **1 -> z0h=z0 - ! 2 -> czil - ! 3 -> ec style - ! 4 -> kb inversed + ! **1 -> z0h=z0m + ! 2 -> czil = f(canopy height) from Chen09 + ! 3 -> ec style from TESSEL + ! 4 -> kb inverse from Blumel99 integer :: opt_diag !< options for surface 2m/q diagnostic approach ! 1 -> external GFS sfc_diag ! **2 -> original NoahMP 2-title ! 3 -> NoahMP 2-title + internal GFS sfc_diag + + integer :: opt_z0m !< options for momentum roughness length + ! **1 -> use z0m from MPTABLE + ! 2 -> z0m = f(canopy height, LAI/SAI) + !------------------------------------------------------------------------------------------! ! physical constants: ! !------------------------------------------------------------------------------------------! @@ -1974,6 +1979,10 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in real (kind=kind_phys) :: ezpd real (kind=kind_phys) :: aone + real (kind=kind_phys) :: canopy_density_factor + real (kind=kind_phys) :: vai_limited + real (kind=kind_phys) :: z0m_hvt_ratio(20) + !jref:end real (kind=kind_phys), parameter :: mpe = 1.e-6 @@ -2012,6 +2021,11 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in csigmaf1 = 0.0 csigmaf0 = 0.0 aone = 0.0 + + canopy_density_factor = 1.0 + vai_limited = 2.0 + z0m_hvt_ratio = (/ 0.545,0.055,0.047,0.050,0.050,0.182,0.545,0.046,0.050,0.120, & + 0.060,0.075,0.067,0.093,0.000,0.000,0.000,0.075,0.100,0.060 /) ! @@ -2054,12 +2068,32 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in zpdg = snowh if(veg) then - z0m = parameters%z0mvt - zpd = 0.65 * parameters%hvt - if(snowh.gt.zpd) zpd = snowh + + if(opt_z0m == 1) then + + z0m = parameters%z0mvt + zpd = 0.65 * parameters%hvt + + elseif(opt_z0m == 2) then + + z0m = z0m_hvt_ratio(vegtyp) * parameters%hvt + zpd = 0.65 * parameters%hvt + if(vegtyp /= 13) then + vai_limited = min(vai, 2.0) + canopy_density_factor = (1.0 - exp(-vai_limited)) / (1.0 - exp(-2.0)) + z0m = exp(canopy_density_factor * log(z0m) + (1.0 - canopy_density_factor) * log(z0mg)) + zpd = canopy_density_factor * zpd + end if + + end if + + if(snowh.gt.zpd) zpd = snowh + else + z0m = z0mg zpd = zpdg + end if ! special case for urban @@ -10154,9 +10188,10 @@ end subroutine psn_crop !>\ingroup NoahMP_LSM !! - subroutine noahmp_options(idveg ,iopt_crs ,iopt_btr ,iopt_run ,iopt_sfc ,iopt_frz , & - iopt_inf ,iopt_rad ,iopt_alb ,iopt_snf ,iopt_tbot, iopt_stc, & - iopt_rsf , iopt_soil, iopt_pedo, iopt_crop ,iopt_trs, iopt_diag ) + subroutine noahmp_options(idveg , iopt_crs , iopt_btr , iopt_run , iopt_sfc , iopt_frz , & + iopt_inf, iopt_rad , iopt_alb , iopt_snf , iopt_tbot, iopt_stc , & + iopt_rsf, iopt_soil, iopt_pedo, iopt_crop, iopt_trs , iopt_diag, & + iopt_z0m ) implicit none @@ -10180,6 +10215,7 @@ subroutine noahmp_options(idveg ,iopt_crs ,iopt_btr ,iopt_run ,iopt_sfc integer, intent(in) :: iopt_crop !< crop model option (0->none; 1->liu et al.) integer, intent(in) :: iopt_trs !< thermal roughness scheme option (1->z0h=z0; 2->rb reversed) integer, intent(in) :: iopt_diag !< surface 2m t/q diagnostic approach + integer, intent(in) :: iopt_z0m !< momentum roughness length option ! ------------------------------------------------------------------------------------------------- @@ -10202,6 +10238,7 @@ subroutine noahmp_options(idveg ,iopt_crs ,iopt_btr ,iopt_run ,iopt_sfc opt_crop = iopt_crop opt_trs = iopt_trs opt_diag = iopt_diag + opt_z0m = iopt_z0m end subroutine noahmp_options diff --git a/physics/noahmpdrv.F90 b/physics/noahmpdrv.F90 index 88e75637b..c1200e829 100644 --- a/physics/noahmpdrv.F90 +++ b/physics/noahmpdrv.F90 @@ -451,6 +451,7 @@ subroutine noahmpdrv_run & integer :: iopt_pedo = 1 ! option for pedotransfer function integer :: iopt_crop = 0 ! option for crop model integer :: iopt_gla = 2 ! option for glacier treatment + integer :: iopt_z0m = 2 ! option for z0m treatment ! ! --- local inputs to noah-mp and glacier subroutines; listed in order in noah-mp call @@ -848,7 +849,8 @@ subroutine noahmpdrv_run & call noahmp_options(idveg ,iopt_crs, iopt_btr , iopt_run, iopt_sfc, & iopt_frz, iopt_inf , iopt_rad, iopt_alb, & iopt_snf, iopt_tbot, iopt_stc, iopt_rsf, & - iopt_soil,iopt_pedo, iopt_crop,iopt_trs,iopt_diag) + iopt_soil,iopt_pedo, iopt_crop,iopt_trs, & + iopt_diag,iopt_z0m) if ( vegetation_category == isice_table ) then From 3ca1cb482ff14b5d85ecb9c931ad21907380e192 Mon Sep 17 00:00:00 2001 From: Michael Barlage Date: Mon, 1 May 2023 11:46:36 -0400 Subject: [PATCH 245/380] revert z0m option to original for testing --- physics/noahmpdrv.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/noahmpdrv.F90 b/physics/noahmpdrv.F90 index c1200e829..fb1859cc9 100644 --- a/physics/noahmpdrv.F90 +++ b/physics/noahmpdrv.F90 @@ -451,7 +451,7 @@ subroutine noahmpdrv_run & integer :: iopt_pedo = 1 ! option for pedotransfer function integer :: iopt_crop = 0 ! option for crop model integer :: iopt_gla = 2 ! option for glacier treatment - integer :: iopt_z0m = 2 ! option for z0m treatment + integer :: iopt_z0m = 1 ! option for z0m treatment ! ! --- local inputs to noah-mp and glacier subroutines; listed in order in noah-mp call From c92f164bad27bd6678675981ff569bf563334456 Mon Sep 17 00:00:00 2001 From: Michael Barlage Date: Mon, 1 May 2023 16:37:35 -0400 Subject: [PATCH 246/380] add gfs stability inside noahmp; remove dependence on sfc_diff --- physics/module_sf_noahmplsm.F90 | 226 +++++++++++++++++++++++++++++++- physics/noahmpdrv.F90 | 5 +- 2 files changed, 226 insertions(+), 5 deletions(-) diff --git a/physics/module_sf_noahmplsm.F90 b/physics/module_sf_noahmplsm.F90 index afea081f3..33150852a 100644 --- a/physics/module_sf_noahmplsm.F90 +++ b/physics/module_sf_noahmplsm.F90 @@ -8,7 +8,6 @@ module module_sf_noahmplsm use module_wrf_utl #endif use machine , only : kind_phys -use sfc_diff, only : stability implicit none @@ -5511,11 +5510,234 @@ subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur tvs = tgb/prsik1x * virtfac endif - call stability (zlvlb, zvfun1, gdx, tv1, thv1, ur, z0m, z0h, tvs, grav, thsfc_loc, & + call gfs_stability (zlvlb, zvfun1, gdx, tv1, thv1, ur, z0m, z0h, tvs, grav, thsfc_loc, & rb1, fm,fh,fm10,fh2,cm,ch,stress1,fv) end subroutine sfcdif3 +!== begin gfs_stability ================================================================================== + +subroutine gfs_stability & +! --- inputs: + ( z1, zvfun, gdx, tv1, thv1, wind, z0max, ztmax, tvs, grav, & + thsfc_loc, & +! --- outputs: + rb, fm, fh, fm10, fh2, cm, ch, stress, ustar) + +! Documentation below refers to UTN and STN which are: +! UTN (Unstable Tech Note) : NCEP Office Note 356 +! STN (Stable Tech Note) : NCEP Office Note 321 + +integer, parameter :: kp = kind_phys +real (kind=kind_phys), parameter :: ca=0.4_kind_phys ! ca - von karman constant + +real(kind=kind_phys), intent(in) :: z1 ! height model level +real(kind=kind_phys), intent(in) :: zvfun ! vegetation adjustment factor +real(kind=kind_phys), intent(in) :: gdx ! grid spatial dimension +real(kind=kind_phys), intent(in) :: tv1 ! virtual temperature at model level +real(kind=kind_phys), intent(in) :: thv1 ! virtual potential temperature at model level +real(kind=kind_phys), intent(in) :: wind ! wind speed at model level +real(kind=kind_phys), intent(in) :: z0max ! momentum roughness length +real(kind=kind_phys), intent(in) :: ztmax ! thermal roughness length +real(kind=kind_phys), intent(in) :: tvs ! surface virtual temperature +real(kind=kind_phys), intent(in) :: grav ! local gravity +logical, intent(in) :: thsfc_loc ! use local theta reference flag + +real(kind=kind_phys), intent(out) :: rb ! bulk richardson number [-] +real(kind=kind_phys), intent(out) :: fm ! phi momentum function (UTN 1.1) [-] +real(kind=kind_phys), intent(out) :: fh ! phi heat function (UTN 1.2) [-] +real(kind=kind_phys), intent(out) :: fm10 ! 10-meter phi momentum function [-] +real(kind=kind_phys), intent(out) :: fh2 ! 2-meter phi heat function [-] +real(kind=kind_phys), intent(out) :: cm ! momentum exchange coeficient [-] +real(kind=kind_phys), intent(out) :: ch ! heat exchange coeficient [-] +real(kind=kind_phys), intent(out) :: stress ! surface stress [m2/s2] +real(kind=kind_phys), intent(out) :: ustar ! friction velocity [m/s] + +! --- locals: +real(kind=kind_phys), parameter :: a0 = -3.975 ! UTN 2.37 +real(kind=kind_phys), parameter :: a1 = 12.32 ! UTN 2.37 +real(kind=kind_phys), parameter :: b1 = -7.755 ! UTN 2.37 +real(kind=kind_phys), parameter :: b2 = 6.041 ! UTN 2.37 +real(kind=kind_phys), parameter :: a0p = -7.941 ! UTN 2.38 +real(kind=kind_phys), parameter :: a1p = 24.75 ! UTN 2.38 +real(kind=kind_phys), parameter :: b1p = -8.705 ! UTN 2.38 +real(kind=kind_phys), parameter :: b2p = 7.899 ! UTN 2.38 + +real(kind=kind_phys), parameter :: alpha = 5.0 ! alpha in e.g., STN 1.10 +real(kind=kind_phys), parameter :: alpha4 = 4.0 * alpha ! term in aa +real(kind=kind_phys), parameter :: xkrefsqr = 0.3 ! baseline maximum z/L +real(kind=kind_phys), parameter :: xkmin = 0.05 ! min multiplier for grid size and vegetation +real(kind=kind_phys), parameter :: xkgdx = 3000.0 ! critical grid scale for diffusivity[m^0.5] +real(kind=kind_phys), parameter :: zolmin = -10.0 ! minimum z/L +real(kind=kind_phys), parameter :: zero = 0.0 +real(kind=kind_phys), parameter :: one = 1.0 + +real(kind=kind_phys) :: aa +real(kind=kind_phys) :: aa0 +real(kind=kind_phys) :: bb +real(kind=kind_phys) :: bb0 +real(kind=kind_phys) :: dtv +real(kind=kind_phys) :: adtv +real(kind=kind_phys) :: hl1 +real(kind=kind_phys) :: hl12 +real(kind=kind_phys) :: pm +real(kind=kind_phys) :: ph +real(kind=kind_phys) :: pm10 +real(kind=kind_phys) :: ph2 +real(kind=kind_phys) :: z1i +real(kind=kind_phys) :: fms +real(kind=kind_phys) :: fhs +real(kind=kind_phys) :: hl0 +real(kind=kind_phys) :: hl0inf +real(kind=kind_phys) :: hlinf +real(kind=kind_phys) :: hl110 +real(kind=kind_phys) :: hlt +real(kind=kind_phys) :: hltinf +real(kind=kind_phys) :: olinf +real(kind=kind_phys) :: tem1 +real(kind=kind_phys) :: tem2 +real(kind=kind_phys) :: zolmax + +real(kind=kind_phys) xkzo + +z1i = one / z1 ! inverse of model height + +! +! set background diffusivities with one for gdx >= xkgdx and +! as a function of horizontal grid size for gdx < xkgdx +! (i.e., gdx/xkgdx for gdx < xkgdx) +! + +if(gdx >= xkgdx) then + xkzo = one +else + xkzo = gdx / xkgdx +endif + +tem1 = tv1 - tvs +if(tem1 > zero) then ! for stable case, adjust for vegetation cover + tem2 = xkzo * zvfun + xkzo = min(max(tem2, xkmin), xkzo) +endif + +zolmax = xkrefsqr / sqrt(xkzo) ! maximum z/L + +! compute stability indices (rb and hlinf) + + dtv = thv1 - tvs + adtv = max(abs(dtv),0.001_kp) + dtv = sign(1.0_kp,dtv) * adtv + + if(thsfc_loc) then ! Use local potential temperature + rb = max(-5000.0_kp, (grav+grav) * dtv * z1 & + / ((thv1 + tvs) * wind * wind)) + else ! Use potential temperature referenced to 1000 hPa + rb = max(-5000.0_kp, grav * dtv * z1 & + / (tv1 * wind * wind)) + endif + + tem1 = one / z0max ! 1/z0m + tem2 = one / ztmax ! 1/z0t + fm = log((z0max+z1) * tem1) ! neutral phi_m + fh = log((ztmax+z1) * tem2) ! neutral phi_h + fm10 = log((z0max+10.0_kp) * tem1) ! neutral phi_m at 10 meters + fh2 = log((ztmax+2.0_kp) * tem2) ! neutral phi_h at 2 meters + hlinf = rb * fm * fm / fh ! z/L STN 2.7 + hlinf = min(max(hlinf,zolmin),zolmax) ! z/L, xi in STN/UTN +! +! stable case +! + if (dtv >= zero) then + hl1 = hlinf ! z/L, xi in STN + if(hlinf > 0.25_kp) then ! z/L > 0.25, do two iterations + tem1 = hlinf * z1i ! 1/L + hl0inf = z0max * tem1 ! z0m/z1, zi_0 in STN + hltinf = ztmax * tem1 ! z0t/z1, zi_0 in STN + aa = sqrt(one + alpha4 * hlinf) ! sqrt term of STN 2.16 with z + aa0 = sqrt(one + alpha4 * hl0inf) ! sqrt term of STN 2.16 with z0m + bb = aa ! sqrt term of STN 2.16 with z + bb0 = sqrt(one + alpha4 * hltinf) ! sqrt term of STN 2.16 with z0t + pm = aa0 - aa + log( (aa + one)/(aa0 + one) ) ! psi_m STN 3.11 + ph = bb0 - bb + log( (bb + one)/(bb0 + one) ) ! psi_h STN 3.11 + fms = fm - pm ! phi_m STN 3.10 + fhs = fh - ph ! phi_h STN 3.10 + hl1 = fms * fms * rb / fhs ! z/L iteration STN 3.8 + hl1 = min(hl1, zolmax) ! z/L iteration + endif +! +! second iteration +! + tem1 = hl1 * z1i ! 1/L + hl0 = z0max * tem1 ! z0m/z1 + hlt = ztmax * tem1 ! z0t/z1 + aa = sqrt(one + alpha4 * hl1) ! sqrt term of STN 2.16 with z + aa0 = sqrt(one + alpha4 * hl0) ! sqrt term of STN 2.16 with z0m + bb = aa ! sqrt term of STN 2.16 with z + bb0 = sqrt(one + alpha4 * hlt) ! sqrt term of STN 2.16 with z0t + pm = aa0 - aa + log( (one+aa)/(one+aa0) ) ! psi_m STN 3.11 + ph = bb0 - bb + log( (one+bb)/(one+bb0) ) ! psi_h STN 3.11 + hl110 = hl1 * 10.0_kp * z1i ! 10/L + aa = sqrt(one + alpha4 * hl110) ! sqrt term of STN 2.16 with z=10m + pm10 = aa0 - aa + log( (one+aa)/(one+aa0) ) ! psi_m STN 3.11 with z=10m + hl12 = (hl1+hl1) * z1i ! 2/L +! aa = sqrt(one + alpha4 * hl12) + bb = sqrt(one + alpha4 * hl12) ! sqrt term of STN 2.16 with z=2m + ph2 = bb0 - bb + log( (one+bb)/(one+bb0) ) ! psi_m STN 3.11 with z=2m +! +! unstable case - check for unphysical obukhov length +! see steps in UTN Sec. D +! + else ! dtv < 0 case + + olinf = z1 / hlinf ! z/L, xi in UTN + tem1 = 50.0_kp * z0max ! 50 * z0m, z/L limit for calc methods, see UTN Sec. E + if(abs(olinf) <= tem1) then ! + hlinf = -z1 / tem1 ! + hlinf = max(hlinf, zolmin) + endif +! +! get pm and ph +! + if (hlinf >= -0.5_kp) then + hl1 = hlinf + pm = (a0 + a1*hl1) * hl1 / (one+ (b1+b2*hl1) *hl1) ! psi_m UTN 2.37 + ph = (a0p + a1p*hl1) * hl1 / (one+ (b1p+b2p*hl1)*hl1) ! psi_h UTN 2.38 + hl110 = hl1 * 10.0_kp * z1i ! 10/L + pm10 = (a0 + a1*hl110) * hl110/(one+(b1+b2*hl110)*hl110) ! psi_m UTN 2.37 with z=10m + hl12 = (hl1+hl1) * z1i ! 2/L + ph2 = (a0p + a1p*hl12) * hl12/(one+(b1p+b2p*hl12)*hl12) ! psi_h UTN 2.38 with z=2m + else ! z/L < -0.5 + hl1 = -hlinf ! -z/L + tem1 = one / sqrt(hl1) ! sqrt(-z/L) + pm = log(hl1) + 2.0_kp * sqrt(tem1) - 0.8776_kp ! UTN 2.64, first three terms + ph = log(hl1) + 0.5_kp * tem1 + 1.386_kp ! UTN 2.65, first three terms + hl110 = hl1 * 10.0_kp * z1i ! 10/L + pm10 = log(hl110) + 2.0_kp/sqrt(sqrt(hl110)) - 0.8776_kp ! psi_m UTN 2.64 with z=10m + hl12 = (hl1+hl1) * z1i ! 2/L + ph2 = log(hl12) + 0.5_kp / sqrt(hl12) + 1.386_kp ! psi_h UTN 2.65 with z=2m + endif + + endif ! end of if (dtv >= 0 ) then loop +! +! finish the exchange coefficient computation to provide fm and fh +! + fm = fm - pm ! phi_m + fh = fh - ph ! phi_h + fm10 = fm10 - pm10 ! phi_m at 10m + fh2 = fh2 - ph2 ! phi_h at 2m + cm = ca * ca / (fm * fm) ! momentum exchange coef = k^2/phi_m^2 + ch = ca * ca / (fm * fh) ! heat exchange coef = k^2/phi_m/phi_h + tem1 = 0.00001_kp/z1 ! minimum exhange coef (?) + cm = max(cm, tem1) + ch = max(ch, tem1) + stress = cm * wind * wind ! surface stress = Cm*U*U + ustar = sqrt(stress) ! friction velocity + + return +!................................. + end subroutine gfs_stability +!--------------------------------- + !== begin thermalz0 !================================================================================== diff --git a/physics/noahmpdrv.F90 b/physics/noahmpdrv.F90 index fb1859cc9..d232b759f 100644 --- a/physics/noahmpdrv.F90 +++ b/physics/noahmpdrv.F90 @@ -203,8 +203,7 @@ subroutine noahmpdrv_run & use machine , only : kind_phys use funcphys, only : fpvs - use sfc_diff, only : stability -! use module_sf_noahmplsm + use module_sf_noahmplsm, only : gfs_stability use module_sf_noahmp_glacier use noahmp_tables @@ -1189,7 +1188,7 @@ subroutine noahmpdrv_run & ! if ( .not. do_mynnsfclay) then !GFS sfcdiff if ( iopt_sfc .ne. 4 ) then !GFS sfcdiff - call stability & + call gfs_stability & (zf(i), zvfun(i), gdx, virtual_temperature, vptemp,wind(i), z0_total, z0h_total, & tvs1, con_g, thsfc_loc, & rb1(i), fm1(i), fh1(i), fm101(i), fh21(i), cm(i), ch(i), stress1(i), ustar1(i)) From 5c438fd3622b42a5f621f89497d8bc054264a402 Mon Sep 17 00:00:00 2001 From: Michael Barlage Date: Mon, 1 May 2023 17:22:11 -0400 Subject: [PATCH 247/380] add z0m to hvt ratio to mptable --- physics/module_sf_noahmplsm.F90 | 6 ++---- physics/noahmp_tables.f90 | 12 +++++++++--- physics/noahmpdrv.F90 | 3 ++- physics/noahmptable.tbl | 2 ++ 4 files changed, 15 insertions(+), 8 deletions(-) diff --git a/physics/module_sf_noahmplsm.F90 b/physics/module_sf_noahmplsm.F90 index 33150852a..b6e751e31 100644 --- a/physics/module_sf_noahmplsm.F90 +++ b/physics/module_sf_noahmplsm.F90 @@ -219,6 +219,7 @@ module module_sf_noahmplsm real (kind=kind_phys) :: z0mvt !< momentum roughness length (m) real (kind=kind_phys) :: hvt !< top of canopy (m) real (kind=kind_phys) :: hvb !< bottom of canopy (m) + real (kind=kind_phys) :: z0mhvt !< ratio of z0m to hvt real (kind=kind_phys) :: den !< tree density (no. of trunks per m2) real (kind=kind_phys) :: rc !< tree crown radius (m) real (kind=kind_phys) :: mfsno !< snowmelt m parameter () @@ -1980,7 +1981,6 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in real (kind=kind_phys) :: canopy_density_factor real (kind=kind_phys) :: vai_limited - real (kind=kind_phys) :: z0m_hvt_ratio(20) !jref:end @@ -2023,8 +2023,6 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in canopy_density_factor = 1.0 vai_limited = 2.0 - z0m_hvt_ratio = (/ 0.545,0.055,0.047,0.050,0.050,0.182,0.545,0.046,0.050,0.120, & - 0.060,0.075,0.067,0.093,0.000,0.000,0.000,0.075,0.100,0.060 /) ! @@ -2075,7 +2073,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in elseif(opt_z0m == 2) then - z0m = z0m_hvt_ratio(vegtyp) * parameters%hvt + z0m = parameters%z0mhvt * parameters%hvt zpd = 0.65 * parameters%hvt if(vegtyp /= 13) then vai_limited = min(vai, 2.0) diff --git a/physics/noahmp_tables.f90 b/physics/noahmp_tables.f90 index 0e44b3cfc..cc7856af6 100644 --- a/physics/noahmp_tables.f90 +++ b/physics/noahmp_tables.f90 @@ -44,6 +44,7 @@ module noahmp_tables real :: z0mvt_table(mvt) !< momentum roughness length (m) real :: hvt_table(mvt) !< top of canopy (m) real :: hvb_table(mvt) !< bottom of canopy (m) + real :: z0mhvt_table(mvt) !< ratio of z0m to hvt real :: den_table(mvt) !< tree density (no. of trunks per m2) real :: rc_table(mvt) !< tree crown radius (m) real :: mfsno_table(mvt) !< snowmelt curve parameter () @@ -323,7 +324,8 @@ subroutine read_mp_table_parameters sai_sep, sai_oct, sai_nov, sai_dec, lai_jan, lai_feb, lai_mar, lai_apr, & lai_may, lai_jun, lai_jul, lai_aug, lai_sep, lai_oct, lai_nov, lai_dec, & rhol_vis, rhol_nir, rhos_vis, rhos_nir, taul_vis, taul_nir, taus_vis, taus_nir,& - ch2op, dleaf, z0mvt, hvt, hvb, den, rc, mfsno, scffac, xl, cwpvt, c3psn, kc25, & + ch2op, dleaf, z0mvt, hvt, hvb, z0mhvt, & + den, rc, mfsno, scffac, xl, cwpvt, c3psn, kc25, & akc, ko25, ako, avcmx, aqe, ltovrc, dilefc, dilefw, rmf25, sla, fragr, tmin, & vcmx25, tdlef, bp, mp, qe25, rms25, rmr25, arm, folnmx, wdpool, wrrat, mrp, & nroot, rgl, rs, hs, topt, rsmax, rtovrc, rswoodc, bf, wstrc, laimin, & @@ -331,7 +333,8 @@ subroutine read_mp_table_parameters namelist / noahmp_usgs_veg_categories / veg_dataset_description, nveg namelist / noahmp_usgs_parameters / isurban, iswater, isbarren, isice, iscrop, eblforest, natural, & lcz_1, lcz_2, lcz_3, lcz_4, lcz_5, lcz_6, lcz_7, lcz_8, lcz_9, lcz_10, lcz_11, & - ch2op, dleaf, z0mvt, hvt, hvb, den, rc, mfsno, scffac, xl, cwpvt, c3psn, kc25, & + ch2op, dleaf, z0mvt, hvt, hvb, z0mhvt, & + den, rc, mfsno, scffac, xl, cwpvt, c3psn, kc25, & akc, ko25, ako, avcmx, aqe, ltovrc, dilefc, dilefw, rmf25, sla, fragr, tmin, & vcmx25, tdlef, bp, mp, qe25, rms25, rmr25, arm, folnmx, wdpool, wrrat, mrp, & nroot, rgl, rs, hs, topt, rsmax, rtovrc, rswoodc, bf, wstrc, laimin, & @@ -343,7 +346,8 @@ subroutine read_mp_table_parameters namelist / noahmp_modis_veg_categories / veg_dataset_description, nveg namelist / noahmp_modis_parameters / isurban, iswater, isbarren, isice, iscrop, eblforest, natural, & lcz_1, lcz_2, lcz_3, lcz_4, lcz_5, lcz_6, lcz_7, lcz_8, lcz_9, lcz_10, lcz_11, & - ch2op, dleaf, z0mvt, hvt, hvb, den, rc, mfsno, scffac, xl, cwpvt, c3psn, kc25, & + ch2op, dleaf, z0mvt, hvt, hvb, z0mhvt, & + den, rc, mfsno, scffac, xl, cwpvt, c3psn, kc25, & akc, ko25, ako, avcmx, aqe, ltovrc, dilefc, dilefw, rmf25, sla, fragr, tmin, & vcmx25, tdlef, bp, mp, qe25, rms25, rmr25, arm, folnmx, wdpool, wrrat, mrp, & nroot, rgl, rs, hs, topt, rsmax, rtovrc, rswoodc, bf, wstrc, laimin, & @@ -502,6 +506,7 @@ subroutine read_mp_table_parameters z0mvt_table = -1.0e36 hvt_table = -1.0e36 hvb_table = -1.0e36 + z0mhvt_table = -1.0e36 den_table = -1.0e36 rc_table = -1.0e36 mfsno_table = -1.0e36 @@ -814,6 +819,7 @@ subroutine read_mp_table_parameters z0mvt_table (1:nveg) = z0mvt (1:nveg) hvt_table (1:nveg) = hvt (1:nveg) hvb_table (1:nveg) = hvb (1:nveg) + z0mhvt_table (1:nveg) = z0mhvt (1:nveg) den_table (1:nveg) = den (1:nveg) rc_table (1:nveg) = rc (1:nveg) mfsno_table (1:nveg) = mfsno (1:nveg) diff --git a/physics/noahmpdrv.F90 b/physics/noahmpdrv.F90 index d232b759f..aad0d1ca5 100644 --- a/physics/noahmpdrv.F90 +++ b/physics/noahmpdrv.F90 @@ -450,7 +450,7 @@ subroutine noahmpdrv_run & integer :: iopt_pedo = 1 ! option for pedotransfer function integer :: iopt_crop = 0 ! option for crop model integer :: iopt_gla = 2 ! option for glacier treatment - integer :: iopt_z0m = 1 ! option for z0m treatment + integer :: iopt_z0m = 2 ! option for z0m treatment ! ! --- local inputs to noah-mp and glacier subroutines; listed in order in noah-mp call @@ -1335,6 +1335,7 @@ subroutine transfer_mp_parameters (vegtype,soiltype,slopetype, & parameters%z0mvt = z0mvt_table(vegtype) !momentum roughness length (m) parameters%hvt = hvt_table(vegtype) !top of canopy (m) parameters%hvb = hvb_table(vegtype) !bottom of canopy (m) + parameters%z0mhvt = z0mhvt_table(vegtype) !momentum roughness length (m) parameters%den = den_table(vegtype) !tree density (no. of trunks per m2) parameters%rc = rc_table(vegtype) !tree crown radius (m) parameters%mfsno = mfsno_table(vegtype) !snowmelt m parameter () diff --git a/physics/noahmptable.tbl b/physics/noahmptable.tbl index 02e59b37a..add1737be 100644 --- a/physics/noahmptable.tbl +++ b/physics/noahmptable.tbl @@ -59,6 +59,7 @@ z0mvt = 1.00, 0.15, 0.15, 0.15, 0.14, 0.50, 0.12, 0.06, 0.09, 0.50, 0.80, 0.85, 1.10, 1.09, 0.80, 0.00, 0.12, 0.50, 0.00, 0.10, 0.30, 0.20, 0.03, 0.00, 0.01, 0.00, 0.00, hvt = 15.0, 2.00, 2.00, 2.00, 1.50, 8.00, 1.00, 1.10, 1.10, 10.0, 16.0, 18.0, 20.0, 20.0, 16.0, 0.00, 0.50, 10.0, 0.00, 0.50, 4.00, 2.00, 0.50, 0.00, 0.10, 0.00, 0.00, hvb = 1.00, 0.10, 0.10, 0.10, 0.10, 0.15, 0.05, 0.10, 0.10, 0.10, 11.5, 7.00, 8.00, 8.50, 10.0, 0.00, 0.05, 0.10, 0.00, 0.10, 0.10, 0.10, 0.10, 0.00, 0.10, 0.00, 0.00, + z0mhvt= 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.00, 0.05, 0.05, 0.05, 0.05, 0.00, 0.05, 0.00, 0.00, den = 0.01, 25.0, 25.0, 25.0, 25.0, 25.0, 100., 10.0, 10.0, 0.02, 0.10, 0.28, 0.02, 0.28, 0.10, 0.01, 10.0, 0.10, 0.01, 1.00, 1.00, 1.00, 1.00, 0.00, 0.01, 0.01, 0.01, rc = 1.00, 0.08, 0.08, 0.08, 0.08, 0.08, 0.03, 0.12, 0.12, 3.00, 1.40, 1.20, 3.60, 1.20, 1.40, 0.01, 0.10, 1.40, 0.01, 0.30, 0.30, 0.30, 0.30, 0.00, 0.01, 0.01, 0.01, !mfsno = 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, @@ -218,6 +219,7 @@ z0mvt = 1.09, 1.10, 0.85, 0.80, 0.80, 0.20, 0.06, 0.60, 0.50, 0.12, 0.30, 0.15, 1.00, 0.14, 0.00, 0.00, 0.00, 0.30, 0.20, 0.03, hvt = 20.0, 20.0, 18.0, 16.0, 16.0, 1.10, 1.10, 13.0, 10.0, 1.00, 5.00, 2.00, 15.0, 1.50, 0.00, 0.00, 0.00, 4.00, 2.00, 0.50, hvb = 8.50, 8.00, 7.00, 11.5, 10.0, 0.10, 0.10, 0.10, 0.10, 0.05, 0.10, 0.10, 1.00, 0.10, 0.00, 0.00, 0.00, 0.30, 0.20, 0.10, + z0mhvt= 0.0545, 0.055, 0.047, 0.050, 0.050, 0.182, 0.0545, 0.046, 0.050, 0.120, 0.060, 0.075, 0.067, 0.093, 0.000, 0.000, 0.000, 0.075, 0.100, 0.060, den = 0.28, 0.02, 0.28, 0.10, 0.10, 10.0, 10.0, 10.0, 0.02, 100., 5.05, 25.0, 0.01, 25.0, 0.00, 0.01, 0.01, 1.00, 1.00, 1.00, rc = 1.20, 3.60, 1.20, 1.40, 1.40, 0.12, 0.12, 0.12, 3.00, 0.03, 0.75, 0.08, 1.00, 0.08, 0.00, 0.01, 0.01, 0.30, 0.30, 0.30, !mfsno = 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, From 54b406ef06b3be00e5002187b507d1c19072d132 Mon Sep 17 00:00:00 2001 From: Michael Barlage Date: Mon, 1 May 2023 17:38:15 -0400 Subject: [PATCH 248/380] use blumel99 approach for bare soil for chen09 trs option --- physics/module_sf_noahmplsm.F90 | 19 +++++++------------ 1 file changed, 7 insertions(+), 12 deletions(-) diff --git a/physics/module_sf_noahmplsm.F90 b/physics/module_sf_noahmplsm.F90 index b6e751e31..51e7fe3f9 100644 --- a/physics/module_sf_noahmplsm.F90 +++ b/physics/module_sf_noahmplsm.F90 @@ -5846,10 +5846,10 @@ subroutine thermalz0(parameters, fveg, z0m, z0mg, zlvl, g_sigma = fveg**blumel_gamma + fveg*(1.0-fveg)*blumel_zeta ! Blumel99 eqn 22 cdmn = g_sigma*cdmn_v + (1.0-g_sigma)*cdmn_g ! Blumel99 eqn 21 - z0m_out = (zlvl - ezpd)*exp(-0.4/sqrt(cdmn)) ! Blumel99 eqn 24 + z0m_out = (zlvl - ezpd)*exp(-0.4/sqrt(cdmn)) ! Blumel99 eqn 24 kb_sigma_fveg = c_sigma_fveg/log((zlvl-ezpd)/z0m_out) - & log((zlvl-ezpd)/z0m_out) ! Blumel99 eqn 34 - z0h_out = z0m_out/exp(kb_sigma_fveg) + z0h_out = z0m_out/exp(kb_sigma_fveg) endif @@ -5861,11 +5861,6 @@ subroutine thermalz0(parameters, fveg, z0m, z0mg, zlvl, z0h_out = z0m_out - elseif (opt_trs == chen09) then - - czil = 10.0 ** (- 0.4 * parameters%hvt) - z0h_out = z0m_out * exp(-czil*0.4*258.2*sqrt(ustarx*z0m_out)) - elseif (opt_trs == tessel) then if (vegtyp <= 5) then @@ -5874,13 +5869,13 @@ subroutine thermalz0(parameters, fveg, z0m, z0mg, zlvl, z0h_out = z0m_out * 0.01 endif - elseif (opt_trs == blumel99) then + elseif (opt_trs == blumel99 .or. opt_trs == chen09) then reyn = ustarx*z0m_out/viscosity ! Blumel99 eqn 36c if (reyn > 2.0) then - kb_sigma_f0 = 2.46*reyn**0.25 - log(7.4) ! Blumel99 eqn 36a + kb_sigma_f0 = 2.46*reyn**0.25 - log(7.4) ! Blumel99 eqn 36a else - kb_sigma_f0 = - log(0.397) ! Blumel99 eqn 36b + kb_sigma_f0 = - log(0.397) ! Blumel99 eqn 36b endif z0h_out = max(z0m_out/exp(kb_sigma_f0),1.0e-6) @@ -5912,8 +5907,8 @@ subroutine thermalz0(parameters, fveg, z0m, z0mg, zlvl, elseif (opt_trs == blumel99) then - sigma_a = 1.0 - (0.5/(0.5+vaie)) * exp(-vaie**2/8.0) ! Blumel99 eqn 8 - kb_sigma_f1 = 16.4 * (sigma_a*vaie**3)**(-0.25) * & ! Blumel99 eqn 38 + sigma_a = 1.0 - (0.5/(0.5+vaie)) * exp(-vaie**2/8.0) ! Blumel99 eqn 8 + kb_sigma_f1 = 16.4 * (sigma_a*vaie**3)**(-0.25) * & ! Blumel99 eqn 38 sqrt(parameters%dleaf*ur/log((zlvl-zpd)/z0m_out)) z0h_out = z0m_out/exp(kb_sigma_f1) c_sigma_f1 = log((zlvl-zpd)/z0m_out)*(log((zlvl-zpd)/z0m_out)+kb_sigma_f1) ! Blumel99 eqn 39 From 591791cb1515b4c9087bacbbba9a1f0b6319a770 Mon Sep 17 00:00:00 2001 From: Michael Barlage Date: Mon, 1 May 2023 17:43:52 -0400 Subject: [PATCH 249/380] use log averaging for z0m --- physics/module_sf_noahmplsm.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/module_sf_noahmplsm.F90 b/physics/module_sf_noahmplsm.F90 index 51e7fe3f9..28e6460a2 100644 --- a/physics/module_sf_noahmplsm.F90 +++ b/physics/module_sf_noahmplsm.F90 @@ -5814,19 +5814,19 @@ subroutine thermalz0(parameters, fveg, z0m, z0mg, zlvl, if (opt_trs == z0heqz0m) then - z0m_out = fveg * z0m + (1.0 - fveg) * z0mg ! probably should be log + z0m_out = exp(fveg * log(z0m) + (1.0 - fveg) * log(z0mg)) z0h_out = z0m_out elseif (opt_trs == chen09) then - z0m_out = fveg * z0m + (1.0 - fveg) * z0mg ! probably should be log + z0m_out = exp(fveg * log(z0m) + (1.0 - fveg) * log(z0mg)) czil = 10.0 ** (- 0.4 * parameters%hvt) z0h_out = fveg * z0m * exp(-czil*0.4*258.2*sqrt(ustarx*z0m )) & + (1.0 - fveg) * z0mg * exp(-czil*0.4*258.2*sqrt(ustarx*z0mg)) elseif (opt_trs == tessel) then - z0m_out = fveg * z0m + (1.0 - fveg) * z0mg ! probably should be log + z0m_out = exp(fveg * log(z0m) + (1.0 - fveg) * log(z0mg)) if (vegtyp <= 5) then z0h_out = fveg * z0m + (1.0 - fveg) * z0mg * 0.1 else From e0460595b81b80c2c5a5c6a25df62cdb54500827 Mon Sep 17 00:00:00 2001 From: Michael Barlage Date: Mon, 1 May 2023 17:49:32 -0400 Subject: [PATCH 250/380] modify compositing for trs = chen09 and tessel --- physics/module_sf_noahmplsm.F90 | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) diff --git a/physics/module_sf_noahmplsm.F90 b/physics/module_sf_noahmplsm.F90 index 28e6460a2..090e120dd 100644 --- a/physics/module_sf_noahmplsm.F90 +++ b/physics/module_sf_noahmplsm.F90 @@ -5820,17 +5820,25 @@ subroutine thermalz0(parameters, fveg, z0m, z0mg, zlvl, elseif (opt_trs == chen09) then z0m_out = exp(fveg * log(z0m) + (1.0 - fveg) * log(z0mg)) - czil = 10.0 ** (- 0.4 * parameters%hvt) - z0h_out = fveg * z0m * exp(-czil*0.4*258.2*sqrt(ustarx*z0m )) & - + (1.0 - fveg) * z0mg * exp(-czil*0.4*258.2*sqrt(ustarx*z0mg)) + czil = 10.0 ** (- 0.4 * parameters%hvt) + + reyn = ustarx*z0m_out/viscosity ! Blumel99 eqn 36c + if (reyn > 2.0) then + kb_sigma_f0 = 2.46*reyn**0.25 - log(7.4) ! Blumel99 eqn 36a + else + kb_sigma_f0 = - log(0.397) ! Blumel99 eqn 36b + endif + + z0h_out = exp( fveg * log(z0m * exp(-czil*0.4*258.2*sqrt(ustarx*z0m))) + & + (1.0 - fveg) * log(max(z0m/exp(kb_sigma_f0),1.0e-6)) ) elseif (opt_trs == tessel) then z0m_out = exp(fveg * log(z0m) + (1.0 - fveg) * log(z0mg)) if (vegtyp <= 5) then - z0h_out = fveg * z0m + (1.0 - fveg) * z0mg * 0.1 + z0h_out = fveg * log(z0m) + (1.0 - fveg) * log(z0mg * 0.1) else - z0h_out = fveg * z0m * 0.01 + (1.0 - fveg) * z0mg * 0.1 + z0h_out = fveg * log(z0m * 0.01) + (1.0 - fveg) * log(z0mg * 0.1) endif elseif (opt_trs == blumel99) then From 8ccdf650e0035ac367cce0443e5c2e6f4a09eaa1 Mon Sep 17 00:00:00 2001 From: Michael Barlage Date: Mon, 1 May 2023 17:51:55 -0400 Subject: [PATCH 251/380] add limits to rb --- physics/module_sf_noahmplsm.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/physics/module_sf_noahmplsm.F90 b/physics/module_sf_noahmplsm.F90 index 090e120dd..48d5024cf 100644 --- a/physics/module_sf_noahmplsm.F90 +++ b/physics/module_sf_noahmplsm.F90 @@ -5028,8 +5028,7 @@ subroutine ragrb(parameters,iter ,vai ,rhoair ,hg ,tah , & !in tmprb = cwpc*50. / (1. - exp(-cwpc/2.)) rb = tmprb * sqrt(parameters%dleaf/uc) - rb = max(rb,20.0) -! rb = 200 + rb = min(max(rb, 5.0),50.0) ! limit rb to 5-50, typically rb<50 end subroutine ragrb From 60fb0e81846a54d5acb3e6fce6ba74f9ae34fb85 Mon Sep 17 00:00:00 2001 From: Michael Barlage Date: Mon, 1 May 2023 17:57:28 -0400 Subject: [PATCH 252/380] lower glacier snow limit to 100mm --- physics/module_sf_noahmp_glacier.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/module_sf_noahmp_glacier.F90 b/physics/module_sf_noahmp_glacier.F90 index bd6b016f1..7b7512fa4 100644 --- a/physics/module_sf_noahmp_glacier.F90 +++ b/physics/module_sf_noahmp_glacier.F90 @@ -2646,9 +2646,9 @@ subroutine snowwater_glacier (nsnow ,nsoil ,imelt ,dt ,sfctmp , & !in !to obtain equilibrium state of snow in glacier region - if(sneqv > 2000.) then ! 2000 mm -> maximum water depth + if(sneqv > 100.) then ! 100 mm -> maximum water depth bdsnow = snice(0) / dzsnso(0) - snoflow = (sneqv - 2000.) + snoflow = (sneqv - 100.) snice(0) = snice(0) - snoflow dzsnso(0) = dzsnso(0) - snoflow/bdsnow snoflow = snoflow / dt From 63aed7ca255f8b420ce50523c73a79c51294dd21 Mon Sep 17 00:00:00 2001 From: Michael Barlage Date: Mon, 1 May 2023 17:59:44 -0400 Subject: [PATCH 253/380] bug fix for mixing ratio calculation in canres --- physics/module_sf_noahmplsm.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/module_sf_noahmplsm.F90 b/physics/module_sf_noahmplsm.F90 index 48d5024cf..38f7313e6 100644 --- a/physics/module_sf_noahmplsm.F90 +++ b/physics/module_sf_noahmplsm.F90 @@ -6179,7 +6179,7 @@ subroutine canres (parameters,par ,sfctmp,rcsoil ,eah ,sfcprs , & !in ! compute q2 and q2sat q2 = 0.622 * eah / (sfcprs - 0.378 * eah) !specific humidity [kg/kg] - q2 = q2 / (1.0 + q2) !mixing ratio [kg/kg] + q2 = q2 / (1.0 - q2) !mixing ratio [kg/kg] call calhum(parameters,sfctmp, sfcprs, q2sat, dqsdt2) From 12d8ab54d5aa33f22bab21cbf0186891acc2ab2b Mon Sep 17 00:00:00 2001 From: Michael Barlage Date: Mon, 1 May 2023 18:06:16 -0400 Subject: [PATCH 254/380] fix bug in infil for infiltration limit --- physics/module_sf_noahmplsm.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/module_sf_noahmplsm.F90 b/physics/module_sf_noahmplsm.F90 index 38f7313e6..22e177912 100644 --- a/physics/module_sf_noahmplsm.F90 +++ b/physics/module_sf_noahmplsm.F90 @@ -8635,7 +8635,7 @@ subroutine infil (parameters,nsoil ,dt ,zsoil ,sh2o ,sice , & !in call wdfcnd2 (parameters,wdf,wcnd,sh2o(1),sicemax,1) infmax = max (infmax,wcnd) - infmax = min (infmax,px) + infmax = min (infmax,px/dt) runsrf= max(0., qinsur - infmax) pddum = qinsur - runsrf From 9525a1650b804e09b95a8f1059ea881dc80a0b20 Mon Sep 17 00:00:00 2001 From: Michael Barlage Date: Mon, 1 May 2023 18:15:40 -0400 Subject: [PATCH 255/380] add canopy heat to mptable for tuning --- physics/module_sf_noahmplsm.F90 | 3 ++- physics/noahmp_tables.f90 | 9 ++++++--- physics/noahmpdrv.F90 | 1 + physics/noahmptable.tbl | 3 +++ 4 files changed, 12 insertions(+), 4 deletions(-) diff --git a/physics/module_sf_noahmplsm.F90 b/physics/module_sf_noahmplsm.F90 index 22e177912..336ae5a26 100644 --- a/physics/module_sf_noahmplsm.F90 +++ b/physics/module_sf_noahmplsm.F90 @@ -224,6 +224,7 @@ module module_sf_noahmplsm real (kind=kind_phys) :: rc !< tree crown radius (m) real (kind=kind_phys) :: mfsno !< snowmelt m parameter () real (kind=kind_phys) :: scffac !< snow cover factor (m) + real (kind=kind_phys) :: cbiom !< canopy biomass heat capacity parameter (m) real (kind=kind_phys) :: saim(12) !< monthly stem area index, one-sided real (kind=kind_phys) :: laim(12) !< monthly leaf area index, one-sided real (kind=kind_phys) :: sla !< single-side leaf area per kg [m2/kg] @@ -4245,7 +4246,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & end if ! canopy heat capacity - hcv = 0.02*vaie*cwat + canliq*cwat/denh2o + canice*cice/denice !j/m2/k + hcv = parameters%cbiom*vaie*cwat + canliq*cwat/denh2o + canice*cice/denice !j/m2/k b = sav-irc-shc-evc-tr+pahv !additional w/m2 ! a = fveg*(4.*cir*tv**3 + csh + (cev+ctr)*destv) !volumetric heat capacity diff --git a/physics/noahmp_tables.f90 b/physics/noahmp_tables.f90 index cc7856af6..de207d0cc 100644 --- a/physics/noahmp_tables.f90 +++ b/physics/noahmp_tables.f90 @@ -49,6 +49,7 @@ module noahmp_tables real :: rc_table(mvt) !< tree crown radius (m) real :: mfsno_table(mvt) !< snowmelt curve parameter () real :: scffac_table(mvt) !< snow cover factor (m) + real :: cbiom_table(mvt) !< canopy biomass heat capacity parameter (m) real :: saim_table(mvt,12) !< monthly stem area index, one-sided real :: laim_table(mvt,12) !< monthly leaf area index, one-sided real :: sla_table(mvt) !< single-side leaf area per kg [m2/kg] @@ -325,7 +326,7 @@ subroutine read_mp_table_parameters lai_may, lai_jun, lai_jul, lai_aug, lai_sep, lai_oct, lai_nov, lai_dec, & rhol_vis, rhol_nir, rhos_vis, rhos_nir, taul_vis, taul_nir, taus_vis, taus_nir,& ch2op, dleaf, z0mvt, hvt, hvb, z0mhvt, & - den, rc, mfsno, scffac, xl, cwpvt, c3psn, kc25, & + den, rc, mfsno, scffac, cbiom, xl, cwpvt, c3psn, kc25, & akc, ko25, ako, avcmx, aqe, ltovrc, dilefc, dilefw, rmf25, sla, fragr, tmin, & vcmx25, tdlef, bp, mp, qe25, rms25, rmr25, arm, folnmx, wdpool, wrrat, mrp, & nroot, rgl, rs, hs, topt, rsmax, rtovrc, rswoodc, bf, wstrc, laimin, & @@ -334,7 +335,7 @@ subroutine read_mp_table_parameters namelist / noahmp_usgs_parameters / isurban, iswater, isbarren, isice, iscrop, eblforest, natural, & lcz_1, lcz_2, lcz_3, lcz_4, lcz_5, lcz_6, lcz_7, lcz_8, lcz_9, lcz_10, lcz_11, & ch2op, dleaf, z0mvt, hvt, hvb, z0mhvt, & - den, rc, mfsno, scffac, xl, cwpvt, c3psn, kc25, & + den, rc, mfsno, scffac, cbiom, xl, cwpvt, c3psn, kc25, & akc, ko25, ako, avcmx, aqe, ltovrc, dilefc, dilefw, rmf25, sla, fragr, tmin, & vcmx25, tdlef, bp, mp, qe25, rms25, rmr25, arm, folnmx, wdpool, wrrat, mrp, & nroot, rgl, rs, hs, topt, rsmax, rtovrc, rswoodc, bf, wstrc, laimin, & @@ -347,7 +348,7 @@ subroutine read_mp_table_parameters namelist / noahmp_modis_parameters / isurban, iswater, isbarren, isice, iscrop, eblforest, natural, & lcz_1, lcz_2, lcz_3, lcz_4, lcz_5, lcz_6, lcz_7, lcz_8, lcz_9, lcz_10, lcz_11, & ch2op, dleaf, z0mvt, hvt, hvb, z0mhvt, & - den, rc, mfsno, scffac, xl, cwpvt, c3psn, kc25, & + den, rc, mfsno, scffac, cbiom, xl, cwpvt, c3psn, kc25, & akc, ko25, ako, avcmx, aqe, ltovrc, dilefc, dilefw, rmf25, sla, fragr, tmin, & vcmx25, tdlef, bp, mp, qe25, rms25, rmr25, arm, folnmx, wdpool, wrrat, mrp, & nroot, rgl, rs, hs, topt, rsmax, rtovrc, rswoodc, bf, wstrc, laimin, & @@ -511,6 +512,7 @@ subroutine read_mp_table_parameters rc_table = -1.0e36 mfsno_table = -1.0e36 scffac_table = -1.0e36 + cbiom_table = -1.0e36 rhol_table = -1.0e36 rhos_table = -1.0e36 taul_table = -1.0e36 @@ -824,6 +826,7 @@ subroutine read_mp_table_parameters rc_table (1:nveg) = rc (1:nveg) mfsno_table (1:nveg) = mfsno (1:nveg) scffac_table (1:nveg) = scffac (1:nveg) + cbiom_table (1:nveg) = cbiom (1:nveg) xl_table (1:nveg) = xl (1:nveg) cwpvt_table (1:nveg) = cwpvt (1:nveg) c3psn_table (1:nveg) = c3psn (1:nveg) diff --git a/physics/noahmpdrv.F90 b/physics/noahmpdrv.F90 index aad0d1ca5..6831d17a2 100644 --- a/physics/noahmpdrv.F90 +++ b/physics/noahmpdrv.F90 @@ -1340,6 +1340,7 @@ subroutine transfer_mp_parameters (vegtype,soiltype,slopetype, & parameters%rc = rc_table(vegtype) !tree crown radius (m) parameters%mfsno = mfsno_table(vegtype) !snowmelt m parameter () parameters%scffac = scffac_table(vegtype) !snow cover factor + parameters%cbiom = cbiom_table(vegtype) !canopy biomass heat capacity parameter (m) parameters%saim = saim_table(vegtype,:) !monthly stem area index, one-sided parameters%laim = laim_table(vegtype,:) !monthly leaf area index, one-sided parameters%sla = sla_table(vegtype) !single-side leaf area per kg [m2/kg] diff --git a/physics/noahmptable.tbl b/physics/noahmptable.tbl index add1737be..3ffd5b532 100644 --- a/physics/noahmptable.tbl +++ b/physics/noahmptable.tbl @@ -67,6 +67,7 @@ mfsno = 4.00, 3.00, 3.00, 3.00, 4.00, 4.00, 2.00, 2.00, 2.00, 2.00, 1.00, 1.00, 1.00, 1.00, 1.00, 3.00, 3.00, 3.00, 3.00, 3.50, 3.50, 3.50, 3.50, 2.50, 3.50, 3.50, 3.50, ! c. he 12/17/2020: optimized snow cover factor (m) in scf formulation to replace original constant 2.5*z0,z0=0.002m, based on evaluation with snotel swe and modis scf, surface albedo scffac= 0.042, 0.014, 0.014, 0.014, 0.026, 0.026, 0.020, 0.018, 0.016, 0.020, 0.008, 0.008, 0.008, 0.008, 0.008, 0.030, 0.020, 0.020, 0.016, 0.030, 0.030, 0.030, 0.030, 0.030, 0.030, 0.030, 0.030, + cbiom = 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, ! row 1: vis ! row 2: near ir @@ -228,6 +229,8 @@ ! c. he 12/17/2020: optimized snow cover factor (m) in scf formulation to replace original constant 2.5*z0,z0=0.002m, based on evaluation with snotel swe and modis scf, surface albedo ! scffac = 0.008, 0.008, 0.008, 0.008, 0.008, 0.016, 0.016, 0.020, 0.020, 0.020, 0.020, 0.014, 0.042, 0.026, 0.030, 0.016, 0.030, 0.030, 0.030, 0.030, scffac = 0.005, 0.005, 0.005, 0.005, 0.005, 0.008, 0.008, 0.010, 0.010, 0.010, 0.010, 0.007, 0.021, 0.013, 0.015, 0.008, 0.015, 0.015, 0.015, 0.015, + cbiom = 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, + ! row 1: vis ! row 2: near ir rhol_vis=0.07, 0.10, 0.07, 0.10, 0.10, 0.07, 0.07, 0.07, 0.10, 0.11, 0.105, 0.11, 0.00, 0.11, 0.00, 0.00, 0.00, 0.10, 0.10, 0.10, From 6ab1b969002d265d0a82acd5f2fb261a390d3633 Mon Sep 17 00:00:00 2001 From: Michael Barlage Date: Mon, 1 May 2023 18:19:41 -0400 Subject: [PATCH 256/380] add two changes missed in previous update --- physics/module_sf_noahmplsm.F90 | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/physics/module_sf_noahmplsm.F90 b/physics/module_sf_noahmplsm.F90 index 336ae5a26..67e24091e 100644 --- a/physics/module_sf_noahmplsm.F90 +++ b/physics/module_sf_noahmplsm.F90 @@ -9103,7 +9103,8 @@ subroutine groundwater(parameters,nsnow ,nsoil ,dt ,sice ,zsoil , & !in fff = parameters%bexp(iwt) / 3.0 ! calibratable, c.he changed based on gy niu's update rsbmx = hk(iwt) * 1.0e3 * exp(3.0) ! mm/s, calibratable, c.he changed based on gy niu's update - qdis = (1.0-fcrmax)*rsbmx*exp(-parameters%timean)*exp(-fff*(zwt-2.0)) +! qdis = (1.0-fcrmax)*rsbmx*exp(-parameters%timean)*exp(-fff*(zwt-2.0)) + qdis = (1.0-fcrmax)*rsbmx*exp(-parameters%timean)*exp(-fff*zwt) ! c.he changed based on gy niu's update ! matric potential at the layer above the water table @@ -9114,7 +9115,9 @@ subroutine groundwater(parameters,nsnow ,nsoil ,dt ,sice ,zsoil , & !in ! recharge rate qin to groundwater - ka = hk(iwt) +! ka = hk(iwt) +! harmonic average, c.he changed based on gy niu's update + ka = 2.0*(hk(iwt)*parameters%dksat(iwt)*1.0e3) / (hk(iwt)+parameters%dksat(iwt)*1.0e3) wh_zwt = - zwt * 1.e3 !(mm) wh = smpfz - znode(iwt)*1.e3 !(mm) From 36e389231736c27a322c52cb0f9b81c606210e74 Mon Sep 17 00:00:00 2001 From: Michael Barlage Date: Mon, 1 May 2023 18:25:07 -0400 Subject: [PATCH 257/380] fix inout on ustar in sfcdif 1 and 2 --- physics/module_sf_noahmp_glacier.F90 | 2 +- physics/module_sf_noahmplsm.F90 | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/module_sf_noahmp_glacier.F90 b/physics/module_sf_noahmp_glacier.F90 index 7b7512fa4..492c4a50d 100644 --- a/physics/module_sf_noahmp_glacier.F90 +++ b/physics/module_sf_noahmp_glacier.F90 @@ -1583,7 +1583,7 @@ subroutine sfcdif1_glacier(iter ,zlvl ,zpd ,z0h ,z0m , & !in #endif ! outputs - real (kind=kind_phys), intent(out) :: fv !< friction velocity (m/s) + real (kind=kind_phys), intent(inout) :: fv !< friction velocity (m/s) real (kind=kind_phys), intent(out) :: cm !< drag coefficient for momentum real (kind=kind_phys), intent(out) :: ch !< drag coefficient for heat real (kind=kind_phys), intent(out) :: ch2 !< drag coefficient for heat diff --git a/physics/module_sf_noahmplsm.F90 b/physics/module_sf_noahmplsm.F90 index 67e24091e..6c199531d 100644 --- a/physics/module_sf_noahmplsm.F90 +++ b/physics/module_sf_noahmplsm.F90 @@ -5084,7 +5084,7 @@ subroutine sfcdif1(parameters,iter ,sfctmp ,rhoair ,h ,qair , & !in real (kind=kind_phys), intent(out) :: cm !< drag coefficient for momentum real (kind=kind_phys), intent(out) :: ch !< drag coefficient for heat - real (kind=kind_phys), intent(out) :: fv !< friction velocity (m/s) + real (kind=kind_phys), intent(inout) :: fv !< friction velocity (m/s) real (kind=kind_phys), intent(out) :: ch2 !< drag coefficient for heat ! locals @@ -5239,7 +5239,7 @@ subroutine sfcdif2(parameters,iter ,z0 ,thz0 ,thlm ,sfcspd , & !in real (kind=kind_phys), intent(inout) :: akhs real (kind=kind_phys), intent(inout) :: rlmo real (kind=kind_phys), intent(inout) :: wstar2 - real (kind=kind_phys), intent(out) :: ustar + real (kind=kind_phys), intent(inout) :: ustar real (kind=kind_phys) zz, pslmu, pslms, pslhu, pslhs real (kind=kind_phys) xx, pspmu, yy, pspms, psphu, psphs From 2fc95fef3e35dcd114c323c214fedc014845d54d Mon Sep 17 00:00:00 2001 From: Michael Barlage Date: Mon, 1 May 2023 18:29:46 -0400 Subject: [PATCH 258/380] remove zvfun and gdx effect from sfcdif3 --- physics/module_sf_noahmplsm.F90 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/physics/module_sf_noahmplsm.F90 b/physics/module_sf_noahmplsm.F90 index 6c199531d..1888a26e8 100644 --- a/physics/module_sf_noahmplsm.F90 +++ b/physics/module_sf_noahmplsm.F90 @@ -5501,6 +5501,9 @@ subroutine sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur tem2 = max(fveg, 0.1_kind_phys) zvfun1 = sqrt(tem1 * tem2) gdx = sqrt(garea1) + + gdx = 3000.0 ! this will remove gdx effect + zvfun1 = 1.0 ! this will remove zvfun effect if(thsfc_loc) then ! Use local potential temperature tvs = tgb * virtfac From 9af21e45d7e9a5c0adb39e9940529e98e21b65c4 Mon Sep 17 00:00:00 2001 From: Qingfu Liu Date: Tue, 2 May 2023 19:56:46 -0400 Subject: [PATCH 259/380] change divide bygrav to multiply by gravi --- physics/satmedmfvdifq.F | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index d12852fe1..75925a5f3 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -1687,7 +1687,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & endif if((pcnvflg(i) .or. scuflg(i)) .and. & (k >= kbx .and. k <= kmx)) then - tem = f1(i,k) * del(i,k) / grav + tem = f1(i,k) * del(i,k) * gravi if(f1(i,k) < 0.) tsumn(i) = tsumn(i) + tem if(f1(i,k) > 0.) tsump(i) = tsump(i) + tem endif @@ -1742,7 +1742,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & enddo do k = 1,km do i = 1,im - tem = f1(i,k) * del(i,k) / grav + tem = f1(i,k) * del(i,k) * gravi if(f1(i,k) < 0.) tsumn(i) = tsumn(i) + tem if(f1(i,k) > 0.) tsump(i) = tsump(i) + tem enddo @@ -1934,7 +1934,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & endif if((pcnvflg(i) .or. scuflg(i)) .and. & (k >= kbx .and. k <= kmx)) then - tem = f2(i,k) * del(i,k) / grav + tem = f2(i,k) * del(i,k) * gravi if(f2(i,k) < 0.) tsumn(i) = tsumn(i) + tem if(f2(i,k) > 0.) tsump(i) = tsump(i) + tem endif @@ -1990,7 +1990,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & enddo do k = 1,km do i = 1,im - tem = f2(i,k) * del(i,k) / grav + tem = f2(i,k) * del(i,k) * gravi if(f2(i,k) < 0.) tsumn(i) = tsumn(i) + tem if(f2(i,k) > 0.) tsump(i) = tsump(i) + tem enddo @@ -2119,7 +2119,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & endif if((pcnvflg(i) .or. scuflg(i)) .and. & (k >= kbx .and. k <= kmx)) then - tem = f2(i,k+is) * del(i,k) / grav + tem = f2(i,k+is) * del(i,k) * gravi if(f2(i,k+is) < 0.) tsumn(i) = tsumn(i) + tem if(f2(i,k+is) > 0.) tsump(i) = tsump(i) + tem endif @@ -2175,7 +2175,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & enddo do k = 1,km do i = 1,im - tem = f2(i,k+is) * del(i,k) / grav + tem = f2(i,k+is) * del(i,k) * gravi if(f2(i,k+is) < 0.) tsumn(i) = tsumn(i) + tem if(f2(i,k+is) > 0.) tsump(i) = tsump(i) + tem enddo From c7f6d31bec5957c11e49662ebe8a36cf39c63de4 Mon Sep 17 00:00:00 2001 From: Greg Thompson Date: Thu, 4 May 2023 10:23:44 -0600 Subject: [PATCH 260/380] three small fixes: max ice size bin made smaller (since snow min size was increased prev); make fewer explicit rain drop breakup from collisions with graupel when T above 0C; fix so snow/graupel only sublimate when not melting --- physics/module_mp_thompson.F90 | 44 ++++++++++++++++------------------ 1 file changed, 20 insertions(+), 24 deletions(-) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index b828c9ab0..38ee79dfa 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -708,9 +708,9 @@ SUBROUTINE thompson_init(is_aerosol_aware_in, & dtc(n) = (Dc(n) - Dc(n-1)) enddo -!> - Create bins of cloud ice (from min diameter up to 5x min snow size) +!> - Create bins of cloud ice (from min diameter up to 2x min snow size) xDx(1) = D0i*1.0d0 - xDx(nbi+1) = 5.0d0*D0s + xDx(nbi+1) = 2.0d0*D0s do n = 2, nbi xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbi) & *DLOG(xDx(nbi+1)/xDx(1)) +DLOG(xDx(1))) @@ -2822,7 +2822,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & prr_rcg(k) = MIN(DBLE(rg(k)*odts), prr_rcg(k)) prg_rcg(k) = -prr_rcg(k) !> - Put in explicit drop break-up due to collisions. - pnr_rcg(k) = -5.*tnr_gacr(idx_g1,idx_g,idx_r1,idx_r) ! RAIN2M + pnr_rcg(k) = -1.5*tnr_gacr(idx_g1,idx_g,idx_r1,idx_r) ! RAIN2M endif endif endif @@ -3053,16 +3053,14 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & if (prr_sml(k) .gt. 0.) then prr_sml(k) = prr_sml(k) + 4218.*olfus*tempc & * (prr_rcs(k)+prs_scw(k)) - endif - prr_sml(k) = MIN(DBLE(rs(k)*odts), MAX(0.D0, prr_sml(k))) - pnr_sml(k) = smo0(k)/rs(k)*prr_sml(k) * 10.0**(-0.25*tempc) ! RAIN2M - pnr_sml(k) = MIN(DBLE(smo0(k)*odts), pnr_sml(k)) - - if (ssati(k).lt. 0.) then - prs_sde(k) = C_cube*t1_subl*diffu(k)*ssati(k)*rvs & - * (t1_qs_sd*smo1(k) & - + t2_qs_sd*rhof2(k)*vsc2(k)*smof(k)) - prs_sde(k) = MAX(DBLE(-rs(k)*odts), prs_sde(k)) + prr_sml(k) = MIN(DBLE(rs(k)*odts), prr_sml(k)) + pnr_sml(k) = smo0(k)/rs(k)*prr_sml(k) * 10.0**(-0.25*tempc) ! RAIN2M + pnr_sml(k) = MIN(DBLE(smo0(k)*odts), pnr_sml(k)) + elseif (ssati(k).lt. 0.) then + prs_sde(k) = C_cube*t1_subl*diffu(k)*ssati(k)*rvs & + * (t1_qs_sd*smo1(k) & + + t2_qs_sd*rhof2(k)*vsc2(k)*smof(k)) + prs_sde(k) = MAX(DBLE(-rs(k)*odts), prs_sde(k)) endif endif @@ -3070,17 +3068,15 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & prr_gml(k) = (tempc*tcond(k)-lvap0*diffu(k)*delQvs(k)) & * N0_g(k)*(t1_qg_me*ilamg(k)**cge(10) & + t2_qg_me*rhof2(k)*vsc2(k)*ilamg(k)**cge(11)) -!-GT prr_gml(k) = prr_gml(k) + 4218.*olfus*tempc & -!-GT * (prr_rcg(k)+prg_gcw(k)) - prr_gml(k) = MIN(DBLE(rg(k)*odts), MAX(0.D0, prr_gml(k))) - pnr_gml(k) = N0_g(k)*cgg(2)*ilamg(k)**cge(2) / rg(k) & ! RAIN2M - * prr_gml(k) * 10.0**(-0.5*tempc) - - if (ssati(k).lt. 0.) then - prg_gde(k) = C_cube*t1_subl*diffu(k)*ssati(k)*rvs & - * N0_g(k) * (t1_qg_sd*ilamg(k)**cge(10) & - + t2_qg_sd*vsc2(k)*rhof2(k)*ilamg(k)**cge(11)) - prg_gde(k) = MAX(DBLE(-rg(k)*odts), prg_gde(k)) + if (prr_gml(k) .gt. 0.) then + prr_gml(k) = MIN(DBLE(rg(k)*odts), prr_gml(k)) + pnr_gml(k) = N0_g(k)*cgg(2)*ilamg(k)**cge(2) / rg(k) & ! RAIN2M + * prr_gml(k) * 10.0**(-0.5*tempc) + elseif (ssati(k).lt. 0.) then + prg_gde(k) = C_cube*t1_subl*diffu(k)*ssati(k)*rvs & + * N0_g(k) * (t1_qg_sd*ilamg(k)**cge(10) & + + t2_qg_sd*vsc2(k)*rhof2(k)*ilamg(k)**cge(11)) + prg_gde(k) = MAX(DBLE(-rg(k)*odts), prg_gde(k)) endif endif From 17c736873810b241078e47ba6a763aca5d0f5324 Mon Sep 17 00:00:00 2001 From: Qingfu Liu Date: Mon, 8 May 2023 13:06:03 -0400 Subject: [PATCH 261/380] move some printout from file err to out --- physics/module_mp_thompson.F90 | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index b828c9ab0..6a4ef5e02 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -469,11 +469,11 @@ SUBROUTINE thompson_init(is_aerosol_aware_in, & end if if (mpirank==mpiroot) then if (is_aerosol_aware) then - write (0,'(a)') 'Using aerosol-aware version of Thompson microphysics' + write (*,'(a)') 'Using aerosol-aware version of Thompson microphysics' else if(merra2_aerosol_aware) then - write (0,'(a)') 'Using merra2 aerosol-aware version of Thompson microphysics' + write (*,'(a)') 'Using merra2 aerosol-aware version of Thompson microphysics' else - write (0,'(a)') 'Using non-aerosol-aware version of Thompson microphysics' + write (*,'(a)') 'Using non-aerosol-aware version of Thompson microphysics' end if end if @@ -896,22 +896,22 @@ SUBROUTINE thompson_init(is_aerosol_aware_in, & !> - Call table_ccnact() to read a static file containing CCN activation of aerosols. The !! data were created from a parcel model by Feingold & Heymsfield with !! further changes by Eidhammer and Kriedenweis - if (mpirank==mpiroot) write(0,*) ' calling table_ccnAct routine' + if (mpirank==mpiroot) write(*,*) ' calling table_ccnAct routine' call table_ccnAct(errmsg,errflg) if (.not. errflg==0) return !> - Call table_efrw() and table_efsw() to creat collision efficiency table !! between rain/snow and cloud water - if (mpirank==mpiroot) write(0,*) ' creating qc collision eff tables' + if (mpirank==mpiroot) write(*,*) ' creating qc collision eff tables' call table_Efrw call table_Efsw !> - Call table_dropevap() to creat rain drop evaporation table - if (mpirank==mpiroot) write(0,*) ' creating rain evap table' + if (mpirank==mpiroot) write(*,*) ' creating rain evap table' call table_dropEvap !> - Call qi_aut_qs() to create conversion of some ice mass into snow category - if (mpirank==mpiroot) write(0,*) ' creating ice converting to snow table' + if (mpirank==mpiroot) write(*,*) ' creating ice converting to snow table' call qi_aut_qs call cpu_time(etime) @@ -942,7 +942,7 @@ SUBROUTINE thompson_init(is_aerosol_aware_in, & call cpu_time(stime) !> - Call qr_acr_qg() to create rain collecting graupel & graupel collecting rain table - if (mpirank==mpiroot) write(0,*) ' creating rain collecting graupel table' + if (mpirank==mpiroot) write(*,*) ' creating rain collecting graupel table' call cpu_time(stime) call qr_acr_qg call cpu_time(etime) @@ -956,7 +956,7 @@ SUBROUTINE thompson_init(is_aerosol_aware_in, & if (mpirank==mpiroot) print '("Computing rain collecting snow table took ",f10.3," seconds.")', etime-stime !> - Call freezeh2o() to create cloud water and rain freezing (Bigg, 1953) table - if (mpirank==mpiroot) write(0,*) ' creating freezing of water drops table' + if (mpirank==mpiroot) write(*,*) ' creating freezing of water drops table' call cpu_time(stime) call freezeH2O(threads) call cpu_time(etime) @@ -969,7 +969,7 @@ SUBROUTINE thompson_init(is_aerosol_aware_in, & endif if_not_iiwarm - if (mpirank==mpiroot) write(0,*) ' ... DONE microphysical lookup tables' + if (mpirank==mpiroot) write(*,*) ' ... DONE microphysical lookup tables' endif if_micro_init From 9dd9e86cf970472c3e8af2733d511ba57acbc3ba Mon Sep 17 00:00:00 2001 From: dustinswales Date: Thu, 11 May 2023 10:00:42 -0600 Subject: [PATCH 262/380] Move allocation of native RRTMGP DDTs from HEAP memory into scheme driver. Working with multiple threads --- physics/rrtmgp_lw_main.F90 | 71 ++++++++++++++++++++------------------ physics/rrtmgp_sw_main.F90 | 59 ++++++++++++++++--------------- 2 files changed, 66 insertions(+), 64 deletions(-) diff --git a/physics/rrtmgp_lw_main.F90 b/physics/rrtmgp_lw_main.F90 index c0bc99d35..67f7f749a 100644 --- a/physics/rrtmgp_lw_main.F90 +++ b/physics/rrtmgp_lw_main.F90 @@ -27,13 +27,6 @@ module rrtmgp_lw_main use rrtmgp_sampling, only: sampled_mask, draw_samples implicit none - type(ty_gas_concs) :: gas_concs - type(ty_optical_props_1scl) :: lw_optical_props_clrsky, lw_optical_props_aerosol_local - type(ty_optical_props_2str) :: lw_optical_props_clouds, lw_optical_props_cloudsByBand, & - lw_optical_props_cnvcloudsByBand, lw_optical_props_pblcloudsByBand, & - lw_optical_props_precipByBand - type(ty_source_func_lw) :: sources - public rrtmgp_lw_main_init, rrtmgp_lw_main_run contains ! ######################################################################################### @@ -94,33 +87,6 @@ subroutine rrtmgp_lw_main_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, rrtmgp_lw_fi doGP_cldoptics_PADE, doGP_cldoptics_LUT, nrghice, mpicomm, mpirank, mpiroot, & errmsg, errflg) - ! DDTs - - ! ty_gas_concs - call check_error_msg('rrtmgp_lw_main_gas_concs_init',gas_concs%init(active_gases_array)) - - ! ty_optical_props - call check_error_msg('rrtmgp_lw_main_gas_optics_init',& - lw_optical_props_clrsky%alloc_1scl(rrtmgp_phys_blksz, nLay, lw_gas_props)) - call check_error_msg('rrtmgp_lw_main_sources_init',& - sources%alloc(rrtmgp_phys_blksz, nLay, lw_gas_props)) - call check_error_msg('rrtmgp_lw_main_cloud_optics_init',& - lw_optical_props_cloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) - call check_error_msg('rrtmgp_lw_main_precip_optics_init',& - lw_optical_props_precipByBand%alloc_2str(rrtmgp_phys_blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) - call check_error_msg('rrtmgp_lw_mian_cloud_sampling_init', & - lw_optical_props_clouds%alloc_2str(rrtmgp_phys_blksz, nLay, lw_gas_props)) - call check_error_msg('rrtmgp_lw_main_aerosol_optics_init',& - lw_optical_props_aerosol_local%alloc_1scl(rrtmgp_phys_blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) - if (doGP_sgs_cnv) then - call check_error_msg('rrtmgp_lw_main_cnv_cloud_optics_init',& - lw_optical_props_cnvcloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) - endif - if (doGP_sgs_pbl) then - call check_error_msg('rrtmgp_lw_main_pbl_cloud_optics_init',& - lw_optical_props_pblcloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) - endif - end subroutine rrtmgp_lw_main_init !> @} ! ###################################################################################### @@ -242,12 +208,49 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, real(kind_phys), dimension(rrtmgp_phys_blksz,lw_gas_props%get_ngpt()) :: lw_Ds real(kind_phys), dimension(lw_gas_props%get_nband(),rrtmgp_phys_blksz) :: sfc_emiss_byband + ! Local RRTMGP DDTs. + type(ty_gas_concs) :: gas_concs + type(ty_optical_props_1scl) :: lw_optical_props_clrsky, lw_optical_props_aerosol_local + type(ty_optical_props_2str) :: lw_optical_props_clouds, lw_optical_props_cloudsByBand, & + lw_optical_props_cnvcloudsByBand, lw_optical_props_pblcloudsByBand, & + lw_optical_props_precipByBand + type(ty_source_func_lw) :: sources + ! Initialize CCPP error handling variables errmsg = '' errflg = 0 if (.not. doLWrad) return + ! + ! Initialize RRTMGP DDTs (local) + ! + + ! ty_gas_concs + call check_error_msg('rrtmgp_lw_main_gas_concs_run',gas_concs%init(active_gases_array)) + + ! ty_optical_props + call check_error_msg('rrtmgp_lw_main_gas_optics_run',& + lw_optical_props_clrsky%alloc_1scl(rrtmgp_phys_blksz, nLay, lw_gas_props)) + call check_error_msg('rrtmgp_lw_main_sources_run',& + sources%alloc(rrtmgp_phys_blksz, nLay, lw_gas_props)) + call check_error_msg('rrtmgp_lw_main_cloud_optics_run',& + lw_optical_props_cloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) + call check_error_msg('rrtmgp_lw_main_precip_optics_run',& + lw_optical_props_precipByBand%alloc_2str(rrtmgp_phys_blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) + call check_error_msg('rrtmgp_lw_mian_cloud_sampling_run', & + lw_optical_props_clouds%alloc_2str(rrtmgp_phys_blksz, nLay, lw_gas_props)) + call check_error_msg('rrtmgp_lw_main_aerosol_optics_run',& + lw_optical_props_aerosol_local%alloc_1scl(rrtmgp_phys_blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) + if (doGP_sgs_cnv) then + call check_error_msg('rrtmgp_lw_main_cnv_cloud_optics_run',& + lw_optical_props_cnvcloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) + endif + if (doGP_sgs_pbl) then + call check_error_msg('rrtmgp_lw_main_pbl_cloud_optics_run',& + lw_optical_props_pblcloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, lw_gas_props%get_band_lims_wavenumber())) + endif + ! ###################################################################################### ! ! Loop over all columns... diff --git a/physics/rrtmgp_sw_main.F90 b/physics/rrtmgp_sw_main.F90 index b25e093e7..124532b03 100644 --- a/physics/rrtmgp_sw_main.F90 +++ b/physics/rrtmgp_sw_main.F90 @@ -20,12 +20,6 @@ module rrtmgp_sw_main use rrtmgp_sampling, only: sampled_mask, draw_samples implicit none - type(ty_gas_concs) :: gas_concs - type(ty_optical_props_2str) :: sw_optical_props_accum, sw_optical_props_aerosol_local, & - sw_optical_props_cloudsByBand, sw_optical_props_cnvcloudsByBand, & - sw_optical_props_pblcloudsByBand, sw_optical_props_precipByBand, & - sw_optical_props_clouds - public rrtmgp_sw_main_init, rrtmgp_sw_main_run contains @@ -80,30 +74,6 @@ subroutine rrtmgp_sw_main_init(rrtmgp_root_dir, rrtmgp_sw_file_gas, rrtmgp_sw_fi doGP_cldoptics_PADE, doGP_cldoptics_LUT, nrghice, mpicomm, mpirank, mpiroot, & errmsg, errflg) - ! DDTs - - ! ty_gas_concs - call check_error_msg('rrtmgp_sw_main_gas_concs_init',gas_concs%init(active_gases_array)) - - ! ty_optical_props - call check_error_msg('rrtmgp_sw_main_accumulated_optics_init',& - sw_optical_props_accum%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props)) - call check_error_msg('rrtmgp_sw_main_cloud_optics_init',& - sw_optical_props_cloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) - call check_error_msg('rrtmgp_sw_main_precip_optics_init',& - sw_optical_props_precipByBand%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) - call check_error_msg('rrtmgp_sw_mian_cloud_sampling_init', & - sw_optical_props_clouds%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props)) - call check_error_msg('rrtmgp_sw_main_aerosol_optics_init',& - sw_optical_props_aerosol_local%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) - if (doGP_sgs_cnv) then - call check_error_msg('rrtmgp_sw_main_cnv_cloud_optics_init',& - sw_optical_props_cnvcloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) - endif - if (doGP_sgs_pbl) then - call check_error_msg('rrtmgp_sw_main_pbl_cloud_optics_init',& - sw_optical_props_pblcloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) - endif end subroutine rrtmgp_sw_main_init ! ######################################################################################### @@ -241,12 +211,41 @@ subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_ uvb_bnd = (/29000,38000/) real(kind_phys), dimension(rrtmgp_phys_blksz,sw_gas_props%get_ngpt()) :: toa_src_sw + type(ty_gas_concs) :: gas_concs + type(ty_optical_props_2str) :: sw_optical_props_accum, sw_optical_props_aerosol_local, & + sw_optical_props_cloudsByBand, sw_optical_props_cnvcloudsByBand, & + sw_optical_props_pblcloudsByBand, sw_optical_props_precipByBand, & + sw_optical_props_clouds + ! Initialize CCPP error handling variables errmsg = '' errflg = 0 if (.not. doSWrad) return + ! ty_gas_concs + call check_error_msg('rrtmgp_sw_main_gas_concs_init',gas_concs%init(active_gases_array)) + + ! ty_optical_props + call check_error_msg('rrtmgp_sw_main_accumulated_optics_init',& + sw_optical_props_accum%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props)) + call check_error_msg('rrtmgp_sw_main_cloud_optics_init',& + sw_optical_props_cloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) + call check_error_msg('rrtmgp_sw_main_precip_optics_init',& + sw_optical_props_precipByBand%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) + call check_error_msg('rrtmgp_sw_mian_cloud_sampling_init', & + sw_optical_props_clouds%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props)) + call check_error_msg('rrtmgp_sw_main_aerosol_optics_init',& + sw_optical_props_aerosol_local%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) + if (doGP_sgs_cnv) then + call check_error_msg('rrtmgp_sw_main_cnv_cloud_optics_init',& + sw_optical_props_cnvcloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) + endif + if (doGP_sgs_pbl) then + call check_error_msg('rrtmgp_sw_main_pbl_cloud_optics_init',& + sw_optical_props_pblcloudsByBand%alloc_2str(rrtmgp_phys_blksz, nLay, sw_gas_props%get_band_lims_wavenumber())) + endif + if (nDay .gt. 0) then bandlimits = sw_gas_props%get_band_lims_wavenumber() From 81e3f5e36bb84cff02a08078e4ad1d8ee3555c2f Mon Sep 17 00:00:00 2001 From: dustinswales Date: Thu, 11 May 2023 11:18:24 -0600 Subject: [PATCH 263/380] Remove lower optimization used in rte-rrtmgp module --- CMakeLists.txt | 7 ------- 1 file changed, 7 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 950bd048e..97591a2ee 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -159,13 +159,6 @@ if(CMAKE_BUILD_TYPE STREQUAL "Release" AND ${CMAKE_Fortran_COMPILER_ID} STREQUAL endforeach() endif() -# Reduce optimization for mo_gas_optics_kernels.F90 (to avoid an apparent compiler bug with Intel 19+) -if(${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/kernels/mo_gas_optics_kernels.F90 IN_LIST SCHEMES_OPENMP_OFF AND - CMAKE_BUILD_TYPE STREQUAL "Release" AND ${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") - SET_SOURCE_FILES_PROPERTIES(${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/kernels/mo_gas_optics_kernels.F90 - APPEND_STRING PROPERTY COMPILE_FLAGS " ${CMAKE_Fortran_FLAGS_PHYSICS} -O1") -endif() - #------------------------------------------------------------------------------ add_library(ccpp_physics STATIC ${SCHEMES} ${SCHEMES_OPENMP_OFF} ${SCHEMES_DYNAMICS} ${CAPS}) From 90f4b65627e06a4bcc5d33385a01eb3dc0afb4f3 Mon Sep 17 00:00:00 2001 From: joeolson42 Date: Sat, 13 May 2023 01:47:52 +0000 Subject: [PATCH 264/380] temporary patch for snow mixing which causes numerical instabilities --- physics/mynnedmf_wrapper.F90 | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/physics/mynnedmf_wrapper.F90 b/physics/mynnedmf_wrapper.F90 index 83a73e6b3..3c7de235f 100644 --- a/physics/mynnedmf_wrapper.F90 +++ b/physics/mynnedmf_wrapper.F90 @@ -418,7 +418,7 @@ SUBROUTINE mynnedmf_wrapper_run( & FLAG_QI = .true. FLAG_QNI= .true. FLAG_QC = .true. - FLAG_QS = .true. + FLAG_QS = .false. FLAG_QNC= .true. FLAG_QNWFA= .true. FLAG_QNIFA= .true. @@ -428,7 +428,7 @@ SUBROUTINE mynnedmf_wrapper_run( & sqv(i,k) = qgrs_water_vapor(i,k) sqc(i,k) = qgrs_liquid_cloud(i,k) sqi(i,k) = qgrs_ice(i,k) - sqs(i,k) = qgrs_snow(i,k) + sqs(i,k) = 0. !qgrs_snow(i,k) qnc(i,k) = qgrs_cloud_droplet_num_conc(i,k) qni(i,k) = qgrs_cloud_ice_num_conc(i,k) ozone(i,k) = qgrs_ozone(i,k) @@ -441,7 +441,7 @@ SUBROUTINE mynnedmf_wrapper_run( & FLAG_QI = .true. FLAG_QNI= .true. FLAG_QC = .true. - FLAG_QS = .true. + FLAG_QS = .false. FLAG_QNC= .true. FLAG_QNWFA= .false. FLAG_QNIFA= .false. @@ -451,7 +451,7 @@ SUBROUTINE mynnedmf_wrapper_run( & sqv(i,k) = qgrs_water_vapor(i,k) sqc(i,k) = qgrs_liquid_cloud(i,k) sqi(i,k) = qgrs_ice(i,k) - sqs(i,k) = qgrs_snow(i,k) + sqs(i,k) = 0. !qgrs_snow(i,k) qnc(i,k) = qgrs_cloud_droplet_num_conc(i,k) qni(i,k) = qgrs_cloud_ice_num_conc(i,k) ozone(i,k) = qgrs_ozone(i,k) @@ -464,7 +464,7 @@ SUBROUTINE mynnedmf_wrapper_run( & FLAG_QI = .true. FLAG_QNI= .true. FLAG_QC = .true. - FLAG_QS = .true. + FLAG_QS = .false. FLAG_QNC= .false. FLAG_QNWFA= .false. FLAG_QNIFA= .false. @@ -474,7 +474,7 @@ SUBROUTINE mynnedmf_wrapper_run( & sqv(i,k) = qgrs_water_vapor(i,k) sqc(i,k) = qgrs_liquid_cloud(i,k) sqi(i,k) = qgrs_ice(i,k) - sqs(i,k) = qgrs_snow(i,k) + sqs(i,k) = 0. !qgrs_snow(i,k) qnc(i,k) = 0. qni(i,k) = qgrs_cloud_ice_num_conc(i,k) ozone(i,k) = qgrs_ozone(i,k) @@ -834,7 +834,7 @@ SUBROUTINE mynnedmf_wrapper_run( & dqdt_cloud_droplet_num_conc(i,k) = RQNCBLTEN(i,k) dqdt_ice(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_ice_num_conc(i,k) = RQNIBLTEN(i,k) - dqdt_snow(i,k) = RQSBLTEN(i,k) !/(1.0 + qv(i,k)) + dqdt_snow(i,k) = 0.0 !RQSBLTEN(i,k) !/(1.0 + qv(i,k)) !dqdt_ozone(i,k) = 0.0 dqdt_water_aer_num_conc(i,k) = RQNWFABLTEN(i,k) dqdt_ice_aer_num_conc(i,k) = RQNIFABLTEN(i,k) @@ -869,7 +869,7 @@ SUBROUTINE mynnedmf_wrapper_run( & dqdt_cloud_droplet_num_conc(i,k) = RQNCBLTEN(i,k) dqdt_ice(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_ice_num_conc(i,k) = RQNIBLTEN(i,k) - dqdt_snow(i,k) = RQSBLTEN(i,k) !/(1.0 + qv(i,k)) + dqdt_snow(i,k) = 0.0 !RQSBLTEN(i,k) !/(1.0 + qv(i,k)) enddo enddo if(ldiag3d .and. .not. flag_for_pbl_generic_tend) then @@ -887,7 +887,7 @@ SUBROUTINE mynnedmf_wrapper_run( & dqdt_liquid_cloud(i,k) = RQCBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_ice(i,k) = RQIBLTEN(i,k) !/(1.0 + qv(i,k)) dqdt_ice_num_conc(i,k) = RQNIBLTEN(i,k) - dqdt_snow(i,k) = RQSBLTEN(i,k) !/(1.0 + qv(i,k)) + dqdt_snow(i,k) = 0.0 !RQSBLTEN(i,k) !/(1.0 + qv(i,k)) !dqdt_ozone(i,k) = 0.0 enddo enddo @@ -896,7 +896,7 @@ SUBROUTINE mynnedmf_wrapper_run( & call dtend_helper(100+ntcw,RQCBLTEN) call dtend_helper(100+ntiw,RQIBLTEN) call dtend_helper(100+ntinc,RQNIBLTEN) - call dtend_helper(100+ntsw,RQSBLTEN) + !call dtend_helper(100+ntsw,RQSBLTEN) endif !do k=1,levs ! do i=1,im From 17fc149be79d3046ae061198602ae9e2184ea54c Mon Sep 17 00:00:00 2001 From: joeolson42 Date: Sat, 13 May 2023 01:50:02 +0000 Subject: [PATCH 265/380] small change to table values of Leaf Area Index to match them better with the LAI monthly climatology that is used in HRRR --- physics/set_soilveg_ruc.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/set_soilveg_ruc.F90 b/physics/set_soilveg_ruc.F90 index db56fb8a4..8ce6023ff 100644 --- a/physics/set_soilveg_ruc.F90 +++ b/physics/set_soilveg_ruc.F90 @@ -190,9 +190,9 @@ subroutine set_soilveg_ruc(me,isot,ivet,nlunit,errmsg,errflg) ifortbl =(/1, 2, 4, 3, 2, 4, 4, 5, 5, 5, 4, 7, 9, 7, & & 9, 9, 9, 5, 5, 5, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0/) - laitbl =(/6.40, 6.48, 5.16, 3.31, 5.50, 3.66, 2.60, & - & 3.66, 3.66, 2.90, 5.72, 5.68, 1.00, 4.29, & - & 0.01, 0.75, 0.01, 3.35, 3.35, 3.35, 0.01, & + laitbl =(/2.80, 5.18, 4.16, 4.81, 4.20, 1.16, 0.90, & + & 3.00, 3.00, 1.10, 1.72, 2.58, 1.00, 2.29, & + & 0.01, 0.75, 0.01, 1.00, 1.00, 1.00, 0.01, & & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, & & 0.00, 0.00/) From b766e8102a8f441e0485e5059d810a7fd4a78f4c Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Fri, 19 May 2023 11:27:32 -0400 Subject: [PATCH 266/380] fix Cray compiler error having to do with binary/unary operator precedence standards --- physics/module_bl_mynn.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index 51a906faf..dcfdc1011 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -7521,7 +7521,7 @@ FUNCTION phim(zet) dummy_0=(1.-am_unst*zet) ! parentesis arg dummy_1=dummy_0**0.333333 ! y - dummy_11=-0.33333*am_unst*dummy_0**-0.6666667 ! dy/dzet + dummy_11=-0.33333*am_unst*dummy_0**(-0.6666667) ! dy/dzet dummy_2 = 0.33333*(dummy_1**2.+dummy_1+1.) ! f dummy_22 = 0.3333*dummy_11*(2.*dummy_1+1.) ! df/dzet dummy_3 = 0.57735*(2.*dummy_1+1.) ! g @@ -7573,7 +7573,7 @@ FUNCTION phih(zet) dummy_0=(1.-ah_unst*zet) ! parentesis arg dummy_1=dummy_0**0.333333 ! y - dummy_11=-0.33333*ah_unst*dummy_0**-0.6666667 ! dy/dzet + dummy_11=-0.33333*ah_unst*dummy_0**(-0.6666667) ! dy/dzet dummy_2 = 0.33333*(dummy_1**2.+dummy_1+1.) ! f dummy_22 = 0.3333*dummy_11*(2.*dummy_1+1.) ! df/dzet dummy_3 = 0.57735*(2.*dummy_1+1.) ! g From 1591a273fa085c443a50214e7aaf7cd673633c58 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Fri, 19 May 2023 11:53:15 -0400 Subject: [PATCH 267/380] add Anders Jensen to Thompson MP CODEOWNERS list --- CODEOWNERS | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/CODEOWNERS b/CODEOWNERS index 4b7e45310..189fabd95 100644 --- a/CODEOWNERS +++ b/CODEOWNERS @@ -116,7 +116,7 @@ physics/module_gfdl_cloud_microphys.* @RuiyuSun physics/module_MP_FER_HIRES.* @ericaligo-NOAA @grantfirl @Qingfu-Liu @dustinswales physics/module_mp_nssl_2mom.F90 @grantfirl @Qingfu-Liu @dustinswales physics/module_mp_radar.* @gthompsnWRF @RuiyuSun @grantfirl @Qingfu-Liu @dustinswales -physics/module_mp_thompson* @gthompsnWRF @RuiyuSun @grantfirl @Qingfu-Liu @dustinswales +physics/module_mp_thompson* @gthompsnWRF @RuiyuSun @AndersJensen-NOAA @grantfirl @Qingfu-Liu @dustinswales physics/module_nst* @XuLi-NOAA @grantfirl @Qingfu-Liu @dustinswales physics/module_sf_exchcoef.f90 @grantfirl @Qingfu-Liu @dustinswales physics/module_SF_JSFC.F90 @Qingfu-Liu @grantfirl @Qingfu-Liu @dustinswales @@ -126,7 +126,7 @@ physics/module_soil_pre.* @tanyasmirnova physics/moninshoc.* @SMoorthi-emc @grantfirl @Qingfu-Liu @dustinswales physics/mp_fer_hires.* @ericaligo-NOAA @grantfirl @Qingfu-Liu @dustinswales physics/mp_nssl.* @grantfirl @Qingfu-Liu @dustinswales -physics/mp_thompson* @gthompsnWRF @RuiyuSun @grantfirl @Qingfu-Liu @dustinswales +physics/mp_thompson* @gthompsnWRF @RuiyuSun @AndersJensen-NOAA @grantfirl @Qingfu-Liu @dustinswales physics/multi_gases.F90 @RuiyuSun @grantfirl @Qingfu-Liu @dustinswales physics/myjpbl_wrapper.* @Qingfu-Liu @grantfirl @Qingfu-Liu @dustinswales physics/myjsfc_wrapper.* @Qingfu-Liu @grantfirl @Qingfu-Liu @dustinswales From 07bb2021d6fca6578e175694734ae5417513c3c9 Mon Sep 17 00:00:00 2001 From: "Haiqin.Li" Date: Mon, 22 May 2023 19:12:49 +0000 Subject: [PATCH 268/380] "for the Community Convective Cloud (C3) scheme" --- physics/GFS_rrtmg_pre.F90 | 6 +- physics/GFS_rrtmg_pre.meta | 6 +- physics/GFS_suite_interstitial_3.F90 | 8 +- physics/GFS_suite_interstitial_3.meta | 14 +- .../{cu_unified_deep.F90 => cu_c3_deep.F90} | 470 ++++++------------ ...cu_unified_driver.F90 => cu_c3_driver.F90} | 144 +++--- ..._unified_driver.meta => cu_c3_driver.meta} | 49 +- physics/cu_c3_driver_post.F90 | 88 ++++ ...river_post.meta => cu_c3_driver_post.meta} | 51 +- ...ed_driver_pre.F90 => cu_c3_driver_pre.F90} | 20 +- ..._driver_pre.meta => cu_c3_driver_pre.meta} | 4 +- physics/{cu_unified_sh.F90 => cu_c3_sh.F90} | 20 +- physics/cu_gf_deep.F90 | 166 ++++--- physics/cu_gf_driver.F90 | 30 +- physics/cu_gf_driver.meta | 28 ++ physics/cu_unified_driver_post.F90 | 65 --- physics/radiation_clouds.f | 12 +- physics/sgscloud_radpre.F90 | 6 +- physics/sgscloud_radpre.meta | 6 +- 19 files changed, 602 insertions(+), 591 deletions(-) rename physics/{cu_unified_deep.F90 => cu_c3_deep.F90} (94%) rename physics/{cu_unified_driver.F90 => cu_c3_driver.F90} (93%) rename physics/{cu_unified_driver.meta => cu_c3_driver.meta} (93%) create mode 100644 physics/cu_c3_driver_post.F90 rename physics/{cu_unified_driver_post.meta => cu_c3_driver_post.meta} (66%) rename physics/{cu_unified_driver_pre.F90 => cu_c3_driver_pre.F90} (80%) rename physics/{cu_unified_driver_pre.meta => cu_c3_driver_pre.meta} (98%) rename physics/{cu_unified_sh.F90 => cu_c3_sh.F90} (98%) delete mode 100644 physics/cu_unified_driver_post.F90 diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index c45bec3e3..2eb154814 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -18,7 +18,7 @@ module GFS_rrtmg_pre !! !>\section rrtmg_pre_gen General Algorithm subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& - ltp, imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_unified, me, ncnd, ntrac, & + ltp, imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_c3, me, ncnd, ntrac, & num_p3d, npdf3d, & ncnvcld3d,ntqv, ntcw,ntiw, ntlnc, ntinc, ntrnc, ntsnc, ntccn, top_at_1,& ntrw, ntsw, ntgl, nthl, ntwa, ntoz, ntsmoke, ntdust, ntcoarsepm, & @@ -84,7 +84,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& integer, intent(in) :: im, levs, lm, lmk, lmp, ltp, & n_var_lndp, imfdeepcnv, & - imfdeepcnv_gf, imfdeepcnv_unified, & + imfdeepcnv_gf, imfdeepcnv_c3, & me, ncnd, ntrac, & num_p3d, npdf3d, ncnvcld3d, ntqv, & ntcw, ntiw, ntlnc, ntinc, & @@ -819,7 +819,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& enddo endif elseif (imp_physics == imp_physics_gfdl) then ! GFDL MP - if ((imfdeepcnv==imfdeepcnv_gf .or. imfdeepcnv==imfdeepcnv_unified) .and. kdt>1) then + if ((imfdeepcnv==imfdeepcnv_gf .or. imfdeepcnv==imfdeepcnv_c3) .and. kdt>1) then do k=1,lm k1 = k + kd do i=1,im diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index d7feaeb3f..908394562 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -79,9 +79,9 @@ dimensions = () type = integer intent = in -[imfdeepcnv_unified] - standard_name = identifier_for_unified_deep_convection - long_name = flag for Unified deep convection scheme +[imfdeepcnv_c3] + standard_name = identifier_for_c3_deep_convection + long_name = flag for C3 deep convection scheme units = flag dimensions = () type = integer diff --git a/physics/GFS_suite_interstitial_3.F90 b/physics/GFS_suite_interstitial_3.F90 index ca82f20aa..5ca20ffc1 100644 --- a/physics/GFS_suite_interstitial_3.F90 +++ b/physics/GFS_suite_interstitial_3.F90 @@ -10,8 +10,8 @@ module GFS_suite_interstitial_3 !! subroutine GFS_suite_interstitial_3_run (otsptflag, & im, levs, nn, cscnv,imfshalcnv, imfdeepcnv, & - imfshalcnv_samf, imfdeepcnv_samf, imfdeepcnv_unified, & - imfshalcnv_unified,progsigma, & + imfshalcnv_samf, imfdeepcnv_samf, imfdeepcnv_c3, & + imfshalcnv_c3,progsigma, & first_time_step, restart, & satmedmf, trans_trac, do_shoc, ltaerosol, ntrac, ntcw, & ntiw, ntclamt, ntrw, ntsw, ntrnc, ntsnc, ntgl, ntgnc, & @@ -40,7 +40,7 @@ subroutine GFS_suite_interstitial_3_run (otsptflag, & logical, intent(in ) :: cscnv, satmedmf, trans_trac, do_shoc, ltaerosol, ras, progsigma logical, intent(in ) :: first_time_step, restart integer, intent(in ) :: imfshalcnv, imfdeepcnv, imfshalcnv_samf,imfdeepcnv_samf - integer, intent(in ) :: imfshalcnv_unified,imfdeepcnv_unified + integer, intent(in ) :: imfshalcnv_c3,imfdeepcnv_c3 integer, intent(in) :: ntinc, ntlnc logical, intent(in) :: ldiag3d, qdiag3d integer, dimension(:,:), intent(in) :: dtidx @@ -84,7 +84,7 @@ subroutine GFS_suite_interstitial_3_run (otsptflag, & ! In case of using prognostic updraf area fraction, initialize area fraction here ! since progsigma_calc is called from both deep and shallow schemes. if(((imfshalcnv == imfshalcnv_samf) .or. (imfdeepcnv == imfdeepcnv_samf) & - .or. (imfshalcnv == imfshalcnv_unified) .or. (imfdeepcnv == imfdeepcnv_unified)) & + .or. (imfshalcnv == imfshalcnv_c3) .or. (imfdeepcnv == imfdeepcnv_c3)) & .and. progsigma)then if(first_time_step .and. .not. restart)then do k=1,levs diff --git a/physics/GFS_suite_interstitial_3.meta b/physics/GFS_suite_interstitial_3.meta index a6d656a75..e8f9fe889 100644 --- a/physics/GFS_suite_interstitial_3.meta +++ b/physics/GFS_suite_interstitial_3.meta @@ -57,9 +57,9 @@ dimensions = () type = integer intent = in -[imfdeepcnv_unified] - standard_name = identifier_for_unified_deep_convection - long_name = flag for Unified deep convection scheme +[imfdeepcnv_c3] + standard_name = identifier_for_c3_deep_convection + long_name = flag for C3 deep convection scheme units = flag dimensions = () type = integer @@ -78,9 +78,9 @@ dimensions = () type = integer intent = in -[imfshalcnv_unified] - standard_name = identifier_for_unified_shallow_convection - long_name = flag for Unified shallow convection scheme +[imfshalcnv_c3] + standard_name = identifier_for_c3_shallow_convection + long_name = flag for C3 shallow convection scheme units = flag dimensions = () type = integer @@ -542,4 +542,4 @@ units = 1 dimensions = () type = integer - intent = out \ No newline at end of file + intent = out diff --git a/physics/cu_unified_deep.F90 b/physics/cu_c3_deep.F90 similarity index 94% rename from physics/cu_unified_deep.F90 rename to physics/cu_c3_deep.F90 index a6be5c450..4ae1989f9 100644 --- a/physics/cu_unified_deep.F90 +++ b/physics/cu_c3_deep.F90 @@ -1,7 +1,7 @@ -!>\file cu_unified_deep.F90 -!! This file is the unified deep convection scheme. +!>\file cu_c3_deep.F90 +!! This file is the C3 deep convection scheme. -module cu_unified_deep +module cu_c3_deep use machine , only : kind_phys use progsigma, only : progsigma_calc @@ -24,12 +24,13 @@ module cu_unified_deep integer, parameter:: use_excess=0 real(kind=kind_phys), parameter :: fluxtune=1.5 !> flag to turn off or modify mom transport by downdrafts - real(kind=kind_phys), parameter :: pgcd = 0.1 + real(kind=kind_phys), parameter :: pgcd = 1. ! !> aerosol awareness, do not use yet! - integer, parameter :: autoconv=1 - integer, parameter :: aeroevap=1 + integer, parameter :: autoconv=1 !2 + integer, parameter :: aeroevap=1 !3 real(kind=kind_phys), parameter :: scav_factor = 0.5 + real(kind=kind_phys), parameter :: dx_thresh = 6500. !> still 16 ensembles for clousres integer, parameter:: maxens3=16 @@ -46,15 +47,15 @@ module cu_unified_deep contains -!>\defgroup cu_unified_deep_group Unified Deep Convection Module -!>\ingroup cu_unified_group -!! This is Unified deep convection scheme module +!>\defgroup cu_c3_deep_group C3 Deep Convection Module +!>\ingroup cu_c3_group +!! This is C3 deep convection scheme module !> @{ - integer function my_maxloc1d(A,N) + integer function my_maxloc1d(A,N,dir) !$acc routine vector implicit none real(kind_phys), intent(in) :: A(:) - integer, intent(in) :: N + integer, intent(in) :: N,dir real(kind_phys) :: imaxval integer :: i @@ -72,8 +73,8 @@ integer function my_maxloc1d(A,N) end function my_maxloc1d !>Driver for the deep or congestus routine. -!! \section general_unified_deep Unified Deep Convection General Algorithm - subroutine cu_unified_deep_run( & +!! \section general_c3_deep C3 Deep Convection General Algorithm + subroutine cu_c3_deep_run( & itf,ktf,its,ite, kts,kte & ,flag_init & ,flag_restart & @@ -461,10 +462,7 @@ subroutine cu_unified_deep_run( & el2orc=xlv*xlv/(r_v*cp) evfact=0.25 ! .4 evfactl=0.25 ! .2 - !evfact=.0 ! for 4F5f - !evfactl=.4 -!cc rainevap(:)=0 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! @@ -527,10 +525,7 @@ subroutine cu_unified_deep_run( & zws(i) = zws(i)*rho(i,kpbl(i)) !check if zrho is correct enddo !$acc end kernels -! cap_maxs=225. -! if(imid.eq.1)cap_maxs=150. cap_maxs=75. ! 150. -! if(imid.eq.1)cap_maxs=100. !$acc kernels do i=its,itf edto(i)=0. @@ -538,13 +533,10 @@ subroutine cu_unified_deep_run( & xmb_out(i)=0. cap_max(i)=cap_maxs cap_max_increment(i)=20. -! if(imid.eq.1)cap_max_increment(i)=10. ! ! for water or ice ! if (xland1(i)==0) then -! if(imid.eq.0)cap_max(i)=cap_maxs-25. -! if(imid.eq.1)cap_max(i)=cap_maxs-50. cap_max_increment(i)=20. else if(ztexec(i).gt.0.)cap_max(i)=cap_max(i)+25. @@ -553,7 +545,6 @@ subroutine cu_unified_deep_run( & #ifndef _OPENACC ierrc(i)=" " #endif -! cap_max_increment(i)=1. enddo !$acc end kernels if(use_excess == 0 )then @@ -588,8 +579,8 @@ subroutine cu_unified_deep_run( & c1d(i,:)= 0. !c1 ! 0. ! c1 ! max(.003,c1+float(csum(i))*.0001) entr_rate(i)=7.e-5 - min(20.,float(csum(i))) * 3.e-6 if(xland1(i) == 0)entr_rate(i)=7.e-5 + if(dx(i) frh_thresh)then @@ -599,6 +590,7 @@ subroutine cu_unified_deep_run( & endif sig(i)=(1.-frh)**2 frh_out(i) = frh + if((dx(i) - Compute downdraft moist static energy + moisture budget do k=2,jmin(i)+1 @@ -1454,7 +1308,6 @@ subroutine cu_unified_deep_run( & dbydo(i,ki)=hcdo(i,ki)-heso_cup(i,ki) bud(i)=bud(i)+dbydo(i,ki)*dzo enddo - ! endif if(bud(i).gt.0)then ierr(i)=7 @@ -1470,29 +1323,10 @@ subroutine cu_unified_deep_run( & ! call cup_dd_moisture(ierrc,zdo,hcdo,heso_cup,qcdo,qeso_cup, & pwdo,qo_cup,zo_cup,dd_massentro,dd_massdetro,jmin,ierr,gammao_cup, & - pwevo,bu,qrcdo,qo,heo,1, & + pwevo,bu,qrcdo,po_cup,qo,heo,1, & itf,ktf, & its,ite, kts,kte) ! -!---meltglac------------------------------------------------- -!--- calculate moisture properties of updraft -! -! if(imid.eq.1)then -! call cup_up_moisture('mid',ierr,zo_cup,qco,qrco,pwo,pwavo, & -! p_cup,kbcon,ktop,dbyo,clw_all,xland1, & -! qo,gammao_cup,zuo,qeso_cup,k22,qo_cup,c0, & -! zqexec,ccn,rho,c1d,tn_cup,up_massentr,up_massdetr,psum,psumh, & -! 1,itf,ktf, & -! its,ite, kts,kte) -! else -! call cup_up_moisture('deep',ierr,zo_cup,qco,qrco,pwo,pwavo, & -! p_cup,kbcon,ktop,dbyo,clw_all,xland1, & -! qo,gammao_cup,zuo,qeso_cup,k22,qo_cup,c0, & -! zqexec,ccn,rho,c1d,tn_cup,up_massentr,up_massdetr,psum,psumh, & -! 1,itf,ktf, & -! its,ite, kts,kte) -! endif -!---meltglac------------------------------------------------- !$acc kernels do i=its,itf if(ierr(i)/=0)cycle @@ -1517,7 +1351,7 @@ subroutine cu_unified_deep_run( & !> - Call cup_up_aa0() to calculate workfunctions for updrafts - + call cup_up_aa0(aa0,z,zu,dby,gamma_cup,t_cup, & kbcon,ktop,ierr, & itf,ktf, & @@ -1537,7 +1371,6 @@ subroutine cu_unified_deep_run( & #endif endif enddo - !$acc end kernels @@ -1555,8 +1388,8 @@ subroutine cu_unified_deep_run( & tau_ecmwf (:) = 0. !$acc end kernels !- way to calculate the fraction of cape consumed by shallow convection - iversion=1 ! ecmwf - !iversion=0 ! orig + !iversion=1 ! ecmwf + iversion=0 ! orig ! ! betchold et al 2008 time-scale of cape removal ! @@ -1596,6 +1429,29 @@ subroutine cu_unified_deep_run( & endif enddo !$acc end kernels +!$acc kernels + !-get the profiles modified only by bl tendencies + do i=its,itf + tn_bl(i,:)=0.;qo_bl(i,:)=0. + if ( ierr(i) == 0 )then + !below kbcon -> modify profiles + tn_bl(i,1:kbcon(i)) = tn(i,1:kbcon(i)) + qo_bl(i,1:kbcon(i)) = qo(i,1:kbcon(i)) + !above kbcon -> keep environment profiles + tn_bl(i,kbcon(i)+1:ktf) = t(i,kbcon(i)+1:ktf) + qo_bl(i,kbcon(i)+1:ktf) = q(i,kbcon(i)+1:ktf) + endif + enddo +!$acc end kernels + !> - Call cup_env() to calculate moist static energy, heights, qes, ... only by bl tendencies + call cup_env(zo,qeso_bl,heo_bl,heso_bl,tn_bl,qo_bl,po,z1, & + psur,ierr,tcrit,-1, & + itf,ktf, its,ite, kts,kte) + !> - Call cup_env_clev() to calculate environmental values on cloud levels only by bl tendencies + call cup_env_clev(tn_bl,qeso_bl,qo_bl,heo_bl,heso_bl,zo,po,qeso_cup_bl,qo_cup_bl, & + heo_cup_bl,heso_cup_bl,zo_cup,po_cup,gammao_cup_bl,tn_cup_bl,psur,& + ierr,z1, & + itf,ktf,its,ite, kts,kte) if(iversion == 1) then !-- version ecmwf @@ -1628,29 +1484,6 @@ subroutine cu_unified_deep_run( & !- version for real cloud-work function -!$acc kernels - !-get the profiles modified only by bl tendencies - do i=its,itf - tn_bl(i,:)=0.;qo_bl(i,:)=0. - if ( ierr(i) == 0 )then - !below kbcon -> modify profiles - tn_bl(i,1:kbcon(i)) = tn(i,1:kbcon(i)) - qo_bl(i,1:kbcon(i)) = qo(i,1:kbcon(i)) - !above kbcon -> keep environment profiles - tn_bl(i,kbcon(i)+1:ktf) = t(i,kbcon(i)+1:ktf) - qo_bl(i,kbcon(i)+1:ktf) = q(i,kbcon(i)+1:ktf) - endif - enddo -!$acc end kernels - !> - Call cup_env() to calculate moist static energy, heights, qes, ... only by bl tendencies - call cup_env(zo,qeso_bl,heo_bl,heso_bl,tn_bl,qo_bl,po,z1, & - psur,ierr,tcrit,-1, & - itf,ktf, its,ite, kts,kte) - !> - Call cup_env_clev() to calculate environmental values on cloud levels only by bl tendencies - call cup_env_clev(tn_bl,qeso_bl,qo_bl,heo_bl,heso_bl,zo,po,qeso_cup_bl,qo_cup_bl, & - heo_cup_bl,heso_cup_bl,zo_cup,po_cup,gammao_cup_bl,tn_cup_bl,psur, & - ierr,z1, & - itf,ktf,its,ite, kts,kte) !$acc kernels do i=its,itf if(ierr(i).eq.0)then @@ -1689,7 +1522,6 @@ subroutine cu_unified_deep_run( & enddo endif enddo - !$acc end kernels !> - Call cup_ip_aa0() to calculate workfunctions for updrafts call cup_up_aa0(aa1_bl,zo,zuo,dbyo_bl,gammao_cup_bl,tn_cup_bl, & @@ -1709,7 +1541,7 @@ subroutine cu_unified_deep_run( & aa1_bl(i) = aa1_bl(i)* tau_bl(i)/ dtime !endif #ifndef _OPENACC - print*,'aa0,aa1bl=',aa0(i),aa1_bl(i),aa0(i)-aa1_bl(i),tau_bl(i)!,dtime,xland(i) +! print*,'aa0,aa1bl=',aa0(i),aa1_bl(i),aa0(i)-aa1_bl(i),tau_bl(i)!,dtime,xland(i) #endif endif enddo @@ -1724,9 +1556,9 @@ subroutine cu_unified_deep_run( & ! !> - Call cup_dd_edt() to determine downdraft strength in terms of windshear ! - call cup_dd_edt(ierr,us,vs,zo,ktop,kbcon,edt,po,pwavo, & - pwo,ccn,ccnclean,pwevo,edtmax,edtmin,edtc,psum,psumh, & - rho,aeroevap,pefc,itf,ktf, & + call cup_dd_edt(ierr,us,vs,zo,ktop,kbcon,edt,po,pwavo, & + pwo,ccn,ccnclean,pwevo,edtmax,edtmin,edtc,psum,psumh, & + rho,aeroevap,pefc,xland1,itf,ktf, & its,ite, kts,kte) do i=its,itf if(ierr(i)/=0)cycle @@ -1735,8 +1567,8 @@ subroutine cu_unified_deep_run( & !> - Call get_melting_profile() to get melting profile call get_melting_profile(ierr,tn_cup,po_cup, p_liq_ice,melting_layer,qrco & - ,pwo,edto,pwdo,melting & - ,itf,ktf,its,ite, kts,kte, cumulus ) + ,pwo,edto,pwdo,melting & + ,itf,ktf,its,ite,kts,kte,cumulus) !$acc kernels do k=kts,ktf do i=its,itf @@ -1912,16 +1744,12 @@ subroutine cu_unified_deep_run( & !-- take out cloud liquid water for detrainment detup=up_massdetro(i,k) dz=zo_cup(i,k)-zo_cup(i,k-1) -!! if(k.lt.ktop(i) .and. k.ge.jmin(i)) then -!! if(k.lt.ktop(i) .and. c1d(i,k).gt.0) then if(k.lt.ktop(i)) then dellaqc(i,k) = zuo(i,k)*c1d(i,k)*qrco(i,k)*dz/dp*g else dellaqc(i,k)= detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp endif -!! if(imid.eq.1) dellaqc(i,k)= detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp -! if(k.eq.ktop(i))dellaqc(i,k)= detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp -! !--- + !--- g_rain= 0.5*(pwo (i,k)+pwo (i,k+1))*g/dp e_dn = -0.5*(pwdo(i,k)+pwdo(i,k+1))*g/dp*edto(i) ! pwdo < 0 and e_dn must > 0 !-- condensation source term = detrained + flux divergence of @@ -2188,6 +2016,9 @@ subroutine cu_unified_deep_run( & imid,ipr,itf,ktf, & its,ite, kts,kte, & dicycle,tau_ecmwf,aa1_bl,xf_dicycle,xf_progsigma) + do i=its,itf + if((dx(i) Calculates tracer fluxes due to subsidence, only up-stream differencing @@ -2665,9 +2499,9 @@ end subroutine rain_evap_below_cloudbase !> Calculates strength of downdraft based on windshear and/or !! aerosol content. - subroutine cup_dd_edt(ierr,us,vs,z,ktop,kbcon,edt,p,pwav, & - pw,ccn,ccnclean,pwev,edtmax,edtmin,edtc,psum2,psumh, & - rho,aeroevap,pefc,itf,ktf, & + subroutine cup_dd_edt(ierr,us,vs,z,ktop,kbcon,edt,p,pwav, & + pw,ccn,ccnclean,pwev,edtmax,edtmin,edtc,psum2,psumh, & + rho,aeroevap,pefc,xland1,itf,ktf, & its,ite, kts,kte ) implicit none @@ -2696,7 +2530,7 @@ subroutine cup_dd_edt(ierr,us,vs,z,ktop,kbcon,edt,p,pwav, & pwav,pwev,psum2,psumh,edtmax,edtmin integer, dimension (its:ite) & ,intent (in ) :: & - ktop,kbcon + ktop,kbcon,xland1 real(kind=kind_phys), intent (in ) :: & !HCB ccnclean real(kind=kind_phys), dimension (its:ite) & @@ -2777,30 +2611,30 @@ subroutine cup_dd_edt(ierr,us,vs,z,ktop,kbcon,edt,p,pwav, & edt(i)=1.-.5*(pefb+pef) if(aeroevap.gt.1)then + pefb=.5 + if(xland1(i) == 1)pefb=.3 aeroadd=0. if((psumh(i)>0.).and.(psum2(i)>0.))then - aeroadd=((1.e-2*ccnclean)**beta3)*(psumh(i)**(alpha3-1)) - prop_c=.5*(pefb+pef)/aeroadd - aeroadd=((1.e-2*ccn(i))**beta3)*(psum2(i)**(alpha3-1)) + aeroadd=((ccnclean)**beta3)*(psumh(i)**(alpha3-1)) + prop_c=pefb/aeroadd + aeroadd=((ccn(i))**beta3)*(psum2(i)**(alpha3-1)) aeroadd=prop_c*aeroadd pefc(i)=aeroadd if(pefc(i).gt.0.9)pefc(i)=0.9 if(pefc(i).lt.0.1)pefc(i)=0.1 edt(i)=1.-pefc(i) - if(aeroevap.eq.2)edt(i)=1.-.25*(pefb+pef+2.*pefc(i)) endif endif !--- edt here is 1-precipeff! - einc=.2*edt(i) - edtc(i,1)=edt(i)-einc + edtc(i,1)=edt(i) endif enddo do i=its,itf if(ierr(i).eq.0)then - edtc(i,1)=-edtc(i,1)*pwav(i)/pwev(i) + edtc(i,1)=-edtc(i,1)*psum2(i)/pwev(i) if(edtc(i,1).gt.edtmax(i))edtc(i,1)=edtmax(i) if(edtc(i,1).lt.edtmin(i))edtc(i,1)=edtmin(i) endif @@ -2812,7 +2646,7 @@ end subroutine cup_dd_edt !> Calcultes moisture properties of downdrafts. subroutine cup_dd_moisture(ierrc,zd,hcd,hes_cup,qcd,qes_cup, & pwd,q_cup,z_cup,dd_massentr,dd_massdetr,jmin,ierr, & - gamma_cup,pwev,bu,qrcd, & + gamma_cup,pwev,bu,qrcd,p_cup, & q,he,iloop, & itf,ktf, & its,ite, kts,kte ) @@ -2842,7 +2676,7 @@ subroutine cup_dd_moisture(ierrc,zd,hcd,hes_cup,qcd,qes_cup, & real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (in ) :: & zd,hes_cup,hcd,qes_cup,q_cup,z_cup, & - dd_massentr,dd_massdetr,gamma_cup,q,he + dd_massentr,dd_massdetr,gamma_cup,q,he,p_cup !$acc declare copyin(zd,hes_cup,hcd,qes_cup,q_cup,z_cup,dd_massentr,dd_massdetr,gamma_cup,q,he) integer & ,intent (in ) :: & @@ -2870,7 +2704,7 @@ subroutine cup_dd_moisture(ierrc,zd,hcd,hes_cup,qcd,qes_cup, & integer :: & i,k,ki real(kind=kind_phys) :: & - denom,dh,dz,dqeva + denom,dp,dh,dz,dqeva !$acc kernels do i=its,itf @@ -2891,6 +2725,7 @@ subroutine cup_dd_moisture(ierrc,zd,hcd,hes_cup,qcd,qes_cup, & if(ierr(i).eq.0)then k=jmin(i) dz=z_cup(i,k+1)-z_cup(i,k) + dp=-100.*(p_cup(i,k+1)-p_cup(i,k)) qcd(i,k)=q_cup(i,k) dh=hcd(i,k)-hes_cup(i,k) if(dh.lt.0)then @@ -2901,12 +2736,13 @@ subroutine cup_dd_moisture(ierrc,zd,hcd,hes_cup,qcd,qes_cup, & endif pwd(i,jmin(i))=zd(i,jmin(i))*min(0.,qcd(i,k)-qrcd(i,k)) qcd(i,k)=qrcd(i,k) - pwev(i)=pwev(i)+pwd(i,jmin(i)) ! *dz + pwev(i)=pwev(i)+pwd(i,jmin(i))*g/dp ! *dz ! bu(i)=dz*dh !$acc loop seq do ki=jmin(i)-1,1,-1 dz=z_cup(i,ki+1)-z_cup(i,ki) + dp=-100.*(p_cup(i,ki+1)-p_cup(i,ki)) ! qcd(i,ki)=(qcd(i,ki+1)*(1.-.5*cdd(i,ki+1)*dz) & ! +entr*dz*q(i,ki) & ! )/(1.+entr*dz-.5*cdd(i,ki+1)*dz) @@ -2939,10 +2775,7 @@ subroutine cup_dd_moisture(ierrc,zd,hcd,hes_cup,qcd,qes_cup, & endif pwd(i,ki)=zd(i,ki)*dqeva qcd(i,ki)=qrcd(i,ki) - pwev(i)=pwev(i)+pwd(i,ki) ! *dz -! if(iloop.eq.1.and.i.eq.102.and.j.eq.62)then -! print *,'in cup_dd_moi ', hcd(i,ki),hes_cup(i,ki),dh,dqeva -! endif + pwev(i)=pwev(i)+pwd(i,ki)*g/dp enddo ! !--- end loop over i @@ -3390,11 +3223,11 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 xff_ens3(4)=betajb*xff_ens3(4) xff_ens3(5)=xff_ens3(4) xff_ens3(6)=xff_ens3(4) + forcing(i,2)=xff_ens3(4) if(xff_ens3(4).lt.0.)xff_ens3(4)=0. if(xff_ens3(5).lt.0.)xff_ens3(5)=0. if(xff_ens3(6).lt.0.)xff_ens3(6)=0. xff_ens3(14)=xff_ens3(4) - forcing(i,2)=xff_ens3(4) ! !--- more like krishnamurti et al.; pick max and average values ! @@ -3410,7 +3243,8 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 xff_ens3(11)=aa1(i)/tau_ecmwf(i) xff_ens3(12)=aa1(i)/tau_ecmwf(i) xff_ens3(13)=(aa1(i))/tau_ecmwf(i) !(60.*15.) !tau_ecmwf(i) -! forcing(i,4)=xff_ens3(10) + forcing(i,4)=xff_ens3(10) +! forcing(i,5)= aa1_bl(i)/tau_ecmwf(i) !!- more like bechtold et al. (jas 2014) !! if(dicycle == 1) xff_dicycle = max(0.,aa1_bl(i)/tau_ecmwf(i)) !(60.*30.) !tau_ecmwf(i) @@ -3431,13 +3265,16 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 endif ! ichoice xk(1)=(xaa0(i,1)-aa1(i))/mbdt - forcing(i,4)=aa0(i) - forcing(i,5)=aa1(i) - forcing(i,6)=xaa0(i,1) - forcing(i,7)=xk(1) - if(xk(1).le.0.and.xk(1).gt.-.01*mbdt) & + forcing(i,8)=mbdt*xk(1)/aa1(i) +! if(forcing(i,1).lt.0. .or. forcing(i,8).gt.-4.)ierr(i)=333 +! if(forcing(i,2).lt.-0.05)ierr(i)=333 +! forcing(i,4)=aa0(i) +! forcing(i,5)=aa1(i) +! forcing(i,6)=xaa0(i,1) +! forcing(i,7)=xk(1) + if(xk(1).lt.0.and.xk(1).gt.-.01*mbdt) & xk(1)=-.01*mbdt - if(xk(1).gt.0.and.xk(1).lt.1.e-2) & + if(xk(1).ge.0.and.xk(1).lt.1.e-2) & xk(1)=1.e-2 ! enddo ! @@ -3528,13 +3365,13 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 xf_ens(i,11)=xf_ens(i,11)+xf_ens(i,11)*rand_clos(i,4) xf_ens(i,12)=xf_ens(i,12)+xf_ens(i,12)*rand_clos(i,4) xf_ens(i,13)=xf_ens(i,13)+xf_ens(i,13)*rand_clos(i,4) - forcing(i,8)=xf_ens(i,11) +! forcing(i,8)=xf_ens(i,11) else xf_ens(i,10)=0. xf_ens(i,11)=0. xf_ens(i,12)=0. xf_ens(i,13)=0. - forcing(i,8)=0. + !forcing(i,8)=0. endif !srf-begin !! if(xk(1).lt.0.)then @@ -3586,13 +3423,16 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 if(ierr(i) /= 0)cycle xk(1)=(xaa0(i,1)-aa1(i))/mbdt - if(xk(1).le.0.and.xk(1).gt.-.01*mbdt) xk(1)=-.01*mbdt - if(xk(1).gt.0.and.xk(1).lt.1.e-2) xk(1)=1.e-2 - +! forcing(i,8)=xk(1) + if(xk(1).lt.0.and.xk(1).gt.-.01*mbdt) xk(1)=-.01*mbdt + if(xk(1).ge.0.and.xk(1).lt.1.e-2) xk(1)=1.e-2 + xff_dicycle = (aa1(i)-aa1_bl(i))/tau_ecmwf(i) +! forcing(i,8)=xff_dicycle if(xk(1).lt.0) xf_dicycle(i)= max(0.,-xff_dicycle/xk(1)) - + xf_dicycle(i)= xf_ens(i,10)-xf_dicycle(i) +! forcing(i,6)=xf_dicycle(i) enddo !$acc end kernels else @@ -4266,7 +4106,11 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & ! --- now use proper count of how many closures were actually ! used in cup_forcing_ens (including screening of some ! closures over water) to properly normalize xmb + if (dx(i).ge.dx_thresh)then clos_wei=16./max(1.,closure_n(i)) + else + clos_wei=1. + endif xmb_ave(i)=min(xmb_ave(i),100.) xmb(i)=clos_wei*sig(i)*xmb_ave(i) @@ -4473,13 +4317,15 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & iprop,iall,i,k integer :: start_level(its:ite),kklev(its:ite) !$acc declare create(start_level,kklev) - real(kind=kind_phys) :: & - prop_ave,qrcb_h,bdsp,dp,rhoc,qrch,qaver,clwdet, & + real(kind=kind_phys) :: & + prop_ave,qrcb_h,dp,rhoc,qrch,qaver,clwdet, & dz,berryc0,q1,berryc - real(kind=kind_phys) :: & + real(kind=kind_phys) :: & denom, c0t, c0_iceconv - real(kind=kind_phys), dimension (kts:kte) :: & + real(kind=kind_phys), dimension (kts:kte) :: & prop_b + real(kind=kind_phys), dimension (its:ite) :: & + bdsp !$acc declare create(prop_b) ! real(kind=kind_phys), parameter:: zero = 0 @@ -4495,7 +4341,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & clwdet=0.1 !0.02 c0_iceconv=0.01 c1d_b=c1d - bdsp=bdispm + bdsp(:)=bdispm ! !--- no precip for small clouds @@ -4509,6 +4355,11 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & pwavh(i)=0. psum(i)=0. psumh(i)=0. + if (xland1(i) .eq. 0) then + bdsp(i)=bdispm + else + bdsp(i)=bdispc + endif enddo do k=kts,ktf do i=its,itf @@ -4575,6 +4426,10 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & qc(i,k)=qrch+qrc(i,k) clw_all(i,k)=qrc(i,k) endif + clw_allh(i,k)=clw_all(i,k) + qrcb(i,k)=qrc(i,k) + pwh(i,k)=pw(i,k) + qch(i,k)=qc(i,k) enddo ! endif ! @@ -4590,6 +4445,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & endif if(is_mid)c0t=0.004 + if(autoconv .gt.1) c0t=c0(i) denom=zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1) if(denom.lt.1.e-16)then ierr(i)=51 @@ -4599,7 +4455,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & rhoc=.5*(rho(i,k)+rho(i,k-1)) dz=z_cup(i,k)-z_cup(i,k-1) - dp=p_cup(i,k)-p_cup(i,k-1) + dp=-100.*(p_cup(i,k)-p_cup(i,k-1)) ! !--- saturation in cloud, this is what is allowed to be in it ! @@ -4632,10 +4488,10 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & qrcb(i,k)=max(0.,(qch(i,k)-qrch)) ! /(1.+c0(i)*dz*zu(i,k)) if(is_deep)then clwdet=0.1 !0.02 ! 05/11/2021 - if(k.lt.kklev(i)) clwdet=0. ! 05/05/2021 + !if(k.lt.kklev(i)) clwdet=0. ! 05/05/2021 else clwdet=0.1 !0.02 ! 05/05/2021 - if(k.lt.kklev(i)) clwdet=0. ! 05/25/2021 + !if(k.lt.kklev(i)) clwdet=0. ! 05/25/2021 endif if(k.gt.kbcon(i)+1)c1d(i,k)=clwdet*up_massdetr(i,k-1) if(k.gt.kbcon(i)+1)c1d_b(i,k)=clwdet*up_massdetr(i,k-1) @@ -4648,50 +4504,52 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & ! this will also determine proportionality constant prop_b, which, if applied, ! would give the same results as c0 under these conditions ! - q1=1.e3*rhoc*clw_allh(i,k) ! g/m^3 ! g[h2o]/cm^3 - berryc0=q1*q1/(60.0*(5.0 + 0.0366*ccnclean/ & - ( q1 * bdsp) ) ) !/( +! Berry conversion for clean atmosphere +! + q1=1.e3*rhoc*clw_allh(i,k) +! pwh units are kg/kg, but normalized by mass flux. So with massflux kg/m^2/s + pwh(i,k)=c0t*dz*zu(i,k)*clw_allh(i,k) qrcb_h=(qch(i,k)-qrch)/(1.+(c1d_b(i,k)+c0t)*dz) - prop_b(k)=(c0t*qrcb_h)/max(1.e-8,(1.e-3*berryc0)) - if(prop_b(k)>5.) prop_b(k)=5. - pwh(i,k)=zu(i,k)*1.e-3*berryc0*dz*prop_b(k) ! 2. - qrcb(i,k)=(max(0.,(qch(i,k)-qrch))*zu(i,k)-pwh(i,k))/(zu(i,k)*(1+c1d_b(i,k)*dz)) - if(qrcb(i,k).lt.0.)then - berryc0=max(0.,(qch(i,k)-qrch))/(1.e-3*dz*prop_b(k)) - pwh(i,k)=zu(i,k)*1.e-3*berryc0*dz*prop_b(k) - qrcb(i,k)=0. + qrcb(i,k)=0. +! unit (B) = g/m^3/s + berryc0=(q1*q1/(60.0*(5.0 + 0.0366*ccnclean*1.e1/ & + ( q1 * bdsp(i)) ) )) +! normalize Berry: berryc0=berryc0*g/dp*dz*zu = pwh, unts become kg/kg +! set 1: + berryc0=1.e-3*berryc0*g/dp*dz + prop_b(k)=pwh(i,k)/berryc0 + qrcb(i,k)=qrcb_h + if(qrcb(i,k).le.0.)then + pwh(i,k)=0. endif qch(i,k)=qrcb(i,k)+qrch pwavh(i)=pwavh(i)+pwh(i,k) - psumh(i)=psumh(i)+pwh(i,k) ! HCB - !psumh(i)=psumh(i)+clw_allh(i,k)*zu(i,k) *dz - ! + psumh(i)=psumh(i)+pwh(i,k)*g/dp !dz !dp/g !*dp ! HCB ! then the real berry ! - q1=1.e3*rhoc*clw_all(i,k) ! g/m^3 ! g[h2o]/cm^3 - berryc0=q1*q1/(60.0*(5.0 + 0.0366*ccn(i)/ & - ( q1 * bdsp) ) ) !/( - berryc0=1.e-3*berryc0*dz*prop_b(k) ! 2. - qrc(i,k)=(max(0.,(qc(i,k)-qrch))*zu(i,k)-zu(i,k)*berryc0)/(zu(i,k)*(1+c1d(i,k)*dz)) + q1=1.e3*rhoc*clw_all(i,k) + berryc=(q1*q1/(60.0*(5.0 + 0.0366*ccn(i)*1.e1/ & + ( q1 * bdsp(i)) ) )) + berryc=1.e-3*berryc*g/dp*dz + pw(i,k)=prop_b(k)*berryc !*dz/zu(i,k) +! use berryc now as new c0 for this level + berryc=pw(i,k)/(dz*zu(i,k)*clw_all(i,k)) + if(qrc(i,k).le.0.)then + berryc=0. + endif + qrc(i,k)=(max(0.,(qc(i,k)-qrch))/(1+(c1d(i,k)+berryc)*dz)) if(qrc(i,k).lt.0.)then - berryc0=max(0.,(qc(i,k)-qrch))/(1.e-3*dz*prop_b(k)) qrc(i,k)=0. + pw(i,k)=0. endif - pw(i,k)=berryc0*zu(i,k) qc(i,k)=qrc(i,k)+qrch ! if not running with berry at all, do the following ! - else !c0=.002 - if(iall.eq.1)then - qrc(i,k)=0. - pw(i,k)=(qc(i,k)-qrch)*zu(i,k) - if(pw(i,k).lt.0.)pw(i,k)=0. - else + else ! create clw detrainment profile that depends on mass detrainment and ! in-cloud clw/ice ! - !c1d(i,k)=clwdet*up_massdetr(i,k-1)*qrc(i,k-1) qrc(i,k)=(qc(i,k)-qrch)/(1.+(c1d(i,k)+c0t)*dz) if(qrc(i,k).lt.0.)then ! hli new test 02/12/19 qrc(i,k)=0. @@ -4705,11 +4563,10 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & qrc(i,k)=0. pw(i,k)=0. endif - endif - qc(i,k)=qrc(i,k)+qrch - endif !autoconv + qc(i,k)=qrc(i,k)+qrch + endif !autoconv pwav(i)=pwav(i)+pw(i,k) - psum(i)=psum(i)+pw(i,k) ! HCB + psum(i)=psum(i)+pw(i,k)*g/dp ! HCB enddo ! k=kbcon,ktop ! do not include liquid/ice in qc !$acc loop independent @@ -4885,9 +4742,6 @@ subroutine rates_up_pdf(rand_vmas,ipr,name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo ierr(i)=41 ktop(i)= 0 else -! call get_zu_zd_pdf_fim(ipr,xland(i),zuh2,"up",ierr(i),start_level(i), & -! call get_zu_zd_pdf_fim(rand_vmas(i),zubeg,ipr,xland(i),zuh2,"up",ierr(i),kbcon(i), & -! kfinalzu,zuo(i,kts:kte),kts,kte,ktf,beta_u,kpbl(i),csum(i),pmin_lev(i)) call get_zu_zd_pdf_fim(kklev,p_cup(i,:),rand_vmas(i),zubeg,ipr,xland(i),zuh2,1,ierr(i),k22(i), & kfinalzu+1,zuo(i,kts:kte),kts,kte,ktf,beta_u,kbcon(i),csum(i),pmin_lev(i)) endif @@ -5016,7 +4870,7 @@ subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,k if(zu(kpbli).gt.0.) & zu(kts:min(ktf,kt-1))= zu(kts:min(ktf,kt-1))/zu(kpbli) - do k=my_maxloc1d(zu(:),kte),1,-1 + do k=my_maxloc1d(zu(:),kte,1),1,-1 if(zu(k).lt.1.e-6)then kb_adj=k+1 exit @@ -5075,7 +4929,7 @@ subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,k ! zu(kts:min(ktf,kt+1))= zu(kts:min(ktf,kt+1))/maxval(zu(kts:min(ktf,kt+1))) if(zu(kpbli).gt.0.) & zu(kts:min(ktf,kt-1))= zu(kts:min(ktf,kt-1))/zu(kpbli) - do k=my_maxloc1d(zu(:),kte),1,-1 + do k=my_maxloc1d(zu(:),kte,1),1,-1 if(zu(k).lt.1.e-6)then kb_adj=k+1 exit @@ -5124,7 +4978,7 @@ subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,k if(zu(kpbli).gt.0.) & zu(kts:min(ktf,kt-1))= zu(kts:min(ktf,kt-1))/zu(kpbli) - do k=my_maxloc1d(zu(:),kte),1,-1 + do k=my_maxloc1d(zu(:),kte,1),1,-1 if(zu(k).lt.1.e-6)then kb_adj=k+1 exit @@ -5365,7 +5219,7 @@ subroutine get_inversion_layers(ierr,p_cup,t_cup,z_cup,qo_cup,qeso_cup,k_inv_lay end subroutine get_inversion_layers !----------------------------------------------------------------------------------- ! DH* 20220604 - this isn't used at all -!!!!>\ingroup cu_unified_deep_group +!!!!>\ingroup cu_c3_deep_group !!!!> This function calcualtes !!! function deriv3(xx, xi, yi, ni, m) !!!!$acc routine vector @@ -6049,4 +5903,4 @@ end subroutine calculate_updraft_velocity !------------------------------------------------------------------------------------ !> @} -end module cu_unified_deep +end module cu_c3_deep diff --git a/physics/cu_unified_driver.F90 b/physics/cu_c3_driver.F90 similarity index 93% rename from physics/cu_unified_driver.F90 rename to physics/cu_c3_driver.F90 index 0e76af979..ea28ad8a7 100644 --- a/physics/cu_unified_driver.F90 +++ b/physics/cu_c3_driver.F90 @@ -1,41 +1,41 @@ -!>\file cu_unified_driver.F90 -!! This file is the unified cumulus scheme driver. +!>\file cu_c3_driver.F90 +!! This file is the Community Convective Cloud (C3) scheme driver. -module cu_unified_driver +module cu_c3_driver - ! DH* TODO: replace constants with arguments to cu_unified_driver_run + ! DH* TODO: replace constants with arguments to cu_c3_driver_run !use physcons , g => con_g, cp => con_cp, xlv => con_hvap, r_v => con_rv use machine , only: kind_phys - use cu_unified_deep, only: cu_unified_deep_run,neg_check,fct1d3 - use cu_unified_sh , only: cu_unified_sh_run + use cu_c3_deep, only: cu_c3_deep_run,neg_check,fct1d3 + use cu_c3_sh , only: cu_c3_sh_run use progsigma , only: progsigma_calc implicit none private - public :: cu_unified_driver_init, cu_unified_driver_run, progsigma_calc + public :: cu_c3_driver_init, cu_c3_driver_run, progsigma_calc contains -!> \defgroup cu_unified_group Grell-Freitas Convection Module +!> \defgroup cu_c3_group Grell-Freitas Convection Module !! This is the Grell-Freitas scale and aerosol aware scheme. !>@{ -!>\defgroup cu_unified_driver Grell-Freitas Convection Driver Module -!> \ingroup cu_unified_group +!>\defgroup cu_c3_driver Grell-Freitas Convection Driver Module +!> \ingroup cu_c3_group !> This is Grell-Freitas cumulus scheme driver module. !! -!! \section arg_table_cu_unified_driver_init Argument Table -!! \htmlinclude cu_unified_driver_init.html +!! \section arg_table_cu_c3_driver_init Argument Table +!! \htmlinclude cu_c3_driver_init.html !! - subroutine cu_unified_driver_init(imfshalcnv, imfshalcnv_unified, imfdeepcnv, & - imfdeepcnv_unified,mpirank, mpiroot, errmsg, errflg) + subroutine cu_c3_driver_init(imfshalcnv, imfshalcnv_c3, imfdeepcnv, & + imfdeepcnv_c3,mpirank, mpiroot, errmsg, errflg) implicit none - integer, intent(in) :: imfshalcnv, imfshalcnv_unified - integer, intent(in) :: imfdeepcnv, imfdeepcnv_unified + integer, intent(in) :: imfshalcnv, imfshalcnv_c3 + integer, intent(in) :: imfdeepcnv, imfdeepcnv_c3 integer, intent(in) :: mpirank integer, intent(in) :: mpiroot character(len=*), intent( out) :: errmsg @@ -45,7 +45,7 @@ subroutine cu_unified_driver_init(imfshalcnv, imfshalcnv_unified, imfdeepcnv, & errmsg = '' errflg = 0 - end subroutine cu_unified_driver_init + end subroutine cu_c3_driver_init ! ! t2di is temp after advection, but before physics @@ -53,11 +53,11 @@ end subroutine cu_unified_driver_init !=================== !> This is the Grell-Freitas convection scheme driver module. -!! \section arg_table_cu_unified_driver_run Argument Table -!! \htmlinclude cu_unified_driver_run.html +!! \section arg_table_cu_c3_driver_run Argument Table +!! \htmlinclude cu_c3_driver_run.html !! -!>\section gen_unified_driver Grell-Freitas Cumulus Scheme Driver General Algorithm - subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& +!>\section gen_c3_driver Grell-Freitas Cumulus Scheme Driver General Algorithm + subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& do_ca,progsigma,cactiv,cactiv_m,g,cp,fv,r_d,xlv,r_v,forcet, & forceqv_spechum,phil,delp,raincv,tmf,qmicro,sigmain, & qv_spechum,t,cld1d,us,vs,t2di,w,qv2di_spechum,p2di,psuri, & @@ -68,7 +68,7 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& index_of_y_wind,index_of_process_scnv,index_of_process_dcnv, & fhour,fh_dfi_radar,ix_dfi_radar,num_dfi_radar,cap_suppress, & dfi_radar_max_intervals,ldiag3d,qci_conv,do_cap_suppress, & - sigmaout,errmsg,errflg) + sigmaout, maxupmf,ichoice_in,ichoicem_in,ichoice_s_in,errmsg,errflg) !------------------------------------------------------------- implicit none integer, parameter :: maxiens=1 @@ -76,12 +76,11 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& integer, parameter :: maxens2=1 integer, parameter :: maxens3=16 integer, parameter :: ensdim=16 - integer, parameter :: imid_gf=1 ! testgf2 turn on middle gf conv. + integer :: imid_gf=1 ! gf congest conv. integer, parameter :: ideep=1 - integer, parameter :: ichoice=0 ! 0 2 5 13 8 - !integer, parameter :: ichoicem=5 ! 0 2 5 13 - integer, parameter :: ichoicem=13 ! 0 2 5 13 - integer, parameter :: ichoice_s=3 ! 0 1 2 3 + integer :: ichoice=0 ! 0 2 5 13 8 + integer :: ichoicem=13 ! 0 2 5 13 + integer :: ichoice_s=3 ! 0 1 2 3 logical, intent(in) :: do_cap_suppress real(kind=kind_phys), parameter :: aodc0=0.14 @@ -93,6 +92,7 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& !------------------------------------------------------------- integer :: its,ite, jts,jte, kts,kte integer, intent(in ) :: im,km,ntracer + integer, intent(in ) :: ichoice_in,ichoicem_in,ichoice_s_in logical, intent(in ) :: flag_init, flag_restart logical, intent(in ) :: flag_for_scnv_generic_tend,flag_for_dcnv_generic_tend, & do_ca,progsigma @@ -135,7 +135,7 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ! ruc variable real(kind=kind_phys), dimension (:), intent(in) :: hfx2,qfx2,psuri,ca_deep real(kind=kind_phys), dimension (:,:), intent(out) :: ud_mf,dd_mf,dt_mf - real(kind=kind_phys), dimension (:), intent(out) :: raincv,cld1d,rainevap + real(kind=kind_phys), dimension (:), intent(out) :: raincv,cld1d,maxupmf,rainevap real(kind=kind_phys), dimension (:,:), intent(in) :: t2di,p2di !$acc declare copyin(hfx2,qfx2,psuri,t2di,p2di) !$acc declare copyout(ud_mf,dd_mf,dt_mf,raincv,cld1d) @@ -234,7 +234,7 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ! gf needs them in w/m2. define hfx and qfx after simple unit conversion real(kind=kind_phys), dimension (im) :: hfx,qfx !$acc declare create(hfx,qfx) - real(kind=kind_phys) tem,tem1,tf,tcr,tcrf + real(kind=kind_phys) tem,tem1,tf,tcr,tcrf,psum real(kind=kind_phys) :: cliw_shal,clcw_shal,tem_shal, cliw_both, weight_sum real(kind=kind_phys) :: cliw_deep,clcw_deep,tem_deep, clcw_both integer :: cliw_deep_idx, clcw_deep_idx, cliw_shal_idx, clcw_shal_idx @@ -252,6 +252,10 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& errmsg = '' errflg = 0 + ichoice = ichoice_in + ichoicem = ichoicem_in + ichoice_s = ichoice_s_in + if(do_cap_suppress) then !$acc serial do itime=1,num_dfi_radar @@ -343,10 +347,7 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& edtd(:)=0. zdd(:,:)=0. flux_tun(:)=5. -! 10/11/2016 dx and tscl_kf are replaced with input dx(i), is dlength. ! dx for scale awareness -! dx=40075000./float(lonf) -! tscl_kf=dx/25000. !$acc end kernels if (imfshalcnv == 5) then @@ -550,6 +551,9 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& subm(:,:)=0. dhdt(:,:)=0. + frhm(:)=0. + frhd(:)=0. + do k=kts,ktf do i=its,itf p2d(i,k)=0.01*p2di(i,k) @@ -614,17 +618,33 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& endif enddo enddo + do i = its,itf + psum=0. + do k=kts,ktf-3 + if (clcw(i,k) .gt. -999.0 .and. clcw(i,k+1) .gt. -999.0 )then + dp=(p2d(i,k)-p2d(i,k+1)) + psum=psum+dp + clwtot = cliw(i,k) + clcw(i,k) + if(clwtot.lt.1.e-32)clwtot=0. + forcing(i,7)=forcing(i,7)+clwtot*dp + endif + enddo + if(psum.gt.0)forcing(i,7)=forcing(i,7)/psum + forcing2(i,7)=forcing(i,7) + enddo do k=kts,ktf-1 do i = its,itf omeg(i,k)= w(i,k) !-g*rhoi(i,k)*w(i,k) -! dq=(q2d(i,k+1)-q2d(i,k)) -! mconv(i)=mconv(i)+omeg(i,k)*dq/g enddo enddo do i = its,itf if(mconv(i).lt.0.)mconv(i)=0. enddo !$acc end kernels + if (dx(its)<6500.) then + ichoice=10 + imid_gf=0 + endif ! !---- call cumulus parameterization ! @@ -637,16 +657,16 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& enddo !$acc end kernels ! -!> - Call shallow: cu_unified_sh_run() +!> - Call shallow: cu_c3_sh_run() ! - call cu_unified_sh_run (us,vs, & + call cu_c3_sh_run (us,vs, & ! input variables, must be supplied zo,t2d,q2d,ter11,tshall,qshall,p2d,psur,dhdt,kpbli, & rhoi,hfx,qfx,xlandi,ichoice_s,tcrit,dt, & ! input variables. ierr should be initialized to zero or larger than zero for ! turning off shallow convection for grid points zus,xmbs,kbcons,ktops,k22s,ierrs,ierrcs, & -!Prog closure +! Prog closure flag_init, flag_restart,fv,r_d,delp,tmfq,qmicro, & forceqv_spechum,sigmain,sigmaout,progsigma,dx, & ! output tendencies @@ -666,9 +686,9 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ipr=0 jpr_deep=0 !340765 -!> - Call cu_unified_deep_run() for middle GF convection +!> - Call cu_c3_deep_run() for middle GF convection if(imid_gf == 1)then - call cu_unified_deep_run( & + call cu_c3_deep_run( & itf,ktf,its,ite, kts,kte & ,flag_init & ,flag_restart & @@ -685,7 +705,7 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,xlandi & ,delp & ,zo & - ,forcing2 & + ,forcing & ,t2d & ,q2d & ,tmfq & @@ -696,14 +716,14 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,ter11 & ,tshall & ,qshall & - ,p2d & + ,p2d & ,psur & ,us & ,vs & ,rhoi & ,hfx & ,qfx & - ,dx & !hj dx(im) + ,dx & ,do_ca & ,progsigma & ,ca_deep & @@ -757,9 +777,9 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& call neg_check('mid',ipn,dt,qcheck,outqm,outtm,outum,outvm, & outqcm,pretm,its,ite,kts,kte,itf,ktf,ktopm) endif -!> - Call cu_unified_deep_run() for deep GF convection +!> - Call cu_c3_deep_run() for deep GF convection if(ideep.eq.1)then - call cu_unified_deep_run( & + call cu_c3_deep_run( & itf,ktf,its,ite, kts,kte & ,flag_init & ,flag_restart & @@ -776,7 +796,7 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,xlandi & ,delp & ,zo & - ,forcing & + ,forcing2 & ,t2d & ,q2d & ,tmfq & @@ -794,7 +814,7 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,rhoi & ,hfx & ,qfx & - ,dx & !hj replace dx(im) + ,dx & ,do_ca & ,progsigma & ,ca_deep & @@ -852,25 +872,6 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& outqc,pret,its,ite,kts,kte,itf,ktf,ktop) ! endif -! do i=its,itf -! kcnv(i)=0 -! if(pret(i).gt.0.)then -! cuten(i)=1. -! kcnv(i)= 1 !jmin(i) -! else -! kbcon(i)=0 -! ktop(i)=0 -! cuten(i)=0. -! endif ! pret > 0 -! if(pretm(i).gt.0.)then -! kcnv(i)= 1 !jmin(i) -! cutenm(i)=1. -! else -! kbconm(i)=0 -! ktopm(i)=0 -! cutenm(i)=0. -! endif ! pret > 0 -! enddo !$acc kernels do i=its,itf kcnv(i)=0 @@ -917,6 +918,7 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& endif dtime_max=dt + forcing2(i,3)=0. do k=kts,kstop cnvc(i,k) = 0.04 * log(1. + 675. * zu(i,k) * xmb(i)) + & 0.04 * log(1. + 675. * zum(i,k) * xmbm(i)) + & @@ -991,6 +993,7 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& -(xmbm(i)*(zdm(i,k)-edtm(i)*zdm(i,k))) & -(xmbs(i)*zus(i,k)) trcflx_in1(k)=massflx(k)*.5*(clwtot+clwtot1) + forcing2(i,3)=forcing2(i,3)+clwtot endif enddo @@ -1028,6 +1031,13 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& gdc(i,13,10)=hfx(i) gdc(i,15,10)=qfx(i) gdc(i,16,10)=pret(i)*3600. + + if(forcing(i,6).gt.0.)then + maxupmf(i)=maxval(xmb(i)*zu(i,kts:ktf)/forcing(i,6)) + else + maxupmf(i)=0. + endif + if(ktop(i).gt.2 .and.pret(i).gt.0.)dt_mf(i,ktop(i)-1)=ud_mf(i,ktop(i)) endif enddo @@ -1192,6 +1202,6 @@ subroutine cu_unified_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& !$acc end parallel endif endif - end subroutine cu_unified_driver_run + end subroutine cu_c3_driver_run !>@} -end module cu_unified_driver +end module cu_c3_driver diff --git a/physics/cu_unified_driver.meta b/physics/cu_c3_driver.meta similarity index 93% rename from physics/cu_unified_driver.meta rename to physics/cu_c3_driver.meta index 3a2e28c66..1e52d03fe 100644 --- a/physics/cu_unified_driver.meta +++ b/physics/cu_c3_driver.meta @@ -1,11 +1,11 @@ [ccpp-table-properties] - name = cu_unified_driver + name = cu_c3_driver type = scheme - dependencies = cu_unified_deep.F90,cu_unified_sh.F90,machine.F,physcons.F90,progsigma_calc.f90 + dependencies = cu_c3_deep.F90,cu_c3_sh.F90,machine.F,physcons.F90,progsigma_calc.f90 ######################################################################## [ccpp-arg-table] - name = cu_unified_driver_init + name = cu_c3_driver_init type = scheme [imfshalcnv] standard_name = control_for_shallow_convection_scheme @@ -14,9 +14,9 @@ dimensions = () type = integer intent = in -[imfshalcnv_unified] - standard_name = identifier_for_unified_shallow_convection - long_name = flag for Unified shallow convection scheme +[imfshalcnv_c3] + standard_name = identifier_for_c3_shallow_convection + long_name = flag for C3 shallow convection scheme units = flag dimensions = () type = integer @@ -28,9 +28,9 @@ dimensions = () type = integer intent = in -[imfdeepcnv_unified] - standard_name = identifier_for_unified_deep_convection - long_name = flag for Unified deep convection scheme +[imfdeepcnv_c3] + standard_name = identifier_for_c3_deep_convection + long_name = flag for C3 deep convection scheme units = flag dimensions = () type = integer @@ -67,7 +67,7 @@ ######################################################################## [ccpp-arg-table] - name = cu_unified_driver_run + name = cu_c3_driver_run type = scheme [ntracer] standard_name = number_of_tracers @@ -639,6 +639,35 @@ type = real kind = kind_phys intent = out +[maxupmf] + standard_name = maximum_convective_updraft_mass_flux + long_name = maximum convective updraft mass flux within a column + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[ichoice_in] + standard_name = identifier_for_c3_or_gf_deep_convection_closure + long_name = flag for C3 or GF deep convection closure + units = flag + dimensions = () + type = integer + intent = in +[ichoicem_in] + standard_name = identifier_for_c3_or_gf_mid_convection_closure + long_name = flag for C3 or GF mid convection closure + units = flag + dimensions = () + type = integer + intent = in +[ichoice_s_in] + standard_name = identifier_for_c3_or_gf_shallow_convection_closure + long_name = flag for C3 or GF shallow convection closure + units = flag + dimensions = () + type = integer + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/cu_c3_driver_post.F90 b/physics/cu_c3_driver_post.F90 new file mode 100644 index 000000000..74957a6b2 --- /dev/null +++ b/physics/cu_c3_driver_post.F90 @@ -0,0 +1,88 @@ +!> \file cu_c3_driver_post.F90 +!! Contains code related to C3 convective schemes to be used within the GFS physics suite. + +module cu_c3_driver_post + + implicit none + + private + + public :: cu_c3_driver_post_run + + contains + +!>\ingroup cu_c3_group +!> \section arg_table_cu_c3_driver_post_run Argument Table +!! \htmlinclude cu_c3_driver_post_run.html +!! + subroutine cu_c3_driver_post_run (im, km, t, q, prevst, prevsq, cactiv, cactiv_m, conv_act, conv_act_m, dt, garea, raincv, maxupmf, refl_10cm, errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + ! Interface variables + integer, intent(in) :: im, km + real(kind_phys), intent(in) :: t(:,:) + real(kind_phys), intent(in) :: q(:,:) + real(kind_phys), dimension(:),intent(in) :: garea + real(kind_phys), intent(out) :: prevst(:,:) + real(kind_phys), intent(out) :: prevsq(:,:) + integer, intent(in) :: cactiv(:) + integer, intent(in) :: cactiv_m(:) + real(kind_phys), intent(out) :: conv_act(:) + real(kind_phys), intent(out) :: conv_act_m(:) + ! for Radar reflectivity + real(kind_phys), intent(in) :: dt + real(kind_phys), intent(in) :: raincv(:), maxupmf(:) + real(kind_phys), intent(inout) :: refl_10cm(:,:) + character(len=*), intent(out) :: errmsg +!$acc declare copyin(t,q,cactiv,cactiv_m) copyout(prevst,prevsq,conv_act,conv_act_m) + integer, intent(out) :: errflg + + ! Local variables + real(kind_phys), parameter :: dbzmin=-10.0 + real(kind_phys) :: cuprate + real(kind_phys) :: ze, ze_conv, dbz_sum + integer :: i, k + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + +!$acc kernels + prevst(:,:) = t(:,:) + prevsq(:,:) = q(:,:) + + do i = 1, im + if (cactiv(i).gt.0) then + conv_act(i) = conv_act(i)+1.0 + else + conv_act(i)=0.0 + endif + if (cactiv_m(i).gt.0) then + conv_act_m(i) = conv_act_m(i)+1.0 + else + conv_act_m(i)=0.0 + endif + ! reflectivity parameterization for parameterized convection (reference:Unipost MDLFLD.f) + if(sqrt(garea(i)).lt.6500.)then + ze = 0.0 + ze_conv = 0.0 + dbz_sum = 0.0 + cuprate = raincv(i) * 3600.0 / dt ! cu precip rate (mm/h) + ze_conv = 300.0 * cuprate**1.4 + if (maxupmf(i).gt.0.05) then + do k = 1, km + ze = 10._kind_phys ** (0.1 * refl_10cm(i,k)) + dbz_sum = max(dbzmin, 10.0 * log10(ze + ze_conv)) + refl_10cm(i,k) = dbz_sum + enddo + endif + endif + enddo +!$acc end kernels + + end subroutine cu_c3_driver_post_run + +end module cu_c3_driver_post diff --git a/physics/cu_unified_driver_post.meta b/physics/cu_c3_driver_post.meta similarity index 66% rename from physics/cu_unified_driver_post.meta rename to physics/cu_c3_driver_post.meta index 5266b86e2..c53972f09 100644 --- a/physics/cu_unified_driver_post.meta +++ b/physics/cu_c3_driver_post.meta @@ -1,11 +1,11 @@ [ccpp-table-properties] - name = cu_unified_driver_post + name = cu_c3_driver_post type = scheme dependencies = machine.F ######################################################################## [ccpp-arg-table] - name = cu_unified_driver_post_run + name = cu_c3_driver_post_run type = scheme [im] standard_name = horizontal_loop_extent @@ -14,6 +14,13 @@ dimensions = () type = integer intent = in +[km] + standard_name = vertical_layer_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in [t] standard_name = air_temperature_of_new_state long_name = temperature updated by physics @@ -76,6 +83,46 @@ type = real kind = kind_phys intent = out +[dt] + standard_name = timestep_for_physics + long_name = physics time step + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[garea] + standard_name = cell_area + long_name = grid cell area + units = m2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[raincv] + standard_name = lwe_thickness_of_deep_convective_precipitation_amount + long_name = deep convective rainfall amount on physics timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[maxupmf] + standard_name = maximum_convective_updraft_mass_flux + long_name = maximum convective updraft mass flux within a column + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[refl_10cm] + standard_name = radar_reflectivity_10cm + long_name = instantaneous refl_10cm + units = dBZ + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/cu_unified_driver_pre.F90 b/physics/cu_c3_driver_pre.F90 similarity index 80% rename from physics/cu_unified_driver_pre.F90 rename to physics/cu_c3_driver_pre.F90 index 69d6d9be4..c6e79059b 100644 --- a/physics/cu_unified_driver_pre.F90 +++ b/physics/cu_c3_driver_pre.F90 @@ -1,21 +1,21 @@ -!> \file cu_unified_driver_pre.F90 -!! Contains code related to the unified convective schemes to be used within the GFS physics suite. +!> \file cu_c3_driver_pre.F90 +!! Contains code related to the C3 convective schemes to be used within the GFS physics suite. -module cu_unified_driver_pre +module cu_c3_driver_pre implicit none private - public :: cu_unified_driver_pre_run + public :: cu_c3_driver_pre_run contains -!>\ingroup cu_unified_group -!> \section arg_table_cu_unified_driver_pre_run Argument Table -!! \htmlinclude cu_unified_driver_pre_run.html +!>\ingroup cu_c3_group +!> \section arg_table_cu_c3_driver_pre_run Argument Table +!! \htmlinclude cu_c3_driver_pre_run.html !! - subroutine cu_unified_driver_pre_run (flag_init, flag_restart, kdt, fhour, dtp, t, q, prevst, prevsq, & + subroutine cu_c3_driver_pre_run (flag_init, flag_restart, kdt, fhour, dtp, t, q, prevst, prevsq, & forcet, forceq, cactiv, cactiv_m, conv_act, conv_act_m, & errmsg, errflg) @@ -79,6 +79,6 @@ subroutine cu_unified_driver_pre_run (flag_init, flag_restart, kdt, fhour, dtp, cactiv_m(:)=nint(conv_act_m(:)) !$acc end kernels - end subroutine cu_unified_driver_pre_run + end subroutine cu_c3_driver_pre_run -end module cu_unified_driver_pre +end module cu_c3_driver_pre diff --git a/physics/cu_unified_driver_pre.meta b/physics/cu_c3_driver_pre.meta similarity index 98% rename from physics/cu_unified_driver_pre.meta rename to physics/cu_c3_driver_pre.meta index aa8b870db..c018bee9f 100644 --- a/physics/cu_unified_driver_pre.meta +++ b/physics/cu_c3_driver_pre.meta @@ -1,11 +1,11 @@ [ccpp-table-properties] - name = cu_unified_driver_pre + name = cu_c3_driver_pre type = scheme dependencies = machine.F ######################################################################## [ccpp-arg-table] - name = cu_unified_driver_pre_run + name = cu_c3_driver_pre_run type = scheme [flag_init] standard_name = flag_for_first_timestep diff --git a/physics/cu_unified_sh.F90 b/physics/cu_c3_sh.F90 similarity index 98% rename from physics/cu_unified_sh.F90 rename to physics/cu_c3_sh.F90 index 84e5cc6da..0ea0f28ae 100644 --- a/physics/cu_unified_sh.F90 +++ b/physics/cu_c3_sh.F90 @@ -1,7 +1,7 @@ -!>\file cu_unified_sh.F90 -!! This file contains unified shallow convection scheme. +!>\file cu_c3_sh.F90 +!! This file contains C3 shallow convection scheme. -module cu_unified_sh +module cu_c3_sh use machine , only : kind_phys use progsigma, only : progsigma_calc @@ -16,9 +16,9 @@ module cu_unified_sh contains -!>\defgroup cu_unified_sh_group Grell-Freitas Shallow Convection Module +!>\defgroup cu_c3_sh_group Grell-Freitas Shallow Convection Module !! This module contains Grell-Freitas shallow convection scheme. -!> \ingroup cu_unified_group +!> \ingroup cu_c3_group !> @{ !> GF shallow convection as described in Grell and !! Freitas (2014) \cite grell_and_freitas_2014. input variables are: @@ -62,8 +62,8 @@ module cu_unified_sh !!\param itf,ktf,its,ite, kts,kte are dimensions !!\param ipr horizontal index of printed column !!\param tropics =0 -!>\section gen_cu_unified_sh_run Grell-Freitas Shallow Convection General Algorithm - subroutine cu_unified_sh_run ( & +!>\section gen_cu_c3_sh_run Grell-Freitas Shallow Convection General Algorithm + subroutine cu_c3_sh_run ( & us,vs,zo,t,q,z1,tn,qo,po,psur,dhdt,kpbl,rho, & ! input variables, must be supplied hfx,qfx,xland,ichoice,tcrit,dtime, & zuo,xmb_out,kbcon,ktop,k22,ierr,ierrc, & @@ -74,7 +74,7 @@ subroutine cu_unified_sh_run ( & ! ! this module needs some subroutines from gf_deep ! - use cu_unified_deep,only:cup_env,cup_env_clev,get_cloud_bc,cup_minimi, & + use cu_c3_deep,only:cup_env,cup_env_clev,get_cloud_bc,cup_minimi, & get_inversion_layers,rates_up_pdf,get_cloud_bc, & cup_up_aa0,cup_kbcon,get_lateral_massflux, & calculate_updraft_velocity @@ -1116,6 +1116,6 @@ subroutine cu_unified_sh_run ( & ! print*,'hlisq',qco(1,k),qrco(1,k),pwo(1,k) ! enddo - end subroutine cu_unified_sh_run + end subroutine cu_c3_sh_run !> @} -end module cu_unified_sh +end module cu_c3_sh diff --git a/physics/cu_gf_deep.F90 b/physics/cu_gf_deep.F90 index 2335a2308..6989f07ca 100644 --- a/physics/cu_gf_deep.F90 +++ b/physics/cu_gf_deep.F90 @@ -49,11 +49,11 @@ module cu_gf_deep !>\ingroup cu_gf_group !! This is Grell-Freitas deep convection scheme module !> @{ - integer function my_maxloc1d(A,N) + integer function my_maxloc1d(A,N,dir) !$acc routine vector implicit none real(kind_phys), intent(in) :: A(:) - integer, intent(in) :: N + integer, intent(in) :: N,dir real(kind_phys) :: imaxval integer :: i @@ -554,7 +554,6 @@ subroutine cu_gf_deep_run( & if(xland1(i) == 0)entr_rate(i)=7.e-5 if(dx(i) frh_thresh)then @@ -563,8 +562,9 @@ subroutine cu_gf_deep_run( & entr_rate(i)=.2/radius endif sig(i)=(1.-frh)**2 - frh_out(i) = frh - if((dx(i) Calculates strength of downdraft based on windshear and/or !! aerosol content. - subroutine cup_dd_edt(ierr,us,vs,z,ktop,kbcon,edt,p,pwav, & - pw,ccn,ccnclean,pwev,edtmax,edtmin,edtc,psum2,psumh, & - rho,aeroevap,pefc,itf,ktf, & + subroutine cup_dd_edt(ierr,us,vs,z,ktop,kbcon,edt,p,pwav, & + pw,ccn,ccnclean,pwev,edtmax,edtmin,edtc,psum2,psumh, & + rho,aeroevap,pefc,xland1,itf,ktf, & its,ite, kts,kte ) implicit none @@ -2455,7 +2456,7 @@ subroutine cup_dd_edt(ierr,us,vs,z,ktop,kbcon,edt,p,pwav, & pwav,pwev,psum2,psumh,edtmax,edtmin integer, dimension (its:ite) & ,intent (in ) :: & - ktop,kbcon + ktop,kbcon,xland1 real(kind=kind_phys), intent (in ) :: & !HCB ccnclean real(kind=kind_phys), dimension (its:ite) & @@ -2536,30 +2537,30 @@ subroutine cup_dd_edt(ierr,us,vs,z,ktop,kbcon,edt,p,pwav, & edt(i)=1.-.5*(pefb+pef) if(aeroevap.gt.1)then + pefb=.5 + if(xland1(i) == 1)pefb=.3 aeroadd=0. if((psumh(i)>0.).and.(psum2(i)>0.))then - aeroadd=((1.e-2*ccnclean)**beta3)*(psumh(i)**(alpha3-1)) - prop_c=.5*(pefb+pef)/aeroadd - aeroadd=((1.e-2*ccn(i))**beta3)*(psum2(i)**(alpha3-1)) + aeroadd=((ccnclean)**beta3)*(psumh(i)**(alpha3-1)) + prop_c=pefb/aeroadd + aeroadd=((ccn(i))**beta3)*(psum2(i)**(alpha3-1)) aeroadd=prop_c*aeroadd pefc(i)=aeroadd if(pefc(i).gt.0.9)pefc(i)=0.9 if(pefc(i).lt.0.1)pefc(i)=0.1 edt(i)=1.-pefc(i) - if(aeroevap.eq.2)edt(i)=1.-.25*(pefb+pef+2.*pefc(i)) endif endif !--- edt here is 1-precipeff! - einc=.2*edt(i) - edtc(i,1)=edt(i)-einc + edtc(i,1)=edt(i) endif enddo do i=its,itf if(ierr(i).eq.0)then - edtc(i,1)=-edtc(i,1)*pwav(i)/pwev(i) + edtc(i,1)=-edtc(i,1)*psum2(i)/pwev(i) if(edtc(i,1).gt.edtmax(i))edtc(i,1)=edtmax(i) if(edtc(i,1).lt.edtmin(i))edtc(i,1)=edtmin(i) endif @@ -2571,7 +2572,7 @@ end subroutine cup_dd_edt !> Calcultes moisture properties of downdrafts. subroutine cup_dd_moisture(ierrc,zd,hcd,hes_cup,qcd,qes_cup, & pwd,q_cup,z_cup,dd_massentr,dd_massdetr,jmin,ierr, & - gamma_cup,pwev,bu,qrcd, & + gamma_cup,pwev,bu,qrcd,p_cup, & q,he,iloop, & itf,ktf, & its,ite, kts,kte ) @@ -2601,7 +2602,7 @@ subroutine cup_dd_moisture(ierrc,zd,hcd,hes_cup,qcd,qes_cup, & real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (in ) :: & zd,hes_cup,hcd,qes_cup,q_cup,z_cup, & - dd_massentr,dd_massdetr,gamma_cup,q,he + dd_massentr,dd_massdetr,gamma_cup,q,he,p_cup !$acc declare copyin(zd,hes_cup,hcd,qes_cup,q_cup,z_cup,dd_massentr,dd_massdetr,gamma_cup,q,he) integer & ,intent (in ) :: & @@ -2629,7 +2630,7 @@ subroutine cup_dd_moisture(ierrc,zd,hcd,hes_cup,qcd,qes_cup, & integer :: & i,k,ki real(kind=kind_phys) :: & - denom,dh,dz,dqeva + denom,dp,dh,dz,dqeva !$acc kernels do i=its,itf @@ -2650,6 +2651,7 @@ subroutine cup_dd_moisture(ierrc,zd,hcd,hes_cup,qcd,qes_cup, & if(ierr(i).eq.0)then k=jmin(i) dz=z_cup(i,k+1)-z_cup(i,k) + dp=-100.*(p_cup(i,k+1)-p_cup(i,k)) qcd(i,k)=q_cup(i,k) dh=hcd(i,k)-hes_cup(i,k) if(dh.lt.0)then @@ -2660,12 +2662,13 @@ subroutine cup_dd_moisture(ierrc,zd,hcd,hes_cup,qcd,qes_cup, & endif pwd(i,jmin(i))=zd(i,jmin(i))*min(0.,qcd(i,k)-qrcd(i,k)) qcd(i,k)=qrcd(i,k) - pwev(i)=pwev(i)+pwd(i,jmin(i)) ! *dz + pwev(i)=pwev(i)+pwd(i,jmin(i))*g/dp ! *dz ! bu(i)=dz*dh !$acc loop seq do ki=jmin(i)-1,1,-1 dz=z_cup(i,ki+1)-z_cup(i,ki) + dp=-100.*(p_cup(i,ki+1)-p_cup(i,ki)) ! qcd(i,ki)=(qcd(i,ki+1)*(1.-.5*cdd(i,ki+1)*dz) & ! +entr*dz*q(i,ki) & ! )/(1.+entr*dz-.5*cdd(i,ki+1)*dz) @@ -2698,10 +2701,7 @@ subroutine cup_dd_moisture(ierrc,zd,hcd,hes_cup,qcd,qes_cup, & endif pwd(i,ki)=zd(i,ki)*dqeva qcd(i,ki)=qrcd(i,ki) - pwev(i)=pwev(i)+pwd(i,ki) ! *dz -! if(iloop.eq.1.and.i.eq.102.and.j.eq.62)then -! print *,'in cup_dd_moi ', hcd(i,ki),hes_cup(i,ki),dh,dqeva -! endif + pwev(i)=pwev(i)+pwd(i,ki)*g/dp enddo ! !--- end loop over i @@ -3990,11 +3990,11 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & ! --- now use proper count of how many closures were actually ! used in cup_forcing_ens (including screening of some ! closures over water) to properly normalize xmb - if (dx(i).ge.dx_thresh)then + !if (dx(i).ge.dx_thresh)then clos_wei=16./max(1.,closure_n(i)) - else - clos_wei=1. - endif + !else + ! clos_wei=1. + !endif xmb_ave(i)=min(xmb_ave(i),100.) xmb(i)=clos_wei*sig(i)*xmb_ave(i) @@ -4199,13 +4199,15 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & iprop,iall,i,k integer :: start_level(its:ite),kklev(its:ite) !$acc declare create(start_level,kklev) - real(kind=kind_phys) :: & - prop_ave,qrcb_h,bdsp,dp,rhoc,qrch,qaver,clwdet, & + real(kind=kind_phys) :: & + prop_ave,qrcb_h,dp,rhoc,qrch,qaver,clwdet, & dz,berryc0,q1,berryc - real(kind=kind_phys) :: & + real(kind=kind_phys) :: & denom, c0t, c0_iceconv - real(kind=kind_phys), dimension (kts:kte) :: & + real(kind=kind_phys), dimension (kts:kte) :: & prop_b + real(kind=kind_phys), dimension (its:ite) :: & + bdsp !$acc declare create(prop_b) ! real(kind=kind_phys), parameter:: zero = 0 @@ -4221,7 +4223,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & clwdet=0.1 !0.02 c0_iceconv=0.01 c1d_b=c1d - bdsp=bdispm + bdsp(:)=bdispm ! !--- no precip for small clouds @@ -4235,6 +4237,11 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & pwavh(i)=0. psum(i)=0. psumh(i)=0. + if (xland1(i) .eq. 0) then + bdsp(i)=bdispm + else + bdsp(i)=bdispc + endif enddo do k=kts,ktf do i=its,itf @@ -4301,6 +4308,10 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & qc(i,k)=qrch+qrc(i,k) clw_all(i,k)=qrc(i,k) endif + clw_allh(i,k)=clw_all(i,k) + qrcb(i,k)=qrc(i,k) + pwh(i,k)=pw(i,k) + qch(i,k)=qc(i,k) enddo ! endif ! @@ -4316,6 +4327,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & endif if(is_mid)c0t=0.004 + if(autoconv .gt.1) c0t=c0(i) denom=zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1) if(denom.lt.1.e-16)then ierr(i)=51 @@ -4325,7 +4337,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & rhoc=.5*(rho(i,k)+rho(i,k-1)) dz=z_cup(i,k)-z_cup(i,k-1) - dp=p_cup(i,k)-p_cup(i,k-1) + dp=-100.*(p_cup(i,k)-p_cup(i,k-1)) ! !--- saturation in cloud, this is what is allowed to be in it ! @@ -4358,10 +4370,10 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & qrcb(i,k)=max(0.,(qch(i,k)-qrch)) ! /(1.+c0(i)*dz*zu(i,k)) if(is_deep)then clwdet=0.1 !0.02 ! 05/11/2021 - if(k.lt.kklev(i)) clwdet=0. ! 05/05/2021 + !if(k.lt.kklev(i)) clwdet=0. ! 05/05/2021 else clwdet=0.1 !0.02 ! 05/05/2021 - if(k.lt.kklev(i)) clwdet=0. ! 05/25/2021 + !if(k.lt.kklev(i)) clwdet=0. ! 05/25/2021 endif if(k.gt.kbcon(i)+1)c1d(i,k)=clwdet*up_massdetr(i,k-1) if(k.gt.kbcon(i)+1)c1d_b(i,k)=clwdet*up_massdetr(i,k-1) @@ -4374,50 +4386,52 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & ! this will also determine proportionality constant prop_b, which, if applied, ! would give the same results as c0 under these conditions ! - q1=1.e3*rhoc*clw_allh(i,k) ! g/m^3 ! g[h2o]/cm^3 - berryc0=q1*q1/(60.0*(5.0 + 0.0366*ccnclean/ & - ( q1 * bdsp) ) ) !/( +! Berry conversion for clean atmosphere +! + q1=1.e3*rhoc*clw_allh(i,k) +! pwh units are kg/kg, but normalized by mass flux. So with massflux kg/m^2/s + pwh(i,k)=c0t*dz*zu(i,k)*clw_allh(i,k) qrcb_h=(qch(i,k)-qrch)/(1.+(c1d_b(i,k)+c0t)*dz) - prop_b(k)=(c0t*qrcb_h)/max(1.e-8,(1.e-3*berryc0)) - if(prop_b(k)>5.) prop_b(k)=5. - pwh(i,k)=zu(i,k)*1.e-3*berryc0*dz*prop_b(k) ! 2. - qrcb(i,k)=(max(0.,(qch(i,k)-qrch))*zu(i,k)-pwh(i,k))/(zu(i,k)*(1+c1d_b(i,k)*dz)) - if(qrcb(i,k).lt.0.)then - berryc0=max(0.,(qch(i,k)-qrch))/(1.e-3*dz*prop_b(k)) - pwh(i,k)=zu(i,k)*1.e-3*berryc0*dz*prop_b(k) qrcb(i,k)=0. +! unit (B) = g/m^3/s + berryc0=(q1*q1/(60.0*(5.0 + 0.0366*ccnclean*1.e1/ & + ( q1 * bdsp(i)) ) )) +! normalize Berry: berryc0=berryc0*g/dp*dz*zu = pwh, unts become kg/kg +! set 1: + berryc0=1.e-3*berryc0*g/dp*dz + prop_b(k)=pwh(i,k)/berryc0 + qrcb(i,k)=qrcb_h + if(qrcb(i,k).le.0.)then + pwh(i,k)=0. endif qch(i,k)=qrcb(i,k)+qrch pwavh(i)=pwavh(i)+pwh(i,k) - psumh(i)=psumh(i)+pwh(i,k) ! HCB - !psumh(i)=psumh(i)+clw_allh(i,k)*zu(i,k) *dz - ! + psumh(i)=psumh(i)+pwh(i,k)*g/dp !dz !dp/g !*dp ! HCB ! then the real berry ! - q1=1.e3*rhoc*clw_all(i,k) ! g/m^3 ! g[h2o]/cm^3 - berryc0=q1*q1/(60.0*(5.0 + 0.0366*ccn(i)/ & - ( q1 * bdsp) ) ) !/( - berryc0=1.e-3*berryc0*dz*prop_b(k) ! 2. - qrc(i,k)=(max(0.,(qc(i,k)-qrch))*zu(i,k)-zu(i,k)*berryc0)/(zu(i,k)*(1+c1d(i,k)*dz)) + q1=1.e3*rhoc*clw_all(i,k) + berryc=(q1*q1/(60.0*(5.0 + 0.0366*ccn(i)*1.e1/ & + ( q1 * bdsp(i)) ) )) + berryc=1.e-3*berryc*g/dp*dz + pw(i,k)=prop_b(k)*berryc !*dz/zu(i,k) +! use berryc now as new c0 for this level + berryc=pw(i,k)/(dz*zu(i,k)*clw_all(i,k)) + if(qrc(i,k).le.0.)then + berryc=0. + endif + qrc(i,k)=(max(0.,(qc(i,k)-qrch))/(1+(c1d(i,k)+berryc)*dz)) if(qrc(i,k).lt.0.)then - berryc0=max(0.,(qc(i,k)-qrch))/(1.e-3*dz*prop_b(k)) qrc(i,k)=0. + pw(i,k)=0. endif - pw(i,k)=berryc0*zu(i,k) qc(i,k)=qrc(i,k)+qrch ! if not running with berry at all, do the following ! - else !c0=.002 - if(iall.eq.1)then - qrc(i,k)=0. - pw(i,k)=(qc(i,k)-qrch)*zu(i,k) - if(pw(i,k).lt.0.)pw(i,k)=0. - else + else ! create clw detrainment profile that depends on mass detrainment and ! in-cloud clw/ice ! - !c1d(i,k)=clwdet*up_massdetr(i,k-1)*qrc(i,k-1) qrc(i,k)=(qc(i,k)-qrch)/(1.+(c1d(i,k)+c0t)*dz) if(qrc(i,k).lt.0.)then ! hli new test 02/12/19 qrc(i,k)=0. @@ -4431,11 +4445,10 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & qrc(i,k)=0. pw(i,k)=0. endif - endif - qc(i,k)=qrc(i,k)+qrch - endif !autoconv + qc(i,k)=qrc(i,k)+qrch + endif !autoconv pwav(i)=pwav(i)+pw(i,k) - psum(i)=psum(i)+pw(i,k) ! HCB + psum(i)=psum(i)+pw(i,k)*g/dp ! HCB enddo ! k=kbcon,ktop ! do not include liquid/ice in qc !$acc loop independent @@ -4611,9 +4624,6 @@ subroutine rates_up_pdf(rand_vmas,ipr,name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo ierr(i)=41 ktop(i)= 0 else -! call get_zu_zd_pdf_fim(ipr,xland(i),zuh2,"up",ierr(i),start_level(i), & -! call get_zu_zd_pdf_fim(rand_vmas(i),zubeg,ipr,xland(i),zuh2,"up",ierr(i),kbcon(i), & -! kfinalzu,zuo(i,kts:kte),kts,kte,ktf,beta_u,kpbl(i),csum(i),pmin_lev(i)) call get_zu_zd_pdf_fim(kklev,p_cup(i,:),rand_vmas(i),zubeg,ipr,xland(i),zuh2,1,ierr(i),k22(i), & kfinalzu+1,zuo(i,kts:kte),kts,kte,ktf,beta_u,kbcon(i),csum(i),pmin_lev(i)) endif @@ -4742,7 +4752,7 @@ subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,k if(zu(kpbli).gt.0.) & zu(kts:min(ktf,kt-1))= zu(kts:min(ktf,kt-1))/zu(kpbli) - do k=my_maxloc1d(zu(:),kte),1,-1 + do k=my_maxloc1d(zu(:),kte,1),1,-1 if(zu(k).lt.1.e-6)then kb_adj=k+1 exit @@ -4801,7 +4811,7 @@ subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,k ! zu(kts:min(ktf,kt+1))= zu(kts:min(ktf,kt+1))/maxval(zu(kts:min(ktf,kt+1))) if(zu(kpbli).gt.0.) & zu(kts:min(ktf,kt-1))= zu(kts:min(ktf,kt-1))/zu(kpbli) - do k=my_maxloc1d(zu(:),kte),1,-1 + do k=my_maxloc1d(zu(:),kte,1),1,-1 if(zu(k).lt.1.e-6)then kb_adj=k+1 exit @@ -4850,7 +4860,7 @@ subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,k if(zu(kpbli).gt.0.) & zu(kts:min(ktf,kt-1))= zu(kts:min(ktf,kt-1))/zu(kpbli) - do k=my_maxloc1d(zu(:),kte),1,-1 + do k=my_maxloc1d(zu(:),kte,1),1,-1 if(zu(k).lt.1.e-6)then kb_adj=k+1 exit diff --git a/physics/cu_gf_driver.F90 b/physics/cu_gf_driver.F90 index ca9f0bec2..9d80e489f 100644 --- a/physics/cu_gf_driver.F90 +++ b/physics/cu_gf_driver.F90 @@ -66,7 +66,8 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& index_of_y_wind,index_of_process_scnv,index_of_process_dcnv, & fhour,fh_dfi_radar,ix_dfi_radar,num_dfi_radar,cap_suppress, & dfi_radar_max_intervals,ldiag3d,qci_conv,do_cap_suppress, & - maxupmf,maxMF,errmsg,errflg) + maxupmf,maxMF,do_mynnedmf,ichoice_in,ichoicem_in,ichoice_s_in, & + errmsg,errflg) !------------------------------------------------------------- implicit none integer, parameter :: maxiens=1 @@ -76,10 +77,9 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& integer, parameter :: ensdim=16 integer :: imid_gf=1 ! gf congest conv. integer, parameter :: ideep=1 - integer :: ichoice=0 ! 0 2 5 13 8 - !integer, parameter :: ichoicem=5 ! 0 2 5 13 - integer, parameter :: ichoicem=13 ! 0 2 5 13 - integer, parameter :: ichoice_s=3 ! 0 1 2 3 + integer :: ichoice=0 ! 0 2 5 13 8 + integer :: ichoicem=13 ! 0 2 5 13 + integer :: ichoice_s=3 ! 0 1 2 3 logical, intent(in) :: do_cap_suppress real(kind=kind_phys), parameter :: aodc0=0.14 @@ -91,7 +91,8 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& !------------------------------------------------------------- integer :: its,ite, jts,jte, kts,kte integer, intent(in ) :: im,km,ntracer - logical, intent(in ) :: flag_init, flag_restart + integer, intent(in ) :: ichoice_in,ichoicem_in,ichoice_s_in + logical, intent(in ) :: flag_init, flag_restart, do_mynnedmf logical, intent(in ) :: flag_for_scnv_generic_tend,flag_for_dcnv_generic_tend real (kind=kind_phys), intent(in) :: g,cp,xlv,r_v logical, intent(in ) :: ldiag3d @@ -246,6 +247,9 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& errmsg = '' errflg = 0 + ichoice = ichoice_in + ichoicem = ichoicem_in + ichoice_s = ichoice_s_in if(do_cap_suppress) then !$acc serial do itime=1,num_dfi_radar @@ -625,7 +629,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& enddo do i = its,itf if(mconv(i).lt.0.)mconv(i)=0. - if(maxMF(i).gt.0.)ierr(i)=555 + if(do_mynnedmf.and.(maxMF(i).gt.0.))ierr(i)=555 enddo !$acc end kernels if (dx(its)<6500.) then @@ -660,7 +664,13 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& !$acc kernels do i=its,itf - if(xmbs(i).gt.0.)cutens(i)=1. + if(xmbs(i).gt.0.)then + cutens(i)=1. + if (dx(i)<6500.) then + ierrm(i)=555 + ierr (i)=555 + endif + endif enddo !$acc end kernels !> - Call neg_check() for GF shallow convection @@ -897,8 +907,8 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& gdc(i,k,1)= max(0.,tun_rad_shall(i)*cupclws(i,k)*cutens(i)) ! my mod !gdc2(i,k,1)=max(0.,tun_rad_deep(i)*(cupclwm(i,k)*cutenm(i)+cupclw(i,k)*cuten(i))) - !gdc2(i,k,1)=max(0.,tun_rad_mid(i)*cupclwm(i,k)*cutenm(i)+tun_rad_deep(i)*cupclw(i,k)*cuten(i)+tun_rad_shall(i)*cupclws(i,k)*cutens(i)) - gdc2(i,k,1) = min(0.1, max(0.01, tun_rad_mid(i)*frhm(i)))*cupclwm(i,k)*cutenm(i) + min(0.1, max(0.01, tun_rad_deep(i)*(frhd(i))))*cupclw(i,k)*cuten(i) + tun_rad_shall(i)*cupclws(i,k)*cutens(i) + gdc2(i,k,1)=max(0.,tun_rad_mid(i)*cupclwm(i,k)*cutenm(i)+frhd(i)*cupclw(i,k)*cuten(i)+tun_rad_shall(i)*cupclws(i,k)*cutens(i)) + !gdc2(i,k,1) = min(0.1, max(0.01, tun_rad_mid(i)*frhm(i)))*cupclwm(i,k)*cutenm(i) + min(0.1, max(0.01, tun_rad_deep(i)*(frhd(i))))*cupclw(i,k)*cuten(i) + tun_rad_shall(i)*cupclws(i,k)*cutens(i) qci_conv(i,k)=gdc2(i,k,1) gdc(i,k,2)=(outt(i,k))*86400. gdc(i,k,3)=(outtm(i,k))*86400. diff --git a/physics/cu_gf_driver.meta b/physics/cu_gf_driver.meta index 60c7e7fe5..8b1a46e2d 100644 --- a/physics/cu_gf_driver.meta +++ b/physics/cu_gf_driver.meta @@ -569,6 +569,34 @@ type = real kind = kind_phys intent = in +[do_mynnedmf] + standard_name = flag_for_mellor_yamada_nakanishi_niino_pbl_scheme + long_name = flag to activate MYNN-EDMF + units = flag + dimensions = () + type = logical + intent = in +[ichoice_in] + standard_name = identifier_for_c3_or_gf_deep_convection_closure + long_name = flag for C3 or GF deep convection closure + units = flag + dimensions = () + type = integer + intent = in +[ichoicem_in] + standard_name = identifier_for_c3_or_gf_mid_convection_closure + long_name = flag for C3 or GF mid convection closure + units = flag + dimensions = () + type = integer + intent = in +[ichoice_s_in] + standard_name = identifier_for_c3_or_gf_shallow_convection_closure + long_name = flag for C3 or GF shallow convection closure + units = flag + dimensions = () + type = integer + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/cu_unified_driver_post.F90 b/physics/cu_unified_driver_post.F90 deleted file mode 100644 index 821992bff..000000000 --- a/physics/cu_unified_driver_post.F90 +++ /dev/null @@ -1,65 +0,0 @@ -!> \file cu_unified_driver_post.F90 -!! Contains code related to unified convective schemes to be used within the GFS physics suite. - -module cu_unified_driver_post - - implicit none - - private - - public :: cu_unified_driver_post_run - - contains - -!>\ingroup cu_unified_group -!> \section arg_table_cu_unified_driver_post_run Argument Table -!! \htmlinclude cu_unified_driver_post_run.html -!! - subroutine cu_unified_driver_post_run (im, t, q, prevst, prevsq, cactiv, cactiv_m, conv_act, conv_act_m, errmsg, errflg) - - use machine, only: kind_phys - - implicit none - - ! Interface variables - integer, intent(in) :: im - real(kind_phys), intent(in) :: t(:,:) - real(kind_phys), intent(in) :: q(:,:) - real(kind_phys), intent(out) :: prevst(:,:) - real(kind_phys), intent(out) :: prevsq(:,:) - integer, intent(in) :: cactiv(:) - integer, intent(in) :: cactiv_m(:) - real(kind_phys), intent(out) :: conv_act(:) - real(kind_phys), intent(out) :: conv_act_m(:) - character(len=*), intent(out) :: errmsg -!$acc declare copyin(t,q,cactiv,cactiv_m) copyout(prevst,prevsq,conv_act,conv_act_m) - integer, intent(out) :: errflg - - ! Local variables - integer :: i - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - -!$acc kernels - prevst(:,:) = t(:,:) - prevsq(:,:) = q(:,:) - - do i = 1, im - if (cactiv(i).gt.0) then - conv_act(i) = conv_act(i)+1.0 - else - conv_act(i)=0.0 - endif - if (cactiv_m(i).gt.0) then - conv_act_m(i) = conv_act_m(i)+1.0 - else - conv_act_m(i)=0.0 - endif - enddo -!$acc end kernels - - end subroutine cu_unified_driver_post_run - -end module cu_unified_driver_post diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index 079218f5a..111be4019 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -32,7 +32,7 @@ ! imp_physics_mg, iovr, iovr_rand, iovr_maxrand, iovr_max, ! ! iovr_dcorr, iovr_exp, iovr_exprand, idcor, idcor_con, ! ! idcor_hogan, idcor_oreopoulos, ! -! imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_unified, do_mynnedmf, lgfdlmprad, ! +! imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_c3, do_mynnedmf, lgfdlmprad, ! ! uni_cld, lmfshal, lmfdeep2, cldcov, clouds1, ! ! effrl, effri, effrr, effrs, effr_in, ! ! effrl_inout, effri_inout, effrs_inout, ! @@ -347,7 +347,7 @@ subroutine radiation_clouds_prop & & imp_physics_mg, iovr, iovr_rand, iovr_maxrand, iovr_max, & & iovr_dcorr, iovr_exp, iovr_exprand, idcor, idcor_con, & & idcor_hogan, idcor_oreopoulos, lcrick, lcnorm, & - & imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_unified, & + & imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_c3, & & do_mynnedmf, lgfdlmprad, & & uni_cld, lmfshal, lmfdeep2, cldcov, clouds1, & & effrl, effri, effrr, effrs, effr_in, & @@ -450,7 +450,7 @@ subroutine radiation_clouds_prop & ! idcor_oreopoulos: flag for decorrelation-length: (=2) ! ! imfdeepcnv : flag for mass-flux deep convection scheme ! ! imfdeepcnv_gf : flag for scale- & aerosol-aware Grell-Freitas scheme (GSD) -! imfdeepcnv_unified : flag for unified convection scheme +! imfdeepcnv_c3 : flag for unified convection scheme ! do_mynnedmf : flag for MYNN-EDMF ! ! lgfdlmprad : flag for GFDLMP radiation interaction ! ! uni_cld : logical - true for cloud fraction from shoc ! @@ -511,7 +511,7 @@ subroutine radiation_clouds_prop & integer, intent(in) :: ntrac, ntcw, ntiw, ntrw, ntsw, ntgl, & & ntclamt integer, intent(in) :: kdt, imfdeepcnv, imfdeepcnv_gf, & - & imfdeepcnv_unified + & imfdeepcnv_c3 integer, intent(in) :: & & imp_physics, ! Flag for MP scheme & imp_physics_nssl, ! Flag for NSSL scheme @@ -702,7 +702,7 @@ subroutine radiation_clouds_prop & elseif ( imp_physics == imp_physics_nssl ) then ! NSSL MP if(do_mynnedmf .or. imfdeepcnv == imfdeepcnv_gf .or. & - & imfdeepcnv == imfdeepcnv_unified) then ! MYNN PBL or GF or unified conv + & imfdeepcnv == imfdeepcnv_c3) then ! MYNN PBL or GF or unified conv !-- MYNN PBL or convective GF !-- use cloud fractions with SGS clouds do k=1,NLAY @@ -742,7 +742,7 @@ subroutine radiation_clouds_prop & elseif(imp_physics == imp_physics_thompson) then ! Thompson MP if(do_mynnedmf .or. imfdeepcnv == imfdeepcnv_gf & - & .or. imfdeepcnv == imfdeepcnv_unified) then ! MYNN PBL or GF conv + & .or. imfdeepcnv == imfdeepcnv_c3) then ! MYNN PBL or GF conv if (icloud == 3) then call progcld_thompson (plyr,plvl,tlyr,qlyr,qstl,rhly, & ! --- inputs diff --git a/physics/sgscloud_radpre.F90 b/physics/sgscloud_radpre.F90 index 07f74714a..44ab87bcc 100644 --- a/physics/sgscloud_radpre.F90 +++ b/physics/sgscloud_radpre.F90 @@ -45,7 +45,7 @@ subroutine sgscloud_radpre_run( & qr, qs, qg, & qci_conv,qlc,qli,ud_mf, & imfdeepcnv, imfdeepcnv_gf, & - imfdeepcnv_unified, & + imfdeepcnv_c3, & imfdeepcnv_sas, & qc_save, qi_save, qs_save, & qc_bl,qi_bl,cldfra_bl, & @@ -74,7 +74,7 @@ subroutine sgscloud_radpre_run( & real :: xls, xlvcp, xlscp !derived below real(kind=kind_phys) :: gfac integer, intent(in) :: im, levs, imfdeepcnv, imfdeepcnv_gf, & - & nlay, imfdeepcnv_sas, imfdeepcnv_unified, imp_physics, & + & nlay, imfdeepcnv_sas, imfdeepcnv_c3, imp_physics, & & imp_physics_gfdl, imp_physics_fa logical, intent(in) :: flag_init, flag_restart, do_mynnedmf @@ -273,7 +273,7 @@ subroutine sgscloud_radpre_run( & ! At this point, we have cloud properties for all non-deep convective clouds. ! So now we add the convective clouds: - if (imfdeepcnv == imfdeepcnv_gf .or. imfdeepcnv == imfdeepcnv_unified) then + if (imfdeepcnv == imfdeepcnv_gf .or. imfdeepcnv == imfdeepcnv_c3) then do k = 1, levs do i = 1, im if ( qci_conv(i,k) > 0. ) then diff --git a/physics/sgscloud_radpre.meta b/physics/sgscloud_radpre.meta index 6415358de..d5341bcd4 100644 --- a/physics/sgscloud_radpre.meta +++ b/physics/sgscloud_radpre.meta @@ -256,9 +256,9 @@ dimensions = () type = integer intent = in -[imfdeepcnv_unified] - standard_name = identifier_for_unified_deep_convection - long_name = flag for Unified deep convection scheme +[imfdeepcnv_c3] + standard_name = identifier_for_c3_deep_convection + long_name = flag for C3 deep convection scheme units = flag dimensions = () type = integer From 4c60a2f50b163cb52495c3815a41ade7e536de39 Mon Sep 17 00:00:00 2001 From: dustinswales Date: Tue, 23 May 2023 14:00:52 -0600 Subject: [PATCH 269/380] Reorganize NRL ozone physics scheme into CCPP phases. Make scheme (memory) stateless. --- physics/GFS_phys_time_vary.fv3.F90 | 80 ++----- physics/GFS_phys_time_vary.fv3.meta | 76 +----- physics/GFS_phys_time_vary.scm.F90 | 68 ++---- physics/GFS_phys_time_vary.scm.meta | 76 +----- physics/GFS_rrtmg_pre.F90 | 11 +- physics/GFS_rrtmg_pre.meta | 30 +++ physics/GFS_rrtmg_setup.F90 | 7 +- physics/GFS_rrtmg_setup.meta | 21 ++ physics/ozinterp.f90 | 212 ----------------- physics/ozne_def.f | 24 -- physics/ozne_def.meta | 29 --- physics/ozphys_2015.F90 | 343 ++++++++++++++++++++++++++++ physics/ozphys_2015.f | 190 --------------- physics/ozphys_2015.meta | 203 ++++++++++++++-- physics/radiation_gases.f | 13 +- 15 files changed, 635 insertions(+), 748 deletions(-) delete mode 100644 physics/ozinterp.f90 delete mode 100644 physics/ozne_def.f delete mode 100644 physics/ozne_def.meta create mode 100644 physics/ozphys_2015.F90 delete mode 100644 physics/ozphys_2015.f diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index 42f2bbc15..334228afe 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -2,7 +2,7 @@ !! Contains code related to GFS physics suite setup (physics part of time_vary_step) !>\defgroup mod_GFS_phys_time_vary GFS Physics Time Update -!! This module contains GFS physics time vary subroutines including ozone, stratospheric water vapor, +!! This module contains GFS physics time vary subroutines including stratospheric water vapor, !! aerosol, IN&CCN and surface properties updates. module GFS_phys_time_vary @@ -14,9 +14,6 @@ module GFS_phys_time_vary use mersenne_twister, only: random_setseed, random_number - use ozne_def, only : levozp, oz_coeff, oz_lat, oz_pres, oz_time, ozplin - use ozinterp, only : read_o3data, setindxoz, ozinterpol - use h2o_def, only : levh2o, h2o_coeff, h2o_lat, h2o_pres, h2o_time, h2oplin use h2ointerp, only : read_h2odata, setindxh2o, h2ointerpol @@ -66,9 +63,9 @@ module GFS_phys_time_vary !>\section gen_GFS_phys_time_vary_init GFS_phys_time_vary_init General Algorithm !> @{ subroutine GFS_phys_time_vary_init ( & - me, master, ntoz, h2o_phys, iaerclm, iccn, iaermdl, iflip, im, levs, & + me, master, h2o_phys, iaerclm, iccn, iaermdl, iflip, im, levs, & nx, ny, idate, xlat_d, xlon_d, & - jindx1_o3, jindx2_o3, ddy_o3, ozpl, jindx1_h, jindx2_h, ddy_h, h2opl,fhour, & + jindx1_h, jindx2_h, ddy_h, h2opl,fhour, & jindx1_aer, jindx2_aer, ddy_aer, iindx1_aer, iindx2_aer, ddx_aer, aer_nm, & jindx1_ci, jindx2_ci, ddy_ci, iindx1_ci, iindx2_ci, ddx_ci, imap, jmap, & do_ugwp_v1, jindx1_tau, jindx2_tau, ddy_j1tau, ddy_j2tau, & @@ -85,15 +82,15 @@ subroutine GFS_phys_time_vary_init ( implicit none ! Interface variables - integer, intent(in) :: me, master, ntoz, iccn, iflip, im, nx, ny, levs, iaermdl + integer, intent(in) :: me, master, iccn, iflip, im, nx, ny, levs, iaermdl logical, intent(in) :: h2o_phys, iaerclm, lsm_cold_start integer, intent(in) :: idate(:) real(kind_phys), intent(in) :: fhour real(kind_phys), intent(in) :: xlat_d(:), xlon_d(:) - integer, intent(inout) :: jindx1_o3(:), jindx2_o3(:), jindx1_h(:), jindx2_h(:) - real(kind_phys), intent(inout) :: ddy_o3(:), ddy_h(:) - real(kind_phys), intent(in) :: ozpl(:,:,:), h2opl(:,:,:) + integer, intent(inout) :: jindx1_h(:), jindx2_h(:) + real(kind_phys), intent(inout) :: ddy_h(:) + real(kind_phys), intent(in) :: h2opl(:,:,:) integer, intent(inout) :: jindx1_aer(:), jindx2_aer(:), iindx1_aer(:), iindx2_aer(:) real(kind_phys), intent(inout) :: ddy_aer(:), ddx_aer(:) real(kind_phys), intent(out) :: aer_nm(:,:,:) @@ -196,13 +193,12 @@ subroutine GFS_phys_time_vary_init ( jamax=-999 !$OMP parallel num_threads(nthrds) default(none) & -!$OMP shared (me,master,ntoz,h2o_phys,im,nx,ny,levs,idate) & +!$OMP shared (me,master,h2o_phys,im,nx,ny,levs,idate) & !$OMP shared (xlat_d,xlon_d,imap,jmap,errmsg,errflg) & -!$OMP shared (levozp,oz_coeff,oz_pres,ozpl) & !$OMP shared (levh2o,h2o_coeff,h2o_pres,h2opl) & !$OMP shared (iamin, iamax, jamin, jamax) & !$OMP shared (iaerclm,iaermdl,ntrcaer,aer_nm,iflip,iccn) & -!$OMP shared (jindx1_o3,jindx2_o3,ddy_o3,jindx1_h,jindx2_h,ddy_h) & +!$OMP shared (jindx1_h,jindx2_h,ddy_h) & !$OMP shared (jindx1_aer,jindx2_aer,ddy_aer,iindx1_aer,iindx2_aer,ddx_aer) & !$OMP shared (jindx1_ci,jindx2_ci,ddy_ci,iindx1_ci,iindx2_ci,ddx_ci) & !$OMP shared (do_ugwp_v1,jindx1_tau,jindx2_tau,ddy_j1tau,ddy_j2tau) & @@ -212,32 +208,12 @@ subroutine GFS_phys_time_vary_init ( !$OMP sections -!$OMP section -!> - Call read_o3data() to read ozone data - call read_o3data (ntoz, me, master) - - ! Consistency check that the hardcoded values for levozp and - ! oz_coeff in GFS_typedefs.F90 match what is set by read_o3data - ! in GFS_typedefs.F90: allocate (Tbd%ozpl (IM,levozp,oz_coeff)) - if (size(ozpl, dim=2).ne.levozp) then - write(errmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", & - "levozp from read_o3data does not match value in GFS_typedefs.F90: ", & - levozp, " /= ", size(ozpl, dim=2) - errflg = 1 - end if - if (size(ozpl, dim=3).ne.oz_coeff) then - write(errmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", & - "oz_coeff from read_o3data does not match value in GFS_typedefs.F90: ", & - oz_coeff, " /= ", size(ozpl, dim=3) - errflg = 1 - end if - !$OMP section !> - Call read_h2odata() to read stratospheric water vapor data call read_h2odata (h2o_phys, me, master) ! Consistency check that the hardcoded values for levh2o and - ! h2o_coeff in GFS_typedefs.F90 match what is set by read_o3data + ! h2o_coeff in GFS_typedefs.F90 match what is set by read_h2odata ! in GFS_typedefs.F90: allocate (Tbd%h2opl (IM,levh2o,h2o_coeff)) if (size(h2opl, dim=2).ne.levh2o) then write(errmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", & @@ -295,12 +271,6 @@ subroutine GFS_phys_time_vary_init ( !$OMP sections -!$OMP section -!> - Call setindxoz() to initialize ozone data - if (ntoz > 0) then - call setindxoz (im, xlat_d, jindx1_o3, jindx2_o3, ddy_o3) - endif - !$OMP section !> - Call setindxh2o() to initialize stratospheric water vapor data if (h2o_phys) then @@ -708,8 +678,8 @@ end subroutine GFS_phys_time_vary_init !> @{ subroutine GFS_phys_time_vary_timestep_init ( & me, master, cnx, cny, isc, jsc, nrcm, im, levs, kdt, idate, nsswr, fhswr, lsswr, fhour, & - imfdeepcnv, cal_pre, random_clds, nscyc, ntoz, h2o_phys, iaerclm, iccn, clstp, & - jindx1_o3, jindx2_o3, ddy_o3, ozpl, jindx1_h, jindx2_h, ddy_h, h2opl, iflip, & + imfdeepcnv, cal_pre, random_clds, nscyc, h2o_phys, iaerclm, iccn, clstp, & + jindx1_h, jindx2_h, ddy_h, h2opl, iflip, & jindx1_aer, jindx2_aer, ddy_aer, iindx1_aer, iindx2_aer, ddx_aer, aer_nm, & jindx1_ci, jindx2_ci, ddy_ci, iindx1_ci, iindx2_ci, ddx_ci, in_nm, ccn_nm, fn_nml, & imap, jmap, prsl, seed0, rann, nthrds, nx, ny, nsst, tile_num, nlunit, lsoil, lsoil_lsm,& @@ -724,14 +694,14 @@ subroutine GFS_phys_time_vary_timestep_init ( ! Interface variables integer, intent(in) :: me, master, cnx, cny, isc, jsc, nrcm, im, levs, kdt, & - nsswr, imfdeepcnv, iccn, nscyc, ntoz, iflip + nsswr, imfdeepcnv, iccn, nscyc, iflip integer, intent(in) :: idate(:) real(kind_phys), intent(in) :: fhswr, fhour logical, intent(in) :: lsswr, cal_pre, random_clds, h2o_phys, iaerclm real(kind_phys), intent(out) :: clstp - integer, intent(in) :: jindx1_o3(:), jindx2_o3(:), jindx1_h(:), jindx2_h(:) - real(kind_phys), intent(in) :: ddy_o3(:), ddy_h(:) - real(kind_phys), intent(inout) :: ozpl(:,:,:), h2opl(:,:,:) + integer, intent(in) :: jindx1_h(:), jindx2_h(:) + real(kind_phys), intent(in) :: ddy_h(:) + real(kind_phys), intent(inout) :: h2opl(:,:,:) integer, intent(in) :: jindx1_aer(:), jindx2_aer(:), iindx1_aer(:), iindx2_aer(:) real(kind_phys), intent(in) :: ddy_aer(:), ddx_aer(:) real(kind_phys), intent(inout) :: aer_nm(:,:,:) @@ -788,8 +758,8 @@ subroutine GFS_phys_time_vary_timestep_init ( !$OMP parallel num_threads(nthrds) default(none) & !$OMP shared(kdt,nsswr,lsswr,clstp,imfdeepcnv,cal_pre,random_clds) & !$OMP shared(fhswr,fhour,seed0,cnx,cny,nrcm,wrk,rannie,rndval) & -!$OMP shared(rann,im,isc,jsc,imap,jmap,ntoz,me,idate,jindx1_o3,jindx2_o3) & -!$OMP shared(ozpl,ddy_o3,h2o_phys,jindx1_h,jindx2_h,h2opl,ddy_h,iaerclm,master) & +!$OMP shared(rann,im,isc,jsc,imap,jmap,me,idate) & +!$OMP shared(h2o_phys,jindx1_h,jindx2_h,h2opl,ddy_h,iaerclm,master) & !$OMP shared(levs,prsl,iccn,jindx1_ci,jindx2_ci,ddy_ci,iindx1_ci,iindx2_ci) & !$OMP shared(ddx_ci,in_nm,ccn_nm,do_ugwp_v1,jindx1_tau,jindx2_tau,ddy_j1tau) & !$OMP shared(ddy_j2tau,tau_amf,iflip) & @@ -842,14 +812,6 @@ subroutine GFS_phys_time_vary_timestep_init ( endif ! imfdeepcnv, cal_re, random_clds -!$OMP section -!> - Call ozinterpol() to make ozone interpolation - if (ntoz > 0) then - call ozinterpol (me, im, idate, fhour, & - jindx1_o3, jindx2_o3, & - ozpl, ddy_o3) - endif - !$OMP section !> - Call h2ointerpol() to make stratospheric water vapor data interpolation if (h2o_phys) then @@ -944,12 +906,6 @@ subroutine GFS_phys_time_vary_finalize(errmsg, errflg) if (.not.is_initialized) return - ! Deallocate ozone arrays - if (allocated(oz_lat) ) deallocate(oz_lat) - if (allocated(oz_pres) ) deallocate(oz_pres) - if (allocated(oz_time) ) deallocate(oz_time) - if (allocated(ozplin) ) deallocate(ozplin) - ! Deallocate h2o arrays if (allocated(h2o_lat) ) deallocate(h2o_lat) if (allocated(h2o_pres)) deallocate(h2o_pres) diff --git a/physics/GFS_phys_time_vary.fv3.meta b/physics/GFS_phys_time_vary.fv3.meta index ce8c6c54b..654b5afd8 100644 --- a/physics/GFS_phys_time_vary.fv3.meta +++ b/physics/GFS_phys_time_vary.fv3.meta @@ -2,7 +2,7 @@ name = GFS_phys_time_vary type = scheme dependencies = aerclm_def.F,aerinterp.F90,gcycle.F90,h2o_def.f,h2ointerp.f90,iccn_def.F,iccninterp.F90,machine.F,mersenne_twister.f - dependencies = namelist_soilveg.f,set_soilveg.f,ozinterp.f90,ozne_def.f,sfcsub.F,cires_tauamf_data.F90,noahmp_tables.f90 + dependencies = namelist_soilveg.f,set_soilveg.f,sfcsub.F,cires_tauamf_data.F90,noahmp_tables.f90 ######################################################################## [ccpp-arg-table] @@ -23,13 +23,6 @@ dimensions = () type = integer intent = in -[ntoz] - standard_name = index_of_ozone_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for ozone mixing ratio - units = index - dimensions = () - type = integer - intent = in [h2o_phys] standard_name = flag_for_stratospheric_water_vapor_physics long_name = flag for stratospheric water vapor physics @@ -116,36 +109,6 @@ type = real kind = kind_phys intent = in -[jindx1_o3] - standard_name = lower_latitude_index_of_ozone_forcing_for_interpolation - long_name = interpolation low index for ozone - units = index - dimensions = (horizontal_dimension) - type = integer - intent = inout -[jindx2_o3] - standard_name = upper_latitude_index_of_ozone_forcing_for_interpolation - long_name = interpolation high index for ozone - units = index - dimensions = (horizontal_dimension) - type = integer - intent = inout -[ddy_o3] - standard_name = latitude_interpolation_weight_for_ozone_forcing - long_name = interpolation high index for ozone - units = none - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = inout -[ozpl] - standard_name = ozone_forcing - long_name = ozone forcing data - units = mixed - dimensions = (horizontal_dimension,vertical_dimension_of_ozone_forcing_data,number_of_coefficients_in_ozone_forcing_data) - type = real - kind = kind_phys - intent = in [jindx1_h] standard_name = lower_latitude_index_of_stratospheric_water_vapor_forcing_for_interpolation long_name = interpolation low index for stratospheric water vapor @@ -1077,13 +1040,6 @@ dimensions = () type = integer intent = in -[ntoz] - standard_name = index_of_ozone_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for ozone mixing ratio - units = index - dimensions = () - type = integer - intent = in [h2o_phys] standard_name = flag_for_stratospheric_water_vapor_physics long_name = flag for stratospheric water vapor physics @@ -1113,36 +1069,6 @@ type = real kind = kind_phys intent = out -[jindx1_o3] - standard_name = lower_latitude_index_of_ozone_forcing_for_interpolation - long_name = interpolation low index for ozone - units = index - dimensions = (horizontal_dimension) - type = integer - intent = in -[jindx2_o3] - standard_name = upper_latitude_index_of_ozone_forcing_for_interpolation - long_name = interpolation high index for ozone - units = index - dimensions = (horizontal_dimension) - type = integer - intent = in -[ddy_o3] - standard_name = latitude_interpolation_weight_for_ozone_forcing - long_name = interpolation high index for ozone - units = none - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in -[ozpl] - standard_name = ozone_forcing - long_name = ozone forcing data - units = mixed - dimensions = (horizontal_dimension,vertical_dimension_of_ozone_forcing_data,number_of_coefficients_in_ozone_forcing_data) - type = real - kind = kind_phys - intent = inout [jindx1_h] standard_name = lower_latitude_index_of_stratospheric_water_vapor_forcing_for_interpolation long_name = interpolation low index for stratospheric water vapor diff --git a/physics/GFS_phys_time_vary.scm.F90 b/physics/GFS_phys_time_vary.scm.F90 index 74b34e974..97460ac98 100644 --- a/physics/GFS_phys_time_vary.scm.F90 +++ b/physics/GFS_phys_time_vary.scm.F90 @@ -2,7 +2,7 @@ !! Contains code related to GFS physics suite setup (physics part of time_vary_step) !>\defgroup mod_GFS_phys_time_vary GFS Physics Time Update -!! This module contains GFS physics time vary subroutines including ozone, stratospheric water vapor, +!! This module contains GFS physics time vary subroutines including, stratospheric water vapor, !! aerosol, IN&CCN and surface properties updates. !> @{ module GFS_phys_time_vary @@ -11,9 +11,6 @@ module GFS_phys_time_vary use mersenne_twister, only: random_setseed, random_number - use ozne_def, only : levozp, oz_coeff, oz_lat, oz_pres, oz_time, ozplin - use ozinterp, only : read_o3data, setindxoz, ozinterpol - use h2o_def, only : levh2o, h2o_coeff, h2o_lat, h2o_pres, h2o_time, h2oplin use h2ointerp, only : read_h2odata, setindxh2o, h2ointerpol @@ -61,8 +58,8 @@ module GFS_phys_time_vary !>\section gen_GFS_phys_time_vary_init GFS_phys_time_vary_init General Algorithm !! @{ subroutine GFS_phys_time_vary_init ( & - me, master, ntoz, h2o_phys, iaerclm, iccn, iflip, im, nx, ny, idate, xlat_d, xlon_d, & - jindx1_o3, jindx2_o3, ddy_o3, ozpl, jindx1_h, jindx2_h, ddy_h, h2opl,fhour, & + me, master, h2o_phys, iaerclm, iccn, iflip, im, nx, ny, idate, xlat_d, xlon_d, & + jindx1_h, jindx2_h, ddy_h, h2opl,fhour, & jindx1_aer, jindx2_aer, ddy_aer, iindx1_aer, iindx2_aer, ddx_aer, aer_nm, & jindx1_ci, jindx2_ci, ddy_ci, iindx1_ci, iindx2_ci, ddx_ci, imap, jmap, & do_ugwp_v1, jindx1_tau, jindx2_tau, ddy_j1tau, ddy_j2tau, & @@ -79,15 +76,15 @@ subroutine GFS_phys_time_vary_init ( implicit none ! Interface variables - integer, intent(in) :: me, master, ntoz, iccn, iflip, im, nx, ny + integer, intent(in) :: me, master, iccn, iflip, im, nx, ny logical, intent(in) :: h2o_phys, iaerclm, lsm_cold_start integer, intent(in) :: idate(:) real(kind_phys), intent(in) :: fhour real(kind_phys), intent(in) :: xlat_d(:), xlon_d(:) - integer, intent(inout) :: jindx1_o3(:), jindx2_o3(:), jindx1_h(:), jindx2_h(:) - real(kind_phys), intent(inout) :: ddy_o3(:), ddy_h(:) - real(kind_phys), intent(in) :: ozpl(:,:,:), h2opl(:,:,:) + integer, intent(inout) :: jindx1_h(:), jindx2_h(:) + real(kind_phys), intent(inout) :: ddy_h(:) + real(kind_phys), intent(in) :: h2opl(:,:,:) integer, intent(inout) :: jindx1_aer(:), jindx2_aer(:), iindx1_aer(:), iindx2_aer(:) real(kind_phys), intent(inout) :: ddy_aer(:), ddx_aer(:) real(kind_phys), intent(in) :: aer_nm(:,:,:) @@ -189,30 +186,11 @@ subroutine GFS_phys_time_vary_init ( jamin=999 jamax=-999 -!> - Call read_o3data() to read ozone data - call read_o3data (ntoz, me, master) - - ! Consistency check that the hardcoded values for levozp and - ! oz_coeff in GFS_typedefs.F90 match what is set by read_o3data - ! in GFS_typedefs.F90: allocate (Tbd%ozpl (IM,levozp,oz_coeff)) - if (size(ozpl, dim=2).ne.levozp) then - write(errmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", & - "levozp from read_o3data does not match value in GFS_typedefs.F90: ", & - levozp, " /= ", size(ozpl, dim=2) - errflg = 1 - end if - if (size(ozpl, dim=3).ne.oz_coeff) then - write(errmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", & - "oz_coeff from read_o3data does not match value in GFS_typedefs.F90: ", & - oz_coeff, " /= ", size(ozpl, dim=3) - errflg = 1 - end if - !> - Call read_h2odata() to read stratospheric water vapor data call read_h2odata (h2o_phys, me, master) ! Consistency check that the hardcoded values for levh2o and - ! h2o_coeff in GFS_typedefs.F90 match what is set by read_o3data + ! h2o_coeff in GFS_typedefs.F90 match what is set by read_h2odata ! in GFS_typedefs.F90: allocate (Tbd%h2opl (IM,levh2o,h2o_coeff)) if (size(h2opl, dim=2).ne.levh2o) then write(errmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", & @@ -266,11 +244,6 @@ subroutine GFS_phys_time_vary_init ( !> - Initialize soil vegetation (needed for sncovr calculation further down) call set_soilveg(me, isot, ivegsrc, nlunit, errmsg, errflg) -!> - Call setindxoz() to initialize ozone data - if (ntoz > 0) then - call setindxoz (im, xlat_d, jindx1_o3, jindx2_o3, ddy_o3) - endif - !> - Call setindxh2o() to initialize stratospheric water vapor data if (h2o_phys) then call setindxh2o (im, xlat_d, jindx1_h, jindx2_h, ddy_h) @@ -652,8 +625,8 @@ end subroutine GFS_phys_time_vary_init !! @{ subroutine GFS_phys_time_vary_timestep_init ( & me, master, cnx, cny, isc, jsc, nrcm, im, levs, kdt, idate, nsswr, fhswr, lsswr, fhour, & - imfdeepcnv, cal_pre, random_clds, ntoz, h2o_phys, iaerclm, iccn, clstp, & - jindx1_o3, jindx2_o3, ddy_o3, ozpl, jindx1_h, jindx2_h, ddy_h, h2opl, iflip, & + imfdeepcnv, cal_pre, random_clds, h2o_phys, iaerclm, iccn, clstp, & + jindx1_h, jindx2_h, ddy_h, h2opl, iflip, & jindx1_aer, jindx2_aer, ddy_aer, iindx1_aer, iindx2_aer, ddx_aer, aer_nm, & jindx1_ci, jindx2_ci, ddy_ci, iindx1_ci, iindx2_ci, ddx_ci, in_nm, ccn_nm, & imap, jmap, prsl, seed0, rann, do_ugwp_v1, jindx1_tau, jindx2_tau, ddy_j1tau, ddy_j2tau,& @@ -663,14 +636,14 @@ subroutine GFS_phys_time_vary_timestep_init ( ! Interface variables integer, intent(in) :: me, master, cnx, cny, isc, jsc, nrcm, im, levs, kdt, & - nsswr, imfdeepcnv, iccn, ntoz, iflip + nsswr, imfdeepcnv, iccn, iflip integer, intent(in) :: idate(:) real(kind_phys), intent(in) :: fhswr, fhour logical, intent(in) :: lsswr, cal_pre, random_clds, h2o_phys, iaerclm real(kind_phys), intent(out) :: clstp - integer, intent(in) :: jindx1_o3(:), jindx2_o3(:), jindx1_h(:), jindx2_h(:) - real(kind_phys), intent(in) :: ddy_o3(:), ddy_h(:) - real(kind_phys), intent(inout) :: ozpl(:,:,:), h2opl(:,:,:) + integer, intent(in) :: jindx1_h(:), jindx2_h(:) + real(kind_phys), intent(in) :: ddy_h(:) + real(kind_phys), intent(inout) :: h2opl(:,:,:) integer, intent(in) :: jindx1_aer(:), jindx2_aer(:), iindx1_aer(:), iindx2_aer(:) real(kind_phys), intent(in) :: ddy_aer(:), ddx_aer(:) real(kind_phys), intent(inout) :: aer_nm(:,:,:) @@ -748,13 +721,6 @@ subroutine GFS_phys_time_vary_timestep_init ( endif ! imfdeepcnv, cal_re, random_clds -!> - Call ozinterpol() to make ozone interpolation - if (ntoz > 0) then - call ozinterpol (me, im, idate, fhour, & - jindx1_o3, jindx2_o3, & - ozpl, ddy_o3) - endif - !> - Call h2ointerpol() to make stratospheric water vapor data interpolation if (h2o_phys) then call h2ointerpol (me, im, idate, fhour, & @@ -844,12 +810,6 @@ subroutine GFS_phys_time_vary_finalize(errmsg, errflg) if (.not.is_initialized) return - ! Deallocate ozone arrays - if (allocated(oz_lat) ) deallocate(oz_lat) - if (allocated(oz_pres) ) deallocate(oz_pres) - if (allocated(oz_time) ) deallocate(oz_time) - if (allocated(ozplin) ) deallocate(ozplin) - ! Deallocate h2o arrays if (allocated(h2o_lat) ) deallocate(h2o_lat) if (allocated(h2o_pres)) deallocate(h2o_pres) diff --git a/physics/GFS_phys_time_vary.scm.meta b/physics/GFS_phys_time_vary.scm.meta index 8b59e4bed..21d1f2736 100644 --- a/physics/GFS_phys_time_vary.scm.meta +++ b/physics/GFS_phys_time_vary.scm.meta @@ -2,7 +2,7 @@ name = GFS_phys_time_vary type = scheme dependencies = aerclm_def.F,aerinterp.F90,h2o_def.f,h2ointerp.f90,iccn_def.F,iccninterp.F90,machine.F,mersenne_twister.f - dependencies = namelist_soilveg.f,set_soilveg.f,ozinterp.f90,ozne_def.f,cires_tauamf_data.F90,noahmp_tables.f90 + dependencies = namelist_soilveg.f,set_soilveg.f,cires_tauamf_data.F90,noahmp_tables.f90 ######################################################################## [ccpp-arg-table] @@ -23,13 +23,6 @@ dimensions = () type = integer intent = in -[ntoz] - standard_name = index_of_ozone_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for ozone mixing ratio - units = index - dimensions = () - type = integer - intent = in [h2o_phys] standard_name = flag_for_stratospheric_water_vapor_physics long_name = flag for stratospheric water vapor physics @@ -102,36 +95,6 @@ type = real kind = kind_phys intent = in -[jindx1_o3] - standard_name = lower_latitude_index_of_ozone_forcing_for_interpolation - long_name = interpolation low index for ozone - units = index - dimensions = (horizontal_dimension) - type = integer - intent = inout -[jindx2_o3] - standard_name = upper_latitude_index_of_ozone_forcing_for_interpolation - long_name = interpolation high index for ozone - units = index - dimensions = (horizontal_dimension) - type = integer - intent = inout -[ddy_o3] - standard_name = latitude_interpolation_weight_for_ozone_forcing - long_name = interpolation high index for ozone - units = none - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = inout -[ozpl] - standard_name = ozone_forcing - long_name = ozone forcing data - units = mixed - dimensions = (horizontal_dimension,vertical_dimension_of_ozone_forcing_data,number_of_coefficients_in_ozone_forcing_data) - type = real - kind = kind_phys - intent = in [jindx1_h] standard_name = lower_latitude_index_of_stratospheric_water_vapor_forcing_for_interpolation long_name = interpolation low index for stratospheric water vapor @@ -1056,13 +1019,6 @@ dimensions = () type = logical intent = in -[ntoz] - standard_name = index_of_ozone_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for ozone mixing ratio - units = index - dimensions = () - type = integer - intent = in [h2o_phys] standard_name = flag_for_stratospheric_water_vapor_physics long_name = flag for stratospheric water vapor physics @@ -1092,36 +1048,6 @@ type = real kind = kind_phys intent = out -[jindx1_o3] - standard_name = lower_latitude_index_of_ozone_forcing_for_interpolation - long_name = interpolation low index for ozone - units = index - dimensions = (horizontal_dimension) - type = integer - intent = in -[jindx2_o3] - standard_name = upper_latitude_index_of_ozone_forcing_for_interpolation - long_name = interpolation high index for ozone - units = index - dimensions = (horizontal_dimension) - type = integer - intent = in -[ddy_o3] - standard_name = latitude_interpolation_weight_for_ozone_forcing - long_name = interpolation high index for ozone - units = none - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in -[ozpl] - standard_name = ozone_forcing - long_name = ozone forcing data - units = mixed - dimensions = (horizontal_dimension,vertical_dimension_of_ozone_forcing_data,number_of_coefficients_in_ozone_forcing_data) - type = real - kind = kind_phys - intent = inout [jindx1_h] standard_name = lower_latitude_index_of_stratospheric_water_vapor_forcing_for_interpolation long_name = interpolation low index for stratospheric water vapor diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index c45bec3e3..ae88ca0fc 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -45,7 +45,8 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& gasvmr_ccl4, gasvmr_cfc113, aerodp,ext550, clouds6, clouds7, clouds8, & clouds9, cldsa, cldfra, cldfra2d, lwp_ex,iwp_ex, lwp_fc,iwp_fc, & faersw1, faersw2, faersw3, faerlw1, faerlw2, faerlw3, alpha, & - aero_dir_fdb, fdb_coef, spp_wts_rad, spp_rad, ico2, errmsg, errflg) + aero_dir_fdb, fdb_coef, spp_wts_rad, spp_rad, ico2, latsozp, levozp, & + blatc, dphiozc, errmsg, errflg) use machine, only: kind_phys @@ -101,7 +102,8 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& imp_physics_mg, imp_physics_wsm6, & imp_physics_nssl, & imp_physics_fer_hires, & - yearlen, icloud, iaermdl, iaerflg + yearlen, icloud, iaermdl, iaerflg, & + latsozp, levozp integer, intent(in) :: & iovr, & ! choice of cloud-overlap method @@ -132,7 +134,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& integer, intent(in) :: spp_rad real(kind_phys), intent(in) :: spp_wts_rad(:,:) - real(kind=kind_phys), intent(in) :: fhswr, fhlwr, solhr, sup, julian, sppt_amp, dcorr_con + real(kind=kind_phys), intent(in) :: fhswr, fhlwr, solhr, sup, julian, sppt_amp, dcorr_con, blatc, dphiozc real(kind=kind_phys), intent(in) :: con_eps, epsm1, fvirt, rog, rocp, con_rd, con_pi, con_g, con_ttp, con_thgni real(kind=kind_phys), dimension(:), intent(in) :: xlat_d, xlat, xlon, & @@ -429,8 +431,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& enddo enddo else ! climatological ozone - call getozn (prslk1, xlat, im, lmk, top_at_1, & ! --- inputs - olyr) ! --- outputs + call getozn (prslk1, xlat, im, lmk, top_at_1, latsozp, levozp, blatc, dphiozc, olyr) endif ! end_if_ntoz !> - Call coszmn(), to compute cosine of zenith angle (only when SW is called) diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index d7feaeb3f..88363ef18 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -1496,6 +1496,36 @@ dimensions = () type = integer intent = in +[latsozp] + standard_name = number_of_latitudes_in_ozone_data + long_name = number of latitude in ozone data + units = count + dimensions = () + type = integer + intent = in +[levozp] + standard_name = number_of_levels_in_ozone_data + long_name = number of levels in ozone data + units = count + dimensions = () + type = integer + intent = in +[dphiozc] + standard_name = ozone_data_parameter_1 + long_name = ozone data parameter 1 + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[blatc] + standard_name = ozone_data_parameter_2 + long_name = ozone data parameter 2 + units = none + dimensions = () + type = real + kind = kind_phys + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/GFS_rrtmg_setup.F90 b/physics/GFS_rrtmg_setup.F90 index 384d5252d..30917b961 100644 --- a/physics/GFS_rrtmg_setup.F90 +++ b/physics/GFS_rrtmg_setup.F90 @@ -44,7 +44,7 @@ subroutine GFS_rrtmg_setup_init ( si, levr, ictm, isol, solar_file, ico2, & iaermdl, iaerflg, aeros_file, con_pi, con_t0c, con_c, con_boltz, & con_plnk, con_solr_2008, con_solr_2002, con_g, con_rd, co2usr_file, & co2cyc_file, rad_hr_units, inc_minor_gas, icliq_lw, isubcsw, isubclw,& - iswmode, ipsd0, ltp, lextop, errmsg, errflg) + iswmode, latsozp, levozp, timeozp, ipsd0, ltp, lextop, errmsg, errflg) ! ================= subprogram documentation block ================ ! ! ! ! subprogram: GFS_rrtmg_setup_init - a subprogram to initialize radiation ! @@ -155,7 +155,8 @@ subroutine GFS_rrtmg_setup_init ( si, levr, ictm, isol, solar_file, ico2, & integer, intent(in) :: levr, ictm, isol, ico2, iaer, ntcw, num_p3d, & ltp, npdf3d, ntoz, iovr, iovr_rand, iovr_maxrand, iovr_max, & iovr_dcorr, iovr_exp, iovr_exprand, icliq_sw, imp_physics, & - iflip, me, rad_hr_units, icliq_lw, isubcsw, isubclw, iswmode + iflip, me, rad_hr_units, icliq_lw, isubcsw, isubclw, iswmode, & + latsozp, levozp, timeozp integer, intent(in) :: idate(:) logical, intent(in) :: lcrick, lcnorm, lnoprec, do_RRTMGP, lalw1bd, & inc_minor_gas, lextop @@ -219,7 +220,7 @@ subroutine GFS_rrtmg_setup_init ( si, levr, ictm, isol, solar_file, ico2, & call aer_init ( levr, me, iaermdl, iaerflg, lalw1bd, aeros_file, & con_pi, con_t0c, con_c, con_boltz, con_plnk, errflg, errmsg) call gas_init ( me, co2usr_file, co2cyc_file, ico2, ictm, ntoz, & - con_pi, errflg, errmsg) + con_pi, latsozp, levozp, timeozp, errflg, errmsg) call cld_init ( si, levr, imp_physics, me, con_g, con_rd, errflg, errmsg) call rlwinit ( me, rad_hr_units, inc_minor_gas, icliq_lw, isubcsw, & iovr, iovr_rand, iovr_maxrand, iovr_max, iovr_dcorr, & diff --git a/physics/GFS_rrtmg_setup.meta b/physics/GFS_rrtmg_setup.meta index adf6d8750..42b999c82 100644 --- a/physics/GFS_rrtmg_setup.meta +++ b/physics/GFS_rrtmg_setup.meta @@ -173,6 +173,27 @@ dimensions = () type = integer intent = in +[levozp] + standard_name = number_of_levels_in_ozone_data + long_name = number of levels in ozone data + units = count + dimensions = () + type = integer + intent = in +[timeozp] + standard_name = number_of_times_in_ozone_data + long_name = number of times in ozone data + units = count + dimensions = () + type = integer + intent = in +[latsozp] + standard_name = number_of_latitudes_in_ozone_data + long_name = number of latitude in ozone data + units = count + dimensions = () + type = integer + intent = in [icliq_sw] standard_name = control_for_shortwave_radiation_liquid_clouds long_name = sw optical property for liquid clouds diff --git a/physics/ozinterp.f90 b/physics/ozinterp.f90 deleted file mode 100644 index 5b3149d61..000000000 --- a/physics/ozinterp.f90 +++ /dev/null @@ -1,212 +0,0 @@ -!>\file ozinterp.f90 -!! This file contains ozone climatology interpolation subroutines. - -!>\ingroup mod_GFS_phys_time_vary -!! This module contains subroutines of reading and interpolating ozone coefficients. -module ozinterp - - implicit none - - private - - public :: read_o3data, setindxoz, ozinterpol - -contains - - SUBROUTINE read_o3data (ntoz, me, master) - use machine, only: kind_phys - use ozne_def -!--- in/out - integer, intent(in) :: ntoz - integer, intent(in) :: me - integer, intent(in) :: master -!--- locals - integer :: i, n, k - real(kind=4), allocatable, dimension(:) :: oz_lat4, oz_pres4 - real(kind=4), allocatable, dimension(:) :: oz_time4, tempin - real(kind=4) :: blatc4 - - if (ntoz <= 0) then ! Diagnostic ozone - rewind (kozc) - read (kozc,end=101) latsozc, levozc, timeozc, blatc4 - 101 if (levozc < 10 .or. levozc > 100) then - rewind (kozc) - levozc = 17 - latsozc = 18 - blatc = -85.0 - else - blatc = blatc4 - endif - latsozp = 2 - levozp = 1 - timeoz = 1 - oz_coeff = 0 - dphiozc = -(blatc+blatc)/(latsozc-1) - return - endif - - open(unit=kozpl,file='global_o3prdlos.f77', form='unformatted', convert='big_endian') - -!--- read in indices -!--- - read (kozpl) oz_coeff, latsozp, levozp, timeoz - if (me == master) then - write(*,*) 'Reading in o3data from global_o3prdlos.f77 ' - write(*,*) ' oz_coeff = ', oz_coeff - write(*,*) ' latsozp = ', latsozp - write(*,*) ' levozp = ', levozp - write(*,*) ' timeoz = ', timeoz - endif - -!--- read in data -!--- oz_lat - latitude of data (-90 to 90) -!--- oz_pres - vertical pressure level (mb) -!--- oz_time - time coordinate (days) -!--- - allocate (oz_lat(latsozp), oz_pres(levozp),oz_time(timeoz+1)) - allocate (oz_lat4(latsozp), oz_pres4(levozp),oz_time4(timeoz+1)) - rewind (kozpl) - read (kozpl) oz_coeff, latsozp, levozp, timeoz, oz_lat4, oz_pres4, oz_time4 - oz_pres(:) = oz_pres4(:) -!--- convert pressure levels from mb to ln(Pa) - oz_pres(:) = log(100.0*oz_pres(:)) - oz_lat(:) = oz_lat4(:) - oz_time(:) = oz_time4(:) - deallocate (oz_lat4, oz_pres4, oz_time4) - -!--- read in ozplin which is in order of (lattitudes, ozone levels, coeff number, time) -!--- assume latitudes is on a uniform gaussian grid -!--- - allocate (tempin(latsozp)) - allocate (ozplin(latsozp,levozp,oz_coeff,timeoz)) - DO i=1,timeoz - DO n=1,oz_coeff - DO k=1,levozp - READ(kozpl) tempin - ozplin(:,k,n,i) = tempin(:) - ENDDO - ENDDO - ENDDO - deallocate (tempin) - - close(kozpl) - - END SUBROUTINE read_o3data -! -!********************************************************************** -! - SUBROUTINE setindxoz(npts,dlat,jindx1,jindx2,ddy) -! - USE MACHINE, ONLY: kind_phys - USE OZNE_DEF, ONLY: jo3 => latsozp, oz_lat -! - implicit none -! - integer npts, JINDX1(npts),JINDX2(npts) - real(kind=kind_phys) dlat(npts),DDY(npts) -! - integer i,j,lat -! - DO J=1,npts - jindx2(j) = jo3 + 1 - do i=1,jo3 - if (dlat(j) < oz_lat(i)) then - jindx2(j) = i - exit - endif - enddo - jindx1(j) = max(jindx2(j)-1,1) - jindx2(j) = min(jindx2(j),jo3) - if (jindx2(j) .ne. jindx1(j)) then - DDY(j) = (dlat(j) - oz_lat(jindx1(j))) & - / (oz_lat(jindx2(j)) - oz_lat(jindx1(j))) - else - ddy(j) = 1.0 - endif -! print *,' j=',j,' dlat=',dlat(j),' jindx12=',jindx1(j), & -! jjindx2(j),' oz_lat=',oz_lat(jindx1(j)), & -! oz_lat(jindx2(j)),' ddy=',ddy(j) - ENDDO - - RETURN - END SUBROUTINE setindxoz -! -!********************************************************************** -! - SUBROUTINE ozinterpol(me,npts,IDATE,FHOUR,jindx1,jindx2,ozplout,ddy) -! - USE MACHINE, ONLY : kind_phys - USE OZNE_DEF - implicit none - integer iday,j,j1,j2,l,npts,nc,n1,n2 - real(kind=kind_phys) fhour,tem, tx1, tx2 -! - - integer JINDX1(npts), JINDX2(npts) - integer me, idate(4), IDAT(8),JDAT(8) -! - real(kind=kind_phys) DDY(npts) - real(kind=kind_phys) ozplout(npts,levozp,oz_coeff) - real(kind=kind_phys) rjday - integer jdow, jdoy, jday - real(8) rinc(5) - real(4) rinc4(5) - integer w3kindreal,w3kindint -! - IDAT=0 - IDAT(1)=IDATE(4) - IDAT(2)=IDATE(2) - IDAT(3)=IDATE(3) - IDAT(5)=IDATE(1) - RINC=0. - RINC(2)=FHOUR - call w3kind(w3kindreal,w3kindint) - if(w3kindreal==4) then - rinc4=rinc - CALL W3MOVDAT(RINC4,IDAT,JDAT) - else - CALL W3MOVDAT(RINC,IDAT,JDAT) - endif -! - jdow = 0 - jdoy = 0 - jday = 0 - call w3doxdat(jdat,jdow,jdoy,jday) - rjday = jdoy + jdat(5) / 24. - IF (RJDAY < oz_time(1)) RJDAY = RJDAY + 365. -! - n2 = timeoz + 1 - do j=2,timeoz - if (rjday < oz_time(j)) then - n2 = j - exit - endif - enddo - n1 = n2 - 1 -! -! if (me == 0) print *,' n1=',n1,' n2=',n2,' rjday=',rjday -! &,'oz_time=',oz_time(n1),oz_time(n2) -! - - tx1 = (oz_time(n2) - rjday) / (oz_time(n2) - oz_time(n1)) - tx2 = 1.0 - tx1 - - if (n2 > timeoz) n2 = n2 - timeoz -! - do nc=1,oz_coeff - DO L=1,levozp - DO J=1,npts - J1 = JINDX1(J) - J2 = JINDX2(J) - TEM = 1.0 - DDY(J) - ozplout(j,L,nc) = & - tx1*(TEM*ozplin(J1,L,nc,n1)+DDY(J)*ozplin(J2,L,nc,n1)) & - + tx2*(TEM*ozplin(J1,L,nc,n2)+DDY(J)*ozplin(J2,L,nc,n2)) - ENDDO - ENDDO - enddo -! - RETURN - END SUBROUTINE ozinterpol - -end module ozinterp diff --git a/physics/ozne_def.f b/physics/ozne_def.f deleted file mode 100644 index 8f3af6240..000000000 --- a/physics/ozne_def.f +++ /dev/null @@ -1,24 +0,0 @@ -!>\file ozne_def.f -!! This file contains the ozone array definition used in ozone physics. - -!>\ingroup mod_GFS_phys_time_vary -!! This module defines arrays in Ozone scheme. - module ozne_def - -!> \section arg_table_ozne_def -!! \htmlinclude ozne_def.html -!! - - use machine , only : kind_phys - implicit none - - integer, parameter :: kozpl=28, kozc=48 - - integer latsozp, levozp, timeoz, latsozc, levozc, timeozc - &, oz_coeff - real (kind=kind_phys) blatc, dphiozc - real (kind=kind_phys), allocatable :: oz_lat(:), oz_pres(:) - &, oz_time(:) - real (kind=kind_phys), allocatable :: ozplin(:,:,:,:) - - end module ozne_def diff --git a/physics/ozne_def.meta b/physics/ozne_def.meta deleted file mode 100644 index 3cad9c14d..000000000 --- a/physics/ozne_def.meta +++ /dev/null @@ -1,29 +0,0 @@ -[ccpp-table-properties] - name = ozne_def - type = module - dependencies = machine.F - -[ccpp-arg-table] - name = ozne_def - type = module - -[levozp] - standard_name = vertical_dimension_of_ozone_forcing_data - long_name = number of vertical layers in ozone forcing data - units = count - dimensions = () - type = integer -[oz_coeff] - standard_name = number_of_coefficients_in_ozone_forcing_data - long_name = number of coefficients in ozone forcing data - units = index - dimensions = () - type = integer -[oz_pres] - standard_name = natural_log_of_ozone_forcing_data_pressure_levels - long_name = natural log of ozone forcing data pressure levels in Pa - units = 1 - dimensions = (vertical_dimension_of_ozone_forcing_data) - type = real - kind = kind_phys - active = (index_of_ozone_mixing_ratio_in_tracer_concentration_array>0) diff --git a/physics/ozphys_2015.F90 b/physics/ozphys_2015.F90 new file mode 100644 index 000000000..17f2178a4 --- /dev/null +++ b/physics/ozphys_2015.F90 @@ -0,0 +1,343 @@ +! ########################################################################################### +!> \file ozphys_2015.F90 +!! +! ########################################################################################### +module ozphys_2015 + use machine , only : kind_phys + implicit none + public ozphys_2015_init, ozphys_2015_timestep_init, ozphys_2015_run +contains + +! ########################################################################################### +!>\defgroup GFS_ozphys_2015 GFS Ozone Photochemistry (2015) Module +!! This module contains the CCPP-compliant Ozone 2015 photochemistry scheme. +!> @{ +!> \section arg_table_ozphys_2015_init Argument Table +!! \htmlinclude ozphys_2015_init.html +!! +! ########################################################################################### + subroutine ozphys_2015_init(oz_phys_2015, nPts, latsozp, oz_lat, dlat, jindx1, jindx2, & + ddy, errmsg, errflg) + ! Inputs + logical, intent(in) :: & + oz_phys_2015 ! Control flag for NRL 2015 ozone physics scheme + integer, intent(in) :: & + nPts, & ! Horizontal dimension + latsozp ! Number of latitudes in ozone data + real(kind_phys), intent(in), dimension(:) :: & + oz_lat, & ! Latitudes of ozone data + dlat ! Latitudes of grid + ! Outputs + integer, intent(out), dimension(:) :: & + jindx1, & ! Interpolation index (low) for ozone data + jindx2 ! Interpolation index (high) for ozone data + real(kind_phys), intent(out), dimension(:) :: & + ddy ! Interpolation high index for ozone data + character(len=*), intent(out) :: & + errmsg ! CCPP error message + integer, intent(out) :: & + errflg ! CCPP error flag + + ! Local + integer i,j + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! Sanity check + if (.not.oz_phys_2015) then + write (errmsg,'(*(a))') 'Logic error: oz_phys_2015 == .false.' + errflg = 1 + return + endif + + ! Set indices + do j=1,nPts + jindx2(j) = latsozp + 1 + do i=1,latsozp + if (dlat(j) < oz_lat(i)) then + jindx2(j) = i + exit + endif + enddo + jindx1(j) = max(jindx2(j)-1,1) + jindx2(j) = min(jindx2(j),latsozp) + if (jindx2(j) .ne. jindx1(j)) then + ddy(j) = (dlat(j) - oz_lat(jindx1(j))) / (oz_lat(jindx2(j)) - oz_lat(jindx1(j))) + else + ddy(j) = 1.0 + endif + enddo + + end subroutine ozphys_2015_init + +! ########################################################################################### +!> \section arg_table_ozphys_2015_timestep_init Argument Table +!! \htmlinclude ozphys_2015_timestep_init.html +!! +! ########################################################################################### + subroutine ozphys_2015_timestep_init(nPts, idate, fhour, jindx1, jindx2, latsozp, levozp, & + oz_coeff, timeoz, ozplin, oz_time, oz_pres, oz_lat, ddy, ozplout, errmsg, errflg) + ! Inputs + integer, intent(in) :: & + nPts, & ! Horizontal dimension + latsozp, & ! Number of latitudes in ozone data + levozp, & ! Number of levels in ozone data + oz_coeff, & ! Number of coefficients in ozone data + timeoz ! Number of times in ozone data + integer, intent(in),dimension(:) :: & + idate, & ! Initial date with different size and ordering + jindx1, & ! Interpolation index (low) for ozone + jindx2 ! Interpolation index (high) for ozone + real(kind_phys), intent(in) :: & + fhour ! Forecast hour + real(kind_phys), intent(in), dimension(:) :: & + ddy, & ! Interpolation high index for ozone data + oz_lat, & ! Latitudes for ozone data + oz_pres, & ! Levels for ozone data + oz_time ! Time for ozone data + real(kind_phys), intent(in), dimension(:,:,:,:) :: & + ozplin ! Ozone data + + ! Outputs + real(kind_phys), intent(out), dimension(:,:,:) :: & + ozplout ! Ozone forcing data + character(len=*), intent(out) :: & + errmsg ! CCPP error message + integer, intent(out) :: & + errflg ! CCPP error flag + + ! Local + integer :: idat(8),jdat(8),iday,j,j1,j2,l,nc,n1,n2,jdow,jdoy,& + jday,w3kindreal,w3kindint + real(kind_phys) :: tem, tx1, tx2, rjday + real(8) :: rinc(5) + real(4) :: rinc4(5) + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! + idat=0 + idat(1)=idate(4) + idat(2)=idate(2) + idat(3)=idate(3) + idat(5)=idate(1) + rinc=0. + rinc(2)=fhour + call w3kind(w3kindreal,w3kindint) + if(w3kindreal==4) then + rinc4=rinc + CALL w3movdat(rinc4,idat,jdat) + else + CALL w3movdat(rinc,idat,jdat) + endif + ! + jdow = 0 + jdoy = 0 + jday = 0 + call w3doxdat(jdat,jdow,jdoy,jday) + rjday = jdoy + jdat(5) / 24. + IF (RJDAY < oz_time(1)) RJDAY = RJDAY + 365. + ! + n2 = timeoz + 1 + do j=2,timeoz + if (rjday < oz_time(j)) then + n2 = j + exit + endif + enddo + n1 = n2 - 1 + + tx1 = (oz_time(n2) - rjday) / (oz_time(n2) - oz_time(n1)) + tx2 = 1.0 - tx1 + + if (n2 > timeoz) n2 = n2 - timeoz + ! + do nc=1,oz_coeff + do L=1,levozp + do J=1,npts + J1 = jindx1(J) + J2 = jindx2(J) + TEM = 1.0 - ddy(J) + ozplout(j,L,nc) = tx1*(TEM*ozplin(J1,L,nc,n1)+ddy(J)*ozplin(J2,L,nc,n1)) & + + tx2*(TEM*ozplin(J1,L,nc,n2)+ddy(J)*ozplin(J2,L,nc,n2)) + enddo + enddo + enddo + + ! + return + + end subroutine ozphys_2015_timestep_init + +! ########################################################################################### +!> The operational GFS currently parameterizes ozone production and +!! destruction based on monthly mean coefficients ( +!! \c ozprdlos_2015_new_sbuvO3_tclm15_nuchem.f77) provided by Naval +!! Research Laboratory through CHEM2D chemistry model +!! (McCormack et al. (2006) \cite mccormack_et_al_2006). +!! \section arg_table_ozphys_2015_run Argument Table +!! \htmlinclude ozphys_2015_run.html +!! +!> \section genal_ozphys_2015 GFS ozphys_2015_run General Algorithm +!> - This code assumes that both prsl and po3 are from bottom to top +!! as are all other variables. +!> - This code is specifically for NRL parameterization and +!! climatological T and O3 are in location 5 and 6 of prdout array +!!\author June 2015 - Shrinivas Moorthi +! ########################################################################################### + subroutine ozphys_2015_run ( im, levs, ko3, dt, oz, tin, po3, prsl, prdout, pl_coeff, & + delp, ldiag3d, dtend, dtidx, ntoz, index_of_process_prod_loss, & + index_of_process_ozmix, index_of_process_temp, index_of_process_overhead_ozone, & + con_g, errmsg, errflg) + + ! Inputs + logical, intent(in) :: & + ldiag3d + real(kind_phys),intent(in) :: & + con_g + integer, intent(in) :: & + im, & ! + levs, & ! + ko3, & ! + pl_coeff, & ! + ntoz, & ! + index_of_process_prod_loss, & ! + index_of_process_ozmix, & ! + index_of_process_temp, & + index_of_process_overhead_ozone + integer, intent(in), dimension(:,:) :: & + dtidx ! + real(kind_phys), intent(in) :: & + dt ! + real(kind_phys), intent(in), dimension(:) :: & + po3 ! + real(kind_phys), intent(in), dimension(:,:) :: & + prsl, & ! + tin, & ! + delp ! + real(kind_phys), intent(in), dimension(:,:,:) :: & + prdout ! + + ! In/Outs + real(kind=kind_phys), intent(inout), dimension(:,:,:) :: & + dtend ! + + ! Outputs + real(kind=kind_phys), intent(inout), dimension(:,:) :: & + oz ! + character(len=*), intent(out) :: & + errmsg ! CCPP error message + integer, intent(out) :: & + errflg ! CCPP error flag + + ! Locals + integer :: k, kmax, kmin, l, i, j + integer, dimension(4) :: idtend + logical, dimension(im) :: flg + real :: gravi + real(kind_phys) :: pmax, pmin, tem, temp + real(kind_phys), dimension(im) :: wk1, wk2, wk3, ozib + real(kind_phys), dimension(im,pl_coeff) :: prod + real(kind_phys), dimension(im,levs) :: ozi + real(kind_phys), dimension(im,levs+1) :: colo3, coloz + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! Are UFS diagnostic tendencies requested? If so, set up bookeeping indices... + if(ldiag3d) then + idtend(1) = dtidx(100+ntoz,index_of_process_prod_loss) ! was ozp1 + idtend(2) = dtidx(100+ntoz,index_of_process_ozmix) ! was ozp2 + idtend(3) = dtidx(100+ntoz,index_of_process_temp) ! was ozp3 + idtend(4) = dtidx(100+ntoz,index_of_process_overhead_ozone) ! was ozp4 + else + idtend=0 + endif + + ! Temporaries + ozi = oz + gravi=1.0/con_g + + colo3(:,levs+1) = 0.0 + coloz(:,levs+1) = 0.0 + + do l=levs,1,-1 + pmin = 1.0e10 + pmax = -1.0e10 + + do i=1,im + wk1(i) = log(prsl(i,l)) + pmin = min(wk1(i), pmin) + pmax = max(wk1(i), pmax) + prod(i,:) = 0.0 + enddo + kmax = 1 + kmin = 1 + do k=1,ko3-1 + if (pmin < po3(k)) kmax = k + if (pmax < po3(k)) kmin = k + enddo + ! + do k=kmin,kmax + temp = 1.0 / (po3(k) - po3(k+1)) + do i=1,im + flg(i) = .false. + if (wk1(i) < po3(k) .and. wk1(i) >= po3(k+1)) then + flg(i) = .true. + wk2(i) = (wk1(i) - po3(k+1)) * temp + wk3(i) = 1.0 - wk2(i) + endif + enddo + do j=1,pl_coeff + do i=1,im + if (flg(i)) then + prod(i,j) = wk2(i) * prdout(i,k,j) + wk3(i) * prdout(i,k+1,j) + endif + enddo + enddo + enddo + + do j=1,pl_coeff + do i=1,im + if (wk1(i) < po3(ko3)) then + prod(i,j) = prdout(i,ko3,j) + endif + if (wk1(i) >= po3(1)) then + prod(i,j) = prdout(i,1,j) + endif + enddo + enddo + do i=1,im + colo3(i,l) = colo3(i,l+1) + ozi(i,l) * delp(i,l)*gravi + coloz(i,l) = coloz(i,l+1) + prod(i,6) * delp(i,l)*gravi + prod(i,2) = min(prod(i,2), 0.0) + enddo + do i=1,im + ozib(i) = ozi(i,l) ! no filling + tem = prod(i,1) - prod(i,2) * prod(i,6) + prod(i,3) * (tin(i,l) - prod(i,5)) & + + prod(i,4) * (colo3(i,l)-coloz(i,l)) + oz(i,l) = (ozib(i) + tem*dt) / (1.0 - prod(i,2)*dt) + enddo + if(idtend(1)>=1) then + dtend(:,l,idtend(1)) = dtend(:,l,idtend(1)) + (prod(:,1)-prod(:,2)*prod(:,6))*dt + endif + if(idtend(2)>=1) then + dtend(:,l,idtend(2)) = dtend(:,l,idtend(2)) + (oz(:,l) - ozib(:)) + endif + if(idtend(3)>=1) then + dtend(:,l,idtend(3)) = dtend(:,l,idtend(3)) + prod(:,3)*(tin(:,l)-prod(:,5))*dt + endif + if(idtend(4)>=1) then + dtend(:,l,idtend(4)) = dtend(:,l,idtend(4)) + prod(:,4) * (colo3(:,l)-coloz(:,l))*dt + endif + enddo + + return + end subroutine ozphys_2015_run +!> @} +end module ozphys_2015 diff --git a/physics/ozphys_2015.f b/physics/ozphys_2015.f deleted file mode 100644 index 85c79f733..000000000 --- a/physics/ozphys_2015.f +++ /dev/null @@ -1,190 +0,0 @@ -!> \file ozphys_2015.f -!! This file is ozone sources and sinks. - - - module ozphys_2015 - - contains - -!>\defgroup GFS_ozphys_2015 GFS Ozone Photochemistry (2015) Module -!! This module contains the CCPP-compliant Ozone 2015 photochemistry scheme. -!> @{ -!> \section arg_table_ozphys_2015_init Argument Table -!! \htmlinclude ozphys_2015_init.html -!! - subroutine ozphys_2015_init(oz_phys_2015, errmsg, errflg) - - implicit none - logical, intent(in) :: oz_phys_2015 - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (.not.oz_phys_2015) then - write (errmsg,'(*(a))') 'Logic error: oz_phys_2015 == .false.' - errflg = 1 - return - endif - - end subroutine ozphys_2015_init - -!> The operational GFS currently parameterizes ozone production and -!! destruction based on monthly mean coefficients ( -!! \c ozprdlos_2015_new_sbuvO3_tclm15_nuchem.f77) provided by Naval -!! Research Laboratory through CHEM2D chemistry model -!! (McCormack et al. (2006) \cite mccormack_et_al_2006). -!! \section arg_table_ozphys_2015_run Argument Table -!! \htmlinclude ozphys_2015_run.html -!! -!> \section genal_ozphys_2015 GFS ozphys_2015_run General Algorithm -!> - This code assumes that both prsl and po3 are from bottom to top -!! as are all other variables. -!> - This code is specifically for NRL parameterization and -!! climatological T and O3 are in location 5 and 6 of prdout array -!!\author June 2015 - Shrinivas Moorthi - subroutine ozphys_2015_run ( & - & im, levs, ko3, dt, oz, tin, po3, prsl, prdout, pl_coeff, & - & delp, ldiag3d, dtend, dtidx, ntoz, index_of_process_prod_loss& - & , index_of_process_ozmix, index_of_process_temp, & - & index_of_process_overhead_ozone, con_g, me, errmsg, errflg) -! -! - use machine , only : kind_phys - implicit none -! - real(kind=kind_phys),intent(in) :: con_g - real :: gravi - integer, intent(in) :: im, levs, ko3, pl_coeff,me - real(kind=kind_phys), intent(in) :: po3(:), & - & prsl(:,:), tin(:,:), & - & delp(:,:), & - & prdout(:,:,:), dt - real(kind=kind_phys), intent(inout) :: dtend(:,:,:) - integer, intent(in) :: dtidx(:,:), ntoz, & - & index_of_process_prod_loss, index_of_process_ozmix, & - & index_of_process_temp, index_of_process_overhead_ozone - real(kind=kind_phys), intent(inout) :: oz(im,levs) - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - integer k,kmax,kmin,l,i,j, idtend(4) - logical ldiag3d, flg(im), qdiag3d - real(kind=kind_phys) pmax, pmin, tem, temp - real(kind=kind_phys) wk1(im), wk2(im), wk3(im),prod(im,pl_coeff), & - & ozib(im), colo3(im,levs+1), coloz(im,levs+1),& - & ozi(im,levs) -! - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if(ldiag3d) then - idtend(1) = dtidx(100+ntoz,index_of_process_prod_loss) ! was ozp1 - idtend(2) = dtidx(100+ntoz,index_of_process_ozmix) ! was ozp2 - idtend(3) = dtidx(100+ntoz,index_of_process_temp) ! was ozp3 - idtend(4) = dtidx(100+ntoz,index_of_process_overhead_ozone) ! was ozp4 - else - idtend=0 - endif - -!ccpp: save input oz in ozi - ozi = oz - gravi=1.0/con_g - - colo3(:,levs+1) = 0.0 - coloz(:,levs+1) = 0.0 -! - do l=levs,1,-1 - pmin = 1.0e10 - pmax = -1.0e10 -! - do i=1,im - wk1(i) = log(prsl(i,l)) - pmin = min(wk1(i), pmin) - pmax = max(wk1(i), pmax) - prod(i,:) = 0.0 - enddo - kmax = 1 - kmin = 1 - do k=1,ko3-1 - if (pmin < po3(k)) kmax = k - if (pmax < po3(k)) kmin = k - enddo -! - do k=kmin,kmax - temp = 1.0 / (po3(k) - po3(k+1)) - do i=1,im - flg(i) = .false. - if (wk1(i) < po3(k) .and. wk1(i) >= po3(k+1)) then - flg(i) = .true. - wk2(i) = (wk1(i) - po3(k+1)) * temp - wk3(i) = 1.0 - wk2(i) - endif - enddo - do j=1,pl_coeff - do i=1,im - if (flg(i)) then - prod(i,j) = wk2(i) * prdout(i,k,j) - & + wk3(i) * prdout(i,k+1,j) - endif - enddo - enddo - enddo -! - do j=1,pl_coeff - do i=1,im - if (wk1(i) < po3(ko3)) then - prod(i,j) = prdout(i,ko3,j) - endif - if (wk1(i) >= po3(1)) then - prod(i,j) = prdout(i,1,j) - endif - enddo - enddo - do i=1,im - colo3(i,l) = colo3(i,l+1) + ozi(i,l) * delp(i,l)*gravi - coloz(i,l) = coloz(i,l+1) + prod(i,6) * delp(i,l)*gravi - prod(i,2) = min(prod(i,2), 0.0) - enddo -! write(1000+me,*) ' colo3=',colo3(1,l),' coloz=',coloz(1,l) -! &,' l=',l - do i=1,im - ozib(i) = ozi(i,l) ! no filling - tem = prod(i,1) - prod(i,2) * prod(i,6) - & + prod(i,3) * (tin(i,l) - prod(i,5)) - & + prod(i,4) * (colo3(i,l)-coloz(i,l)) - -! if (me .eq. 0) print *,'ozphys_2015 tem=',tem,' prod=',prod(i,:) -! &,' ozib=',ozib(i),' l=',l,' tin=',tin(i,l),'colo3=',colo3(i,l+1) - -!ccpp ozo(i,l) = (ozib(i) + tem*dt) / (1.0 - prod(i,2)*dt) - oz(i,l) = (ozib(i) + tem*dt) / (1.0 - prod(i,2)*dt) - enddo - if(idtend(1)>=1) then - dtend(:,l,idtend(1)) = dtend(:,l,idtend(1)) + ! was ozp1 - & (prod(:,1)-prod(:,2)*prod(:,6))*dt - endif - if(idtend(2)>=1) then - dtend(:,l,idtend(2)) = dtend(:,l,idtend(2)) + ! was ozp2 - & (oz(:,l) - ozib(:)) - endif - if(idtend(3)>=1) then - dtend(:,l,idtend(3)) = dtend(:,l,idtend(3)) + ! was ozp3 - & prod(:,3)*(tin(:,l)-prod(:,5))*dt - endif - if(idtend(4)>=1) then - dtend(:,l,idtend(4)) = dtend(:,l,idtend(4)) + ! was ozp4 - & prod(:,4) * (colo3(:,l)-coloz(:,l))*dt - endif - enddo ! vertical loop -! - return - end subroutine ozphys_2015_run - -!> @} - - end module ozphys_2015 diff --git a/physics/ozphys_2015.meta b/physics/ozphys_2015.meta index 8bce7defe..59621b386 100644 --- a/physics/ozphys_2015.meta +++ b/physics/ozphys_2015.meta @@ -7,6 +7,20 @@ [ccpp-arg-table] name = ozphys_2015_init type = scheme +[nPts] + standard_name = horizontal_dimension + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in +[latsozp] + standard_name = number_of_latitudes_in_ozone_data + long_name = number of latitude in ozone data + units = count + dimensions = () + type = integer + intent = in [oz_phys_2015] standard_name = flag_for_nrl_2015_ozone_scheme long_name = flag for new (2015) ozone physics @@ -14,6 +28,176 @@ dimensions = () type = logical intent = in +[oz_lat] + standard_name = ozone_data_latitude + long_name = ozone data latitude + units = deg + dimensions = (number_of_latitudes_in_ozone_data) + type = real + kind = kind_phys + intent = in +[dlat] + standard_name = latitude_in_degree + long_name = latitude in degree north + units = degree_north + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in +[jindx1] + standard_name = lower_latitude_index_of_ozone_forcing_for_interpolation + long_name = interpolation low index for ozone + units = index + dimensions = (horizontal_dimension) + type = integer + intent = out +[jindx2] + standard_name = upper_latitude_index_of_ozone_forcing_for_interpolation + long_name = interpolation high index for ozone + units = index + dimensions = (horizontal_dimension) + type = integer + intent = out +[ddy] + standard_name = latitude_interpolation_weight_for_ozone_forcing + long_name = interpolation high index for ozone + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out + +######################################################################## +[ccpp-arg-table] + name = ozphys_2015_timestep_init + type = scheme +[nPts] + standard_name = horizontal_dimension + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in +[idate] + standard_name = date_and_time_at_model_initialization_in_united_states_order + long_name = initial date with different size and ordering + units = none + dimensions = (4) + type = integer + intent = in +[fhour] + standard_name = forecast_time + long_name = current forecast time + units = h + dimensions = () + type = real + kind = kind_phys + intent = in +[jindx1] + standard_name = lower_latitude_index_of_ozone_forcing_for_interpolation + long_name = interpolation low index for ozone + units = index + dimensions = (horizontal_dimension) + type = integer + intent = in +[jindx2] + standard_name = upper_latitude_index_of_ozone_forcing_for_interpolation + long_name = interpolation high index for ozone + units = index + dimensions = (horizontal_dimension) + type = integer + intent = in +[latsozp] + standard_name = number_of_latitudes_in_ozone_data + long_name = number of latitude in ozone data + units = count + dimensions = () + type = integer + intent = in +[levozp] + standard_name = number_of_levels_in_ozone_data + long_name = number of levels in ozone data + units = count + dimensions = () + type = integer + intent = in +[oz_coeff] + standard_name = number_of_coefficients_in_ozone_data + long_name = number of coefficients in ozone data + units = count + dimensions = () + type = integer + intent = in +[timeoz] + standard_name = number_of_times_in_ozone_data + long_name = number of times in ozone data + units = count + dimensions = () + type = integer + intent = in +[ozplin] + standard_name = ozone_data + long_name = ozone data + units = 1 + dimensions = (number_of_latitudes_in_ozone_data,number_of_levels_in_ozone_data,number_of_coefficients_in_ozone_data,number_of_times_in_ozone_data) + type = real + kind = kind_phys + intent = in +[oz_time] + standard_name = ozone_data_time + long_name = ozone data time + units = none + dimensions = (13) + type = real + kind = kind_phys + intent = in +[oz_pres] + standard_name = ozone_data_level_pressure + long_name = ozone data level pressure + units = Pa + dimensions = (number_of_levels_in_ozone_data) + type = real + kind = kind_phys + intent = in +[oz_lat] + standard_name = ozone_data_latitude + long_name = ozone data latitude + units = deg + dimensions = (number_of_latitudes_in_ozone_data) + type = real + kind = kind_phys + intent = in +[ddy] + standard_name = latitude_interpolation_weight_for_ozone_forcing + long_name = interpolation high index for ozone + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in +[ozplout] + standard_name = ozone_forcing + long_name = ozone forcing data + units = mixed + dimensions = (horizontal_dimension,number_of_levels_in_ozone_data,number_of_coefficients_in_ozone_data) + type = real + kind = kind_phys + intent = out [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -49,7 +233,7 @@ type = integer intent = in [ko3] - standard_name = vertical_dimension_of_ozone_forcing_data + standard_name = number_of_levels_in_ozone_data long_name = number of vertical layers in ozone forcing data units = count dimensions = () @@ -80,10 +264,10 @@ kind = kind_phys intent = in [po3] - standard_name = natural_log_of_ozone_forcing_data_pressure_levels + standard_name = natural_log_of_ozone_data_pressure_levels long_name = natural log of ozone forcing data pressure levels units = 1 - dimensions = (vertical_dimension_of_ozone_forcing_data) + dimensions = (number_of_levels_in_ozone_data) type = real kind = kind_phys intent = in @@ -99,14 +283,14 @@ standard_name = ozone_forcing long_name = ozone forcing data units = mixed - dimensions = (horizontal_loop_extent,vertical_dimension_of_ozone_forcing_data,number_of_coefficients_in_ozone_forcing_data) + dimensions = (horizontal_loop_extent,number_of_levels_in_ozone_data,number_of_coefficients_in_ozone_data) type = real kind = kind_phys intent = in [pl_coeff] - standard_name = number_of_coefficients_in_ozone_forcing_data + standard_name = number_of_coefficients_in_ozone_data long_name = number of coefficients in ozone forcing data - units = index + units = count dimensions = () type = integer intent = in @@ -183,13 +367,6 @@ type = real kind = kind_phys intent = in -[me] - standard_name = mpi_rank - long_name = rank of the current MPI task - units = index - dimensions = () - type = integer - intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/radiation_gases.f b/physics/radiation_gases.f index ccc3b598a..5f017598f 100644 --- a/physics/radiation_gases.f +++ b/physics/radiation_gases.f @@ -142,9 +142,6 @@ module module_radiation_gases use machine, only : kind_phys, kind_io4 use funcphys, only : fpkapx - use ozne_def, only : JMR => latsozc, LOZ => levozc, & - & blte => blatc, dlte=> dphiozc, & - & timeozc => timeozc use module_iounitdef, only : NIO3CLM, NICO2CN ! implicit none @@ -233,7 +230,7 @@ module module_radiation_gases !>\section gas_init_gen gas_init General Algorithm !----------------------------------- subroutine gas_init( me, co2usr_file, co2cyc_file, ico2flg, & - & ictmflg, ioznflg, con_pi, errflg, errmsg) + & ictmflg, ioznflg, con_pi, JMR, LOZ, timeozc, errflg, errmsg) ! =================================================================== ! ! ! @@ -283,8 +280,10 @@ subroutine gas_init( me, co2usr_file, co2cyc_file, ico2flg, & ! --- inputs: integer, intent(in) :: me, ictmflg, ioznflg, ico2flg + integer, intent(in) :: JMR, LOZ, timeozc character(len=26),intent(in) :: co2usr_file,co2cyc_file real(kind=kind_phys), intent(in) :: con_pi + ! --- output: character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -1115,7 +1114,8 @@ end subroutine getgases !! ratio (g/g) !>\section getozn_gen getozn General Algorithm !----------------------------------- - subroutine getozn( prslk,xlat, IMAX, LM, top_at_1, o3mmr) + subroutine getozn( prslk,xlat, IMAX, LM, top_at_1, JMR, LOZ, blte,& + & dlte, o3mmr) ! =================================================================== ! ! ! @@ -1144,7 +1144,8 @@ subroutine getozn( prslk,xlat, IMAX, LM, top_at_1, o3mmr) implicit none ! --- inputs: - integer, intent(in) :: IMAX, LM + integer, intent(in) :: IMAX, LM, JMR, LOZ + real(kind=kind_phys), intent(in) :: blte, dlte logical, intent(in) :: top_at_1 real (kind=kind_phys), intent(in) :: prslk(:,:), xlat(:) From 70b9d7e5ddaf8a4308415ea601a1f8366f62e9d1 Mon Sep 17 00:00:00 2001 From: dustinswales Date: Thu, 25 May 2023 10:27:12 -0600 Subject: [PATCH 270/380] RRTMGP changes for refactored NRL ozone physics. --- physics/GFS_rrtmgp_pre.F90 | 13 +++++++--- physics/GFS_rrtmgp_pre.meta | 30 ++++++++++++++++++++++ physics/GFS_rrtmgp_setup.F90 | 13 +++++----- physics/GFS_rrtmgp_setup.meta | 21 ++++++++++++++++ physics/ozphys_2015.F90 | 47 ++++++++++++++++++----------------- 5 files changed, 91 insertions(+), 33 deletions(-) diff --git a/physics/GFS_rrtmgp_pre.F90 b/physics/GFS_rrtmgp_pre.F90 index 009eb8c38..e9cbc3d23 100644 --- a/physics/GFS_rrtmgp_pre.F90 +++ b/physics/GFS_rrtmgp_pre.F90 @@ -117,7 +117,7 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, doSWrad, doLWrad, fhswr, fhl vmr_n2o, vmr_co2, tsfg, tsfa, qs_lay, q_lay, tv_lay, & relhum, deltaZ, deltaZc, deltaP, active_gases_array, & tsfc_radtime, coszen, coszdg, top_at_1, iSFC, iTOA, nDay, idxday, semis, & - sfc_emiss_byband, ico2, con_pi, errmsg, errflg) + sfc_emiss_byband, ico2, latsozp, levozp, blatc, dphiozc, con_pi, errmsg, errflg) ! Inputs integer, intent(in) :: & @@ -125,13 +125,17 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, doSWrad, doLWrad, fhswr, fhl nCol, & ! Number of horizontal grid points nLev, & ! Number of vertical layers ico2, & ! Flag for co2 radiation scheme - i_o3 ! Index into tracer array for ozone + i_o3, & ! Index into tracer array for ozone + latsozp, & ! + levozp logical, intent(in) :: & doSWrad, & ! Call SW radiation? doLWrad ! Call LW radiation real(kind_phys), intent(in) :: & fhswr, & ! Frequency of SW radiation call. - fhlwr ! Frequency of LW radiation call. + fhlwr, & ! Frequency of LW radiation call. + blatc, & ! + dphiozc real(kind_phys), intent(in) :: & con_g, & ! Physical constant: gravitational constant con_rd, & ! Physical constant: gas-constant for dry air @@ -350,7 +354,8 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, doSWrad, doLWrad, fhswr, fhl enddo ! OR Use climatological ozone data else - call getozn (prslk(1:NCOL,:), xlat, nCol, nLev, top_at_1, o3_lay) + call getozn (prslk(1:NCOL,:), xlat, nCol, nLev, top_at_1, latsozp, levozp, blatc, & + dphiozc, o3_lay) endif ! ####################################################################################### diff --git a/physics/GFS_rrtmgp_pre.meta b/physics/GFS_rrtmgp_pre.meta index abb07b825..47980b513 100644 --- a/physics/GFS_rrtmgp_pre.meta +++ b/physics/GFS_rrtmgp_pre.meta @@ -503,6 +503,36 @@ dimensions = (horizontal_loop_extent) type = integer intent = inout +[latsozp] + standard_name = number_of_latitudes_in_ozone_data + long_name = number of latitude in ozone data + units = count + dimensions = () + type = integer + intent = in +[levozp] + standard_name = number_of_levels_in_ozone_data + long_name = number of levels in ozone data + units = count + dimensions = () + type = integer + intent = in +[dphiozc] + standard_name = ozone_data_parameter_1 + long_name = ozone data parameter 1 + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[blatc] + standard_name = ozone_data_parameter_2 + long_name = ozone data parameter 2 + units = none + dimensions = () + type = real + kind = kind_phys + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/GFS_rrtmgp_setup.F90 b/physics/GFS_rrtmgp_setup.F90 index 76db14279..7b5479e60 100644 --- a/physics/GFS_rrtmgp_setup.F90 +++ b/physics/GFS_rrtmgp_setup.F90 @@ -37,9 +37,10 @@ module GFS_rrtmgp_setup subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires, & imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, imp_physics_zhao_carr, & imp_physics_zhao_carr_pdf, imp_physics_mg, si, levr, ictm, isol, ico2, iaer, & - ntcw, ntoz, iovr, isubc_sw, isubc_lw, lalw1bd, idate, me, aeros_file, & - iaermdl, iaerflg, con_pi, con_t0c, con_c, con_boltz, con_plnk, solar_file, & - con_solr_2008, con_solr_2002, co2usr_file, co2cyc_file, ipsd0, errmsg, errflg) + ntcw, ntoz, iovr, latsozp, levozp, timeozp, isubc_sw, isubc_lw, lalw1bd, idate, & + me, aeros_file, iaermdl, iaerflg, con_pi, con_t0c, con_c, con_boltz, con_plnk, & + solar_file, con_solr_2008, con_solr_2002, co2usr_file, co2cyc_file, ipsd0, & + errmsg, errflg) ! Inputs logical, intent(in) :: do_RRTMGP @@ -57,8 +58,7 @@ subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires, real(kind_phys), dimension(:), intent(in) :: & si integer, intent(in) :: levr, ictm, isol, ico2, iaer, & - ntcw, ntoz, iovr, isubc_sw, isubc_lw, & - me + ntcw, ntoz, iovr, isubc_sw, isubc_lw, latsozp, levozp, timeozp, me logical, intent(in) :: & lalw1bd integer, intent(in), dimension(:) :: & @@ -129,7 +129,8 @@ subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires, call sol_init ( me, isol, solar_file, con_solr_2008, con_solr_2002, con_pi ) call aer_init ( levr, me, iaermdl, iaerflg, lalw1bd, aeros_file, con_pi, con_t0c, & con_c, con_boltz, con_plnk, errflg, errmsg) - call gas_init ( me, co2usr_file, co2cyc_file, ico2, ictm, ntoz, con_pi, errflg, errmsg ) + call gas_init ( me, co2usr_file, co2cyc_file, ico2, ictm, ntoz, con_pi, latsozp, & + levozp, timeozp, errflg, errmsg ) if ( me == 0 ) then print *,' return from rad_initialize (GFS_rrtmgp_setup_init) - after calling radinit' diff --git a/physics/GFS_rrtmgp_setup.meta b/physics/GFS_rrtmgp_setup.meta index c4f7cfaa5..567294d4a 100644 --- a/physics/GFS_rrtmgp_setup.meta +++ b/physics/GFS_rrtmgp_setup.meta @@ -266,6 +266,27 @@ dimensions = () type = integer intent = inout +[levozp] + standard_name = number_of_levels_in_ozone_data + long_name = number of levels in ozone data + units = count + dimensions = () + type = integer + intent = in +[timeozp] + standard_name = number_of_times_in_ozone_data + long_name = number of times in ozone data + units = count + dimensions = () + type = integer + intent = in +[latsozp] + standard_name = number_of_latitudes_in_ozone_data + long_name = number of latitude in ozone data + units = count + dimensions = () + type = integer + intent = in [iaermdl] standard_name = control_for_aerosol_radiation_scheme long_name = control of aerosol scheme in radiation diff --git a/physics/ozphys_2015.F90 b/physics/ozphys_2015.F90 index 17f2178a4..4e73a5262 100644 --- a/physics/ozphys_2015.F90 +++ b/physics/ozphys_2015.F90 @@ -83,7 +83,7 @@ subroutine ozphys_2015_timestep_init(nPts, idate, fhour, jindx1, jindx2, latsozp integer, intent(in) :: & nPts, & ! Horizontal dimension latsozp, & ! Number of latitudes in ozone data - levozp, & ! Number of levels in ozone data + levozp, & ! Number of vertical layers in ozone data oz_coeff, & ! Number of coefficients in ozone data timeoz ! Number of times in ozone data integer, intent(in),dimension(:) :: & @@ -188,6 +188,7 @@ end subroutine ozphys_2015_timestep_init !> - This code is specifically for NRL parameterization and !! climatological T and O3 are in location 5 and 6 of prdout array !!\author June 2015 - Shrinivas Moorthi +!!\author May 2023 - Dustin Swales ! ########################################################################################### subroutine ozphys_2015_run ( im, levs, ko3, dt, oz, tin, po3, prsl, prdout, pl_coeff, & delp, ldiag3d, dtend, dtidx, ntoz, index_of_process_prod_loss, & @@ -196,43 +197,43 @@ subroutine ozphys_2015_run ( im, levs, ko3, dt, oz, tin, po3, prsl, prdout, pl_c ! Inputs logical, intent(in) :: & - ldiag3d + ldiag3d ! Flag to output GFS diagnostic tendencies real(kind_phys),intent(in) :: & - con_g + con_g ! Physical constant: Gravitational acceleration (ms-2) integer, intent(in) :: & - im, & ! - levs, & ! - ko3, & ! - pl_coeff, & ! - ntoz, & ! - index_of_process_prod_loss, & ! - index_of_process_ozmix, & ! - index_of_process_temp, & - index_of_process_overhead_ozone + im, & ! Horizontal dimension + levs, & ! Number of vertical layers + ko3, & ! Number of vertical layers in ozone forcing data + pl_coeff, & ! Number of coefficients in ozone forcing data + ntoz, & ! Index for ozone mixing ratio + index_of_process_prod_loss, & ! Index for process in diagnostic tendency output + index_of_process_ozmix, & ! Index for process in diagnostic tendency output + index_of_process_temp, & ! Index for process in diagnostic tendency output + index_of_process_overhead_ozone ! Index for process in diagnostic tendency output integer, intent(in), dimension(:,:) :: & - dtidx ! + dtidx ! Bookkeeping indices for GFS diagnostic tendencies real(kind_phys), intent(in) :: & - dt ! + dt ! Physics timestep (seconds) real(kind_phys), intent(in), dimension(:) :: & - po3 ! + po3 ! Natural log of ozone forcing data pressure levels real(kind_phys), intent(in), dimension(:,:) :: & - prsl, & ! - tin, & ! - delp ! + prsl, & ! Air-pressure (Pa) + tin, & ! Temperature of new-state (K) + delp ! Difference between mid-layer pressures (Pa) real(kind_phys), intent(in), dimension(:,:,:) :: & - prdout ! + prdout ! Ozone forcing data ! In/Outs real(kind=kind_phys), intent(inout), dimension(:,:,:) :: & - dtend ! + dtend ! Diagnostic tendencies for state variables ! Outputs real(kind=kind_phys), intent(inout), dimension(:,:) :: & - oz ! + oz ! Ozone concentration updated by physics character(len=*), intent(out) :: & - errmsg ! CCPP error message + errmsg ! CCPP error message integer, intent(out) :: & - errflg ! CCPP error flag + errflg ! CCPP error flag ! Locals integer :: k, kmax, kmin, l, i, j From 6ff8689d3e1ed9ccaec7c09db6d8b12f633e59c1 Mon Sep 17 00:00:00 2001 From: dustinswales Date: Thu, 25 May 2023 11:34:29 -0600 Subject: [PATCH 271/380] Revert change to CI test from NCAR->UWM merge --- .github/workflows/ci_fv3_ccpp_prebuild.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci_fv3_ccpp_prebuild.yml b/.github/workflows/ci_fv3_ccpp_prebuild.yml index b23c9977e..a5c2f8092 100644 --- a/.github/workflows/ci_fv3_ccpp_prebuild.yml +++ b/.github/workflows/ci_fv3_ccpp_prebuild.yml @@ -24,7 +24,7 @@ jobs: run: echo "GIT_REMOTE_HASH=`git rev-parse HEAD`" >> $GITHUB_ENV - name: Checkout latest fv3atm - run: git clone https://github.com/NCAR/fv3atm.git + run: git clone https://github.com/NOAA-EMC/fv3atm.git - name: Initialize submodules run: | From 668e15a5ce9b9730e11846a023012b3b58bb757d Mon Sep 17 00:00:00 2001 From: Dan Kokron Date: Fri, 26 May 2023 13:52:12 +0000 Subject: [PATCH 272/380] Increase optimization for ugwp_driver_v0.F --- CMakeLists.txt | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/CMakeLists.txt b/CMakeLists.txt index 950bd048e..c109093a3 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -166,6 +166,12 @@ if(${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/kernels/mo_gas_optics_k APPEND_STRING PROPERTY COMPILE_FLAGS " ${CMAKE_Fortran_FLAGS_PHYSICS} -O1") endif() +# Increase optimization for ugwp_driver_v0.F +if(CMAKE_BUILD_TYPE STREQUAL "Release" AND ${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") + SET_SOURCE_FILES_PROPERTIES(${LOCAL_CURRENT_SOURCE_DIR}/physics/ugwp_driver_v0.F + APPEND_STRING PROPERTY COMPILE_FLAGS " ${CMAKE_Fortran_FLAGS_PHYSICS} -fp-model=fast -fprotect-parens -fimf-precision=high") +endif() + #------------------------------------------------------------------------------ add_library(ccpp_physics STATIC ${SCHEMES} ${SCHEMES_OPENMP_OFF} ${SCHEMES_DYNAMICS} ${CAPS}) From 5ffa961ae46c8901658ff76790c24fc3de10f238 Mon Sep 17 00:00:00 2001 From: joeolson42 Date: Fri, 26 May 2023 16:34:20 +0000 Subject: [PATCH 273/380] remove benign bug from smoke/dust mixing when nchem /= ndvel --- physics/module_bl_mynn.F90 | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index dcfdc1011..ec6b5700d 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -1003,9 +1003,8 @@ SUBROUTINE mynn_bl_driver( & if ( mix_chem ) then do ic = 1,ndvel vd1(ic) = vdep(i,ic) ! dry deposition velocity - chem1(kts,ic) = chem3d(i,kts,ic) enddo - do k = kts+1,kte + do k = kts,kte do ic = 1,nchem chem1(k,ic) = chem3d(i,k,ic) enddo @@ -1013,9 +1012,8 @@ SUBROUTINE mynn_bl_driver( & else do ic = 1,ndvel vd1(ic) = 0. ! dry deposition velocity - chem1(kts,ic) = 0. enddo - do k = kts+1,kte + do k = kts,kte do ic = 1,nchem chem1(k,ic) = 0. enddo From 3a1c48dfaf227ffd061cf5ccc81a7cccef1bb9d6 Mon Sep 17 00:00:00 2001 From: joeolson42 Date: Fri, 26 May 2023 18:01:46 +0000 Subject: [PATCH 274/380] changes to the irrigation algorithm in RUC to use real-time vegetation fraction instead of LAI to define the growing phase of the crops --- physics/module_sf_ruclsm.F90 | 96 +++++++++++++++--------------------- 1 file changed, 41 insertions(+), 55 deletions(-) diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 850e3ee5e..6294bc068 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -415,7 +415,7 @@ SUBROUTINE LSMRUC(xlat,xlon, & curat, & INFILTRP real (kind_phys) :: cq,r61,r273,arp,brp,x,evs,eis - real (kind_phys) :: cropsm + real (kind_phys) :: cropfr, cropsm, newsm, factor real (kind_phys) :: meltfactor, ac,as, wb,rovcp INTEGER :: NROOT @@ -445,8 +445,8 @@ SUBROUTINE LSMRUC(xlat,xlon, & NDDZS=2*(nzs-2) !-- - testptlat = 48.7074_kind_phys !39.958 !42.05 !39.0 !74.12 !29.5 - testptlon = 289.03_kind_phys !271.622 !286.75 !280.6 !164.0 !283.0 + testptlat = 35.55 !48.7074_kind_phys !39.958 !42.05 !39.0 !74.12 !29.5 + testptlon = 278.66 !289.03_kind_phys !271.622 !286.75 !280.6 !164.0 !283.0 !-- @@ -983,63 +983,49 @@ SUBROUTINE LSMRUC(xlat,xlon, & ! Fraction of cropland category in the grid box should not have soil moisture below ! wilting point during the growing season. -! Let's keep soil moisture 20% above wilting point for the fraction of grid box under -! croplands. +! Let's keep soil moisture 5% above wilting point for the crop fraction of grid box. ! This change violates LSM moisture budget, but ! can be considered as a compensation for irrigation not included into LSM. -!tgs - "irrigation" uses fractional landuse, therefore mosaic_lu=1. +! "Irigation" could be applied when landuse fractional information +! is available and mosaic_lu=1. if(mosaic_lu == 1) then - IF (lufrac(crop) > zero .and. lai(i,j) > 1.1_kind_phys) THEN - ! cropland - do k=1,nroot - cropsm=1.1_kind_phys*wilt - qmin - if(soilm1d(k) < cropsm*lufrac(crop)) then - IF (debug_print ) THEN - if (abs(xlat-testptlat).lt.0.2 .and. & - abs(xlon-testptlon).lt.0.2)then -print * ,'Soil moisture is below wilting in cropland category at time step',ktau - print*,' lat,lon=',xlat,xlon & - ,'lufrac(crop),k,soilm1d(k),wilt,cropsm', & - lufrac(crop),k,soilm1d(k),wilt,cropsm - endif - ENDIF - soilm1d(k) = cropsm*lufrac(crop) - IF (debug_print ) THEN - if (abs(xlat-testptlat).lt.0.2 .and. & - abs(xlon-testptlon).lt.0.2)then - print*,' lat,lon=',xlat,xlon - print * ,'Added soil water to cropland category, i,j,k,soilm1d(k)',i,j,k,soilm1d(k) - endif - ENDIF - endif - enddo + ! greenness factor: between 0 for min greenness and 1 for max greenness. + factor = max(zero,min(one,(vegfra(i,j)-shdmin(i,j))/max(one,(shdmax(i,j)-shdmin(i,j))))) + if (abs(xlat-testptlat).lt.0.1 .and. & + abs(xlon-testptlon).lt.0.1)then + print *,' lat,lon=',xlat,xlon,' factor=',factor + endif - ELSEIF (ivgtyp(i,j) == natural .and. lai(i,j) > 0.7) THEN - ! grassland: assume that 40% of grassland is irrigated cropland - do k=1,nroot - cropsm=1.2_kind_phys*wilt - qmin - if(soilm1d(k) < cropsm*lufrac(natural)*0.4) then - IF (debug_print ) THEN - if (abs(xlat-testptlat).lt.0.2 .and. & - abs(xlon-testptlon).lt.0.2)then -print * ,'Soil moisture is below wilting in mixed grassland/cropland category at time step',ktau - print*,' lat,lon=',xlat,xlon, & - 'lufrac(natural),k,soilm1d(k),wilt', & - lufrac(natural),k,soilm1d(k),wilt - endif - ENDIF - soilm1d(k) = cropsm * lufrac(natural)*0.4_kind_phys + if((ivgtyp(i,j) == natural .or. ivgtyp(i,j) == crop) .and. factor > 0.75) then + ! cropland or grassland, apply irrigation during the growing seaspon when fraction + ! of greenness is > 0.75. - IF (debug_print ) THEN - if (abs(xlat-testptlat).lt.0.2 .and. & - abs(xlon-testptlon).lt.0.2)then - print*,' lat,lon=',xlat,xlon - print * ,'Added soil water to grassland category, i,j,k,soilm1d(k)',i,j,k,soilm1d(k) - endif - ENDIF - endif + do k=1,nroot + cropsm=1.05_kind_phys*wilt - qmin + cropfr = min(one,lufrac(crop) + 0.4*lufrac(natural)) ! assume that 40% of natural is cropland + newsm = cropsm*cropfr + (1.-cropfr)*soilm1d(k) + if(soilm1d(k) < newsm) then + IF (debug_print ) THEN + if (abs(xlat-testptlat).lt.0.1 .and. & + abs(xlon-testptlon).lt.0.1)then + print * ,'Soil moisture is below wilting in cropland areas at time step',ktau + print * ,' lat,lon=',xlat,xlon + print * ,' lufrac=',lufrac,'factor=',factor & + ,'lai,ivgtyp,lufrac(crop),k,soilm1d(k),cropfr,wilt,cropsm,newsm,', & + lai(i,j),ivgtyp(i,j),lufrac(crop),k,soilm1d(k),cropfr,wilt,cropsm,newsm + endif + ENDIF + soilm1d(k) = newsm + IF (debug_print ) THEN + if (abs(xlat-testptlat).lt.0.1 .and. & + abs(xlon-testptlon).lt.0.1)then + print*,' lat,lon=',xlat,xlon + print * ,'Added soil water to cropland areas, k,soilm1d(k)',k,soilm1d(k) + endif + ENDIF + endif ! < cropsm enddo - ENDIF + endif ! crop endif ! mosaic_lu !*** DIAGNOSTICS @@ -6599,7 +6585,7 @@ SUBROUTINE TRANSF( debug_print, & TRANF(1)=(TOTLIQ-WILT)/(REF-WILT)*DID ENDIF !-- uncomment next line for non-linear root distribution -! TRANF(1)=part(1) + TRANF(1)=part(1) DO K=2,NROOT totliq=soiliqw(k)+qmin From 5eeb02e96c6e1853565d5e320a56c018cd2624b7 Mon Sep 17 00:00:00 2001 From: "Haiqin.Li" Date: Tue, 30 May 2023 18:00:16 +0000 Subject: [PATCH 275/380] "update to address the comments from UFS code managers" --- physics/GFS_rrtmg_pre.F90 | 6 +++--- physics/GFS_rrtmg_pre.meta | 7 +++++++ physics/cu_c3_deep.F90 | 26 ++++++++++---------------- physics/cu_c3_driver.F90 | 3 +-- physics/cu_gf_deep.F90 | 19 ++++++------------- physics/cu_gf_driver.F90 | 3 +-- 6 files changed, 28 insertions(+), 36 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 2eb154814..4f4de181a 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -44,7 +44,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& gasvmr_o2, gasvmr_co, gasvmr_cfc11, gasvmr_cfc12, gasvmr_cfc22, & gasvmr_ccl4, gasvmr_cfc113, aerodp,ext550, clouds6, clouds7, clouds8, & clouds9, cldsa, cldfra, cldfra2d, lwp_ex,iwp_ex, lwp_fc,iwp_fc, & - faersw1, faersw2, faersw3, faerlw1, faerlw2, faerlw3, alpha, & + faersw1, faersw2, faersw3, faerlw1, faerlw2, faerlw3, alpha, rrfs_sd, & aero_dir_fdb, fdb_coef, spp_wts_rad, spp_rad, ico2, errmsg, errflg) use machine, only: kind_phys @@ -126,7 +126,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& uni_cld, effr_in, do_mynnedmf, & lmfshal, lmfdeep2, pert_clds, lcrick,& lcnorm, top_at_1, lextop, mraerosol - logical, intent(in) :: aero_dir_fdb + logical, intent(in) :: rrfs_sd, aero_dir_fdb logical, intent(in) :: nssl_ccn_on, nssl_invertccn integer, intent(in) :: spp_rad @@ -640,7 +640,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& endif !>--- add smoke and dust --- - if (aero_dir_fdb) then + if (rrfs_sd .and. aero_dir_fdb) then do k=1,lmk do i=1,im aer_nm(i,k,1 )=aer_nm(i,k,1 )+ qgrs(i,k,ntdust)*fdb_coef(1)*1.e-9 ! dust bin1 diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 908394562..a8aecdbe0 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -1466,6 +1466,13 @@ dimensions = () type = integer intent = in +[rrfs_sd] + standard_name = do_smoke_coupling + long_name = flag controlling rrfs_sd collection (default off) + units = flag + dimensions = () + type = logical + intent = in [aero_dir_fdb] standard_name = do_smoke_aerosol_direct_feedback long_name = flag for smoke and dust radiation feedback diff --git a/physics/cu_c3_deep.F90 b/physics/cu_c3_deep.F90 index 4ae1989f9..c3a4b2c4e 100644 --- a/physics/cu_c3_deep.F90 +++ b/physics/cu_c3_deep.F90 @@ -24,7 +24,7 @@ module cu_c3_deep integer, parameter:: use_excess=0 real(kind=kind_phys), parameter :: fluxtune=1.5 !> flag to turn off or modify mom transport by downdrafts - real(kind=kind_phys), parameter :: pgcd = 1. + real(kind=kind_phys), parameter :: pgcd = 0.1 ! !> aerosol awareness, do not use yet! integer, parameter :: autoconv=1 !2 @@ -51,11 +51,11 @@ module cu_c3_deep !>\ingroup cu_c3_group !! This is C3 deep convection scheme module !> @{ - integer function my_maxloc1d(A,N,dir) + integer function my_maxloc1d(A,N) !$acc routine vector implicit none real(kind_phys), intent(in) :: A(:) - integer, intent(in) :: N,dir + integer, intent(in) :: N real(kind_phys) :: imaxval integer :: i @@ -589,8 +589,9 @@ subroutine cu_c3_deep_run( & entr_rate(i)=.2/radius endif sig(i)=(1.-frh)**2 - frh_out(i) = frh - if((dx(i)\ingroup cu_gf_group !! This is Grell-Freitas deep convection scheme module !> @{ - integer function my_maxloc1d(A,N,dir) + integer function my_maxloc1d(A,N) !$acc routine vector implicit none real(kind_phys), intent(in) :: A(:) - integer, intent(in) :: N,dir + integer, intent(in) :: N real(kind_phys) :: imaxval integer :: i @@ -1949,9 +1949,6 @@ subroutine cu_gf_deep_run( & imid,ipr,itf,ktf, & its,ite, kts,kte, & dicycle,tau_ecmwf,aa1_bl,xf_dicycle) - !do i=its,itf - !if((dx(i) Date: Wed, 31 May 2023 16:22:05 -0500 Subject: [PATCH 276/380] Add new namelist parameters to documentation for NSSL microphysics; minor naming tweak for these parameters in the code. --- physics/docs/pdftxt/suite_input.nml.txt | 3 +++ physics/module_mp_nssl_2mom.F90 | 2 +- physics/mp_nssl.F90 | 8 ++++---- physics/mp_nssl.meta | 4 ++-- 4 files changed, 10 insertions(+), 7 deletions(-) diff --git a/physics/docs/pdftxt/suite_input.nml.txt b/physics/docs/pdftxt/suite_input.nml.txt index f37383f24..093e38797 100644 --- a/physics/docs/pdftxt/suite_input.nml.txt +++ b/physics/docs/pdftxt/suite_input.nml.txt @@ -394,11 +394,14 @@ show some variables in the namelist that must match the SDF. cnvcld see \a GFS_typedefs.F90 flag for convective cloud .false. lgfdlmprad gfs_rrtmg_pre flag for GFDL mp scheme and radiation consistency .false. nssl_cccn mp_nssl CCN concentration (m^-3) 0.6e9 +nssl_alphar mp_nssl rain shape parameter 0.0 nssl_alphah mp_nssl graupel shape parameter 0.0 nssl_alphahl mp_nssl hail shape parameter 1.0 nssl_hail_on mp_nssl NSSL flag to activate the hail category .false. nssl_ccn_on mp_nssl NSSL flag to activate the CCN category .true. nssl_invertccn mp_nssl NSSL flag to treat CCN as activated or unactivated .true. +nssl_ehw0 mp_nssl NSSL graupel-droplet collection efficiency 0.9 +nssl_ehlw0 mp_nssl NSSL hail-droplet collection efficiency 0.9 \b Parameters \b related \b to \b gravity \b drag \b scheme \b options knob_ugwp_version cires_ugwp parameter selects a version of the UGWP implementation in FV3GFS-127L \n
    diff --git a/physics/module_mp_nssl_2mom.F90 b/physics/module_mp_nssl_2mom.F90 index d190e94b4..409bf4019 100644 --- a/physics/module_mp_nssl_2mom.F90 +++ b/physics/module_mp_nssl_2mom.F90 @@ -1228,7 +1228,7 @@ SUBROUTINE nssl_2mom_init( & rho_qh = nssl_params(8) rho_qhl = nssl_params(9) rho_qs = nssl_params(10) - alphar = nssl_params(14) + alphar = nssl_params(15) ! ipelec = Nint(nssl_params(11)) ! isaund = Nint(nssl_params(12)) diff --git a/physics/mp_nssl.F90 b/physics/mp_nssl.F90 index 4e0e323ce..59ca877fa 100644 --- a/physics/mp_nssl.F90 +++ b/physics/mp_nssl.F90 @@ -31,7 +31,7 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & con_t0c, con_cliq, con_csol, con_eps, & imp_physics, imp_physics_nssl, & nssl_cccn, nssl_alphah, nssl_alphahl, & - nssl_alphar, nssl_ehw0_in, nssl_ehlw0_in, & + nssl_alphar, nssl_ehw0, nssl_ehlw0, & nssl_ccn_on, nssl_hail_on, nssl_invertccn ) @@ -53,7 +53,7 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & integer, intent(in) :: imp_physics integer, intent(in) :: imp_physics_nssl real(kind_phys), intent(in) :: nssl_cccn, nssl_alphah, nssl_alphahl - real(kind_phys), intent(in) :: nssl_alphar, nssl_ehw0_in, nssl_ehlw0_in + real(kind_phys), intent(in) :: nssl_alphar, nssl_ehw0, nssl_ehlw0 logical, intent(in) :: nssl_ccn_on, nssl_hail_on, nssl_invertccn ! Local variables: dimensions used in nssl_init @@ -117,7 +117,7 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & nssl_params(11) = 0 ! nssl_ipelec_tmp nssl_params(12) = 11 ! nssl_isaund nssl_params(13) = 0 ! 1= turn on cccna; 0 = turn off - nssl_params(14) = nssl_alphar + nssl_params(15) = nssl_alphar nssl_qccn = nssl_cccn/1.225 ! if (mpirank==mpiroot) then @@ -132,7 +132,7 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & ! write(0,*) 'call nssl_2mom_init' CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0, & - ihvol=ihailv,nssl_ehw0=nssl_ehw0_in,nssl_ehlw0=nssl_ehlw0_in,errmsg=errmsg,errflg=errflg,myrank=mpirank,mpiroot=mpiroot) + ihvol=ihailv,nssl_ehw0=nssl_ehw0,nssl_ehlw0=nssl_ehlw0,errmsg=errmsg,errflg=errflg,myrank=mpirank,mpiroot=mpiroot) ! For restart runs, the init is done here if (restart) then diff --git a/physics/mp_nssl.meta b/physics/mp_nssl.meta index c7e398f0a..6bbf92c73 100644 --- a/physics/mp_nssl.meta +++ b/physics/mp_nssl.meta @@ -173,7 +173,7 @@ type = real kind = kind_phys intent = in -[nssl_ehw0_in] +[nssl_ehw0] standard_name = nssl_graupel_collection_efficiency long_name = graupel droplet collection efficiency in NSSL microphysics scheme units = none @@ -181,7 +181,7 @@ type = real kind = kind_phys intent = in -[nssl_ehlw0_in] +[nssl_ehlw0] standard_name = nssl_hail_collection_efficiency long_name = hail droplet collection efficiency in NSSL microphysics scheme units = none From ec589d1467fe1b34a846f09f5b5cb596998a3603 Mon Sep 17 00:00:00 2001 From: Michael Barlage Date: Fri, 2 Jun 2023 14:32:29 +0000 Subject: [PATCH 277/380] multiply canopy heat by fveg to conform to solution assumption --- physics/module_sf_noahmplsm.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/module_sf_noahmplsm.F90 b/physics/module_sf_noahmplsm.F90 index 1888a26e8..7813130b6 100644 --- a/physics/module_sf_noahmplsm.F90 +++ b/physics/module_sf_noahmplsm.F90 @@ -4246,7 +4246,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & end if ! canopy heat capacity - hcv = parameters%cbiom*vaie*cwat + canliq*cwat/denh2o + canice*cice/denice !j/m2/k + hcv = fveg*(parameters%cbiom*vaie*cwat + canliq*cwat/denh2o + canice*cice/denice) !j/m2/k b = sav-irc-shc-evc-tr+pahv !additional w/m2 ! a = fveg*(4.*cir*tv**3 + csh + (cev+ctr)*destv) !volumetric heat capacity From 53c8b9c73328877087dcb0bf66047e364a05dcb5 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Fri, 2 Jun 2023 10:08:46 -0500 Subject: [PATCH 278/380] Clarify that 'shape parameter' is 'PSD shape parameter' --- physics/docs/pdftxt/suite_input.nml.txt | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/docs/pdftxt/suite_input.nml.txt b/physics/docs/pdftxt/suite_input.nml.txt index 093e38797..be3785b74 100644 --- a/physics/docs/pdftxt/suite_input.nml.txt +++ b/physics/docs/pdftxt/suite_input.nml.txt @@ -394,9 +394,9 @@ show some variables in the namelist that must match the SDF. cnvcld see \a GFS_typedefs.F90 flag for convective cloud .false. lgfdlmprad gfs_rrtmg_pre flag for GFDL mp scheme and radiation consistency .false. nssl_cccn mp_nssl CCN concentration (m^-3) 0.6e9 -nssl_alphar mp_nssl rain shape parameter 0.0 -nssl_alphah mp_nssl graupel shape parameter 0.0 -nssl_alphahl mp_nssl hail shape parameter 1.0 +nssl_alphar mp_nssl rain PSD shape parameter 0.0 +nssl_alphah mp_nssl graupel PSD shape parameter 0.0 +nssl_alphahl mp_nssl hail PSD shape parameter 1.0 nssl_hail_on mp_nssl NSSL flag to activate the hail category .false. nssl_ccn_on mp_nssl NSSL flag to activate the CCN category .true. nssl_invertccn mp_nssl NSSL flag to treat CCN as activated or unactivated .true. From 5e7c2837c66c0ea3863bff8cf733c5a3fb52c0d4 Mon Sep 17 00:00:00 2001 From: Helin Wei Date: Mon, 5 Jun 2023 11:11:31 -0400 Subject: [PATCH 279/380] update .github/workflows/ci_fv3_ccpp_prebuild.yml --- .github/workflows/ci_fv3_ccpp_prebuild.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/ci_fv3_ccpp_prebuild.yml b/.github/workflows/ci_fv3_ccpp_prebuild.yml index b23c9977e..b042db2a6 100644 --- a/.github/workflows/ci_fv3_ccpp_prebuild.yml +++ b/.github/workflows/ci_fv3_ccpp_prebuild.yml @@ -24,7 +24,7 @@ jobs: run: echo "GIT_REMOTE_HASH=`git rev-parse HEAD`" >> $GITHUB_ENV - name: Checkout latest fv3atm - run: git clone https://github.com/NCAR/fv3atm.git + run: git clone https://github.com/NOAA-EMC/fv3atm.git - name: Initialize submodules run: | @@ -53,4 +53,4 @@ jobs: run: | cd /home/runner/work/ccpp-physics/ccpp-physics/fv3atm/ccpp/ mkdir -p /home/runner/work/ccpp-physics/ccpp-physics/fv3atm/bin/ccpp/physics/physics/ - ./framework/scripts/ccpp_prebuild.py --config config/ccpp_prebuild_config.py \ No newline at end of file + ./framework/scripts/ccpp_prebuild.py --config config/ccpp_prebuild_config.py From 363c82cf4a4759387909dafec6a14d0fff622e1c Mon Sep 17 00:00:00 2001 From: Helin Wei Date: Mon, 5 Jun 2023 14:59:05 -0400 Subject: [PATCH 280/380] addressing comments from reviewers --- .github/workflows/ci_fv3_ccpp_prebuild.yml | 2 +- physics/GFS_phys_time_vary.fv3.F90 | 1 - physics/module_sf_noahmp_glacier.F90 | 5 +- physics/module_sf_noahmplsm.F90 | 35 +- physics/noahmp_tables.f90 | 537 +++++++++++---------- physics/noahmpdrv.F90 | 2 +- physics/sfcsub.F | 2 +- 7 files changed, 306 insertions(+), 278 deletions(-) diff --git a/.github/workflows/ci_fv3_ccpp_prebuild.yml b/.github/workflows/ci_fv3_ccpp_prebuild.yml index b042db2a6..a5c2f8092 100644 --- a/.github/workflows/ci_fv3_ccpp_prebuild.yml +++ b/.github/workflows/ci_fv3_ccpp_prebuild.yml @@ -53,4 +53,4 @@ jobs: run: | cd /home/runner/work/ccpp-physics/ccpp-physics/fv3atm/ccpp/ mkdir -p /home/runner/work/ccpp-physics/ccpp-physics/fv3atm/bin/ccpp/physics/physics/ - ./framework/scripts/ccpp_prebuild.py --config config/ccpp_prebuild_config.py + ./framework/scripts/ccpp_prebuild.py --config config/ccpp_prebuild_config.py \ No newline at end of file diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index 641f399df..67fec5ca1 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -164,7 +164,6 @@ subroutine GFS_phys_time_vary_init ( real(kind_phys), intent(inout) :: tsnoxy (:,lsnow_lsm_lbound:) real(kind_phys), intent(inout) :: smoiseq(:,:) real(kind_phys), intent(inout) :: zsnsoxy(:,lsnow_lsm_lbound:) - real(kind_phys), intent(inout) :: slc(:,:) real(kind_phys), intent(inout) :: smc(:,:) real(kind_phys), intent(inout) :: stc(:,:) diff --git a/physics/module_sf_noahmp_glacier.F90 b/physics/module_sf_noahmp_glacier.F90 index 492c4a50d..7822ead30 100644 --- a/physics/module_sf_noahmp_glacier.F90 +++ b/physics/module_sf_noahmp_glacier.F90 @@ -2603,6 +2603,7 @@ subroutine snowwater_glacier (nsnow ,nsoil ,imelt ,dt ,sfctmp , & !in ! local integer :: iz real (kind=kind_phys) :: bdsnow !< bulk density of snow (kg/m3) + real (kind=kind_phys),parameter :: mwd = 100. !< maximum water depth (mm) ! ---------------------------------------------------------------------- snoflow = 0.0 ponding1 = 0.0 @@ -2646,9 +2647,9 @@ subroutine snowwater_glacier (nsnow ,nsoil ,imelt ,dt ,sfctmp , & !in !to obtain equilibrium state of snow in glacier region - if(sneqv > 100.) then ! 100 mm -> maximum water depth + if(sneqv > mwd) then ! 100 mm -> maximum water depth bdsnow = snice(0) / dzsnso(0) - snoflow = (sneqv - 100.) + snoflow = (sneqv - mwd) snice(0) = snice(0) - snoflow dzsnso(0) = dzsnso(0) - snoflow/bdsnow snoflow = snoflow / dt diff --git a/physics/module_sf_noahmplsm.F90 b/physics/module_sf_noahmplsm.F90 index 7813130b6..ff49a41cd 100644 --- a/physics/module_sf_noahmplsm.F90 +++ b/physics/module_sf_noahmplsm.F90 @@ -5529,7 +5529,6 @@ subroutine gfs_stability & ! UTN (Unstable Tech Note) : NCEP Office Note 356 ! STN (Stable Tech Note) : NCEP Office Note 321 -integer, parameter :: kp = kind_phys real (kind=kind_phys), parameter :: ca=0.4_kind_phys ! ca - von karman constant real(kind=kind_phys), intent(in) :: z1 ! height model level @@ -5626,14 +5625,14 @@ subroutine gfs_stability & ! compute stability indices (rb and hlinf) dtv = thv1 - tvs - adtv = max(abs(dtv),0.001_kp) - dtv = sign(1.0_kp,dtv) * adtv + adtv = max(abs(dtv),0.001_kind_phys) + dtv = sign(1.0_kind_phys,dtv) * adtv if(thsfc_loc) then ! Use local potential temperature - rb = max(-5000.0_kp, (grav+grav) * dtv * z1 & + rb = max(-5000.0_kind_phys, (grav+grav) * dtv * z1 & / ((thv1 + tvs) * wind * wind)) else ! Use potential temperature referenced to 1000 hPa - rb = max(-5000.0_kp, grav * dtv * z1 & + rb = max(-5000.0_kind_phys, grav * dtv * z1 & / (tv1 * wind * wind)) endif @@ -5641,8 +5640,8 @@ subroutine gfs_stability & tem2 = one / ztmax ! 1/z0t fm = log((z0max+z1) * tem1) ! neutral phi_m fh = log((ztmax+z1) * tem2) ! neutral phi_h - fm10 = log((z0max+10.0_kp) * tem1) ! neutral phi_m at 10 meters - fh2 = log((ztmax+2.0_kp) * tem2) ! neutral phi_h at 2 meters + fm10 = log((z0max+10.0_kind_phys) * tem1) ! neutral phi_m at 10 meters + fh2 = log((ztmax+2.0_kind_phys) * tem2) ! neutral phi_h at 2 meters hlinf = rb * fm * fm / fh ! z/L STN 2.7 hlinf = min(max(hlinf,zolmin),zolmax) ! z/L, xi in STN/UTN ! @@ -5650,7 +5649,7 @@ subroutine gfs_stability & ! if (dtv >= zero) then hl1 = hlinf ! z/L, xi in STN - if(hlinf > 0.25_kp) then ! z/L > 0.25, do two iterations + if(hlinf > 0.25_kind_phys) then ! z/L > 0.25, do two iterations tem1 = hlinf * z1i ! 1/L hl0inf = z0max * tem1 ! z0m/z1, zi_0 in STN hltinf = ztmax * tem1 ! z0t/z1, zi_0 in STN @@ -5677,7 +5676,7 @@ subroutine gfs_stability & bb0 = sqrt(one + alpha4 * hlt) ! sqrt term of STN 2.16 with z0t pm = aa0 - aa + log( (one+aa)/(one+aa0) ) ! psi_m STN 3.11 ph = bb0 - bb + log( (one+bb)/(one+bb0) ) ! psi_h STN 3.11 - hl110 = hl1 * 10.0_kp * z1i ! 10/L + hl110 = hl1 * 10.0_kind_phys * z1i ! 10/L aa = sqrt(one + alpha4 * hl110) ! sqrt term of STN 2.16 with z=10m pm10 = aa0 - aa + log( (one+aa)/(one+aa0) ) ! psi_m STN 3.11 with z=10m hl12 = (hl1+hl1) * z1i ! 2/L @@ -5691,7 +5690,7 @@ subroutine gfs_stability & else ! dtv < 0 case olinf = z1 / hlinf ! z/L, xi in UTN - tem1 = 50.0_kp * z0max ! 50 * z0m, z/L limit for calc methods, see UTN Sec. E + tem1 = 50.0_kind_phys * z0max ! 50 * z0m, z/L limit for calc methods, see UTN Sec. E if(abs(olinf) <= tem1) then ! hlinf = -z1 / tem1 ! hlinf = max(hlinf, zolmin) @@ -5699,23 +5698,23 @@ subroutine gfs_stability & ! ! get pm and ph ! - if (hlinf >= -0.5_kp) then + if (hlinf >= -0.5_kind_phys) then hl1 = hlinf pm = (a0 + a1*hl1) * hl1 / (one+ (b1+b2*hl1) *hl1) ! psi_m UTN 2.37 ph = (a0p + a1p*hl1) * hl1 / (one+ (b1p+b2p*hl1)*hl1) ! psi_h UTN 2.38 - hl110 = hl1 * 10.0_kp * z1i ! 10/L + hl110 = hl1 * 10.0_kind_phys * z1i ! 10/L pm10 = (a0 + a1*hl110) * hl110/(one+(b1+b2*hl110)*hl110) ! psi_m UTN 2.37 with z=10m hl12 = (hl1+hl1) * z1i ! 2/L ph2 = (a0p + a1p*hl12) * hl12/(one+(b1p+b2p*hl12)*hl12) ! psi_h UTN 2.38 with z=2m else ! z/L < -0.5 hl1 = -hlinf ! -z/L tem1 = one / sqrt(hl1) ! sqrt(-z/L) - pm = log(hl1) + 2.0_kp * sqrt(tem1) - 0.8776_kp ! UTN 2.64, first three terms - ph = log(hl1) + 0.5_kp * tem1 + 1.386_kp ! UTN 2.65, first three terms - hl110 = hl1 * 10.0_kp * z1i ! 10/L - pm10 = log(hl110) + 2.0_kp/sqrt(sqrt(hl110)) - 0.8776_kp ! psi_m UTN 2.64 with z=10m + pm = log(hl1) + 2.0_kind_phys * sqrt(tem1) - 0.8776_kind_phys ! UTN 2.64, first three terms + ph = log(hl1) + 0.5_kind_phys * tem1 + 1.386_kind_phys ! UTN 2.65, first three terms + hl110 = hl1 * 10.0_kind_phys * z1i ! 10/L + pm10 = log(hl110) + 2.0_kind_phys/sqrt(sqrt(hl110)) - 0.8776_kind_phys ! psi_m UTN 2.64 with z=10m hl12 = (hl1+hl1) * z1i ! 2/L - ph2 = log(hl12) + 0.5_kp / sqrt(hl12) + 1.386_kp ! psi_h UTN 2.65 with z=2m + ph2 = log(hl12) + 0.5_kind_phys / sqrt(hl12) + 1.386_kind_phys ! psi_h UTN 2.65 with z=2m endif endif ! end of if (dtv >= 0 ) then loop @@ -5728,7 +5727,7 @@ subroutine gfs_stability & fh2 = fh2 - ph2 ! phi_h at 2m cm = ca * ca / (fm * fm) ! momentum exchange coef = k^2/phi_m^2 ch = ca * ca / (fm * fh) ! heat exchange coef = k^2/phi_m/phi_h - tem1 = 0.00001_kp/z1 ! minimum exhange coef (?) + tem1 = 0.00001_kind_phys/z1 ! minimum exhange coef (?) cm = max(cm, tem1) ch = max(ch, tem1) stress = cm * wind * wind ! surface stress = Cm*U*U diff --git a/physics/noahmp_tables.f90 b/physics/noahmp_tables.f90 index de207d0cc..3b06d7f53 100644 --- a/physics/noahmp_tables.f90 +++ b/physics/noahmp_tables.f90 @@ -8,7 +8,7 @@ !! only the data in the noah_mp_modis_parameters section of MPTABLE.TBL and the STAS section of !! SOILPARM.TBL are included in this module. module noahmp_tables - +use machine , only : kind_phys implicit none integer, private, parameter :: mvt = 30 ! use 30 instead of 27 @@ -39,219 +39,219 @@ module noahmp_tables integer :: lcz_9_table integer :: lcz_10_table integer :: lcz_11_table - real :: ch2op_table(mvt) !< maximum intercepted h2o per unit lai+sai (mm) - real :: dleaf_table(mvt) !< characteristic leaf dimension (m) - real :: z0mvt_table(mvt) !< momentum roughness length (m) - real :: hvt_table(mvt) !< top of canopy (m) - real :: hvb_table(mvt) !< bottom of canopy (m) - real :: z0mhvt_table(mvt) !< ratio of z0m to hvt - real :: den_table(mvt) !< tree density (no. of trunks per m2) - real :: rc_table(mvt) !< tree crown radius (m) - real :: mfsno_table(mvt) !< snowmelt curve parameter () - real :: scffac_table(mvt) !< snow cover factor (m) - real :: cbiom_table(mvt) !< canopy biomass heat capacity parameter (m) - real :: saim_table(mvt,12) !< monthly stem area index, one-sided - real :: laim_table(mvt,12) !< monthly leaf area index, one-sided - real :: sla_table(mvt) !< single-side leaf area per kg [m2/kg] - real :: dilefc_table(mvt) !< coeficient for leaf stress death [1/s] - real :: dilefw_table(mvt) !< coeficient for leaf stress death [1/s] - real :: fragr_table(mvt) !< fraction of growth respiration !original was 0.3 - real :: ltovrc_table(mvt) !< leaf turnover [1/s] - - real :: c3psn_table(mvt) !< photosynthetic pathway: 0. = c4, 1. = c3 - real :: kc25_table(mvt) !< co2 michaelis-menten constant at 25c (pa) - real :: akc_table(mvt) !< q10 for kc25 - real :: ko25_table(mvt) !< o2 michaelis-menten constant at 25c (pa) - real :: ako_table(mvt) !< q10 for ko25 - real :: vcmx25_table(mvt) !< maximum rate of carboxylation at 25c (umol co2/m**2/s) - real :: avcmx_table(mvt) !< q10 for vcmx25 - real :: bp_table(mvt) !< minimum leaf conductance (umol/m**2/s) - real :: mp_table(mvt) !< slope of conductance-to-photosynthesis relationship - real :: qe25_table(mvt) !< quantum efficiency at 25c (umol co2 / umo photon) - real :: aqe_table(mvt) !< q10 for qe25 - real :: rmf25_table(mvt) !< leaf maintenance respiration at 25c (umol co2/m**2/s) - real :: rms25_table(mvt) !< stem maintenance respiration at 25c (umol co2/kg bio/s) - real :: rmr25_table(mvt) !< root maintenance respiration at 25c (umol co2/kg bio/s) - real :: arm_table(mvt) !< q10 for maintenance respiration - real :: folnmx_table(mvt) !< foliage nitrogen concentration when f(n)=1 (%) - real :: tmin_table(mvt) !< minimum temperature for photosynthesis (k) - - real :: xl_table(mvt) !< leaf/stem orientation index - real :: rhol_table(mvt,mband) !< leaf reflectance: 1=vis, 2=nir - real :: rhos_table(mvt,mband) !< stem reflectance: 1=vis, 2=nir - real :: taul_table(mvt,mband) !< leaf transmittance: 1=vis, 2=nir - real :: taus_table(mvt,mband) !< stem transmittance: 1=vis, 2=nir - - real :: mrp_table(mvt) !< microbial respiration parameter (umol co2 /kg c/ s) - real :: cwpvt_table(mvt) !< empirical canopy wind parameter - - real :: wrrat_table(mvt) !< wood to non-wood ratio - real :: wdpool_table(mvt) !< wood pool (switch 1 or 0) depending on woody or not [-] - real :: tdlef_table(mvt) !< characteristic t for leaf freezing [k] - - real :: nroot_table(mvt) !< number of soil layers with root present - real :: rgl_table(mvt) !< parameter used in radiation stress function - real :: rs_table(mvt) !< minimum stomatal resistance [s m-1] - real :: hs_table(mvt) !< parameter used in vapor pressure deficit function - real :: topt_table(mvt) !< optimum transpiration air temperature [k] - real :: rsmax_table(mvt) !< maximal stomatal resistance [s m-1] + real (kind=kind_phys) :: ch2op_table(mvt) !< maximum intercepted h2o per unit lai+sai (mm) + real (kind=kind_phys) :: dleaf_table(mvt) !< characteristic leaf dimension (m) + real (kind=kind_phys) :: z0mvt_table(mvt) !< momentum roughness length (m) + real (kind=kind_phys) :: hvt_table(mvt) !< top of canopy (m) + real (kind=kind_phys) :: hvb_table(mvt) !< bottom of canopy (m) + real (kind=kind_phys) :: z0mhvt_table(mvt) !< ratio of z0m to hvt + real (kind=kind_phys) :: den_table(mvt) !< tree density (no. of trunks per m2) + real (kind=kind_phys) :: rc_table(mvt) !< tree crown radius (m) + real (kind=kind_phys) :: mfsno_table(mvt) !< snowmelt curve parameter () + real (kind=kind_phys) :: scffac_table(mvt) !< snow cover factor (m) + real (kind=kind_phys) :: cbiom_table(mvt) !< canopy biomass heat capacity parameter (m) + real (kind=kind_phys) :: saim_table(mvt,12) !< monthly stem area index, one-sided + real (kind=kind_phys) :: laim_table(mvt,12) !< monthly leaf area index, one-sided + real (kind=kind_phys) :: sla_table(mvt) !< single-side leaf area per kg [m2/kg] + real (kind=kind_phys) :: dilefc_table(mvt) !< coeficient for leaf stress death [1/s] + real (kind=kind_phys) :: dilefw_table(mvt) !< coeficient for leaf stress death [1/s] + real (kind=kind_phys) :: fragr_table(mvt) !< fraction of growth respiration !original was 0.3 + real (kind=kind_phys) :: ltovrc_table(mvt) !< leaf turnover [1/s] + + real (kind=kind_phys) :: c3psn_table(mvt) !< photosynthetic pathway: 0. = c4, 1. = c3 + real (kind=kind_phys) :: kc25_table(mvt) !< co2 michaelis-menten constant at 25c (pa) + real (kind=kind_phys) :: akc_table(mvt) !< q10 for kc25 + real (kind=kind_phys) :: ko25_table(mvt) !< o2 michaelis-menten constant at 25c (pa) + real (kind=kind_phys) :: ako_table(mvt) !< q10 for ko25 + real (kind=kind_phys) :: vcmx25_table(mvt) !< maximum rate of carboxylation at 25c (umol co2/m**2/s) + real (kind=kind_phys) :: avcmx_table(mvt) !< q10 for vcmx25 + real (kind=kind_phys) :: bp_table(mvt) !< minimum leaf conductance (umol/m**2/s) + real (kind=kind_phys) :: mp_table(mvt) !< slope of conductance-to-photosynthesis relationship + real (kind=kind_phys) :: qe25_table(mvt) !< quantum efficiency at 25c (umol co2 / umo photon) + real (kind=kind_phys) :: aqe_table(mvt) !< q10 for qe25 + real (kind=kind_phys) :: rmf25_table(mvt) !< leaf maintenance respiration at 25c (umol co2/m**2/s) + real (kind=kind_phys) :: rms25_table(mvt) !< stem maintenance respiration at 25c (umol co2/kg bio/s) + real (kind=kind_phys) :: rmr25_table(mvt) !< root maintenance respiration at 25c (umol co2/kg bio/s) + real (kind=kind_phys) :: arm_table(mvt) !< q10 for maintenance respiration + real (kind=kind_phys) :: folnmx_table(mvt) !< foliage nitrogen concentration when f(n)=1 (%) + real (kind=kind_phys) :: tmin_table(mvt) !< minimum temperature for photosynthesis (k) + + real (kind=kind_phys) :: xl_table(mvt) !< leaf/stem orientation index + real (kind=kind_phys) :: rhol_table(mvt,mband) !< leaf reflectance: 1=vis, 2=nir + real (kind=kind_phys) :: rhos_table(mvt,mband) !< stem reflectance: 1=vis, 2=nir + real (kind=kind_phys) :: taul_table(mvt,mband) !< leaf transmittance: 1=vis, 2=nir + real (kind=kind_phys) :: taus_table(mvt,mband) !< stem transmittance: 1=vis, 2=nir + + real (kind=kind_phys) :: mrp_table(mvt) !< microbial respiration parameter (umol co2 /kg c/ s) + real (kind=kind_phys) :: cwpvt_table(mvt) !< empirical canopy wind parameter + + real (kind=kind_phys) :: wrrat_table(mvt) !< wood to non-wood ratio + real (kind=kind_phys) :: wdpool_table(mvt) !< wood pool (switch 1 or 0) depending on woody or not [-] + real (kind=kind_phys) :: tdlef_table(mvt) !< characteristic t for leaf freezing [k] + + real (kind=kind_phys) :: nroot_table(mvt) !< number of soil layers with root present + real (kind=kind_phys) :: rgl_table(mvt) !< parameter used in radiation stress function + real (kind=kind_phys) :: rs_table(mvt) !< minimum stomatal resistance [s m-1] + real (kind=kind_phys) :: hs_table(mvt) !< parameter used in vapor pressure deficit function + real (kind=kind_phys) :: topt_table(mvt) !< optimum transpiration air temperature [k] + real (kind=kind_phys) :: rsmax_table(mvt) !< maximal stomatal resistance [s m-1] ! soilparm.tbl parameters integer :: slcats - real :: bexp_table(max_soiltyp) - real :: smcdry_table(max_soiltyp) - real :: f1_table(max_soiltyp) - real :: smcmax_table(max_soiltyp) - real :: smcref_table(max_soiltyp) - real :: psisat_table(max_soiltyp) - real :: dksat_table(max_soiltyp) - real :: dwsat_table(max_soiltyp) - real :: smcwlt_table(max_soiltyp) - real :: quartz_table(max_soiltyp) - real :: bvic_table(max_soiltyp) !vic model infiltration parameter (-) for opt_run=6 - real :: axaj_table(max_soiltyp) !Xinanjiang: Tension water distribution inflection parameter [-] for opt_run=7 - real :: bxaj_table(max_soiltyp) !Xinanjiang: Tension water distribution shape parameter [-] for opt_run=7 - real :: xxaj_table(max_soiltyp) !Xinanjiang: Free water distribution shape parameter [-] for opt_run=7 - real :: bdvic_table(max_soiltyp) !VIC model infiltration parameter (-) - real :: gdvic_table(max_soiltyp) !mean capilary drive (m) - real :: bbvic_table(max_soiltyp) !heterogeniety parameter for DVIC infiltration [-] + real (kind=kind_phys) :: bexp_table(max_soiltyp) + real (kind=kind_phys) :: smcdry_table(max_soiltyp) + real (kind=kind_phys) :: f1_table(max_soiltyp) + real (kind=kind_phys) :: smcmax_table(max_soiltyp) + real (kind=kind_phys) :: smcref_table(max_soiltyp) + real (kind=kind_phys) :: psisat_table(max_soiltyp) + real (kind=kind_phys) :: dksat_table(max_soiltyp) + real (kind=kind_phys) :: dwsat_table(max_soiltyp) + real (kind=kind_phys) :: smcwlt_table(max_soiltyp) + real (kind=kind_phys) :: quartz_table(max_soiltyp) + real (kind=kind_phys) :: bvic_table(max_soiltyp) !vic model infiltration parameter (-) for opt_run=6 + real (kind=kind_phys) :: axaj_table(max_soiltyp) !Xinanjiang: Tension water distribution inflection parameter [-] for opt_run=7 + real (kind=kind_phys) :: bxaj_table(max_soiltyp) !Xinanjiang: Tension water distribution shape parameter [-] for opt_run=7 + real (kind=kind_phys) :: xxaj_table(max_soiltyp) !Xinanjiang: Free water distribution shape parameter [-] for opt_run=7 + real (kind=kind_phys) :: bdvic_table(max_soiltyp) !VIC model infiltration parameter (-) + real (kind=kind_phys) :: gdvic_table(max_soiltyp) !mean capilary drive (m) + real (kind=kind_phys) :: bbvic_table(max_soiltyp) !heterogeniety parameter for DVIC infiltration [-] ! genparm.tbl parameters - real :: slope_table(num_slope) !< slope factor for soil drainage + real (kind=kind_phys) :: slope_table(num_slope) !< slope factor for soil drainage - real :: csoil_table !< soil heat capacity [j m-3 k-1] - real :: refdk_table !< parameter in the surface runoff parameterization - real :: refkdt_table !< parameter in the surface runoff parameterization - real :: frzk_table !< frozen ground parameter - real :: zbot_table !< depth [m] of lower boundary soil temperature - real :: czil_table !< parameter used in the calculation of the roughness length for heat + real (kind=kind_phys) :: csoil_table !< soil heat capacity [j m-3 k-1] + real (kind=kind_phys) :: refdk_table !< parameter in the surface runoff parameterization + real (kind=kind_phys) :: refkdt_table !< parameter in the surface runoff parameterization + real (kind=kind_phys) :: frzk_table !< frozen ground parameter + real (kind=kind_phys) :: zbot_table !< depth [m] of lower boundary soil temperature + real (kind=kind_phys) :: czil_table !< parameter used in the calculation of the roughness length for heat ! mptable.tbl radiation parameters - real :: albsat_table(msc,mband) !< saturated soil albedos: 1=vis, 2=nir - real :: albdry_table(msc,mband) !< dry soil albedos: 1=vis, 2=nir - real :: albice_table(mband) !< albedo land ice: 1=vis, 2=nir - real :: alblak_table(mband) !< albedo frozen lakes: 1=vis, 2=nir - real :: omegas_table(mband) !< two-stream parameter omega for snow - real :: betads_table !< two-stream parameter betad for snow - real :: betais_table !< two-stream parameter betad for snow - real :: eg_table(2) !< emissivity + real (kind=kind_phys) :: albsat_table(msc,mband) !< saturated soil albedos: 1=vis, 2=nir + real (kind=kind_phys) :: albdry_table(msc,mband) !< dry soil albedos: 1=vis, 2=nir + real (kind=kind_phys) :: albice_table(mband) !< albedo land ice: 1=vis, 2=nir + real (kind=kind_phys) :: alblak_table(mband) !< albedo frozen lakes: 1=vis, 2=nir + real (kind=kind_phys) :: omegas_table(mband) !< two-stream parameter omega for snow + real (kind=kind_phys) :: betads_table !< two-stream parameter betad for snow + real (kind=kind_phys) :: betais_table !< two-stream parameter betad for snow + real (kind=kind_phys) :: eg_table(2) !< emissivity ! mptable.tbl global parameters - real :: co2_table !< co2 partial pressure - real :: o2_table !< o2 partial pressure - real :: timean_table !< gridcell mean topgraphic index (global mean) - real :: fsatmx_table !< maximum surface saturated fraction (global mean) - real :: z0sno_table !< snow surface roughness length (m) (0.002) - real :: ssi_table !< liquid water holding capacity for snowpack (m3/m3) (0.03) - real :: snow_ret_fac_table !< snowpack water release timescale factor (1/s) - real :: snow_emis_table !< surface emissivity - real :: swemx_table !< new snow mass to fully cover old snow (mm) - real :: tau0_table !< tau0 from yang97 eqn. 10a - real :: grain_growth_table !< growth from vapor diffusion yang97 eqn. 10b - real :: extra_growth_table !< extra growth near freezing yang97 eqn. 10c - real :: dirt_soot_table !< dirt and soot term yang97 eqn. 10d - real :: bats_cosz_table !< zenith angle snow albedo adjustment; b in yang97 eqn. 15 - real :: bats_vis_new_table !< new snow visible albedo - real :: bats_nir_new_table !< new snow nir albedo - real :: bats_vis_age_table !< age factor for diffuse visible snow albedo yang97 eqn. 17 - real :: bats_nir_age_table !< age factor for diffuse nir snow albedo yang97 eqn. 18 - real :: bats_vis_dir_table !< cosz factor for direct visible snow albedo yang97 eqn. 15 - real :: bats_nir_dir_table !< cosz factor for direct nir snow albedo yang97 eqn. 16 - real :: rsurf_snow_table !< surface resistance for snow(s/m) - real :: rsurf_exp_table !< exponent in the shape parameter for soil resistance option 1 + real (kind=kind_phys) :: co2_table !< co2 partial pressure + real (kind=kind_phys) :: o2_table !< o2 partial pressure + real (kind=kind_phys) :: timean_table !< gridcell mean topgraphic index (global mean) + real (kind=kind_phys) :: fsatmx_table !< maximum surface saturated fraction (global mean) + real (kind=kind_phys) :: z0sno_table !< snow surface roughness length (m) (0.002) + real (kind=kind_phys) :: ssi_table !< liquid water holding capacity for snowpack (m3/m3) (0.03) + real (kind=kind_phys) :: snow_ret_fac_table !< snowpack water release timescale factor (1/s) + real (kind=kind_phys) :: snow_emis_table !< surface emissivity + real (kind=kind_phys) :: swemx_table !< new snow mass to fully cover old snow (mm) + real (kind=kind_phys) :: tau0_table !< tau0 from yang97 eqn. 10a + real (kind=kind_phys) :: grain_growth_table !< growth from vapor diffusion yang97 eqn. 10b + real (kind=kind_phys) :: extra_growth_table !< extra growth near freezing yang97 eqn. 10c + real (kind=kind_phys) :: dirt_soot_table !< dirt and soot term yang97 eqn. 10d + real (kind=kind_phys) :: bats_cosz_table !< zenith angle snow albedo adjustment; b in yang97 eqn. 15 + real (kind=kind_phys) :: bats_vis_new_table !< new snow visible albedo + real (kind=kind_phys) :: bats_nir_new_table !< new snow nir albedo + real (kind=kind_phys) :: bats_vis_age_table !< age factor for diffuse visible snow albedo yang97 eqn. 17 + real (kind=kind_phys) :: bats_nir_age_table !< age factor for diffuse nir snow albedo yang97 eqn. 18 + real (kind=kind_phys) :: bats_vis_dir_table !< cosz factor for direct visible snow albedo yang97 eqn. 15 + real (kind=kind_phys) :: bats_nir_dir_table !< cosz factor for direct nir snow albedo yang97 eqn. 16 + real (kind=kind_phys) :: rsurf_snow_table !< surface resistance for snow(s/m) + real (kind=kind_phys) :: rsurf_exp_table !< exponent in the shape parameter for soil resistance option 1 ! mptable.tbl irrigation parameters - real :: irr_frac_table ! irrigation Fraction + real (kind=kind_phys) :: irr_frac_table ! irrigation Fraction integer :: irr_har_table ! number of days before harvest date to stop irrigation - real :: irr_lai_table ! Minimum lai to trigger irrigation - real :: irr_mad_table ! management allowable deficit (0-1) - real :: filoss_table ! fraction of flood irrigation loss (0-1) - real :: sprir_rate_table ! mm/h, sprinkler irrigation rate - real :: micir_rate_table ! mm/h, micro irrigation rate - real :: firtfac_table ! flood application rate factor - real :: ir_rain_table ! maximum precipitation to stop irrigation trigger + real (kind=kind_phys) :: irr_lai_table ! Minimum lai to trigger irrigation + real (kind=kind_phys) :: irr_mad_table ! management allowable deficit (0-1) + real (kind=kind_phys) :: filoss_table ! fraction of flood irrigation loss (0-1) + real (kind=kind_phys) :: sprir_rate_table ! mm/h, sprinkler irrigation rate + real (kind=kind_phys) :: micir_rate_table ! mm/h, micro irrigation rate + real (kind=kind_phys) :: firtfac_table ! flood application rate factor + real (kind=kind_phys) :: ir_rain_table ! maximum precipitation to stop irrigation trigger ! mptable.tbl crop parameters integer :: default_crop_table ! Default crop index integer :: pltday_table(ncrop) !< planting date integer :: hsday_table(ncrop) !< harvest date - real :: plantpop_table(ncrop) !< plant density [per ha] - used? - real :: irri_table(ncrop) !< irrigation strategy 0= non-irrigation 1=irrigation (no water-stress) - - real :: gddtbase_table(ncrop) !< base temperature for gdd accumulation [c] - real :: gddtcut_table(ncrop) !< upper temperature for gdd accumulation [c] - real :: gdds1_table(ncrop) !< gdd from seeding to emergence - real :: gdds2_table(ncrop) !< gdd from seeding to initial vegetative - real :: gdds3_table(ncrop) !< gdd from seeding to post vegetative - real :: gdds4_table(ncrop) !< gdd from seeding to intial reproductive - real :: gdds5_table(ncrop) !< gdd from seeding to pysical maturity - - real :: c3psni_table(ncrop) !photosynthetic pathway: 0. = c4, 1. = c3 ! Zhe Zhang 2020-07-03 - real :: kc25i_table(ncrop) !co2 michaelis-menten constant at 25c (pa) - real :: akci_table(ncrop) !q10 for kc25 - real :: ko25i_table(ncrop) !o2 michaelis-menten constant at 25c (pa) - real :: akoi_table(ncrop) !q10 for ko25 - real :: vcmx25i_table(ncrop) !maximum rate of carboxylation at 25c (umol co2/m**2/s) - real :: avcmxi_table(ncrop) !q10 for vcmx25 - real :: bpi_table(ncrop) !minimum leaf conductance (umol/m**2/s) - real :: mpi_table(ncrop) !slope of conductance-to-photosynthesis relationship - real :: qe25i_table(ncrop) !quantum efficiency at 25c (umol co2 / umol photon) - real :: folnmxi_table(ncrop) !foliage nitrogen concentration when + real (kind=kind_phys) :: plantpop_table(ncrop) !< plant density [per ha] - used? + real (kind=kind_phys) :: irri_table(ncrop) !< irrigation strategy 0= non-irrigation 1=irrigation (no water-stress) + + real (kind=kind_phys) :: gddtbase_table(ncrop) !< base temperature for gdd accumulation [c] + real (kind=kind_phys) :: gddtcut_table(ncrop) !< upper temperature for gdd accumulation [c] + real (kind=kind_phys) :: gdds1_table(ncrop) !< gdd from seeding to emergence + real (kind=kind_phys) :: gdds2_table(ncrop) !< gdd from seeding to initial vegetative + real (kind=kind_phys) :: gdds3_table(ncrop) !< gdd from seeding to post vegetative + real (kind=kind_phys) :: gdds4_table(ncrop) !< gdd from seeding to intial reproductive + real (kind=kind_phys) :: gdds5_table(ncrop) !< gdd from seeding to pysical maturity + + real (kind=kind_phys) :: c3psni_table(ncrop) !photosynthetic pathway: 0. = c4, 1. = c3 ! Zhe Zhang 2020-07-03 + real (kind=kind_phys) :: kc25i_table(ncrop) !co2 michaelis-menten constant at 25c (pa) + real (kind=kind_phys) :: akci_table(ncrop) !q10 for kc25 + real (kind=kind_phys) :: ko25i_table(ncrop) !o2 michaelis-menten constant at 25c (pa) + real (kind=kind_phys) :: akoi_table(ncrop) !q10 for ko25 + real (kind=kind_phys) :: vcmx25i_table(ncrop) !maximum rate of carboxylation at 25c (umol co2/m**2/s) + real (kind=kind_phys) :: avcmxi_table(ncrop) !q10 for vcmx25 + real (kind=kind_phys) :: bpi_table(ncrop) !minimum leaf conductance (umol/m**2/s) + real (kind=kind_phys) :: mpi_table(ncrop) !slope of conductance-to-photosynthesis relationship + real (kind=kind_phys) :: qe25i_table(ncrop) !quantum efficiency at 25c (umol co2 / umol photon) + real (kind=kind_phys) :: folnmxi_table(ncrop) !foliage nitrogen concentration when integer :: c3c4_table(ncrop) !< photosynthetic pathway: 1. = c3 2. = c4 - real :: aref_table(ncrop) !< reference maximum co2 assimulation rate - real :: psnrf_table(ncrop) !< co2 assimulation reduction factor(0-1) (caused by non-modeling part,e.g.pest,weeds) - real :: i2par_table(ncrop) !< fraction of incoming solar radiation to photosynthetically active radiation - real :: tassim0_table(ncrop) !< minimum temperature for co2 assimulation [c] - real :: tassim1_table(ncrop) !< co2 assimulation linearly increasing until temperature reaches t1 [c] - real :: tassim2_table(ncrop) !< co2 assmilation rate remain at aref until temperature reaches t2 [c] - real :: k_table(ncrop) !< light extinction coefficient - real :: epsi_table(ncrop) !< initial light use efficiency - - real :: q10mr_table(ncrop) !< q10 for maintainance respiration - real :: foln_mx_table(ncrop) !< foliage nitrogen concentration when f(n)=1 (%) - real :: lefreez_table(ncrop) !< characteristic t for leaf freezing [k] - - real :: dile_fc_table(ncrop,nstage) !< coeficient for temperature leaf stress death [1/s] - real :: dile_fw_table(ncrop,nstage) !< coeficient for water leaf stress death [1/s] - real :: fra_gr_table(ncrop) !< fraction of growth respiration - - real :: lf_ovrc_table(ncrop,nstage) !< fraction of leaf turnover [1/s] - real :: st_ovrc_table(ncrop,nstage) !< fraction of stem turnover [1/s] - real :: rt_ovrc_table(ncrop,nstage) !< fraction of root tunrover [1/s] - real :: lfmr25_table(ncrop) !< leaf maintenance respiration at 25c [umol co2/m**2 /s] - real :: stmr25_table(ncrop) !< stem maintenance respiration at 25c [umol co2/kg bio/s] - real :: rtmr25_table(ncrop) !< root maintenance respiration at 25c [umol co2/kg bio/s] - real :: grainmr25_table(ncrop) !< grain maintenance respiration at 25c [umol co2/kg bio/s] - - real :: lfpt_table(ncrop,nstage) !< fraction of carbohydrate flux to leaf - real :: stpt_table(ncrop,nstage) !< fraction of carbohydrate flux to stem - real :: rtpt_table(ncrop,nstage) !< fraction of carbohydrate flux to root - real :: grainpt_table(ncrop,nstage) !< fraction of carbohydrate flux to grain - real :: lfct_table(ncrop,nstage) ! fraction of carbohydrate translocation from leaf to grain ! Zhe Zhang 2020-07-13 - real :: stct_table(ncrop,nstage) ! stem to grain - real :: rtct_table(ncrop,nstage) ! root to grain - real :: bio2lai_table(ncrop) !< leaf are per living leaf biomass [m^2/kg] + real (kind=kind_phys) :: aref_table(ncrop) !< reference maximum co2 assimulation rate + real (kind=kind_phys) :: psnrf_table(ncrop) !< co2 assimulation reduction factor(0-1) (caused by non-modeling part,e.g.pest,weeds) + real (kind=kind_phys) :: i2par_table(ncrop) !< fraction of incoming solar radiation to photosynthetically active radiation + real (kind=kind_phys) :: tassim0_table(ncrop) !< minimum temperature for co2 assimulation [c] + real (kind=kind_phys) :: tassim1_table(ncrop) !< co2 assimulation linearly increasing until temperature reaches t1 [c] + real (kind=kind_phys) :: tassim2_table(ncrop) !< co2 assmilation rate remain at aref until temperature reaches t2 [c] + real (kind=kind_phys) :: k_table(ncrop) !< light extinction coefficient + real (kind=kind_phys) :: epsi_table(ncrop) !< initial light use efficiency + + real (kind=kind_phys) :: q10mr_table(ncrop) !< q10 for maintainance respiration + real (kind=kind_phys) :: foln_mx_table(ncrop) !< foliage nitrogen concentration when f(n)=1 (%) + real (kind=kind_phys) :: lefreez_table(ncrop) !< characteristic t for leaf freezing [k] + + real (kind=kind_phys) :: dile_fc_table(ncrop,nstage) !< coeficient for temperature leaf stress death [1/s] + real (kind=kind_phys) :: dile_fw_table(ncrop,nstage) !< coeficient for water leaf stress death [1/s] + real (kind=kind_phys) :: fra_gr_table(ncrop) !< fraction of growth respiration + + real (kind=kind_phys) :: lf_ovrc_table(ncrop,nstage) !< fraction of leaf turnover [1/s] + real (kind=kind_phys) :: st_ovrc_table(ncrop,nstage) !< fraction of stem turnover [1/s] + real (kind=kind_phys) :: rt_ovrc_table(ncrop,nstage) !< fraction of root tunrover [1/s] + real (kind=kind_phys) :: lfmr25_table(ncrop) !< leaf maintenance respiration at 25c [umol co2/m**2 /s] + real (kind=kind_phys) :: stmr25_table(ncrop) !< stem maintenance respiration at 25c [umol co2/kg bio/s] + real (kind=kind_phys) :: rtmr25_table(ncrop) !< root maintenance respiration at 25c [umol co2/kg bio/s] + real (kind=kind_phys) :: grainmr25_table(ncrop) !< grain maintenance respiration at 25c [umol co2/kg bio/s] + + real (kind=kind_phys) :: lfpt_table(ncrop,nstage) !< fraction of carbohydrate flux to leaf + real (kind=kind_phys) :: stpt_table(ncrop,nstage) !< fraction of carbohydrate flux to stem + real (kind=kind_phys) :: rtpt_table(ncrop,nstage) !< fraction of carbohydrate flux to root + real (kind=kind_phys) :: grainpt_table(ncrop,nstage) !< fraction of carbohydrate flux to grain + real (kind=kind_phys) :: lfct_table(ncrop,nstage) ! fraction of carbohydrate translocation from leaf to grain ! Zhe Zhang 2020-07-13 + real (kind=kind_phys) :: stct_table(ncrop,nstage) ! stem to grain + real (kind=kind_phys) :: rtct_table(ncrop,nstage) ! root to grain + real (kind=kind_phys) :: bio2lai_table(ncrop) !< leaf are per living leaf biomass [m^2/kg] ! tile drainage parameters - real :: tdsmc_fac_table(max_soiltyp) - real :: td_dc_table(max_soiltyp) + real (kind=kind_phys) :: tdsmc_fac_table(max_soiltyp) + real (kind=kind_phys) :: td_dc_table(max_soiltyp) integer :: td_depth_table(max_soiltyp) integer :: drain_layer_opt_table - real :: td_dcoef_table(max_soiltyp) - real :: td_d_table(max_soiltyp) - real :: td_adepth_table(max_soiltyp) - real :: td_radi_table(max_soiltyp) - real :: td_spac_table(max_soiltyp) - real :: td_ddrain_table(max_soiltyp) - real :: klat_fac_table(max_soiltyp) + real (kind=kind_phys) :: td_dcoef_table(max_soiltyp) + real (kind=kind_phys) :: td_d_table(max_soiltyp) + real (kind=kind_phys) :: td_adepth_table(max_soiltyp) + real (kind=kind_phys) :: td_radi_table(max_soiltyp) + real (kind=kind_phys) :: td_spac_table(max_soiltyp) + real (kind=kind_phys) :: td_ddrain_table(max_soiltyp) + real (kind=kind_phys) :: klat_fac_table(max_soiltyp) ! mptable.tbl optional parameters @@ -259,60 +259,62 @@ module noahmp_tables ! Saxton and Rawls 2006 Pedo-transfer function coefficients !------------------------------------------------------------------------------ - real :: sr2006_theta_1500t_a !< sand coefficient - real :: sr2006_theta_1500t_b !< clay coefficient - real :: sr2006_theta_1500t_c !< orgm coefficient - real :: sr2006_theta_1500t_d !< sand*orgm coefficient - real :: sr2006_theta_1500t_e !< clay*orgm coefficient - real :: sr2006_theta_1500t_f !< sand*clay coefficient - real :: sr2006_theta_1500t_g !< constant adjustment - - real :: sr2006_theta_1500_a !< theta_1500t coefficient - real :: sr2006_theta_1500_b !< constant adjustment - - real :: sr2006_theta_33t_a !< sand coefficient - real :: sr2006_theta_33t_b !< clay coefficient - real :: sr2006_theta_33t_c !< orgm coefficient - real :: sr2006_theta_33t_d !< sand*orgm coefficient - real :: sr2006_theta_33t_e !< clay*orgm coefficient - real :: sr2006_theta_33t_f !< sand*clay coefficient - real :: sr2006_theta_33t_g !< constant adjustment - - real :: sr2006_theta_33_a !< theta_33t*theta_33t coefficient - real :: sr2006_theta_33_b !< theta_33t coefficient - real :: sr2006_theta_33_c !< constant adjustment - - real :: sr2006_theta_s33t_a !< sand coefficient - real :: sr2006_theta_s33t_b !< clay coefficient - real :: sr2006_theta_s33t_c !< orgm coefficient - real :: sr2006_theta_s33t_d !< sand*orgm coefficient - real :: sr2006_theta_s33t_e !< clay*orgm coefficient - real :: sr2006_theta_s33t_f !< sand*clay coefficient - real :: sr2006_theta_s33t_g !< constant adjustment - - real :: sr2006_theta_s33_a !< theta_s33t coefficient - real :: sr2006_theta_s33_b !< constant adjustment - - real :: sr2006_psi_et_a !< sand coefficient - real :: sr2006_psi_et_b !< clay coefficient - real :: sr2006_psi_et_c !< theta_s33 coefficient - real :: sr2006_psi_et_d !< sand*theta_s33 coefficient - real :: sr2006_psi_et_e !< clay*theta_s33 coefficient - real :: sr2006_psi_et_f !< sand*clay coefficient - real :: sr2006_psi_et_g !< constant adjustment - - real :: sr2006_psi_e_a !< psi_et*psi_et coefficient - real :: sr2006_psi_e_b !< psi_et coefficient - real :: sr2006_psi_e_c !< constant adjustment - - real :: sr2006_smcmax_a !< sand adjustment - real :: sr2006_smcmax_b !< constant adjustment + real (kind=kind_phys) :: sr2006_theta_1500t_a !< sand coefficient + real (kind=kind_phys) :: sr2006_theta_1500t_b !< clay coefficient + real (kind=kind_phys) :: sr2006_theta_1500t_c !< orgm coefficient + real (kind=kind_phys) :: sr2006_theta_1500t_d !< sand*orgm coefficient + real (kind=kind_phys) :: sr2006_theta_1500t_e !< clay*orgm coefficient + real (kind=kind_phys) :: sr2006_theta_1500t_f !< sand*clay coefficient + real (kind=kind_phys) :: sr2006_theta_1500t_g !< constant adjustment + + real (kind=kind_phys) :: sr2006_theta_1500_a !< theta_1500t coefficient + real (kind=kind_phys) :: sr2006_theta_1500_b !< constant adjustment + + real (kind=kind_phys) :: sr2006_theta_33t_a !< sand coefficient + real (kind=kind_phys) :: sr2006_theta_33t_b !< clay coefficient + real (kind=kind_phys) :: sr2006_theta_33t_c !< orgm coefficient + real (kind=kind_phys) :: sr2006_theta_33t_d !< sand*orgm coefficient + real (kind=kind_phys) :: sr2006_theta_33t_e !< clay*orgm coefficient + real (kind=kind_phys) :: sr2006_theta_33t_f !< sand*clay coefficient + real (kind=kind_phys) :: sr2006_theta_33t_g !< constant adjustment + + real (kind=kind_phys) :: sr2006_theta_33_a !< theta_33t*theta_33t coefficient + real (kind=kind_phys) :: sr2006_theta_33_b !< theta_33t coefficient + real (kind=kind_phys) :: sr2006_theta_33_c !< constant adjustment + + real (kind=kind_phys) :: sr2006_theta_s33t_a !< sand coefficient + real (kind=kind_phys) :: sr2006_theta_s33t_b !< clay coefficient + real (kind=kind_phys) :: sr2006_theta_s33t_c !< orgm coefficient + real (kind=kind_phys) :: sr2006_theta_s33t_d !< sand*orgm coefficient + real (kind=kind_phys) :: sr2006_theta_s33t_e !< clay*orgm coefficient + real (kind=kind_phys) :: sr2006_theta_s33t_f !< sand*clay coefficient + real (kind=kind_phys) :: sr2006_theta_s33t_g !< constant adjustment + + real (kind=kind_phys) :: sr2006_theta_s33_a !< theta_s33t coefficient + real (kind=kind_phys) :: sr2006_theta_s33_b !< constant adjustment + + real (kind=kind_phys) :: sr2006_psi_et_a !< sand coefficient + real (kind=kind_phys) :: sr2006_psi_et_b !< clay coefficient + real (kind=kind_phys) :: sr2006_psi_et_c !< theta_s33 coefficient + real (kind=kind_phys) :: sr2006_psi_et_d !< sand*theta_s33 coefficient + real (kind=kind_phys) :: sr2006_psi_et_e !< clay*theta_s33 coefficient + real (kind=kind_phys) :: sr2006_psi_et_f !< sand*clay coefficient + real (kind=kind_phys) :: sr2006_psi_et_g !< constant adjustment + + real (kind=kind_phys) :: sr2006_psi_e_a !< psi_et*psi_et coefficient + real (kind=kind_phys) :: sr2006_psi_e_b !< psi_et coefficient + real (kind=kind_phys) :: sr2006_psi_e_c !< constant adjustment + + real (kind=kind_phys) :: sr2006_smcmax_a !< sand adjustment + real (kind=kind_phys) :: sr2006_smcmax_b !< constant adjustment contains - subroutine read_mp_table_parameters + subroutine read_mp_table_parameters(errmsg, errflg) implicit none + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg ! vegetation parameters character(len=256) :: dataset_identifier @@ -321,7 +323,7 @@ subroutine read_mp_table_parameters integer :: ierr, ik, im integer :: nveg, isurban, iswater, isbarren, isice, iscrop, eblforest, natural integer :: lcz_1, lcz_2, lcz_3, lcz_4, lcz_5, lcz_6, lcz_7, lcz_8, lcz_9, lcz_10, lcz_11 - real, dimension(mvt) :: sai_jan, sai_feb, sai_mar, sai_apr, sai_may, sai_jun, sai_jul, sai_aug, & + real (kind=kind_phys), dimension(mvt) :: sai_jan, sai_feb, sai_mar, sai_apr, sai_may, sai_jun, sai_jul, sai_aug, & sai_sep, sai_oct, sai_nov, sai_dec, lai_jan, lai_feb, lai_mar, lai_apr, & lai_may, lai_jun, lai_jul, lai_aug, lai_sep, lai_oct, lai_nov, lai_dec, & rhol_vis, rhol_nir, rhos_vis, rhos_nir, taul_vis, taul_nir, taus_vis, taus_nir,& @@ -361,7 +363,7 @@ subroutine read_mp_table_parameters character(len=256) :: message character(len=10) :: sltype integer :: slcats - real, dimension(max_soiltyp) :: bb, drysmc, maxsmc, refsmc, satpsi, satdk, satdw, wltsmc, qtz, & + real (kind=kind_phys), dimension(max_soiltyp) :: bb, drysmc, maxsmc, refsmc, satpsi, satdk, satdw, wltsmc, qtz, & bvic, axaj, bxaj, xxaj, bdvic, bbvic, gdvic, hc namelist / noahmp_stas_soil_categories / sltype, slcats namelist / noahmp_soil_stas_parameters / bb, drysmc, maxsmc, refsmc, satpsi, satdk, satdw, wltsmc, qtz, & @@ -370,21 +372,21 @@ subroutine read_mp_table_parameters bvic, axaj, bxaj, xxaj, bdvic, bbvic, gdvic ! general parameters - real :: csoil_data, refdk_data, refkdt_data, frzk_data, zbot_data, czil_data - real, dimension(num_slope) :: slope_data + real (kind=kind_phys) :: csoil_data, refdk_data, refkdt_data, frzk_data, zbot_data, czil_data + real (kind=kind_phys), dimension(num_slope) :: slope_data namelist / noahmp_general_parameters / slope_data, csoil_data, refdk_data, refkdt_data, frzk_data, zbot_data, & czil_data ! radiation parameters - real :: betads, betais, eice - real, dimension(mband) :: albice, alblak, omegas - real, dimension(2) :: eg - real, dimension(msc) :: albsat_vis, albsat_nir, albdry_vis, albdry_nir + real (kind=kind_phys) :: betads, betais, eice + real (kind=kind_phys), dimension(mband) :: albice, alblak, omegas + real (kind=kind_phys), dimension(2) :: eg + real (kind=kind_phys), dimension(msc) :: albsat_vis, albsat_nir, albdry_vis, albdry_nir namelist / noahmp_rad_parameters / albsat_vis, albsat_nir, albdry_vis, albdry_nir, albice, alblak, omegas, & betads, betais, eg, eice ! global parameters - real :: co2, o2, timean, fsatmx, z0sno, ssi, snow_ret_fac ,snow_emis, swemx, tau0, & + real (kind=kind_phys) :: co2, o2, timean, fsatmx, z0sno, ssi, snow_ret_fac ,snow_emis, swemx, tau0, & grain_growth, extra_growth, dirt_soot, bats_cosz, bats_vis_new, & bats_nir_new, bats_vis_age, bats_nir_age, bats_vis_dir, bats_nir_dir, & rsurf_snow, rsurf_exp, c2_snowcompact, c3_snowcompact, c4_snowcompact, & @@ -401,14 +403,14 @@ subroutine read_mp_table_parameters ! irrigation parameters integer :: irr_har - real :: irr_frac, irr_lai, irr_mad, filoss, sprir_rate, micir_rate, firtfac, ir_rain + real (kind=kind_phys) :: irr_frac, irr_lai, irr_mad, filoss, sprir_rate, micir_rate, firtfac, ir_rain namelist / noahmp_irrigation_parameters / irr_frac, irr_har, irr_lai, irr_mad, filoss, sprir_rate, micir_rate, firtfac,& ir_rain ! crop parameters integer :: default_crop integer , dimension(ncrop) :: pltday, hsday - real, dimension(ncrop) :: plantpop, irri, gddtbase, gddtcut, gdds1, gdds2, gdds3, gdds4, gdds5, c3psni,& + real (kind=kind_phys), dimension(ncrop) :: plantpop, irri, gddtbase, gddtcut, gdds1, gdds2, gdds3, gdds4, gdds5, c3psni,& kc25i, akci, ko25i, akoi, avcmxi, vcmx25i, bpi, mpi, folnmxi, qe25i, aref, & psnrf, i2par, tassim0, tassim1, tassim2, k, epsi, q10mr, lefreez, & dile_fc_s1, dile_fc_s2, dile_fc_s3, dile_fc_s4, dile_fc_s5, dile_fc_s6, & @@ -449,13 +451,13 @@ subroutine read_mp_table_parameters ! tile drainage parameters integer :: nsoiltype, drain_layer_opt integer , dimension(max_soiltyp) :: td_depth - real, dimension(max_soiltyp) :: tdsmc_fac, td_dc, td_dcoef, td_d, td_adepth, td_radi, td_spac, & + real (kind=kind_phys), dimension(max_soiltyp) :: tdsmc_fac, td_dc, td_dcoef, td_d, td_adepth, td_radi, td_spac, & td_ddrain, klat_fac namelist / noahmp_tiledrain_parameters / nsoiltype, drain_layer_opt, tdsmc_fac, td_depth, td_dc, td_dcoef, td_d,& td_adepth, td_radi, td_spac, td_ddrain, klat_fac ! optional parameters - real :: sr2006_theta_1500t_a, sr2006_theta_1500t_b, sr2006_theta_1500t_c, & + real (kind=kind_phys) :: sr2006_theta_1500t_a, sr2006_theta_1500t_b, sr2006_theta_1500t_c, & sr2006_theta_1500t_d, sr2006_theta_1500t_e, sr2006_theta_1500t_f, & sr2006_theta_1500t_g, sr2006_theta_1500_a , sr2006_theta_1500_b, & sr2006_theta_33t_a, sr2006_theta_33t_b, sr2006_theta_33t_c, & @@ -781,7 +783,10 @@ subroutine read_mp_table_parameters open(15, status='old', form='formatted', action='read', iostat=ierr) end if if ( ierr /= 0 ) then - write(*,'("warning: cannot find file noahmptable.tbl")') + errmsg = 'warning: cannot find file noahmptable.tb' + errflg = 1 + return +! write(*,'("warning: cannot find file noahmptable.tbl")') endif if ( trim(dataset_identifier) == "usgs" ) then @@ -909,7 +914,10 @@ subroutine read_mp_table_parameters open(15, status='old', form='formatted', action='read', iostat=ierr) end if if ( ierr /= 0 ) then - write(*,'("warning: cannot find file noahmptable.tbl")') + errmsg = 'warning: cannot find file noahmptable.tb' + errflg = 1 + return +! write(*,'("warning: cannot find file noahmptable.tbl")') endif read(15, noahmp_stas_soil_categories) if ( trim(sltype) == "stas" ) then @@ -949,7 +957,10 @@ subroutine read_mp_table_parameters open(15, status='old', form='formatted', action='read', iostat=ierr) end if if ( ierr /= 0 ) then - write(*,'("warning: cannot find file noahmptable.tbl")') + errmsg = 'warning: cannot find file noahmptable.tb' + errflg = 1 + return +! write(*,'("warning: cannot find file noahmptable.tbl")') endif read(15, noahmp_general_parameters) close(15) @@ -971,7 +982,10 @@ subroutine read_mp_table_parameters open(15, status='old', form='formatted', action='read', iostat=ierr) end if if (ierr /= 0) then - write(*,'("warning: cannot find file noahmptable.tbl")') + errmsg = 'warning: cannot find file noahmptable.tb' + errflg = 1 + return +! write(*,'("warning: cannot find file noahmptable.tbl")') endif read(15,noahmp_rad_parameters) close(15) @@ -997,7 +1011,10 @@ subroutine read_mp_table_parameters open(15, status='old', form='formatted', action='read', iostat=ierr) end if if (ierr /= 0) then - write(*,'("warning: cannot find file noahmptable.tbl")') + errmsg = 'warning: cannot find file noahmptable.tb' + errflg = 1 + return +! write(*,'("warning: cannot find file noahmptable.tbl")') endif read(15,noahmp_global_parameters) close(15) @@ -1052,7 +1069,10 @@ subroutine read_mp_table_parameters open(15, status='old', form='formatted', action='read', iostat=ierr) end if if (ierr /= 0) then - write(*,'("warning: cannot find file noahmptable.tbl")') + errmsg = 'warning: cannot find file noahmptable.tb' + errflg = 1 + return +! write(*,'("warning: cannot find file noahmptable.tbl")') endif read(15,noahmp_irrigation_parameters) close(15) @@ -1076,7 +1096,10 @@ subroutine read_mp_table_parameters open(15, status='old', form='formatted', action='read', iostat=ierr) end if if (ierr /= 0) then - write(*,'("warning: cannot find file noahmptable.tbl")') + errmsg = 'warning: cannot find file noahmptable.tb' + errflg = 1 + return +! write(*,'("warning: cannot find file noahmptable.tbl")') endif read(15,noahmp_crop_parameters) close(15) @@ -1226,7 +1249,10 @@ subroutine read_mp_table_parameters open(15, status='old', form='formatted', action='read', iostat=ierr) end if if (ierr /= 0) then - write(*,'("warning: cannot find file noahmptable.tbl")') + errmsg = 'warning: cannot find file noahmptable.tb' + errflg = 1 + return +! write(*,'("warning: cannot find file noahmptable.tbl")') endif read(15,noahmp_tiledrain_parameters) close(15) @@ -1252,7 +1278,10 @@ subroutine read_mp_table_parameters open(15, status='old', form='formatted', action='read', iostat=ierr) end if if (ierr /= 0) then - write(*,'("warning: cannot find file noahmptable.tbl")') + errmsg = 'warning: cannot find file noahmptable.tb' + errflg = 1 + return +! write(*,'("warning: cannot find file noahmptable.tbl")') endif read(15,noahmp_optional_parameters) close(15) diff --git a/physics/noahmpdrv.F90 b/physics/noahmpdrv.F90 index 6831d17a2..d4e84bd7d 100644 --- a/physics/noahmpdrv.F90 +++ b/physics/noahmpdrv.F90 @@ -90,7 +90,7 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, me, isot, ivegsrc, & call set_soilveg(me, isot, ivegsrc, nlunit, errmsg, errflg) !--- read in noahmp table - call read_mp_table_parameters + call read_mp_table_parameters(errmsg, errflg) ! initialize psih and psim diff --git a/physics/sfcsub.F b/physics/sfcsub.F index 3ac7df7c5..1ff8a41b2 100644 --- a/physics/sfcsub.F +++ b/physics/sfcsub.F @@ -660,7 +660,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & data fnalbc2/'global_albedo4.1x1.grb'/ data fntsfc/'global_sstclim.2x2.grb'/ data fnsotc/'global_soiltype.1x1.grb'/ - data fnsocc/'soil_color.clm.0.05.nc'/ + data fnsocc/''/ data fnvegc/'global_vegfrac.1x1.grb'/ data fnvetc/'global_vegtype.1x1.grb'/ data fnglac/'global_glacier.2x2.grb'/ From 5b50134d7e1a7847e69d61ec06506f52c1be967a Mon Sep 17 00:00:00 2001 From: Helin Wei Date: Wed, 7 Jun 2023 13:02:53 -0400 Subject: [PATCH 281/380] remove soil color comment --- physics/GFS_phys_time_vary.fv3.F90 | 4 ++-- physics/gcycle.F90 | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index 67fec5ca1..72f873b12 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -743,7 +743,7 @@ subroutine GFS_phys_time_vary_timestep_init ( kice, ialb, isot, ivegsrc, input_nml_file, use_ufo, nst_anl, frac_grid, fhcyc, phour, & lakefrac, min_seaice, min_lakeice, smc, slc, stc, smois, sh2o, tslb, tiice, tg3, tref, & tsfc, tsfco, tisfc, hice, fice, facsf, facwf, alvsf, alvwf, alnsf, alnwf, zorli, zorll, & - zorlo, weasd, slope, snoalb, canopy, vfrac, vtype, stype,scolor, shdmin, shdmax, snowd, & !soil color + zorlo, weasd, slope, snoalb, canopy, vfrac, vtype, stype,scolor, shdmin, shdmax, snowd, & cv, cvb, cvt, oro, oro_uf, xlat_d, xlon_d, slmsk, landfrac, & do_ugwp_v1, jindx1_tau, jindx2_tau, ddy_j1tau, ddy_j2tau, tau_amf, errmsg, errflg) @@ -790,7 +790,7 @@ subroutine GFS_phys_time_vary_timestep_init ( zorli(:), zorll(:), zorlo(:), weasd(:), snoalb(:), & canopy(:), vfrac(:), shdmin(:), shdmax(:), & snowd(:), cv(:), cvb(:), cvt(:), oro(:), oro_uf(:), slmsk(:) - integer, intent(inout) :: vtype(:), stype(:),scolor(:), slope(:) !soil color + integer, intent(inout) :: vtype(:), stype(:),scolor(:), slope(:) character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg diff --git a/physics/gcycle.F90 b/physics/gcycle.F90 index 52ed97efb..f5eecbd18 100644 --- a/physics/gcycle.F90 +++ b/physics/gcycle.F90 @@ -75,7 +75,7 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, fn_nml, slmsk(:) integer, intent(inout) :: vtype(:), & stype(:), & - scolor(:), & !soil color + scolor(:), & slope(:) integer, intent(in) :: imap(:), jmap(:) From a99876bef304ea468351abf0731460dc7c61b6be Mon Sep 17 00:00:00 2001 From: Helin Wei Date: Thu, 8 Jun 2023 23:40:40 -0400 Subject: [PATCH 282/380] to address issues on ep_2 epsm1 and fv --- physics/module_sf_noahmp_glacier.F90 | 47 ++++++++++++----------- physics/module_sf_noahmplsm.F90 | 56 +++++++++++++++------------- physics/noahmpdrv.F90 | 2 +- 3 files changed, 57 insertions(+), 48 deletions(-) diff --git a/physics/module_sf_noahmp_glacier.F90 b/physics/module_sf_noahmp_glacier.F90 index 7822ead30..6e34c43af 100644 --- a/physics/module_sf_noahmp_glacier.F90 +++ b/physics/module_sf_noahmp_glacier.F90 @@ -126,7 +126,7 @@ subroutine noahmp_glacier (& thsfc_loc ,prslkix ,prsik1x ,prslk1x , & psfc ,pblhx ,iz0tlnd ,itime , & sigmaf1 ,garea1 ,psi_opt , & ! in : - ep_1 ,ep_2 ,cp , & + ep_1 ,ep_2 ,epsm1 ,cp , & qsnow ,sneqvo ,albold ,cm ,ch ,isnow , & ! in/out : sneqv ,smc ,zsnso ,snowh ,snice ,snliq , & ! in/out : tg ,stc ,sh2o ,tauss ,qsfc , & ! in/out : @@ -177,6 +177,7 @@ subroutine noahmp_glacier (& real (kind=kind_phys) , intent(in) :: pblhx ! pbl height real (kind=kind_phys) , intent(in) :: ep_1 real (kind=kind_phys) , intent(in) :: ep_2 + real (kind=kind_phys) , intent(in) :: epsm1 real (kind=kind_phys) , intent(in) :: cp integer , intent(in) :: iz0tlnd ! integer , intent(in) :: itime !< timestep @@ -267,7 +268,7 @@ subroutine noahmp_glacier (& ! -------------------------------------------------------------------------------------------------- ! re-process atmospheric forcing - call atm_glacier (sfcprs ,sfctmp ,q2 ,soldn ,cosz ,thair , & + call atm_glacier (ep_2, epsm1,sfcprs ,sfctmp ,q2 ,soldn ,cosz ,thair , & qair ,eair ,rhoair ,solad ,solai ,swdown ) beg_wb = sneqv @@ -290,7 +291,7 @@ subroutine noahmp_glacier (& tbot ,zbot ,zsnso ,dzsnso ,sigmaf1 ,garea1 , & !in thsfc_loc ,prslkix ,prsik1x ,prslk1x , & !in psfc ,pblhx ,iz0tlnd ,itime ,psi_opt , & - ep_1, ep_2, cp, & + ep_1, ep_2, epsm1, cp, & tg ,stc ,snowh ,sneqv ,sneqvo ,sh2o , & !inout smc ,snice ,snliq ,albold ,cm ,ch , & !inout #ifdef CCPP @@ -363,7 +364,7 @@ end subroutine noahmp_glacier ! ================================================================================================== !>\ingroup NoahMP_LSM !! re-process atmospheric forcing - subroutine atm_glacier (sfcprs ,sfctmp ,q2 ,soldn ,cosz ,thair , & + subroutine atm_glacier (ep_2, epsm1, sfcprs ,sfctmp ,q2 ,soldn ,cosz ,thair , & qair ,eair ,rhoair ,solad ,solai , & swdown ) ! -------------------------------------------------------------------------------------------------- @@ -373,6 +374,8 @@ subroutine atm_glacier (sfcprs ,sfctmp ,q2 ,soldn ,cosz ,thair , & ! -------------------------------------------------------------------------------------------------- ! inputs + real (kind=kind_phys) , intent(in) :: ep_2 + real (kind=kind_phys) , intent(in) :: epsm1 real (kind=kind_phys) , intent(in) :: sfcprs !< pressure (pa) real (kind=kind_phys) , intent(in) :: sfctmp !< surface air temperature [k] real (kind=kind_phys) , intent(in) :: q2 !< mixing ratio (kg/kg) @@ -399,8 +402,8 @@ subroutine atm_glacier (sfcprs ,sfctmp ,q2 ,soldn ,cosz ,thair , & ! qair = q2 / (1.0+q2) ! mixing ratio to specific humidity [kg/kg] qair = q2 ! in wrf, driver converts to specific humidity - eair = qair*sfcprs / (0.622+0.378*qair) - rhoair = (sfcprs-0.378*eair) / (rair*sfctmp) + eair = qair*sfcprs / (ep_2-epsm1*qair) + rhoair = (sfcprs+epsm1*eair) / (rair*sfctmp) if(cosz <= 0.) then swdown = 0. @@ -424,7 +427,7 @@ subroutine energy_glacier (nsnow ,nsoil ,isnow ,dt ,qsnow ,rhoair tbot ,zbot ,zsnso ,dzsnso ,sigmaf1 ,garea1 , & !in thsfc_loc ,prslkix ,prsik1x ,prslk1x , & !in psfc ,pblhx ,iz0tlnd ,itime ,psi_opt , & - ep_1, ep_2, cp, & + ep_1, ep_2, epsm1, cp, & tg ,stc ,snowh ,sneqv ,sneqvo ,sh2o , & !inout smc ,snice ,snliq ,albold ,cm ,ch , & !inout #ifdef CCPP @@ -478,6 +481,7 @@ subroutine energy_glacier (nsnow ,nsoil ,isnow ,dt ,qsnow ,rhoair real (kind=kind_phys) , intent(in) :: psfc !< surface pressure real (kind=kind_phys) , intent(in) :: ep_1 real (kind=kind_phys) , intent(in) :: ep_2 + real (kind=kind_phys) , intent(in) :: epsm1 real (kind=kind_phys) , intent(in) :: cp integer , intent(in) :: iz0tlnd !< z0t option integer , intent(in) :: itime !< integration time @@ -584,7 +588,7 @@ subroutine energy_glacier (nsnow ,nsoil ,isnow ,dt ,qsnow ,rhoair ! set psychrometric constant lathea = hsub - gamma = cpair*sfcprs/(0.622*lathea) + gamma = cpair*sfcprs/(ep_2*lathea) ! surface temperatures of the ground and energy fluxes @@ -594,7 +598,7 @@ subroutine energy_glacier (nsnow ,nsoil ,isnow ,dt ,qsnow ,rhoair eair ,stc ,sag ,snowh ,lathea ,sh2o , & !in thsfc_loc ,prslkix ,prsik1x ,prslk1x , & psfc ,pblhx ,iz0tlnd ,itime ,uu ,vv , & - sigmaf1 ,garea1 ,psi_opt ,ep_1, ep_2, cp, & !in + sigmaf1 ,garea1 ,psi_opt ,ep_1, ep_2, epsm1, cp, & !in #ifdef CCPP cm ,ch ,tg ,qsfc ,errmsg ,errflg , & !inout #else @@ -1034,7 +1038,7 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso eair ,stc ,sag ,snowh ,lathea ,sh2o , & !in thsfc_loc ,prslkix ,prsik1x ,prslk1x , & psfc ,pblhx ,iz0tlnd ,itime ,uu ,vv , & - sigmaf1 ,garea1 ,psi_opt ,ep_1, ep_2, cp, & !in + sigmaf1 ,garea1 ,psi_opt ,ep_1, ep_2, epsm1, cp, & !in #ifdef CCPP cm ,ch ,tgb ,qsfc ,errmsg ,errflg , & !inout #else @@ -1092,6 +1096,7 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso real (kind=kind_phys) , intent(in) :: psfc !< real (kind=kind_phys) , intent(in) :: ep_1 real (kind=kind_phys) , intent(in) :: ep_2 + real (kind=kind_phys) , intent(in) :: epsm1 real (kind=kind_phys) , intent(in) :: cp integer , intent(in) :: iz0tlnd !< integer , intent(in) :: itime !< integration time @@ -1266,11 +1271,11 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso call sfcdif1_glacier(iter ,zlvl ,zpd ,z0h ,z0m , & !in qair ,sfctmp ,h ,rhoair ,mpe ,ur , & !in #ifdef CCPP - & moz ,mozsgn ,fm ,fh ,fm2 ,fh2 ,errmsg, errflg, & !inout + & moz ,mozsgn ,fm ,fh ,fm2 ,fh2,fv, errmsg, errflg, & !inout #else - & moz ,mozsgn ,fm ,fh ,fm2 ,fh2 , & !inout + & moz ,mozsgn ,fm ,fh ,fm2 ,fh2,fv , & !inout #endif - & fv ,cm ,ch ,ch2) !out + & cm ,ch ,ch2) !out #ifdef CCPP if (errflg /= 0) return @@ -1364,7 +1369,7 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso else estg = esati end if - qsfc = 0.622*(estg*rhsur)/(sfcprs-0.378*(estg*rhsur)) + qsfc = ep_2*(estg*rhsur)/(sfcprs+epsm1*(estg*rhsur)) qfx = (qsfc-qair)*cev*gamma/cpair end do loop3 ! end stability iteration @@ -1437,7 +1442,7 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso else estg = esati end if - qsfc = 0.622*(estg*rhsur)/(sfcprs-0.378*(estg*rhsur)) + qsfc = ep_2*(estg*rhsur)/(sfcprs+epsm1*(estg*rhsur)) end do !sfc_diff3 iter end if !sfc_diff3 @@ -1453,7 +1458,7 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso t = tdc(tgb) ! mb: recalculate estg call esat(t, esatw, esati, dsatw, dsati) estg = esati - qsfc = 0.622*(estg*rhsur)/(sfcprs-0.378*(estg*rhsur)) + qsfc = ep_2*(estg*rhsur)/(sfcprs+epsm1*(estg*rhsur)) irb = cir * tgb**4 - emg*lwdn shb = csh * (tgb - sfctmp) evb = cev * (estg*rhsur - eair ) !estg reevaluate ? @@ -1545,12 +1550,12 @@ end subroutine esat subroutine sfcdif1_glacier(iter ,zlvl ,zpd ,z0h ,z0m , & !in qair ,sfctmp ,h ,rhoair ,mpe ,ur , & !in #ifdef CCPP - & moz ,mozsgn ,fm ,fh ,fm2 ,fh2 , & !inout - & errmsg ,errflg , & !inout + & moz ,mozsgn ,fm ,fh ,fm2 ,fh2 , fv, & !inout + & errmsg ,errflg , & !inout #else - & moz ,mozsgn ,fm ,fh ,fm2 ,fh2 , & !inout + & moz ,mozsgn ,fm ,fh ,fm2 ,fh2 , fv, & !inout #endif - & fv ,cm ,ch ,ch2 ) !out + & cm ,ch ,ch2 ) !out ! ------------------------------------------------------------------------------------------------- ! computing surface drag coefficient cm for momentum and ch for heat ! ------------------------------------------------------------------------------------------------- @@ -1576,6 +1581,7 @@ subroutine sfcdif1_glacier(iter ,zlvl ,zpd ,z0h ,z0m , & !in real (kind=kind_phys), intent(inout) :: fh !< sen heat stability correction, weighted by prior iters real (kind=kind_phys), intent(inout) :: fm2 !< sen heat stability correction, weighted by prior iters real (kind=kind_phys), intent(inout) :: fh2 !< sen heat stability correction, weighted by prior iters + real (kind=kind_phys), intent(inout) :: fv !< friction velocity (m/s) #ifdef CCPP character(len=*), intent(inout) :: errmsg @@ -1583,7 +1589,6 @@ subroutine sfcdif1_glacier(iter ,zlvl ,zpd ,z0h ,z0m , & !in #endif ! outputs - real (kind=kind_phys), intent(inout) :: fv !< friction velocity (m/s) real (kind=kind_phys), intent(out) :: cm !< drag coefficient for momentum real (kind=kind_phys), intent(out) :: ch !< drag coefficient for heat real (kind=kind_phys), intent(out) :: ch2 !< drag coefficient for heat diff --git a/physics/module_sf_noahmplsm.F90 b/physics/module_sf_noahmplsm.F90 index ff49a41cd..a685095aa 100644 --- a/physics/module_sf_noahmplsm.F90 +++ b/physics/module_sf_noahmplsm.F90 @@ -749,7 +749,7 @@ subroutine noahmp_sflx (parameters, & ! -------------------------------------------------------------------------------------------------- ! re-process atmospheric forcing - call atm (parameters,sfcprs ,sfctmp ,q2 , & + call atm (parameters,ep_2, epsm1, sfcprs ,sfctmp ,q2 , & prcpconv, prcpnonc,prcpshcv,prcpsnow,prcpgrpl,prcphail, & soldn ,cosz ,thair ,qair , & eair ,rhoair ,qprecc ,qprecl ,solad ,solai , & @@ -856,7 +856,7 @@ subroutine noahmp_sflx (parameters, & emissi ,pah ,canhs, & shg,shc,shb,evg,evb,ghv,ghb,irg,irc,irb,tr,evc,chleaf,chuc,chv2,chb2 ) !out - qsfcveg = eah*0.622/(sfcprs - 0.378*eah) + qsfcveg = eah*ep_2/(sfcprs + epsm1*eah) qsfcbare = qsfc qsfc = q1 !jref:end @@ -960,7 +960,7 @@ end subroutine noahmp_sflx !>\ingroup NoahMP_LSM !! re-precess atmospheric forcing. - subroutine atm (parameters,sfcprs ,sfctmp ,q2 , & + subroutine atm (parameters,ep_2,epsm1,sfcprs ,sfctmp ,q2 , & prcpconv,prcpnonc ,prcpshcv,prcpsnow,prcpgrpl,prcphail , & soldn ,cosz ,thair ,qair , & eair ,rhoair ,qprecc ,qprecl ,solad , solai , & @@ -973,6 +973,8 @@ subroutine atm (parameters,sfcprs ,sfctmp ,q2 , ! inputs type (noahmp_parameters), intent(in) :: parameters + real (kind=kind_phys) , intent(in) :: ep_2 !< + real (kind=kind_phys) , intent(in) :: epsm1 !< real (kind=kind_phys) , intent(in) :: sfcprs !< pressure (pa) real (kind=kind_phys) , intent(in) :: sfctmp !< surface air temperature [k] real (kind=kind_phys) , intent(in) :: q2 !< mixing ratio (kg/kg) @@ -1017,8 +1019,8 @@ subroutine atm (parameters,sfcprs ,sfctmp ,q2 , qair = q2 ! in wrf, driver converts to specific humidity - eair = qair*sfcprs / (0.622+0.378*qair) - rhoair = (sfcprs-0.378*eair) / (rair*sfctmp) + eair = qair*sfcprs / (ep_2-epsm1*qair) + rhoair = (sfcprs+epsm1*eair) / (rair*sfctmp) if(cosz <= 0.) then swdown = 0. @@ -2212,7 +2214,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in latheav = hsub frozen_canopy = .true. end if - gammav = cpair*sfcprs/(0.622*latheav) + gammav = cpair*sfcprs/(ep_2*latheav) if (tg .gt. tfrz) then latheag = hvap @@ -2221,14 +2223,14 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in latheag = hsub frozen_ground = .true. end if - gammag = cpair*sfcprs/(0.622*latheag) + gammag = cpair*sfcprs/(ep_2*latheag) ! if (sfctmp .gt. tfrz) then ! lathea = hvap ! else ! lathea = hsub ! end if -! gamma = cpair*sfcprs/(0.622*lathea) +! gamma = cpair*sfcprs/(ep_2*lathea) ! surface temperatures of the ground and canopy and energy fluxes @@ -2335,7 +2337,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in ts = fveg * tah + (1.0 - fveg) * tgb cm = fveg * cmv + (1.0 - fveg) * cmb ! better way to average? ch = fveg * chv + (1.0 - fveg) * chb - q1 = fveg * (eah*0.622/(sfcprs - 0.378*eah)) + (1.0 - fveg)*qsfc + q1 = fveg * (eah*ep_2/(sfcprs + epsm1*eah)) + (1.0 - fveg)*qsfc q2e = fveg * q2v + (1.0 - fveg) * q2b ! effectibe skin temperature @@ -4005,7 +4007,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & !jref - consistent surface specific humidity for sfcdif3 and sfcdif4 - qsfc = 0.622*eair/(psfc-0.378*eair) + qsfc = ep_2*eair/(psfc+epsm1*eair) ! canopy height hcan = parameters%hvt @@ -4092,11 +4094,11 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & zlvl ,zpd ,z0m ,z0h ,ur , & !in mpe ,iloc ,jloc , & !in #ifdef CCPP - moz ,mozsgn ,fm ,fh ,fm2 ,fh2 ,errmsg ,errflg ,& !inout + moz ,mozsgn ,fm ,fh ,fm2 ,fh2 ,fv, errmsg ,errflg ,& !inout #else - moz ,mozsgn ,fm ,fh ,fm2,fh2, & !inout + moz ,mozsgn ,fm ,fh ,fm2,fh2, fv, & !inout #endif - cm ,ch ,fv ,ch2 ) !out + cm ,ch ,ch2 ) !out #ifdef CCPP if (errflg /= 0) return #endif @@ -4191,10 +4193,10 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & end if if (opt_crs == 2) then ! jarvis - call canres (parameters,parsun,tv ,btran ,eah ,sfcprs, & !in + call canres (parameters,ep_2, epsm1,parsun,tv ,btran ,eah ,sfcprs, & !in rssun ,psnsun,iloc ,jloc ) !out - call canres (parameters,parsha,tv ,btran ,eah ,sfcprs, & !in + call canres (parameters,ep_2, epsm1,parsha,tv ,btran ,eah ,sfcprs, & !in rssha ,psnsha,iloc ,jloc ) !out end if end if @@ -4268,7 +4270,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & hg = rhoair*cpair*(tg - tah) /rahg ! consistent specific humidity from canopy air vapor pressure - qsfc = (0.622*eah)/(sfcprs-0.378*eah) + qsfc = (ep_2*eah)/(sfcprs+epsm1*eah) if ( opt_sfc == 4 ) then qfx = (qsfc-qair)*rhoair*caw @@ -4693,11 +4695,11 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & zlvl ,zpd ,z0m ,z0h ,ur , & !in mpe ,iloc ,jloc , & !in #ifdef CCPP - moz ,mozsgn ,fm ,fh ,fm2 ,fh2 ,errmsg ,errflg ,& !inout + moz ,mozsgn ,fm ,fh ,fm2 ,fh2 ,fv,errmsg ,errflg ,& !inout #else - moz ,mozsgn ,fm ,fh ,fm2 ,fh2 , & !inout + moz ,mozsgn ,fm ,fh ,fm2 ,fh2 ,fv, & !inout #endif - cm ,ch ,fv ,ch2 ) !out + cm ,ch ,ch2 ) !out #ifdef CCPP if (errflg /= 0) return #endif @@ -4814,7 +4816,7 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & else estg = esati end if - qsfc = 0.622*(estg*rhsur)/(psfc-0.378*(estg*rhsur)) + qsfc = ep_2*(estg*rhsur)/(psfc+epsm1*(estg*rhsur)) qfx = (qsfc-qair)*cev*gamma/cpair @@ -5041,11 +5043,11 @@ subroutine sfcdif1(parameters,iter ,sfctmp ,rhoair ,h ,qair , & !in & zlvl ,zpd ,z0m ,z0h ,ur , & !in & mpe ,iloc ,jloc , & !in #ifdef CCPP - & moz ,mozsgn ,fm ,fh ,fm2,fh2,errmsg,errflg, & !inout + & moz ,mozsgn ,fm ,fh ,fm2,fh2,fv,errmsg,errflg, & !inout #else - & moz ,mozsgn ,fm ,fh ,fm2,fh2, & !inout + & moz ,mozsgn ,fm ,fh ,fm2,fh2, fv, & !inout #endif - & cm ,ch ,fv ,ch2 ) !out + & cm ,ch ,ch2 ) !out ! ------------------------------------------------------------------------------------------------- ! computing surface drag coefficient cm for momentum and ch for heat ! ------------------------------------------------------------------------------------------------- @@ -5075,6 +5077,7 @@ subroutine sfcdif1(parameters,iter ,sfctmp ,rhoair ,h ,qair , & !in real (kind=kind_phys), intent(inout) :: fh !< sen heat stability correction, weighted by prior iters real (kind=kind_phys), intent(inout) :: fm2 !< sen heat stability correction, weighted by prior iters real (kind=kind_phys), intent(inout) :: fh2 !< sen heat stability correction, weighted by prior iters + real (kind=kind_phys), intent(inout) :: fv !< friction velocity (m/s) #ifdef CCPP character(len=*), intent(inout) :: errmsg integer, intent(inout) :: errflg @@ -5084,7 +5087,6 @@ subroutine sfcdif1(parameters,iter ,sfctmp ,rhoair ,h ,qair , & !in real (kind=kind_phys), intent(out) :: cm !< drag coefficient for momentum real (kind=kind_phys), intent(out) :: ch !< drag coefficient for heat - real (kind=kind_phys), intent(inout) :: fv !< friction velocity (m/s) real (kind=kind_phys), intent(out) :: ch2 !< drag coefficient for heat ! locals @@ -6127,7 +6129,7 @@ end subroutine stomata !! air temperature, atmospheric water vapor pressure deficit at the lowest !! model level, and soil moisture (preferably unfrozen soil moisture rather !! than total). - subroutine canres (parameters,par ,sfctmp,rcsoil ,eah ,sfcprs , & !in + subroutine canres (parameters,ep_2,epsm1,par ,sfctmp,rcsoil ,eah ,sfcprs , & !in rc ,psn ,iloc ,jloc ) !out ! -------------------------------------------------------------------------------------------------- @@ -6149,6 +6151,8 @@ subroutine canres (parameters,par ,sfctmp,rcsoil ,eah ,sfcprs , & !in type (noahmp_parameters), intent(in) :: parameters !< integer, intent(in) :: iloc !< grid index integer, intent(in) :: jloc !< grid index + real (kind=kind_phys), intent(in) :: ep_2 !< + real (kind=kind_phys), intent(in) :: epsm1 !< real (kind=kind_phys), intent(in) :: par !< par absorbed per unit sunlit lai (w/m2) real (kind=kind_phys), intent(in) :: sfctmp !< canopy air temperature real (kind=kind_phys), intent(in) :: sfcprs !< surface pressure (pa) @@ -6181,7 +6185,7 @@ subroutine canres (parameters,par ,sfctmp,rcsoil ,eah ,sfcprs , & !in ! compute q2 and q2sat - q2 = 0.622 * eah / (sfcprs - 0.378 * eah) !specific humidity [kg/kg] + q2 = ep_2 * eah / (sfcprs + epsm1 * eah) !specific humidity [kg/kg] q2 = q2 / (1.0 - q2) !mixing ratio [kg/kg] call calhum(parameters,sfctmp, sfcprs, q2sat, dqsdt2) diff --git a/physics/noahmpdrv.F90 b/physics/noahmpdrv.F90 index d4e84bd7d..4500d51a8 100644 --- a/physics/noahmpdrv.F90 +++ b/physics/noahmpdrv.F90 @@ -874,7 +874,7 @@ subroutine noahmpdrv_run & thsfc_loc ,prslkix ,prsik1x ,prslk1x , & air_pressure_surface ,pblhx ,iz0tlnd ,itime , & vegetation_frac ,area_grid ,psi_opt , & - con_fvirt ,con_eps ,con_cp , & + con_fvirt ,con_eps ,con_epsm1 ,con_cp , & snowfall ,snow_water_equiv_old ,snow_albedo_old , & cm_noahmp ,ch_noahmp ,snow_levels ,snow_water_equiv , & soil_moisture_vol ,interface_depth ,snow_depth ,snow_level_ice , & From a003a40555c27f356f3765ab81ed7c580a062ab9 Mon Sep 17 00:00:00 2001 From: "Haiqin.Li" Date: Mon, 12 Jun 2023 17:36:15 +0000 Subject: [PATCH 283/380] "a minor update of C3/GF" --- physics/cu_c3_driver.F90 | 20 ++++++++++++++------ physics/cu_c3_driver.meta | 15 +++++++++++++++ physics/cu_gf_driver.F90 | 5 +---- 3 files changed, 30 insertions(+), 10 deletions(-) diff --git a/physics/cu_c3_driver.F90 b/physics/cu_c3_driver.F90 index f367c5888..fd4d37b0b 100644 --- a/physics/cu_c3_driver.F90 +++ b/physics/cu_c3_driver.F90 @@ -68,7 +68,8 @@ subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& index_of_y_wind,index_of_process_scnv,index_of_process_dcnv, & fhour,fh_dfi_radar,ix_dfi_radar,num_dfi_radar,cap_suppress, & dfi_radar_max_intervals,ldiag3d,qci_conv,do_cap_suppress, & - sigmaout, maxupmf,ichoice_in,ichoicem_in,ichoice_s_in,errmsg,errflg) + sigmaout,maxupmf,maxMF,do_mynnedmf,ichoice_in,ichoicem_in, & + ichoice_s_in,errmsg,errflg) !------------------------------------------------------------- implicit none integer, parameter :: maxiens=1 @@ -93,7 +94,7 @@ subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& integer :: its,ite, jts,jte, kts,kte integer, intent(in ) :: im,km,ntracer integer, intent(in ) :: ichoice_in,ichoicem_in,ichoice_s_in - logical, intent(in ) :: flag_init, flag_restart + logical, intent(in ) :: flag_init, flag_restart, do_mynnedmf logical, intent(in ) :: flag_for_scnv_generic_tend,flag_for_dcnv_generic_tend, & do_ca,progsigma real (kind=kind_phys), intent(in) :: g,cp,fv,r_d,xlv,r_v @@ -127,7 +128,7 @@ subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& integer, dimension (:), intent(out) :: hbot,htop,kcnv integer, dimension (:), intent(in) :: xland - real(kind=kind_phys), dimension (:), intent(in) :: pbl + real(kind=kind_phys), dimension (:), intent(in) :: pbl,maxMF !$acc declare copyout(hbot,htop,kcnv) !$acc declare copyin(xland,pbl) integer, dimension (im) :: tropics @@ -639,6 +640,7 @@ subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& enddo do i = its,itf if(mconv(i).lt.0.)mconv(i)=0. + if((dx(i)<6500.).and.do_mynnedmf.and.(maxMF(i).gt.0.))ierr(i)=555 enddo !$acc end kernels if (dx(its)<6500.) then @@ -676,7 +678,13 @@ subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& !$acc kernels do i=its,itf - if(xmbs(i).gt.0.)cutens(i)=1. + if(xmbs(i).gt.0.)then + cutens(i)=1. + if (dx(i)<6500.) then + ierrm(i)=555 + ierr (i)=555 + endif + endif enddo !$acc end kernels !> - Call neg_check() for GF shallow convection @@ -936,8 +944,8 @@ subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& gdc(i,k,1)= max(0.,tun_rad_shall(i)*cupclws(i,k)*cutens(i)) ! my mod !gdc2(i,k,1)=max(0.,tun_rad_deep(i)*(cupclwm(i,k)*cutenm(i)+cupclw(i,k)*cuten(i))) - !gdc2(i,k,1)=max(0.,tun_rad_mid(i)*cupclwm(i,k)*cutenm(i)+tun_rad_deep(i)*cupclw(i,k)*cuten(i)+tun_rad_shall(i)*cupclws(i,k)*cutens(i)) - gdc2(i,k,1) = min(0.1, max(0.01, tun_rad_mid(i)*frhm(i)))*cupclwm(i,k)*cutenm(i) + min(0.1, max(0.01, tun_rad_deep(i)*(frhd(i))))*cupclw(i,k)*cuten(i) + tun_rad_shall(i)*cupclws(i,k)*cutens(i) + gdc2(i,k,1)=max(0.,tun_rad_mid(i)*cupclwm(i,k)*cutenm(i)+tun_rad_deep(i)*cupclw(i,k)*cuten(i)+tun_rad_shall(i)*cupclws(i,k)*cutens(i)) + !gdc2(i,k,1) = min(0.1, max(0.01, tun_rad_mid(i)*frhm(i)))*cupclwm(i,k)*cutenm(i) + min(0.1, max(0.01, tun_rad_deep(i)*(frhd(i))))*cupclw(i,k)*cuten(i) + tun_rad_shall(i)*cupclws(i,k)*cutens(i) qci_conv(i,k)=gdc2(i,k,1) gdc(i,k,2)=(outt(i,k))*86400. gdc(i,k,3)=(outtm(i,k))*86400. diff --git a/physics/cu_c3_driver.meta b/physics/cu_c3_driver.meta index 1e52d03fe..999b5c2bc 100644 --- a/physics/cu_c3_driver.meta +++ b/physics/cu_c3_driver.meta @@ -647,6 +647,21 @@ type = real kind = kind_phys intent = out +[maxMF] + standard_name = maximum_mass_flux + long_name = maximum mass flux within a column + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[do_mynnedmf] + standard_name = flag_for_mellor_yamada_nakanishi_niino_pbl_scheme + long_name = flag to activate MYNN-EDMF + units = flag + dimensions = () + type = logical + intent = in [ichoice_in] standard_name = identifier_for_c3_or_gf_deep_convection_closure long_name = flag for C3 or GF deep convection closure diff --git a/physics/cu_gf_driver.F90 b/physics/cu_gf_driver.F90 index 2cc91fd91..f82569b99 100644 --- a/physics/cu_gf_driver.F90 +++ b/physics/cu_gf_driver.F90 @@ -341,10 +341,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& edtd(:)=0. zdd(:,:)=0. flux_tun(:)=5. -! 10/11/2016 dx and tscl_kf are replaced with input dx(i), is dlength. ! dx for scale awareness -! dx=40075000./float(lonf) -! tscl_kf=dx/25000. !$acc end kernels if (imfshalcnv == 3) then @@ -629,7 +626,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& enddo do i = its,itf if(mconv(i).lt.0.)mconv(i)=0. - if(do_mynnedmf.and.(maxMF(i).gt.0.))ierr(i)=555 + if((dx(i)<6500.).and.do_mynnedmf.and.(maxMF(i).gt.0.))ierr(i)=555 enddo !$acc end kernels if (dx(its)<6500.) then From 3682e476db2e1899f58f1ae4ace8996438ba6a3f Mon Sep 17 00:00:00 2001 From: Anders Jensen Date: Wed, 14 Jun 2023 13:23:10 -0600 Subject: [PATCH 284/380] Rollback changes to rain evaporation --- physics/module_mp_thompson.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index 9ef110b63..38ee79dfa 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -3712,13 +3712,13 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & lamr = 1./ilamr(k) !> - Rapidly eliminate near zero values when low humidity (<95%) if (qv(k)/qvs(k) .lt. 0.95 .AND. rr(k)*orho.le.1.E-8) then - prv_rev(k) = rr(k)*odts + prv_rev(k) = rr(k)*orho*odts else prv_rev(k) = t1_evap*diffu(k)*(-ssatw(k))*N0_r(k)*rvs & * (t1_qr_ev*ilamr(k)**cre(10) & + t2_qr_ev*vsc2(k)*rhof2(k)*((lamr+0.5*fv_r)**(-cre(11)))) - rate_max = MIN((rr(k)*odts), (qvs(k)-qv(k))*rho(k)*odts) - prv_rev(k) = MIN(DBLE(rate_max*orho), prv_rev(k)*orho) + rate_max = MIN((rr(k)*orho*odts), (qvs(k)-qv(k))*odts) + prv_rev(k) = MIN(DBLE(rate_max), prv_rev(k)*orho) !..TEST: G. Thompson 10 May 2013 !> - Reduce the rain evaporation in same places as melting graupel occurs. From 7edf9921a065fd927574e4b27610803e11853f77 Mon Sep 17 00:00:00 2001 From: Helin Wei Date: Wed, 14 Jun 2023 15:40:51 -0400 Subject: [PATCH 285/380] update some data type --- physics/module_sf_noahmplsm.F90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/physics/module_sf_noahmplsm.F90 b/physics/module_sf_noahmplsm.F90 index a685095aa..98ac09d6d 100644 --- a/physics/module_sf_noahmplsm.F90 +++ b/physics/module_sf_noahmplsm.F90 @@ -3604,7 +3604,7 @@ subroutine twostream (parameters,ib ,ic ,vegtyp ,cosz ,vai , & ! tmp1 = b*b - c*c h = sqrt(tmp1) / avmu sigma = tmp0*tmp0 - tmp1 - if ( abs (sigma) < 1.e-6 ) sigma = sign(1.e-6,sigma) + if ( abs (sigma) < 1.e-6 ) sigma = sign(1.e-6_kind_phys,sigma) p1 = b + avmu*h p2 = b - avmu*h p3 = b + tmp0 @@ -4687,7 +4687,7 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & ! z0h = z0m !* exp(-czil*0.4*258.2*sqrt(fv*z0m)) ! end if call thermalz0(parameters,fveg,z0m,z0m,zlvl,zpd,zpd,ustarx, & !in - vegtyp,0.,ur,csigmaf0,csigmaf1,temptrs,temptrs,temptrs,0, & !in + vegtyp,0._kind_phys,ur,csigmaf0,csigmaf1,temptrs,temptrs,temptrs,0, & !in z0mo,z0h) if(opt_sfc == 1) then @@ -10772,13 +10772,13 @@ subroutine sfcdif4(iloc ,jloc ,ux ,vx ,t1d , & if ( present(iz0tlnd) ) then if ( iz0tlnd .le. 1 ) then call zilitinkevich_1995(znt,zt,zq,restar,& - ust,vkc,1.0,iz0tlnd,0,0.0) + ust,vkc,1.0_kind_phys,iz0tlnd,0,0.0) elseif ( iz0tlnd .eq. 2 ) then call yang_2008(znt,zt,zq,ust,molx,& qstar,restar,visc) elseif ( iz0tlnd .eq. 3 ) then !original mynn in wrf-arw used this form: - call garratt_1992(zt,zq,znt,restar,1.0) + call garratt_1992(zt,zq,znt,restar,1.0_kind_phys) endif ! the GFS option is removed along with gfs_z0_lnd @@ -10787,7 +10787,7 @@ subroutine sfcdif4(iloc ,jloc ,ux ,vx ,t1d , & !default to zilitinkevich call zilitinkevich_1995(znt,zt,zq,restar,& - ust,vkc,1.0,0,0,0.0) + ust,vkc,1.0_kind_phys,0,0,0.0) endif endif @@ -11522,7 +11522,7 @@ real*8 function psim_unstable_full(zolf) x=(1.-16.*zolf)**.25 !psimk=2*alog(0.5*(1+x))+alog(0.5*(1+x*x))-2.*atan(x)+2.*atan(1.) - psimk=2.*alog(0.5*(1+x))+alog(0.5*(1+x*x))-2.*atan(x)+2.*atan1 + psimk=2.*dlog(0.5*(1+x))+dlog(0.5*(1+x*x))-2.*atan(x)+2.*atan1 ym=(1.-10.*zolf)**onethird !psimc=(3./2.)*log((ym**2.+ym+1.)/3.)-sqrt(3.)*atan((2.*ym+1)/sqrt(3.))+4.*atan(1.)/sqrt(3.) From d61e8bc2a846be30ecf33a3a9569a14b66f8f809 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Wed, 14 Jun 2023 20:12:09 +0000 Subject: [PATCH 286/380] bug fixes for 32-bit physics in RRFS --- physics/GFS_phys_time_vary.fv3.F90 | 5 +- physics/aerinterp.F90 | 151 +++++++++++++++++++++++------ 2 files changed, 123 insertions(+), 33 deletions(-) diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index af6e5b18e..2ee1cb918 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -913,7 +913,10 @@ subroutine GFS_phys_time_vary_timestep_init ( fhour, iflip, jindx1_aer, jindx2_aer, & ddy_aer, iindx1_aer, & iindx2_aer, ddx_aer, & - levs, prsl, aer_nm) + levs, prsl, aer_nm, errmsg, errflg) + if(errflg /= 0) then + return + endif endif !> - Call gcycle() to repopulate specific time-varying surface properties for AMIP/forecast runs diff --git a/physics/aerinterp.F90 b/physics/aerinterp.F90 index 8ad446f30..4e2dc9047 100644 --- a/physics/aerinterp.F90 +++ b/physics/aerinterp.F90 @@ -15,6 +15,26 @@ module aerinterp contains + logical function netcdf_check(status, errmsg, errflg, why) + use netcdf + implicit none + character(len=*), intent(inout) :: errmsg + integer, intent(out) :: errflg + integer, intent(in) :: status + character(len=*), intent(in) :: why + + netcdf_check = (status == NF90_NOERR) + + if(netcdf_check) then + errflg = 0 + errmsg = ' ' + else + errflg = 1 + errmsg = trim(why) // ': ' // trim(nf90_strerror(status)) + endif + + END function netcdf_check + SUBROUTINE read_aerdata (me, master, iflip, idate, errmsg, errflg) use machine, only: kind_phys, kind_io4, kind_io8 use aerclm_def @@ -26,12 +46,16 @@ SUBROUTINE read_aerdata (me, master, iflip, idate, errmsg, errflg) integer, intent(inout) :: errflg !--- locals - integer :: ncid, varid, ndims, dim1, dim2, dim3, hmx + integer :: ncid, varid, ndims, hmx integer :: i, j, k, n, ii, imon, klev character :: fname*50, mn*2, vname*10 logical :: file_exist + integer :: dimids(NF90_MAX_VAR_DIMS) + integer :: dimlen(NF90_MAX_VAR_DIMS) + + errflg = 0 + errmsg = ' ' - integer, allocatable :: invardims(:) ! !! =================================================================== if (me == master) then @@ -60,25 +84,37 @@ SUBROUTINE read_aerdata (me, master, iflip, idate, errmsg, errflg) !! fetch dim spec and lat/lon from m01 data set !! =================================================================== fname=trim("aeroclim.m"//'01'//".nc") - call nf_open(fname , nf90_NOWRITE, ncid) + ncid = -1 + if(.not.netcdf_check(nf90_open(fname , nf90_NOWRITE, ncid), & + errmsg, errflg, 'open '//trim(fname))) then + return + endif vname = trim(specname(1)) - call nf_inq_varid(ncid, vname, varid) - call nf_inq_varndims(ncid, varid, ndims) - - if(.not. allocated(invardims)) allocate(invardims(3)) - call nf_inq_vardimid(ncid,varid,invardims) - call nf_inq_dimlen(ncid, invardims(1), dim1) - call nf_inq_dimlen(ncid, invardims(2), dim2) - call nf_inq_dimlen(ncid, invardims(3), dim3) + varid = -1 + if(.not.netcdf_check(nf90_inq_varid(ncid, vname, varid), & + errmsg, errflg, 'find id of '//trim(vname)//' var')) then + return + endif + ndims = 0 + if(.not.netcdf_check(nf90_inquire_variable(ncid, varid, ndims=ndims, dimids=dimids), & + errmsg, errflg, 'inquire details about '//trim(vname)//' var')) then + return + endif + do i=1,ndims + if(.not.netcdf_check(nf90_inquire_dimension(ncid, dimids(i), len=dimlen(i)), & + errmsg, errflg, 'inquire details about dimension')) then + return + endif + enddo ! specify latsaer, lonsaer, hmx - lonsaer = dim1 - latsaer = dim2 - levsw = dim3 + lonsaer = dimlen(1) + latsaer = dimlen(2) + levsw = dimlen(3) if(me==master) then - print *, 'MERRA2 dim: ',dim1, dim2, dim3 + print *, 'MERRA2 dim: ',dimlen(1:ndims) endif ! allocate arrays @@ -89,11 +125,29 @@ SUBROUTINE read_aerdata (me, master, iflip, idate, errmsg, errflg) endif ! construct lat/lon array - call nf_inq_varid(ncid, 'lat', varid) - call nf_get_var(ncid, varid, aer_lat) - call nf_inq_varid(ncid, 'lon', varid) - call nf_get_var(ncid, varid, aer_lon) - call nf_close(ncid) + varid = -1 + if(.not.netcdf_check(nf90_inq_varid(ncid, 'lat', varid), & + errmsg, errflg, 'find id of lat var')) then + return + endif + aer_lat = 0 + if(.not.netcdf_check(nf90_get_var(ncid, varid, aer_lat, (/ 1, 1, 1 /), (/latsaer, 1, 1/)), & + errmsg, errflg, 'read lat var')) then + return + endif + varid = -1 + if(.not.netcdf_check(nf90_inq_varid(ncid, 'lon', varid), & + errmsg, errflg, 'find id of lon var')) then + return + endif + aer_lon = 0 + if(.not.netcdf_check(nf90_get_var(ncid, varid, aer_lon, (/ 1, 1, 1 /), (/lonsaer, 1, 1/)), & + errmsg, errflg, 'read lon var')) then + return + endif + if(.not.netcdf_check(nf90_close(ncid), errmsg, errflg, 'close '//trim(fname))) then + return + endif END SUBROUTINE read_aerdata ! !********************************************************************** @@ -157,8 +211,10 @@ SUBROUTINE read_aerdataf ( me, master, iflip, idate, FHOUR, errmsg, errflg) n1 = n2 - 1 if (n2 > 12) n2 = n2 -12 !! =================================================================== - call read_netfaer(n1, iflip, 1) - call read_netfaer(n2, iflip, 2) + call read_netfaer(n1, iflip, 1, errmsg, errflg) + if(errflg/=0) return + call read_netfaer(n2, iflip, 2, errmsg, errflg) + if(errflg/=0) return !! =================================================================== n1sv=n1 n2sv=n2 @@ -224,12 +280,14 @@ END SUBROUTINE setindxaer !********************************************************************** ! SUBROUTINE aerinterpol( me,master,nthrds,npts,IDATE,FHOUR,iflip, jindx1,jindx2, & - ddy,iindx1,iindx2,ddx,lev,prsl,aerout) + ddy,iindx1,iindx2,ddx,lev,prsl,aerout, errmsg,errflg) ! use machine, only: kind_phys, kind_io4, kind_io8 use aerclm_def implicit none + integer, intent(inout) :: errflg + character(*), intent(inout) :: errmsg integer, intent(in) :: iflip integer i1,i2, iday,j,j1,j2,l,npts,nc,n1,n2,lev,k,i,ii, klev real(kind=kind_phys) fhour,temj, tx1, tx2,temi, tem @@ -252,6 +310,8 @@ SUBROUTINE aerinterpol( me,master,nthrds,npts,IDATE,FHOUR,iflip, jindx1,jindx2, integer w3kindreal,w3kindint ! + errflg = 0 + errmsg = ' ' IDAT = 0 IDAT(1) = IDATE(4) IDAT(2) = IDATE(2) @@ -298,7 +358,7 @@ SUBROUTINE aerinterpol( me,master,nthrds,npts,IDATE,FHOUR,iflip, jindx1,jindx2, enddo !j-loop (lat) ENDDO ! ii-loop (ntracaerm) !! =================================================================== - call read_netfaer(n2, iflip, 2) + call read_netfaer(n2, iflip, 2, errmsg, errflg) n1sv=n1 n2sv=n2 end if @@ -390,11 +450,13 @@ SUBROUTINE aerinterpol( me,master,nthrds,npts,IDATE,FHOUR,iflip, jindx1,jindx2, RETURN END SUBROUTINE aerinterpol - subroutine read_netfaer(nf, iflip,nt) + subroutine read_netfaer(nf, iflip,nt, errmsg,errflg) use machine, only: kind_phys, kind_io4, kind_io8 use aerclm_def use netcdf integer, intent(in) :: iflip, nf, nt + integer, intent(inout) :: errflg + character(*), intent(inout) :: errmsg integer :: ncid, varid, i,j,k,ii,klev character :: fname*50, mn*2, vname*10 real(kind=kind_io4),allocatable,dimension(:,:,:) :: buff @@ -406,13 +468,30 @@ subroutine read_netfaer(nf, iflip,nt) allocate (pres_tmp(lonsaer, levsw)) allocate (buffx(lonsaer, latsaer, levsw, 1)) + errflg = 0 + errmsg = ' ' + buff = 0 + pres_tmp = 0 + buffx = 0 + write(mn,'(i2.2)') nf fname=trim("aeroclim.m"//mn//".nc") - call nf_open(fname , nf90_NOWRITE, ncid) + ncid = -1 + if(.not.netcdf_check(nf90_open(fname , nf90_NOWRITE, ncid), & + errmsg, errflg, 'open '//trim(fname))) then + return + endif ! ====> construct 3-d pressure array (Pa) - call nf_inq_varid(ncid, "DELP", varid) - call nf_get_var(ncid, varid, buff) + varid = -1 + if(.not.netcdf_check(nf90_inq_varid(ncid, "DELP", varid), & + errmsg, errflg, 'find id of DELP var')) then + return + endif + if(.not.netcdf_check(nf90_get_var(ncid, varid, buff), & + errmsg, errflg, 'read DELP var')) then + return + endif do j = jamin, jamax do i = iamin, iamax @@ -441,8 +520,15 @@ subroutine read_netfaer(nf, iflip,nt) ! for GFS, iflip 0: toa to sfc; 1: sfc to toa DO ii = 1, ntrcaerm vname=trim(specname(ii)) - call nf_inq_varid(ncid, vname, varid) - call nf_get_var(ncid, varid, buffx) + varid = -1 + if(.not.netcdf_check(nf90_inq_varid(ncid, vname, varid), & + errmsg, errflg, 'get id of '//trim(vname)//' var')) then + return + endif + if(.not.netcdf_check(nf90_get_var(ncid, varid, buffx), & + errmsg, errflg, 'read '//trim(vname)//' var')) then + return + endif do j = jamin, jamax do k = 1, levsaer @@ -464,10 +550,11 @@ subroutine read_netfaer(nf, iflip,nt) ENDDO ! ii-loop (ntracaerm) ! close the file - call nf_close(ncid) + if(.not.netcdf_check(nf90_close(ncid), errmsg, errflg, 'close '//trim(fname))) then + return + endif deallocate (buff, pres_tmp) deallocate (buffx) - return END SUBROUTINE read_netfaer end module aerinterp From 07a38c685d1df610b9fbe6497606897cc1d968c3 Mon Sep 17 00:00:00 2001 From: Helin Wei Date: Thu, 15 Jun 2023 12:13:19 -0400 Subject: [PATCH 287/380] fixed rstoch data type --- physics/module_sf_noahmplsm.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/module_sf_noahmplsm.F90 b/physics/module_sf_noahmplsm.F90 index 98ac09d6d..273343d40 100644 --- a/physics/module_sf_noahmplsm.F90 +++ b/physics/module_sf_noahmplsm.F90 @@ -10772,7 +10772,7 @@ subroutine sfcdif4(iloc ,jloc ,ux ,vx ,t1d , & if ( present(iz0tlnd) ) then if ( iz0tlnd .le. 1 ) then call zilitinkevich_1995(znt,zt,zq,restar,& - ust,vkc,1.0_kind_phys,iz0tlnd,0,0.0) + ust,vkc,1.0_kind_phys,iz0tlnd,0,0.0_kind_phys) elseif ( iz0tlnd .eq. 2 ) then call yang_2008(znt,zt,zq,ust,molx,& qstar,restar,visc) @@ -10787,7 +10787,7 @@ subroutine sfcdif4(iloc ,jloc ,ux ,vx ,t1d , & !default to zilitinkevich call zilitinkevich_1995(znt,zt,zq,restar,& - ust,vkc,1.0_kind_phys,0,0,0.0) + ust,vkc,1.0_kind_phys,0,0,0.0_kind_phys) endif endif From 9859339985948e4d1fe2c721f7fab7830101dd72 Mon Sep 17 00:00:00 2001 From: dustinswales Date: Thu, 15 Jun 2023 11:17:35 -0600 Subject: [PATCH 288/380] Some changes --- physics/GFS_rrtmg_pre.F90 | 6 +++--- physics/GFS_rrtmg_pre.meta | 12 ++++++------ physics/GFS_rrtmgp_pre.F90 | 8 ++++---- physics/GFS_rrtmgp_pre.meta | 12 ++++++------ physics/ozphys_2015.F90 | 7 ++++--- physics/ozphys_2015.meta | 8 -------- 6 files changed, 23 insertions(+), 30 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index ae88ca0fc..cf9bbb6aa 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -45,7 +45,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& gasvmr_ccl4, gasvmr_cfc113, aerodp,ext550, clouds6, clouds7, clouds8, & clouds9, cldsa, cldfra, cldfra2d, lwp_ex,iwp_ex, lwp_fc,iwp_fc, & faersw1, faersw2, faersw3, faerlw1, faerlw2, faerlw3, alpha, & - aero_dir_fdb, fdb_coef, spp_wts_rad, spp_rad, ico2, latsozp, levozp, & + aero_dir_fdb, fdb_coef, spp_wts_rad, spp_rad, ico2, latsozc, levozc, & blatc, dphiozc, errmsg, errflg) use machine, only: kind_phys @@ -103,7 +103,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& imp_physics_nssl, & imp_physics_fer_hires, & yearlen, icloud, iaermdl, iaerflg, & - latsozp, levozp + latsozc, levozc integer, intent(in) :: & iovr, & ! choice of cloud-overlap method @@ -431,7 +431,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& enddo enddo else ! climatological ozone - call getozn (prslk1, xlat, im, lmk, top_at_1, latsozp, levozp, blatc, dphiozc, olyr) + call getozn (prslk1, xlat, im, lmk, top_at_1, latsozc, levozc, blatc, dphiozc, olyr) endif ! end_if_ntoz !> - Call coszmn(), to compute cosine of zenith angle (only when SW is called) diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 88363ef18..3b4d35c6d 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -1496,16 +1496,16 @@ dimensions = () type = integer intent = in -[latsozp] - standard_name = number_of_latitudes_in_ozone_data - long_name = number of latitude in ozone data +[latsozc] + standard_name = number_of_latitudes_in_ozone_climotology_data + long_name = number of latitude in ozone climotology data units = count dimensions = () type = integer intent = in -[levozp] - standard_name = number_of_levels_in_ozone_data - long_name = number of levels in ozone data +[levozc] + standard_name = number_of_levels_in_ozone_climotology_data + long_name = number of levels in ozone climotology data units = count dimensions = () type = integer diff --git a/physics/GFS_rrtmgp_pre.F90 b/physics/GFS_rrtmgp_pre.F90 index e9cbc3d23..dd72a6a1c 100644 --- a/physics/GFS_rrtmgp_pre.F90 +++ b/physics/GFS_rrtmgp_pre.F90 @@ -117,7 +117,7 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, doSWrad, doLWrad, fhswr, fhl vmr_n2o, vmr_co2, tsfg, tsfa, qs_lay, q_lay, tv_lay, & relhum, deltaZ, deltaZc, deltaP, active_gases_array, & tsfc_radtime, coszen, coszdg, top_at_1, iSFC, iTOA, nDay, idxday, semis, & - sfc_emiss_byband, ico2, latsozp, levozp, blatc, dphiozc, con_pi, errmsg, errflg) + sfc_emiss_byband, ico2, latsozc, levozc, blatc, dphiozc, con_pi, errmsg, errflg) ! Inputs integer, intent(in) :: & @@ -126,8 +126,8 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, doSWrad, doLWrad, fhswr, fhl nLev, & ! Number of vertical layers ico2, & ! Flag for co2 radiation scheme i_o3, & ! Index into tracer array for ozone - latsozp, & ! - levozp + latsozc, & ! + levozc logical, intent(in) :: & doSWrad, & ! Call SW radiation? doLWrad ! Call LW radiation @@ -354,7 +354,7 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, doSWrad, doLWrad, fhswr, fhl enddo ! OR Use climatological ozone data else - call getozn (prslk(1:NCOL,:), xlat, nCol, nLev, top_at_1, latsozp, levozp, blatc, & + call getozn (prslk(1:NCOL,:), xlat, nCol, nLev, top_at_1, latsozc, levozc, blatc, & dphiozc, o3_lay) endif diff --git a/physics/GFS_rrtmgp_pre.meta b/physics/GFS_rrtmgp_pre.meta index 47980b513..1a96eee1b 100644 --- a/physics/GFS_rrtmgp_pre.meta +++ b/physics/GFS_rrtmgp_pre.meta @@ -503,16 +503,16 @@ dimensions = (horizontal_loop_extent) type = integer intent = inout -[latsozp] - standard_name = number_of_latitudes_in_ozone_data - long_name = number of latitude in ozone data +[latsozc] + standard_name = number_of_latitudes_in_ozone_climotology_data + long_name = number of latitude in ozone climotology data units = count dimensions = () type = integer intent = in -[levozp] - standard_name = number_of_levels_in_ozone_data - long_name = number of levels in ozone data +[levozc] + standard_name = number_of_levels_in_ozone_climotology_data + long_name = number of levels in ozone climotology data units = count dimensions = () type = integer diff --git a/physics/ozphys_2015.F90 b/physics/ozphys_2015.F90 index 4e73a5262..fda87611c 100644 --- a/physics/ozphys_2015.F90 +++ b/physics/ozphys_2015.F90 @@ -3,7 +3,7 @@ !! ! ########################################################################################### module ozphys_2015 - use machine , only : kind_phys + use machine, only : kind_phys, kind_dbl_prec, kind_sngl_prec implicit none public ozphys_2015_init, ozphys_2015_timestep_init, ozphys_2015_run contains @@ -78,7 +78,7 @@ end subroutine ozphys_2015_init !! ! ########################################################################################### subroutine ozphys_2015_timestep_init(nPts, idate, fhour, jindx1, jindx2, latsozp, levozp, & - oz_coeff, timeoz, ozplin, oz_time, oz_pres, oz_lat, ddy, ozplout, errmsg, errflg) + oz_coeff, timeoz, ozplin, oz_time, oz_lat, ddy, ozplout, errmsg, errflg) ! Inputs integer, intent(in) :: & nPts, & ! Horizontal dimension @@ -95,7 +95,6 @@ subroutine ozphys_2015_timestep_init(nPts, idate, fhour, jindx1, jindx2, latsozp real(kind_phys), intent(in), dimension(:) :: & ddy, & ! Interpolation high index for ozone data oz_lat, & ! Latitudes for ozone data - oz_pres, & ! Levels for ozone data oz_time ! Time for ozone data real(kind_phys), intent(in), dimension(:,:,:,:) :: & ozplin ! Ozone data @@ -114,6 +113,8 @@ subroutine ozphys_2015_timestep_init(nPts, idate, fhour, jindx1, jindx2, latsozp real(kind_phys) :: tem, tx1, tx2, rjday real(8) :: rinc(5) real(4) :: rinc4(5) + !real(kind_dbl_prec) :: rinc(5) + !real(kind_sngl_prec) :: rinc4(5) ! Initialize CCPP error handling variables errmsg = '' diff --git a/physics/ozphys_2015.meta b/physics/ozphys_2015.meta index 59621b386..eab24baf1 100644 --- a/physics/ozphys_2015.meta +++ b/physics/ozphys_2015.meta @@ -166,14 +166,6 @@ type = real kind = kind_phys intent = in -[oz_pres] - standard_name = ozone_data_level_pressure - long_name = ozone data level pressure - units = Pa - dimensions = (number_of_levels_in_ozone_data) - type = real - kind = kind_phys - intent = in [oz_lat] standard_name = ozone_data_latitude long_name = ozone data latitude From f477bbb0a8c94a5ed5d486c55cbf023a22f73194 Mon Sep 17 00:00:00 2001 From: Helin Wei Date: Fri, 16 Jun 2023 15:51:47 -0400 Subject: [PATCH 289/380] delete some printout statements in sfcsub.f --- physics/sfcsub.F | 53 ------------------------------------------------ 1 file changed, 53 deletions(-) diff --git a/physics/sfcsub.F b/physics/sfcsub.F index 1ff8a41b2..5e27924ba 100644 --- a/physics/sfcsub.F +++ b/physics/sfcsub.F @@ -1123,9 +1123,6 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & snoclm(i) = 0. icefl1(i) = .true. enddo -! if(lprnt) print *,' tsffcsin=',tsffcs(iprnt) -! if(lprnt) print *,' slifcsin=',slifcs(iprnt) -! if(lprnt) print *,'slmskl=',slmskl(iprnt),' slmskw=',slmskw(iprnt) ! ! read climatology fields ! @@ -1155,13 +1152,9 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & &, imsk, jmsk, slmskh, rla, rlo, gausm, blnmsk, bltmsk,me &, lprnt,iprnt,fnalbc2,ialb,tile_num_ch,i_index,j_index) -! if(lprnt) print *,'tsfclm=',tsfclm(iprnt),' tsfcl2=',tsfcl2(iprnt) ! ! scale surface roughness and albedo to model required units ! -! do i=1,len -! print *, 'BEFORE QC socclm (i) is ',socclm (i) -! enddo zsca=100. call scale(zorclm,len,zsca) @@ -1237,7 +1230,6 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! if(lprnt) print *,' aisclm=',aisclm(iprnt),' sliclm=' ! &,sliclm(iprnt),' slmskw=',slmskw(iprnt) ! -! write(6,*) 'sliclm' ! znnt=1. ! call nntprt(sliclm,len,znnt) ! @@ -1358,11 +1350,6 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & socjmx,socjmn,socsmx,socsmn,epssoc, & rla,rlo,len,kqcm,percrit,lgchek,me) -! do i=1,len -! print *, 'AFTER QC socclm (i) is ',socclm (i) -! enddo - -! write(6,*) 'socclm after QC ' ! znnt=1. ! call nntprt(socclm,len,znnt) @@ -1466,9 +1453,6 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & vmnclm,vmxclm,slpclm,absclm, & len,lsoil) -! do i=1,len -! print *, 'AFTER FILANL (i) is ',socanl (i) -! enddo ! ! reverse scaling to match with grib analysis input ! @@ -1512,9 +1496,6 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & imsk, jmsk, slmskh, rla, rlo, gausm, blnmsk, bltmsk &, me, lanom) -! do i=1,len -! print *, 'AFTER ANALY (i) is ',socanl (i) -! enddo ! if(lprnt) print *,' tsfanl=',tsfanl(iprnt) ! @@ -1768,9 +1749,6 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & soclmx,soclmn,socomx,socomn,socimx,socimn, & socjmx,socjmn,socsmx,socsmn,epssoc, & rla,rlo,len,kqcm,percrit,lgchek,me) -! do i=1,len -! print *, 'AFTER QC (i) is ',socanl (i) -! enddo !clu [+16l]---------------------------------------------------------------------- ! call qcmxmn('vmna ',vmnanl,slianl,snoanl,icefl1, @@ -2027,10 +2005,6 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & socjmx,socjmn,socsmx,socsmn,epssoc, & rla,rlo,len,kqcm,percrit,lgchek,me) -! do i=1,len -! print *, 'AFTER QC SOCFCS(i) is ',socfcs (i) -! enddo - !clu [+16l] --------------------------------------------------------------- ! call qcmxmn('vmnf ',vmnfcs,slifcs,snofcs,icefl1, @@ -2260,17 +2234,11 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & sotlmx,sotlmn,sotomx,sotomn,sotimx,sotimn, & sotjmx,sotjmn,sotsmx,sotsmn,epssot, & rla,rlo,len,kqcm,percrit,lgchek,me) -! do i=1,len -! print *, 'BEFORE FINAL QC SOCANL(i) is ',socanl (i) -! enddo call qcmxmn('socm ',socanl,slmskl,snoanl,icefl1, & soclmx,soclmn,socomx,socomn,socimx,socimn, & socjmx,socjmn,socsmx,socsmn,epssoc, & rla,rlo,len,kqcm,percrit,lgchek,me) -! do i=1,len -! print *, 'AFTER FINAL QC SOCANL(i) is ',socanl (i) -! enddo !cwu [+8l] add sih, sic, call qcmxmn('sihm ',sihanl,slianl,snoanl,icefl1, & sihlmx,sihlmn,sihomx,sihomn,sihimx,sihimn, @@ -2822,8 +2790,6 @@ subroutine hmskrd(lugb,imsk,jmsk,fnmskh, & call fixrdg(lugb,imsk,jmsk,fnmskh, & kpds5,slmskh,gausm,blnmsk,bltmsk,me) -! print *,'in sfc_sub, aft fixrdg,slmskh=',maxval(slmskh), -! & minval(slmskh),'mdata=',mdata,'imsk*jmsk=',imsk*jmsk do i=1,imsk*jmsk slmskh(i) = nint(slmskh(i)) @@ -3585,9 +3551,6 @@ subroutine la2ga(regin,imxin,jmxin,rinlon,rinlat,rlon,rlat,inttyp,& & wi1j2*sums +wi2j2*sums ) & * wsumiv endif -! print *,' slmask=',slmask(i),' sums=',sums,' sumn=',sumn -! & ,' regin=',regin(i1,j2),regin(i2,j2),' j1=',j1,' j2=',j2 -! & ,' wij=',wi1j1, wi2j1, wi1j2, wi2j2,wsumiv else if (slmask(i) .eq. 1.0) then sums = sum1 @@ -5059,8 +5022,6 @@ subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & 100 format('rtsfl,ralbl,raisl,rsnol,rsmcl,rzorl,rvegl=',10f7.3) write(6,101) rtsfs,ralbs,raiss,rsnos,rsmcs,rzors,rvegs,rsics 101 format('rtsfs,ralbs,raiss,rsnos,rsmcs,rzors,rvegs,rsics=',11f7.3) -! print *,' ralfl=',ralfl,' ralfs=',ralfs,' rsotl=',rsotl -! *,' rsots=',rsots,' rvetl=',rvetl,' rvets=',rvets write(6,102) rsocl,rsocs 102 format('rsoc1, rsocs =',10f7.3) @@ -5125,17 +5086,6 @@ subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & print *, 'dbgx-- csnol, csnos:',csnol,csnos print *, 'dbgx-- rsnol, rsnos:',rsnol,rsnos endif - -! print *, rtsfs, qtsfs, raiss , qaiss -! *, rsnos , qsnos, rzors , qzors, rvegs , qvegs -! *, rvets , qvets, rsots , qsots -! *, rcv, rcvb, rcvt, qcv, qcvb, qcvt -! *, ralbs, qalbs, ralfs, qalfs -! print *, rtsfl, qtsfl, raisl , qaisl -! *, rsnol , qsnol, rzorl , qzorl, rvegl , qvegl -! *, rvetl , qvetl, rsotl , qsotl -! *, ralbl, qalbl, ralfl, qalfl -! ! len_thread_m = (len+num_threads-1) / num_threads @@ -7083,9 +7033,6 @@ subroutine gaulat(gaul,k) do n=1,k gaul(n) = acos(a(n)) * radi enddo -! -! print *,'gaussian lat (deg) for jmax=',k -! print *,(gaul(n),n=1,k) ! return 70 write(6,6000) From 84fd6c4866af72b8c6983796f52bc2e6e6124bd6 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Wed, 21 Jun 2023 22:55:15 -0400 Subject: [PATCH 290/380] update CODEOWNERS --- CODEOWNERS | 67 +++++++++++++++++++++++++++--------------------------- 1 file changed, 33 insertions(+), 34 deletions(-) diff --git a/CODEOWNERS b/CODEOWNERS index 189fabd95..8f53a50bc 100644 --- a/CODEOWNERS +++ b/CODEOWNERS @@ -11,26 +11,28 @@ # https://docs.google.com/spreadsheets/d/14y0Th_sSpCqlssEMNfSZ_Ni9wrpPqfpPY0kRG7jCZB8/edit#gid=0 # (Internal NOAA document.) -smoke/* @haiqinli @grantfirl @Qingfu-Liu @dustinswales -physics/aerclm_def.F @AnningCheng-NOAA @andrewgettelman @grantfirl @Qingfu-Liu @dustinswales +smoke_dust/* @haiqinli @grantfirl @Qingfu-Liu @dustinswales physics/aer_cloud.F @AnningCheng-NOAA @andrewgettelman @grantfirl @Qingfu-Liu @dustinswales +physics/aerclm_def.F @AnningCheng-NOAA @andrewgettelman @grantfirl @Qingfu-Liu @dustinswales physics/aerinterp.F90 @AnningCheng-NOAA @andrewgettelman @grantfirl @Qingfu-Liu @dustinswales physics/bl_mynn_common.f90 @joeolson42 @grantfirl @Qingfu-Liu @dustinswales physics/calpreciptype.f90 @grantfirl @Qingfu-Liu @dustinswales -physics/cires_orowam2017.f @grantfirl @Qingfu-Liu @dustinswales -physics/cires_tauamf_data.F90 @grantfirl @Qingfu-Liu @dustinswales -physics/cires_ugwp* @ValeryYudin-NOAA @mdtoyNOAA @grantfirl @Qingfu-Liu @dustinswales +physics/cires_orowam2017.f @mdtoyNOAA @grantfirl @Qingfu-Liu @dustinswales +physics/cires_tauamf_data.F90 @mdtoyNOAA @grantfirl @Qingfu-Liu @dustinswales +physics/cires_ugwp* @mdtoyNOAA @grantfirl @Qingfu-Liu @dustinswales physics/cldmacro.F @AnningCheng-NOAA @andrewgettelman @grantfirl @Qingfu-Liu @dustinswales physics/cldwat2m_micro.F @AnningCheng-NOAA @andrewgettelman @grantfirl @Qingfu-Liu @dustinswales +physics/clm_lake.* @tanyasmirnova @SamuelTrahanNOAA @grantfirl @Qingfu-Liu @dustinswales physics/cnvc90.* @grantfirl @Qingfu-Liu @dustinswales physics/cs_conv_aw_adj.* @AnningCheng-NOAA @grantfirl @Qingfu-Liu @dustinswales physics/cs_conv.* @AnningCheng-NOAA @grantfirl @Qingfu-Liu @dustinswales -physics/cu_gf* @hannahcbarnes @haiqinli @grantfirl @Qingfu-Liu @dustinswales -physics/cu_ntiedtke* @grantfirl @Qingfu-Liu @dustinswales +physics/cu_gf* @haiqinli @grantfirl @Qingfu-Liu @dustinswales +physics/cu_ntiedtke* @JongilHan66 @Qingfu-Liu @grantfirl @Qingfu-Liu @dustinswales +physics/cu_c3* @lisa-bengtsson @haiqinli @grantfirl @Qingfu-Liu @dustinswales physics/date_def.f @XuLi-NOAA @grantfirl @Qingfu-Liu @dustinswales physics/dcyc2t3.* @Qingfu-Liu @dustinswales @grantfirl @Qingfu-Liu @dustinswales physics/drag_suite.* @mdtoyNOAA @grantfirl @Qingfu-Liu @dustinswales -physics/flake* @YihuaWu-NOAA @grantfirl @Qingfu-Liu @dustinswales +physics/flake* @barlage @grantfirl @Qingfu-Liu @dustinswales physics/funcphys.f90 @grantfirl @Qingfu-Liu @dustinswales physics/fv_sat_adj.* @RuiyuSun @grantfirl @Qingfu-Liu @dustinswales physics/gcycle.F90 @grantfirl @Qingfu-Liu @dustinswales @@ -39,7 +41,7 @@ physics/get_prs_fv3.* physics/gfdl_cloud_microphys.* @RuiyuSun @grantfirl @Qingfu-Liu @dustinswales physics/GFDL_parse_tracers.F90 @grantfirl @Qingfu-Liu @dustinswales physics/gfdl_sfc_layer.* @ZhanZhang-NOAA @grantfirl @Qingfu-Liu @dustinswales -physics/GFS_cloud_diagnostics.* @dustinswales @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_cloud_diagnostics.* @dustinswales @Qingfu-Liu @grantfirl @Qingfu-Liu @dustinswales physics/GFS_DCNV_generic_post.* @grantfirl @Qingfu-Liu @dustinswales physics/GFS_DCNV_generic_pre.* @grantfirl @Qingfu-Liu @dustinswales physics/GFS_debug.* @grantfirl @Qingfu-Liu @dustinswales @@ -58,13 +60,11 @@ physics/GFS_rad_time_vary.fv3.* physics/GFS_rad_time_vary.scm.* @grantfirl @Qingfu-Liu @dustinswales physics/GFS_rrtmgp_cloud_mp.* @dustinswales @Qingfu-Liu @grantfirl @Qingfu-Liu @dustinswales physics/GFS_rrtmgp_cloud_overlap.* @dustinswales @Qingfu-Liu @grantfirl @Qingfu-Liu @dustinswales -physics/GFS_rrtmgp_lw_post.* @dustinswales @Qingfu-Liu @grantfirl @Qingfu-Liu @dustinswales physics/GFS_rrtmg_post.* @Qingfu-Liu @dustinswales @grantfirl @Qingfu-Liu @dustinswales physics/GFS_rrtmgp_pre.* @dustinswales @Qingfu-Liu @grantfirl @Qingfu-Liu @dustinswales physics/GFS_rrtmg_pre.* @Qingfu-Liu @dustinswales @grantfirl @Qingfu-Liu @dustinswales physics/GFS_rrtmgp_setup.* @dustinswales @Qingfu-Liu @grantfirl @Qingfu-Liu @dustinswales -physics/GFS_rrtmgp_sw_post.* @dustinswales @Qingfu-Liu @grantfirl @Qingfu-Liu @dustinswales -physics/GFS_rrtmgp_sw_pre.* @dustinswales @Qingfu-Liu @grantfirl @Qingfu-Liu @dustinswales +physics/GFS_rrtmgp_post.* @dustinswales @Qingfu-Liu @grantfirl @Qingfu-Liu @dustinswales physics/GFS_rrtmg_setup.* @Qingfu-Liu @dustinswales @grantfirl @Qingfu-Liu @dustinswales physics/GFS_SCNV_generic_post.* @grantfirl @Qingfu-Liu @dustinswales physics/GFS_SCNV_generic_pre.* @grantfirl @Qingfu-Liu @dustinswales @@ -92,7 +92,7 @@ physics/gwdc.* @Songyou184 physics/gwdps.* @Songyou184 @grantfirl @Qingfu-Liu @dustinswales physics/h2o_def.* @grantfirl @Qingfu-Liu @dustinswales physics/h2ointerp.f90 @grantfirl @Qingfu-Liu @dustinswales -physics/h2ophys.* @SMoorthi-emc @grantfirl @Qingfu-Liu @dustinswales +physics/h2ophys.* @Qingfu-Liu @grantfirl @Qingfu-Liu @dustinswales physics/hedmf.* @JongilHan66 @WeiguoWang-NOAA @grantfirl @Qingfu-Liu @dustinswales physics/iccn_def.F @grantfirl @Qingfu-Liu @dustinswales physics/iccninterp.F90 @grantfirl @Qingfu-Liu @dustinswales @@ -114,18 +114,18 @@ physics/module_BL_MYJPBL.* @Qingfu-Liu physics/module_bl_mynn.* @joeolson42 @grantfirl @Qingfu-Liu @dustinswales physics/module_gfdl_cloud_microphys.* @RuiyuSun @grantfirl @Qingfu-Liu @dustinswales physics/module_MP_FER_HIRES.* @ericaligo-NOAA @grantfirl @Qingfu-Liu @dustinswales -physics/module_mp_nssl_2mom.F90 @grantfirl @Qingfu-Liu @dustinswales +physics/module_mp_nssl_2mom.F90 @MicroTed @grantfirl @Qingfu-Liu @dustinswales physics/module_mp_radar.* @gthompsnWRF @RuiyuSun @grantfirl @Qingfu-Liu @dustinswales physics/module_mp_thompson* @gthompsnWRF @RuiyuSun @AndersJensen-NOAA @grantfirl @Qingfu-Liu @dustinswales physics/module_nst* @XuLi-NOAA @grantfirl @Qingfu-Liu @dustinswales -physics/module_sf_exchcoef.f90 @grantfirl @Qingfu-Liu @dustinswales +physics/module_sf_exchcoef.f90 @ZhanZhang-NOAA @grantfirl @Qingfu-Liu @dustinswales physics/module_SF_JSFC.F90 @Qingfu-Liu @grantfirl @Qingfu-Liu @dustinswales physics/module_sf_mynn.F90 @joeolson42 @grantfirl @Qingfu-Liu @dustinswales physics/module_sf_ruclsm.* @tanyasmirnova @grantfirl @Qingfu-Liu @dustinswales physics/module_soil_pre.* @tanyasmirnova @grantfirl @Qingfu-Liu @dustinswales -physics/moninshoc.* @SMoorthi-emc @grantfirl @Qingfu-Liu @dustinswales +physics/moninshoc.* @grantfirl @Qingfu-Liu @dustinswales physics/mp_fer_hires.* @ericaligo-NOAA @grantfirl @Qingfu-Liu @dustinswales -physics/mp_nssl.* @grantfirl @Qingfu-Liu @dustinswales +physics/mp_nssl.* @MicroTed @grantfirl @Qingfu-Liu @dustinswales physics/mp_thompson* @gthompsnWRF @RuiyuSun @AndersJensen-NOAA @grantfirl @Qingfu-Liu @dustinswales physics/multi_gases.F90 @RuiyuSun @grantfirl @Qingfu-Liu @dustinswales physics/myjpbl_wrapper.* @Qingfu-Liu @grantfirl @Qingfu-Liu @dustinswales @@ -137,35 +137,34 @@ physics/namelist_soilveg_ruc.* @tanyasmirnova physics/*noahmp* @barlage @cenlinhe @grantfirl @Qingfu-Liu @dustinswales physics/ozinterp.f90 @grantfirl @Qingfu-Liu @dustinswales physics/ozne_def.* @grantfirl @Qingfu-Liu @dustinswales -physics/ozphys* @SMoorthi-emc @grantfirl @Qingfu-Liu @dustinswales +physics/ozphys* @Qingfu-Liu @dustinswales @grantfirl @Qingfu-Liu @dustinswales physics/physcons.F90 @grantfirl @Qingfu-Liu @dustinswales physics/phys_tend.* @grantfirl @Qingfu-Liu @dustinswales physics/progsigma_calc.f90 @lisa-bengtsson @grantfirl @Qingfu-Liu @dustinswales physics/radcons.f90 @Qingfu-Liu @dustinswales @grantfirl @Qingfu-Liu @dustinswales -physics/radiation_aerosols.f @Qingfu-Liu @dustinswales @AnningCheng-NOAA @grantfirl @Qingfu-Liu @dustinswales +physics/radiation_aerosols.f @Qingfu-Liu @dustinswales @grantfirl @Qingfu-Liu @dustinswales physics/radiation_astronomy.f @Qingfu-Liu @dustinswales @grantfirl @Qingfu-Liu @dustinswales -physics/radiation_cloud_overlap.F90 @dustinswales @mjiacono @grantfirl @Qingfu-Liu @dustinswales +physics/radiation_cloud_overlap.F90 @Qingfu-Liu @dustinswales @grantfirl @Qingfu-Liu @dustinswales physics/radiation_clouds.f @Qingfu-Liu @dustinswales @grantfirl @Qingfu-Liu @dustinswales physics/radiation_gases.f @Qingfu-Liu @dustinswales @grantfirl @Qingfu-Liu @dustinswales physics/radiation_surface.* @Qingfu-Liu @dustinswales @grantfirl @Qingfu-Liu @dustinswales physics/radiation_tools.F90 @Qingfu-Liu @dustinswales @grantfirl @Qingfu-Liu @dustinswales physics/radlw_* @mjiacono @Qingfu-Liu @grantfirl @Qingfu-Liu @dustinswales physics/radsw_* @mjiacono @Qingfu-Liu @grantfirl @Qingfu-Liu @dustinswales -physics/rad_sw_pre.* @dustinswales @Qingfu-Liu @grantfirl @Qingfu-Liu @dustinswales -physics/rascnv.* @SMoorthi-emc @grantfirl @Qingfu-Liu @dustinswales +physics/rascnv.* @haiqinli @JongilHan66 @grantfirl @Qingfu-Liu @dustinswales physics/rayleigh_damp.* @yangfanglin @grantfirl @Qingfu-Liu @dustinswales -physics/rrtmg_lw_cloud_optics.F90 @dustinswales @grantfirl @Qingfu-Liu @dustinswales +physics/rrtmg_lw_cloud_optics.F90 @Qingfu-Liu @dustinswales @grantfirl @Qingfu-Liu @dustinswales physics/rrtmg_lw_post.* @Qingfu-Liu @dustinswales @grantfirl @Qingfu-Liu @dustinswales physics/rrtmg_lw_pre.* @Qingfu-Liu @dustinswales @grantfirl @Qingfu-Liu @dustinswales -physics/rrtmgp_aerosol_optics.* @dustinswales @grantfirl @Qingfu-Liu @dustinswales -physics/rrtmgp_lw_* @dustinswales @grantfirl @Qingfu-Liu @dustinswales -physics/rrtmgp_sw_* @dustinswales @grantfirl @Qingfu-Liu @dustinswales -physics/rrtmg_sw_cloud_optics.F90 @dustinswales @grantfirl @Qingfu-Liu @dustinswales +physics/rrtmgp_aerosol_optics.* @dustinswales @Qingfu-Liu @grantfirl @Qingfu-Liu @dustinswales +physics/rrtmgp_lw_* @dustinswales @Qingfu-Liu @grantfirl @Qingfu-Liu @dustinswales +physics/rrtmgp_sw_* @dustinswales @Qingfu-Liu @grantfirl @Qingfu-Liu @dustinswales +physics/rrtmg_sw_cloud_optics.F90 @dustinswales @Qingfu-Liu @grantfirl @Qingfu-Liu @dustinswales physics/rrtmg_sw_post.* @Qingfu-Liu @dustinswales @grantfirl @Qingfu-Liu @dustinswales -physics/rte-rrtmgp @RobertPincus @dustinswales @grantfirl @Qingfu-Liu @dustinswales +physics/rte-rrtmgp @dustinswales @Qingfu-Liu @grantfirl @Qingfu-Liu @dustinswales physics/samfdeepcnv.* @JongilHan66 @lisa-bengtsson @grantfirl @Qingfu-Liu @dustinswales physics/samfshalcnv.* @JongilHan66 @lisa-bengtsson @grantfirl @Qingfu-Liu @dustinswales -physics/samfaerosols.* @JongilHan66 @grantfirl @Qingfu-Liu @dustinswales +physics/samfaerosols.* @JongilHan66 @lisa-bengtsson @grantfirl @Qingfu-Liu @dustinswales physics/sascnvn.* @JongilHan66 @grantfirl @Qingfu-Liu @dustinswales physics/satmedmfvdif.* @JongilHan66 @grantfirl @Qingfu-Liu @dustinswales physics/satmedmfvdifq.* @JongilHan66 @grantfirl @Qingfu-Liu @dustinswales @@ -179,21 +178,21 @@ physics/sfc_diff.* @JongilHan66 physics/sfc_nst* @XuLi-NOAA @grantfirl @Qingfu-Liu @dustinswales physics/sfc_ocean.* @HelinWei-NOAA @grantfirl @Qingfu-Liu @dustinswales physics/sfc_sice.* @wd20xw @grantfirl @Qingfu-Liu @dustinswales -#physics/sfcsub.F @grantfirl @Qingfu-Liu @dustinswales +physics/sfcsub.F @grantfirl @Qingfu-Liu @dustinswales physics/sflx.f @HelinWei-NOAA @grantfirl @Qingfu-Liu @dustinswales physics/sgscloud_radpost.* @grantfirl @Qingfu-Liu @dustinswales physics/sgscloud_radpre.* @grantfirl @Qingfu-Liu @dustinswales physics/shalcnv.* @JongilHan66 @grantfirl @Qingfu-Liu @dustinswales -physics/shinhongvdif.* @grantfirl @Qingfu-Liu @dustinswales -physics/shoc.* @SMoorthi-emc @grantfirl @Qingfu-Liu @dustinswales +physics/shinhongvdif.* @Qingfu-Liu @WeiguoWang-NOAA @grantfirl @Qingfu-Liu @dustinswales +physics/shoc.* @grantfirl @Qingfu-Liu @dustinswales physics/surface_perturbation.* @HelinWei-NOAA @grantfirl @Qingfu-Liu @dustinswales physics/tridi.f @JongilHan66 @WeiguoWang-NOAA @grantfirl @Qingfu-Liu @dustinswales physics/ugwp_driver_v0.F @mdtoyNOAA @grantfirl @Qingfu-Liu @dustinswales physics/ugwpv1_gsldrag.* @mdtoyNOAA @grantfirl @Qingfu-Liu @dustinswales -physics/ugwpv1_gsldrag_post.* @grantfirl @Qingfu-Liu @dustinswales +physics/ugwpv1_gsldrag_post.* @mdtoyNOAA @grantfirl @Qingfu-Liu @dustinswales physics/unified_ugwp* @mdtoyNOAA @grantfirl @Qingfu-Liu @dustinswales physics/wv_saturation.F @AnningCheng-NOAA @andrewgettelman @grantfirl @Qingfu-Liu @dustinswales -physics/ysuvdif.* @grantfirl @Qingfu-Liu @dustinswales +physics/ysuvdif.* @Qingfu-Liu @WeiguoWang-NOAA @grantfirl @Qingfu-Liu @dustinswales physics/zhaocarr_gscond.* @RuiyuSun @grantfirl @Qingfu-Liu @dustinswales physics/zhaocarr_precpd.* @RuiyuSun @grantfirl @Qingfu-Liu @dustinswales From 85e3edb4ace98c50cc1ff031ccd9a3862843bca1 Mon Sep 17 00:00:00 2001 From: Helin Wei Date: Wed, 28 Jun 2023 19:45:42 -0400 Subject: [PATCH 291/380] noahmp table needed to be read in GFS_phys_time_vary.fv3 --- physics/GFS_phys_time_vary.fv3.F90 | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index 72f873b12..b11f7ecc2 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -36,7 +36,8 @@ module GFS_phys_time_vary use set_soilveg_mod, only: set_soilveg ! --- needed for Noah MP init - use noahmp_tables, only: laim_table,saim_table,sla_table, & + use noahmp_tables, only: read_mp_table_parameters, & + laim_table,saim_table,sla_table, & bexp_table,smcmax_table,smcwlt_table, & dwsat_table,dksat_table,psisat_table, & isurban_table,isbarren_table, & @@ -295,6 +296,10 @@ subroutine GFS_phys_time_vary_init ( !> - Initialize soil vegetation (needed for sncovr calculation further down) call set_soilveg(me, isot, ivegsrc, nlunit, errmsg, errflg) +!$OMP section +!> - read in NoahMP table (needed for NoahMP init) + call read_mp_table_parameters(errmsg, errflg) + !$OMP end sections ! Need an OpenMP barrier here (implicit in "end sections") From bb2af8cf67cd8c760cab8c72c022013ab43e3df0 Mon Sep 17 00:00:00 2001 From: "anning.cheng" Date: Wed, 28 Jun 2023 23:28:58 -0400 Subject: [PATCH 292/380] optimized the code and decrease the stratosphere warm bias for mraerosol=T --- physics/GFS_rrtmgp_cloud_mp.F90 | 7 +------ physics/module_mp_thompson.F90 | 20 ++++++++++++-------- physics/mp_thompson.F90 | 20 +++++++++++--------- 3 files changed, 24 insertions(+), 23 deletions(-) diff --git a/physics/GFS_rrtmgp_cloud_mp.F90 b/physics/GFS_rrtmgp_cloud_mp.F90 index 32104b7f8..79ae1559a 100644 --- a/physics/GFS_rrtmgp_cloud_mp.F90 +++ b/physics/GFS_rrtmgp_cloud_mp.F90 @@ -875,17 +875,12 @@ subroutine cmp_reff_Thompson(nLev, nCol, i_cldliq, i_cldice, i_cldsnow, i_cldice qi_mp(iCol,iLay) = tracer(iCol,iLay,i_cldice) / (1.-q_lay(iCol,iLay)) qs_mp(iCol,iLay) = tracer(iCol,iLay,i_cldsnow) / (1.-q_lay(iCol,iLay)) ni_mp(iCol,iLay) = tracer(iCol,iLay,i_cldice_nc) / (1.-q_lay(iCol,iLay)) - if (ltaerosol) then + if (ltaerosol .or. mraerosol) then nc_mp(iCol,iLay) = tracer(iCol,iLay,i_cldliq_nc) / (1.-q_lay(iCol,iLay)) nwfa(iCol,iLay) = tracer(iCol,iLay,i_twa) if (qc_mp(iCol,iLay) > 1.e-12 .and. nc_mp(iCol,iLay) < 100.) then nc_mp(iCol,iLay) = make_DropletNumber(qc_mp(iCol,iLay)*rho, nwfa(iCol,iLay)*rho) * orho endif - elseif (mraerosol) then - nc_mp(iCol,iLay) = tracer(iCol,iLay,i_cldliq_nc) / (1.-q_lay(iCol,iLay)) - if (qc_mp(iCol,iLay) > 1.e-12 .and. nc_mp(iCol,iLay) < 100.) then - nc_mp(iCol,iLay) = make_DropletNumber(qc_mp(iCol,iLay)*rho, nwfa(iCol,iLay)*rho) * orho - endif else if (nint(lsmask(iCol)) == 1) then !land nc_mp(iCol,iLay) = nt_c_l*orho diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index 6a4ef5e02..0c708cb3d 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -3400,8 +3400,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & tcond(k) = (5.69 + 0.0168*tempc)*1.0E-5 * 418.936 ocp(k) = 1./(Cp*(1.+0.887*qv(k))) lvt2(k)=lvap(k)*lvap(k)*ocp(k)*oRv*otemp*otemp - - nwfa(k) = MAX(11.1E6*rho(k), (nwfa1d(k) + nwfaten(k)*DT)*rho(k)) + if (is_aerosol_aware) & + nwfa(k) = MAX(11.1E6*rho(k), (nwfa1d(k) + nwfaten(k)*DT)*rho(k)) enddo do k = kts, kte @@ -3654,7 +3654,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & qvten(k) = qvten(k) - prw_vcd(k) qcten(k) = qcten(k) + prw_vcd(k) ncten(k) = ncten(k) + pnc_wcd(k) - nwfaten(k) = nwfaten(k) - pnc_wcd(k) + if (is_aerosol_aware) & + nwfaten(k) = nwfaten(k) - pnc_wcd(k) tten(k) = tten(k) + lvap(k)*ocp(k)*prw_vcd(k)*(1-IFDRY) rc(k) = MAX(R1, (qc1d(k) + DT*qcten(k))*rho(k)) if (rc(k).eq.R1) L_qc(k) = .false. @@ -3743,7 +3744,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & qrten(k) = qrten(k) - prv_rev(k) qvten(k) = qvten(k) + prv_rev(k) nrten(k) = nrten(k) - pnr_rev(k) - nwfaten(k) = nwfaten(k) + pnr_rev(k) + if (is_aerosol_aware) & + nwfaten(k) = nwfaten(k) + pnr_rev(k) tten(k) = tten(k) - lvap(k)*ocp(k)*prv_rev(k)*(1-IFDRY) rr(k) = MAX(R1, (qr1d(k) + DT*qrten(k))*rho(k)) @@ -4232,10 +4234,12 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & qv1d(k) = MAX(1.E-10, qv1d(k) + qvten(k)*DT) qc1d(k) = qc1d(k) + qcten(k)*DT nc1d(k) = MAX(2./rho(k), MIN(nc1d(k) + ncten(k)*DT, Nt_c_max)) - nwfa1d(k) = MAX(11.1E6, MIN(9999.E6, & - (nwfa1d(k)+nwfaten(k)*DT))) - nifa1d(k) = MAX(naIN1*0.01, MIN(9999.E6, & - (nifa1d(k)+nifaten(k)*DT))) + if (is_aerosol_aware) then + nwfa1d(k) = MAX(11.1E6, MIN(9999.E6, & + (nwfa1d(k)+nwfaten(k)*DT))) + nifa1d(k) = MAX(naIN1*0.01, MIN(9999.E6, & + (nifa1d(k)+nifaten(k)*DT))) + end if if (qc1d(k) .le. R1) then qc1d(k) = 0.0 nc1d(k) = 0.0 diff --git a/physics/mp_thompson.F90 b/physics/mp_thompson.F90 index e62e8a596..6a95a706c 100644 --- a/physics/mp_thompson.F90 +++ b/physics/mp_thompson.F90 @@ -151,6 +151,10 @@ subroutine mp_thompson_init(ncol, nlev, con_g, con_rd, con_eps, & !> - Convert specific humidity to water vapor mixing ratio. !> - Also, hydrometeor variables are mass or number mixing ratio !> - either kg of species per kg of dry air, or per kg of (dry + vapor). + if (merra2_aerosol_aware) then + call get_niwfa(aerfld, nifa, nwfa, ncol, nlev) + end if + qv = spechum/(1.0_kind_phys-spechum) @@ -163,7 +167,7 @@ subroutine mp_thompson_init(ncol, nlev, con_g, con_rd, con_eps, & ni = ni/(1.0_kind_phys-spechum) nr = nr/(1.0_kind_phys-spechum) - if (is_aerosol_aware) then + if (is_aerosol_aware .or. merra2_aerosol_aware) then nc = nc/(1.0_kind_phys-spechum) nwfa = nwfa/(1.0_kind_phys-spechum) nifa = nifa/(1.0_kind_phys-spechum) @@ -208,8 +212,6 @@ subroutine mp_thompson_init(ncol, nlev, con_g, con_rd, con_eps, & nwfa(i,k) = naCCN1+naCCN0*exp(-((hgt(i,k)-hgt(i,1))/1000.)*niCCN3) enddo enddo - else if (merra2_aerosol_aware) then - call get_niwfa(aerfld, nifa, nwfa, ncol, nlev) else if (mpirank==mpiroot) write(*,*) ' Apparently initial CCN aerosols are present.' if (MAXVAL(nwfa2d) .lt. eps) then @@ -555,6 +557,9 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & else dtstep = dtp end if + if (merra2_aerosol_aware) then + call get_niwfa(aerfld, nifa, nwfa, ncol, nlev) + end if !> - Convert specific humidity to water vapor mixing ratio. !> - Also, hydrometeor variables are mass or number mixing ratio @@ -574,7 +579,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ni = ni/(1.0_kind_phys-spechum) nr = nr/(1.0_kind_phys-spechum) - if (is_aerosol_aware) then + if (is_aerosol_aware .or. merra2_aerosol_aware) then nc = nc/(1.0_kind_phys-spechum) nwfa = nwfa/(1.0_kind_phys-spechum) nifa = nifa/(1.0_kind_phys-spechum) @@ -681,9 +686,6 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ncten3 => diag3d(:,:,36:36) qcten3 => diag3d(:,:,37:37) end if set_extended_diagnostic_pointers - if (merra2_aerosol_aware) then - call get_niwfa(aerfld, nifa, nwfa, ncol, nlev) - end if !> - Call mp_gt_driver() with or without aerosols, with or without effective radii, ... if (is_aerosol_aware .or. merra2_aerosol_aware) then call mp_gt_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, ni=ni, nr=nr, & @@ -921,8 +923,8 @@ subroutine get_niwfa(aerfld, nifa, nwfa, ncol, nlev) aerfld(:,:,4)/1011.5142+ aerfld(:,:,5)/5683.3501)*1.e15 nwfa=((aerfld(:,:,6)/0.0045435214+aerfld(:,:,7)/0.2907854+aerfld(:,:,8)/12.91224+ & - aerfld(:,:,9)/206.2216+ aerfld(:,:,10)/4326.23)*1.+aerfld(:,:,11)/0.3053104*5+ & - aerfld(:,:,15)/0.3232698*1)*1.e15 + aerfld(:,:,9)/206.2216+ aerfld(:,:,10)/4326.23)*9.+aerfld(:,:,11)/0.3053104*5+ & + aerfld(:,:,15)/0.3232698*8)*1.e15 end subroutine get_niwfa end module mp_thompson From 0a873dad283e900f72f546275b204f2469055ebf Mon Sep 17 00:00:00 2001 From: Helin Wei Date: Thu, 29 Jun 2023 19:03:51 -0400 Subject: [PATCH 293/380] initialize soil color in case no input data --- physics/sfcsub.F | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/physics/sfcsub.F b/physics/sfcsub.F index 5e27924ba..7be07b39c 100644 --- a/physics/sfcsub.F +++ b/physics/sfcsub.F @@ -8206,6 +8206,12 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil,slmskl,slmskw, & enddo endif +! initialize socclm in case there is no soil color data input + + do i=1,len + socclm(i) = 4. + enddo + if(fnsocc(1:8).ne.' ') then do i=1,len socclm(i) = soc(i) From 0c01b39356ede6fb4c653a4d76fc7c6fa50c18b3 Mon Sep 17 00:00:00 2001 From: Greg Thompson Date: Wed, 5 Jul 2023 13:24:02 -0600 Subject: [PATCH 294/380] bug fix the snow and graupel melting terms set to zero when sublimation happens instead of melting --- physics/module_mp_thompson.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index 59f2f8a65..41cdb7e94 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -3057,6 +3057,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & pnr_sml(k) = smo0(k)/rs(k)*prr_sml(k) * 10.0**(-0.25*tempc) ! RAIN2M pnr_sml(k) = MIN(DBLE(smo0(k)*odts), pnr_sml(k)) elseif (ssati(k).lt. 0.) then + prr_sml(k) = 0.0 prs_sde(k) = C_cube*t1_subl*diffu(k)*ssati(k)*rvs & * (t1_qs_sd*smo1(k) & + t2_qs_sd*rhof2(k)*vsc2(k)*smof(k)) @@ -3073,6 +3074,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & pnr_gml(k) = N0_g(k)*cgg(2)*ilamg(k)**cge(2) / rg(k) & ! RAIN2M * prr_gml(k) * 10.0**(-0.5*tempc) elseif (ssati(k).lt. 0.) then + prr_gml(k) = 0.0 prg_gde(k) = C_cube*t1_subl*diffu(k)*ssati(k)*rvs & * N0_g(k) * (t1_qg_sd*ilamg(k)**cge(10) & + t2_qg_sd*vsc2(k)*rhof2(k)*ilamg(k)**cge(11)) From 680e8419caa653c4b66face72781a8b3c6d62058 Mon Sep 17 00:00:00 2001 From: Helin Wei Date: Tue, 11 Jul 2023 07:32:02 -0400 Subject: [PATCH 295/380] use log to replace both alog and dlog --- physics/module_sf_noahmplsm.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/module_sf_noahmplsm.F90 b/physics/module_sf_noahmplsm.F90 index 273343d40..86853dabe 100644 --- a/physics/module_sf_noahmplsm.F90 +++ b/physics/module_sf_noahmplsm.F90 @@ -11522,7 +11522,7 @@ real*8 function psim_unstable_full(zolf) x=(1.-16.*zolf)**.25 !psimk=2*alog(0.5*(1+x))+alog(0.5*(1+x*x))-2.*atan(x)+2.*atan(1.) - psimk=2.*dlog(0.5*(1+x))+dlog(0.5*(1+x*x))-2.*atan(x)+2.*atan1 + psimk=2.*log(0.5*(1+x))+log(0.5*(1+x*x))-2.*atan(x)+2.*atan1 ym=(1.-10.*zolf)**onethird !psimc=(3./2.)*log((ym**2.+ym+1.)/3.)-sqrt(3.)*atan((2.*ym+1)/sqrt(3.))+4.*atan(1.)/sqrt(3.) From 2b6a7a4e9bce9f33c122f8df14521a2d985e3985 Mon Sep 17 00:00:00 2001 From: Man Zhang Date: Thu, 8 Jun 2023 09:21:49 -0600 Subject: [PATCH 296/380] Initiate SRW v3.0.0 SciDoc --- physics/clm_lake.f90 | 1128 ++++++++--------- physics/docs/ccppsrw3_doxyfile | 557 ++++++++ physics/docs/library.bib | 160 ++- physics/docs/pdftxt/CLM_LAKE.txt | 59 + physics/docs/pdftxt/CU_GF_deep.txt | 32 +- physics/docs/pdftxt/GFS_NOAHMP.txt | 18 +- physics/docs/pdftxt/GFS_UGWPv0.txt | 46 + physics/docs/pdftxt/GFS_v16_suite.txt | 4 +- physics/docs/pdftxt/HRRR_suite.txt | 2 +- physics/docs/pdftxt/NoahMP.txt | 41 - physics/docs/pdftxt/RAP_suite.txt | 2 +- .../docs/pdftxt/RE300/FV3_GFS_v16_input.nml | 335 +++++ physics/docs/pdftxt/RE300/FV3_HRRR_input.nml | 293 +++++ physics/docs/pdftxt/RE300/FV3_RAP_input.nml | 300 +++++ .../pdftxt/RE300/FV3_RRFS_v1beta_input.nml | 285 +++++ .../docs/pdftxt/RE300/FV3_WoFS_v0_input.nml | 291 +++++ .../namelists/input.nml.develop.FV3_GFS_v16 | 330 +++++ .../namelists/input.nml.develop.FV3_HRRR | 293 +++++ .../RE300/namelists/input.nml.develop.FV3_RAP | 300 +++++ .../input.nml.develop.FV3_RRFS_v1beta | 285 +++++ .../namelists/input.nml.develop.FV3_WoFS_v0 | 291 +++++ .../RE300/namelists/input.nml.v21.FV3_GFS_v16 | 336 +++++ .../RE300/namelists/input.nml.v21.FV3_HRRR | 299 +++++ .../namelists/input.nml.v21.FV3_RRFS_v1beta | 291 +++++ .../RE300/namelists/input.nml.v21.FV3_WoFS_v0 | 297 +++++ .../docs/pdftxt/RE300/suite_FV3_GFS_v16.xml | 94 ++ physics/docs/pdftxt/RE300/suite_FV3_HRRR.xml | 82 ++ physics/docs/pdftxt/RE300/suite_FV3_RAP.xml | 90 ++ .../pdftxt/RE300/suite_FV3_RRFS_v1beta.xml | 84 ++ .../docs/pdftxt/RE300/suite_FV3_WoFS_v0.xml | 80 ++ physics/docs/pdftxt/RUCLSM.txt | 93 +- physics/docs/pdftxt/SRW_all_shemes_list.txt | 3 + physics/docs/pdftxt/SRW_mainpage.txt | 5 +- physics/docs/pdftxt/THOMPSON.txt | 9 + 34 files changed, 6132 insertions(+), 683 deletions(-) create mode 100644 physics/docs/ccppsrw3_doxyfile create mode 100644 physics/docs/pdftxt/CLM_LAKE.txt delete mode 100644 physics/docs/pdftxt/NoahMP.txt create mode 100644 physics/docs/pdftxt/RE300/FV3_GFS_v16_input.nml create mode 100644 physics/docs/pdftxt/RE300/FV3_HRRR_input.nml create mode 100644 physics/docs/pdftxt/RE300/FV3_RAP_input.nml create mode 100644 physics/docs/pdftxt/RE300/FV3_RRFS_v1beta_input.nml create mode 100644 physics/docs/pdftxt/RE300/FV3_WoFS_v0_input.nml create mode 100644 physics/docs/pdftxt/RE300/namelists/input.nml.develop.FV3_GFS_v16 create mode 100644 physics/docs/pdftxt/RE300/namelists/input.nml.develop.FV3_HRRR create mode 100644 physics/docs/pdftxt/RE300/namelists/input.nml.develop.FV3_RAP create mode 100644 physics/docs/pdftxt/RE300/namelists/input.nml.develop.FV3_RRFS_v1beta create mode 100644 physics/docs/pdftxt/RE300/namelists/input.nml.develop.FV3_WoFS_v0 create mode 100644 physics/docs/pdftxt/RE300/namelists/input.nml.v21.FV3_GFS_v16 create mode 100644 physics/docs/pdftxt/RE300/namelists/input.nml.v21.FV3_HRRR create mode 100644 physics/docs/pdftxt/RE300/namelists/input.nml.v21.FV3_RRFS_v1beta create mode 100644 physics/docs/pdftxt/RE300/namelists/input.nml.v21.FV3_WoFS_v0 create mode 100644 physics/docs/pdftxt/RE300/suite_FV3_GFS_v16.xml create mode 100644 physics/docs/pdftxt/RE300/suite_FV3_HRRR.xml create mode 100644 physics/docs/pdftxt/RE300/suite_FV3_RAP.xml create mode 100644 physics/docs/pdftxt/RE300/suite_FV3_RRFS_v1beta.xml create mode 100644 physics/docs/pdftxt/RE300/suite_FV3_WoFS_v0.xml diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90 index 4fc4112ce..1728d28b5 100644 --- a/physics/clm_lake.f90 +++ b/physics/clm_lake.f90 @@ -1,4 +1,4 @@ -!> \file clm_lake.F90 +!> \file clm_lake.f90 !! Contains code related to the CLM lake model !! !! This lake scheme was taken from module_sf_lake in WRF 4.3.1, and @@ -7,7 +7,7 @@ !! The original documentation said: !! !! The lake scheme was retrieved from the Community Land Model version 4.5 -!! (Oleson et al. 2013) with some modifications by Gu et al. (2013). It is a +!! (Oleson et al. (2013) \cite Oleson2013) with some modifications by Gu et al. (2015) \cite Gu2015. It is a !! one-dimensional mass and energy balance scheme with 20-25 model layers, !! including up to 5 snow layers on the lake ice, 10 water layers, and 10 soil !! layers on the lake bottom. The lake scheme is used with actual lake points and @@ -15,15 +15,8 @@ !! lake points and lake depth in WRF (lake_min_elev and lakedepth_default). !! The lake scheme is independent of a land surface scheme and therefore !! can be used with any land surface scheme embedded in WRF. The lake scheme -!! developments and evaluations were included in Subin et al. (2012) and Gu et al. (2013) -!! -!! Subin et al. 2012: Improved lake model for climate simulations, J. Adv. Model. -!! -!! Earth Syst., 4, M02001. DOI:10.1029/2011MS000072; -!! -!! Gu et al. 2013: Calibration and validation of lake surface temperature simulations -!! -!! with the coupled WRF-Lake model. Climatic Change, 1-13, 10.1007/s10584-013-0978-y. +!! developments and evaluations were included in Subin et al. (2012) \cite Subin_2012 +!! and Gu et al. (2015) \cite Gu2015 . MODULE clm_lake @@ -46,26 +39,26 @@ MODULE clm_lake logical, parameter :: PERGRO = .false. logical, parameter :: USE_ETALAKE = .false. - real(kind_lake), parameter :: ETALAKE = 1.1925*50**(-0.424) ! Set this to your desired value if USE_ETALAKE=.true. + real(kind_lake), parameter :: ETALAKE = 1.1925*50**(-0.424) !< Set this to your desired value if USE_ETALAKE=.true. ! Level counts must be consistent with model (GFS_typedefs.F90) - integer, parameter :: nlevsoil = 10 ! number of soil layers - integer, parameter :: nlevlake = 10 ! number of lake layers - integer, parameter :: nlevsnow = 5 ! maximum number of snow layers - real(kind_lake), parameter :: scalez = 0.025_kind_lake ! Soil layer thickness discretization (m) + integer, parameter :: nlevsoil = 10 !< number of soil layers + integer, parameter :: nlevlake = 10 !< number of lake layers + integer, parameter :: nlevsnow = 5 !< maximum number of snow layers + real(kind_lake), parameter :: scalez = 0.025_kind_lake !< Soil layer thickness discretization (m) - integer,parameter :: lbp = 1 ! pft-index bounds + integer,parameter :: lbp = 1 !< pft-index bounds integer,parameter :: ubp = 1 - integer,parameter :: lbc = 1 ! column-index bounds + integer,parameter :: lbc = 1 !< column-index bounds integer,parameter :: ubc = 1 - integer,parameter :: num_shlakec = 1 ! number of columns in lake filter - integer,parameter :: filter_shlakec(1) = 1 ! lake filter (columns) - integer,parameter :: num_shlakep = 1 ! number of pfts in lake filter - integer,parameter :: filter_shlakep(1) = 1 ! lake filter (pfts) + integer,parameter :: num_shlakec = 1 !< number of columns in lake filter + integer,parameter :: filter_shlakec(1) = 1 !< lake filter (columns) + integer,parameter :: num_shlakep = 1 !< number of pfts in lake filter + integer,parameter :: filter_shlakep(1) = 1 !< lake filter (pfts) integer,parameter :: pcolumn(1) = 1 integer,parameter :: pgridcell(1) = 1 - integer,parameter :: cgridcell(1) = 1 ! gridcell index of column - integer,parameter :: clandunit(1) = 1 ! landunit index of column + integer,parameter :: cgridcell(1) = 1 !< gridcell index of column + integer,parameter :: clandunit(1) = 1 !< landunit index of column integer,parameter :: begg = 1 integer,parameter :: endg = 1 @@ -80,44 +73,44 @@ MODULE clm_lake logical,parameter :: lakpoi(1) = .true. !Initialize physical constants not available from model: - real(kind_lake), parameter :: tcrit = 2.5 !critical temperature to determine rain or snow - real(kind_lake), parameter :: tkwat = 0.6 !thermal conductivity of water [W/m/k] - real(kind_lake), parameter :: tkice = 2.290 !thermal conductivity of ice [W/m/k] - real(kind_lake), parameter :: tkairc = 0.023 !thermal conductivity of air [W/m/k] - real(kind_lake), parameter :: snow_bd = 250 !constant snow bulk density (only used in special case here) [kg/m^3] + real(kind_lake), parameter :: tcrit = 2.5 !< critical temperature to determine rain or snow + real(kind_lake), parameter :: tkwat = 0.6 !< thermal conductivity of water [W/m/k] + real(kind_lake), parameter :: tkice = 2.290 !< thermal conductivity of ice [W/m/k] + real(kind_lake), parameter :: tkairc = 0.023 !< thermal conductivity of air [W/m/k] + real(kind_lake), parameter :: snow_bd = 250 !< constant snow bulk density (only used in special case here) [kg/m^3] ! Constants that are copied from model values by clm_lake_init: - real(kind_lake) :: pi !ratio of the circumference of a circle to its diameter - real(kind_lake) :: vkc !von Karman constant [-] - real(kind_lake) :: grav !gravity constant [m/s2] - real(kind_lake) :: sb !stefan-boltzmann constant [W/m2/K4] - real(kind_lake) :: tfrz !freezing temperature [K] - real(kind_lake) :: denh2o !density of liquid water [kg/m3] - real(kind_lake) :: denice !density of ice [kg/m3] - real(kind_lake) :: cpice !Specific heat of ice [J/kg-K] - real(kind_lake) :: cpliq !Specific heat of water [J/kg-K] - real(kind_lake) :: hfus !Latent heat of fusion for ice [J/kg] - real(kind_lake) :: hvap !Latent heat of evap for water [J/kg] - real(kind_lake) :: hsub !Latent heat of sublimation [J/kg] - real(kind_lake) :: invhvap !1/hvap [kg/J] - real(kind_lake) :: invhsub !1/hsub [kg/J] - real(kind_lake) :: rair !gas constant for dry air [J/kg/K] - real(kind_lake) :: cpair !specific heat of dry air [J/kg/K] - real(kind_lake) :: con_eps !ratio of gas constants of air and water vapor [unitless] - real(kind_lake) :: one_minus_con_eps !1 - con_eps [unitless] - real(kind_lake) :: con_fvirt !1/con_eps - 1 [unitless] + real(kind_lake) :: pi !< ratio of the circumference of a circle to its diameter + real(kind_lake) :: vkc !< von Karman constant [-] + real(kind_lake) :: grav !< gravity constant [m/s2] + real(kind_lake) :: sb !< stefan-boltzmann constant [W/m2/K4] + real(kind_lake) :: tfrz !< freezing temperature [K] + real(kind_lake) :: denh2o !< density of liquid water [kg/m3] + real(kind_lake) :: denice !< density of ice [kg/m3] + real(kind_lake) :: cpice !< Specific heat of ice [J/kg-K] + real(kind_lake) :: cpliq !< Specific heat of water [J/kg-K] + real(kind_lake) :: hfus !< Latent heat of fusion for ice [J/kg] + real(kind_lake) :: hvap !< Latent heat of evap for water [J/kg] + real(kind_lake) :: hsub !< Latent heat of sublimation [J/kg] + real(kind_lake) :: invhvap !< 1/hvap [kg/J] + real(kind_lake) :: invhsub !< 1/hsub [kg/J] + real(kind_lake) :: rair !< gas constant for dry air [J/kg/K] + real(kind_lake) :: cpair !< specific heat of dry air [J/kg/K] + real(kind_lake) :: con_eps !< ratio of gas constants of air and water vapor [unitless] + real(kind_lake) :: one_minus_con_eps !< 1 - con_eps [unitless] + real(kind_lake) :: con_fvirt !< 1/con_eps - 1 [unitless] - real(kind_lake), public, parameter :: spval = 1.e36 !special value for missing data (ocean) - real(kind_lake), parameter :: depth_c = 50. !below the level t_lake3d will be 277.0 !mchen - real(kind_lake), parameter :: zero_h2o = 1e-12 !lower mixing ratio is is treated as zero + real(kind_lake), public, parameter :: spval = 1.e36 !< special value for missing data (ocean) + real(kind_lake), parameter :: depth_c = 50. !< below the level t_lake3d will be 277.0 !mchen + real(kind_lake), parameter :: zero_h2o = 1e-12 !< lower mixing ratio is is treated as zero ! These are tunable constants - real(kind_lake), parameter :: wimp = 0.05 !Water impermeable if porosity less than wimp - real(kind_lake), parameter :: ssi = 0.033 !Irreducible water saturation of snow - real(kind_lake), parameter :: cnfac = 0.5 !Crank Nicholson factor between 0 and 1 + real(kind_lake), parameter :: wimp = 0.05 !< Water impermeable if porosity less than wimp + real(kind_lake), parameter :: ssi = 0.033 !< Irreducible water saturation of snow + real(kind_lake), parameter :: cnfac = 0.5 !< Crank Nicholson factor between 0 and 1 ! Initialize water type constants - integer,parameter :: istsoil = 1 !soil "water" type + integer,parameter :: istsoil = 1 !tgs - 7nov19 - salinity effect on freezing point (Tanya, Stan, Trevor). + !! The Great Salt Lake (GSL), Utah lat/long (39.5-42.0,-111.5- -117.7). + !! The GSL's salinity is 270 ppt above ~41.22 N with freezing point of -24 C, + !! and 150 ppt south of ~41.22 N with freezing point -10 C (info from Trevor Alcott). + !! The fresh-water Willard Bay should be excluded from the box around the Great Salt + !! Lake: lat/long 41.3539, -112.102, HRRR i,j = 494,667 (info from Stan and Trevor). + !! + !! 1jun2020: reset the GSL freezing point to be -5 C, + !! and add a check (after call to LakeMain) to keep the lake ice free for the whole year. if ((xlon_d.gt.-117.7 .and. xlon_d.lt.-111.5) .and. & ! excludes Willard Bay .not. (xlon_d.gt.-112.104 .and. xlon_d.lt.-112.100))then @@ -800,69 +793,69 @@ SUBROUTINE LakeMain(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, & !I integer, intent(inout) :: errflg character(*), intent(inout) :: errmsg - real(kind_lake),intent(in) :: dtime ! timestep - real(kind_lake),intent(in) :: xlat_d, xlon_d ! grid location for debugging - real(kind_lake),intent(in) :: forc_t(1) ! atmospheric temperature (Kelvin) - real(kind_lake),intent(in) :: forc_pbot(1) ! atm bottom level pressure (Pa) - real(kind_lake),intent(in) :: forc_psrf(1) ! atmospheric surface pressure (Pa) - real(kind_lake),intent(in) :: forc_hgt(1) ! atmospheric reference height (m) - real(kind_lake),intent(in) :: forc_hgt_q(1) ! observational height of humidity [m] - real(kind_lake),intent(in) :: forc_hgt_t(1) ! observational height of temperature [m] - real(kind_lake),intent(in) :: forc_hgt_u(1) ! observational height of wind [m] - real(kind_lake),intent(in) :: forc_q(1) ! atmospheric specific humidity (kg/kg) - real(kind_lake),intent(in) :: forc_u(1) ! atmospheric wind speed in east direction (m/s) - real(kind_lake),intent(in) :: forc_v(1) ! atmospheric wind speed in north direction (m/s) + real(kind_lake),intent(in) :: dtime !< timestep + real(kind_lake),intent(in) :: xlat_d, xlon_d !< grid location for debugging + real(kind_lake),intent(in) :: forc_t(1) !< atmospheric temperature (Kelvin) + real(kind_lake),intent(in) :: forc_pbot(1) !< atm bottom level pressure (Pa) + real(kind_lake),intent(in) :: forc_psrf(1) !< atmospheric surface pressure (Pa) + real(kind_lake),intent(in) :: forc_hgt(1) !< atmospheric reference height (m) + real(kind_lake),intent(in) :: forc_hgt_q(1) !< observational height of humidity [m] + real(kind_lake),intent(in) :: forc_hgt_t(1) !< observational height of temperature [m] + real(kind_lake),intent(in) :: forc_hgt_u(1) !< observational height of wind [m] + real(kind_lake),intent(in) :: forc_q(1) !< atmospheric specific humidity (kg/kg) + real(kind_lake),intent(in) :: forc_u(1) !< atmospheric wind speed in east direction (m/s) + real(kind_lake),intent(in) :: forc_v(1) !< atmospheric wind speed in north direction (m/s) ! real(kind_lake),intent(in) :: forc_rho(1) ! density (kg/m**3) - real(kind_lake),intent(in) :: forc_lwrad(1) ! downward infrared (longwave) radiation (W/m**2) - real(kind_lake),intent(in) :: prec(1) ! snow or rain rate [mm/s] - real(kind_lake),intent(in) :: sabg(1) ! solar radiation absorbed by ground (W/m**2) - real(kind_lake),intent(in) :: lat(1) ! latitude (radians) - real(kind_lake),intent(in) :: z_lake(1,nlevlake) ! layer depth for lake (m) - real(kind_lake),intent(in) :: dz_lake(1,nlevlake) ! layer thickness for lake (m) - real(kind_lake),intent(out) :: ustar_out(1) ! friction velocity [m/s] - real(kind_lake), intent(in) :: lakedepth(1) ! column lake depth (m) + real(kind_lake),intent(in) :: forc_lwrad(1) !< downward infrared (longwave) radiation (W/m**2) + real(kind_lake),intent(in) :: prec(1) !< snow or rain rate [mm/s] + real(kind_lake),intent(in) :: sabg(1) !< solar radiation absorbed by ground (W/m**2) + real(kind_lake),intent(in) :: lat(1) !< latitude (radians) + real(kind_lake),intent(in) :: z_lake(1,nlevlake) !< layer depth for lake (m) + real(kind_lake),intent(in) :: dz_lake(1,nlevlake) !< layer thickness for lake (m) + real(kind_lake),intent(out) :: ustar_out(1) !< friction velocity [m/s] + real(kind_lake), intent(in) :: lakedepth(1) !< column lake depth (m) !!!!!!!!!!!!!!!!tep(in),hydro(in) ! real(kind_lake), intent(in) :: watsat(1,1:nlevsoil) ! volumetric soil water at saturation (porosity) !!!!!!!!!!!!!!!!hydro - logical , intent(in) :: do_capsnow(1) ! true => do snow capping - real(kind_lake), intent(in) :: watsat(1,nlevsoil) ! volumetric soil water at saturation (porosity) - real(kind_lake), intent(in) :: tksatu(1,nlevsoil) ! thermal conductivity, saturated soil [W/m-K] - real(kind_lake), intent(in) :: tkmg(1,nlevsoil) ! thermal conductivity, soil minerals [W/m-K] - real(kind_lake), intent(in) :: tkdry(1,nlevsoil) ! thermal conductivity, dry soil (W/m/Kelvin) - real(kind_lake), intent(in) :: csol(1,nlevsoil) ! heat capacity, soil solids (J/m**3/Kelvin) + logical , intent(in) :: do_capsnow(1) !< true => do snow capping + real(kind_lake), intent(in) :: watsat(1,nlevsoil) !< volumetric soil water at saturation (porosity) + real(kind_lake), intent(in) :: tksatu(1,nlevsoil) !< thermal conductivity, saturated soil [W/m-K] + real(kind_lake), intent(in) :: tkmg(1,nlevsoil) !< thermal conductivity, soil minerals [W/m-K] + real(kind_lake), intent(in) :: tkdry(1,nlevsoil) !< thermal conductivity, dry soil (W/m/Kelvin) + real(kind_lake), intent(in) :: csol(1,nlevsoil) !< heat capacity, soil solids (J/m**3/Kelvin) !in&out - real(kind_lake),intent(inout) :: h2osoi_vol(1,-nlevsnow+1:nlevsoil) ! volumetric soil water (0<=h2osoi_vol<=watsat)[m3/m3] - real(kind_lake),intent(inout) :: t_grnd(1) ! ground temperature (Kelvin) - real(kind_lake),intent(inout) :: h2osno(1) ! snow water (mm H2O) - real(kind_lake),intent(inout) :: snowdp(1) ! snow height (m) - real(kind_lake),intent(inout) :: z(1,-nlevsnow+1:nlevsoil) ! layer depth for snow & soil (m) - real(kind_lake),intent(inout) :: dz(1,-nlevsnow+1:nlevsoil) ! layer thickness for soil or snow (m) - real(kind_lake),intent(inout) :: t_soisno(1,-nlevsnow+1:nlevsoil) ! soil (or snow) temperature (Kelvin) - real(kind_lake),intent(inout) :: t_lake(1,nlevlake) ! lake temperature (Kelvin) - integer ,intent(inout) :: snl(1) ! number of snow layers - real(kind_lake),intent(inout) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) ! liquid water (kg/m2) - real(kind_lake),intent(inout) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) ! ice lens (kg/m2) - real(kind_lake),intent(inout) :: savedtke1(1) ! top level eddy conductivity from previous timestep (W/m.K) - real(kind_lake),intent(inout) :: zi(1,-nlevsnow+0:nlevsoil) ! interface level below a "z" level (m) - real(kind_lake),intent(inout) :: lake_icefrac(1,nlevlake) ! mass fraction of lake layer that is frozen + real(kind_lake),intent(inout) :: h2osoi_vol(1,-nlevsnow+1:nlevsoil) !< volumetric soil water (0<=h2osoi_vol<=watsat)[m3/m3] + real(kind_lake),intent(inout) :: t_grnd(1) !< ground temperature (Kelvin) + real(kind_lake),intent(inout) :: h2osno(1) !< snow water (mm H2O) + real(kind_lake),intent(inout) :: snowdp(1) !< snow height (m) + real(kind_lake),intent(inout) :: z(1,-nlevsnow+1:nlevsoil) !< layer depth for snow & soil (m) + real(kind_lake),intent(inout) :: dz(1,-nlevsnow+1:nlevsoil) !< layer thickness for soil or snow (m) + real(kind_lake),intent(inout) :: t_soisno(1,-nlevsnow+1:nlevsoil) !< soil (or snow) temperature (Kelvin) + real(kind_lake),intent(inout) :: t_lake(1,nlevlake) !< lake temperature (Kelvin) + integer ,intent(inout) :: snl(1) !< number of snow layers + real(kind_lake),intent(inout) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) !< liquid water (kg/m2) + real(kind_lake),intent(inout) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) !< ice lens (kg/m2) + real(kind_lake),intent(inout) :: savedtke1(1) !< top level eddy conductivity from previous timestep (W/m.K) + real(kind_lake),intent(inout) :: zi(1,-nlevsnow+0:nlevsoil) !< interface level below a "z" level (m) + real(kind_lake),intent(inout) :: lake_icefrac(1,nlevlake) !< mass fraction of lake layer that is frozen !out: - real(kind_lake),intent(out) :: eflx_gnet(1) !net heat flux into ground (W/m**2) - real(kind_lake),intent(out) :: eflx_lwrad_net(1) ! net infrared (longwave) rad (W/m**2) [+ = to atm] - real(kind_lake),intent(out) :: eflx_sh_tot(1) ! total sensible heat flux (W/m**2) [+ to atm] - real(kind_lake),intent(out) :: eflx_lh_tot(1) ! total latent heat flux (W/m8*2) [+ to atm] - real(kind_lake),intent(out) :: t_ref2m(1) ! 2 m height surface air temperature (Kelvin) - real(kind_lake),intent(out) :: q_ref2m(1) ! 2 m height surface specific humidity (kg/kg) - real(kind_lake),intent(out) :: taux(1) ! wind (shear) stress: e-w (kg/m/s**2) - real(kind_lake),intent(out) :: tauy(1) ! wind (shear) stress: n-s (kg/m/s**2) - real(kind_lake),intent(out) :: ram1(1) ! aerodynamical resistance (s/m) - ! for calculation of decay of eddy diffusivity with depth - ! Change the type variable to pass back to WRF. - real(kind_lake),intent(out) :: z0mg(1) ! roughness length over ground, momentum (m( + real(kind_lake),intent(out) :: eflx_gnet(1) !< net heat flux into ground (W/m**2) + real(kind_lake),intent(out) :: eflx_lwrad_net(1) !< net infrared (longwave) rad (W/m**2) [+ = to atm] + real(kind_lake),intent(out) :: eflx_sh_tot(1) !< total sensible heat flux (W/m**2) [+ to atm] + real(kind_lake),intent(out) :: eflx_lh_tot(1) !< total latent heat flux (W/m8*2) [+ to atm] + real(kind_lake),intent(out) :: t_ref2m(1) !< 2 m height surface air temperature (Kelvin) + real(kind_lake),intent(out) :: q_ref2m(1) !< 2 m height surface specific humidity (kg/kg) + real(kind_lake),intent(out) :: taux(1) !< wind (shear) stress: e-w (kg/m/s**2) + real(kind_lake),intent(out) :: tauy(1) !< wind (shear) stress: n-s (kg/m/s**2) + real(kind_lake),intent(out) :: ram1(1) !< aerodynamical resistance (s/m) + !! for calculation of decay of eddy diffusivity with depth + !! Change the type variable to pass back to WRF. + real(kind_lake),intent(out) :: z0mg(1) !< roughness length over ground, momentum (m( !local output @@ -989,6 +982,13 @@ SUBROUTINE LakeMain(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, & !I END SUBROUTINE LakeMain + ! DESCRIPTION: + !> Calculates lake temperatures and surface fluxes for shallow lakes. + !! + !! Shallow lakes have variable depth, possible snow layers above, freezing & thawing of lake water, + !! and soil layers with active temperature and gas diffusion below. + !! + !! WARNING: This subroutine assumes lake columns have one and only one pft. SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, & !i forc_hgt_t,forc_hgt_u,forc_q, & forc_u,forc_v,forc_lwrad,forc_snow, & @@ -1001,18 +1001,10 @@ SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, eflx_lh_grnd,t_veg,t_ref2m,q_ref2m,taux,tauy, & ram1,ws,ks,eflx_gnet,z0mg,ustar_out,errmsg,errflg,xlat_d,xlon_d) !============================================================================== - ! DESCRIPTION: - ! Calculates lake temperatures and surface fluxes for shallow lakes. - ! - ! Shallow lakes have variable depth, possible snow layers above, freezing & thawing of lake water, - ! and soil layers with active temperature and gas diffusion below. - ! - ! WARNING: This subroutine assumes lake columns have one and only one pft. - ! ! REVISION HISTORY: - ! Created by Zack Subin, 2009 - ! Reedited by Hongping Gu, 2010 - ! Updated for CCPP by Sam Trahan, 2022 + ! - Created by Zack Subin, 2009 + ! - Reedited by Hongping Gu, 2010 + ! - Updated for CCPP by Sam Trahan, 2022 !============================================================================== ! implicit none @@ -1021,62 +1013,62 @@ SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, !in: - integer, intent(inout) :: errflg - character(len=*), intent(inout) :: errmsg - real(kind_lake),intent(in) :: xlat_d,xlon_d - real(kind_lake),intent(in) :: forc_t(1) ! atmospheric temperature (Kelvin) - real(kind_lake),intent(in) :: forc_pbot(1) ! atmospheric pressure (Pa) - real(kind_lake),intent(in) :: forc_psrf(1) ! atmospheric surface pressure (Pa) - real(kind_lake),intent(in) :: forc_hgt(1) ! atmospheric reference height (m) - real(kind_lake),intent(in) :: forc_hgt_q(1) ! observational height of humidity [m] - real(kind_lake),intent(in) :: forc_hgt_t(1) ! observational height of temperature [m] - real(kind_lake),intent(in) :: forc_hgt_u(1) ! observational height of wind [m] - real(kind_lake),intent(in) :: forc_q(1) ! atmospheric specific humidity (kg/kg) - real(kind_lake),intent(in) :: forc_u(1) ! atmospheric wind speed in east direction (m/s) - real(kind_lake),intent(in) :: forc_v(1) ! atmospheric wind speed in north direction (m/s) - real(kind_lake),intent(in) :: forc_lwrad(1) ! downward infrared (longwave) radiation (W/m**2) + integer, intent(inout) :: errflg !< + character(len=*), intent(inout) :: errmsg !< + real(kind_lake),intent(in) :: xlat_d,xlon_d !< + real(kind_lake),intent(in) :: forc_t(1) !< atmospheric temperature (Kelvin) + real(kind_lake),intent(in) :: forc_pbot(1) !< atmospheric pressure (Pa) + real(kind_lake),intent(in) :: forc_psrf(1) !< atmospheric surface pressure (Pa) + real(kind_lake),intent(in) :: forc_hgt(1) !< atmospheric reference height (m) + real(kind_lake),intent(in) :: forc_hgt_q(1) !< observational height of humidity [m] + real(kind_lake),intent(in) :: forc_hgt_t(1) !< observational height of temperature [m] + real(kind_lake),intent(in) :: forc_hgt_u(1) !< observational height of wind [m] + real(kind_lake),intent(in) :: forc_q(1) !< atmospheric specific humidity (kg/kg) + real(kind_lake),intent(in) :: forc_u(1) !< atmospheric wind speed in east direction (m/s) + real(kind_lake),intent(in) :: forc_v(1) !< atmospheric wind speed in north direction (m/s) + real(kind_lake),intent(in) :: forc_lwrad(1) !< downward infrared (longwave) radiation (W/m**2) ! real(kind_lake),intent(in) :: forc_rho(1) ! density (kg/m**3) - real(kind_lake),intent(in) :: forc_snow(1) ! snow rate [mm/s] - real(kind_lake),intent(in) :: forc_rain(1) ! rain rate [mm/s] - real(kind_lake),intent(in) :: h2osno(1) ! snow water (mm H2O) - real(kind_lake),intent(in) :: snowdp(1) ! snow height (m) - real(kind_lake),intent(in) :: sabg(1) ! solar radiation absorbed by ground (W/m**2) - real(kind_lake),intent(in) :: lat(1) ! latitude (radians) - real(kind_lake),intent(in) :: dz(1,-nlevsnow+1:nlevsoil) ! layer thickness for soil or snow (m) - real(kind_lake),intent(in) :: dz_lake(1,nlevlake) ! layer thickness for lake (m) - real(kind_lake),intent(in) :: t_soisno(1,-nlevsnow+1:nlevsoil) ! soil (or snow) temperature (Kelvin) - real(kind_lake),intent(in) :: t_lake(1,nlevlake) ! lake temperature (Kelvin) - integer ,intent(in) :: snl(1) ! number of snow layers - real(kind_lake),intent(in) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) ! liquid water (kg/m2) - real(kind_lake),intent(in) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) ! ice lens (kg/m2) - real(kind_lake),intent(in) :: savedtke1(1) ! top level eddy conductivity from previous timestep (W/m.K) + real(kind_lake),intent(in) :: forc_snow(1) !< snow rate [mm/s] + real(kind_lake),intent(in) :: forc_rain(1) !< rain rate [mm/s] + real(kind_lake),intent(in) :: h2osno(1) !< snow water (mm H2O) + real(kind_lake),intent(in) :: snowdp(1) !< snow height (m) + real(kind_lake),intent(in) :: sabg(1) !< solar radiation absorbed by ground (W/m**2) + real(kind_lake),intent(in) :: lat(1) !< latitude (radians) + real(kind_lake),intent(in) :: dz(1,-nlevsnow+1:nlevsoil) !< layer thickness for soil or snow (m) + real(kind_lake),intent(in) :: dz_lake(1,nlevlake) !< layer thickness for lake (m) + real(kind_lake),intent(in) :: t_soisno(1,-nlevsnow+1:nlevsoil) !< soil (or snow) temperature (Kelvin) + real(kind_lake),intent(in) :: t_lake(1,nlevlake) !< lake temperature (Kelvin) + integer ,intent(in) :: snl(1) !< number of snow layers + real(kind_lake),intent(in) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) !< liquid water (kg/m2) + real(kind_lake),intent(in) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) !< ice lens (kg/m2) + real(kind_lake),intent(in) :: savedtke1(1) !< top level eddy conductivity from previous timestep (W/m.K) !inout: - real(kind_lake),intent(inout) :: t_grnd(1) ! ground temperature (Kelvin) + real(kind_lake),intent(inout) :: t_grnd(1) !< ground temperature (Kelvin) !out: - real(kind_lake),intent(out):: ustar_out(1) ! friction velocity [m/s] - real(kind_lake),intent(out):: qflx_prec_grnd(1) ! water onto ground including canopy runoff [kg/(m2 s)] - real(kind_lake),intent(out):: qflx_evap_soi(1) ! soil evaporation (mm H2O/s) (+ = to atm) - real(kind_lake),intent(out):: qflx_evap_tot(1) ! qflx_evap_soi + qflx_evap_veg + qflx_tran_veg - real(kind_lake),intent(out):: eflx_sh_grnd(1) ! sensible heat flux from ground (W/m**2) [+ to atm] - real(kind_lake),intent(out):: eflx_lwrad_out(1) ! emitted infrared (longwave) radiation (W/m**2) - real(kind_lake),intent(out):: eflx_lwrad_net(1) ! net infrared (longwave) rad (W/m**2) [+ = to atm] - real(kind_lake),intent(out):: eflx_soil_grnd(1) ! soil heat flux (W/m**2) [+ = into soil] - real(kind_lake),intent(out):: eflx_sh_tot(1) ! total sensible heat flux (W/m**2) [+ to atm] - real(kind_lake),intent(out):: eflx_lh_tot(1) ! total latent heat flux (W/m8*2) [+ to atm] - real(kind_lake),intent(out):: eflx_lh_grnd(1) ! ground evaporation heat flux (W/m**2) [+ to atm] - real(kind_lake),intent(out):: t_veg(1) ! vegetation temperature (Kelvin) - real(kind_lake),intent(out):: t_ref2m(1) ! 2 m height surface air temperature (Kelvin) - real(kind_lake),intent(out):: q_ref2m(1) ! 2 m height surface specific humidity (kg/kg) - real(kind_lake),intent(out):: taux(1) ! wind (shear) stress: e-w (kg/m/s**2) - real(kind_lake),intent(out):: tauy(1) ! wind (shear) stress: n-s (kg/m/s**2) - real(kind_lake),intent(out):: ram1(1) ! aerodynamical resistance (s/m) - real(kind_lake),intent(out):: ws(1) ! surface friction velocity (m/s) - real(kind_lake),intent(out):: ks(1) ! coefficient passed to ShalLakeTemperature - ! for calculation of decay of eddy diffusivity with depth - real(kind_lake),intent(out):: eflx_gnet(1) !net heat flux into ground (W/m**2) - ! Change the type variable to pass back to WRF. - real(kind_lake),intent(out):: z0mg(1) ! roughness length over ground, momentum (m( + real(kind_lake),intent(out):: ustar_out(1) !< friction velocity [m/s] + real(kind_lake),intent(out):: qflx_prec_grnd(1) !< water onto ground including canopy runoff [kg/(m2 s)] + real(kind_lake),intent(out):: qflx_evap_soi(1) !< soil evaporation (mm H2O/s) (+ = to atm) + real(kind_lake),intent(out):: qflx_evap_tot(1) !< qflx_evap_soi + qflx_evap_veg + qflx_tran_veg + real(kind_lake),intent(out):: eflx_sh_grnd(1) !< sensible heat flux from ground (W/m**2) [+ to atm] + real(kind_lake),intent(out):: eflx_lwrad_out(1) !< emitted infrared (longwave) radiation (W/m**2) + real(kind_lake),intent(out):: eflx_lwrad_net(1) !< net infrared (longwave) rad (W/m**2) [+ = to atm] + real(kind_lake),intent(out):: eflx_soil_grnd(1) !< soil heat flux (W/m**2) [+ = into soil] + real(kind_lake),intent(out):: eflx_sh_tot(1) !< total sensible heat flux (W/m**2) [+ to atm] + real(kind_lake),intent(out):: eflx_lh_tot(1) !< total latent heat flux (W/m8*2) [+ to atm] + real(kind_lake),intent(out):: eflx_lh_grnd(1) !< ground evaporation heat flux (W/m**2) [+ to atm] + real(kind_lake),intent(out):: t_veg(1) !< vegetation temperature (Kelvin) + real(kind_lake),intent(out):: t_ref2m(1) !< 2 m height surface air temperature (Kelvin) + real(kind_lake),intent(out):: q_ref2m(1) !< 2 m height surface specific humidity (kg/kg) + real(kind_lake),intent(out):: taux(1) !< wind (shear) stress: e-w (kg/m/s**2) + real(kind_lake),intent(out):: tauy(1) !< wind (shear) stress: n-s (kg/m/s**2) + real(kind_lake),intent(out):: ram1(1) !< aerodynamical resistance (s/m) + real(kind_lake),intent(out):: ws(1) !< surface friction velocity (m/s) + real(kind_lake),intent(out):: ks(1) !< coefficient passed to ShalLakeTemperature + !! for calculation of decay of eddy diffusivity with depth + real(kind_lake),intent(out):: eflx_gnet(1) !< net heat flux into ground (W/m**2) + !! Change the type variable to pass back to WRF. + real(kind_lake),intent(out):: z0mg(1) !< roughness length over ground, momentum (m( @@ -1566,22 +1558,22 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! watsat, tksatu, tkmg, tkdry, csol, dtime, & frac_iceold,qflx_snomelt,imelt,errmsg,errflg) !======================================================================================================= - ! !DESCRIPTION: - ! Calculates temperatures in the 20-25 layer column of (possible) snow, - ! lake water, and soil beneath lake. - ! Snow and soil temperatures are determined as in SoilTemperature, except - ! for appropriate boundary conditions at the top of the snow (the flux is fixed - ! to be the ground heat flux calculated in ShalLakeFluxes), the bottom of the snow - ! (adjacent to top lake layer), and the top of the soil (adjacent to the bottom - ! lake layer). Also, the soil is assumed to be always fully saturated (ShalLakeHydrology - ! will have to insure this). The whole column is solved simultaneously as one tridiagonal matrix. - ! Lake temperatures are determined from the Hostetler model as before, except now: - ! i) Lake water layers can freeze by any fraction and release latent heat; thermal - ! and mechanical properties are adjusted for ice fraction. - ! ii) Convective mixing (though not eddy diffusion) still occurs for frozen lakes. - ! iii) No sunlight is absorbed in the lake if there are snow layers. - ! iv) Light is allowed to reach the top soil layer (where it is assumed to be completely absorbed). - ! v) Lakes have variable depth, set ultimately in surface data set but now in initShalLakeMod. + ! DESCRIPTION: + !< Calculates temperatures in the 20-25 layer column of (possible) snow, + !! lake water, and soil beneath lake. + !! Snow and soil temperatures are determined as in SoilTemperature, except + !! for appropriate boundary conditions at the top of the snow (the flux is fixed + !! to be the ground heat flux calculated in ShalLakeFluxes), the bottom of the snow + !! (adjacent to top lake layer), and the top of the soil (adjacent to the bottom + !! lake layer). Also, the soil is assumed to be always fully saturated (ShalLakeHydrology + !! will have to insure this). The whole column is solved simultaneously as one tridiagonal matrix. + !! Lake temperatures are determined from the Hostetler model as before, except now: + !!\n i) Lake water layers can freeze by any fraction and release latent heat; thermal + !! and mechanical properties are adjusted for ice fraction. + !!\n ii) Convective mixing (though not eddy diffusion) still occurs for frozen lakes. + !!\n iii) No sunlight is absorbed in the lake if there are snow layers. + !!\n iv) Light is allowed to reach the top soil layer (where it is assumed to be completely absorbed). + !!\n v) Lakes have variable depth, set ultimately in surface data set but now in initShalLakeMod. ! ! Eddy + molecular diffusion: ! d ts d d ts 1 ds @@ -1652,49 +1644,49 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! implicit none !in: - integer, intent(inout) :: errflg - real(kind_lake), intent(in) :: watsat(1,nlevsoil) ! volumetric soil water at saturation (porosity) - real(kind_lake), intent(in) :: tksatu(1,nlevsoil) ! thermal conductivity, saturated soil [W/m-K] - real(kind_lake), intent(in) :: tkmg(1,nlevsoil) ! thermal conductivity, soil minerals [W/m-K] - real(kind_lake), intent(in) :: tkdry(1,nlevsoil) ! thermal conductivity, dry soil (W/m/Kelvin) - real(kind_lake), intent(in) :: csol(1,nlevsoil) ! heat capacity, soil solids (J/m**3/Kelvin) - character(*), intent(inout) :: errmsg - real(kind_lake), intent(in) :: t_grnd(1) ! ground temperature (Kelvin) - real(kind_lake), intent(inout) :: h2osno(1) ! snow water (mm H2O) - real(kind_lake), intent(in) :: sabg(1) ! solar radiation absorbed by ground (W/m**2) - real(kind_lake), intent(in) :: dz(1,-nlevsnow + 1:nlevsoil) ! layer thickness for snow & soil (m) - real(kind_lake), intent(in) :: dz_lake(1,nlevlake) ! layer thickness for lake (m) - real(kind_lake), intent(in) :: z(1,-nlevsnow+1:nlevsoil) ! layer depth for snow & soil (m) - real(kind_lake), intent(in) :: zi(1,-nlevsnow+0:nlevsoil) ! interface level below a "z" level (m) - ! the other z and dz variables - real(kind_lake), intent(in) :: z_lake(1,nlevlake) ! layer depth for lake (m) - real(kind_lake), intent(in) :: ws(1) ! surface friction velocity (m/s) - real(kind_lake), intent(in) :: ks(1) ! coefficient passed to ShalLakeTemperature - ! for calculation of decay of eddy diffusivity with depth - integer , intent(in) :: snl(1) ! negative of number of snow layers - real(kind_lake), intent(inout) :: eflx_gnet(1) ! net heat flux into ground (W/m**2) at the surface interface - real(kind_lake), intent(in) :: lakedepth(1) ! column lake depth (m) + integer, intent(inout) :: errflg !< + real(kind_lake), intent(in) :: watsat(1,nlevsoil) !< volumetric soil water at saturation (porosity) + real(kind_lake), intent(in) :: tksatu(1,nlevsoil) !< thermal conductivity, saturated soil [W/m-K] + real(kind_lake), intent(in) :: tkmg(1,nlevsoil) !< thermal conductivity, soil minerals [W/m-K] + real(kind_lake), intent(in) :: tkdry(1,nlevsoil) !< thermal conductivity, dry soil (W/m/Kelvin) + real(kind_lake), intent(in) :: csol(1,nlevsoil) !< heat capacity, soil solids (J/m**3/Kelvin) + character(*), intent(inout) :: errmsg !< + real(kind_lake), intent(in) :: t_grnd(1) !< ground temperature (Kelvin) + real(kind_lake), intent(inout) :: h2osno(1) !< snow water (mm H2O) + real(kind_lake), intent(in) :: sabg(1) !< solar radiation absorbed by ground (W/m**2) + real(kind_lake), intent(in) :: dz(1,-nlevsnow + 1:nlevsoil) !< layer thickness for snow & soil (m) + real(kind_lake), intent(in) :: dz_lake(1,nlevlake) !< layer thickness for lake (m) + real(kind_lake), intent(in) :: z(1,-nlevsnow+1:nlevsoil) !< layer depth for snow & soil (m) + real(kind_lake), intent(in) :: zi(1,-nlevsnow+0:nlevsoil) !< interface level below a "z" level (m) + !! the other z and dz variables + real(kind_lake), intent(in) :: z_lake(1,nlevlake) !< layer depth for lake (m) + real(kind_lake), intent(in) :: ws(1) !< surface friction velocity (m/s) + real(kind_lake), intent(in) :: ks(1) !< coefficient passed to ShalLakeTemperature + !! for calculation of decay of eddy diffusivity with depth + integer , intent(in) :: snl(1) !< negative of number of snow layers + real(kind_lake), intent(inout) :: eflx_gnet(1) !< net heat flux into ground (W/m**2) at the surface interface + real(kind_lake), intent(in) :: lakedepth(1) !< column lake depth (m) ! real(kind_lake), intent(in) :: watsat(1,nlevsoil) ! volumetric soil water at saturation (porosity) - real(kind_lake), intent(inout) :: snowdp(1) !snow height (m) - real(kind_lake), intent(in) :: dtime !timestep + real(kind_lake), intent(inout) :: snowdp(1) !< snow height (m) + real(kind_lake), intent(in) :: dtime !< timestep !out: - real(kind_lake), intent(out) :: eflx_sh_grnd(1) ! sensible heat flux from ground (W/m**2) [+ to atm] - real(kind_lake), intent(out) :: eflx_sh_tot(1) ! total sensible heat flux (W/m**2) [+ to atm] - real(kind_lake), intent(out) :: eflx_soil_grnd(1) ! heat flux into snow / lake (W/m**2) [+ = into soil] - ! Here this includes the whole lake radiation absorbed. - !real(kind_lake), intent(out) :: qmelt(1) ! snow melt [mm/s] [temporary] + real(kind_lake), intent(out) :: eflx_sh_grnd(1) !< sensible heat flux from ground (W/m**2) [+ to atm] + real(kind_lake), intent(out) :: eflx_sh_tot(1) !< total sensible heat flux (W/m**2) [+ to atm] + real(kind_lake), intent(out) :: eflx_soil_grnd(1) !< heat flux into snow / lake (W/m**2) [+ = into soil] + !! Here this includes the whole lake radiation absorbed. + !real(kind_lake), intent(out) :: qmelt(1) !< snow melt [mm/s] [temporary] - real(kind_lake), intent(inout) :: t_lake(1,nlevlake) ! lake temperature (Kelvin) - real(kind_lake), intent(inout) :: t_soisno(1,-nlevsnow+1:nlevsoil) ! soil (or snow) temperature (Kelvin) - real(kind_lake), intent(inout) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) ! liquid water (kg/m2) [for snow & soil layers] - real(kind_lake), intent(inout) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) ! ice lens (kg/m2) [for snow & soil layers] - real(kind_lake), intent(inout) :: lake_icefrac(1,nlevlake) ! mass fraction of lake layer that is frozen - real(kind_lake), intent(out) :: savedtke1(1) ! top level thermal conductivity (W/mK) - real(kind_lake), intent(out) :: frac_iceold(1,-nlevsnow+1:nlevsoil) ! fraction of ice relative to the tot water - real(kind_lake), intent(out) :: qflx_snomelt(1) !snow melt (mm H2O /s) - integer, intent(out) :: imelt(1,-nlevsnow+1:nlevsoil) !flag for melting (=1), freezing (=2), Not=0 (new) + real(kind_lake), intent(inout) :: t_lake(1,nlevlake) !< lake temperature (Kelvin) + real(kind_lake), intent(inout) :: t_soisno(1,-nlevsnow+1:nlevsoil) !< soil (or snow) temperature (Kelvin) + real(kind_lake), intent(inout) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) !< liquid water (kg/m2) [for snow & soil layers] + real(kind_lake), intent(inout) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) !< ice lens (kg/m2) [for snow & soil layers] + real(kind_lake), intent(inout) :: lake_icefrac(1,nlevlake) !< mass fraction of lake layer that is frozen + real(kind_lake), intent(out) :: savedtke1(1) !< top level thermal conductivity (W/mK) + real(kind_lake), intent(out) :: frac_iceold(1,-nlevsnow+1:nlevsoil) !< fraction of ice relative to the tot water + real(kind_lake), intent(out) :: qflx_snomelt(1) !< snow melt (mm H2O /s) + integer, intent(out) :: imelt(1,-nlevsnow+1:nlevsoil) !< flag for melting (=1), freezing (=2), Not=0 (new) ! OTHER LOCAL VARIABLES: @@ -2540,52 +2532,48 @@ end subroutine ShalLakeTemperature ! ! ROUTINE: SoilThermProp_Lake ! - ! !INTERFACE: + ! INTERFACE: + ! DESCRIPTION: + !> Calculation of thermal conductivities and heat capacities of + !! snow/soil layers + !!\n (1) The volumetric heat capacity is calculated as a linear combination + !! in terms of the volumetric fraction of the constituent phases. + !! + !!\n (2) The thermal conductivity of soil is computed from the algorithm of + !! Johansen (as reported by Farouki 1981), and of snow is from the + !! formulation used in SNTHERM (Jordan 1991). + !! The thermal conductivities at the interfaces between two neighboring + !! layers (j, j+1) are derived from an assumption that the flux across + !! the interface is equal to that from the node j to the interface and the + !! flux from the interface to the node j+1. + !! + !! For lakes, the proper soil layers (not snow) should always be saturated. subroutine SoilThermProp_Lake (snl,dz,zi,z,t_soisno,h2osoi_liq,h2osoi_ice, & watsat, tksatu, tkmg, tkdry, csol, tk, cv, tktopsoillay,errmsg,errflg) - ! - ! !DESCRIPTION: - ! Calculation of thermal conductivities and heat capacities of - ! snow/soil layers - ! (1) The volumetric heat capacity is calculated as a linear combination - ! in terms of the volumetric fraction of the constituent phases. - ! - ! (2) The thermal conductivity of soil is computed from the algorithm of - ! Johansen (as reported by Farouki 1981), and of snow is from the - ! formulation used in SNTHERM (Jordan 1991). - ! The thermal conductivities at the interfaces between two neighboring - ! layers (j, j+1) are derived from an assumption that the flux across - ! the interface is equal to that from the node j to the interface and the - ! flux from the interface to the node j+1. - ! - ! For lakes, the proper soil layers (not snow) should always be saturated. - ! - ! !USES: - implicit none !in - integer, intent(inout) :: errflg - character(*), intent(inout) :: errmsg - integer , intent(in) :: snl(1) ! number of snow layers - ! real(kind_lake), intent(in) :: h2osno(1) ! snow water (mm H2O) - real(kind_lake), intent(in) :: watsat(1,nlevsoil) ! volumetric soil water at saturation (porosity) - real(kind_lake), intent(in) :: tksatu(1,nlevsoil) ! thermal conductivity, saturated soil [W/m-K] - real(kind_lake), intent(in) :: tkmg(1,nlevsoil) ! thermal conductivity, soil minerals [W/m-K] - real(kind_lake), intent(in) :: tkdry(1,nlevsoil) ! thermal conductivity, dry soil (W/m/Kelvin) - real(kind_lake), intent(in) :: csol(1,nlevsoil) ! heat capacity, soil solids (J/m**3/Kelvin) - real(kind_lake), intent(in) :: dz(1,-nlevsnow+1:nlevsoil) ! layer thickness (m) - real(kind_lake), intent(in) :: zi(1,-nlevsnow+0:nlevsoil) ! interface level below a "z" level (m) - real(kind_lake), intent(in) :: z(1,-nlevsnow+1:nlevsoil) ! layer depth (m) - real(kind_lake), intent(in) :: t_soisno(1,-nlevsnow+1:nlevsoil) ! soil temperature (Kelvin) - real(kind_lake), intent(in) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) ! liquid water (kg/m2) - real(kind_lake), intent(in) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) ! ice lens (kg/m2) + integer, intent(inout) :: errflg + character(*), intent(inout) :: errmsg + integer , intent(in) :: snl(1) !< number of snow layers + ! real(kind_lake), intent(in) :: h2osno(1) !< snow water (mm H2O) + real(kind_lake), intent(in) :: watsat(1,nlevsoil) !< volumetric soil water at saturation (porosity) + real(kind_lake), intent(in) :: tksatu(1,nlevsoil) !< thermal conductivity, saturated soil [W/m-K] + real(kind_lake), intent(in) :: tkmg(1,nlevsoil) !< thermal conductivity, soil minerals [W/m-K] + real(kind_lake), intent(in) :: tkdry(1,nlevsoil) !< thermal conductivity, dry soil (W/m/Kelvin) + real(kind_lake), intent(in) :: csol(1,nlevsoil) !< heat capacity, soil solids (J/m**3/Kelvin) + real(kind_lake), intent(in) :: dz(1,-nlevsnow+1:nlevsoil) !< layer thickness (m) + real(kind_lake), intent(in) :: zi(1,-nlevsnow+0:nlevsoil) !< interface level below a "z" level (m) + real(kind_lake), intent(in) :: z(1,-nlevsnow+1:nlevsoil) !< layer depth (m) + real(kind_lake), intent(in) :: t_soisno(1,-nlevsnow+1:nlevsoil) !< soil temperature (Kelvin) + real(kind_lake), intent(in) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) !< liquid water (kg/m2) + real(kind_lake), intent(in) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) !< ice lens (kg/m2) !out - real(kind_lake), intent(out) :: cv(lbc:ubc,-nlevsnow+1:nlevsoil) ! heat capacity [J/(m2 K)] - real(kind_lake), intent(out) :: tk(lbc:ubc,-nlevsnow+1:nlevsoil) ! thermal conductivity [W/(m K)] - real(kind_lake), intent(out) :: tktopsoillay(lbc:ubc) ! thermal conductivity [W/(m K)] + real(kind_lake), intent(out) :: cv(lbc:ubc,-nlevsnow+1:nlevsoil) !< heat capacity [J/(m2 K)] + real(kind_lake), intent(out) :: tk(lbc:ubc,-nlevsnow+1:nlevsoil) !< thermal conductivity [W/(m K)] + real(kind_lake), intent(out) :: tktopsoillay(lbc:ubc) !< thermal conductivity [W/(m K)] !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !CALLED FROM: ! subroutine ShalLakeTemperature in this module. @@ -2754,6 +2742,24 @@ end subroutine SoilThermProp_Lake ! ROUTINE: PhaseChange_Lake ! ! !INTERFACE: + + ! DESCRIPTION: + !> Calculation of the phase change within snow, soil, & lake layers: + !!\n (1) Check the conditions for which the phase change may take place, + !! i.e., the layer temperature is great than the freezing point + !! and the ice mass is not equal to zero (i.e. melting), + !! or the layer temperature is less than the freezing point + !! and the liquid water mass is greater than the allowable supercooled + !! (i.e. freezing). + !!\n (2) Assess the amount of phase change from the energy excess (or deficit) + !! after setting the layer temperature to freezing point, depending on + !! how much water or ice is available. + !!\n (3) Re-adjust the ice and liquid mass, and the layer temperature: either to + !! the freezing point if enough water or ice is available to fully compensate, + !! or to a remaining temperature. + !! + !! The specific heats are assumed constant. Potential cycling errors resulting from + !! this assumption will be trapped at the end of ShalLakeTemperature. subroutine PhaseChange_Lake (snl,h2osno,dz,dz_lake, & !i t_soisno,h2osoi_liq,h2osoi_ice, & !i&o lake_icefrac,t_lake, snowdp, & !i&o @@ -2761,28 +2767,12 @@ subroutine PhaseChange_Lake (snl,h2osno,dz,dz_lake, & !i cv, cv_lake, & !i&o lhabs) !o !============================================================================================= - ! !DESCRIPTION: - ! Calculation of the phase change within snow, soil, & lake layers: - ! (1) Check the conditions for which the phase change may take place, - ! i.e., the layer temperature is great than the freezing point - ! and the ice mass is not equal to zero (i.e. melting), - ! or the layer temperature is less than the freezing point - ! and the liquid water mass is greater than the allowable supercooled - ! (i.e. freezing). - ! (2) Assess the amount of phase change from the energy excess (or deficit) - ! after setting the layer temperature to freezing point, depending on - ! how much water or ice is available. - ! (3) Re-adjust the ice and liquid mass, and the layer temperature: either to - ! the freezing point if enough water or ice is available to fully compensate, - ! or to a remaining temperature. - ! The specific heats are assumed constant. Potential cycling errors resulting from - ! this assumption will be trapped at the end of ShalLakeTemperature. - ! !CALLED FROM: + !CALLED FROM: ! subroutine ShalLakeTemperature in this module ! - ! !REVISION HISTORY: - ! 04/2009 Zack Subin: Initial code - ! June 2022 Sam Trahan: Modified for CCPP + !REVISION HISTORY: + ! - 04/2009 Zack Subin: Initial code + ! - June 2022 Sam Trahan: Modified for CCPP !============================================================================================== ! !USES: ! @@ -2790,29 +2780,29 @@ subroutine PhaseChange_Lake (snl,h2osno,dz,dz_lake, & !i implicit none !in: - integer , intent(in) :: snl(1) !number of snow layers - real(kind_lake), intent(inout) :: h2osno(1) !snow water (mm H2O) - real(kind_lake), intent(in) :: dz(1,-nlevsnow+1:nlevsoil) !layer thickness (m) - real(kind_lake), intent(in) :: dz_lake(1,nlevlake) !lake layer thickness (m) + integer , intent(in) :: snl(1) !< number of snow layers + real(kind_lake), intent(inout) :: h2osno(1) !< snow water (mm H2O) + real(kind_lake), intent(in) :: dz(1,-nlevsnow+1:nlevsoil) !< layer thickness (m) + real(kind_lake), intent(in) :: dz_lake(1,nlevlake) !< lake layer thickness (m) ! Needed in case snow height is less than critical value. !inout: - real(kind_lake), intent(inout) :: snowdp(1) !snow height (m) - real(kind_lake), intent(inout) :: t_soisno(1,-nlevsnow+1:nlevsoil) !soil temperature (Kelvin) - real(kind_lake), intent(inout) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) !liquid water (kg/m2) - real(kind_lake), intent(inout) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) !ice lens (kg/m2) - real(kind_lake), intent(inout) :: lake_icefrac(1,nlevlake) ! mass fraction of lake layer that is frozen - real(kind_lake), intent(inout) :: t_lake(1,nlevlake) ! lake temperature (Kelvin) + real(kind_lake), intent(inout) :: snowdp(1) !< snow height (m) + real(kind_lake), intent(inout) :: t_soisno(1,-nlevsnow+1:nlevsoil) !< soil temperature (Kelvin) + real(kind_lake), intent(inout) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) !< liquid water (kg/m2) + real(kind_lake), intent(inout) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) !< ice lens (kg/m2) + real(kind_lake), intent(inout) :: lake_icefrac(1,nlevlake) !< mass fraction of lake layer that is frozen + real(kind_lake), intent(inout) :: t_lake(1,nlevlake) !< lake temperature (Kelvin) !out: - real(kind_lake), intent(out) :: qflx_snomelt(1) !snow melt (mm H2O /s) - real(kind_lake), intent(out) :: eflx_snomelt(1) !snow melt heat flux (W/m**2) - integer, intent(out) :: imelt(1,-nlevsnow+1:nlevsoil) !flag for melting (=1), freezing (=2), Not=0 (new) + real(kind_lake), intent(out) :: qflx_snomelt(1) !< snow melt (mm H2O /s) + real(kind_lake), intent(out) :: eflx_snomelt(1) !< snow melt heat flux (W/m**2) + integer, intent(out) :: imelt(1,-nlevsnow+1:nlevsoil) !< flag for melting (=1), freezing (=2), Not=0 (new) !What's the sign of this? Is it just output? - real(kind_lake), intent(inout) :: cv(lbc:ubc,-nlevsnow+1:nlevsoil) ! heat capacity [J/(m2 K)] - real(kind_lake), intent(inout) :: cv_lake (lbc:ubc,1:nlevlake) ! heat capacity [J/(m2 K)] - real(kind_lake), intent(out):: lhabs(lbc:ubc) ! total per-column latent heat abs. (J/m^2) + real(kind_lake), intent(inout) :: cv(lbc:ubc,-nlevsnow+1:nlevsoil) !< heat capacity [J/(m2 K)] + real(kind_lake), intent(inout) :: cv_lake (lbc:ubc,1:nlevlake) !< heat capacity [J/(m2 K)] + real(kind_lake), intent(out):: lhabs(lbc:ubc) !< total per-column latent heat abs. (J/m^2) ! OTHER LOCAL VARIABLES: @@ -2972,7 +2962,19 @@ subroutine PhaseChange_Lake (snl,h2osno,dz,dz_lake, & !i end subroutine PhaseChange_Lake - + ! DESCRIPTION: + !> Calculation of Shallow Lake Hydrology. Full hydrology of snow layers is + !! done. However, there is no infiltration, and the water budget is balanced with + !! qflx_qrgwl. Lake water mass is kept constant. The soil is simply maintained at + !! volumetric saturation if ice melting frees up pore space. Likewise, if the water + !! portion alone at some point exceeds pore capacity, it is reduced. This is consistent + !! with the possibility of initializing the soil layer with excess ice. The only + !! real error with that is that the thermal conductivity will ignore the excess ice + !! (and accompanying thickness change). + !! + !! If snow layers are present over an unfrozen lake, and the top layer of the lake + !! is capable of absorbing the latent heat without going below freezing, + !! the snow-water is runoff and the latent heat is subtracted from the lake. subroutine ShalLakeHydrology(dz_lake,forc_rain,forc_snow, & !i begwb,qflx_evap_tot,forc_t,do_capsnow, & t_grnd,qflx_evap_soi, & @@ -2991,19 +2993,6 @@ subroutine ShalLakeHydrology(dz_lake,forc_rain,forc_snow, & dtime,errmsg,errflg) !================================================================================== - ! !DESCRIPTION: - ! Calculation of Shallow Lake Hydrology. Full hydrology of snow layers is - ! done. However, there is no infiltration, and the water budget is balanced with - ! qflx_qrgwl. Lake water mass is kept constant. The soil is simply maintained at - ! volumetric saturation if ice melting frees up pore space. Likewise, if the water - ! portion alone at some point exceeds pore capacity, it is reduced. This is consistent - ! with the possibility of initializing the soil layer with excess ice. The only - ! real error with that is that the thermal conductivity will ignore the excess ice - ! (and accompanying thickness change). - ! - ! If snow layers are present over an unfrozen lake, and the top layer of the lake - ! is capable of absorbing the latent heat without going below freezing, - ! the snow-water is runoff and the latent heat is subtracted from the lake. ! ! WARNING: This subroutine assumes lake columns have one and only one pft. ! @@ -3034,79 +3023,79 @@ subroutine ShalLakeHydrology(dz_lake,forc_rain,forc_snow, & integer, intent(inout) :: errflg character(*), intent(inout) :: errmsg - real(kind_lake) :: watsat(1,nlevsoil) ! volumetric soil water at saturation (porosity) - real(kind_lake) :: tksatu(1,nlevsoil) ! thermal conductivity, saturated soil [W/m-K] - real(kind_lake) :: tkmg(1,nlevsoil) ! thermal conductivity, soil minerals [W/m-K] - real(kind_lake) :: tkdry(1,nlevsoil) ! thermal conductivity, dry soil (W/m/Kelvin) - real(kind_lake) :: csol(1,nlevsoil) ! heat capacity, soil solids (J/m**3/Kelvin) - - ! integer , intent(in) :: clandunit(1) ! column's landunit - ! integer , intent(in) :: ityplun(1) ! landunit type - real(kind_lake), intent(in) :: dtime ! timestep - real(kind_lake), intent(in) :: dz_lake(1,nlevlake) ! layer thickness for lake (m) - real(kind_lake), intent(in) :: forc_rain(1) ! rain rate [mm/s] - real(kind_lake), intent(in) :: forc_snow(1) ! snow rate [mm/s] - real(kind_lake), intent(in) :: qflx_evap_tot(1) ! qflx_evap_soi + qflx_evap_veg + qflx_tran_veg - real(kind_lake), intent(in) :: forc_t(1) ! atmospheric temperature (Kelvin) - - !real(kind_lake), intent(in),optional :: flfall(1) ! fraction of liquid water within falling precipitation (unused) - - logical , intent(in) :: do_capsnow(1) ! true => do snow capping - real(kind_lake), intent(in) :: t_grnd(1) ! ground temperature (Kelvin) - real(kind_lake), intent(in) :: qflx_evap_soi(1) ! soil evaporation (mm H2O/s) (+ = to atm) - real(kind_lake), intent(in) :: qflx_snomelt(1) !snow melt (mm H2O /s) - integer, intent(in) :: imelt(1,-nlevsnow+1:nlevsoil) !flag for melting (=1), freezing (=2), Not=0 + real(kind_lake) :: watsat(1,nlevsoil) !< volumetric soil water at saturation (porosity) + real(kind_lake) :: tksatu(1,nlevsoil) !< thermal conductivity, saturated soil [W/m-K] + real(kind_lake) :: tkmg(1,nlevsoil) !< thermal conductivity, soil minerals [W/m-K] + real(kind_lake) :: tkdry(1,nlevsoil) !< thermal conductivity, dry soil (W/m/Kelvin) + real(kind_lake) :: csol(1,nlevsoil) !< heat capacity, soil solids (J/m**3/Kelvin) + + ! integer , intent(in) :: clandunit(1) !< column's landunit + ! integer , intent(in) :: ityplun(1) !< landunit type + real(kind_lake), intent(in) :: dtime !< timestep + real(kind_lake), intent(in) :: dz_lake(1,nlevlake) !< layer thickness for lake (m) + real(kind_lake), intent(in) :: forc_rain(1) !< rain rate [mm/s] + real(kind_lake), intent(in) :: forc_snow(1) !< snow rate [mm/s] + real(kind_lake), intent(in) :: qflx_evap_tot(1) !< qflx_evap_soi + qflx_evap_veg + qflx_tran_veg + real(kind_lake), intent(in) :: forc_t(1) !< atmospheric temperature (Kelvin) + + !real(kind_lake), intent(in),optional :: flfall(1) !< fraction of liquid water within falling precipitation (unused) + + logical , intent(in) :: do_capsnow(1) !< true => do snow capping + real(kind_lake), intent(in) :: t_grnd(1) !< ground temperature (Kelvin) + real(kind_lake), intent(in) :: qflx_evap_soi(1) !< soil evaporation (mm H2O/s) (+ = to atm) + real(kind_lake), intent(in) :: qflx_snomelt(1) !< snow melt (mm H2O /s) + integer, intent(in) :: imelt(1,-nlevsnow+1:nlevsoil) !< flag for melting (=1), freezing (=2), Not=0 !inout: - real(kind_lake), intent(inout) :: begwb(1) ! water mass begining of the time step + real(kind_lake), intent(inout) :: begwb(1) !< water mass begining of the time step ! inout: - real(kind_lake), intent(inout) :: z(1,-nlevsnow+1:nlevsoil) ! layer depth (m) - real(kind_lake), intent(inout) :: dz(1,-nlevsnow+1:nlevsoil) ! layer thickness depth (m) - real(kind_lake), intent(inout) :: zi(1,-nlevsnow+0:nlevsoil) ! interface depth (m) - integer , intent(inout) :: snl(1) ! number of snow layers - real(kind_lake), intent(inout) :: h2osno(1) ! snow water (mm H2O) - real(kind_lake), intent(inout) :: snowdp(1) ! snow height (m) - real(kind_lake), intent(inout) :: lake_icefrac(1,nlevlake) ! mass fraction of lake layer that is frozen - real(kind_lake), intent(inout) :: t_lake(1,nlevlake) ! lake temperature (Kelvin) - - real(kind_lake), intent(inout) :: frac_iceold(1,-nlevsnow+1:nlevsoil) ! fraction of ice relative to the tot water + real(kind_lake), intent(inout) :: z(1,-nlevsnow+1:nlevsoil) !< layer depth (m) + real(kind_lake), intent(inout) :: dz(1,-nlevsnow+1:nlevsoil) !< layer thickness depth (m) + real(kind_lake), intent(inout) :: zi(1,-nlevsnow+0:nlevsoil) !< interface depth (m) + integer , intent(inout) :: snl(1) !< number of snow layers + real(kind_lake), intent(inout) :: h2osno(1) !< snow water (mm H2O) + real(kind_lake), intent(inout) :: snowdp(1) !< snow height (m) + real(kind_lake), intent(inout) :: lake_icefrac(1,nlevlake) !< mass fraction of lake layer that is frozen + real(kind_lake), intent(inout) :: t_lake(1,nlevlake) !< lake temperature (Kelvin) + + real(kind_lake), intent(inout) :: frac_iceold(1,-nlevsnow+1:nlevsoil) !< fraction of ice relative to the tot water ! out: - real(kind_lake), intent(out) :: endwb(1) ! water mass end of the time step - real(kind_lake), intent(out) :: snowage(1) ! non dimensional snow age [-] - real(kind_lake), intent(out) :: snowice(1) ! average snow ice lens - real(kind_lake), intent(out) :: snowliq(1) ! average snow liquid water - real(kind_lake), intent(out) :: t_snow(1) ! vertically averaged snow temperature - real(kind_lake), intent(out) :: t_soisno(1,-nlevsnow+1:nlevsoil) ! snow temperature (Kelvin) - real(kind_lake), intent(out) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) ! ice lens (kg/m2) - real(kind_lake), intent(out) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) ! liquid water (kg/m2) - real(kind_lake), intent(out) :: h2osoi_vol(1,-nlevsnow+1:nlevsoil) ! volumetric soil water (0<=h2osoi_vol<=watsat)[m3/m3] - real(kind_lake), intent(out) :: qflx_drain(1) ! sub-surface runoff (mm H2O /s) - real(kind_lake), intent(out) :: qflx_surf(1) ! surface runoff (mm H2O /s) - real(kind_lake), intent(out) :: qflx_infl(1) ! infiltration (mm H2O /s) - real(kind_lake), intent(out) :: qflx_qrgwl(1) ! qflx_surf at glaciers, wetlands, lakes - real(kind_lake), intent(out) :: qcharge(1) ! aquifer recharge rate (mm/s) - real(kind_lake), intent(out) :: qflx_prec_grnd(1) ! water onto ground including canopy runoff [kg/(m2 s)] - real(kind_lake), intent(out) :: qflx_snowcap(1) ! excess precipitation due to snow capping (mm H2O /s) [+] - real(kind_lake), intent(out) :: qflx_snowcap_col(1) ! excess precipitation due to snow capping (mm H2O /s) [+] - real(kind_lake), intent(out) :: qflx_snow_grnd_pft(1) ! snow on ground after interception (mm H2O/s) [+] - real(kind_lake), intent(out) :: qflx_snow_grnd_col(1) ! snow on ground after interception (mm H2O/s) [+] - real(kind_lake), intent(out) :: qflx_rain_grnd(1) ! rain on ground after interception (mm H2O/s) [+] - real(kind_lake), intent(out) :: qflx_evap_tot_col(1) !pft quantity averaged to the column (assuming one pft) - real(kind_lake) ,intent(out) :: soilalpha(1) !factor that reduces ground saturated specific humidity (-) - real(kind_lake), intent(out) :: zwt(1) !water table depth - real(kind_lake), intent(out) :: fcov(1) !fractional area with water table at surface - real(kind_lake), intent(out) :: rootr_column(1,1:nlevsoil) !effective fraction of roots in each soil layer - real(kind_lake), intent(out) :: qflx_evap_grnd(1) ! ground surface evaporation rate (mm H2O/s) [+] - real(kind_lake), intent(out) :: qflx_sub_snow(1) ! sublimation rate from snow pack (mm H2O /s) [+] - real(kind_lake), intent(out) :: qflx_dew_snow(1) ! surface dew added to snow pack (mm H2O /s) [+] - real(kind_lake), intent(out) :: qflx_dew_grnd(1) ! ground surface dew formation (mm H2O /s) [+] - real(kind_lake), intent(out) :: qflx_rain_grnd_col(1) !rain on ground after interception (mm H2O/s) [+] + real(kind_lake), intent(out) :: endwb(1) !< water mass end of the time step + real(kind_lake), intent(out) :: snowage(1) !< non dimensional snow age [-] + real(kind_lake), intent(out) :: snowice(1) !< average snow ice lens + real(kind_lake), intent(out) :: snowliq(1) !< average snow liquid water + real(kind_lake), intent(out) :: t_snow(1) !< vertically averaged snow temperature + real(kind_lake), intent(out) :: t_soisno(1,-nlevsnow+1:nlevsoil) !< snow temperature (Kelvin) + real(kind_lake), intent(out) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) !< ice lens (kg/m2) + real(kind_lake), intent(out) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) !< liquid water (kg/m2) + real(kind_lake), intent(out) :: h2osoi_vol(1,-nlevsnow+1:nlevsoil) !< volumetric soil water (0<=h2osoi_vol<=watsat)[m3/m3] + real(kind_lake), intent(out) :: qflx_drain(1) !< sub-surface runoff (mm H2O /s) + real(kind_lake), intent(out) :: qflx_surf(1) !< surface runoff (mm H2O /s) + real(kind_lake), intent(out) :: qflx_infl(1) !< infiltration (mm H2O /s) + real(kind_lake), intent(out) :: qflx_qrgwl(1) !< qflx_surf at glaciers, wetlands, lakes + real(kind_lake), intent(out) :: qcharge(1) !< aquifer recharge rate (mm/s) + real(kind_lake), intent(out) :: qflx_prec_grnd(1) !< water onto ground including canopy runoff [kg/(m2 s)] + real(kind_lake), intent(out) :: qflx_snowcap(1) !< excess precipitation due to snow capping (mm H2O /s) [+] + real(kind_lake), intent(out) :: qflx_snowcap_col(1) !< excess precipitation due to snow capping (mm H2O /s) [+] + real(kind_lake), intent(out) :: qflx_snow_grnd_pft(1) !< snow on ground after interception (mm H2O/s) [+] + real(kind_lake), intent(out) :: qflx_snow_grnd_col(1) !< snow on ground after interception (mm H2O/s) [+] + real(kind_lake), intent(out) :: qflx_rain_grnd(1) !< rain on ground after interception (mm H2O/s) [+] + real(kind_lake), intent(out) :: qflx_evap_tot_col(1) !< pft quantity averaged to the column (assuming one pft) + real(kind_lake) ,intent(out) :: soilalpha(1) !< factor that reduces ground saturated specific humidity (-) + real(kind_lake), intent(out) :: zwt(1) !< water table depth + real(kind_lake), intent(out) :: fcov(1) !< fractional area with water table at surface + real(kind_lake), intent(out) :: rootr_column(1,1:nlevsoil) !< effective fraction of roots in each soil layer + real(kind_lake), intent(out) :: qflx_evap_grnd(1) !< ground surface evaporation rate (mm H2O/s) [+] + real(kind_lake), intent(out) :: qflx_sub_snow(1) !< sublimation rate from snow pack (mm H2O /s) [+] + real(kind_lake), intent(out) :: qflx_dew_snow(1) !< surface dew added to snow pack (mm H2O /s) [+] + real(kind_lake), intent(out) :: qflx_dew_grnd(1) !< ground surface dew formation (mm H2O /s) [+] + real(kind_lake), intent(out) :: qflx_rain_grnd_col(1) !< rain on ground after interception (mm H2O/s) [+] ! Block of biogeochem currently not used. real(kind_lake), pointer :: sucsat(:,:) ! minimum soil suction (mm) @@ -3644,25 +3633,25 @@ subroutine ShalLakeHydrology(dz_lake,forc_rain,forc_snow, & end subroutine ShalLakeHydrology +! DESCRIPTION: +!> Computes saturation mixing ratio and the change in saturation +!! mixing ratio with respect to temperature. subroutine QSat (T, p, es, esdT, qs, qsdT) ! - ! !DESCRIPTION: - ! Computes saturation mixing ratio and the change in saturation - ! mixing ratio with respect to temperature. ! Reference: Polynomial approximations from: ! Piotr J. Flatau, et al.,1992: Polynomial fits to saturation ! vapor pressure. Journal of Applied Meteorology, 31, 1507-1513. ! - ! !USES: + ! USES: ! - ! !ARGUMENTS: + ! ARGUMENTS: implicit none - real(kind_lake), intent(in) :: T ! temperature (K) - real(kind_lake), intent(in) :: p ! surface atmospheric pressure (pa) - real(kind_lake), intent(out) :: es ! vapor pressure (pa) - real(kind_lake), intent(out) :: esdT ! d(es)/d(T) - real(kind_lake), intent(out) :: qs ! humidity (kg/kg) - real(kind_lake), intent(out) :: qsdT ! d(qs)/d(T) + real(kind_lake), intent(in) :: T !< temperature (K) + real(kind_lake), intent(in) :: p !< surface atmospheric pressure (pa) + real(kind_lake), intent(out) :: es !< vapor pressure (pa) + real(kind_lake), intent(out) :: esdT !< d(es)/d(T) + real(kind_lake), intent(out) :: qs !< humidity (kg/kg) + real(kind_lake), intent(out) :: qsdT !< d(qs)/d(T) ! ! !CALLED FROM: ! subroutine Biogeophysics1 in module Biogeophysics1Mod @@ -3762,21 +3751,21 @@ end subroutine QSat subroutine Tridiagonal (lbc, ubc, lbj, ubj, jtop, numf, filter, & a, b, c, r, u) ! - ! !DESCRIPTION: - ! Tridiagonal matrix solution + ! DESCRIPTION: + !< Tridiagonal matrix solution ! - ! !ARGUMENTS: + ! ARGUMENTS: implicit none - integer , intent(in) :: lbc, ubc ! lbinning and ubing column indices - integer , intent(in) :: lbj, ubj ! lbinning and ubing level indices - integer , intent(in) :: jtop(lbc:ubc) ! top level for each column - integer , intent(in) :: numf ! filter dimension - integer , intent(in) :: filter(1:numf) ! filter - real(kind_lake), intent(in) :: a(lbc:ubc, lbj:ubj) ! "a" left off diagonal of tridiagonal matrix - real(kind_lake), intent(in) :: b(lbc:ubc, lbj:ubj) ! "b" diagonal column for tridiagonal matrix - real(kind_lake), intent(in) :: c(lbc:ubc, lbj:ubj) ! "c" right off diagonal tridiagonal matrix - real(kind_lake), intent(in) :: r(lbc:ubc, lbj:ubj) ! "r" forcing term of tridiagonal matrix - real(kind_lake), intent(inout) :: u(lbc:ubc, lbj:ubj) ! solution + integer , intent(in) :: lbc, ubc !< lbinning and ubing column indices + integer , intent(in) :: lbj, ubj !< lbinning and ubing level indices + integer , intent(in) :: jtop(lbc:ubc) !< top level for each column + integer , intent(in) :: numf !< filter dimension + integer , intent(in) :: filter(1:numf) !< filter + real(kind_lake), intent(in) :: a(lbc:ubc, lbj:ubj) !< "a" left off diagonal of tridiagonal matrix + real(kind_lake), intent(in) :: b(lbc:ubc, lbj:ubj) !< "b" diagonal column for tridiagonal matrix + real(kind_lake), intent(in) :: c(lbc:ubc, lbj:ubj) !< "c" right off diagonal tridiagonal matrix + real(kind_lake), intent(in) :: r(lbc:ubc, lbj:ubj) !< "r" forcing term of tridiagonal matrix + real(kind_lake), intent(inout) :: u(lbc:ubc, lbj:ubj) !< solution ! ! !CALLED FROM: ! subroutine BiogeophysicsLake in module BiogeophysicsLakeMod @@ -3841,6 +3830,17 @@ subroutine Tridiagonal (lbc, ubc, lbj, ubj, jtop, numf, filter, & end subroutine Tridiagonal + ! DESCRIPTION: + !> Evaluate the change of snow mass and the snow water onto soil. + !! Water flow within snow is computed by an explicit and non-physical + !! based scheme, which permits a part of liquid water over the holding + !! capacity (a tentative value is used, i.e. equal to 0.033*porosity) to + !! percolate into the underlying layer. Except for cases where the + !! porosity of one of the two neighboring layers is less than 0.05, zero + !! flow is assumed. The water flow out of the bottom of the snow pack will + !! participate as the input of the soil water and runoff. This subroutine + !! uses a filter for columns containing snow which must be constructed prior + !! to being called. subroutine SnowWater(lbc, ubc, num_snowc, filter_snowc, & !i num_nosnowc, filter_nosnowc, & !i snl,do_capsnow,qflx_snomelt,qflx_rain_grnd, & !i @@ -3849,18 +3849,6 @@ subroutine SnowWater(lbc, ubc, num_snowc, filter_snowc, & !i h2osoi_ice,h2osoi_liq, & !i&o qflx_top_soil) !o !=============================================================================== - ! !DESCRIPTION: - ! Evaluate the change of snow mass and the snow water onto soil. - ! Water flow within snow is computed by an explicit and non-physical - ! based scheme, which permits a part of liquid water over the holding - ! capacity (a tentative value is used, i.e. equal to 0.033*porosity) to - ! percolate into the underlying layer. Except for cases where the - ! porosity of one of the two neighboring layers is less than 0.05, zero - ! flow is assumed. The water flow out of the bottom of the snow pack will - ! participate as the input of the soil water and runoff. This subroutine - ! uses a filter for columns containing snow which must be constructed prior - ! to being called. - ! ! !REVISION HISTORY: ! 15 September 1999: Yongjiu Dai; Initial code ! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision @@ -3873,32 +3861,32 @@ subroutine SnowWater(lbc, ubc, num_snowc, filter_snowc, & !i implicit none !in: - integer, intent(in) :: lbc, ubc ! column bounds - integer, intent(in) :: num_snowc ! number of snow points in column filter - integer, intent(in) :: filter_snowc(ubc-lbc+1) ! column filter for snow points - integer, intent(in) :: num_nosnowc ! number of non-snow points in column filter - integer, intent(in) :: filter_nosnowc(ubc-lbc+1) ! column filter for non-snow points - - integer , intent(in) :: snl(1) !number of snow layers - logical , intent(in) :: do_capsnow(1) !true => do snow capping - real(kind_lake), intent(in) :: dtime !timestep - real(kind_lake), intent(in) :: qflx_snomelt(1) !snow melt (mm H2O /s) - real(kind_lake), intent(in) :: qflx_rain_grnd(1) !rain on ground after interception (mm H2O/s) [+] - real(kind_lake), intent(in) :: qflx_sub_snow(1) !sublimation rate from snow pack (mm H2O /s) [+] - real(kind_lake), intent(in) :: qflx_evap_grnd(1) !ground surface evaporation rate (mm H2O/s) [+] - real(kind_lake), intent(in) :: qflx_dew_snow(1) !surface dew added to snow pack (mm H2O /s) [+] - real(kind_lake), intent(in) :: qflx_dew_grnd(1) !ground surface dew formation (mm H2O /s) [+] - real(kind_lake), intent(in) :: dz(1,-nlevsnow+1:nlevsoil) !layer depth (m) + integer, intent(in) :: lbc, ubc !< column bounds + integer, intent(in) :: num_snowc !< number of snow points in column filter + integer, intent(in) :: filter_snowc(ubc-lbc+1) !< column filter for snow points + integer, intent(in) :: num_nosnowc !< number of non-snow points in column filter + integer, intent(in) :: filter_nosnowc(ubc-lbc+1) !< column filter for non-snow points + + integer , intent(in) :: snl(1) !< number of snow layers + logical , intent(in) :: do_capsnow(1) !< true => do snow capping + real(kind_lake), intent(in) :: dtime !< timestep + real(kind_lake), intent(in) :: qflx_snomelt(1) !< snow melt (mm H2O /s) + real(kind_lake), intent(in) :: qflx_rain_grnd(1) !< rain on ground after interception (mm H2O/s) [+] + real(kind_lake), intent(in) :: qflx_sub_snow(1) !< sublimation rate from snow pack (mm H2O /s) [+] + real(kind_lake), intent(in) :: qflx_evap_grnd(1) !< ground surface evaporation rate (mm H2O/s) [+] + real(kind_lake), intent(in) :: qflx_dew_snow(1) !< surface dew added to snow pack (mm H2O /s) [+] + real(kind_lake), intent(in) :: qflx_dew_grnd(1) !< ground surface dew formation (mm H2O /s) [+] + real(kind_lake), intent(in) :: dz(1,-nlevsnow+1:nlevsoil) !< layer depth (m) !inout: - real(kind_lake), intent(inout) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) !ice lens (kg/m2) - real(kind_lake), intent(inout) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) !liquid water (kg/m2) + real(kind_lake), intent(inout) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) !< ice lens (kg/m2) + real(kind_lake), intent(inout) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) !< liquid water (kg/m2) !out: - real(kind_lake), intent(out) :: qflx_top_soil(1) !net water input into soil from top (mm/s) + real(kind_lake), intent(out) :: qflx_top_soil(1) !< net water input into soil from top (mm/s) ! OTHER LOCAL VARIABLES: @@ -4006,6 +3994,13 @@ subroutine SnowWater(lbc, ubc, num_snowc, filter_snowc, & !i end subroutine SnowWater +!> Determine the change in snow layer thickness due to compaction and +!! settling. +!! Three metamorphisms of changing snow characteristics are implemented, +!! i.e., destructive, overburden, and melt. The treatments of the former +!! two are from SNTHERM.89 and SNTHERM.99 (1991, 1999). The contribution +!! due to melt metamorphism is simply taken as a ratio of snow ice +!! fraction after the melting versus before the melting. subroutine SnowCompaction(lbc, ubc, num_snowc, filter_snowc, &!i snl,imelt,frac_iceold,t_soisno, &!i h2osoi_ice,h2osoi_liq,dtime, &!i @@ -4013,15 +4008,6 @@ subroutine SnowCompaction(lbc, ubc, num_snowc, filter_snowc, &!i !================================================================================ - ! !DESCRIPTION: - ! Determine the change in snow layer thickness due to compaction and - ! settling. - ! Three metamorphisms of changing snow characteristics are implemented, - ! i.e., destructive, overburden, and melt. The treatments of the former - ! two are from SNTHERM.89 and SNTHERM.99 (1991, 1999). The contribution - ! due to melt metamorphism is simply taken as a ratio of snow ice - ! fraction after the melting versus before the melting. - ! ! CALLED FROM: ! subroutine Hydrology2 in module Hydrology2Mod ! @@ -4037,20 +4023,20 @@ subroutine SnowCompaction(lbc, ubc, num_snowc, filter_snowc, &!i implicit none !in: - integer, intent(in) :: lbc, ubc ! column bounds - integer, intent(in) :: num_snowc ! number of column snow points in column filter - integer, intent(in) :: filter_snowc(ubc-lbc+1) ! column filter for snow points - integer, intent(in) :: snl(1) !number of snow layers - integer, intent(in) :: imelt(1,-nlevsnow+1:nlevsoil) !flag for melting (=1), freezing (=2), Not=0 - real(kind_lake), intent(in) :: dtime - real(kind_lake), intent(in) :: frac_iceold(1,-nlevsnow+1:nlevsoil) !fraction of ice relative to the tot water - real(kind_lake), intent(in) :: t_soisno(1,-nlevsnow+1:nlevsoil) !soil temperature (Kelvin) - real(kind_lake), intent(in) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) !ice lens (kg/m2) - real(kind_lake), intent(in) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) !liquid water (kg/m2) + integer, intent(in) :: lbc, ubc !< column bounds + integer, intent(in) :: num_snowc !< number of column snow points in column filter + integer, intent(in) :: filter_snowc(ubc-lbc+1) !< column filter for snow points + integer, intent(in) :: snl(1) !< number of snow layers + integer, intent(in) :: imelt(1,-nlevsnow+1:nlevsoil) !< flag for melting (=1), freezing (=2), Not=0 + real(kind_lake), intent(in) :: dtime !< + real(kind_lake), intent(in) :: frac_iceold(1,-nlevsnow+1:nlevsoil) !< fraction of ice relative to the tot water + real(kind_lake), intent(in) :: t_soisno(1,-nlevsnow+1:nlevsoil) !< soil temperature (Kelvin) + real(kind_lake), intent(in) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) !< ice lens (kg/m2) + real(kind_lake), intent(in) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) !< liquid water (kg/m2) !inout: - real(kind_lake), intent(inout) :: dz(1,-nlevsnow+1:nlevsoil) !layer depth (m) + real(kind_lake), intent(inout) :: dz(1,-nlevsnow+1:nlevsoil) !< layer depth (m) ! OTHER LOCAL VARIABLES: @@ -4137,21 +4123,24 @@ subroutine SnowCompaction(lbc, ubc, num_snowc, filter_snowc, &!i end subroutine SnowCompaction +!> Combine snow layers that are less than a minimum thickness or mass +!! If the snow element thickness or mass is less than a prescribed minimum, +!! then it is combined with a neighboring element. subroutine CombineSnowLayers(lbc, ubc, & !i num_snowc, filter_snowc, & !i&o snl,h2osno,snowdp,dz,zi, & !i&o t_soisno,h2osoi_ice,h2osoi_liq, & !i&o z) !o !========================================================================== - ! !DESCRIPTION: + ! DESCRIPTION: ! Combine snow layers that are less than a minimum thickness or mass ! If the snow element thickness or mass is less than a prescribed minimum, ! then it is combined with a neighboring element. The subroutine ! clm\_combo.f90 then executes the combination of mass and energy. - ! !CALLED FROM: + ! CALLED FROM: ! subroutine Hydrology2 in module Hydrology2Mod ! - ! !REVISION HISTORY: + ! REVISION HISTORY: ! 15 September 1999: Yongjiu Dai; Initial code ! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision ! 2/28/02, Peter Thornton: Migrated to new data structures. @@ -4162,25 +4151,25 @@ subroutine CombineSnowLayers(lbc, ubc, & !i ! !ARGUMENTS: implicit none !in: - integer, intent(in) :: lbc, ubc ! column bounds + integer, intent(in) :: lbc, ubc !< column bounds ! integer, intent(in) :: clandunit(1) !landunit index for each column ! integer, intent(in) :: ityplun(1) !landunit type !inout: - integer, intent(inout) :: num_snowc ! number of column snow points in column filter - integer, intent(inout) :: filter_snowc(ubc-lbc+1) ! column filter for snow points - integer , intent(inout) :: snl(1) !number of snow layers - real(kind_lake), intent(inout) :: h2osno(1) !snow water (mm H2O) - real(kind_lake), intent(inout) :: snowdp(1) !snow height (m) - real(kind_lake), intent(inout) :: dz(1,-nlevsnow+1:nlevsoil) !layer depth (m) - real(kind_lake), intent(inout) :: zi(1,-nlevsnow+0:nlevsoil) !interface level below a "z" level (m) - real(kind_lake), intent(inout) :: t_soisno(1,-nlevsnow+1:nlevsoil) !soil temperature (Kelvin) - real(kind_lake), intent(inout) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) !ice lens (kg/m2) - real(kind_lake), intent(inout) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) !liquid water (kg/m2) + integer, intent(inout) :: num_snowc !< number of column snow points in column filter + integer, intent(inout) :: filter_snowc(ubc-lbc+1) !< column filter for snow points + integer , intent(inout) :: snl(1) !< number of snow layers + real(kind_lake), intent(inout) :: h2osno(1) !< snow water (mm H2O) + real(kind_lake), intent(inout) :: snowdp(1) !< snow height (m) + real(kind_lake), intent(inout) :: dz(1,-nlevsnow+1:nlevsoil) !< layer depth (m) + real(kind_lake), intent(inout) :: zi(1,-nlevsnow+0:nlevsoil) !< interface level below a "z" level (m) + real(kind_lake), intent(inout) :: t_soisno(1,-nlevsnow+1:nlevsoil) !< soil temperature (Kelvin) + real(kind_lake), intent(inout) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) !< ice lens (kg/m2) + real(kind_lake), intent(inout) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) !< liquid water (kg/m2) !out: - real(kind_lake), intent(out) :: z(1,-nlevsnow+1:nlevsoil) !layer thickness (m) + real(kind_lake), intent(out) :: z(1,-nlevsnow+1:nlevsoil) !< layer thickness (m) ! !EOP ! @@ -4359,6 +4348,8 @@ subroutine CombineSnowLayers(lbc, ubc, & !i end subroutine CombineSnowLayers +! DESCRIPTION: +!> Subdivides snow layers if they exceed their prescribed maximum thickness. subroutine DivideSnowLayers(lbc, ubc, & !i num_snowc, filter_snowc, & !i&o snl,dz,zi,t_soisno, & !i&o @@ -4367,8 +4358,6 @@ subroutine DivideSnowLayers(lbc, ubc, & !i !============================================================================ - ! !DESCRIPTION: - ! Subdivides snow layers if they exceed their prescribed maximum thickness. ! !CALLED FROM: ! subroutine Hydrology2 in module Hydrology2Mod ! @@ -4384,22 +4373,22 @@ subroutine DivideSnowLayers(lbc, ubc, & !i implicit none !in: - integer, intent(in) :: lbc, ubc ! column bounds + integer, intent(in) :: lbc, ubc !< column bounds !inout: - integer, intent(inout) :: num_snowc ! number of column snow points in column filter - integer, intent(inout) :: filter_snowc(ubc-lbc+1) ! column filter for snow points - integer , intent(inout) :: snl(1) !number of snow layers - real(kind_lake), intent(inout) :: dz(1,-nlevsnow+1:nlevsoil) !layer depth (m) - real(kind_lake), intent(inout) :: zi(1,-nlevsnow+0:nlevsoil) !interface level below a "z" level (m) - real(kind_lake), intent(inout) :: t_soisno(1,-nlevsnow+1:nlevsoil) !soil temperature (Kelvin) - real(kind_lake), intent(inout) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) !ice lens (kg/m2) - real(kind_lake), intent(inout) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) !liquid water (kg/m2) + integer, intent(inout) :: num_snowc !< number of column snow points in column filter + integer, intent(inout) :: filter_snowc(ubc-lbc+1) !< column filter for snow points + integer , intent(inout) :: snl(1) !< number of snow layers + real(kind_lake), intent(inout) :: dz(1,-nlevsnow+1:nlevsoil) !< layer depth (m) + real(kind_lake), intent(inout) :: zi(1,-nlevsnow+0:nlevsoil) !< interface level below a "z" level (m) + real(kind_lake), intent(inout) :: t_soisno(1,-nlevsnow+1:nlevsoil) !< soil temperature (Kelvin) + real(kind_lake), intent(inout) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil) !< ice lens (kg/m2) + real(kind_lake), intent(inout) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil) !< liquid water (kg/m2) !out: - real(kind_lake), intent(out) :: z(1,-nlevsnow+1:nlevsoil) !layer thickness (m) + real(kind_lake), intent(out) :: z(1,-nlevsnow+1:nlevsoil) !< layer thickness (m) @@ -4587,11 +4576,13 @@ subroutine DivideSnowLayers(lbc, ubc, & !i end subroutine DivideSnowLayers +!> Combines two elements and returns the following combined +!! variables: dz, t, wliq, wice. subroutine Combo(dz, wliq, wice, t, dz2, wliq2, wice2, t2) ! - ! !DESCRIPTION: - ! Combines two elements and returns the following combined - ! variables: dz, t, wliq, wice. + ! DESCRIPTION: + !> Combines two elements and returns the following combined + !! variables: dz, t, wliq, wice. ! The combined temperature is based on the equation: ! the sum of the enthalpies of the two elements = ! that of the combined element. @@ -4600,14 +4591,14 @@ subroutine Combo(dz, wliq, wice, t, dz2, wliq2, wice2, t2) ! ! !ARGUMENTS: implicit none - real(kind_lake), intent(in) :: dz2 ! nodal thickness of 2 elements being combined [m] - real(kind_lake), intent(in) :: wliq2 ! liquid water of element 2 [kg/m2] - real(kind_lake), intent(in) :: wice2 ! ice of element 2 [kg/m2] - real(kind_lake), intent(in) :: t2 ! nodal temperature of element 2 [K] - real(kind_lake), intent(inout) :: dz ! nodal thickness of 1 elements being combined [m] - real(kind_lake), intent(inout) :: wliq ! liquid water of element 1 - real(kind_lake), intent(inout) :: wice ! ice of element 1 [kg/m2] - real(kind_lake), intent(inout) :: t ! nodel temperature of elment 1 [K] + real(kind_lake), intent(in) :: dz2 !< nodal thickness of 2 elements being combined [m] + real(kind_lake), intent(in) :: wliq2 !< liquid water of element 2 [kg/m2] + real(kind_lake), intent(in) :: wice2 !< ice of element 2 [kg/m2] + real(kind_lake), intent(in) :: t2 !< nodal temperature of element 2 [K] + real(kind_lake), intent(inout) :: dz !< nodal thickness of 1 elements being combined [m] + real(kind_lake), intent(inout) :: wliq !< liquid water of element 1 + real(kind_lake), intent(inout) :: wice !< ice of element 1 [kg/m2] + real(kind_lake), intent(inout) :: t !< nodel temperature of elment 1 [K] ! ! !CALLED FROM: ! subroutine CombineSnowLayers in this module @@ -4653,26 +4644,27 @@ subroutine Combo(dz, wliq, wice, t, dz2, wliq2, wice2, t2) end subroutine Combo +!> Constructs snow filter for use in vectorized loops for snow hydrology. subroutine BuildSnowFilter(lbc, ubc, num_nolakec, filter_nolakec,snl, & !i num_snowc, filter_snowc, & !o num_nosnowc, filter_nosnowc) !o ! - ! !DESCRIPTION: - ! Constructs snow filter for use in vectorized loops for snow hydrology. + ! DESCRIPTION: + !> Constructs snow filter for use in vectorized loops for snow hydrology. ! ! !USES: ! use clmtype ! ! !ARGUMENTS: implicit none - integer, intent(in) :: lbc, ubc ! column bounds - integer, intent(in) :: num_nolakec ! number of column non-lake points in column filter - integer, intent(in) :: filter_nolakec(ubc-lbc+1) ! column filter for non-lake points - integer, intent(in) :: snl(1) ! number of snow layers - integer, intent(out) :: num_snowc ! number of column snow points in column filter - integer, intent(out) :: filter_snowc(ubc-lbc+1) ! column filter for snow points - integer, intent(out) :: num_nosnowc ! number of column non-snow points in column filter - integer, intent(out) :: filter_nosnowc(ubc-lbc+1) ! column filter for non-snow points + integer, intent(in) :: lbc, ubc !< column bounds + integer, intent(in) :: num_nolakec !< number of column non-lake points in column filter + integer, intent(in) :: filter_nolakec(ubc-lbc+1) !< column filter for non-lake points + integer, intent(in) :: snl(1) !< number of snow layers + integer, intent(out) :: num_snowc !< number of column snow points in column filter + integer, intent(out) :: filter_snowc(ubc-lbc+1) !< column filter for snow points + integer, intent(out) :: num_nosnowc !< number of column non-snow points in column filter + integer, intent(out) :: filter_nosnowc(ubc-lbc+1) !< column filter for non-snow points ! ! !CALLED FROM: ! subroutine Hydrology2 in Hydrology2Mod @@ -4710,7 +4702,13 @@ subroutine BuildSnowFilter(lbc, ubc, num_nolakec, filter_nolakec,snl, & !i end subroutine BuildSnowFilter - + ! DESCRIPTION: + !> Calculation of the friction velocity, relation for potential + !! temperature and humidity profiles of surface boundary layer. + !! The scheme is based on the work of Zeng et al. (1998): + !! Intercomparison of bulk aerodynamic algorithms for the computation + !! of sea surface fluxes using TOGA CORE and TAO data. J. Climate, + !! Vol. 11, 2628-2644. subroutine FrictionVelocity(pgridcell,forc_hgt,forc_hgt_u, & !i forc_hgt_t,forc_hgt_q, & !i lbp, ubp, fn, filterp, & !i @@ -4721,15 +4719,7 @@ subroutine FrictionVelocity(pgridcell,forc_hgt,forc_hgt_u, & !i fm) !i&o !============================================================================= - ! !DESCRIPTION: - ! Calculation of the friction velocity, relation for potential - ! temperature and humidity profiles of surface boundary layer. - ! The scheme is based on the work of Zeng et al. (1998): - ! Intercomparison of bulk aerodynamic algorithms for the computation - ! of sea surface fluxes using TOGA CORE and TAO data. J. Climate, - ! Vol. 11, 2628-2644. - ! - ! !REVISION HISTORY: + ! REVISION HISTORY: ! 15 September 1999: Yongjiu Dai; Initial code ! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision ! 12/19/01, Peter Thornton @@ -4746,35 +4736,35 @@ subroutine FrictionVelocity(pgridcell,forc_hgt,forc_hgt_u, & !i !in: - integer , intent(in) :: pgridcell(1) ! pft's gridcell index - real(kind_lake), intent(in) :: forc_hgt(1) ! atmospheric reference height (m) - real(kind_lake), intent(in) :: forc_hgt_u(1) ! observational height of wind [m] - real(kind_lake), intent(in) :: forc_hgt_t(1) ! observational height of temperature [m] - real(kind_lake), intent(in) :: forc_hgt_q(1) ! observational height of humidity [m] - integer , intent(in) :: lbp, ubp ! pft array bounds - integer , intent(in) :: fn ! number of filtered pft elements - integer , intent(in) :: filterp(fn) ! pft filter - real(kind_lake), intent(in) :: displa(lbp:ubp) ! displacement height (m) - real(kind_lake), intent(in) :: z0m(lbp:ubp) ! roughness length over vegetation, momentum [m] - real(kind_lake), intent(in) :: z0h(lbp:ubp) ! roughness length over vegetation, sensible heat [m] - real(kind_lake), intent(in) :: z0q(lbp:ubp) ! roughness length over vegetation, latent heat [m] - real(kind_lake), intent(in) :: obu(lbp:ubp) ! monin-obukhov length (m) - integer, intent(in) :: iter ! iteration number - real(kind_lake), intent(in) :: ur(lbp:ubp) ! wind speed at reference height [m/s] - real(kind_lake), intent(in) :: um(lbp:ubp) ! wind speed including the stablity effect [m/s] + integer , intent(in) :: pgridcell(1) !< pft's gridcell index + real(kind_lake), intent(in) :: forc_hgt(1) !< atmospheric reference height (m) + real(kind_lake), intent(in) :: forc_hgt_u(1) !< observational height of wind [m] + real(kind_lake), intent(in) :: forc_hgt_t(1) !< observational height of temperature [m] + real(kind_lake), intent(in) :: forc_hgt_q(1) !< observational height of humidity [m] + integer , intent(in) :: lbp, ubp !< pft array bounds + integer , intent(in) :: fn !< number of filtered pft elements + integer , intent(in) :: filterp(fn) !< pft filter + real(kind_lake), intent(in) :: displa(lbp:ubp) !< displacement height (m) + real(kind_lake), intent(in) :: z0m(lbp:ubp) !< roughness length over vegetation, momentum [m] + real(kind_lake), intent(in) :: z0h(lbp:ubp) !< roughness length over vegetation, sensible heat [m] + real(kind_lake), intent(in) :: z0q(lbp:ubp) !< roughness length over vegetation, latent heat [m] + real(kind_lake), intent(in) :: obu(lbp:ubp) !< monin-obukhov length (m) + integer, intent(in) :: iter !< iteration number + real(kind_lake), intent(in) :: ur(lbp:ubp) !< wind speed at reference height [m/s] + real(kind_lake), intent(in) :: um(lbp:ubp) !< wind speed including the stablity effect [m/s] !out: - real(kind_lake), intent(out) :: ustar(lbp:ubp) ! friction velocity [m/s] - real(kind_lake), intent(out) :: temp1(lbp:ubp) ! relation for potential temperature profile - real(kind_lake), intent(out) :: temp12m(lbp:ubp) ! relation for potential temperature profile applied at 2-m - real(kind_lake), intent(out) :: temp2(lbp:ubp) ! relation for specific humidity profile - real(kind_lake), intent(out) :: temp22m(lbp:ubp) ! relation for specific humidity profile applied at 2-m - real(kind_lake), intent(out) :: u10(1) ! 10-m wind (m/s) (for dust model) - real(kind_lake), intent(out) :: fv(1) ! friction velocity (m/s) (for dust model) + real(kind_lake), intent(out) :: ustar(lbp:ubp) !< friction velocity [m/s] + real(kind_lake), intent(out) :: temp1(lbp:ubp) !< relation for potential temperature profile + real(kind_lake), intent(out) :: temp12m(lbp:ubp) !< relation for potential temperature profile applied at 2-m + real(kind_lake), intent(out) :: temp2(lbp:ubp) !< relation for specific humidity profile + real(kind_lake), intent(out) :: temp22m(lbp:ubp) !< relation for specific humidity profile applied at 2-m + real(kind_lake), intent(out) :: u10(1) !< 10-m wind (m/s) (for dust model) + real(kind_lake), intent(out) :: fv(1) !< friction velocity (m/s) (for dust model) !inout: - real(kind_lake), intent(inout) :: fm(lbp:ubp) ! needed for DGVM only to diagnose 10m wind + real(kind_lake), intent(inout) :: fm(lbp:ubp) !< needed for DGVM only to diagnose 10m wind ! OTHER LOCAL VARIABLES: @@ -4990,8 +4980,8 @@ end subroutine FrictionVelocity ! !INTERFACE: real(kind_lake) function StabilityFunc1(zeta) ! - ! !DESCRIPTION: - ! Stability function for rib < 0. + ! DESCRIPTION: + !> Stability function for rib < 0. ! ! !USES: ! use shr_const_mod, only: SHR_CONST_PI @@ -4999,7 +4989,7 @@ real(kind_lake) function StabilityFunc1(zeta) ! ! !ARGUMENTS: implicit none - real(kind_lake), intent(in) :: zeta ! dimensionless height used in Monin-Obukhov theory + real(kind_lake), intent(in) :: zeta !< dimensionless height used in Monin-Obukhov theory ! ! !CALLED FROM: ! subroutine FrictionVelocity in this module @@ -5033,7 +5023,7 @@ end function StabilityFunc1 real(kind_lake) function StabilityFunc2(zeta) ! ! !DESCRIPTION: - ! Stability function for rib < 0. + !> Stability function for rib < 0. ! ! !USES: !Removed by Zack Subin, 7/9/08 @@ -5041,7 +5031,7 @@ real(kind_lake) function StabilityFunc2(zeta) ! ! !ARGUMENTS: implicit none - real(kind_lake), intent(in) :: zeta ! dimensionless height used in Monin-Obukhov theory + real(kind_lake), intent(in) :: zeta !< dimensionless height used in Monin-Obukhov theory ! ! !CALLED FROM: ! subroutine FrictionVelocity in this module @@ -5071,23 +5061,23 @@ end function StabilityFunc2 subroutine MoninObukIni (ur, thv, dthv, zldis, z0m, um, obu) ! ! !DESCRIPTION: - ! Initialization of the Monin-Obukhov length. - ! The scheme is based on the work of Zeng et al. (1998): - ! Intercomparison of bulk aerodynamic algorithms for the computation - ! of sea surface fluxes using TOGA CORE and TAO data. J. Climate, - ! Vol. 11, 2628-2644. + !> Initialization of the Monin-Obukhov length. + !! The scheme is based on the work of Zeng et al. (1998): + !! Intercomparison of bulk aerodynamic algorithms for the computation + !! of sea surface fluxes using TOGA CORE and TAO data. J. Climate, + !! Vol. 11, 2628-2644. ! ! !USES: ! ! !ARGUMENTS: implicit none - real(kind_lake), intent(in) :: ur ! wind speed at reference height [m/s] - real(kind_lake), intent(in) :: thv ! virtual potential temperature (kelvin) - real(kind_lake), intent(in) :: dthv ! diff of vir. poten. temp. between ref. height and surface - real(kind_lake), intent(in) :: zldis ! reference height "minus" zero displacement heght [m] - real(kind_lake), intent(in) :: z0m ! roughness length, momentum [m] - real(kind_lake), intent(out) :: um ! wind speed including the stability effect [m/s] - real(kind_lake), intent(out) :: obu ! monin-obukhov length (m) + real(kind_lake), intent(in) :: ur !< wind speed at reference height [m/s] + real(kind_lake), intent(in) :: thv !< virtual potential temperature (kelvin) + real(kind_lake), intent(in) :: dthv !< diff of vir. poten. temp. between ref. height and surface + real(kind_lake), intent(in) :: zldis !< reference height "minus" zero displacement heght [m] + real(kind_lake), intent(in) :: z0m !< roughness length, momentum [m] + real(kind_lake), intent(out) :: um !< wind speed including the stability effect [m/s] + real(kind_lake), intent(out) :: obu !< monin-obukhov length (m) ! ! !CALLED FROM: ! subroutine BareGroundFluxes in module BareGroundFluxesMod.F90 @@ -5256,12 +5246,12 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, sand3d, clay3d, tg3, clm_lakedepth, & km, me, master, errmsg, errflg) - ! Some fields in lakeini are not available during initialization, - ! so clm_lake_init cannot complete the initialization. What is not - ! in clm_lake_init, is initialized in lakeini on points where - ! use_lake_model(i)>0. The clm_lake_initialized(i) guards against - ! initializing a point twice. For that to work, - ! clm_lake_initialized must be a restart variable. + !> Some fields in lakeini are not available during initialization, + !! so clm_lake_init cannot complete the initialization. What is not + !! in clm_lake_init, is initialized in lakeini on points where + !! use_lake_model(i)>0. The clm_lake_initialized(i) guards against + !! initializing a point twice. For that to work, + !! clm_lake_initialized must be a restart variable. !============================================================================== ! This subroutine was first edited by Hongping Gu for coupling diff --git a/physics/docs/ccppsrw3_doxyfile b/physics/docs/ccppsrw3_doxyfile new file mode 100644 index 000000000..b1cc3138c --- /dev/null +++ b/physics/docs/ccppsrw3_doxyfile @@ -0,0 +1,557 @@ +# Doxyfile 1.9.3 + +DOXYFILE_ENCODING = UTF-8 +PROJECT_NAME = "CCPP SciDoc for UFS-SRW v3.0.0" +PROJECT_NUMBER = "SRW v3.0.0" +PROJECT_BRIEF = "Common Community Physics Package Developed at DTC" +PROJECT_LOGO = img/dtc_logo.png +OUTPUT_DIRECTORY = doc +CREATE_SUBDIRS = NO +ALLOW_UNICODE_NAMES = NO +OUTPUT_LANGUAGE = English +BRIEF_MEMBER_DESC = YES +REPEAT_BRIEF = NO +ABBREVIATE_BRIEF = +ALWAYS_DETAILED_SEC = NO +INLINE_INHERITED_MEMB = NO +FULL_PATH_NAMES = NO +STRIP_FROM_PATH = +STRIP_FROM_INC_PATH = +SHORT_NAMES = NO +JAVADOC_AUTOBRIEF = NO +JAVADOC_BANNER = NO +QT_AUTOBRIEF = NO +MULTILINE_CPP_IS_BRIEF = NO +PYTHON_DOCSTRING = YES +INHERIT_DOCS = YES +SEPARATE_MEMBER_PAGES = YES +TAB_SIZE = 4 +ALIASES = +OPTIMIZE_OUTPUT_FOR_C = NO +OPTIMIZE_OUTPUT_JAVA = NO +OPTIMIZE_FOR_FORTRAN = YES +OPTIMIZE_OUTPUT_VHDL = NO +OPTIMIZE_OUTPUT_SLICE = NO +EXTENSION_MAPPING = .f=FortranFree \ + .F=FortranFree \ + .F90=FortranFree \ + .f90=FortranFree +MARKDOWN_SUPPORT = YES +TOC_INCLUDE_HEADINGS = 5 +AUTOLINK_SUPPORT = YES +BUILTIN_STL_SUPPORT = NO +CPP_CLI_SUPPORT = NO +SIP_SUPPORT = NO +IDL_PROPERTY_SUPPORT = YES +DISTRIBUTE_GROUP_DOC = YES +GROUP_NESTED_COMPOUNDS = NO +SUBGROUPING = YES +INLINE_GROUPED_CLASSES = NO +INLINE_SIMPLE_STRUCTS = NO +TYPEDEF_HIDES_STRUCT = YES +LOOKUP_CACHE_SIZE = 0 +NUM_PROC_THREADS = 1 + +#--------------------------------------------------------------------------- +# Build related configuration options +#--------------------------------------------------------------------------- + +EXTRACT_ALL = YES +EXTRACT_PRIVATE = YES +EXTRACT_PRIV_VIRTUAL = NO +EXTRACT_PACKAGE = YES +EXTRACT_STATIC = YES +EXTRACT_LOCAL_CLASSES = YES +EXTRACT_LOCAL_METHODS = YES +EXTRACT_ANON_NSPACES = YES +RESOLVE_UNNAMED_PARAMS = YES +HIDE_UNDOC_MEMBERS = NO +HIDE_UNDOC_CLASSES = NO +HIDE_FRIEND_COMPOUNDS = NO +HIDE_IN_BODY_DOCS = NO +INTERNAL_DOCS = YES +CASE_SENSE_NAMES = NO +HIDE_SCOPE_NAMES = NO +HIDE_COMPOUND_REFERENCE= NO +SHOW_HEADERFILE = YES +SHOW_INCLUDE_FILES = NO +SHOW_GROUPED_MEMB_INC = NO +FORCE_LOCAL_INCLUDES = NO +INLINE_INFO = YES +SORT_MEMBER_DOCS = NO +SORT_BRIEF_DOCS = NO +SORT_MEMBERS_CTORS_1ST = NO +SORT_GROUP_NAMES = NO +SORT_BY_SCOPE_NAME = NO +STRICT_PROTO_MATCHING = NO +GENERATE_TODOLIST = YES +GENERATE_TESTLIST = YES +GENERATE_BUGLIST = YES +GENERATE_DEPRECATEDLIST= YES +ENABLED_SECTIONS = YES +MAX_INITIALIZER_LINES = 30 +SHOW_USED_FILES = NO +SHOW_FILES = NO +SHOW_NAMESPACES = YES +FILE_VERSION_FILTER = +LAYOUT_FILE = ccpp_dox_layout.xml +CITE_BIB_FILES = library.bib + +#--------------------------------------------------------------------------- +# Configuration options related to warning and progress messages +#--------------------------------------------------------------------------- +QUIET = NO +WARNINGS = YES +WARN_IF_UNDOCUMENTED = NO +WARN_IF_DOC_ERROR = YES +WARN_IF_INCOMPLETE_DOC = YES +WARN_NO_PARAMDOC = NO +WARN_AS_ERROR = NO +WARN_FORMAT = +WARN_LOGFILE = + +#--------------------------------------------------------------------------- +# Configuration options related to the input files +#--------------------------------------------------------------------------- + +INPUT = pdftxt/SRW_mainpage.txt \ + pdftxt/SRW_all_shemes_list.txt \ + pdftxt/GFS_v16_suite.txt \ + pdftxt/HRRR_suite.txt \ + pdftxt/RAP_suite.txt \ + pdftxt/RRFS_v1beta_suite.txt \ + pdftxt/WoFS_v0_suite.txt \ + pdftxt/RRFS_SGSCLOUD.txt \ + pdftxt/GFS_RRTMG.txt \ + pdftxt/GFS_SFCLYR.txt \ + pdftxt/MYNN_SFCLAYER.txt \ + pdftxt/GFS_NSST.txt \ + pdftxt/GFS_OCEAN.txt \ + pdftxt/GFS_NOAH.txt \ + pdftxt/GFS_SFCSICE.txt \ + pdftxt/GFS_SATMEDMFVDIFQ.txt \ + pdftxt/GFS_NOAHMP.txt \ + pdftxt/GFS_UGWPv0.txt \ + pdftxt/GFS_drag_suite.txt \ + pdftxt/GFS_GWDPS.txt \ + pdftxt/GFS_OZPHYS.txt \ + pdftxt/GFS_H2OPHYS.txt \ + pdftxt/GFS_SAMFdeep.txt \ + pdftxt/GFS_SAMFshal.txt \ + pdftxt/GFDL_cloud.txt \ + pdftxt/NSSLMICRO.txt \ + pdftxt/MYNN_EDMF.txt \ + pdftxt/CU_GF_deep.txt \ + pdftxt/RUCLSM.txt \ + pdftxt/THOMPSON.txt \ + pdftxt/suite_input.nml.txt \ + pdftxt/CLM_LAKE.txt \ + pdftxt/GFS_SPP.txt \ + ../fv_sat_adj.F90 \ + ../GFS_time_vary_pre.fv3.F90 \ + ../GFS_rad_time_vary.fv3.F90 \ + ../GFS_phys_time_vary.fv3.F90 \ + ../get_prs_fv3.F90 \ + ../get_phi_fv3.F90 \ + ../ozne_def.f \ + ../ozinterp.f90 \ + ../h2o_def.f \ + ../h2ointerp.f90 \ + ../aerclm_def.F \ + ../aerinterp.F90 \ + ../iccn_def.F \ + ../iccninterp.F90 \ + ../sfcsub.F \ + ../gcycle.F90 \ + ../GFS_suite_interstitial_1.F90 \ + ../GFS_suite_interstitial_2.F90 \ + ../GFS_suite_interstitial_3.F90 \ + ../GFS_suite_interstitial_4.F90 \ + ../GFS_suite_interstitial_5.F90 \ + ../GFS_suite_interstitial_phys_reset.F90 \ + ../GFS_suite_interstitial_rad_reset.F90 \ + ../GFS_suite_stateout_reset.F90 \ + ../GFS_suite_stateout_update.F90 \ + ../GFS_surface_composites_inter.F90 \ + ../GFS_surface_composites_pre.F90 \ + ../GFS_surface_composites_post.F90 \ + ../GFS_surface_loop_control_part1.F90 \ + ../GFS_surface_loop_control_part2.F90 \ + ../GFS_radiation_surface.F90 \ + ../GFS_rrtmg_pre.F90 \ + ../GFS_rrtmg_post.F90 \ + ../GFS_rrtmg_setup.F90 \ + ../rad_sw_pre.F90 \ + ../sgscloud_radpre.F90 \ + ../sgscloud_radpost.F90 \ + ../radsw_main.F90 \ + ../rrtmg_sw_post.F90 \ + ../rrtmg_lw_pre.F90 \ + ../radlw_main.F90 \ + ../rrtmg_lw_post.F90 \ + ../radiation_aerosols.f \ + ../radiation_astronomy.f \ + ../radiation_clouds.f \ + ../radiation_cloud_overlap.F90 \ + ../radiation_gases.f \ + ../radiation_surface.f \ + ../radlw_param.f \ + ../radlw_datatb.f \ + ../radsw_param.f \ + ../radsw_datatb.f \ + ../GFS_cloud_diagnostics.F90 \ + ../dcyc2t3.f \ + ../sfc_diff.f \ + ../sfc_diag.f \ + ../sfc_diag_post.F90 \ + ../sfc_nst.f \ + ../sfc_nst_pre.f \ + ../sfc_nst_post.f \ + ../sfc_ocean.F \ + ../clm_lake.f90 \ + ../module_nst_model.f90 \ + ../module_nst_parameters.f90 \ + ../module_nst_water_prop.f90 \ + ../lsm_noah.f \ + ../sflx.f \ + ../namelist_soilveg.f \ + ../set_soilveg.f \ + ../noahmpdrv.F90 \ + ../module_sf_noahmplsm.f90 \ + ../module_sf_noahmp_glacier.f90 \ + ../noahmp_tables.f90 \ + ../GFS_surface_generic_pre.F90 \ + ../GFS_surface_generic_post.F90 \ + ../surface_perturbation.F90 \ + ../GFS_DCNV_generic_pre.F90 \ + ../GFS_DCNV_generic_post.F90 \ + ../GFS_SCNV_generic_pre.F90 \ + ../GFS_SCNV_generic_post.F90 \ + ../sfc_sice.f \ + ../satmedmfvdifq.F \ + ../mfpbltq.f \ + ../mfscuq.f \ + ../tridi.f \ + ../GFS_GWD_generic_pre.F90 \ + ../GFS_GWD_generic_post.F90 \ + ../unified_ugwp.F90 \ + ../drag_suite.F90 \ + ../cires_tauamf_data.F90 \ + ../cires_orowam2017.f \ + ../cires_ugwp.F90 \ + ../cires_ugwp_initialize.F90 \ + ../cires_ugwp_module.F90 \ + ../cires_ugwp_post.F90 \ + ../cires_ugwp_triggers.F90 \ + ../cires_ugwp_module.F90 \ + ../gwdps.f \ + ../ugwp_driver_v0.F \ + ../ozphys_2015.f \ + ../h2ophys.f \ + ../samfdeepcnv.f \ + ../samfshalcnv.f \ + ../progsigma_calc.f90 \ + ../cnvc90.f \ + ../module_bfmicrophysics.f \ + ../gfdl_cloud_microphys.F90 \ + ../module_gfdl_cloud_microphys.F90 \ + ../GFS_MP_generic_pre.F90 \ + ../GFS_MP_generic_post.F90 \ + ../GFS_PBL_generic_common.F90 \ + ../GFS_PBL_generic_pre.F90 \ + ../GFS_PBL_generic_post.F90 \ + ../calpreciptype.f90 \ + ../GFS_stochastics.F90 \ + ../cu_gf_driver.F90 \ + ../cu_gf_driver_pre.F90 \ + ../cu_gf_deep.F90 \ + ../cu_gf_sh.F90 \ + ../cu_gf_driver_post.F90 \ + ../mynnedmf_wrapper.F90 \ + ../module_bl_mynn.F90 \ + ../bl_mynn_common.f90 \ + ../mynnsfc_wrapper.F90 \ + ../module_sf_mynn.F90 \ + ../lsm_ruc.F90 \ + ../module_sf_ruclsm.F90 \ + ../namelist_soilveg_ruc.F90 \ + ../set_soilveg_ruc.F90 \ + ../module_soil_pre.F90 \ + ../mp_thompson_pre.F90 \ + ../module_mp_thompson_make_number_concentrations.F90 \ + ../mp_thompson.F90 \ + ../module_mp_thompson.F90 \ + ../module_mp_radar.F90 \ + ../mp_thompson_post.F90 \ + ../mp_nssl.F90 \ + ../module_mp_nssl_2mom.F90 \ + ../funcphys.f90 \ + ../physcons.F90 \ + ../radcons.f90 \ + ../mersenne_twister.f \ + ../maximum_hourly_diagnostics.F90 \ + ../phys_tend.F90 + +INPUT_ENCODING = UTF-8 +FILE_PATTERNS = *.f \ + *.F \ + *.F90 \ + *.f90 \ + *.nml \ + *.txt +RECURSIVE = YES +EXCLUDE = +EXCLUDE_SYMLINKS = NO +EXCLUDE_PATTERNS = +EXCLUDE_SYMBOLS = +EXAMPLE_PATH = pdftxt/RE300 \ + doc/html +EXAMPLE_PATTERNS = +EXAMPLE_RECURSIVE = NO +IMAGE_PATH = img +INPUT_FILTER = +FILTER_PATTERNS = +FILTER_SOURCE_FILES = NO +FILTER_SOURCE_PATTERNS = +USE_MDFILE_AS_MAINPAGE = + +#--------------------------------------------------------------------------- +# Configuration options related to source browsing +#--------------------------------------------------------------------------- + +SOURCE_BROWSER = NO +INLINE_SOURCES = NO +STRIP_CODE_COMMENTS = YES +REFERENCED_BY_RELATION = YES +REFERENCES_RELATION = YES +REFERENCES_LINK_SOURCE = YES +SOURCE_TOOLTIPS = YES +USE_HTAGS = NO +VERBATIM_HEADERS = YES +CLANG_ASSISTED_PARSING = NO +CLANG_ADD_INC_PATHS = YES +CLANG_OPTIONS = +CLANG_DATABASE_PATH = + +#--------------------------------------------------------------------------- +# Configuration options related to the alphabetical class index +#--------------------------------------------------------------------------- + +ALPHABETICAL_INDEX = NO +IGNORE_PREFIX = + +#--------------------------------------------------------------------------- +# Configuration options related to the HTML output +#--------------------------------------------------------------------------- + +GENERATE_HTML = YES +HTML_OUTPUT = html +HTML_FILE_EXTENSION = .html +HTML_HEADER = _doxygen/header.html +HTML_FOOTER = _doxygen/footer.html +HTML_STYLESHEET = +HTML_EXTRA_STYLESHEET = _doxygen/doxygen-awesome.css \ + _doxygen/doxygen-awesome-sidebar-only.css \ + _doxygen/doxygen-awesome-sidebar-only-darkmode-toggle.css \ + _doxygen/doxygen-awesome-ccpp.css +HTML_EXTRA_FILES = _doxygen/doxygen-awesome-darkmode-toggle.js \ + _doxygen/doxygen-awesome-ccpp.js +HTML_COLORSTYLE_HUE = 209 +HTML_COLORSTYLE_SAT = 255 +HTML_COLORSTYLE_GAMMA = 113 +HTML_TIMESTAMP = NO +HTML_DYNAMIC_MENUS = YES +HTML_DYNAMIC_SECTIONS = NO +HTML_INDEX_NUM_ENTRIES = 100 +GENERATE_DOCSET = NO +DOCSET_FEEDNAME = "Doxygen generated docs" +DOCSET_FEEDURL = +DOCSET_BUNDLE_ID = org.doxygen.Project +DOCSET_PUBLISHER_ID = org.doxygen.Publisher +DOCSET_PUBLISHER_NAME = Publisher +GENERATE_HTMLHELP = NO +CHM_FILE = +HHC_LOCATION = +GENERATE_CHI = NO +CHM_INDEX_ENCODING = +BINARY_TOC = NO +TOC_EXPAND = NO +GENERATE_QHP = NO +QCH_FILE = +QHP_NAMESPACE = org.doxygen.Project +QHP_VIRTUAL_FOLDER = doc +QHP_CUST_FILTER_NAME = +QHP_CUST_FILTER_ATTRS = +QHP_SECT_FILTER_ATTRS = +QHG_LOCATION = +GENERATE_ECLIPSEHELP = NO +ECLIPSE_DOC_ID = org.doxygen.Project +DISABLE_INDEX = YES +GENERATE_TREEVIEW = YES +FULL_SIDEBAR = NO +ENUM_VALUES_PER_LINE = 4 +TREEVIEW_WIDTH = 335 +EXT_LINKS_IN_WINDOW = NO +OBFUSCATE_EMAILS = YES +HTML_FORMULA_FORMAT = SVG +FORMULA_FONTSIZE = 10 +FORMULA_TRANSPARENT = YES +FORMULA_MACROFILE = +USE_MATHJAX = YES +MATHJAX_VERSION = MathJax_2 +MATHJAX_FORMAT = HTML-CSS +#MATHJAX_RELPATH = https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.2 +MATHJAX_RELPATH = https://cdn.jsdelivr.net/npm/mathjax@2 +MATHJAX_EXTENSIONS = +MATHJAX_CODEFILE = +SEARCHENGINE = YES +SERVER_BASED_SEARCH = NO +EXTERNAL_SEARCH = NO +SEARCHENGINE_URL = +SEARCHDATA_FILE = searchdata.xml +EXTERNAL_SEARCH_ID = +EXTRA_SEARCH_MAPPINGS = + +#--------------------------------------------------------------------------- +# Configuration options related to the LaTeX output +#--------------------------------------------------------------------------- + +GENERATE_LATEX = YES +LATEX_OUTPUT = latex +LATEX_CMD_NAME = latex +MAKEINDEX_CMD_NAME = makeindex +LATEX_MAKEINDEX_CMD = makeindex +COMPACT_LATEX = YES +PAPER_TYPE = a4 +EXTRA_PACKAGES = amsmath +LATEX_HEADER = +LATEX_FOOTER = +LATEX_EXTRA_STYLESHEET = +LATEX_EXTRA_FILES = +PDF_HYPERLINKS = YES +USE_PDFLATEX = YES +LATEX_BATCHMODE = NO +LATEX_HIDE_INDICES = YES +LATEX_BIB_STYLE = plainnat +LATEX_TIMESTAMP = NO +LATEX_EMOJI_DIRECTORY = + +#--------------------------------------------------------------------------- +# Configuration options related to the RTF output +#--------------------------------------------------------------------------- + +GENERATE_RTF = NO +RTF_OUTPUT = rtf +COMPACT_RTF = NO +RTF_HYPERLINKS = NO +RTF_STYLESHEET_FILE = +RTF_EXTENSIONS_FILE = + +#--------------------------------------------------------------------------- +# Configuration options related to the man page output +#--------------------------------------------------------------------------- + +GENERATE_MAN = NO +MAN_OUTPUT = man +MAN_EXTENSION = .3 +MAN_SUBDIR = +MAN_LINKS = NO + +#--------------------------------------------------------------------------- +# Configuration options related to the XML output +#--------------------------------------------------------------------------- + +GENERATE_XML = NO +XML_OUTPUT = xml +XML_PROGRAMLISTING = YES +XML_NS_MEMB_FILE_SCOPE = NO + +#--------------------------------------------------------------------------- +# Configuration options related to the DOCBOOK output +#--------------------------------------------------------------------------- + +GENERATE_DOCBOOK = NO +DOCBOOK_OUTPUT = docbook + +#--------------------------------------------------------------------------- +# Configuration options for the AutoGen Definitions output +#--------------------------------------------------------------------------- + +GENERATE_AUTOGEN_DEF = NO + +#--------------------------------------------------------------------------- +# Configuration options related to the Perl module output +#--------------------------------------------------------------------------- + +GENERATE_PERLMOD = NO +PERLMOD_LATEX = NO +PERLMOD_PRETTY = YES +PERLMOD_MAKEVAR_PREFIX = + +#--------------------------------------------------------------------------- +# Configuration options related to the preprocessor +#--------------------------------------------------------------------------- + +ENABLE_PREPROCESSING = NO +MACRO_EXPANSION = NO +EXPAND_ONLY_PREDEF = NO +SEARCH_INCLUDES = YES +INCLUDE_PATH = +INCLUDE_FILE_PATTERNS = +PREDEFINED = CCPP \ + MULTI_GASES \ + 0 +EXPAND_AS_DEFINED = +SKIP_FUNCTION_MACROS = YES + +#--------------------------------------------------------------------------- +# Configuration options related to external references +#--------------------------------------------------------------------------- + +TAGFILES = +GENERATE_TAGFILE = +ALLEXTERNALS = NO +EXTERNAL_GROUPS = YES +EXTERNAL_PAGES = YES + +#--------------------------------------------------------------------------- +# Configuration options related to the dot tool +#--------------------------------------------------------------------------- + +DIA_PATH = +HIDE_UNDOC_RELATIONS = YES +HAVE_DOT = YES +DOT_NUM_THREADS = 0 +DOT_FONTNAME = Source Sans Pro +DOT_FONTSIZE = +DOT_FONTPATH = +CLASS_GRAPH = YES +COLLABORATION_GRAPH = YES +GROUP_GRAPHS = YES +UML_LOOK = YES +UML_LIMIT_NUM_FIELDS = 10 +DOT_UML_DETAILS = NO +DOT_WRAP_THRESHOLD = 17 +TEMPLATE_RELATIONS = NO +INCLUDE_GRAPH = YES +INCLUDED_BY_GRAPH = NO +CALL_GRAPH = YES +CALLER_GRAPH = YES +GRAPHICAL_HIERARCHY = YES +DIRECTORY_GRAPH = YES +DIR_GRAPH_MAX_DEPTH = 1 +DOT_IMAGE_FORMAT = SVG +INTERACTIVE_SVG = NO +DOT_PATH = /Users/man.zhang/homebrew/bin/dot +DOTFILE_DIRS = +MSCFILE_DIRS = +DIAFILE_DIRS = +PLANTUML_JAR_PATH = +PLANTUML_CFG_FILE = +PLANTUML_INCLUDE_PATH = +DOT_GRAPH_MAX_NODES = 1000 +MAX_DOT_GRAPH_DEPTH = 0 +DOT_TRANSPARENT = YES +DOT_MULTI_TARGETS = YES +GENERATE_LEGEND = YES +DOT_CLEANUP = YES diff --git a/physics/docs/library.bib b/physics/docs/library.bib index b6109b12c..7c01fbc65 100644 --- a/physics/docs/library.bib +++ b/physics/docs/library.bib @@ -1,13 +1,159 @@ %% This BibTeX bibliography file was created using BibDesk. %% https://bibdesk.sourceforge.io/ -%% Created for Man Zhang at 2022-10-13 16:15:17 -0600 +%% Created for Man Zhang at 2023-06-07 10:17:09 -0600 %% Saved with string encoding Unicode (UTF-8) +@article{Lin_2022, + author = {Jialin Lin and Taotao Qian and Peter Bechtold and Georg Grell and Guang J. Zhang and Ping Zhu and Saulo R. Freitas and Hannah Barnes and Jongil Han}, + date-added = {2023-06-07 10:16:46 -0600}, + date-modified = {2023-06-07 10:16:46 -0600}, + doi = {10.1080/07055900.2022.2082915}, + journal = {Atmosphere-Ocean}, + month = {jul}, + number = {3-4}, + pages = {422--476}, + publisher = {Informa {UK} Limited}, + title = {Atmospheric Convection}, + url = {https://doi.org/10.1080%2F07055900.2022.2082915}, + volume = {60}, + year = 2022, + bdsk-url-1 = {https://doi.org/10.1080%2F07055900.2022.2082915}, + bdsk-url-2 = {https://doi.org/10.1080/07055900.2022.2082915}} + +@techreport{He_2023, + author = {He, Cenlin and Valayamkunnath, Prasanth and Barlage, Michael and Chen, Fei and Gochis, David and Cabell, Ryan and Schneider, Tim and Rasmussen, Roy and Niu, Guo-Yue and Yang, Zong-Liang and Niyogi, Dev and Ek, Michael}, + date-added = {2023-06-06 12:37:33 -0600}, + date-modified = {2023-06-06 12:39:16 -0600}, + doi = {10.5065/EW8G-YR95}, + publisher = {NCAR/UCAR}, + title = {The Community Noah-MP Land Surface Modeling System Technical Description Version 5.0}, + url = {https://opensky.ucar.edu/islandora/object/technotes:599}, + year = {2023}, + bdsk-url-1 = {https://opensky.ucar.edu/islandora/object/technotes:599}, + bdsk-url-2 = {https://doi.org/10.5065/EW8G-YR95}} + +@article{Niu_2007, + author = {Guo-Yue Niu and Zong-Liang Yang}, + date-added = {2023-06-05 14:03:26 -0600}, + date-modified = {2023-06-05 14:03:26 -0600}, + doi = {10.1029/2007jd008674}, + journal = {Journal of Geophysical Research}, + month = {nov}, + number = {D21}, + publisher = {American Geophysical Union ({AGU})}, + title = {An observation-based formulation of snow cover fraction and its evaluation over large North American river basins}, + url = {https://doi.org/10.1029%2F2007jd008674}, + volume = {112}, + year = 2007, + bdsk-url-1 = {https://doi.org/10.1029%2F2007jd008674}, + bdsk-url-2 = {https://doi.org/10.1029/2007jd008674}} + +@techreport{Oleson2013, + author = {Oleson, Keith and Lawrence, David and Bonan, Gordon and Drewniak, Beth and Huang, Maoyi and Koven, Charles and Levis, Samuel and Li, Fang and Riley, William and Subin, Zachary and Swenson, Sean and Thornton, Peter and Bozbiyik, Anil and Fisher, Rosie and Heald, Colette and Kluzek, Erik and Lamarque, Jean-Francois and Lawrence, Peter and Leung, L and Lipscomb, William and Muszala, Stefan and Ricciuto, Daniel and Sacks, William and Sun, Ying and Tang, Jinyun and Yang, Zong-Liang}, + date-added = {2023-06-05 09:28:16 -0600}, + date-modified = {2023-06-05 09:30:30 -0600}, + doi = {10.5065/D6RR1W7M}, + keywords = {Land surface model, Climate model, Biogeochemistry, Biogeophysics}, + language = {en}, + publisher = {UCAR/NCAR}, + title = {Technical description of version 4.5 of the Community Land Model (CLM)}, + url = {http://opensky.ucar.edu/islandora/object/technotes:515}, + year = {2013}, + bdsk-url-1 = {http://opensky.ucar.edu/islandora/object/technotes:515}, + bdsk-url-2 = {https://doi.org/10.5065/D6RR1W7M}} + +@article{Kourzeneva_2012, + author = {Ekaterina Kourzeneva and Hermann Asensio and Eric Martin and Stephanie Faroux}, + date-added = {2023-05-30 11:29:07 -0600}, + date-modified = {2023-05-30 11:29:07 -0600}, + doi = {10.3402/tellusa.v64i0.15640}, + journal = {Tellus A: Dynamic Meteorology and Oceanography}, + month = {dec}, + number = {1}, + pages = {15640}, + publisher = {Stockholm University Press}, + title = {Global gridded dataset of lake coverage and lake depth for use in numerical weather prediction and climate modelling}, + url = {https://doi.org/10.3402%2Ftellusa.v64i0.15640}, + volume = {64}, + year = 2012, + bdsk-url-1 = {https://doi.org/10.3402%2Ftellusa.v64i0.15640}, + bdsk-url-2 = {https://doi.org/10.3402/tellusa.v64i0.15640}} + +@article{Gu2015, + abstract = {A one-dimensional (1-D) physically based lake model was coupled to the Weather Research and Forecasting (WRF) model version 3.2 developed by the National Center for Atmospheric Research to dynamically simulate physical processes of lakes and their effects on weather and climate at local and regional scales. Our study area is focused on the Great Lakes. This coupled model realistically reproduces the lake surface temperature (LST) at a buoy station in a shallow lake (Lake Erie) while generating strong LST biases ranging from −20 to 20 {\textdegree}C at a buoy station in a deep lake (Lake Superior). Through many sensitivity tests, we find that the biases in the deep lake LST simulations result from the drastic underestimation of heat transfer between the lower and upper parts of the lake through unrealistic eddy diffusion. Additional tests were made to calibrate the eddy diffusivity in WRF-Lake. It is found that when this parameter is multiplied by a factor ranging from 102 to 105 for various lake depths deeper than 15 m, the LST simulations for the deep lake buoy station show good agreement with observations, and the bias range reduces to {\textpm}4 {\textdegree}C. Essentially, the enlarged eddy diffusivity strengthens heat transfer within the lake columns in the deep lake, which is significantly underestimated in the lake model without calibration. Validation simulations with the calibrated eddy diffusivity were carried out for the whole of Lake Superior and Lake Erie. The LST simulations still have a substantial bias reduction when compared with those produced with the original eddy diffusivity, indicating that the calibrated parameter is representative. In addition, the improved 1-D lake model with WRF reasonably reproduces the remotely sensed LST geographic distribution.}, + author = {Gu, Hongping and Jin, Jiming and Wu, Yihua and Ek, Michael B. and Subin, Zachary M.}, + date-added = {2023-05-24 14:45:55 -0600}, + date-modified = {2023-05-24 14:45:55 -0600}, + day = {01}, + doi = {10.1007/s10584-013-0978-y}, + issn = {1573-1480}, + journal = {Climatic Change}, + month = {Apr}, + number = {3}, + pages = {471--483}, + title = {Calibration and validation of lake surface temperature simulations with the coupled WRF-lake model}, + url = {https://link.springer.com/content/pdf/10.1007/s10584-013-0978-y.pdf}, + volume = {129}, + year = {2015}, + bdsk-url-1 = {https://link.springer.com/content/pdf/10.1007/s10584-013-0978-y.pdf}, + bdsk-url-2 = {https://doi.org/10.1007/s10584-013-0978-y}} + +@article{Subin_2012, + author = {Zachary M. Subin and William J. Riley and Dmitrii Mironov}, + date-added = {2023-05-24 14:35:27 -0600}, + date-modified = {2023-05-24 14:35:27 -0600}, + doi = {10.1029/2011ms000072}, + journal = {Journal of Advances in Modeling Earth Systems}, + month = {feb}, + publisher = {American Geophysical Union ({AGU})}, + title = {An improved lake model for climate simulations: Model structure, evaluation, and sensitivity analyses in {CESM}1}, + url = {https://doi.org/10.1029%2F2011ms000072}, + volume = {4}, + year = 2012, + bdsk-url-1 = {https://doi.org/10.1029%2F2011ms000072}, + bdsk-url-2 = {https://doi.org/10.1029/2011ms000072}} + +@article{Lawrence_2019, + author = {David M. Lawrence and Rosie A. Fisher and Charles D. Koven and Keith W. Oleson and Sean C. Swenson and Gordon Bonan and Nathan Collier and Bardan Ghimire and Leo van Kampenhout and Daniel Kennedy and Erik Kluzek and Peter J. Lawrence and Fang Li and Hongyi Li and Danica Lombardozzi and William J. Riley and William J. Sacks and Mingjie Shi and Mariana Vertenstein and William R. Wieder and Chonggang Xu and Ashehad A. Ali and Andrew M. Badger and Gautam Bisht and Michiel van den Broeke and Michael A. Brunke and Sean P. Burns and Jonathan Buzan and Martyn Clark and Anthony Craig and Kyla Dahlin and Beth Drewniak and Joshua B. Fisher and Mark Flanner and Andrew M. Fox and Pierre Gentine and Forrest Hoffman and Gretchen Keppel-Aleks and Ryan Knox and Sanjiv Kumar and Jan Lenaerts and L. Ruby Leung and William H. Lipscomb and Yaqiong Lu and Ashutosh Pandey and Jon D. Pelletier and Justin Perket and James T. Randerson and Daniel M. Ricciuto and Benjamin M. Sanderson and Andrew Slater and Zachary M. Subin and Jinyun Tang and R. Quinn Thomas and Maria Val Martin and Xubin Zeng}, + date-added = {2023-05-24 14:34:12 -0600}, + date-modified = {2023-05-24 14:34:12 -0600}, + doi = {10.1029/2018ms001583}, + journal = {Journal of Advances in Modeling Earth Systems}, + month = {dec}, + number = {12}, + pages = {4245--4287}, + publisher = {American Geophysical Union ({AGU})}, + title = {The Community Land Model Version 5: Description of New Features, Benchmarking, and Impact of Forcing Uncertainty}, + url = {https://doi.org/10.1029%2F2018ms001583}, + volume = {11}, + year = 2019, + bdsk-url-1 = {https://doi.org/10.1029%2F2018ms001583}, + bdsk-url-2 = {https://doi.org/10.1029/2018ms001583}} + +@article{cite-key, + date-added = {2023-05-24 11:18:09 -0600}, + date-modified = {2023-05-24 11:18:09 -0600}} + +@article{gmd-15-6659-2022, + author = {Benjamin, S. G. and Smirnova, T. G. and James, E. P. and Anderson, E. J. and Fujisaki-Manome, A. and Kelley, J. G. W. and Mann, G. E. and Gronewold, A. D. and Chu, P. and Kelley, S. G. T.}, + date-added = {2023-05-24 10:51:47 -0600}, + date-modified = {2023-05-24 10:51:47 -0600}, + doi = {10.5194/gmd-15-6659-2022}, + journal = {Geoscientific Model Development}, + number = {17}, + pages = {6659--6676}, + title = {Inland lake temperature initialization via coupled cycling with atmospheric data assimilation}, + url = {https://gmd.copernicus.org/articles/15/6659/2022/}, + volume = {15}, + year = {2022}, + bdsk-url-1 = {https://gmd.copernicus.org/articles/15/6659/2022/}, + bdsk-url-2 = {https://doi.org/10.5194/gmd-15-6659-2022}} + @article{Chaboureau_2005, author = {Jean-Pierre Chaboureau}, date-added = {2022-10-13 16:14:54 -0600}, @@ -3663,6 +3809,18 @@ @article{tsiringakis_et_al_2017 year = {2017}, bdsk-url-1 = {https://doi.org/10.1002/qj.3021}} +@article{sturm_1997, + author = {Sturm, Matthew and Holmgren, Jon and K{\"o}nig, Max and Morris, Kim}, + doi = {10.3189/S0022143000002781}, + journal = {Journal of Glaciology}, + number = {143}, + pages = {26--41}, + publisher = {Cambridge University Press}, + title = {The thermal conductivity of seasonal snow}, + volume = {43}, + year = {1997}, + bdsk-url-1 = {https://doi.org/10.3189/S0022143000002781}} + @comment{BibDesk Static Groups{ diff --git a/physics/docs/pdftxt/CLM_LAKE.txt b/physics/docs/pdftxt/CLM_LAKE.txt new file mode 100644 index 000000000..c091d2b17 --- /dev/null +++ b/physics/docs/pdftxt/CLM_LAKE.txt @@ -0,0 +1,59 @@ +/** +\page CLM_LAKE_model CLM Lake Model +\section des_clmlake Description + +CLM lake model is a multi-level one-dimensional lake model that has been implemented within the operational 3-km HRRR and +13-km RAP for small lakes (Benjamin et al. (2022) \cite gmd-15-6659-2022). It is the Community Land Model, version 4.5. +Subin et al. (2012) \cite Subin_2012 describe the 1-d CLM lake model as applied within the Community Earth System +Model (CESM) as a component of the overall CESM CLM (Lawrence et al. (2019) \cite Lawrence_2019). Gu et al. (2015) \cite Gu2015 +describe the introduction of the CLM lake model into the WRF model and inital experiments using its 1-d solution for both +lakes Superior (average depth of 147 m) and Erie (average depth of 19 m). + +The atmospheric inputs into the model are temperature, water vapor, horizontal wind components from the lowest atmospheric level +and short-wave and longwave radiative fluxes. The CLM lake model then provides latent heat and sensible heat fluxes back to the +atmosphere. It also computes 2-m temperature/moisture, skin temperature, lake temperature, ice fraction, ice thickness, snow water +equivalent and snow depth. The CLM lake model divides the vertical lake profile into 10 layers driven by wind-driven eddies. The +thickness of the top layer is fixed to 10-cm and the rest of the lake depth is divided evenly into the other 9 layers. Energy +transfer (heat and kinetic energy) occurs between lake layers via eddy and molecular diffusion as a function of the vertical +temperature gradient. The CLM lake model also uses a 10-layer soil model beneath the lake, a multi-layer ice formation model and +up to 5-layer snow-on-ice model. Multiple layers in lake model have the potential to better represent vertical mixing processes +in the lake. + +Testing of the CLM lake model within RAP/HRRR applications showed computational efficiency of the model with no change of even +0.1% in run time. The lake/snow variables have to be continuously transfered within the CLM lake model from one forecast to another, +constrained by the atmospheric data assimilation. The lake-cycling initialization in RAP/HRRR has been effective overall, owing to +accurate houly estimates of near-surface temperature, moisture and winds, and shortwave and longwave estimates provided to the 1-d CLM +lake model every time step (Benjamin et al. (2022) \cite gmd-15-6659-2022). Cycling technique showed improvements over initializing +lake temperatures from the SST analysis, problematic for small water bodies. The improvements are particularly eminent during transition +periods between cold and warm seasons, and in the regions with anomalies in weather conditions. The CLM lake model has the potential +to improve surface prediction in the vicinity of small lakes. + +The CLM lake model requires bathymetry for the lake points in the model domain. Grid points are assigned as lake points when the +fraction of lake coverage in the grid cell exceeds 50% and when this point is disconnected from oceans. The lake water mask is +therefore binary, set to either 1 or 0. This binary approach for models with higher horizontal resolution, for example, 3-km resolution in +the regional application of UFS (RRFS), is capable of capturing the effect of lakes on regional heat and moisture fluxes. + +Lake depths for the RRFS lake configuration (Fig.1) are assigned from a global dataset provided by Kourzeneva et al.(2012) \cite Kourzeneva_2012, +this dataset is referred to as GLOBv3 bathymetry in the UFS_UTL. + +\image html Lake_depths_RRFS3km.png "Figure 1: Lake depths for lakes in the 3-km RRFS domain." width=600 + +To cold-start the CLM lake model in RRFS: +- Use the CLM option in the input.nml +\n - lkm = 1 +\n - iopt_lake = 2 +- Lake temperature is initialized from interpolation between SST at the surface and \f$-4^oC\f$ at 50-m depth +\n - A special case is for the Great Salt Lake, the temperature is limited with +/- 3 K from the bi-weekly climatology +- Temperature for soil under the lake is initialized from bottom lake temperature at the top to the substrate soil temperature at the bottom of soil layer +- Lake ice at the top level is initialized from the GFS ice concentration + +The differences of surface variables from the RRFS 6-h forecast with/without CLM lake model are shown in Figure 2 for 2-m temperature and in Figure 3 for 2-m dewpoint. +\image html diff_t2m_lake_rrfs.png "Figure 2: Differences of 2-m temperature between the RRFS coupled to the CLM model and the RRFS without CLM." width=600 +\image html diff_td2m_lake_rrfs.png "Figure 3: Differences of 2-m dew point between the RRFS coupled to the CLM model and the RRFS without CLM." width=600 + + + +\section intra_clmlake Intraphysics Communication +- \ref arg_table_clm_lake_run + +*/ diff --git a/physics/docs/pdftxt/CU_GF_deep.txt b/physics/docs/pdftxt/CU_GF_deep.txt index 92b8c3b7c..f30cb28dc 100644 --- a/physics/docs/pdftxt/CU_GF_deep.txt +++ b/physics/docs/pdftxt/CU_GF_deep.txt @@ -3,26 +3,22 @@ \section gfcu_descrip Description The Grell-Freitas (GF) scheme, as described in Grell and Freitas (2014) \cite grell_and_freitas_2014, -Freitas et al. (2018) \cite freitas_et_al_2018, Freitas et al. (2021) \cite freitas_et_al_2021, and Lin et al. (2022) -(under review) follows the mass flux approach published by Grell (1993) \cite grell_1993. +Freitas et al. (2018) \cite freitas_et_al_2018, Freitas et al. (2021) \cite freitas_et_al_2021, and Lin et al. (2022) \cite Lin_2022 +follows the mass flux approach published by Grell (1993) \cite grell_1993. Further developments by Grell and \f$D\acute{e}v\acute{e}nyi\f$ (2002) \cite Grell_2002 included implementing -stochastics through allowing parameter perturbations. In GF1 scale awareness, and the aerosol dependence through rain generation (following +stochastics through allowing parameter perturbations. In GF scale awareness, and the aerosol dependence through rain generation (following Berry (1968) \cite berry_1968 and evaporation formulations (following Jiang et al. (2010) \cite Jiang_2010 ), depending on the -cloud concentration nuclei at cloud base were added. FG included mixed phase physics impact, momentum transport (as in ECMWF), +cloud concentration nuclei at cloud base were added. GF included mixed phase physics impact, momentum transport, a diurnal cycle closure (Bechtold et al. (2014) \cite bechtold_et_al_2014 ), and a trimodal spectral size to simulate the interaction -and transition from shallow, congestus and deep convection regimes. In order for this trimodal size spectrum to be -accurately represented, GF's deep and shallow convective schemes must be run together. -The vertical massflux distribution of shallow, congestus and +and transition from shallow, congestus and deep convection regimes. The vertical massflux distribution of shallow, congestus and deep convection regimes is characterized by Probability Density Functions (PDF's). The three PDF's are meant to represent the average statistical mass flux characteristic of deep, congestus, and shallow (respectively) plumes in the grid area. Each PDF therefore represents a spectrum of plumes within the grid box. Forcing is different for each characteristic type. Entrainment and detrainment are derived -from the PDF's. The deep convection considers scale awareness (Arakawa et al. (2011) \cite Arakawa_2011 ), the congestus type convection -as well as the shallow convection are not scale-aware. Aerosol dependence is implemented through dependence of rain generation and +from the PDF's. The deep and congestus convection considers scale awareness (Arakawa et al. (2011) \cite Arakawa_2011 ), the shallow convection is not scale-aware. Aerosol dependence is implemented through dependence of rain generation and evaporation formulations depending on the cloud concentration nuclei at cloud base (Berry 1968 \cite berry_1968, -Jiang et al.(2010) \cite Jiang_2010, and Lee and Feingold (2010) \cite lee_and_feingold_2010 ). Aerosol dependence is considered experimental and +Jiang et al.(2010) \cite Jiang_2010, and Lee and Feingold (2010) \cite lee_and_feingold_2010 ). Wet scavenging is considered to add a memory impact. Aerosol dependence is considered experimental and is turned off at this point. GF is able to transport tracers. -A paper describing the latest changes and modifications is in process and will be submitted to GMD. \section version_cugf_enh CCPP Physics Updates \version CCPP v6.0.0 @@ -42,6 +38,20 @@ transition as grid spacing decreases into a shallow convection scheme - Coupled to the grid scale precipitation and radiation schemes through passing of diagnosed cloud liquid and ice from simulated precipitating convective cloud and shallow convective clouds +\version UFS-SRW v3.0.0 +- The choices of closures for deep/mid/shallow convection are now namelist options +- Updates for aerosol-awareness + +\b The \b Implementation \b of \b GF \b in \b RRFS + +- Scale-awareness is turned off when explicit microphysics is not active anywhere in the column +- GF completely is turned off at grid points when MYNN produces shallow convection at that point +- Radar reflectivity considers mass flux PDF as well as whether scale-awareness is turned on at the grid point in equation. + +\b The \b implementation \b of \b GF \b in \b HAFS \b is \b undergoing. + + + \section intra_rough_gf Intraphysics Communication The GF scheme passes cloud hydrometeors to the grid-scale microphysics scheme (\ref THOMPSON ) through detrainment from each convective cloud layer containing convective cloud. The detrained condensate interacts with short- and longwave radiation by diff --git a/physics/docs/pdftxt/GFS_NOAHMP.txt b/physics/docs/pdftxt/GFS_NOAHMP.txt index bc2c58457..83e8c0650 100644 --- a/physics/docs/pdftxt/GFS_NOAHMP.txt +++ b/physics/docs/pdftxt/GFS_NOAHMP.txt @@ -4,21 +4,17 @@ This implementation of the NoahMP Land Surface Model (LSM) is adapted from the version implemented in WRF v3.7 with additions by NOAA EMC staff to work with the UFS Atmosphere model. Authoritative documentation of the NoahMP scheme can be accessed at the following links: -[University of Texas at Austin NoahMP Documentation](http://www.jsg.utexas.edu/noah-mp "University of Texas at Austin NoahMP Documentation") +Technical documentation freely available at He et al. (2023) \cite He_2023. -[NCAR Research Application Laboratory NoahMP Documentation](https://ral.ucar.edu/solutions/products/noah-multiparameterization-land-surface-model-noah-mp-lsm "NCAR RAL NoahMP Documentation") +To cite the technical documentation: He, C., P. Valayamkunnath, M. Barlage, F. Chen, D. Gochis, R. Cabell, T. Schneider, R. Rasmussen, G.-Y. Niu, Z.-L. Yang, D. Niyogi, and M. Ek (2023): The Community Noah-MP Land Surface Modeling System Technical Description Version 5.0, (No. NCAR/TN-575+STR). doi:10.5065/ew8g-yr95 A primary reference for the NoahMP LSM is Niu et al. (2011) \cite niu_et_al_2011. -The CCPP interface to the NoahMP LSM is a driving software layer on top of the actual NoahMP LSM. During the run sequence, code organization is as follows: -+ \ref noahmpdrv_run() calls - + \ref transfer_mp_parameters() - + \ref noahmp_options() - + \ref noahmp_options_glacier() and noahmp_glacier() if over the ice vegetation type (glacier) - + \ref noahmp_sflx() if over other vegetation types - + \ref penman() - -Note that noahmp_glacer() and noahmp_sflx() are the actual NoahMP codes. +\section noahmp_update CCPP Physics Updates +\version UFS-SRW v3.0.0 +- As part of a larger-scale effort to unify how microphysics outputs (in particular snow) are used in the land models and outputs, an addition option for using the unified frozen precipitation fraction in NoahMP was added +- Diagnostic 2-meter temperature and humidity are based on vegetation and bare-ground tiles +- Bug fixes for GFS-based thermal roughness length scheme \section intra_noahmp Intraphysics Communication + \ref arg_table_noahmpdrv_run diff --git a/physics/docs/pdftxt/GFS_UGWPv0.txt b/physics/docs/pdftxt/GFS_UGWPv0.txt index f2b3b143a..1b3f0166f 100644 --- a/physics/docs/pdftxt/GFS_UGWPv0.txt +++ b/physics/docs/pdftxt/GFS_UGWPv0.txt @@ -108,6 +108,52 @@ and dynamical instability of waves described by the linear (Lindzen 1981 \cite lindzen_1981) and nonlinear (Weinstock 1984 \cite weinstock_1984; Hines 1997 \cite hines_1997) saturation theories. +\section ugwp_updates CCPP Physics Updates +\version UFS-SRW v3.0.0 + +We have added optional diagnostic outputs for the various tendencies supplied by the UGWP. They can be switched on by setting the two following input namelist variables equal to “.true.”: \p ldiag3d and \p ldiag_ugwp. + +The optional diagnostic outputs are: +- \b dws3dt_ogw: time-averaged wind speed tendency due to mesoscale gravity wave drag +- \b dws3dt_obl: time-averaged wind speed tendency due to blocking drag +- \b dws3dt_oss: time-averaged wind speed tendency due to small-scale gravity wave drag +- \b dws3dt_ofd: time-averaged wind speed tendency due to turbulent orographic form drag +- \b ldu3dt_ogw: time-averaged x wind tendency due to mesoscale orographic gravity wave drag +- \b ldu3dt_obl: time-averaged x wind tendency due to blocking drag +- \b ldu3dt_oss: time-averaged x wind tendency due to small scale gravity wave drag +- \b ldu3dt_ofd: time-averaged x wind tendency due to form drag +- \b ldu3dt_ngw: time-averaged u momentum tendency due to non-stationary gravity wave drag +- \b ldv3dt_ngw: time-averaged v momentum tendency due to non-stationary gravity wave drag +- \b ldt3dt_ngw: time-averaged temperature tendency due to non-stationary gravity wave drag +- \b dudt_ogw: instantaneous x wind tendency from mesoscale orographic gravity wave drag +- \b dvdt_ogw: instantaneous y wind tendency from mesoscale orographic gravity wave drag +- \b dudt_obl: instantaneous x wind tendency from blocking drag +- \b dvdt_obl: instantaneous y wind tendency from blocking drag +- \b dudt_oss: instantaneous x wind tendency from small scale GWD +- \b dvdt_oss: instantaneous y wind tendency from small scale GWD +- \b dudt_ofd: instantaneous x wind tendency from form drag +- \b dvdt_ofd: instantaneous y wind tendency from form drag +- \b du_ogwcol: instantaneous integrated x momentum flux from mesoscale orographic gravity wave drag +- \b dv_ogwcol: instantaneous integrated y momentum flux from mesoscale orographic gravity wave drag +- \b du_oblcol: instantaneous integrated x momentum flux from blocking drag +- \b dv_oblcol: instantaneous integrated y momentum flux from blocking drag +- \b du_osscol: instantaneous integrated x momentum flux from small scale gwd +- \b dv_osscol: instantaneous integrated y momentum flux from small scale gwd +- \b du_ofdcol: instantaneous integrated x momentum flux from form drag +- \b dv_ofdcol: instantaneous integrated y momentum flux from form drag +- \b du3_ogwcol: time-averaged surface x momentum flux from mesoscale orographic gravity wave drag +- \b dv3_ogwcol: time-averaged surface y momentum flux from mesoscale orographic gravity wave drag +- \b du3_oblcol: time-averaged surface x momentum flux from blocking drag +- \b dv3_oblcol: time-averaged surface y momentum flux from blocking drag +- \b du3_osscol: time-averaged surface x momentum flux from small scale gravity wave drag +- \b dv3_osscol: time-averaged surface y momentum flux from small scale gravity wave drag +- \b du3_ofdcol: time-averaged surface x momentum flux from form drag +- \b dv3_ofdcol: time-averaged surface y momentum flux from form drag + +Note that the relevant diag_table entries for these variables are included in: +ufs-weather-model/tests/parm/diag_table/diag_table_rap + + \section intra_UGWPv0 Intraphysics Communication - \ref arg_table_cires_ugwp_run diff --git a/physics/docs/pdftxt/GFS_v16_suite.txt b/physics/docs/pdftxt/GFS_v16_suite.txt index 11e997bf1..8966d6be8 100644 --- a/physics/docs/pdftxt/GFS_v16_suite.txt +++ b/physics/docs/pdftxt/GFS_v16_suite.txt @@ -25,9 +25,9 @@ National Centers for Environmental Prediction (NCEP) in 2021. The GFS_v16 suite \section gfs16_nml_opt_des Namelist \ref GFDL_cloud namelist options -\snippet RE210/FV3_GFS_v16_input.nml GFDL_CLOUD_MP_NML +\snippet RE300/FV3_GFS_v16_input.nml GFDL_CLOUD_MP_NML Other namelist options -\snippet RE210/FV3_GFS_v16_input.nml GFS_PHYSICS_NML +\snippet RE300/FV3_GFS_v16_input.nml GFS_PHYSICS_NML - nstf_name = \f$[2,0,0,0,0]^1 [2,1,0,0,0]^2\f$ - \f$^1\f$ NSST is on and coupled with spin up off diff --git a/physics/docs/pdftxt/HRRR_suite.txt b/physics/docs/pdftxt/HRRR_suite.txt index c08f50211..d8b529ada 100644 --- a/physics/docs/pdftxt/HRRR_suite.txt +++ b/physics/docs/pdftxt/HRRR_suite.txt @@ -28,6 +28,6 @@ The HRRR suite uses the parameterizations in the following order: \include suite_FV3_HRRR.xml \section hrrr_nml_option Namelist -\snippet RE210/FV3_HRRR_input.nml GFS_PHYSICS_NML +\snippet FV3_HRRR_input.nml GFS_PHYSICS_NML */ diff --git a/physics/docs/pdftxt/NoahMP.txt b/physics/docs/pdftxt/NoahMP.txt deleted file mode 100644 index f42aaaa00..000000000 --- a/physics/docs/pdftxt/NoahMP.txt +++ /dev/null @@ -1,41 +0,0 @@ -/** -\page NoahMP GFS NoahMP Land Surface Model -\section des_noahmp Description - -This implementation of the NoahMP Land Surface Model (LSM) is adapted from the version implemented in WRF v3.7 with additions by NOAA EMC staff to work with the UFS Atmosphere model. Authoritative documentation of the NoahMP scheme can be accessed at the following links: - -[University of Texas at Austin NoahMP Documentation](http://www.jsg.utexas.edu/noah-mp "University of Texas at Austin NoahMP Documentation") - -[NCAR Research Application Laboratory NoahMP Documentation](https://ral.ucar.edu/solutions/products/noah-multiparameterization-land-surface-model-noah-mp-lsm "NCAR RAL NoahMP Documentation") - -A primary reference for the NoahMP LSM is Niu et al. (2011) \cite niu_et_al_2011. - -The CCPP interface to the NoahMP LSM is a driving software layer on top of the actual NoahMP LSM. During the run sequence, code organization is as follows: -+ \ref noahmpdrv_run() calls - + \ref transfer_mp_parameters() - + \ref noahmp_options() - + \ref noahmp_options_glacier() and noahmp_glacier() if over the ice vegetation type (glacier) - + \ref noahmp_sflx() if over other vegetation types - + \ref penman() - -Note that noahmp_glacer() and noahmp_sflx() are the actual NoahMP codes. - -\section Default NoahMP LSM Options used in UFS atmosphere -+ Dynamic Vegetation (opt_dveg): 2 [On] -+ Canopy Stomatal Resistance (opt_crs): 1 [Ball-Berry] -+ Soil Moisture Factor for Stomatal Resistance (opt_btr): 1 [Noah soil moisture] -+ Runoff and Groundwater (opt_run): 1 [topmodel with groundwater (Niu et al. 2007 \cite niu_et_al_2007)] -+ Surface Layer Drag Coeff (opt_sfc): 1 [Monin-Obukhov] -+ Supercooled Liquid Water or Ice Fraction (opt_frz): 1 [no iteration (Niu and Yang, 2006 \cite niu_and_yang_2006)] -+ Frozen Soil Permeability (opt_inf): 1 [linear effects, more permeable (Niu and Yang, 2006, \cite niu_and_yang_2006)] -+ Radiation Transfer (opt_rad): 1 [modified two-stream (gap = f(solar angle, 3d structure ...)<1-fveg)] -+ Ground Snow Surface Albedo (opt_alb): 2 [class] -+ Partitioning Precipitation into Rainfall & Snowfall (opt_snf): 4 [use microphysics output] -+ Lower Boundary Condition of Soil Temperature (opt_tbot): 2 [tbot at zbot (8m) read from a file (original Noah)] -+ Snow/Soil Temperature Time Scheme (only layer 1) (opt_stc): 1 [semi-implicit; flux top boundary condition] - -\section intra_noahmp Intraphysics Communication - + GFS NoahMP LSM Driver (\ref arg_table_noahmpdrv_run) -\section gen_al_noahmp General Algorithm of Driver -+ \ref general_noahmpdrv -*/ diff --git a/physics/docs/pdftxt/RAP_suite.txt b/physics/docs/pdftxt/RAP_suite.txt index 3b16315e7..425bf40ff 100644 --- a/physics/docs/pdftxt/RAP_suite.txt +++ b/physics/docs/pdftxt/RAP_suite.txt @@ -26,6 +26,6 @@ The RAP suite uses the parameterizations in the following order: \include suite_SCM_RAP.xml \section RAP_nml_option Namelist -\snippet RE210/SCM_RAP_input.nml GFS_PHYSICS_NML +\snippet SCM_RAP_input.nml GFS_PHYSICS_NML */ diff --git a/physics/docs/pdftxt/RE300/FV3_GFS_v16_input.nml b/physics/docs/pdftxt/RE300/FV3_GFS_v16_input.nml new file mode 100644 index 000000000..23ca37f9c --- /dev/null +++ b/physics/docs/pdftxt/RE300/FV3_GFS_v16_input.nml @@ -0,0 +1,335 @@ +&amip_interp_nml + data_set = 'reynolds_oi' + date_out_of_range = 'climo' + interp_oi_sst = .true. + no_anom_sst = .false. + use_ncep_ice = .false. + use_ncep_sst = .true. +/ + +&atmos_model_nml + blocksize = 40 + ccpp_suite = 'FV3_GFS_v16' + chksum_debug = .false. + dycore_only = .false. +/ + +&cires_ugwp_nml + knob_ugwp_azdir = 2, 4, 4, 4 + knob_ugwp_doaxyz = 1 + knob_ugwp_doheat = 1 + knob_ugwp_dokdis = 1 + knob_ugwp_effac = 1, 1, 1, 1 + knob_ugwp_ndx4lh = 1 + knob_ugwp_solver = 2 + knob_ugwp_source = 1, 1, 0, 0 + knob_ugwp_stoch = 0, 0, 0, 0 + knob_ugwp_version = 0 + knob_ugwp_wvspec = 1, 25, 25, 25 + launch_level = 27 +/ + +&diag_manager_nml + max_output_fields = 450 + prepend_date = .false. +/ + +&external_ic_nml + checker_tr = .false. + filtered_terrain = .true. + gfs_dwinds = .true. + levp = 65 + nt_checker = 0 +/ + +&fms_io_nml + checksum_required = .false. + max_files_r = 100 + max_files_w = 100 +/ + +&fms_nml + clock_grain = 'ROUTINE' + domains_stack_size = 12000000 + print_memory_usage = .false. +/ + +&fv_core_nml + a_imp = 1.0 + adjust_dry_mass = .false. + agrid_vel_rst = .false. + bc_update_interval = 6 + beta = 0.0 + consv_am = .false. + consv_te = 0.0 + d2_bg = 0.0 + d2_bg_k1 = 0.2 + d2_bg_k2 = 0.0 + d4_bg = 0.12 + d_con = 1.0 + d_ext = 0.0 + dddmp = 0.1 + delt_max = 0.002 + dnats = 1 + do_sat_adj = .true. + do_schmidt = .true. + do_vort_damp = .true. + dwind_2d = .false. + dz_min = 6 + external_eta = .true. + external_ic = .true. + fill = .true. + full_zs_filter = .false. + fv_debug = .false. + fv_sg_adj = 450 + gfs_phil = .false. + hord_dp = -5 + hord_mt = 5 + hord_tm = 5 + hord_tr = 10 + hord_vt = 5 + hydrostatic = .false. + io_layout = 1, 1 + k_split = 6 + ke_bg = 0.0 + kord_mt = 9 + kord_tm = -9 + kord_tr = 9 + kord_wz = 9 + layout = 5, 2 + make_nh = .false. + mountain = .false. + n_split = 6 + n_sponge = 10 + n_zs_filter = 0 + na_init = 0 + ncep_ic = .false. + nggps_ic = .true. + no_dycore = .false. + nord = 3 + npx = 220 + npy = 132 + npz = 64 + nrows_blend = 10 + ntiles = 1 + nudge_dz = .false. + nudge_qv = .true. + nwat = 6 + p_fac = 0.1 + phys_hydrostatic = .false. + print_freq = 6 + psm_bc = 1 + range_warn = .false. + read_increment = .false. + regional = .true. + regional_bcs_from_gsi = .false. + res_latlon_dynamics = '' + reset_eta = .false. + rf_cutoff = 750.0 + stretch_fac = 0.999 + target_lat = 38.5 + target_lon = -97.5 + tau = 10.0 + use_hydro_pressure = .false. + vtdm4 = 0.02 + warm_start = .false. + write_restart_with_bcs = .false. + z_tracer = .true. +/ + +&fv_grid_nml + grid_file = 'INPUT/grid_spec.nc' +/ + +!> [GFDL_CLOUD_MP_NML] +&gfdl_cloud_microphysics_nml + c_cracw = 0.8 + c_paut = 0.5 + c_pgacs = 0.01 + c_psaci = 0.05 + ccn_l = 300.0 + ccn_o = 100.0 + const_vg = .false. + const_vi = .false. + const_vr = .false. + const_vs = .false. + de_ice = .false. + do_qa = .true. + do_sedi_heat = .false. + dw_land = 0.16 + dw_ocean = 0.1 + fast_sat_adj = .true. + fix_negative = .true. + icloud_f = 1 + mono_prof = .true. + mp_time = 150.0 + prog_ccn = .false. + qi0_crt = 8e-05 + qi_lim = 1.0 + ql_gen = 0.001 + ql_mlt = 0.001 + qs0_crt = 0.001 + rad_graupel = .true. + rad_rain = .true. + rad_snow = .true. + reiflag = 2 + rh_inc = 0.3 + rh_inr = 0.3 + rh_ins = 0.3 + rthresh = 1e-05 + sedi_transport = .true. + tau_g2v = 900.0 + tau_i2s = 1000.0 + tau_l2v = 225.0 + tau_v2l = 150.0 + use_ccn = .true. + use_ppm = .false. + vg_max = 12.0 + vi_max = 1.0 + vr_max = 12.0 + vs_max = 2.0 + z_slope_ice = .true. + z_slope_liq = .true. +/ +!! [GFDL_CLOUD_MP_NML] + + +!>[GFS_PHYSICS_NML] +&gfs_physics_nml + cal_pre = .false. + cdmbgwd = 4.0, 0.15, 1.0, 1.0 + cnvcld = .true. + cnvgwd = .true. + debug = .false. + do_tofd = .true. + do_ugwp = .false. + dspheat = .true. + effr_in = .true. + fhcyc = 0.0 + fhlwr = 3600.0 + fhswr = 3600.0 + fhzero = 1.0 + h2o_phys = .true. + hybedmf = .false. + iaer = 5111 + ialb = 1 + iau_inc_files = '' + icliq_sw = 2 + ico2 = 2 + iems = 1 + imfdeepcnv = 2 + imfshalcnv = 2 + imp_physics = 11 + iopt_alb = 2 + iopt_btr = 1 + iopt_crs = 1 + iopt_dveg = 1 + iopt_frz = 1 + iopt_inf = 1 + iopt_rad = 1 + iopt_run = 1 + iopt_sfc = 1 + iopt_snf = 4 + iopt_stc = 1 + iopt_tbot = 2 + iopt_trs = 2 + iovr = 3 + isatmedmf = 1 + isol = 2 + isot = 1 + isubc_lw = 2 + isubc_sw = 2 + ivegsrc = 1 + ldiag3d = .false. + ldiag_ugwp = .false. + lgfdlmprad = .true. + lheatstrg = .true. + lsm = 1 + lsoil = 4 + lwhtr = .true. + nsfullradar_diag = 3600 + nst_anl = .true. + nstf_name = 2, 1, 0, 0, 0 + oz_phys = .false. + oz_phys_2015 = .true. + pdfcld = .false. + prautco = 0.00015, 0.00015 + pre_rad = .false. + print_diff_pgr = .false. + prslrd0 = 0.0 + psautco = 0.0008, 0.0005 + random_clds = .false. + redrag = .true. + satmedmf = .true. + sfclay_compute_flux = .false. + shal_cnv = .true. + swhtr = .true. + trans_trac = .true. + use_ufo = .true. +/ +!! [GFS_PHYSICS_NML] + +&interpolator_nml + interp_method = 'conserve_great_circle' +/ + +&mpp_io_nml + deflate_level = 1 + shuffle = 1 +/ + +&nam_sfcperts +/ + +&nam_sppperts +/ + +&nam_stochy +/ + +&namsfc + fabsl = 99999 + faisl = 99999 + faiss = 99999 + fnacna = '' + fnaisc = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/CFSR.SEAICE.1982.2012.monthly.clim.grb' + fnglac = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/global_glacier.2x2.grb' + fnmskh = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/seaice_newland.grb' + fnmxic = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/global_maxice.2x2.grb' + fnsmcc = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/global_soilmgldas.t126.384.190.grb' + fnsnoa = '' + fnsnoc = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/global_snoclim.1.875.grb' + fntsfa = '' + fntsfc = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/RTGSST.1982.2012.monthly.clim.grb' + fnzorc = 'igbp' + fsicl = 99999 + fsics = 99999 + fslpl = 99999 + fsmcl = 99999, 99999, 99999 + fsnol = 99999 + fsnos = 99999 + fsotl = 99999 + ftsfl = 99999 + ftsfs = 90 + fvetl = 99999 + fvmnl = 99999 + fvmxl = 99999 + landice = .true. + ldebug = .false. +/ + +&namsfc_dict + fnabsc = '../fix_lam/C403.maximum_snow_albedo.tileX.nc' + fnalbc = '../fix_lam/C403.snowfree_albedo.tileX.nc' + fnalbc2 = '../fix_lam/C403.facsf.tileX.nc' + fnslpc = '../fix_lam/C403.slope_type.tileX.nc' + fnsotc = '../fix_lam/C403.soil_type.tileX.nc' + fntg3c = '../fix_lam/C403.substrate_temperature.tileX.nc' + fnvegc = '../fix_lam/C403.vegetation_greenness.tileX.nc' + fnvetc = '../fix_lam/C403.vegetation_type.tileX.nc' + fnvmnc = '../fix_lam/C403.vegetation_greenness.tileX.nc' + fnvmxc = '../fix_lam/C403.vegetation_greenness.tileX.nc' +/ + +&surf_map_nml +/ diff --git a/physics/docs/pdftxt/RE300/FV3_HRRR_input.nml b/physics/docs/pdftxt/RE300/FV3_HRRR_input.nml new file mode 100644 index 000000000..8a7d621f3 --- /dev/null +++ b/physics/docs/pdftxt/RE300/FV3_HRRR_input.nml @@ -0,0 +1,293 @@ +&amip_interp_nml + data_set = 'reynolds_oi' + date_out_of_range = 'climo' + interp_oi_sst = .true. + no_anom_sst = .false. + use_ncep_ice = .false. + use_ncep_sst = .true. +/ + +&atmos_model_nml + blocksize = 40 + ccpp_suite = 'FV3_HRRR' + chksum_debug = .false. + dycore_only = .false. +/ + +&cires_ugwp_nml + knob_ugwp_azdir = 2, 4, 4, 4 + knob_ugwp_doaxyz = 1 + knob_ugwp_doheat = 1 + knob_ugwp_dokdis = 1 + knob_ugwp_effac = 1, 1, 1, 1 + knob_ugwp_ndx4lh = 1 + knob_ugwp_solver = 2 + knob_ugwp_source = 1, 1, 0, 0 + knob_ugwp_stoch = 0, 0, 0, 0 + knob_ugwp_version = 0 + knob_ugwp_wvspec = 1, 25, 25, 25 + launch_level = 25 +/ + +&diag_manager_nml + max_output_fields = 450 + prepend_date = .false. +/ + +&external_ic_nml + checker_tr = .false. + filtered_terrain = .true. + gfs_dwinds = .true. + levp = 65 + nt_checker = 0 +/ + +&fms_io_nml + checksum_required = .false. + max_files_r = 100 + max_files_w = 100 +/ + +&fms_nml + clock_grain = 'ROUTINE' + domains_stack_size = 12000000 + print_memory_usage = .false. +/ + +&fv_core_nml + a_imp = 1.0 + adjust_dry_mass = .false. + bc_update_interval = 6 + beta = 0.0 + consv_am = .false. + consv_te = 0.0 + d2_bg = 0.0 + d2_bg_k1 = 0.2 + d2_bg_k2 = 0.04 + d4_bg = 0.12 + d_con = 1.0 + d_ext = 0.0 + dddmp = 0.1 + delt_max = 0.008 + dnats = 0 + do_sat_adj = .false. + do_schmidt = .true. + do_vort_damp = .true. + dwind_2d = .false. + dz_min = 2 + external_eta = .true. + external_ic = .true. + fill = .true. + full_zs_filter = .false. + fv_debug = .false. + fv_sg_adj = 300 + gfs_phil = .false. + hord_dp = -5 + hord_mt = 5 + hord_tm = 5 + hord_tr = 10 + hord_vt = 5 + hydrostatic = .false. + io_layout = 1, 1 + k_split = 2 + ke_bg = 0.0 + kord_mt = 9 + kord_tm = -9 + kord_tr = 9 + kord_wz = 9 + layout = 5, 2 + make_nh = .true. + mountain = .false. + n_split = 5 + n_sponge = 24 + n_zs_filter = 0 + na_init = 1 + ncep_ic = .false. + nggps_ic = .true. + no_dycore = .false. + nord = 3 + nord_tr = 2 + npx = 220 + npy = 132 + npz = 64 + nrows_blend = 10 + ntiles = 1 + nudge_qv = .false. + nwat = 6 + p_fac = 0.1 + phys_hydrostatic = .false. + print_freq = 6 + psm_bc = 1 + range_warn = .true. + read_increment = .false. + regional = .true. + regional_bcs_from_gsi = .false. + res_latlon_dynamics = 'fv3_increment.nc' + reset_eta = .false. + rf_cutoff = 2000.0 + stretch_fac = 0.999 + target_lat = 38.5 + target_lon = -97.5 + tau = 5.0 + use_hydro_pressure = .false. + vtdm4 = 0.02 + warm_start = .false. + write_restart_with_bcs = .false. + z_tracer = .true. +/ + +&fv_grid_nml + grid_file = 'INPUT/grid_spec.nc' +/ + +&gfs_physics_nml + bl_mynn_edmf = 1 + bl_mynn_edmf_mom = 1 + bl_mynn_tkeadvect = .true. + cal_pre = .false. + cdmbgwd = 3.5, 1.0 + cnvcld = .false. + cnvgwd = .false. + cplflx = .false. + debug = .false. + do_deep = .false. + do_gsl_drag_ls_bl = .true. + do_gsl_drag_ss = .true. + do_gsl_drag_tofd = .true. + do_mynnedmf = .true. + do_mynnsfclay = .true. + dspheat = .true. + effr_in = .true. + fhcyc = 0.0 + fhlwr = 1200.0 + fhswr = 1200.0 + fhzero = 1.0 + gwd_opt = 3 + h2o_phys = .true. + hybedmf = .false. + iaer = 5111 + ialb = 1 + iau_delthrs = 6 + iau_inc_files = '' + iaufhrs = 30 + icliq_sw = 2 + icloud_bl = 1 + ico2 = 2 + iems = 1 + imfdeepcnv = -1 + imfshalcnv = -1 + imp_physics = 8 + iopt_alb = 2 + iopt_btr = 1 + iopt_crs = 1 + iopt_dveg = 2 + iopt_frz = 1 + iopt_inf = 1 + iopt_rad = 1 + iopt_run = 1 + iopt_sfc = 1 + iopt_snf = 4 + iopt_stc = 1 + iopt_tbot = 2 + iopt_trs = 2 + iovr = 3 + isol = 2 + isot = 1 + isubc_lw = 2 + isubc_sw = 2 + ivegsrc = 1 + kice = 9 + ldiag3d = .false. + lheatstrg = .false. + lradar = .true. + lsm = 3 + lsoil = 4 + lsoil_lsm = 9 + ltaerosol = .true. + lwhtr = .true. + nsfullradar_diag = 3600 + nst_anl = .true. + nstf_name = 2, 1, 0, 0, 0 + oz_phys = .false. + oz_phys_2015 = .true. + pdfcld = .false. + pre_rad = .false. + print_diff_pgr = .false. + prslrd0 = 0.0 + random_clds = .false. + redrag = .true. + satmedmf = .false. + sfclay_compute_flux = .true. + shal_cnv = .false. + swhtr = .true. + trans_trac = .true. + ttendlim = -999 + use_ufo = .true. +/ + +&interpolator_nml + interp_method = 'conserve_great_circle' +/ + +&nam_sfcperts +/ + +&nam_sppperts +/ + +&nam_stochy +/ + +&namsfc + fabsl = 99999 + faisl = 99999 + faiss = 99999 + fnacna = '' + fnaisc = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/CFSR.SEAICE.1982.2012.monthly.clim.grb' + fnglac = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/global_glacier.2x2.grb' + fnmskh = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/seaice_newland.grb' + fnmxic = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/global_maxice.2x2.grb' + fnsmcc = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/global_soilmgldas.t126.384.190.grb' + fnsnoa = '' + fnsnoc = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/global_snoclim.1.875.grb' + fntsfa = '' + fntsfc = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/RTGSST.1982.2012.monthly.clim.grb' + fnzorc = 'igbp' + fsicl = 99999 + fsics = 99999 + fslpl = 99999 + fsmcl = 99999, 99999, 99999 + fsnol = 99999 + fsnos = 99999 + fsotl = 99999 + ftsfl = 99999 + ftsfs = 90 + fvetl = 99999 + fvmnl = 99999 + fvmxl = 99999 + ldebug = .true. +/ + +&namsfc_dict + fnabsc = '../fix_lam/C403.maximum_snow_albedo.tileX.nc' + fnalbc = '../fix_lam/C403.snowfree_albedo.tileX.nc' + fnalbc2 = '../fix_lam/C403.facsf.tileX.nc' + fnslpc = '../fix_lam/C403.slope_type.tileX.nc' + fnsotc = '../fix_lam/C403.soil_type.tileX.nc' + fntg3c = '../fix_lam/C403.substrate_temperature.tileX.nc' + fnvegc = '../fix_lam/C403.vegetation_greenness.tileX.nc' + fnvetc = '../fix_lam/C403.vegetation_type.tileX.nc' + fnvmnc = '../fix_lam/C403.vegetation_greenness.tileX.nc' + fnvmxc = '../fix_lam/C403.vegetation_greenness.tileX.nc' +/ + +&surf_map_nml + cd2 = -1 + cd4 = 0.12 + max_slope = 0.4 + n_del2_strong = 0 + n_del2_weak = 2 + n_del4 = 1 + peak_fac = 1.0 + zero_ocean = .false. +/ diff --git a/physics/docs/pdftxt/RE300/FV3_RAP_input.nml b/physics/docs/pdftxt/RE300/FV3_RAP_input.nml new file mode 100644 index 000000000..ef3f44fc5 --- /dev/null +++ b/physics/docs/pdftxt/RE300/FV3_RAP_input.nml @@ -0,0 +1,300 @@ +&amip_interp_nml + data_set = 'reynolds_oi' + date_out_of_range = 'climo' + interp_oi_sst = .true. + no_anom_sst = .false. + use_ncep_ice = .false. + use_ncep_sst = .true. +/ + +&atmos_model_nml + blocksize = 40 + ccpp_suite = 'FV3_RAP' + chksum_debug = .false. + dycore_only = .false. +/ + +&cires_ugwp_nml + knob_ugwp_azdir = 2, 4, 4, 4 + knob_ugwp_doaxyz = 1 + knob_ugwp_doheat = 1 + knob_ugwp_dokdis = 1 + knob_ugwp_effac = 1, 1, 1, 1 + knob_ugwp_ndx4lh = 1 + knob_ugwp_solver = 2 + knob_ugwp_source = 1, 1, 0, 0 + knob_ugwp_stoch = 0, 0, 0, 0 + knob_ugwp_version = 0 + knob_ugwp_wvspec = 1, 25, 25, 25 + launch_level = 25 +/ + +&diag_manager_nml + max_output_fields = 450 + prepend_date = .false. +/ + +&external_ic_nml + checker_tr = .false. + filtered_terrain = .true. + gfs_dwinds = .true. + levp = 65 + nt_checker = 0 +/ + +&fms_io_nml + checksum_required = .false. + max_files_r = 100 + max_files_w = 100 +/ + +&fms_nml + clock_grain = 'ROUTINE' + domains_stack_size = 12000000 + print_memory_usage = .false. +/ + +&fv_core_nml + a_imp = 1.0 + adjust_dry_mass = .false. + bc_update_interval = 6 + beta = 0.0 + consv_am = .false. + consv_te = 0.0 + d2_bg = 0.0 + d2_bg_k1 = 0.2 + d2_bg_k2 = 0.04 + d4_bg = 0.12 + d_con = 1.0 + d_ext = 0.0 + dddmp = 0.1 + delt_max = 0.008 + dnats = 0 + do_sat_adj = .false. + do_schmidt = .true. + do_vort_damp = .true. + dwind_2d = .false. + dz_min = 2 + external_eta = .true. + external_ic = .true. + fill = .true. + full_zs_filter = .false. + fv_debug = .false. + fv_sg_adj = 300 + gfs_phil = .false. + hord_dp = -5 + hord_mt = 5 + hord_tm = 5 + hord_tr = 10 + hord_vt = 5 + hydrostatic = .false. + io_layout = 1, 1 + k_split = 2 + ke_bg = 0.0 + kord_mt = 9 + kord_tm = -9 + kord_tr = 9 + kord_wz = 9 + layout = 5, 2 + make_nh = .true. + mountain = .false. + n_split = 5 + n_sponge = 24 + n_zs_filter = 0 + na_init = 1 + ncep_ic = .false. + nggps_ic = .true. + no_dycore = .false. + nord = 3 + nord_tr = 2 + npx = 220 + npy = 132 + npz = 64 + nrows_blend = 10 + ntiles = 1 + nudge_qv = .false. + nwat = 6 + p_fac = 0.1 + phys_hydrostatic = .false. + print_freq = 6 + psm_bc = 1 + range_warn = .true. + read_increment = .false. + regional = .true. + regional_bcs_from_gsi = .false. + res_latlon_dynamics = 'fv3_increment.nc' + reset_eta = .false. + rf_cutoff = 2000.0 + stretch_fac = 0.999 + target_lat = 38.5 + target_lon = -97.5 + tau = 5.0 + use_hydro_pressure = .false. + vtdm4 = 0.02 + warm_start = .false. + write_restart_with_bcs = .false. + z_tracer = .true. +/ + +&fv_grid_nml + grid_file = 'INPUT/grid_spec.nc' +/ + +&gfs_physics_nml + bl_mynn_edmf = 1 + bl_mynn_edmf_mom = 1 + bl_mynn_tkeadvect = .true. + cal_pre = .false. + cdmbgwd = 3.5, 1.0 + cnvcld = .false. + cnvgwd = .false. + cplflx = .false. + debug = .false. + do_deep = .true. + do_gsl_drag_ls_bl = .true. + do_gsl_drag_ss = .true. + do_gsl_drag_tofd = .true. + do_mynnedmf = .true. + do_mynnsfclay = .true. + do_shum = .false. + do_skeb = .false. + do_spp = .false. + do_sppt = .false. + dspheat = .true. + effr_in = .true. + fhcyc = 0 + fhlwr = 1200.0 + fhswr = 1200.0 + fhzero = 1.0 + gwd_opt = 3 + h2o_phys = .true. + hybedmf = .false. + iaer = 5111 + ialb = 1 + iau_delthrs = 6 + iau_inc_files = '' + iaufhrs = 30 + icliq_sw = 2 + icloud_bl = 1 + ico2 = 2 + iems = 1 + imfdeepcnv = 3 + imfshalcnv = 3 + imp_physics = 8 + iopt_alb = 2 + iopt_btr = 1 + iopt_crs = 1 + iopt_dveg = 2 + iopt_frz = 1 + iopt_inf = 1 + iopt_rad = 1 + iopt_run = 1 + iopt_sfc = 1 + iopt_snf = 4 + iopt_stc = 1 + iopt_tbot = 2 + iopt_trs = 2 + iovr = 3 + isol = 2 + isot = 1 + isubc_lw = 2 + isubc_sw = 2 + ivegsrc = 1 + kice = 9 + ldiag3d = .false. + lheatstrg = .false. + lndp_type = 0 + lradar = .true. + lsm = 3 + lsoil = 4 + lsoil_lsm = 9 + ltaerosol = .true. + lwhtr = .true. + n_var_lndp = 0 + n_var_spp = 0 + nsfullradar_diag = 3600 + nst_anl = .true. + nstf_name = 2, 1, 0, 0, 0 + oz_phys = .false. + oz_phys_2015 = .true. + pdfcld = .false. + pre_rad = .false. + print_diff_pgr = .false. + prslrd0 = 0.0 + random_clds = .false. + redrag = .true. + satmedmf = .false. + sfclay_compute_flux = .false. + shal_cnv = .true. + swhtr = .true. + trans_trac = .true. + ttendlim = -999 + use_ufo = .true. +/ + +&interpolator_nml + interp_method = 'conserve_great_circle' +/ + +&nam_sfcperts +/ + +&nam_sppperts +/ + +&nam_stochy +/ + +&namsfc + fabsl = 99999 + faisl = 99999 + faiss = 99999 + fnacna = '' + fnaisc = '../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/CFSR.SEAICE.1982.2012.monthly.clim.grb' + fnglac = '../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/global_glacier.2x2.grb' + fnmskh = '../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/seaice_newland.grb' + fnmxic = '../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/global_maxice.2x2.grb' + fnsmcc = '../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/global_soilmgldas.t126.384.190.grb' + fnsnoa = '' + fnsnoc = '../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/global_snoclim.1.875.grb' + fntsfa = '' + fntsfc = '../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/RTGSST.1982.2012.monthly.clim.grb' + fnzorc = 'igbp' + fsicl = 99999 + fsics = 99999 + fslpl = 99999 + fsmcl = 99999, 99999, 99999 + fsnol = 99999 + fsnos = 99999 + fsotl = 99999 + ftsfl = 99999 + ftsfs = 90 + fvetl = 99999 + fvmnl = 99999 + fvmxl = 99999 + ldebug = .true. +/ + +&namsfc_dict + fnabsc = '../fix_lam/C403.maximum_snow_albedo.tileX.nc' + fnalbc = '../fix_lam/C403.snowfree_albedo.tileX.nc' + fnalbc2 = '../fix_lam/C403.facsf.tileX.nc' + fnslpc = '../fix_lam/C403.slope_type.tileX.nc' + fnsotc = '../fix_lam/C403.soil_type.tileX.nc' + fntg3c = '../fix_lam/C403.substrate_temperature.tileX.nc' + fnvegc = '../fix_lam/C403.vegetation_greenness.tileX.nc' + fnvetc = '../fix_lam/C403.vegetation_type.tileX.nc' + fnvmnc = '../fix_lam/C403.vegetation_greenness.tileX.nc' + fnvmxc = '../fix_lam/C403.vegetation_greenness.tileX.nc' +/ + +&surf_map_nml + cd2 = -1 + cd4 = 0.12 + max_slope = 0.4 + n_del2_strong = 0 + n_del2_weak = 2 + n_del4 = 1 + peak_fac = 1.0 + zero_ocean = .false. +/ diff --git a/physics/docs/pdftxt/RE300/FV3_RRFS_v1beta_input.nml b/physics/docs/pdftxt/RE300/FV3_RRFS_v1beta_input.nml new file mode 100644 index 000000000..97a0f1216 --- /dev/null +++ b/physics/docs/pdftxt/RE300/FV3_RRFS_v1beta_input.nml @@ -0,0 +1,285 @@ +&amip_interp_nml + data_set = 'reynolds_oi' + date_out_of_range = 'climo' + interp_oi_sst = .true. + no_anom_sst = .false. + use_ncep_ice = .false. + use_ncep_sst = .true. +/ + +&atmos_model_nml + blocksize = 40 + ccpp_suite = 'FV3_RRFS_v1beta' + chksum_debug = .false. + dycore_only = .false. +/ + +&cires_ugwp_nml + knob_ugwp_azdir = 2, 4, 4, 4 + knob_ugwp_doaxyz = 1 + knob_ugwp_doheat = 1 + knob_ugwp_dokdis = 1 + knob_ugwp_effac = 1, 1, 1, 1 + knob_ugwp_ndx4lh = 1 + knob_ugwp_solver = 2 + knob_ugwp_source = 1, 1, 0, 0 + knob_ugwp_stoch = 0, 0, 0, 0 + knob_ugwp_version = 0 + knob_ugwp_wvspec = 1, 25, 25, 25 + launch_level = 25 +/ + +&diag_manager_nml + max_output_fields = 450 + prepend_date = .false. +/ + +&external_ic_nml + checker_tr = .false. + filtered_terrain = .true. + gfs_dwinds = .true. + levp = 65 + nt_checker = 0 +/ + +&fms_io_nml + checksum_required = .false. + max_files_r = 100 + max_files_w = 100 +/ + +&fms_nml + clock_grain = 'ROUTINE' + domains_stack_size = 12000000 + print_memory_usage = .false. +/ + +&fv_core_nml + a_imp = 1.0 + adjust_dry_mass = .false. + bc_update_interval = 6 + beta = 0.0 + consv_am = .false. + consv_te = 0.0 + d2_bg = 0.0 + d2_bg_k1 = 0.2 + d2_bg_k2 = 0.04 + d4_bg = 0.12 + d_con = 1.0 + d_ext = 0.0 + dddmp = 0.1 + delt_max = 0.008 + dnats = 0 + do_sat_adj = .false. + do_schmidt = .true. + do_vort_damp = .true. + dwind_2d = .false. + dz_min = 2 + external_eta = .true. + external_ic = .true. + fill = .true. + full_zs_filter = .false. + fv_debug = .false. + fv_sg_adj = 300 + gfs_phil = .false. + hord_dp = 6 + hord_mt = 6 + hord_tm = 6 + hord_tr = 10 + hord_vt = 6 + hydrostatic = .false. + io_layout = 1, 1 + k_split = 2 + ke_bg = 0.0 + kord_mt = 9 + kord_tm = -9 + kord_tr = 9 + kord_wz = 9 + layout = 5, 2 + make_nh = .true. + mountain = .false. + n_split = 5 + n_sponge = 24 + n_zs_filter = 0 + na_init = 1 + ncep_ic = .false. + nggps_ic = .true. + no_dycore = .false. + nord = 3 + npx = 220 + npy = 132 + npz = 64 + nrows_blend = 10 + ntiles = 1 + nudge_qv = .false. + nwat = 6 + p_fac = 0.1 + phys_hydrostatic = .false. + print_freq = 6 + psm_bc = 1 + range_warn = .true. + read_increment = .false. + regional = .true. + regional_bcs_from_gsi = .false. + res_latlon_dynamics = 'fv3_increment.nc' + reset_eta = .false. + rf_cutoff = 2000.0 + stretch_fac = 0.999 + target_lat = 38.5 + target_lon = -97.5 + tau = 5.0 + use_hydro_pressure = .false. + vtdm4 = 0.02 + warm_start = .false. + write_restart_with_bcs = .false. + z_tracer = .true. +/ + +&fv_grid_nml + grid_file = 'INPUT/grid_spec.nc' +/ + +&gfs_physics_nml + bl_mynn_edmf = 1 + bl_mynn_edmf_mom = 1 + bl_mynn_tkeadvect = .true. + cal_pre = .false. + cdmbgwd = 3.5, 0.25 + cnvcld = .false. + cnvgwd = .false. + cplflx = .false. + debug = .false. + do_deep = .false. + do_mynnedmf = .true. + do_mynnsfclay = .true. + dspheat = .true. + effr_in = .true. + fhcyc = 0.0 + fhlwr = 1200.0 + fhswr = 1200.0 + fhzero = 1.0 + h2o_phys = .true. + hybedmf = .false. + iaer = 111 + ialb = 1 + iau_delthrs = 6 + iau_inc_files = '' + iaufhrs = 30 + icloud_bl = 1 + ico2 = 2 + iems = 1 + imfdeepcnv = -1 + imfshalcnv = -1 + imp_physics = 8 + iopt_alb = 2 + iopt_btr = 1 + iopt_crs = 1 + iopt_dveg = 2 + iopt_frz = 1 + iopt_inf = 1 + iopt_rad = 1 + iopt_run = 1 + iopt_sfc = 1 + iopt_snf = 4 + iopt_stc = 1 + iopt_tbot = 2 + iopt_trs = 2 + isol = 2 + isot = 1 + isubc_lw = 2 + isubc_sw = 2 + ivegsrc = 1 + ldiag3d = .false. + lheatstrg = .false. + lradar = .true. + lsm = 2 + lsoil = 4 + lsoil_lsm = 4 + ltaerosol = .true. + lwhtr = .true. + nsfullradar_diag = 3600 + nst_anl = .true. + nstf_name = 2, 1, 0, 0, 0 + oz_phys = .false. + oz_phys_2015 = .true. + pdfcld = .false. + pre_rad = .false. + print_diff_pgr = .false. + prslrd0 = 0.0 + random_clds = .false. + redrag = .true. + satmedmf = .false. + sfclay_compute_flux = .false. + shal_cnv = .false. + swhtr = .true. + trans_trac = .true. + ttendlim = -999 + use_ufo = .true. +/ + +&interpolator_nml + interp_method = 'conserve_great_circle' +/ + +&nam_sfcperts +/ + +&nam_sppperts +/ + +&nam_stochy +/ + +&namsfc + fabsl = 99999 + faisl = 99999 + faiss = 99999 + fnacna = '' + fnaisc = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/CFSR.SEAICE.1982.2012.monthly.clim.grb' + fnglac = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/global_glacier.2x2.grb' + fnmskh = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/seaice_newland.grb' + fnmxic = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/global_maxice.2x2.grb' + fnsmcc = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/global_soilmgldas.t126.384.190.grb' + fnsnoa = '' + fnsnoc = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/global_snoclim.1.875.grb' + fntsfa = '' + fntsfc = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/RTGSST.1982.2012.monthly.clim.grb' + fnzorc = 'igbp' + fsicl = 99999 + fsics = 99999 + fslpl = 99999 + fsmcl = 99999, 99999, 99999 + fsnol = 99999 + fsnos = 99999 + fsotl = 99999 + ftsfl = 99999 + ftsfs = 90 + fvetl = 99999 + fvmnl = 99999 + fvmxl = 99999 + ldebug = .true. +/ + +&namsfc_dict + fnabsc = '../fix_lam/C403.maximum_snow_albedo.tileX.nc' + fnalbc = '../fix_lam/C403.snowfree_albedo.tileX.nc' + fnalbc2 = '../fix_lam/C403.facsf.tileX.nc' + fnslpc = '../fix_lam/C403.slope_type.tileX.nc' + fnsotc = '../fix_lam/C403.soil_type.tileX.nc' + fntg3c = '../fix_lam/C403.substrate_temperature.tileX.nc' + fnvegc = '../fix_lam/C403.vegetation_greenness.tileX.nc' + fnvetc = '../fix_lam/C403.vegetation_type.tileX.nc' + fnvmnc = '../fix_lam/C403.vegetation_greenness.tileX.nc' + fnvmxc = '../fix_lam/C403.vegetation_greenness.tileX.nc' +/ + +&surf_map_nml + cd2 = -1 + cd4 = 0.12 + max_slope = 0.4 + n_del2_strong = 0 + n_del2_weak = 2 + n_del4 = 1 + peak_fac = 1.0 + zero_ocean = .false. +/ diff --git a/physics/docs/pdftxt/RE300/FV3_WoFS_v0_input.nml b/physics/docs/pdftxt/RE300/FV3_WoFS_v0_input.nml new file mode 100644 index 000000000..1236cde3b --- /dev/null +++ b/physics/docs/pdftxt/RE300/FV3_WoFS_v0_input.nml @@ -0,0 +1,291 @@ +&amip_interp_nml + data_set = 'reynolds_oi' + date_out_of_range = 'climo' + interp_oi_sst = .true. + no_anom_sst = .false. + use_ncep_ice = .false. + use_ncep_sst = .true. +/ + +&atmos_model_nml + blocksize = 40 + ccpp_suite = 'FV3_WoFS_v0' + chksum_debug = .false. + dycore_only = .false. +/ + +&cires_ugwp_nml + knob_ugwp_azdir = 2, 4, 4, 4 + knob_ugwp_doaxyz = 1 + knob_ugwp_doheat = 1 + knob_ugwp_dokdis = 1 + knob_ugwp_effac = 1, 1, 1, 1 + knob_ugwp_ndx4lh = 1 + knob_ugwp_solver = 2 + knob_ugwp_source = 1, 1, 0, 0 + knob_ugwp_stoch = 0, 0, 0, 0 + knob_ugwp_version = 0 + knob_ugwp_wvspec = 1, 25, 25, 25 + launch_level = 25 +/ + +&diag_manager_nml + max_output_fields = 450 + prepend_date = .false. +/ + +&external_ic_nml + checker_tr = .false. + filtered_terrain = .true. + gfs_dwinds = .true. + levp = 65 + nt_checker = 0 +/ + +&fms_io_nml + checksum_required = .false. + max_files_r = 100 + max_files_w = 100 +/ + +&fms_nml + clock_grain = 'ROUTINE' + domains_stack_size = 12000000 + print_memory_usage = .false. +/ + +&fv_core_nml + a_imp = 1.0 + adjust_dry_mass = .false. + bc_update_interval = 6 + beta = 0.0 + consv_am = .false. + consv_te = 0.0 + d2_bg = 0.0 + d2_bg_k1 = 0.2 + d2_bg_k2 = 0.04 + d4_bg = 0.12 + d_con = 1.0 + d_ext = 0.0 + dddmp = 0.1 + delt_max = 0.008 + dnats = 0 + do_sat_adj = .false. + do_schmidt = .true. + do_vort_damp = .true. + dwind_2d = .false. + dz_min = 2 + external_eta = .true. + external_ic = .true. + fill = .true. + full_zs_filter = .false. + fv_debug = .false. + fv_sg_adj = 300 + gfs_phil = .false. + hord_dp = 6 + hord_mt = 6 + hord_tm = 6 + hord_tr = 10 + hord_vt = 6 + hydrostatic = .false. + io_layout = 1, 1 + k_split = 2 + ke_bg = 0.0 + kord_mt = 9 + kord_tm = -9 + kord_tr = 9 + kord_wz = 9 + layout = 5, 2 + make_nh = .true. + mountain = .false. + n_split = 5 + n_sponge = 24 + n_zs_filter = 0 + na_init = 1 + ncep_ic = .false. + nggps_ic = .true. + no_dycore = .false. + nord = 3 + npx = 220 + npy = 132 + npz = 64 + nrows_blend = 10 + ntiles = 1 + nudge_qv = .false. + nwat = 7 + p_fac = 0.1 + phys_hydrostatic = .false. + print_freq = 6 + psm_bc = 1 + range_warn = .true. + read_increment = .false. + regional = .true. + regional_bcs_from_gsi = .false. + res_latlon_dynamics = 'fv3_increment.nc' + reset_eta = .false. + rf_cutoff = 2000.0 + stretch_fac = 0.999 + target_lat = 38.5 + target_lon = -97.5 + tau = 5.0 + use_hydro_pressure = .false. + vtdm4 = 0.02 + warm_start = .false. + write_restart_with_bcs = .false. + z_tracer = .true. +/ + +&fv_diagnostics_nml + do_hailcast = .true. +/ + +&fv_grid_nml + grid_file = 'INPUT/grid_spec.nc' +/ + +&gfs_physics_nml + bl_mynn_edmf = 1 + bl_mynn_edmf_mom = 1 + bl_mynn_tkeadvect = .true. + cal_pre = .false. + cdmbgwd = 3.5, 0.25 + cnvcld = .false. + cnvgwd = .false. + cplflx = .false. + debug = .false. + do_deep = .false. + do_mynnedmf = .true. + do_mynnsfclay = .true. + dspheat = .true. + effr_in = .true. + fhcyc = 0.0 + fhlwr = 1200.0 + fhswr = 1200.0 + fhzero = 1.0 + h2o_phys = .true. + hybedmf = .false. + iaer = 111 + ialb = 1 + iau_delthrs = 6 + iau_inc_files = '' + iaufhrs = 30 + icloud_bl = 1 + ico2 = 2 + iems = 1 + imfdeepcnv = -1 + imfshalcnv = -1 + imp_physics = 17 + iopt_alb = 2 + iopt_btr = 1 + iopt_crs = 1 + iopt_dveg = 2 + iopt_frz = 1 + iopt_inf = 1 + iopt_rad = 1 + iopt_run = 1 + iopt_sfc = 1 + iopt_snf = 4 + iopt_stc = 1 + iopt_tbot = 2 + isol = 2 + isot = 1 + isubc_lw = 2 + isubc_sw = 2 + ivegsrc = 1 + ldiag3d = .false. + lheatstrg = .false. + lradar = .true. + lsm = 1 + lsoil = 4 + lsoil_lsm = 4 + ltaerosol = .true. + lwhtr = .true. + nsfullradar_diag = 3600 + nssl_cccn = 600000000.0 + nssl_ccn_on = .true. + nssl_hail_on = .true. + nst_anl = .true. + nstf_name = 2, 1, 0, 0, 0 + oz_phys = .false. + oz_phys_2015 = .true. + pdfcld = .false. + pre_rad = .false. + print_diff_pgr = .false. + prslrd0 = 0.0 + random_clds = .false. + redrag = .true. + satmedmf = .false. + sfclay_compute_flux = .false. + shal_cnv = .false. + swhtr = .true. + trans_trac = .true. + ttendlim = -999 + use_ufo = .true. +/ + +&interpolator_nml + interp_method = 'conserve_great_circle' +/ + +&nam_sfcperts +/ + +&nam_sppperts +/ + +&nam_stochy +/ + +&namsfc + fabsl = 99999 + faisl = 99999 + faiss = 99999 + fnacna = '' + fnaisc = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/CFSR.SEAICE.1982.2012.monthly.clim.grb' + fnglac = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/global_glacier.2x2.grb' + fnmskh = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/seaice_newland.grb' + fnmxic = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/global_maxice.2x2.grb' + fnsmcc = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/global_soilmgldas.t126.384.190.grb' + fnsnoa = '' + fnsnoc = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/global_snoclim.1.875.grb' + fntsfa = '' + fntsfc = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/RTGSST.1982.2012.monthly.clim.grb' + fnzorc = 'igbp' + fsicl = 99999 + fsics = 99999 + fslpl = 99999 + fsmcl = 99999, 99999, 99999 + fsnol = 99999 + fsnos = 99999 + fsotl = 99999 + ftsfl = 99999 + ftsfs = 90 + fvetl = 99999 + fvmnl = 99999 + fvmxl = 99999 + ldebug = .true. +/ + +&namsfc_dict + fnabsc = '../fix_lam/C403.maximum_snow_albedo.tileX.nc' + fnalbc = '../fix_lam/C403.snowfree_albedo.tileX.nc' + fnalbc2 = '../fix_lam/C403.facsf.tileX.nc' + fnslpc = '../fix_lam/C403.slope_type.tileX.nc' + fnsotc = '../fix_lam/C403.soil_type.tileX.nc' + fntg3c = '../fix_lam/C403.substrate_temperature.tileX.nc' + fnvegc = '../fix_lam/C403.vegetation_greenness.tileX.nc' + fnvetc = '../fix_lam/C403.vegetation_type.tileX.nc' + fnvmnc = '../fix_lam/C403.vegetation_greenness.tileX.nc' + fnvmxc = '../fix_lam/C403.vegetation_greenness.tileX.nc' +/ + +&surf_map_nml + cd2 = -1 + cd4 = 0.12 + max_slope = 0.4 + n_del2_strong = 0 + n_del2_weak = 2 + n_del4 = 1 + peak_fac = 1.0 + zero_ocean = .false. +/ diff --git a/physics/docs/pdftxt/RE300/namelists/input.nml.develop.FV3_GFS_v16 b/physics/docs/pdftxt/RE300/namelists/input.nml.develop.FV3_GFS_v16 new file mode 100644 index 000000000..6dac0ecaf --- /dev/null +++ b/physics/docs/pdftxt/RE300/namelists/input.nml.develop.FV3_GFS_v16 @@ -0,0 +1,330 @@ +&amip_interp_nml + data_set = 'reynolds_oi' + date_out_of_range = 'climo' + interp_oi_sst = .true. + no_anom_sst = .false. + use_ncep_ice = .false. + use_ncep_sst = .true. +/ + +&atmos_model_nml + blocksize = 40 + ccpp_suite = 'FV3_GFS_v16' + chksum_debug = .false. + dycore_only = .false. +/ + +&cires_ugwp_nml + knob_ugwp_azdir = 2, 4, 4, 4 + knob_ugwp_doaxyz = 1 + knob_ugwp_doheat = 1 + knob_ugwp_dokdis = 1 + knob_ugwp_effac = 1, 1, 1, 1 + knob_ugwp_ndx4lh = 1 + knob_ugwp_solver = 2 + knob_ugwp_source = 1, 1, 0, 0 + knob_ugwp_stoch = 0, 0, 0, 0 + knob_ugwp_version = 0 + knob_ugwp_wvspec = 1, 25, 25, 25 + launch_level = 27 +/ + +&diag_manager_nml + max_output_fields = 450 + prepend_date = .false. +/ + +&external_ic_nml + checker_tr = .false. + filtered_terrain = .true. + gfs_dwinds = .true. + levp = 65 + nt_checker = 0 +/ + +&fms_io_nml + checksum_required = .false. + max_files_r = 100 + max_files_w = 100 +/ + +&fms_nml + clock_grain = 'ROUTINE' + domains_stack_size = 12000000 + print_memory_usage = .false. +/ + +&fv_core_nml + a_imp = 1.0 + adjust_dry_mass = .false. + agrid_vel_rst = .false. + bc_update_interval = 6 + beta = 0.0 + consv_am = .false. + consv_te = 0.0 + d2_bg = 0.0 + d2_bg_k1 = 0.2 + d2_bg_k2 = 0.0 + d4_bg = 0.12 + d_con = 1.0 + d_ext = 0.0 + dddmp = 0.1 + delt_max = 0.002 + dnats = 1 + do_sat_adj = .true. + do_schmidt = .true. + do_vort_damp = .true. + dwind_2d = .false. + dz_min = 6 + external_eta = .true. + external_ic = .true. + fill = .true. + full_zs_filter = .false. + fv_debug = .false. + fv_sg_adj = 450 + gfs_phil = .false. + hord_dp = -5 + hord_mt = 5 + hord_tm = 5 + hord_tr = 10 + hord_vt = 5 + hydrostatic = .false. + io_layout = 1, 1 + k_split = 6 + ke_bg = 0.0 + kord_mt = 9 + kord_tm = -9 + kord_tr = 9 + kord_wz = 9 + layout = 5, 2 + make_nh = .false. + mountain = .false. + n_split = 6 + n_sponge = 10 + n_zs_filter = 0 + na_init = 0 + ncep_ic = .false. + nggps_ic = .true. + no_dycore = .false. + nord = 3 + npx = 220 + npy = 132 + npz = 64 + nrows_blend = 10 + ntiles = 1 + nudge_dz = .false. + nudge_qv = .true. + nwat = 6 + p_fac = 0.1 + phys_hydrostatic = .false. + print_freq = 6 + psm_bc = 1 + range_warn = .false. + read_increment = .false. + regional = .true. + regional_bcs_from_gsi = .false. + res_latlon_dynamics = '' + reset_eta = .false. + rf_cutoff = 750.0 + stretch_fac = 0.999 + target_lat = 38.5 + target_lon = -97.5 + tau = 10.0 + use_hydro_pressure = .false. + vtdm4 = 0.02 + warm_start = .false. + write_restart_with_bcs = .false. + z_tracer = .true. +/ + +&fv_grid_nml + grid_file = 'INPUT/grid_spec.nc' +/ + +&gfdl_cloud_microphysics_nml + c_cracw = 0.8 + c_paut = 0.5 + c_pgacs = 0.01 + c_psaci = 0.05 + ccn_l = 300.0 + ccn_o = 100.0 + const_vg = .false. + const_vi = .false. + const_vr = .false. + const_vs = .false. + de_ice = .false. + do_qa = .true. + do_sedi_heat = .false. + dw_land = 0.16 + dw_ocean = 0.1 + fast_sat_adj = .true. + fix_negative = .true. + icloud_f = 1 + mono_prof = .true. + mp_time = 150.0 + prog_ccn = .false. + qi0_crt = 8e-05 + qi_lim = 1.0 + ql_gen = 0.001 + ql_mlt = 0.001 + qs0_crt = 0.001 + rad_graupel = .true. + rad_rain = .true. + rad_snow = .true. + reiflag = 2 + rh_inc = 0.3 + rh_inr = 0.3 + rh_ins = 0.3 + rthresh = 1e-05 + sedi_transport = .true. + tau_g2v = 900.0 + tau_i2s = 1000.0 + tau_l2v = 225.0 + tau_v2l = 150.0 + use_ccn = .true. + use_ppm = .false. + vg_max = 12.0 + vi_max = 1.0 + vr_max = 12.0 + vs_max = 2.0 + z_slope_ice = .true. + z_slope_liq = .true. +/ + +&gfs_physics_nml + cal_pre = .false. + cdmbgwd = 4.0, 0.15, 1.0, 1.0 + cnvcld = .true. + cnvgwd = .true. + debug = .false. + do_tofd = .true. + do_ugwp = .false. + dspheat = .true. + effr_in = .true. + fhcyc = 0.0 + fhlwr = 3600.0 + fhswr = 3600.0 + fhzero = 1.0 + h2o_phys = .true. + hybedmf = .false. + iaer = 5111 + ialb = 1 + iau_inc_files = '' + icliq_sw = 2 + ico2 = 2 + iems = 1 + imfdeepcnv = 2 + imfshalcnv = 2 + imp_physics = 11 + iopt_alb = 2 + iopt_btr = 1 + iopt_crs = 1 + iopt_dveg = 1 + iopt_frz = 1 + iopt_inf = 1 + iopt_rad = 1 + iopt_run = 1 + iopt_sfc = 1 + iopt_snf = 4 + iopt_stc = 1 + iopt_tbot = 2 + iopt_trs = 2 + iovr = 3 + isatmedmf = 1 + isol = 2 + isot = 1 + isubc_lw = 2 + isubc_sw = 2 + ivegsrc = 1 + ldiag3d = .false. + ldiag_ugwp = .false. + lgfdlmprad = .true. + lheatstrg = .true. + lsm = 1 + lsoil = 4 + lwhtr = .true. + nsfullradar_diag = 3600 + nst_anl = .true. + nstf_name = 2, 1, 0, 0, 0 + oz_phys = .false. + oz_phys_2015 = .true. + pdfcld = .false. + prautco = 0.00015, 0.00015 + pre_rad = .false. + print_diff_pgr = .false. + prslrd0 = 0.0 + psautco = 0.0008, 0.0005 + random_clds = .false. + redrag = .true. + satmedmf = .true. + sfclay_compute_flux = .false. + shal_cnv = .true. + swhtr = .true. + trans_trac = .true. + use_ufo = .true. +/ + +&interpolator_nml + interp_method = 'conserve_great_circle' +/ + +&mpp_io_nml + deflate_level = 1 + shuffle = 1 +/ + +&nam_sfcperts +/ + +&nam_sppperts +/ + +&nam_stochy +/ + +&namsfc + fabsl = 99999 + faisl = 99999 + faiss = 99999 + fnacna = '' + fnaisc = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/CFSR.SEAICE.1982.2012.monthly.clim.grb' + fnglac = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/global_glacier.2x2.grb' + fnmskh = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/seaice_newland.grb' + fnmxic = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/global_maxice.2x2.grb' + fnsmcc = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/global_soilmgldas.t126.384.190.grb' + fnsnoa = '' + fnsnoc = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/global_snoclim.1.875.grb' + fntsfa = '' + fntsfc = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/RTGSST.1982.2012.monthly.clim.grb' + fnzorc = 'igbp' + fsicl = 99999 + fsics = 99999 + fslpl = 99999 + fsmcl = 99999, 99999, 99999 + fsnol = 99999 + fsnos = 99999 + fsotl = 99999 + ftsfl = 99999 + ftsfs = 90 + fvetl = 99999 + fvmnl = 99999 + fvmxl = 99999 + landice = .true. + ldebug = .false. +/ + +&namsfc_dict + fnabsc = '../fix_lam/C403.maximum_snow_albedo.tileX.nc' + fnalbc = '../fix_lam/C403.snowfree_albedo.tileX.nc' + fnalbc2 = '../fix_lam/C403.facsf.tileX.nc' + fnslpc = '../fix_lam/C403.slope_type.tileX.nc' + fnsotc = '../fix_lam/C403.soil_type.tileX.nc' + fntg3c = '../fix_lam/C403.substrate_temperature.tileX.nc' + fnvegc = '../fix_lam/C403.vegetation_greenness.tileX.nc' + fnvetc = '../fix_lam/C403.vegetation_type.tileX.nc' + fnvmnc = '../fix_lam/C403.vegetation_greenness.tileX.nc' + fnvmxc = '../fix_lam/C403.vegetation_greenness.tileX.nc' +/ + +&surf_map_nml +/ diff --git a/physics/docs/pdftxt/RE300/namelists/input.nml.develop.FV3_HRRR b/physics/docs/pdftxt/RE300/namelists/input.nml.develop.FV3_HRRR new file mode 100644 index 000000000..8a7d621f3 --- /dev/null +++ b/physics/docs/pdftxt/RE300/namelists/input.nml.develop.FV3_HRRR @@ -0,0 +1,293 @@ +&amip_interp_nml + data_set = 'reynolds_oi' + date_out_of_range = 'climo' + interp_oi_sst = .true. + no_anom_sst = .false. + use_ncep_ice = .false. + use_ncep_sst = .true. +/ + +&atmos_model_nml + blocksize = 40 + ccpp_suite = 'FV3_HRRR' + chksum_debug = .false. + dycore_only = .false. +/ + +&cires_ugwp_nml + knob_ugwp_azdir = 2, 4, 4, 4 + knob_ugwp_doaxyz = 1 + knob_ugwp_doheat = 1 + knob_ugwp_dokdis = 1 + knob_ugwp_effac = 1, 1, 1, 1 + knob_ugwp_ndx4lh = 1 + knob_ugwp_solver = 2 + knob_ugwp_source = 1, 1, 0, 0 + knob_ugwp_stoch = 0, 0, 0, 0 + knob_ugwp_version = 0 + knob_ugwp_wvspec = 1, 25, 25, 25 + launch_level = 25 +/ + +&diag_manager_nml + max_output_fields = 450 + prepend_date = .false. +/ + +&external_ic_nml + checker_tr = .false. + filtered_terrain = .true. + gfs_dwinds = .true. + levp = 65 + nt_checker = 0 +/ + +&fms_io_nml + checksum_required = .false. + max_files_r = 100 + max_files_w = 100 +/ + +&fms_nml + clock_grain = 'ROUTINE' + domains_stack_size = 12000000 + print_memory_usage = .false. +/ + +&fv_core_nml + a_imp = 1.0 + adjust_dry_mass = .false. + bc_update_interval = 6 + beta = 0.0 + consv_am = .false. + consv_te = 0.0 + d2_bg = 0.0 + d2_bg_k1 = 0.2 + d2_bg_k2 = 0.04 + d4_bg = 0.12 + d_con = 1.0 + d_ext = 0.0 + dddmp = 0.1 + delt_max = 0.008 + dnats = 0 + do_sat_adj = .false. + do_schmidt = .true. + do_vort_damp = .true. + dwind_2d = .false. + dz_min = 2 + external_eta = .true. + external_ic = .true. + fill = .true. + full_zs_filter = .false. + fv_debug = .false. + fv_sg_adj = 300 + gfs_phil = .false. + hord_dp = -5 + hord_mt = 5 + hord_tm = 5 + hord_tr = 10 + hord_vt = 5 + hydrostatic = .false. + io_layout = 1, 1 + k_split = 2 + ke_bg = 0.0 + kord_mt = 9 + kord_tm = -9 + kord_tr = 9 + kord_wz = 9 + layout = 5, 2 + make_nh = .true. + mountain = .false. + n_split = 5 + n_sponge = 24 + n_zs_filter = 0 + na_init = 1 + ncep_ic = .false. + nggps_ic = .true. + no_dycore = .false. + nord = 3 + nord_tr = 2 + npx = 220 + npy = 132 + npz = 64 + nrows_blend = 10 + ntiles = 1 + nudge_qv = .false. + nwat = 6 + p_fac = 0.1 + phys_hydrostatic = .false. + print_freq = 6 + psm_bc = 1 + range_warn = .true. + read_increment = .false. + regional = .true. + regional_bcs_from_gsi = .false. + res_latlon_dynamics = 'fv3_increment.nc' + reset_eta = .false. + rf_cutoff = 2000.0 + stretch_fac = 0.999 + target_lat = 38.5 + target_lon = -97.5 + tau = 5.0 + use_hydro_pressure = .false. + vtdm4 = 0.02 + warm_start = .false. + write_restart_with_bcs = .false. + z_tracer = .true. +/ + +&fv_grid_nml + grid_file = 'INPUT/grid_spec.nc' +/ + +&gfs_physics_nml + bl_mynn_edmf = 1 + bl_mynn_edmf_mom = 1 + bl_mynn_tkeadvect = .true. + cal_pre = .false. + cdmbgwd = 3.5, 1.0 + cnvcld = .false. + cnvgwd = .false. + cplflx = .false. + debug = .false. + do_deep = .false. + do_gsl_drag_ls_bl = .true. + do_gsl_drag_ss = .true. + do_gsl_drag_tofd = .true. + do_mynnedmf = .true. + do_mynnsfclay = .true. + dspheat = .true. + effr_in = .true. + fhcyc = 0.0 + fhlwr = 1200.0 + fhswr = 1200.0 + fhzero = 1.0 + gwd_opt = 3 + h2o_phys = .true. + hybedmf = .false. + iaer = 5111 + ialb = 1 + iau_delthrs = 6 + iau_inc_files = '' + iaufhrs = 30 + icliq_sw = 2 + icloud_bl = 1 + ico2 = 2 + iems = 1 + imfdeepcnv = -1 + imfshalcnv = -1 + imp_physics = 8 + iopt_alb = 2 + iopt_btr = 1 + iopt_crs = 1 + iopt_dveg = 2 + iopt_frz = 1 + iopt_inf = 1 + iopt_rad = 1 + iopt_run = 1 + iopt_sfc = 1 + iopt_snf = 4 + iopt_stc = 1 + iopt_tbot = 2 + iopt_trs = 2 + iovr = 3 + isol = 2 + isot = 1 + isubc_lw = 2 + isubc_sw = 2 + ivegsrc = 1 + kice = 9 + ldiag3d = .false. + lheatstrg = .false. + lradar = .true. + lsm = 3 + lsoil = 4 + lsoil_lsm = 9 + ltaerosol = .true. + lwhtr = .true. + nsfullradar_diag = 3600 + nst_anl = .true. + nstf_name = 2, 1, 0, 0, 0 + oz_phys = .false. + oz_phys_2015 = .true. + pdfcld = .false. + pre_rad = .false. + print_diff_pgr = .false. + prslrd0 = 0.0 + random_clds = .false. + redrag = .true. + satmedmf = .false. + sfclay_compute_flux = .true. + shal_cnv = .false. + swhtr = .true. + trans_trac = .true. + ttendlim = -999 + use_ufo = .true. +/ + +&interpolator_nml + interp_method = 'conserve_great_circle' +/ + +&nam_sfcperts +/ + +&nam_sppperts +/ + +&nam_stochy +/ + +&namsfc + fabsl = 99999 + faisl = 99999 + faiss = 99999 + fnacna = '' + fnaisc = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/CFSR.SEAICE.1982.2012.monthly.clim.grb' + fnglac = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/global_glacier.2x2.grb' + fnmskh = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/seaice_newland.grb' + fnmxic = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/global_maxice.2x2.grb' + fnsmcc = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/global_soilmgldas.t126.384.190.grb' + fnsnoa = '' + fnsnoc = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/global_snoclim.1.875.grb' + fntsfa = '' + fntsfc = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/RTGSST.1982.2012.monthly.clim.grb' + fnzorc = 'igbp' + fsicl = 99999 + fsics = 99999 + fslpl = 99999 + fsmcl = 99999, 99999, 99999 + fsnol = 99999 + fsnos = 99999 + fsotl = 99999 + ftsfl = 99999 + ftsfs = 90 + fvetl = 99999 + fvmnl = 99999 + fvmxl = 99999 + ldebug = .true. +/ + +&namsfc_dict + fnabsc = '../fix_lam/C403.maximum_snow_albedo.tileX.nc' + fnalbc = '../fix_lam/C403.snowfree_albedo.tileX.nc' + fnalbc2 = '../fix_lam/C403.facsf.tileX.nc' + fnslpc = '../fix_lam/C403.slope_type.tileX.nc' + fnsotc = '../fix_lam/C403.soil_type.tileX.nc' + fntg3c = '../fix_lam/C403.substrate_temperature.tileX.nc' + fnvegc = '../fix_lam/C403.vegetation_greenness.tileX.nc' + fnvetc = '../fix_lam/C403.vegetation_type.tileX.nc' + fnvmnc = '../fix_lam/C403.vegetation_greenness.tileX.nc' + fnvmxc = '../fix_lam/C403.vegetation_greenness.tileX.nc' +/ + +&surf_map_nml + cd2 = -1 + cd4 = 0.12 + max_slope = 0.4 + n_del2_strong = 0 + n_del2_weak = 2 + n_del4 = 1 + peak_fac = 1.0 + zero_ocean = .false. +/ diff --git a/physics/docs/pdftxt/RE300/namelists/input.nml.develop.FV3_RAP b/physics/docs/pdftxt/RE300/namelists/input.nml.develop.FV3_RAP new file mode 100644 index 000000000..ef3f44fc5 --- /dev/null +++ b/physics/docs/pdftxt/RE300/namelists/input.nml.develop.FV3_RAP @@ -0,0 +1,300 @@ +&amip_interp_nml + data_set = 'reynolds_oi' + date_out_of_range = 'climo' + interp_oi_sst = .true. + no_anom_sst = .false. + use_ncep_ice = .false. + use_ncep_sst = .true. +/ + +&atmos_model_nml + blocksize = 40 + ccpp_suite = 'FV3_RAP' + chksum_debug = .false. + dycore_only = .false. +/ + +&cires_ugwp_nml + knob_ugwp_azdir = 2, 4, 4, 4 + knob_ugwp_doaxyz = 1 + knob_ugwp_doheat = 1 + knob_ugwp_dokdis = 1 + knob_ugwp_effac = 1, 1, 1, 1 + knob_ugwp_ndx4lh = 1 + knob_ugwp_solver = 2 + knob_ugwp_source = 1, 1, 0, 0 + knob_ugwp_stoch = 0, 0, 0, 0 + knob_ugwp_version = 0 + knob_ugwp_wvspec = 1, 25, 25, 25 + launch_level = 25 +/ + +&diag_manager_nml + max_output_fields = 450 + prepend_date = .false. +/ + +&external_ic_nml + checker_tr = .false. + filtered_terrain = .true. + gfs_dwinds = .true. + levp = 65 + nt_checker = 0 +/ + +&fms_io_nml + checksum_required = .false. + max_files_r = 100 + max_files_w = 100 +/ + +&fms_nml + clock_grain = 'ROUTINE' + domains_stack_size = 12000000 + print_memory_usage = .false. +/ + +&fv_core_nml + a_imp = 1.0 + adjust_dry_mass = .false. + bc_update_interval = 6 + beta = 0.0 + consv_am = .false. + consv_te = 0.0 + d2_bg = 0.0 + d2_bg_k1 = 0.2 + d2_bg_k2 = 0.04 + d4_bg = 0.12 + d_con = 1.0 + d_ext = 0.0 + dddmp = 0.1 + delt_max = 0.008 + dnats = 0 + do_sat_adj = .false. + do_schmidt = .true. + do_vort_damp = .true. + dwind_2d = .false. + dz_min = 2 + external_eta = .true. + external_ic = .true. + fill = .true. + full_zs_filter = .false. + fv_debug = .false. + fv_sg_adj = 300 + gfs_phil = .false. + hord_dp = -5 + hord_mt = 5 + hord_tm = 5 + hord_tr = 10 + hord_vt = 5 + hydrostatic = .false. + io_layout = 1, 1 + k_split = 2 + ke_bg = 0.0 + kord_mt = 9 + kord_tm = -9 + kord_tr = 9 + kord_wz = 9 + layout = 5, 2 + make_nh = .true. + mountain = .false. + n_split = 5 + n_sponge = 24 + n_zs_filter = 0 + na_init = 1 + ncep_ic = .false. + nggps_ic = .true. + no_dycore = .false. + nord = 3 + nord_tr = 2 + npx = 220 + npy = 132 + npz = 64 + nrows_blend = 10 + ntiles = 1 + nudge_qv = .false. + nwat = 6 + p_fac = 0.1 + phys_hydrostatic = .false. + print_freq = 6 + psm_bc = 1 + range_warn = .true. + read_increment = .false. + regional = .true. + regional_bcs_from_gsi = .false. + res_latlon_dynamics = 'fv3_increment.nc' + reset_eta = .false. + rf_cutoff = 2000.0 + stretch_fac = 0.999 + target_lat = 38.5 + target_lon = -97.5 + tau = 5.0 + use_hydro_pressure = .false. + vtdm4 = 0.02 + warm_start = .false. + write_restart_with_bcs = .false. + z_tracer = .true. +/ + +&fv_grid_nml + grid_file = 'INPUT/grid_spec.nc' +/ + +&gfs_physics_nml + bl_mynn_edmf = 1 + bl_mynn_edmf_mom = 1 + bl_mynn_tkeadvect = .true. + cal_pre = .false. + cdmbgwd = 3.5, 1.0 + cnvcld = .false. + cnvgwd = .false. + cplflx = .false. + debug = .false. + do_deep = .true. + do_gsl_drag_ls_bl = .true. + do_gsl_drag_ss = .true. + do_gsl_drag_tofd = .true. + do_mynnedmf = .true. + do_mynnsfclay = .true. + do_shum = .false. + do_skeb = .false. + do_spp = .false. + do_sppt = .false. + dspheat = .true. + effr_in = .true. + fhcyc = 0 + fhlwr = 1200.0 + fhswr = 1200.0 + fhzero = 1.0 + gwd_opt = 3 + h2o_phys = .true. + hybedmf = .false. + iaer = 5111 + ialb = 1 + iau_delthrs = 6 + iau_inc_files = '' + iaufhrs = 30 + icliq_sw = 2 + icloud_bl = 1 + ico2 = 2 + iems = 1 + imfdeepcnv = 3 + imfshalcnv = 3 + imp_physics = 8 + iopt_alb = 2 + iopt_btr = 1 + iopt_crs = 1 + iopt_dveg = 2 + iopt_frz = 1 + iopt_inf = 1 + iopt_rad = 1 + iopt_run = 1 + iopt_sfc = 1 + iopt_snf = 4 + iopt_stc = 1 + iopt_tbot = 2 + iopt_trs = 2 + iovr = 3 + isol = 2 + isot = 1 + isubc_lw = 2 + isubc_sw = 2 + ivegsrc = 1 + kice = 9 + ldiag3d = .false. + lheatstrg = .false. + lndp_type = 0 + lradar = .true. + lsm = 3 + lsoil = 4 + lsoil_lsm = 9 + ltaerosol = .true. + lwhtr = .true. + n_var_lndp = 0 + n_var_spp = 0 + nsfullradar_diag = 3600 + nst_anl = .true. + nstf_name = 2, 1, 0, 0, 0 + oz_phys = .false. + oz_phys_2015 = .true. + pdfcld = .false. + pre_rad = .false. + print_diff_pgr = .false. + prslrd0 = 0.0 + random_clds = .false. + redrag = .true. + satmedmf = .false. + sfclay_compute_flux = .false. + shal_cnv = .true. + swhtr = .true. + trans_trac = .true. + ttendlim = -999 + use_ufo = .true. +/ + +&interpolator_nml + interp_method = 'conserve_great_circle' +/ + +&nam_sfcperts +/ + +&nam_sppperts +/ + +&nam_stochy +/ + +&namsfc + fabsl = 99999 + faisl = 99999 + faiss = 99999 + fnacna = '' + fnaisc = '../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/CFSR.SEAICE.1982.2012.monthly.clim.grb' + fnglac = '../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/global_glacier.2x2.grb' + fnmskh = '../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/seaice_newland.grb' + fnmxic = '../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/global_maxice.2x2.grb' + fnsmcc = '../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/global_soilmgldas.t126.384.190.grb' + fnsnoa = '' + fnsnoc = '../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/global_snoclim.1.875.grb' + fntsfa = '' + fntsfc = '../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/RTGSST.1982.2012.monthly.clim.grb' + fnzorc = 'igbp' + fsicl = 99999 + fsics = 99999 + fslpl = 99999 + fsmcl = 99999, 99999, 99999 + fsnol = 99999 + fsnos = 99999 + fsotl = 99999 + ftsfl = 99999 + ftsfs = 90 + fvetl = 99999 + fvmnl = 99999 + fvmxl = 99999 + ldebug = .true. +/ + +&namsfc_dict + fnabsc = '../fix_lam/C403.maximum_snow_albedo.tileX.nc' + fnalbc = '../fix_lam/C403.snowfree_albedo.tileX.nc' + fnalbc2 = '../fix_lam/C403.facsf.tileX.nc' + fnslpc = '../fix_lam/C403.slope_type.tileX.nc' + fnsotc = '../fix_lam/C403.soil_type.tileX.nc' + fntg3c = '../fix_lam/C403.substrate_temperature.tileX.nc' + fnvegc = '../fix_lam/C403.vegetation_greenness.tileX.nc' + fnvetc = '../fix_lam/C403.vegetation_type.tileX.nc' + fnvmnc = '../fix_lam/C403.vegetation_greenness.tileX.nc' + fnvmxc = '../fix_lam/C403.vegetation_greenness.tileX.nc' +/ + +&surf_map_nml + cd2 = -1 + cd4 = 0.12 + max_slope = 0.4 + n_del2_strong = 0 + n_del2_weak = 2 + n_del4 = 1 + peak_fac = 1.0 + zero_ocean = .false. +/ diff --git a/physics/docs/pdftxt/RE300/namelists/input.nml.develop.FV3_RRFS_v1beta b/physics/docs/pdftxt/RE300/namelists/input.nml.develop.FV3_RRFS_v1beta new file mode 100644 index 000000000..97a0f1216 --- /dev/null +++ b/physics/docs/pdftxt/RE300/namelists/input.nml.develop.FV3_RRFS_v1beta @@ -0,0 +1,285 @@ +&amip_interp_nml + data_set = 'reynolds_oi' + date_out_of_range = 'climo' + interp_oi_sst = .true. + no_anom_sst = .false. + use_ncep_ice = .false. + use_ncep_sst = .true. +/ + +&atmos_model_nml + blocksize = 40 + ccpp_suite = 'FV3_RRFS_v1beta' + chksum_debug = .false. + dycore_only = .false. +/ + +&cires_ugwp_nml + knob_ugwp_azdir = 2, 4, 4, 4 + knob_ugwp_doaxyz = 1 + knob_ugwp_doheat = 1 + knob_ugwp_dokdis = 1 + knob_ugwp_effac = 1, 1, 1, 1 + knob_ugwp_ndx4lh = 1 + knob_ugwp_solver = 2 + knob_ugwp_source = 1, 1, 0, 0 + knob_ugwp_stoch = 0, 0, 0, 0 + knob_ugwp_version = 0 + knob_ugwp_wvspec = 1, 25, 25, 25 + launch_level = 25 +/ + +&diag_manager_nml + max_output_fields = 450 + prepend_date = .false. +/ + +&external_ic_nml + checker_tr = .false. + filtered_terrain = .true. + gfs_dwinds = .true. + levp = 65 + nt_checker = 0 +/ + +&fms_io_nml + checksum_required = .false. + max_files_r = 100 + max_files_w = 100 +/ + +&fms_nml + clock_grain = 'ROUTINE' + domains_stack_size = 12000000 + print_memory_usage = .false. +/ + +&fv_core_nml + a_imp = 1.0 + adjust_dry_mass = .false. + bc_update_interval = 6 + beta = 0.0 + consv_am = .false. + consv_te = 0.0 + d2_bg = 0.0 + d2_bg_k1 = 0.2 + d2_bg_k2 = 0.04 + d4_bg = 0.12 + d_con = 1.0 + d_ext = 0.0 + dddmp = 0.1 + delt_max = 0.008 + dnats = 0 + do_sat_adj = .false. + do_schmidt = .true. + do_vort_damp = .true. + dwind_2d = .false. + dz_min = 2 + external_eta = .true. + external_ic = .true. + fill = .true. + full_zs_filter = .false. + fv_debug = .false. + fv_sg_adj = 300 + gfs_phil = .false. + hord_dp = 6 + hord_mt = 6 + hord_tm = 6 + hord_tr = 10 + hord_vt = 6 + hydrostatic = .false. + io_layout = 1, 1 + k_split = 2 + ke_bg = 0.0 + kord_mt = 9 + kord_tm = -9 + kord_tr = 9 + kord_wz = 9 + layout = 5, 2 + make_nh = .true. + mountain = .false. + n_split = 5 + n_sponge = 24 + n_zs_filter = 0 + na_init = 1 + ncep_ic = .false. + nggps_ic = .true. + no_dycore = .false. + nord = 3 + npx = 220 + npy = 132 + npz = 64 + nrows_blend = 10 + ntiles = 1 + nudge_qv = .false. + nwat = 6 + p_fac = 0.1 + phys_hydrostatic = .false. + print_freq = 6 + psm_bc = 1 + range_warn = .true. + read_increment = .false. + regional = .true. + regional_bcs_from_gsi = .false. + res_latlon_dynamics = 'fv3_increment.nc' + reset_eta = .false. + rf_cutoff = 2000.0 + stretch_fac = 0.999 + target_lat = 38.5 + target_lon = -97.5 + tau = 5.0 + use_hydro_pressure = .false. + vtdm4 = 0.02 + warm_start = .false. + write_restart_with_bcs = .false. + z_tracer = .true. +/ + +&fv_grid_nml + grid_file = 'INPUT/grid_spec.nc' +/ + +&gfs_physics_nml + bl_mynn_edmf = 1 + bl_mynn_edmf_mom = 1 + bl_mynn_tkeadvect = .true. + cal_pre = .false. + cdmbgwd = 3.5, 0.25 + cnvcld = .false. + cnvgwd = .false. + cplflx = .false. + debug = .false. + do_deep = .false. + do_mynnedmf = .true. + do_mynnsfclay = .true. + dspheat = .true. + effr_in = .true. + fhcyc = 0.0 + fhlwr = 1200.0 + fhswr = 1200.0 + fhzero = 1.0 + h2o_phys = .true. + hybedmf = .false. + iaer = 111 + ialb = 1 + iau_delthrs = 6 + iau_inc_files = '' + iaufhrs = 30 + icloud_bl = 1 + ico2 = 2 + iems = 1 + imfdeepcnv = -1 + imfshalcnv = -1 + imp_physics = 8 + iopt_alb = 2 + iopt_btr = 1 + iopt_crs = 1 + iopt_dveg = 2 + iopt_frz = 1 + iopt_inf = 1 + iopt_rad = 1 + iopt_run = 1 + iopt_sfc = 1 + iopt_snf = 4 + iopt_stc = 1 + iopt_tbot = 2 + iopt_trs = 2 + isol = 2 + isot = 1 + isubc_lw = 2 + isubc_sw = 2 + ivegsrc = 1 + ldiag3d = .false. + lheatstrg = .false. + lradar = .true. + lsm = 2 + lsoil = 4 + lsoil_lsm = 4 + ltaerosol = .true. + lwhtr = .true. + nsfullradar_diag = 3600 + nst_anl = .true. + nstf_name = 2, 1, 0, 0, 0 + oz_phys = .false. + oz_phys_2015 = .true. + pdfcld = .false. + pre_rad = .false. + print_diff_pgr = .false. + prslrd0 = 0.0 + random_clds = .false. + redrag = .true. + satmedmf = .false. + sfclay_compute_flux = .false. + shal_cnv = .false. + swhtr = .true. + trans_trac = .true. + ttendlim = -999 + use_ufo = .true. +/ + +&interpolator_nml + interp_method = 'conserve_great_circle' +/ + +&nam_sfcperts +/ + +&nam_sppperts +/ + +&nam_stochy +/ + +&namsfc + fabsl = 99999 + faisl = 99999 + faiss = 99999 + fnacna = '' + fnaisc = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/CFSR.SEAICE.1982.2012.monthly.clim.grb' + fnglac = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/global_glacier.2x2.grb' + fnmskh = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/seaice_newland.grb' + fnmxic = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/global_maxice.2x2.grb' + fnsmcc = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/global_soilmgldas.t126.384.190.grb' + fnsnoa = '' + fnsnoc = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/global_snoclim.1.875.grb' + fntsfa = '' + fntsfc = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/RTGSST.1982.2012.monthly.clim.grb' + fnzorc = 'igbp' + fsicl = 99999 + fsics = 99999 + fslpl = 99999 + fsmcl = 99999, 99999, 99999 + fsnol = 99999 + fsnos = 99999 + fsotl = 99999 + ftsfl = 99999 + ftsfs = 90 + fvetl = 99999 + fvmnl = 99999 + fvmxl = 99999 + ldebug = .true. +/ + +&namsfc_dict + fnabsc = '../fix_lam/C403.maximum_snow_albedo.tileX.nc' + fnalbc = '../fix_lam/C403.snowfree_albedo.tileX.nc' + fnalbc2 = '../fix_lam/C403.facsf.tileX.nc' + fnslpc = '../fix_lam/C403.slope_type.tileX.nc' + fnsotc = '../fix_lam/C403.soil_type.tileX.nc' + fntg3c = '../fix_lam/C403.substrate_temperature.tileX.nc' + fnvegc = '../fix_lam/C403.vegetation_greenness.tileX.nc' + fnvetc = '../fix_lam/C403.vegetation_type.tileX.nc' + fnvmnc = '../fix_lam/C403.vegetation_greenness.tileX.nc' + fnvmxc = '../fix_lam/C403.vegetation_greenness.tileX.nc' +/ + +&surf_map_nml + cd2 = -1 + cd4 = 0.12 + max_slope = 0.4 + n_del2_strong = 0 + n_del2_weak = 2 + n_del4 = 1 + peak_fac = 1.0 + zero_ocean = .false. +/ diff --git a/physics/docs/pdftxt/RE300/namelists/input.nml.develop.FV3_WoFS_v0 b/physics/docs/pdftxt/RE300/namelists/input.nml.develop.FV3_WoFS_v0 new file mode 100644 index 000000000..1236cde3b --- /dev/null +++ b/physics/docs/pdftxt/RE300/namelists/input.nml.develop.FV3_WoFS_v0 @@ -0,0 +1,291 @@ +&amip_interp_nml + data_set = 'reynolds_oi' + date_out_of_range = 'climo' + interp_oi_sst = .true. + no_anom_sst = .false. + use_ncep_ice = .false. + use_ncep_sst = .true. +/ + +&atmos_model_nml + blocksize = 40 + ccpp_suite = 'FV3_WoFS_v0' + chksum_debug = .false. + dycore_only = .false. +/ + +&cires_ugwp_nml + knob_ugwp_azdir = 2, 4, 4, 4 + knob_ugwp_doaxyz = 1 + knob_ugwp_doheat = 1 + knob_ugwp_dokdis = 1 + knob_ugwp_effac = 1, 1, 1, 1 + knob_ugwp_ndx4lh = 1 + knob_ugwp_solver = 2 + knob_ugwp_source = 1, 1, 0, 0 + knob_ugwp_stoch = 0, 0, 0, 0 + knob_ugwp_version = 0 + knob_ugwp_wvspec = 1, 25, 25, 25 + launch_level = 25 +/ + +&diag_manager_nml + max_output_fields = 450 + prepend_date = .false. +/ + +&external_ic_nml + checker_tr = .false. + filtered_terrain = .true. + gfs_dwinds = .true. + levp = 65 + nt_checker = 0 +/ + +&fms_io_nml + checksum_required = .false. + max_files_r = 100 + max_files_w = 100 +/ + +&fms_nml + clock_grain = 'ROUTINE' + domains_stack_size = 12000000 + print_memory_usage = .false. +/ + +&fv_core_nml + a_imp = 1.0 + adjust_dry_mass = .false. + bc_update_interval = 6 + beta = 0.0 + consv_am = .false. + consv_te = 0.0 + d2_bg = 0.0 + d2_bg_k1 = 0.2 + d2_bg_k2 = 0.04 + d4_bg = 0.12 + d_con = 1.0 + d_ext = 0.0 + dddmp = 0.1 + delt_max = 0.008 + dnats = 0 + do_sat_adj = .false. + do_schmidt = .true. + do_vort_damp = .true. + dwind_2d = .false. + dz_min = 2 + external_eta = .true. + external_ic = .true. + fill = .true. + full_zs_filter = .false. + fv_debug = .false. + fv_sg_adj = 300 + gfs_phil = .false. + hord_dp = 6 + hord_mt = 6 + hord_tm = 6 + hord_tr = 10 + hord_vt = 6 + hydrostatic = .false. + io_layout = 1, 1 + k_split = 2 + ke_bg = 0.0 + kord_mt = 9 + kord_tm = -9 + kord_tr = 9 + kord_wz = 9 + layout = 5, 2 + make_nh = .true. + mountain = .false. + n_split = 5 + n_sponge = 24 + n_zs_filter = 0 + na_init = 1 + ncep_ic = .false. + nggps_ic = .true. + no_dycore = .false. + nord = 3 + npx = 220 + npy = 132 + npz = 64 + nrows_blend = 10 + ntiles = 1 + nudge_qv = .false. + nwat = 7 + p_fac = 0.1 + phys_hydrostatic = .false. + print_freq = 6 + psm_bc = 1 + range_warn = .true. + read_increment = .false. + regional = .true. + regional_bcs_from_gsi = .false. + res_latlon_dynamics = 'fv3_increment.nc' + reset_eta = .false. + rf_cutoff = 2000.0 + stretch_fac = 0.999 + target_lat = 38.5 + target_lon = -97.5 + tau = 5.0 + use_hydro_pressure = .false. + vtdm4 = 0.02 + warm_start = .false. + write_restart_with_bcs = .false. + z_tracer = .true. +/ + +&fv_diagnostics_nml + do_hailcast = .true. +/ + +&fv_grid_nml + grid_file = 'INPUT/grid_spec.nc' +/ + +&gfs_physics_nml + bl_mynn_edmf = 1 + bl_mynn_edmf_mom = 1 + bl_mynn_tkeadvect = .true. + cal_pre = .false. + cdmbgwd = 3.5, 0.25 + cnvcld = .false. + cnvgwd = .false. + cplflx = .false. + debug = .false. + do_deep = .false. + do_mynnedmf = .true. + do_mynnsfclay = .true. + dspheat = .true. + effr_in = .true. + fhcyc = 0.0 + fhlwr = 1200.0 + fhswr = 1200.0 + fhzero = 1.0 + h2o_phys = .true. + hybedmf = .false. + iaer = 111 + ialb = 1 + iau_delthrs = 6 + iau_inc_files = '' + iaufhrs = 30 + icloud_bl = 1 + ico2 = 2 + iems = 1 + imfdeepcnv = -1 + imfshalcnv = -1 + imp_physics = 17 + iopt_alb = 2 + iopt_btr = 1 + iopt_crs = 1 + iopt_dveg = 2 + iopt_frz = 1 + iopt_inf = 1 + iopt_rad = 1 + iopt_run = 1 + iopt_sfc = 1 + iopt_snf = 4 + iopt_stc = 1 + iopt_tbot = 2 + isol = 2 + isot = 1 + isubc_lw = 2 + isubc_sw = 2 + ivegsrc = 1 + ldiag3d = .false. + lheatstrg = .false. + lradar = .true. + lsm = 1 + lsoil = 4 + lsoil_lsm = 4 + ltaerosol = .true. + lwhtr = .true. + nsfullradar_diag = 3600 + nssl_cccn = 600000000.0 + nssl_ccn_on = .true. + nssl_hail_on = .true. + nst_anl = .true. + nstf_name = 2, 1, 0, 0, 0 + oz_phys = .false. + oz_phys_2015 = .true. + pdfcld = .false. + pre_rad = .false. + print_diff_pgr = .false. + prslrd0 = 0.0 + random_clds = .false. + redrag = .true. + satmedmf = .false. + sfclay_compute_flux = .false. + shal_cnv = .false. + swhtr = .true. + trans_trac = .true. + ttendlim = -999 + use_ufo = .true. +/ + +&interpolator_nml + interp_method = 'conserve_great_circle' +/ + +&nam_sfcperts +/ + +&nam_sppperts +/ + +&nam_stochy +/ + +&namsfc + fabsl = 99999 + faisl = 99999 + faiss = 99999 + fnacna = '' + fnaisc = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/CFSR.SEAICE.1982.2012.monthly.clim.grb' + fnglac = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/global_glacier.2x2.grb' + fnmskh = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/seaice_newland.grb' + fnmxic = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/global_maxice.2x2.grb' + fnsmcc = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/global_soilmgldas.t126.384.190.grb' + fnsnoa = '' + fnsnoc = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/global_snoclim.1.875.grb' + fntsfa = '' + fntsfc = '../../../../../../../../../../../../scratch1/NCEPDEV/nems/role.epic/UFS_SRW_data/develop/fix/fix_am/RTGSST.1982.2012.monthly.clim.grb' + fnzorc = 'igbp' + fsicl = 99999 + fsics = 99999 + fslpl = 99999 + fsmcl = 99999, 99999, 99999 + fsnol = 99999 + fsnos = 99999 + fsotl = 99999 + ftsfl = 99999 + ftsfs = 90 + fvetl = 99999 + fvmnl = 99999 + fvmxl = 99999 + ldebug = .true. +/ + +&namsfc_dict + fnabsc = '../fix_lam/C403.maximum_snow_albedo.tileX.nc' + fnalbc = '../fix_lam/C403.snowfree_albedo.tileX.nc' + fnalbc2 = '../fix_lam/C403.facsf.tileX.nc' + fnslpc = '../fix_lam/C403.slope_type.tileX.nc' + fnsotc = '../fix_lam/C403.soil_type.tileX.nc' + fntg3c = '../fix_lam/C403.substrate_temperature.tileX.nc' + fnvegc = '../fix_lam/C403.vegetation_greenness.tileX.nc' + fnvetc = '../fix_lam/C403.vegetation_type.tileX.nc' + fnvmnc = '../fix_lam/C403.vegetation_greenness.tileX.nc' + fnvmxc = '../fix_lam/C403.vegetation_greenness.tileX.nc' +/ + +&surf_map_nml + cd2 = -1 + cd4 = 0.12 + max_slope = 0.4 + n_del2_strong = 0 + n_del2_weak = 2 + n_del4 = 1 + peak_fac = 1.0 + zero_ocean = .false. +/ diff --git a/physics/docs/pdftxt/RE300/namelists/input.nml.v21.FV3_GFS_v16 b/physics/docs/pdftxt/RE300/namelists/input.nml.v21.FV3_GFS_v16 new file mode 100644 index 000000000..6dc85900b --- /dev/null +++ b/physics/docs/pdftxt/RE300/namelists/input.nml.v21.FV3_GFS_v16 @@ -0,0 +1,336 @@ +&amip_interp_nml + data_set = 'reynolds_oi' + date_out_of_range = 'climo' + interp_oi_sst = .true. + no_anom_sst = .false. + use_ncep_ice = .false. + use_ncep_sst = .true. +/ + +&atmos_model_nml + blocksize = 40 + ccpp_suite = 'FV3_GFS_v16' + chksum_debug = .false. + dycore_only = .false. +/ + +&cires_ugwp_nml + knob_ugwp_azdir = 2, 4, 4, 4 + knob_ugwp_doaxyz = 1 + knob_ugwp_doheat = 1 + knob_ugwp_dokdis = 1 + knob_ugwp_effac = 1, 1, 1, 1 + knob_ugwp_ndx4lh = 1 + knob_ugwp_solver = 2 + knob_ugwp_source = 1, 1, 0, 0 + knob_ugwp_stoch = 0, 0, 0, 0 + knob_ugwp_version = 0 + knob_ugwp_wvspec = 1, 25, 25, 25 + launch_level = 27 +/ + +&diag_manager_nml + prepend_date = .false. +/ + +&external_ic_nml + checker_tr = .false. + filtered_terrain = .true. + gfs_dwinds = .true. + levp = 65 + nt_checker = 0 +/ + +&fms_io_nml + checksum_required = .false. + max_files_r = 100 + max_files_w = 100 +/ + +&fms_nml + clock_grain = 'ROUTINE' + domains_stack_size = 5000000 + print_memory_usage = .false. +/ + +&fv_core_nml + a_imp = 1.0 + adjust_dry_mass = .false. + agrid_vel_rst = .false. + bc_update_interval = 6 + beta = 0.0 + consv_am = .false. + consv_te = 0.0 + d2_bg = 0.0 + d2_bg_k1 = 0.2 + d2_bg_k2 = 0.0 + d4_bg = 0.12 + d_con = 1.0 + d_ext = 0.0 + dddmp = 0.1 + delt_max = 0.008 + dnats = 1 + do_sat_adj = .true. + do_schmidt = .true. + do_vort_damp = .true. + dwind_2d = .false. + dz_min = 2 + external_eta = .true. + external_ic = .true. + fill = .true. + full_zs_filter = .false. + fv_debug = .false. + fv_sg_adj = 450 + gfs_phil = .false. + hord_dp = -5 + hord_mt = 5 + hord_tm = 5 + hord_tr = 10 + hord_vt = 5 + hydrostatic = .false. + io_layout = 1, 1 + k_split = 6 + ke_bg = 0.0 + kord_mt = 9 + kord_tm = -9 + kord_tr = 9 + kord_wz = 9 + layout = 5, 2 + make_nh = .false. + mountain = .false. + n_split = 6 + n_sponge = 10 + n_zs_filter = 0 + na_init = 0 + ncep_ic = .false. + nggps_ic = .true. + no_dycore = .false. + nord = 3 + npx = 220 + npy = 132 + npz = 64 + nrows_blend = 10 + ntiles = 1 + nudge_dz = .false. + nudge_qv = .true. + nwat = 6 + p_fac = 0.1 + phys_hydrostatic = .false. + print_freq = 6 + psm_bc = 1 + range_warn = .false. + read_increment = .false. + regional = .true. + regional_bcs_from_gsi = .false. + res_latlon_dynamics = '' + reset_eta = .false. + rf_cutoff = 750.0 + stretch_fac = 0.999 + target_lat = 38.5 + target_lon = -97.5 + tau = 10.0 + use_hydro_pressure = .false. + vtdm4 = 0.02 + warm_start = .false. + write_restart_with_bcs = .false. + z_tracer = .true. +/ + +&fv_grid_nml + grid_file = 'INPUT/grid_spec.nc' +/ + +&gfdl_cloud_microphysics_nml + c_cracw = 0.8 + c_paut = 0.5 + c_pgacs = 0.01 + c_psaci = 0.05 + ccn_l = 300.0 + ccn_o = 100.0 + const_vg = .false. + const_vi = .false. + const_vr = .false. + const_vs = .false. + de_ice = .false. + do_qa = .true. + do_sedi_heat = .false. + dw_land = 0.16 + dw_ocean = 0.1 + fast_sat_adj = .true. + fix_negative = .true. + icloud_f = 1 + mono_prof = .true. + mp_time = 150.0 + prog_ccn = .false. + qi0_crt = 8e-05 + qi_lim = 1.0 + ql_gen = 0.001 + ql_mlt = 0.001 + qs0_crt = 0.001 + rad_graupel = .true. + rad_rain = .true. + rad_snow = .true. + reiflag = 2 + rh_inc = 0.3 + rh_inr = 0.3 + rh_ins = 0.3 + rthresh = 1e-05 + sedi_transport = .true. + tau_g2v = 900.0 + tau_i2s = 1000.0 + tau_l2v = 225.0 + tau_v2l = 150.0 + use_ccn = .true. + use_ppm = .false. + vg_max = 12.0 + vi_max = 1.0 + vr_max = 12.0 + vs_max = 2.0 + z_slope_ice = .true. + z_slope_liq = .true. +/ + +&gfs_physics_nml + cal_pre = .false. + cdmbgwd = 4.0, 0.15, 1.0, 1.0 + cnvcld = .true. + cnvgwd = .true. + debug = .false. + do_shum = .false. + do_skeb = .false. + do_spp = .false. + do_sppt = .false. + do_tofd = .true. + do_ugwp = .false. + dspheat = .true. + effr_in = .true. + fhcyc = 0 + fhlwr = 3600.0 + fhswr = 3600.0 + fhzero = 1.0 + h2o_phys = .true. + hybedmf = .false. + iaer = 5111 + ialb = 1 + iau_inc_files = '' + icliq_sw = 2 + ico2 = 2 + iems = 1 + imfdeepcnv = 2 + imfshalcnv = 2 + imp_physics = 11 + iopt_alb = 2 + iopt_btr = 1 + iopt_crs = 1 + iopt_dveg = 1 + iopt_frz = 1 + iopt_inf = 1 + iopt_rad = 1 + iopt_run = 1 + iopt_sfc = 1 + iopt_snf = 4 + iopt_stc = 1 + iopt_tbot = 2 + iopt_trs = 2 + iovr = 3 + isatmedmf = 1 + isol = 2 + isot = 1 + isubc_lw = 2 + isubc_sw = 2 + ivegsrc = 1 + ldiag3d = .false. + ldiag_ugwp = .false. + lgfdlmprad = .true. + lheatstrg = .true. + lndp_type = 0 + lsm = 1 + lsoil = 4 + lwhtr = .true. + n_var_lndp = 0 + n_var_spp = 0 + nsradar_reset = 3600 + nst_anl = .true. + nstf_name = 2, 1, 0, 0, 0 + oz_phys = .false. + oz_phys_2015 = .true. + pdfcld = .false. + prautco = 0.00015, 0.00015 + pre_rad = .false. + print_diff_pgr = .false. + prslrd0 = 0.0 + psautco = 0.0008, 0.0005 + random_clds = .false. + redrag = .true. + satmedmf = .true. + sfclay_compute_flux = .false. + shal_cnv = .true. + swhtr = .true. + trans_trac = .true. + use_ufo = .true. +/ + +&interpolator_nml + interp_method = 'conserve_great_circle' +/ + +&mpp_io_nml + deflate_level = 1 + shuffle = 1 +/ + +&nam_sfcperts +/ + +&nam_sppperts +/ + +&nam_stochy +/ + +&namsfc + fabsl = 99999 + faisl = 99999 + faiss = 99999 + fnacna = '' + fnaisc = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/CFSR.SEAICE.1982.2012.monthly.clim.grb' + fnglac = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/global_glacier.2x2.grb' + fnmskh = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/seaice_newland.grb' + fnmxic = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/global_maxice.2x2.grb' + fnsmcc = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/global_soilmgldas.t126.384.190.grb' + fnsnoa = '' + fnsnoc = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/global_snoclim.1.875.grb' + fntsfa = '' + fntsfc = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/RTGSST.1982.2012.monthly.clim.grb' + fnzorc = 'igbp' + fsicl = 99999 + fsics = 99999 + fslpl = 99999 + fsmcl = 99999, 99999, 99999 + fsnol = 99999 + fsnos = 99999 + fsotl = 99999 + ftsfl = 99999 + ftsfs = 90 + fvetl = 99999 + fvmnl = 99999 + fvmxl = 99999 + landice = .true. + ldebug = .false. +/ + +&namsfc_dict + fnabsc = '../fix_lam/C403.maximum_snow_albedo.tileX.nc' + fnalbc = '../fix_lam/C403.snowfree_albedo.tileX.nc' + fnalbc2 = '../fix_lam/C403.facsf.tileX.nc' + fnslpc = '../fix_lam/C403.slope_type.tileX.nc' + fnsotc = '../fix_lam/C403.soil_type.tileX.nc' + fntg3c = '../fix_lam/C403.substrate_temperature.tileX.nc' + fnvegc = '../fix_lam/C403.vegetation_greenness.tileX.nc' + fnvetc = '../fix_lam/C403.vegetation_type.tileX.nc' + fnvmnc = '../fix_lam/C403.vegetation_greenness.tileX.nc' + fnvmxc = '../fix_lam/C403.vegetation_greenness.tileX.nc' +/ + +&surf_map_nml +/ diff --git a/physics/docs/pdftxt/RE300/namelists/input.nml.v21.FV3_HRRR b/physics/docs/pdftxt/RE300/namelists/input.nml.v21.FV3_HRRR new file mode 100644 index 000000000..cd9408a4d --- /dev/null +++ b/physics/docs/pdftxt/RE300/namelists/input.nml.v21.FV3_HRRR @@ -0,0 +1,299 @@ +&amip_interp_nml + data_set = 'reynolds_oi' + date_out_of_range = 'climo' + interp_oi_sst = .true. + no_anom_sst = .false. + use_ncep_ice = .false. + use_ncep_sst = .true. +/ + +&atmos_model_nml + blocksize = 40 + ccpp_suite = 'FV3_HRRR' + chksum_debug = .false. + dycore_only = .false. +/ + +&cires_ugwp_nml + knob_ugwp_azdir = 2, 4, 4, 4 + knob_ugwp_doaxyz = 1 + knob_ugwp_doheat = 1 + knob_ugwp_dokdis = 1 + knob_ugwp_effac = 1, 1, 1, 1 + knob_ugwp_ndx4lh = 1 + knob_ugwp_solver = 2 + knob_ugwp_source = 1, 1, 0, 0 + knob_ugwp_stoch = 0, 0, 0, 0 + knob_ugwp_version = 0 + knob_ugwp_wvspec = 1, 25, 25, 25 + launch_level = 25 +/ + +&diag_manager_nml + prepend_date = .false. +/ + +&external_ic_nml + checker_tr = .false. + filtered_terrain = .true. + gfs_dwinds = .true. + levp = 65 + nt_checker = 0 +/ + +&fms_io_nml + checksum_required = .false. + max_files_r = 100 + max_files_w = 100 +/ + +&fms_nml + clock_grain = 'ROUTINE' + domains_stack_size = 5000000 + print_memory_usage = .false. +/ + +&fv_core_nml + a_imp = 1.0 + adjust_dry_mass = .false. + bc_update_interval = 6 + beta = 0.0 + consv_am = .false. + consv_te = 0.0 + d2_bg = 0.0 + d2_bg_k1 = 0.2 + d2_bg_k2 = 0.04 + d4_bg = 0.12 + d_con = 1.0 + d_ext = 0.0 + dddmp = 0.1 + delt_max = 0.008 + dnats = 0 + do_sat_adj = .false. + do_schmidt = .true. + do_vort_damp = .true. + dwind_2d = .false. + dz_min = 2 + external_eta = .true. + external_ic = .true. + fill = .true. + full_zs_filter = .false. + fv_debug = .false. + fv_sg_adj = 300 + gfs_phil = .false. + hord_dp = -5 + hord_mt = 5 + hord_tm = 5 + hord_tr = 10 + hord_vt = 5 + hydrostatic = .false. + io_layout = 1, 1 + k_split = 2 + ke_bg = 0.0 + kord_mt = 9 + kord_tm = -9 + kord_tr = 9 + kord_wz = 9 + layout = 5, 2 + make_nh = .true. + mountain = .false. + n_split = 5 + n_sponge = 24 + n_zs_filter = 0 + na_init = 1 + ncep_ic = .false. + nggps_ic = .true. + no_dycore = .false. + nord = 3 + nord_tr = 2 + npx = 220 + npy = 132 + npz = 64 + nrows_blend = 10 + ntiles = 1 + nudge_qv = .false. + nwat = 6 + p_fac = 0.1 + phys_hydrostatic = .false. + print_freq = 6 + psm_bc = 1 + range_warn = .true. + read_increment = .false. + regional = .true. + regional_bcs_from_gsi = .false. + res_latlon_dynamics = 'fv3_increment.nc' + reset_eta = .false. + rf_cutoff = 2000.0 + stretch_fac = 0.999 + target_lat = 38.5 + target_lon = -97.5 + tau = 5.0 + use_hydro_pressure = .false. + vtdm4 = 0.02 + warm_start = .false. + write_restart_with_bcs = .false. + z_tracer = .true. +/ + +&fv_grid_nml + grid_file = 'INPUT/grid_spec.nc' +/ + +&gfs_physics_nml + bl_mynn_edmf = 1 + bl_mynn_edmf_mom = 1 + bl_mynn_tkeadvect = .true. + cal_pre = .false. + cdmbgwd = 3.5, 1.0 + cnvcld = .false. + cnvgwd = .false. + cplflx = .false. + debug = .false. + do_deep = .false. + do_gsl_drag_ls_bl = .true. + do_gsl_drag_ss = .true. + do_gsl_drag_tofd = .true. + do_mynnedmf = .true. + do_mynnsfclay = .true. + do_shum = .false. + do_skeb = .false. + do_spp = .false. + do_sppt = .false. + dspheat = .true. + effr_in = .true. + fhcyc = 0 + fhlwr = 1200.0 + fhswr = 1200.0 + fhzero = 1.0 + gwd_opt = 3 + h2o_phys = .true. + hybedmf = .false. + iaer = 5111 + ialb = 1 + iau_delthrs = 6 + iau_inc_files = '' + iaufhrs = 30 + icliq_sw = 2 + icloud_bl = 1 + ico2 = 2 + iems = 1 + imfdeepcnv = -1 + imfshalcnv = -1 + imp_physics = 8 + iopt_alb = 2 + iopt_btr = 1 + iopt_crs = 1 + iopt_dveg = 2 + iopt_frz = 1 + iopt_inf = 1 + iopt_rad = 1 + iopt_run = 1 + iopt_sfc = 1 + iopt_snf = 4 + iopt_stc = 1 + iopt_tbot = 2 + iopt_trs = 2 + iovr = 3 + isol = 2 + isot = 1 + isubc_lw = 2 + isubc_sw = 2 + ivegsrc = 1 + kice = 9 + ldiag3d = .false. + lheatstrg = .false. + lndp_type = 0 + lradar = .true. + lsm = 3 + lsoil = 4 + lsoil_lsm = 9 + ltaerosol = .true. + lwhtr = .true. + n_var_lndp = 0 + n_var_spp = 0 + nsradar_reset = 3600 + nst_anl = .true. + nstf_name = 2, 1, 0, 0, 0 + oz_phys = .false. + oz_phys_2015 = .true. + pdfcld = .false. + pre_rad = .false. + print_diff_pgr = .false. + prslrd0 = 0.0 + random_clds = .false. + redrag = .true. + satmedmf = .false. + sfclay_compute_flux = .true. + shal_cnv = .false. + swhtr = .true. + trans_trac = .true. + ttendlim = -999 + use_ufo = .true. +/ + +&interpolator_nml + interp_method = 'conserve_great_circle' +/ + +&nam_sfcperts +/ + +&nam_sppperts +/ + +&nam_stochy +/ + +&namsfc + fabsl = 99999 + faisl = 99999 + faiss = 99999 + fnacna = '' + fnaisc = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/CFSR.SEAICE.1982.2012.monthly.clim.grb' + fnglac = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/global_glacier.2x2.grb' + fnmskh = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/seaice_newland.grb' + fnmxic = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/global_maxice.2x2.grb' + fnsmcc = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/global_soilmgldas.t126.384.190.grb' + fnsnoa = '' + fnsnoc = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/global_snoclim.1.875.grb' + fntsfa = '' + fntsfc = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/RTGSST.1982.2012.monthly.clim.grb' + fnzorc = 'igbp' + fsicl = 99999 + fsics = 99999 + fslpl = 99999 + fsmcl = 99999, 99999, 99999 + fsnol = 99999 + fsnos = 99999 + fsotl = 99999 + ftsfl = 99999 + ftsfs = 90 + fvetl = 99999 + fvmnl = 99999 + fvmxl = 99999 + ldebug = .true. +/ + +&namsfc_dict + fnabsc = '../fix_lam/C403.maximum_snow_albedo.tileX.nc' + fnalbc = '../fix_lam/C403.snowfree_albedo.tileX.nc' + fnalbc2 = '../fix_lam/C403.facsf.tileX.nc' + fnslpc = '../fix_lam/C403.slope_type.tileX.nc' + fnsotc = '../fix_lam/C403.soil_type.tileX.nc' + fntg3c = '../fix_lam/C403.substrate_temperature.tileX.nc' + fnvegc = '../fix_lam/C403.vegetation_greenness.tileX.nc' + fnvetc = '../fix_lam/C403.vegetation_type.tileX.nc' + fnvmnc = '../fix_lam/C403.vegetation_greenness.tileX.nc' + fnvmxc = '../fix_lam/C403.vegetation_greenness.tileX.nc' +/ + +&surf_map_nml + cd2 = -1 + cd4 = 0.12 + max_slope = 0.4 + n_del2_strong = 0 + n_del2_weak = 2 + n_del4 = 1 + peak_fac = 1.0 + zero_ocean = .false. +/ diff --git a/physics/docs/pdftxt/RE300/namelists/input.nml.v21.FV3_RRFS_v1beta b/physics/docs/pdftxt/RE300/namelists/input.nml.v21.FV3_RRFS_v1beta new file mode 100644 index 000000000..97e775107 --- /dev/null +++ b/physics/docs/pdftxt/RE300/namelists/input.nml.v21.FV3_RRFS_v1beta @@ -0,0 +1,291 @@ +&amip_interp_nml + data_set = 'reynolds_oi' + date_out_of_range = 'climo' + interp_oi_sst = .true. + no_anom_sst = .false. + use_ncep_ice = .false. + use_ncep_sst = .true. +/ + +&atmos_model_nml + blocksize = 40 + ccpp_suite = 'FV3_RRFS_v1beta' + chksum_debug = .false. + dycore_only = .false. +/ + +&cires_ugwp_nml + knob_ugwp_azdir = 2, 4, 4, 4 + knob_ugwp_doaxyz = 1 + knob_ugwp_doheat = 1 + knob_ugwp_dokdis = 1 + knob_ugwp_effac = 1, 1, 1, 1 + knob_ugwp_ndx4lh = 1 + knob_ugwp_solver = 2 + knob_ugwp_source = 1, 1, 0, 0 + knob_ugwp_stoch = 0, 0, 0, 0 + knob_ugwp_version = 0 + knob_ugwp_wvspec = 1, 25, 25, 25 + launch_level = 25 +/ + +&diag_manager_nml + prepend_date = .false. +/ + +&external_ic_nml + checker_tr = .false. + filtered_terrain = .true. + gfs_dwinds = .true. + levp = 65 + nt_checker = 0 +/ + +&fms_io_nml + checksum_required = .false. + max_files_r = 100 + max_files_w = 100 +/ + +&fms_nml + clock_grain = 'ROUTINE' + domains_stack_size = 5000000 + print_memory_usage = .false. +/ + +&fv_core_nml + a_imp = 1.0 + adjust_dry_mass = .false. + bc_update_interval = 6 + beta = 0.0 + consv_am = .false. + consv_te = 0.0 + d2_bg = 0.0 + d2_bg_k1 = 0.2 + d2_bg_k2 = 0.04 + d4_bg = 0.12 + d_con = 1.0 + d_ext = 0.0 + dddmp = 0.1 + delt_max = 0.008 + dnats = 0 + do_sat_adj = .false. + do_schmidt = .true. + do_vort_damp = .true. + dwind_2d = .false. + dz_min = 2 + external_eta = .true. + external_ic = .true. + fill = .true. + full_zs_filter = .false. + fv_debug = .false. + fv_sg_adj = 300 + gfs_phil = .false. + hord_dp = 6 + hord_mt = 6 + hord_tm = 6 + hord_tr = 10 + hord_vt = 6 + hydrostatic = .false. + io_layout = 1, 1 + k_split = 2 + ke_bg = 0.0 + kord_mt = 9 + kord_tm = -9 + kord_tr = 9 + kord_wz = 9 + layout = 5, 2 + make_nh = .true. + mountain = .false. + n_split = 5 + n_sponge = 24 + n_zs_filter = 0 + na_init = 1 + ncep_ic = .false. + nggps_ic = .true. + no_dycore = .false. + nord = 3 + npx = 220 + npy = 132 + npz = 64 + nrows_blend = 10 + ntiles = 1 + nudge_qv = .false. + nwat = 6 + p_fac = 0.1 + phys_hydrostatic = .false. + print_freq = 6 + psm_bc = 1 + range_warn = .true. + read_increment = .false. + regional = .true. + regional_bcs_from_gsi = .false. + res_latlon_dynamics = 'fv3_increment.nc' + reset_eta = .false. + rf_cutoff = 2000.0 + stretch_fac = 0.999 + target_lat = 38.5 + target_lon = -97.5 + tau = 5.0 + use_hydro_pressure = .false. + vtdm4 = 0.02 + warm_start = .false. + write_restart_with_bcs = .false. + z_tracer = .true. +/ + +&fv_grid_nml + grid_file = 'INPUT/grid_spec.nc' +/ + +&gfs_physics_nml + bl_mynn_edmf = 1 + bl_mynn_edmf_mom = 1 + bl_mynn_tkeadvect = .true. + cal_pre = .false. + cdmbgwd = 3.5, 0.25 + cnvcld = .false. + cnvgwd = .false. + cplflx = .false. + debug = .false. + do_deep = .false. + do_mynnedmf = .true. + do_mynnsfclay = .true. + do_shum = .false. + do_skeb = .false. + do_spp = .false. + do_sppt = .false. + dspheat = .true. + effr_in = .true. + fhcyc = 0 + fhlwr = 1200.0 + fhswr = 1200.0 + fhzero = 1.0 + h2o_phys = .true. + hybedmf = .false. + iaer = 111 + ialb = 1 + iau_delthrs = 6 + iau_inc_files = '' + iaufhrs = 30 + icloud_bl = 1 + ico2 = 2 + iems = 1 + imfdeepcnv = -1 + imfshalcnv = -1 + imp_physics = 8 + iopt_alb = 2 + iopt_btr = 1 + iopt_crs = 1 + iopt_dveg = 2 + iopt_frz = 1 + iopt_inf = 1 + iopt_rad = 1 + iopt_run = 1 + iopt_sfc = 1 + iopt_snf = 4 + iopt_stc = 1 + iopt_tbot = 2 + iopt_trs = 2 + isol = 2 + isot = 1 + isubc_lw = 2 + isubc_sw = 2 + ivegsrc = 1 + ldiag3d = .false. + lheatstrg = .false. + lndp_type = 0 + lradar = .true. + lsm = 2 + lsoil = 4 + lsoil_lsm = 4 + ltaerosol = .true. + lwhtr = .true. + n_var_lndp = 0 + n_var_spp = 0 + nsradar_reset = 3600 + nst_anl = .true. + nstf_name = 2, 1, 0, 0, 0 + oz_phys = .false. + oz_phys_2015 = .true. + pdfcld = .false. + pre_rad = .false. + print_diff_pgr = .false. + prslrd0 = 0.0 + random_clds = .false. + redrag = .true. + satmedmf = .false. + sfclay_compute_flux = .false. + shal_cnv = .false. + swhtr = .true. + trans_trac = .true. + ttendlim = -999 + use_ufo = .true. +/ + +&interpolator_nml + interp_method = 'conserve_great_circle' +/ + +&nam_sfcperts +/ + +&nam_sppperts +/ + +&nam_stochy +/ + +&namsfc + fabsl = 99999 + faisl = 99999 + faiss = 99999 + fnacna = '' + fnaisc = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/CFSR.SEAICE.1982.2012.monthly.clim.grb' + fnglac = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/global_glacier.2x2.grb' + fnmskh = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/seaice_newland.grb' + fnmxic = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/global_maxice.2x2.grb' + fnsmcc = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/global_soilmgldas.t126.384.190.grb' + fnsnoa = '' + fnsnoc = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/global_snoclim.1.875.grb' + fntsfa = '' + fntsfc = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/RTGSST.1982.2012.monthly.clim.grb' + fnzorc = 'igbp' + fsicl = 99999 + fsics = 99999 + fslpl = 99999 + fsmcl = 99999, 99999, 99999 + fsnol = 99999 + fsnos = 99999 + fsotl = 99999 + ftsfl = 99999 + ftsfs = 90 + fvetl = 99999 + fvmnl = 99999 + fvmxl = 99999 + ldebug = .true. +/ + +&namsfc_dict + fnabsc = '../fix_lam/C403.maximum_snow_albedo.tileX.nc' + fnalbc = '../fix_lam/C403.snowfree_albedo.tileX.nc' + fnalbc2 = '../fix_lam/C403.facsf.tileX.nc' + fnslpc = '../fix_lam/C403.slope_type.tileX.nc' + fnsotc = '../fix_lam/C403.soil_type.tileX.nc' + fntg3c = '../fix_lam/C403.substrate_temperature.tileX.nc' + fnvegc = '../fix_lam/C403.vegetation_greenness.tileX.nc' + fnvetc = '../fix_lam/C403.vegetation_type.tileX.nc' + fnvmnc = '../fix_lam/C403.vegetation_greenness.tileX.nc' + fnvmxc = '../fix_lam/C403.vegetation_greenness.tileX.nc' +/ + +&surf_map_nml + cd2 = -1 + cd4 = 0.12 + max_slope = 0.4 + n_del2_strong = 0 + n_del2_weak = 2 + n_del4 = 1 + peak_fac = 1.0 + zero_ocean = .false. +/ diff --git a/physics/docs/pdftxt/RE300/namelists/input.nml.v21.FV3_WoFS_v0 b/physics/docs/pdftxt/RE300/namelists/input.nml.v21.FV3_WoFS_v0 new file mode 100644 index 000000000..94cc34d0f --- /dev/null +++ b/physics/docs/pdftxt/RE300/namelists/input.nml.v21.FV3_WoFS_v0 @@ -0,0 +1,297 @@ +&amip_interp_nml + data_set = 'reynolds_oi' + date_out_of_range = 'climo' + interp_oi_sst = .true. + no_anom_sst = .false. + use_ncep_ice = .false. + use_ncep_sst = .true. +/ + +&atmos_model_nml + blocksize = 40 + ccpp_suite = 'FV3_WoFS_v0' + chksum_debug = .false. + dycore_only = .false. +/ + +&cires_ugwp_nml + knob_ugwp_azdir = 2, 4, 4, 4 + knob_ugwp_doaxyz = 1 + knob_ugwp_doheat = 1 + knob_ugwp_dokdis = 1 + knob_ugwp_effac = 1, 1, 1, 1 + knob_ugwp_ndx4lh = 1 + knob_ugwp_solver = 2 + knob_ugwp_source = 1, 1, 0, 0 + knob_ugwp_stoch = 0, 0, 0, 0 + knob_ugwp_version = 0 + knob_ugwp_wvspec = 1, 25, 25, 25 + launch_level = 25 +/ + +&diag_manager_nml + prepend_date = .false. +/ + +&external_ic_nml + checker_tr = .false. + filtered_terrain = .true. + gfs_dwinds = .true. + levp = 65 + nt_checker = 0 +/ + +&fms_io_nml + checksum_required = .false. + max_files_r = 100 + max_files_w = 100 +/ + +&fms_nml + clock_grain = 'ROUTINE' + domains_stack_size = 5000000 + print_memory_usage = .false. +/ + +&fv_core_nml + a_imp = 1.0 + adjust_dry_mass = .false. + bc_update_interval = 6 + beta = 0.0 + consv_am = .false. + consv_te = 0.0 + d2_bg = 0.0 + d2_bg_k1 = 0.2 + d2_bg_k2 = 0.04 + d4_bg = 0.12 + d_con = 1.0 + d_ext = 0.0 + dddmp = 0.1 + delt_max = 0.008 + dnats = 0 + do_sat_adj = .false. + do_schmidt = .true. + do_vort_damp = .true. + dwind_2d = .false. + dz_min = 2 + external_eta = .true. + external_ic = .true. + fill = .true. + full_zs_filter = .false. + fv_debug = .false. + fv_sg_adj = 300 + gfs_phil = .false. + hord_dp = 6 + hord_mt = 6 + hord_tm = 6 + hord_tr = 10 + hord_vt = 6 + hydrostatic = .false. + io_layout = 1, 1 + k_split = 2 + ke_bg = 0.0 + kord_mt = 9 + kord_tm = -9 + kord_tr = 9 + kord_wz = 9 + layout = 5, 2 + make_nh = .true. + mountain = .false. + n_split = 5 + n_sponge = 24 + n_zs_filter = 0 + na_init = 1 + ncep_ic = .false. + nggps_ic = .true. + no_dycore = .false. + nord = 3 + npx = 220 + npy = 132 + npz = 64 + nrows_blend = 10 + ntiles = 1 + nudge_qv = .false. + nwat = 7 + p_fac = 0.1 + phys_hydrostatic = .false. + print_freq = 6 + psm_bc = 1 + range_warn = .true. + read_increment = .false. + regional = .true. + regional_bcs_from_gsi = .false. + res_latlon_dynamics = 'fv3_increment.nc' + reset_eta = .false. + rf_cutoff = 2000.0 + stretch_fac = 0.999 + target_lat = 38.5 + target_lon = -97.5 + tau = 5.0 + use_hydro_pressure = .false. + vtdm4 = 0.02 + warm_start = .false. + write_restart_with_bcs = .false. + z_tracer = .true. +/ + +&fv_diagnostics_nml + do_hailcast = .true. +/ + +&fv_grid_nml + grid_file = 'INPUT/grid_spec.nc' +/ + +&gfs_physics_nml + bl_mynn_edmf = 1 + bl_mynn_edmf_mom = 1 + bl_mynn_tkeadvect = .true. + cal_pre = .false. + cdmbgwd = 3.5, 0.25 + cnvcld = .false. + cnvgwd = .false. + cplflx = .false. + debug = .false. + do_deep = .false. + do_mynnedmf = .true. + do_mynnsfclay = .true. + do_shum = .false. + do_skeb = .false. + do_spp = .false. + do_sppt = .false. + dspheat = .true. + effr_in = .true. + fhcyc = 0 + fhlwr = 1200.0 + fhswr = 1200.0 + fhzero = 1.0 + h2o_phys = .true. + hybedmf = .false. + iaer = 111 + ialb = 1 + iau_delthrs = 6 + iau_inc_files = '' + iaufhrs = 30 + icloud_bl = 1 + ico2 = 2 + iems = 1 + imfdeepcnv = -1 + imfshalcnv = -1 + imp_physics = 17 + iopt_alb = 2 + iopt_btr = 1 + iopt_crs = 1 + iopt_dveg = 2 + iopt_frz = 1 + iopt_inf = 1 + iopt_rad = 1 + iopt_run = 1 + iopt_sfc = 1 + iopt_snf = 4 + iopt_stc = 1 + iopt_tbot = 2 + isol = 2 + isot = 1 + isubc_lw = 2 + isubc_sw = 2 + ivegsrc = 1 + ldiag3d = .false. + lheatstrg = .false. + lndp_type = 0 + lradar = .true. + lsm = 1 + lsoil = 4 + lsoil_lsm = 4 + ltaerosol = .true. + lwhtr = .true. + n_var_lndp = 0 + n_var_spp = 0 + nsradar_reset = 3600 + nssl_cccn = 600000000.0 + nssl_ccn_on = .true. + nssl_hail_on = .true. + nst_anl = .true. + nstf_name = 2, 1, 0, 0, 0 + oz_phys = .false. + oz_phys_2015 = .true. + pdfcld = .false. + pre_rad = .false. + print_diff_pgr = .false. + prslrd0 = 0.0 + random_clds = .false. + redrag = .true. + satmedmf = .false. + sfclay_compute_flux = .false. + shal_cnv = .false. + swhtr = .true. + trans_trac = .true. + ttendlim = -999 + use_ufo = .true. +/ + +&interpolator_nml + interp_method = 'conserve_great_circle' +/ + +&nam_sfcperts +/ + +&nam_sppperts +/ + +&nam_stochy +/ + +&namsfc + fabsl = 99999 + faisl = 99999 + faiss = 99999 + fnacna = '' + fnaisc = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/CFSR.SEAICE.1982.2012.monthly.clim.grb' + fnglac = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/global_glacier.2x2.grb' + fnmskh = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/seaice_newland.grb' + fnmxic = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/global_maxice.2x2.grb' + fnsmcc = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/global_soilmgldas.t126.384.190.grb' + fnsnoa = '' + fnsnoc = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/global_snoclim.1.875.grb' + fntsfa = '' + fntsfc = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/RTGSST.1982.2012.monthly.clim.grb' + fnzorc = 'igbp' + fsicl = 99999 + fsics = 99999 + fslpl = 99999 + fsmcl = 99999, 99999, 99999 + fsnol = 99999 + fsnos = 99999 + fsotl = 99999 + ftsfl = 99999 + ftsfs = 90 + fvetl = 99999 + fvmnl = 99999 + fvmxl = 99999 + ldebug = .true. +/ + +&namsfc_dict + fnabsc = '../fix_lam/C403.maximum_snow_albedo.tileX.nc' + fnalbc = '../fix_lam/C403.snowfree_albedo.tileX.nc' + fnalbc2 = '../fix_lam/C403.facsf.tileX.nc' + fnslpc = '../fix_lam/C403.slope_type.tileX.nc' + fnsotc = '../fix_lam/C403.soil_type.tileX.nc' + fntg3c = '../fix_lam/C403.substrate_temperature.tileX.nc' + fnvegc = '../fix_lam/C403.vegetation_greenness.tileX.nc' + fnvetc = '../fix_lam/C403.vegetation_type.tileX.nc' + fnvmnc = '../fix_lam/C403.vegetation_greenness.tileX.nc' + fnvmxc = '../fix_lam/C403.vegetation_greenness.tileX.nc' +/ + +&surf_map_nml + cd2 = -1 + cd4 = 0.12 + max_slope = 0.4 + n_del2_strong = 0 + n_del2_weak = 2 + n_del4 = 1 + peak_fac = 1.0 + zero_ocean = .false. +/ diff --git a/physics/docs/pdftxt/RE300/suite_FV3_GFS_v16.xml b/physics/docs/pdftxt/RE300/suite_FV3_GFS_v16.xml new file mode 100644 index 000000000..122b937e1 --- /dev/null +++ b/physics/docs/pdftxt/RE300/suite_FV3_GFS_v16.xml @@ -0,0 +1,94 @@ + + + + + + + fv_sat_adj + + + + + GFS_time_vary_pre + GFS_rrtmg_setup + GFS_rad_time_vary + GFS_phys_time_vary + + + + + GFS_suite_interstitial_rad_reset + GFS_rrtmg_pre + GFS_radiation_surface + rad_sw_pre + rrtmg_sw + rrtmg_sw_post + rrtmg_lw_pre + rrtmg_lw + rrtmg_lw_post + GFS_rrtmg_post + + + + + GFS_suite_interstitial_phys_reset + GFS_suite_stateout_reset + get_prs_fv3 + GFS_suite_interstitial_1 + GFS_surface_generic_pre + GFS_surface_composites_pre + dcyc2t3 + GFS_surface_composites_inter + GFS_suite_interstitial_2 + + + + sfc_diff + GFS_surface_loop_control_part1 + sfc_nst_pre + sfc_nst + sfc_nst_post + lsm_noah + sfc_sice + GFS_surface_loop_control_part2 + + + + GFS_surface_composites_post + sfc_diag + sfc_diag_post + GFS_surface_generic_post + GFS_PBL_generic_pre + satmedmfvdifq + GFS_PBL_generic_post + GFS_GWD_generic_pre + cires_ugwp + cires_ugwp_post + GFS_GWD_generic_post + GFS_suite_stateout_update + ozphys_2015 + h2ophys + get_phi_fv3 + GFS_suite_interstitial_3 + GFS_DCNV_generic_pre + samfdeepcnv + GFS_DCNV_generic_post + GFS_SCNV_generic_pre + samfshalcnv + GFS_SCNV_generic_post + GFS_suite_interstitial_4 + cnvc90 + GFS_MP_generic_pre + gfdl_cloud_microphys + GFS_MP_generic_post + maximum_hourly_diagnostics + phys_tend + + + + + GFS_stochastics + + + + diff --git a/physics/docs/pdftxt/RE300/suite_FV3_HRRR.xml b/physics/docs/pdftxt/RE300/suite_FV3_HRRR.xml new file mode 100644 index 000000000..6ac35db14 --- /dev/null +++ b/physics/docs/pdftxt/RE300/suite_FV3_HRRR.xml @@ -0,0 +1,82 @@ + + + + + + + GFS_time_vary_pre + GFS_rrtmg_setup + GFS_rad_time_vary + GFS_phys_time_vary + + + + + GFS_suite_interstitial_rad_reset + sgscloud_radpre + GFS_rrtmg_pre + GFS_radiation_surface + rad_sw_pre + rrtmg_sw + rrtmg_sw_post + rrtmg_lw_pre + rrtmg_lw + sgscloud_radpost + rrtmg_lw_post + GFS_rrtmg_post + + + + + GFS_suite_interstitial_phys_reset + GFS_suite_stateout_reset + get_prs_fv3 + GFS_suite_interstitial_1 + GFS_surface_generic_pre + GFS_surface_composites_pre + dcyc2t3 + GFS_surface_composites_inter + GFS_suite_interstitial_2 + + + + mynnsfc_wrapper + GFS_surface_loop_control_part1 + lsm_ruc + clm_lake + GFS_surface_loop_control_part2 + + + + GFS_surface_composites_post + sfc_diag + sfc_diag_post + GFS_surface_generic_post + rrfs_smoke_wrapper + mynnedmf_wrapper + rrfs_smoke_postpbl + GFS_GWD_generic_pre + drag_suite + GFS_GWD_generic_post + GFS_suite_stateout_update + ozphys_2015 + h2ophys + get_phi_fv3 + GFS_suite_interstitial_3 + GFS_suite_interstitial_4 + GFS_MP_generic_pre + mp_thompson_pre + mp_thompson + mp_thompson_post + GFS_MP_generic_post + maximum_hourly_diagnostics + phys_tend + + + + + GFS_stochastics + + + + diff --git a/physics/docs/pdftxt/RE300/suite_FV3_RAP.xml b/physics/docs/pdftxt/RE300/suite_FV3_RAP.xml new file mode 100644 index 000000000..f03c1a1e8 --- /dev/null +++ b/physics/docs/pdftxt/RE300/suite_FV3_RAP.xml @@ -0,0 +1,90 @@ + + + + + + + GFS_time_vary_pre + GFS_rrtmg_setup + GFS_rad_time_vary + GFS_phys_time_vary + + + + + GFS_suite_interstitial_rad_reset + sgscloud_radpre + GFS_rrtmg_pre + GFS_radiation_surface + rad_sw_pre + rrtmg_sw + rrtmg_sw_post + rrtmg_lw_pre + rrtmg_lw + sgscloud_radpost + rrtmg_lw_post + GFS_rrtmg_post + + + + + GFS_suite_interstitial_phys_reset + GFS_suite_stateout_reset + get_prs_fv3 + GFS_suite_interstitial_1 + GFS_surface_generic_pre + GFS_surface_composites_pre + dcyc2t3 + GFS_surface_composites_inter + GFS_suite_interstitial_2 + + + + mynnsfc_wrapper + GFS_surface_loop_control_part1 + sfc_nst_pre + sfc_nst + sfc_nst_post + lsm_ruc + GFS_surface_loop_control_part2 + + + + GFS_surface_composites_post + sfc_diag + sfc_diag_post + GFS_surface_generic_post + mynnedmf_wrapper + GFS_GWD_generic_pre + drag_suite + GFS_GWD_generic_post + GFS_suite_stateout_update + ozphys_2015 + h2ophys + get_phi_fv3 + GFS_suite_interstitial_3 + GFS_DCNV_generic_pre + cu_gf_driver_pre + cu_gf_driver + GFS_DCNV_generic_post + GFS_SCNV_generic_pre + GFS_SCNV_generic_post + GFS_suite_interstitial_4 + cnvc90 + GFS_MP_generic_pre + mp_thompson_pre + mp_thompson + mp_thompson_post + GFS_MP_generic_post + cu_gf_driver_post + maximum_hourly_diagnostics + phys_tend + + + + + GFS_stochastics + + + + diff --git a/physics/docs/pdftxt/RE300/suite_FV3_RRFS_v1beta.xml b/physics/docs/pdftxt/RE300/suite_FV3_RRFS_v1beta.xml new file mode 100644 index 000000000..97228c0a6 --- /dev/null +++ b/physics/docs/pdftxt/RE300/suite_FV3_RRFS_v1beta.xml @@ -0,0 +1,84 @@ + + + + + + + GFS_time_vary_pre + GFS_rrtmg_setup + GFS_rad_time_vary + GFS_phys_time_vary + + + + + GFS_suite_interstitial_rad_reset + sgscloud_radpre + GFS_rrtmg_pre + GFS_radiation_surface + rad_sw_pre + rrtmg_sw + rrtmg_sw_post + rrtmg_lw_pre + rrtmg_lw + sgscloud_radpost + rrtmg_lw_post + GFS_rrtmg_post + + + + + GFS_suite_interstitial_phys_reset + GFS_suite_stateout_reset + get_prs_fv3 + GFS_suite_interstitial_1 + GFS_surface_generic_pre + GFS_surface_composites_pre + dcyc2t3 + GFS_surface_composites_inter + GFS_suite_interstitial_2 + + + + mynnsfc_wrapper + GFS_surface_loop_control_part1 + sfc_nst_pre + sfc_nst + sfc_nst_post + noahmpdrv + sfc_sice + GFS_surface_loop_control_part2 + + + + GFS_surface_composites_post + sfc_diag + sfc_diag_post + GFS_surface_generic_post + mynnedmf_wrapper + GFS_GWD_generic_pre + cires_ugwp + cires_ugwp_post + GFS_GWD_generic_post + GFS_suite_stateout_update + ozphys_2015 + h2ophys + get_phi_fv3 + GFS_suite_interstitial_3 + GFS_suite_interstitial_4 + GFS_MP_generic_pre + mp_thompson_pre + mp_thompson + mp_thompson_post + GFS_MP_generic_post + maximum_hourly_diagnostics + phys_tend + + + + + GFS_stochastics + + + + diff --git a/physics/docs/pdftxt/RE300/suite_FV3_WoFS_v0.xml b/physics/docs/pdftxt/RE300/suite_FV3_WoFS_v0.xml new file mode 100644 index 000000000..1a34ba1a1 --- /dev/null +++ b/physics/docs/pdftxt/RE300/suite_FV3_WoFS_v0.xml @@ -0,0 +1,80 @@ + + + + + + + GFS_time_vary_pre + GFS_rrtmg_setup + GFS_rad_time_vary + GFS_phys_time_vary + + + + + GFS_suite_interstitial_rad_reset + sgscloud_radpre + GFS_rrtmg_pre + GFS_radiation_surface + rad_sw_pre + rrtmg_sw + rrtmg_sw_post + rrtmg_lw_pre + rrtmg_lw + sgscloud_radpost + rrtmg_lw_post + GFS_rrtmg_post + + + + + GFS_suite_interstitial_phys_reset + GFS_suite_stateout_reset + get_prs_fv3 + GFS_suite_interstitial_1 + GFS_surface_generic_pre + GFS_surface_composites_pre + dcyc2t3 + GFS_surface_composites_inter + GFS_suite_interstitial_2 + + + + mynnsfc_wrapper + GFS_surface_loop_control_part1 + sfc_nst_pre + sfc_nst + sfc_nst_post + lsm_noah + sfc_sice + GFS_surface_loop_control_part2 + + + + GFS_surface_composites_post + sfc_diag + sfc_diag_post + GFS_surface_generic_post + mynnedmf_wrapper + GFS_GWD_generic_pre + cires_ugwp + cires_ugwp_post + GFS_GWD_generic_post + GFS_suite_stateout_update + ozphys_2015 + h2ophys + get_phi_fv3 + GFS_MP_generic_pre + mp_nssl + GFS_MP_generic_post + maximum_hourly_diagnostics + phys_tend + + + + + GFS_stochastics + + + + diff --git a/physics/docs/pdftxt/RUCLSM.txt b/physics/docs/pdftxt/RUCLSM.txt index 00b064e5f..461348aa4 100644 --- a/physics/docs/pdftxt/RUCLSM.txt +++ b/physics/docs/pdftxt/RUCLSM.txt @@ -9,11 +9,11 @@ as part of the RAP from 2012 through the present and as part of HRRR from 2014 t processes in the RUC LSM (Smirnova et al. 2016 \cite Smirnova_2016 ) have proven to be physically robust and capable of realistically representing the evolution of soil moisture, soil temperature, and snow in cycled models. Extension of the RAP domain to encompass all of North America and adjacent high-latitude ocean areas necessitated further development of the RUC LSM for application in the tundra permafrost regions and over Arctic -sea ice (Smirnova et al. 2000 \cite Smirnova_2000). Other modifications include refinements in the snow model and a more accurate specification of -albedo, roughness length, and other surface properties. These recent modifications in the RUC LSM are described and evaluated in +sea ice (Smirnova et al. 2000 \cite Smirnova_2000). Other modifications include refinements in the snow model (snow "mosaic" approach, improvements in computation of snow cover fraction and snow thermal conductivity) and a more accurate specification of +albedo, roughness length, and other surface properties. Some of these recent modifications in the RUC LSM are described and evaluated in Smirnova et al. 2016 \cite Smirnova_2016 . -The parameterizations in the RUC LSM describe complicated atmosphere–land surface interactions in an intentionally simplified fashion to avoid +The parameterizations in the RUC LSM describe complicated atmosphere–land surface interactions (Fig.1) in an intentionally simplified fashion to avoid excessive sensitivity to multiple uncertain surface parameters. Nevertheless, the RUC LSM, when coupled with the hourly-assimilating atmospheric model, demonstrated over years of ongoing cycling (Benjamin et al. 2004a,b \cite Benjamin_2004a \cite Benjamin_2004b ; Berbery et al. 1999 \cite Berbery_1999) that it can produce a realistic evolution of hydrologic and time-varying soil fields (i.e., soil moisture and temperature) that cannot be directly @@ -28,88 +28,93 @@ included in phase 2(d) of the Project for the Intercomparison of Land Surface Pr Luo et al. 2003 \cite Luo_2003 ). The RUC LSM was also tested during the Snow Models Intercomparison Project (SnowMIP, SnowMIP2, ESM-SnowMIP), with emphasis on snow parameterizations for both grassland and forest locations in different parts of the world (Etchevers et al. 2002, 2004 \cite Etchevers_2002 \cite Etchevers_2004; Essery et al. 2009 \cite Essery_2009 ; Rutter et al. 2009 \cite Rutter_2009 , -Krinner et al. 2018 \cite Krinner_2018 ). The analysis of RUC LSM performance over 10 reference sites in ESM-SnowMIP rated it on the 5th place +Krinner et al. 2018 \cite Krinner_2018 ). The analysis of RUC LSM performance over 10 reference sites in ESM-SnowMIP rated it on the 4th place among the 26 participating models. The results were published in Menard et al.(2021) \cite Menard_2021 and Essery et al. (2020) \cite essery_et_al_2020. RUC LSM received high rankings in ESM-SnowMIP experiement in terms of multi-year snow cover and surface temperature simulations -for several sites located in different parts of the world (Menard et al.2021 \cite Menard_2021). +for several sites located in different parts of the world (Fig.2, Menard et al.2021 \cite Menard_2021). -RUC LSM is used in several weather prediction models around the world (Austria, New Zealand, Switzerland, RAP/HRRR in US). Recent RUC LSM implementation in the high-resolution model in the Swiss Alps led to some small modifications and adjustments to the snow model. -These adjustments will be available in the next CCPP public release. +RUC LSM is used in several weather prediction models around the world (Austria, New Zealand, Switzerland, RAP/HRRR in US). Recent RUC LSM implementation in the 1km-resolution model over Europe revealed some issues in the snow-covered high terrain (Swiss Alps), and this led to some small modifications and adjustments to the snow model. +These adjustments are available in the current CCPP public release. - -Coupling of the RUC LSM to physically-based stochastic snow model (He et al.(2021) \cite he_et_al_2021) will be implemented in the next public release. +Coupling of the RUC LSM to physically-based stochastic snow model (He et al.(2021) \cite he_et_al_2021) is also available in the current public release. The sensitivity of surface fluxes and turbine-height winds to the RUC LSM parameters has been explored by Geng Xia, NREL. This study will determine the uncertainty range for the selected parameters in the RUC LSM and will be described in the journal paper. ## RUC LSM characteristics that differ from NOAH LSM: -\image html ruc_lsm_veg_soil.png "Figure 1. RUC LSM Vegetation and Soil Model (Courtesy of T.G. Smirnova) " width=900 +\image html ruc_lsm_veg_soil.png "Figure 1: RUC LSM Vegetation and Soil Model (Courtesy of T.G. Smirnova) " width=900 +\image html ruc_ranking.png "Figure 2: Model ranking as a function of normalized root mean square error of snow water equivalent and surface temperature (Courtesy of C. Menard)" width=900 - \b Implicit \b solution of energy and moisture budgets in the layer spanning the ground surface - \b 9 \b soil \b levels with high vertical resolution near surface -RUC LSM has more levels in oil than \ref GFS_NOAH model with higher resolution near the interface with the atmosphere +RUC LSM has more levels in soil than \ref GFS_NOAH model with higher resolution near the interface with the atmosphere - \b Prognostic \b soil moisture variable (\f$\theta-\theta_r\f$) The prognostic variables for soil moisture is volumetric soil moisture content minus residual value of soil moisture which is tied to soil particles and does not participate in moisture transport. - \b Frozen \b soil \b physics algorithm RUC LSM has a different approach to take into account freezing and thawing processes in soil. -- Treatment of \b mixed \b phase \b precipitation -It accounts for mixed phase precipitation provided by \ref THOMPSON used in RAP and HRRR. -- Simple treatment of \b sea \c ice which solves heat diffusion in sea ice and allows evolving snow cover on top of sea ice -- sub-grid-scale \b heterogeneity of surface parameters in RUC LSM +- Treatment of \b mixed \b phase \b precipitation accounts for mixed phase precipitation provided by \ref THOMPSON used in RAP and HRRR. +- Simple treatment of \b sea \b ice which solves heat diffusion in sea ice and allows evolving snow cover on top of sea ice +- Sub-grid-scale \b heterogeneity of surface parameters in RUC LSM (Fig.3). With the certain level of confidence in the skill of the model, the next requirement is to provide land static fields and surface -parameters with the best possible accuracy. RAP and HRRR use the same datasets as \ref GFS_NOAH. But instead of specifying surface -parameters for the dominant soil and land-use category in the grid box, RUC LSM takes into account the sub-grid scale heterogeneity +parameters with the best possible accuracy. RAP and HRRR use the same soil/vegetation calssifications as \ref GFS_NOAH. But in addition to +specifying surface +parameters for the dominant soil and land-use category in the grid box, RUC LSM has an option to take into account the sub-grid scale heterogeneity in the computation of such parameters as roughness length, emissivity, soil porosity, soil heat capacity and others. The difference in -roughness between the mosaic and dominant category presented on figure 2 is positive from contribution of the forests, which helped to -reduce high biases of surface wind speeds in these regions. Roughness lenghth has also seasonal variability in the cropland regions, -which again helped to improve the wind forecasts during the warm season. -\image html ruc_lsm_heterogeneity.png "Figure 2: sub-grid scale heterogeneity of surface parameters in RUC LSM (Courtesy of T.G. Smirnova)" width=900 +roughness between the mosaic and dominant category presented on Figure 3, is positive from contribution of the forests, which helped to +reduce high biases of surface wind speeds in these regions. In the cropland regions, roughness lenghth has also a seasonal variability depending on the growing phase of the plants. This again helped to improve the wind forecasts during the warm season. +Turning on sub-grid-scale heterogeneity option requries: \p mosaic_lu = 1 and \p mosaic_soil = 1 in the namelist, and fractions of soil and vegetation types in a grid cell. +\image html ruc_lsm_heterogeneity.png "Figure 3: sub-grid scale heterogeneity of surface parameters in RUC LSM (Courtesy of T.G. Smirnova)" width=900 -- New: simple irrigation in the cropland area +- New: simple irrigation in the cropland area with \p mosaic_lu = 1 - New: water/snow intercepted by canopy as function of vegetation fraction and leaf area index (LAI) ## RUC snow model characteristics: Snow forms additional two layers on top of soil in RUC LSM -- \b 2-layer \b snow model: when SWE < 1.6 cm - snow layer is combined with top soil layer -- Fractional snow cover (SWE < 3 cm): -- weighted average of snow-covered and snow-free areas to compute snow paramters (roughness, albedo) -- New: "mosaic" approach for patchy snow - - Seperate treatment of energy and moisture budgets for snow-covered and snow-free portions of the grid cell +- \b 2-layer \b snow model: when SWE < 1.6 cm - snow layer is combined with top soil layer; +- Fractional snow cover (SWE < 3 cm); +- Weighted average of snow-covered and snow-free areas to compute snow parameters (roughness, albedo); +- "Mosaic" approach for patchy snow (Fig.4): + - Separate treatment of energy and moisture budgets for snow-covered and snow-free portions of the grid cell - Aggregate solutions at the end of time step - - Reduced cold bias for areas with thin snow -\image html ruc_lsm_mosaic.png "Figure 3: recent development: mosaic approach for patchy snow (Courtesy of T.G. Smirnova) " width=900 -- Iterative snow melting algorithm -- Density of snow on the ground - a function of compaction parameter and snow depth and temperature -- Snow albedo - a function of temperature and snow fraction -- Snow interception by canopy - a function of vegetation fraction and LAI -- Density of falling snow/graupel/ice precipitation + - Outcome: reduced cold bias for areas with thin snow +\image html ruc_lsm_mosaic.png "Figure 4: 'Mosaic' approach for patchy snow (Courtesy of T.G. Smirnova) " width=900 + - New: additional options to compute snow cover fraction (\p isncovr_opt =2 and 3, Niu and Yang (2007) \cite Niu_2007). These options allowed to reduce overprediction of number of grid cells fully covered with snow which further reduced cold-biases over snow. Figure 5 demonstrates that option 3 of snow cover fraction computation (\p isncovr_opt = 3) in the UFS-based regional model matches better the satellite data for the test case on 6 February 2022. +- New: added an option to use of a new formulation of snow thermal conductivity (\p isncond_opt = 2, Sturm et al. (1997) \cite sturm_1997); +\image html sncov_rrfs_ruc.png "Figure 5: Snow cover fraction from MODIS (a,b), Regional UFS-based system (RRFS) original (c), and modified with isncover_opt=3 (d), 6 February 2022. (Courtesy of T.G. Smirnova)" width=900 +- Iterative snow melting algorithm; +- Density of snow on the ground - a function of compaction parameter and snow depth and temperature; +- Snow albedo - a function of temperature and snow fraction; +- Snow interception by canopy - a function of vegetation fraction and leaf area index (LAI); +- Density of falling snow/graupel/ice precipitation (Fig.6) - The density of falling snow/graupel/ice is computed inside RUC LSM using empirical temperature-dependent equations; - Averaged density of frozen precipitation is defined from weighted contribution of each hydrometeor species: \f[ \rho_{fr}=\rho_{sn}*\alpha_{sn}+\rho_{gr}*\alpha_{gr}+\rho_{ice}*\alpha_{ice} + \f] +Where subscripts sn, gr, ice - snow, graupel and ice precipitation, respectively. - The depth of new snow is defined from its liquid equivalent and \f$\rho_{fr}\f$ -\image html ruc_lsm_frozen_precip.png "Figure 4: HRRR 23-h forecasts of snow accumulation, valid 08 UTC, 29 Dec 2015 (Courtesy of T.G. Smirnova)" width=900 +\image html ruc_lsm_frozen_precip.png "Figure 6: HRRR 23-h forecasts of snow accumulation, valid 08 UTC, 29 Dec 2015 (Courtesy of T.G. Smirnova)" width=900 -snow accumulation with variable density is provided as an additional product in the model guidance. Figure 4 shows one example of this product +Snow accumulation with variable density is provided as an additional product in the model guidance. Figure 6 shows one example of this product from the 23-h HRRR forecast for snowstorm on 29 Dec 2015. This product is in the middle panel. The panel on the left uses traditional 10:1 ratio, -and the right panel is oberved snow accumulation. We can see that the new product in the middle here has a better, further north location of maximum -snow accumulation, and high ammounts of snow in the product with 10:1 ratio are trimmed in central and southern Iowa where both observed and model +and the right panel is observed snow accumulation. We can see that the new product in the middle here has a better, further north location of maximum +snow accumulation, and high amounts of snow in the product with 10:1 ratio are trimmed in central and southern Iowa where both observed and model precipitation had a high content of sleet. There is even larger improvement in the Chicago area, where observed and model precipitation were almost totally sleet. \section v6_updates_ruc Physics Updates -\version CCPP V6.0.0 +\version UFS-SRW v3.0.0 - Initialization of land and ice emissivity with consideration of partial snow cover - Initialization of land and ice albedo with consideration of partial snow cover - Initialization of water vapor mixing ratio over land and ice +- Initialization of fractions of soil and vegetation types in a grid cell - Changes in the computation of a flag for sea ice: it is set to true only if \p flag_cice = .false. (uncoupled sea ice model) - Introduced separate variables for sea ice, for example: \p showfallac is replaced with \p snowfallac_ice -- Added accomodation of fractional surface grid (land and ice fractions are possible within the grid cell) -- Introduced solar angle dependence of albedo for snow-free land -- Introduced a SPP option for stochastic perturbations for emissivity, albedo and vegetation fraction -- Bug fix in hydraulic conductivity +- Added accommodation of fractional surface grid (land and ice fractions are possible within the grid cell) +- Solar angle dependence of albedo for snow-free land +- SPP option for stochastic perturbations for emissivity, albedo and vegetation fraction - Based on RRFS testing, the coefficient in the soil resistance formulation (Sakaguchi and Zeng (2009) \cite sakaguchi_and_zeng_2009) -was increased from 0.5 to 0.7 to increase soil resistance to evaporation +was increased from 0.7 to 1.0 to increase soil resistance to evaporation \section intra_ruclsm Intraphysics Communication diff --git a/physics/docs/pdftxt/SRW_all_shemes_list.txt b/physics/docs/pdftxt/SRW_all_shemes_list.txt index bb320008e..db9683579 100644 --- a/physics/docs/pdftxt/SRW_all_shemes_list.txt +++ b/physics/docs/pdftxt/SRW_all_shemes_list.txt @@ -46,6 +46,9 @@ The UFS-SRW App. assembles the parameterizations in suites. - \subpage GFS_OCEAN - \subpage GFS_SFCSICE +\b CLM \b Lake \b Model + - \subpage CLM_LAKE_model + \b Others - \subpage GFS_SPP diff --git a/physics/docs/pdftxt/SRW_mainpage.txt b/physics/docs/pdftxt/SRW_mainpage.txt index 154b1b0eb..59b551d55 100644 --- a/physics/docs/pdftxt/SRW_mainpage.txt +++ b/physics/docs/pdftxt/SRW_mainpage.txt @@ -1,15 +1,16 @@ /** \mainpage Introduction -Welcome to the scientific documentation for the physical parameterizations available in the Unified Forecast System (UFS) Short-Range Weather (SRW) Application version 2.1.0 (available through https://github.com/ufs-community/ufs-srweather-app/) and the suites that can be configured using them. The SRW app targets predictions of atmospheric behavior on a +Welcome to the scientific documentation for the physical parameterizations available in the Unified Forecast System (UFS) Short-Range Weather (SRW) Application version 3.0 (available through https://github.com/ufs-community/ufs-srweather-app/) and the suites that can be configured using them. The SRW app targets predictions of atmospheric behavior on a limited spatial domain and on time scales from less than an hour out to several days. -The CCPP parameterizations are aggregated in suites by the host models. In this release, the UFS Short-Range Weather Application 2.1.0 +The CCPP parameterizations are aggregated in suites by the host models. In this release, the UFS Short-Range Weather Application 3.0 supports suites: - \ref GFS_v16_page - \ref HRRR_suite_page - \ref RRFS_v1beta_page - \ref WoFS_v0_page +- \ref rap_suite_page */ diff --git a/physics/docs/pdftxt/THOMPSON.txt b/physics/docs/pdftxt/THOMPSON.txt index 60a873de9..fed003ebd 100644 --- a/physics/docs/pdftxt/THOMPSON.txt +++ b/physics/docs/pdftxt/THOMPSON.txt @@ -84,6 +84,15 @@ increases numerical stability by applying the subtime step only to sedimentation Two namelist variables control the usage of the semi-Lagrangian sedimentation, \p sedi_semi and \p decfl. \p sedi_semi is set to ‘true’ to activate the method. Decfl is a parameter that needs to avoid deformation of the arriving grids, currently, "10". +\version SRW v3.0.0 + +- The ice generation supersaturation requirement for nonaerosol option is reduced from 0.25 to 0.15. The purpose is to generate more ice in +the upper level and reduce the OLR bias. + +- For the non-aerosol option of the scheme, the cloud number concentration is divided into two parts (over land and others). The number +concentration over the ocean is reduced to a smaller numer (50/L) from its default (100/L). The purpose is to reduce the bias in surface +downward shortwave radiative flux off the coastal regional including the Southeast Pacific. + \section intra_thompson Intraphysics Communication - \ref arg_table_mp_thompson_run From 7ec1eb82fc1f3caccb37e52102840efdfa52c814 Mon Sep 17 00:00:00 2001 From: Man Zhang Date: Fri, 9 Jun 2023 11:32:06 -0600 Subject: [PATCH 297/380] Some format and file size adjustments --- physics/docs/pdftxt/HRRR_suite.txt | 1 + physics/docs/pdftxt/RAP_suite.txt | 4 +- .../docs/pdftxt/RE300/FV3_GFS_v16_input.nml | 152 +++++++-------- physics/docs/pdftxt/RE300/FV3_HRRR_input.nml | 164 ++++++++-------- physics/docs/pdftxt/RE300/FV3_RAP_input.nml | 174 ++++++++--------- .../pdftxt/RE300/FV3_RRFS_v1beta_input.nml | 172 ++++++++--------- .../docs/pdftxt/RE300/FV3_WoFS_v0_input.nml | 176 +++++++++--------- physics/docs/pdftxt/SRW_all_shemes_list.txt | 30 ++- physics/docs/pdftxt/SRW_mainpage.txt | 4 +- 9 files changed, 444 insertions(+), 433 deletions(-) diff --git a/physics/docs/pdftxt/HRRR_suite.txt b/physics/docs/pdftxt/HRRR_suite.txt index d8b529ada..33a1eb0b8 100644 --- a/physics/docs/pdftxt/HRRR_suite.txt +++ b/physics/docs/pdftxt/HRRR_suite.txt @@ -17,6 +17,7 @@ The HRRR suite uses the parameterizations in the following order: - \ref SFC_MYNNSFL - \ref GFS_NSST - \ref RUCLSM + - \ref CLM_LAKE_model - \ref MYNNEDMF - \ref GFS_drag_suite - \ref GFS_OZPHYS diff --git a/physics/docs/pdftxt/RAP_suite.txt b/physics/docs/pdftxt/RAP_suite.txt index 425bf40ff..0371050b0 100644 --- a/physics/docs/pdftxt/RAP_suite.txt +++ b/physics/docs/pdftxt/RAP_suite.txt @@ -23,9 +23,9 @@ The RAP suite uses the parameterizations in the following order: - \ref THOMPSON \section sdf_gsdsuite Suite Definition File -\include suite_SCM_RAP.xml +\include suite_FV3_RAP.xml \section RAP_nml_option Namelist -\snippet SCM_RAP_input.nml GFS_PHYSICS_NML +\snippet FV3_RAP_input.nml GFS_PHYSICS_NML */ diff --git a/physics/docs/pdftxt/RE300/FV3_GFS_v16_input.nml b/physics/docs/pdftxt/RE300/FV3_GFS_v16_input.nml index 23ca37f9c..6fd84ec22 100644 --- a/physics/docs/pdftxt/RE300/FV3_GFS_v16_input.nml +++ b/physics/docs/pdftxt/RE300/FV3_GFS_v16_input.nml @@ -179,93 +179,93 @@ rthresh = 1e-05 sedi_transport = .true. tau_g2v = 900.0 - tau_i2s = 1000.0 - tau_l2v = 225.0 - tau_v2l = 150.0 - use_ccn = .true. - use_ppm = .false. - vg_max = 12.0 - vi_max = 1.0 - vr_max = 12.0 - vs_max = 2.0 - z_slope_ice = .true. - z_slope_liq = .true. + tau_i2s = 1000.0 + tau_l2v = 225.0 + tau_v2l = 150.0 + use_ccn = .true. + use_ppm = .false. + vg_max = 12.0 + vi_max = 1.0 + vr_max = 12.0 + vs_max = 2.0 + z_slope_ice = .true. + z_slope_liq = .true. / !! [GFDL_CLOUD_MP_NML] !>[GFS_PHYSICS_NML] &gfs_physics_nml - cal_pre = .false. - cdmbgwd = 4.0, 0.15, 1.0, 1.0 - cnvcld = .true. - cnvgwd = .true. - debug = .false. - do_tofd = .true. - do_ugwp = .false. - dspheat = .true. - effr_in = .true. - fhcyc = 0.0 - fhlwr = 3600.0 - fhswr = 3600.0 - fhzero = 1.0 - h2o_phys = .true. - hybedmf = .false. - iaer = 5111 - ialb = 1 + cal_pre = .false. + cdmbgwd = 4.0, 0.15, 1.0, 1.0 + cnvcld = .true. + cnvgwd = .true. + debug = .false. + do_tofd = .true. + do_ugwp = .false. + dspheat = .true. + effr_in = .true. + fhcyc = 0.0 + fhlwr = 3600.0 + fhswr = 3600.0 + fhzero = 1.0 + h2o_phys = .true. + hybedmf = .false. + iaer = 5111 + ialb = 1 iau_inc_files = '' - icliq_sw = 2 - ico2 = 2 - iems = 1 - imfdeepcnv = 2 - imfshalcnv = 2 - imp_physics = 11 - iopt_alb = 2 - iopt_btr = 1 - iopt_crs = 1 - iopt_dveg = 1 - iopt_frz = 1 - iopt_inf = 1 - iopt_rad = 1 - iopt_run = 1 - iopt_sfc = 1 - iopt_snf = 4 - iopt_stc = 1 - iopt_tbot = 2 - iopt_trs = 2 - iovr = 3 - isatmedmf = 1 - isol = 2 - isot = 1 - isubc_lw = 2 - isubc_sw = 2 - ivegsrc = 1 - ldiag3d = .false. - ldiag_ugwp = .false. - lgfdlmprad = .true. - lheatstrg = .true. - lsm = 1 - lsoil = 4 - lwhtr = .true. + icliq_sw = 2 + ico2 = 2 + iems = 1 + imfdeepcnv = 2 + imfshalcnv = 2 + imp_physics = 11 + iopt_alb = 2 + iopt_btr = 1 + iopt_crs = 1 + iopt_dveg = 1 + iopt_frz = 1 + iopt_inf = 1 + iopt_rad = 1 + iopt_run = 1 + iopt_sfc = 1 + iopt_snf = 4 + iopt_stc = 1 + iopt_tbot = 2 + iopt_trs = 2 + iovr = 3 + isatmedmf = 1 + isol = 2 + isot = 1 + isubc_lw = 2 + isubc_sw = 2 + ivegsrc = 1 + ldiag3d = .false. + ldiag_ugwp = .false. + lgfdlmprad = .true. + lheatstrg = .true. + lsm = 1 + lsoil = 4 + lwhtr = .true. nsfullradar_diag = 3600 - nst_anl = .true. - nstf_name = 2, 1, 0, 0, 0 - oz_phys = .false. + nst_anl = .true. + nstf_name = 2, 1, 0, 0, 0 + oz_phys = .false. oz_phys_2015 = .true. - pdfcld = .false. - prautco = 0.00015, 0.00015 - pre_rad = .false. + pdfcld = .false. + prautco = 0.00015, 0.00015 + pre_rad = .false. print_diff_pgr = .false. - prslrd0 = 0.0 - psautco = 0.0008, 0.0005 - random_clds = .false. - redrag = .true. - satmedmf = .true. + prslrd0 = 0.0 + psautco = 0.0008, 0.0005 + random_clds = .false. + redrag = .true. + satmedmf = .true. sfclay_compute_flux = .false. - shal_cnv = .true. - swhtr = .true. - trans_trac = .true. - use_ufo = .true. + shal_cnv = .true. + swhtr = .true. + trans_trac = .true. + use_ufo = .true. / !! [GFS_PHYSICS_NML] diff --git a/physics/docs/pdftxt/RE300/FV3_HRRR_input.nml b/physics/docs/pdftxt/RE300/FV3_HRRR_input.nml index 8a7d621f3..9a89b9a1f 100644 --- a/physics/docs/pdftxt/RE300/FV3_HRRR_input.nml +++ b/physics/docs/pdftxt/RE300/FV3_HRRR_input.nml @@ -140,90 +140,92 @@ grid_file = 'INPUT/grid_spec.nc' / +!>[GFS_PHYSICS_NML] &gfs_physics_nml - bl_mynn_edmf = 1 - bl_mynn_edmf_mom = 1 - bl_mynn_tkeadvect = .true. - cal_pre = .false. - cdmbgwd = 3.5, 1.0 - cnvcld = .false. - cnvgwd = .false. - cplflx = .false. - debug = .false. - do_deep = .false. - do_gsl_drag_ls_bl = .true. - do_gsl_drag_ss = .true. - do_gsl_drag_tofd = .true. - do_mynnedmf = .true. - do_mynnsfclay = .true. - dspheat = .true. - effr_in = .true. - fhcyc = 0.0 - fhlwr = 1200.0 - fhswr = 1200.0 - fhzero = 1.0 - gwd_opt = 3 - h2o_phys = .true. - hybedmf = .false. - iaer = 5111 - ialb = 1 - iau_delthrs = 6 - iau_inc_files = '' - iaufhrs = 30 - icliq_sw = 2 - icloud_bl = 1 - ico2 = 2 - iems = 1 - imfdeepcnv = -1 - imfshalcnv = -1 - imp_physics = 8 - iopt_alb = 2 - iopt_btr = 1 - iopt_crs = 1 - iopt_dveg = 2 - iopt_frz = 1 - iopt_inf = 1 - iopt_rad = 1 - iopt_run = 1 - iopt_sfc = 1 - iopt_snf = 4 - iopt_stc = 1 - iopt_tbot = 2 - iopt_trs = 2 - iovr = 3 - isol = 2 - isot = 1 - isubc_lw = 2 - isubc_sw = 2 - ivegsrc = 1 - kice = 9 - ldiag3d = .false. - lheatstrg = .false. - lradar = .true. - lsm = 3 - lsoil = 4 - lsoil_lsm = 9 - ltaerosol = .true. - lwhtr = .true. - nsfullradar_diag = 3600 - nst_anl = .true. - nstf_name = 2, 1, 0, 0, 0 - oz_phys = .false. - oz_phys_2015 = .true. - pdfcld = .false. - pre_rad = .false. - print_diff_pgr = .false. - prslrd0 = 0.0 - random_clds = .false. - redrag = .true. - satmedmf = .false. + bl_mynn_edmf = 1 + bl_mynn_edmf_mom = 1 + bl_mynn_tkeadvect = .true. + cal_pre = .false. + cdmbgwd = 3.5, 1.0 + cnvcld = .false. + cnvgwd = .false. + cplflx = .false. + debug = .false. + do_deep = .false. + do_gsl_drag_ls_bl = .true. + do_gsl_drag_ss = .true. + do_gsl_drag_tofd = .true. + do_mynnedmf = .true. + do_mynnsfclay = .true. + dspheat = .true. + effr_in = .true. + fhcyc = 0.0 + fhlwr = 1200.0 + fhswr = 1200.0 + fhzero = 1.0 + gwd_opt = 3 + h2o_phys = .true. + hybedmf = .false. + iaer = 5111 + ialb = 1 + iau_delthrs = 6 + iau_inc_files = '' + iaufhrs = 30 + icliq_sw = 2 + icloud_bl = 1 + ico2 = 2 + iems = 1 + imfdeepcnv = -1 + imfshalcnv = -1 + imp_physics = 8 + iopt_alb = 2 + iopt_btr = 1 + iopt_crs = 1 + iopt_dveg = 2 + iopt_frz = 1 + iopt_inf = 1 + iopt_rad = 1 + iopt_run = 1 + iopt_sfc = 1 + iopt_snf = 4 + iopt_stc = 1 + iopt_tbot = 2 + iopt_trs = 2 + iovr = 3 + isol = 2 + isot = 1 + isubc_lw = 2 + isubc_sw = 2 + ivegsrc = 1 + kice = 9 + ldiag3d = .false. + lheatstrg = .false. + lradar = .true. + lsm = 3 + lsoil = 4 + lsoil_lsm = 9 + ltaerosol = .true. + lwhtr = .true. + nsfullradar_diag = 3600 + nst_anl = .true. + nstf_name = 2, 1, 0, 0, 0 + oz_phys = .false. + oz_phys_2015 = .true. + pdfcld = .false. + pre_rad = .false. + print_diff_pgr = .false. + prslrd0 = 0.0 + random_clds = .false. + redrag = .true. + satmedmf = .false. sfclay_compute_flux = .true. - shal_cnv = .false. - swhtr = .true. - trans_trac = .true. - ttendlim = -999 - use_ufo = .true. + shal_cnv = .false. + swhtr = .true. + trans_trac = .true. + ttendlim = -999 + use_ufo = .true. / +!![GFS_PHYSICS_NML] &interpolator_nml interp_method = 'conserve_great_circle' diff --git a/physics/docs/pdftxt/RE300/FV3_RAP_input.nml b/physics/docs/pdftxt/RE300/FV3_RAP_input.nml index ef3f44fc5..aa80cac21 100644 --- a/physics/docs/pdftxt/RE300/FV3_RAP_input.nml +++ b/physics/docs/pdftxt/RE300/FV3_RAP_input.nml @@ -140,97 +140,99 @@ grid_file = 'INPUT/grid_spec.nc' / +!>[GFS_PHYSICS_NML] &gfs_physics_nml - bl_mynn_edmf = 1 - bl_mynn_edmf_mom = 1 + bl_mynn_edmf = 1 + bl_mynn_edmf_mom = 1 bl_mynn_tkeadvect = .true. - cal_pre = .false. - cdmbgwd = 3.5, 1.0 - cnvcld = .false. - cnvgwd = .false. - cplflx = .false. - debug = .false. - do_deep = .true. + cal_pre = .false. + cdmbgwd = 3.5, 1.0 + cnvcld = .false. + cnvgwd = .false. + cplflx = .false. + debug = .false. + do_deep = .true. do_gsl_drag_ls_bl = .true. - do_gsl_drag_ss = .true. - do_gsl_drag_tofd = .true. - do_mynnedmf = .true. - do_mynnsfclay = .true. - do_shum = .false. - do_skeb = .false. - do_spp = .false. - do_sppt = .false. - dspheat = .true. - effr_in = .true. - fhcyc = 0 - fhlwr = 1200.0 - fhswr = 1200.0 - fhzero = 1.0 - gwd_opt = 3 - h2o_phys = .true. - hybedmf = .false. - iaer = 5111 - ialb = 1 - iau_delthrs = 6 - iau_inc_files = '' - iaufhrs = 30 - icliq_sw = 2 - icloud_bl = 1 - ico2 = 2 - iems = 1 - imfdeepcnv = 3 - imfshalcnv = 3 - imp_physics = 8 - iopt_alb = 2 - iopt_btr = 1 - iopt_crs = 1 - iopt_dveg = 2 - iopt_frz = 1 - iopt_inf = 1 - iopt_rad = 1 - iopt_run = 1 - iopt_sfc = 1 - iopt_snf = 4 - iopt_stc = 1 - iopt_tbot = 2 - iopt_trs = 2 - iovr = 3 - isol = 2 - isot = 1 - isubc_lw = 2 - isubc_sw = 2 - ivegsrc = 1 - kice = 9 - ldiag3d = .false. - lheatstrg = .false. - lndp_type = 0 - lradar = .true. - lsm = 3 - lsoil = 4 - lsoil_lsm = 9 - ltaerosol = .true. - lwhtr = .true. - n_var_lndp = 0 - n_var_spp = 0 - nsfullradar_diag = 3600 - nst_anl = .true. - nstf_name = 2, 1, 0, 0, 0 - oz_phys = .false. - oz_phys_2015 = .true. - pdfcld = .false. - pre_rad = .false. - print_diff_pgr = .false. - prslrd0 = 0.0 - random_clds = .false. - redrag = .true. - satmedmf = .false. + do_gsl_drag_ss = .true. + do_gsl_drag_tofd = .true. + do_mynnedmf = .true. + do_mynnsfclay = .true. + do_shum = .false. + do_skeb = .false. + do_spp = .false. + do_sppt = .false. + dspheat = .true. + effr_in = .true. + fhcyc = 0 + fhlwr = 1200.0 + fhswr = 1200.0 + fhzero = 1.0 + gwd_opt = 3 + h2o_phys = .true. + hybedmf = .false. + iaer = 5111 + ialb = 1 + iau_delthrs = 6 + iau_inc_files = '' + iaufhrs = 30 + icliq_sw = 2 + icloud_bl = 1 + ico2 = 2 + iems = 1 + imfdeepcnv = 3 + imfshalcnv = 3 + imp_physics = 8 + iopt_alb = 2 + iopt_btr = 1 + iopt_crs = 1 + iopt_dveg = 2 + iopt_frz = 1 + iopt_inf = 1 + iopt_rad = 1 + iopt_run = 1 + iopt_sfc = 1 + iopt_snf = 4 + iopt_stc = 1 + iopt_tbot = 2 + iopt_trs = 2 + iovr = 3 + isol = 2 + isot = 1 + isubc_lw = 2 + isubc_sw = 2 + ivegsrc = 1 + kice = 9 + ldiag3d = .false. + lheatstrg = .false. + lndp_type = 0 + lradar = .true. + lsm = 3 + lsoil = 4 + lsoil_lsm = 9 + ltaerosol = .true. + lwhtr = .true. + n_var_lndp = 0 + n_var_spp = 0 + nsfullradar_diag = 3600 + nst_anl = .true. + nstf_name = 2, 1, 0, 0, 0 + oz_phys = .false. + oz_phys_2015 = .true. + pdfcld = .false. + pre_rad = .false. + print_diff_pgr = .false. + prslrd0 = 0.0 + random_clds = .false. + redrag = .true. + satmedmf = .false. sfclay_compute_flux = .false. - shal_cnv = .true. - swhtr = .true. - trans_trac = .true. - ttendlim = -999 - use_ufo = .true. + shal_cnv = .true. + swhtr = .true. + trans_trac = .true. + ttendlim = -999 + use_ufo = .true. / +!![GFS_PHYSICS_NML] &interpolator_nml interp_method = 'conserve_great_circle' diff --git a/physics/docs/pdftxt/RE300/FV3_RRFS_v1beta_input.nml b/physics/docs/pdftxt/RE300/FV3_RRFS_v1beta_input.nml index 97a0f1216..aff1b47a5 100644 --- a/physics/docs/pdftxt/RE300/FV3_RRFS_v1beta_input.nml +++ b/physics/docs/pdftxt/RE300/FV3_RRFS_v1beta_input.nml @@ -14,20 +14,22 @@ dycore_only = .false. / +!>[CIRES_UGWP_NML] &cires_ugwp_nml - knob_ugwp_azdir = 2, 4, 4, 4 - knob_ugwp_doaxyz = 1 - knob_ugwp_doheat = 1 - knob_ugwp_dokdis = 1 - knob_ugwp_effac = 1, 1, 1, 1 - knob_ugwp_ndx4lh = 1 - knob_ugwp_solver = 2 - knob_ugwp_source = 1, 1, 0, 0 - knob_ugwp_stoch = 0, 0, 0, 0 + knob_ugwp_azdir = 2, 4, 4, 4 + knob_ugwp_doaxyz = 1 + knob_ugwp_doheat = 1 + knob_ugwp_dokdis = 1 + knob_ugwp_effac = 1, 1, 1, 1 + knob_ugwp_ndx4lh = 1 + knob_ugwp_solver = 2 + knob_ugwp_source = 1, 1, 0, 0 + knob_ugwp_stoch = 0, 0, 0, 0 knob_ugwp_version = 0 - knob_ugwp_wvspec = 1, 25, 25, 25 - launch_level = 25 + knob_ugwp_wvspec = 1, 25, 25, 25 + launch_level = 25 / +!![CIRES_UGWP_NML] &diag_manager_nml max_output_fields = 450 @@ -139,83 +141,85 @@ grid_file = 'INPUT/grid_spec.nc' / +!>[GFS_PHYSICS_NML] &gfs_physics_nml - bl_mynn_edmf = 1 - bl_mynn_edmf_mom = 1 + bl_mynn_edmf = 1 + bl_mynn_edmf_mom = 1 bl_mynn_tkeadvect = .true. - cal_pre = .false. - cdmbgwd = 3.5, 0.25 - cnvcld = .false. - cnvgwd = .false. - cplflx = .false. - debug = .false. - do_deep = .false. - do_mynnedmf = .true. - do_mynnsfclay = .true. - dspheat = .true. - effr_in = .true. - fhcyc = 0.0 - fhlwr = 1200.0 - fhswr = 1200.0 - fhzero = 1.0 - h2o_phys = .true. - hybedmf = .false. - iaer = 111 - ialb = 1 - iau_delthrs = 6 - iau_inc_files = '' - iaufhrs = 30 - icloud_bl = 1 - ico2 = 2 - iems = 1 - imfdeepcnv = -1 - imfshalcnv = -1 - imp_physics = 8 - iopt_alb = 2 - iopt_btr = 1 - iopt_crs = 1 - iopt_dveg = 2 - iopt_frz = 1 - iopt_inf = 1 - iopt_rad = 1 - iopt_run = 1 - iopt_sfc = 1 - iopt_snf = 4 - iopt_stc = 1 - iopt_tbot = 2 - iopt_trs = 2 - isol = 2 - isot = 1 - isubc_lw = 2 - isubc_sw = 2 - ivegsrc = 1 - ldiag3d = .false. - lheatstrg = .false. - lradar = .true. - lsm = 2 - lsoil = 4 - lsoil_lsm = 4 - ltaerosol = .true. - lwhtr = .true. - nsfullradar_diag = 3600 - nst_anl = .true. - nstf_name = 2, 1, 0, 0, 0 - oz_phys = .false. - oz_phys_2015 = .true. - pdfcld = .false. - pre_rad = .false. - print_diff_pgr = .false. - prslrd0 = 0.0 - random_clds = .false. - redrag = .true. - satmedmf = .false. + cal_pre = .false. + cdmbgwd = 3.5, 0.25 + cnvcld = .false. + cnvgwd = .false. + cplflx = .false. + debug = .false. + do_deep = .false. + do_mynnedmf = .true. + do_mynnsfclay = .true. + dspheat = .true. + effr_in = .true. + fhcyc = 0.0 + fhlwr = 1200.0 + fhswr = 1200.0 + fhzero = 1.0 + h2o_phys = .true. + hybedmf = .false. + iaer = 111 + ialb = 1 + iau_delthrs = 6 + iau_inc_files = '' + iaufhrs = 30 + icloud_bl = 1 + ico2 = 2 + iems = 1 + imfdeepcnv = -1 + imfshalcnv = -1 + imp_physics = 8 + iopt_alb = 2 + iopt_btr = 1 + iopt_crs = 1 + iopt_dveg = 2 + iopt_frz = 1 + iopt_inf = 1 + iopt_rad = 1 + iopt_run = 1 + iopt_sfc = 1 + iopt_snf = 4 + iopt_stc = 1 + iopt_tbot = 2 + iopt_trs = 2 + isol = 2 + isot = 1 + isubc_lw = 2 + isubc_sw = 2 + ivegsrc = 1 + ldiag3d = .false. + lheatstrg = .false. + lradar = .true. + lsm = 2 + lsoil = 4 + lsoil_lsm = 4 + ltaerosol = .true. + lwhtr = .true. + nsfullradar_diag = 3600 + nst_anl = .true. + nstf_name = 2, 1, 0, 0, 0 + oz_phys = .false. + oz_phys_2015 = .true. + pdfcld = .false. + pre_rad = .false. + print_diff_pgr = .false. + prslrd0 = 0.0 + random_clds = .false. + redrag = .true. + satmedmf = .false. sfclay_compute_flux = .false. - shal_cnv = .false. - swhtr = .true. - trans_trac = .true. - ttendlim = -999 - use_ufo = .true. + shal_cnv = .false. + swhtr = .true. + trans_trac = .true. + ttendlim = -999 + use_ufo = .true. / +!![GFS_PHYSICS_NML] &interpolator_nml interp_method = 'conserve_great_circle' diff --git a/physics/docs/pdftxt/RE300/FV3_WoFS_v0_input.nml b/physics/docs/pdftxt/RE300/FV3_WoFS_v0_input.nml index 1236cde3b..70206c335 100644 --- a/physics/docs/pdftxt/RE300/FV3_WoFS_v0_input.nml +++ b/physics/docs/pdftxt/RE300/FV3_WoFS_v0_input.nml @@ -14,20 +14,22 @@ dycore_only = .false. / +!>[CIRES_UGWP_NML] &cires_ugwp_nml - knob_ugwp_azdir = 2, 4, 4, 4 - knob_ugwp_doaxyz = 1 - knob_ugwp_doheat = 1 - knob_ugwp_dokdis = 1 - knob_ugwp_effac = 1, 1, 1, 1 - knob_ugwp_ndx4lh = 1 - knob_ugwp_solver = 2 - knob_ugwp_source = 1, 1, 0, 0 - knob_ugwp_stoch = 0, 0, 0, 0 + knob_ugwp_azdir = 2, 4, 4, 4 + knob_ugwp_doaxyz = 1 + knob_ugwp_doheat = 1 + knob_ugwp_dokdis = 1 + knob_ugwp_effac = 1, 1, 1, 1 + knob_ugwp_ndx4lh = 1 + knob_ugwp_solver = 2 + knob_ugwp_source = 1, 1, 0, 0 + knob_ugwp_stoch = 0, 0, 0, 0 knob_ugwp_version = 0 - knob_ugwp_wvspec = 1, 25, 25, 25 - launch_level = 25 + knob_ugwp_wvspec = 1, 25, 25, 25 + launch_level = 25 / +!![CIRES_UGWP_NML] &diag_manager_nml max_output_fields = 450 @@ -143,85 +145,87 @@ grid_file = 'INPUT/grid_spec.nc' / +!>[GFS_PHYSICS_NML] &gfs_physics_nml - bl_mynn_edmf = 1 - bl_mynn_edmf_mom = 1 + bl_mynn_edmf = 1 + bl_mynn_edmf_mom = 1 bl_mynn_tkeadvect = .true. - cal_pre = .false. - cdmbgwd = 3.5, 0.25 - cnvcld = .false. - cnvgwd = .false. - cplflx = .false. - debug = .false. - do_deep = .false. - do_mynnedmf = .true. - do_mynnsfclay = .true. - dspheat = .true. - effr_in = .true. - fhcyc = 0.0 - fhlwr = 1200.0 - fhswr = 1200.0 - fhzero = 1.0 - h2o_phys = .true. - hybedmf = .false. - iaer = 111 - ialb = 1 - iau_delthrs = 6 - iau_inc_files = '' - iaufhrs = 30 - icloud_bl = 1 - ico2 = 2 - iems = 1 - imfdeepcnv = -1 - imfshalcnv = -1 - imp_physics = 17 - iopt_alb = 2 - iopt_btr = 1 - iopt_crs = 1 - iopt_dveg = 2 - iopt_frz = 1 - iopt_inf = 1 - iopt_rad = 1 - iopt_run = 1 - iopt_sfc = 1 - iopt_snf = 4 - iopt_stc = 1 - iopt_tbot = 2 - isol = 2 - isot = 1 - isubc_lw = 2 - isubc_sw = 2 - ivegsrc = 1 - ldiag3d = .false. - lheatstrg = .false. - lradar = .true. - lsm = 1 - lsoil = 4 - lsoil_lsm = 4 - ltaerosol = .true. - lwhtr = .true. - nsfullradar_diag = 3600 - nssl_cccn = 600000000.0 - nssl_ccn_on = .true. - nssl_hail_on = .true. - nst_anl = .true. - nstf_name = 2, 1, 0, 0, 0 - oz_phys = .false. - oz_phys_2015 = .true. - pdfcld = .false. - pre_rad = .false. - print_diff_pgr = .false. - prslrd0 = 0.0 - random_clds = .false. - redrag = .true. - satmedmf = .false. + cal_pre = .false. + cdmbgwd = 3.5, 0.25 + cnvcld = .false. + cnvgwd = .false. + cplflx = .false. + debug = .false. + do_deep = .false. + do_mynnedmf = .true. + do_mynnsfclay = .true. + dspheat = .true. + effr_in = .true. + fhcyc = 0.0 + fhlwr = 1200.0 + fhswr = 1200.0 + fhzero = 1.0 + h2o_phys = .true. + hybedmf = .false. + iaer = 111 + ialb = 1 + iau_delthrs = 6 + iau_inc_files = '' + iaufhrs = 30 + icloud_bl = 1 + ico2 = 2 + iems = 1 + imfdeepcnv = -1 + imfshalcnv = -1 + imp_physics = 17 + iopt_alb = 2 + iopt_btr = 1 + iopt_crs = 1 + iopt_dveg = 2 + iopt_frz = 1 + iopt_inf = 1 + iopt_rad = 1 + iopt_run = 1 + iopt_sfc = 1 + iopt_snf = 4 + iopt_stc = 1 + iopt_tbot = 2 + isol = 2 + isot = 1 + isubc_lw = 2 + isubc_sw = 2 + ivegsrc = 1 + ldiag3d = .false. + lheatstrg = .false. + lradar = .true. + lsm = 1 + lsoil = 4 + lsoil_lsm = 4 + ltaerosol = .true. + lwhtr = .true. + nsfullradar_diag = 3600 + nssl_cccn = 600000000.0 + nssl_ccn_on = .true. + nssl_hail_on = .true. + nst_anl = .true. + nstf_name = 2, 1, 0, 0, 0 + oz_phys = .false. + oz_phys_2015 = .true. + pdfcld = .false. + pre_rad = .false. + print_diff_pgr = .false. + prslrd0 = 0.0 + random_clds = .false. + redrag = .true. + satmedmf = .false. sfclay_compute_flux = .false. - shal_cnv = .false. - swhtr = .true. - trans_trac = .true. - ttendlim = -999 - use_ufo = .true. + shal_cnv = .false. + swhtr = .true. + trans_trac = .true. + ttendlim = -999 + use_ufo = .true. / +!![GFS_PHYSICS_NML] &interpolator_nml interp_method = 'conserve_great_circle' diff --git a/physics/docs/pdftxt/SRW_all_shemes_list.txt b/physics/docs/pdftxt/SRW_all_shemes_list.txt index db9683579..16a1727e6 100644 --- a/physics/docs/pdftxt/SRW_all_shemes_list.txt +++ b/physics/docs/pdftxt/SRW_all_shemes_list.txt @@ -16,6 +16,7 @@ The UFS-SRW App. assembles the parameterizations in suites. - \subpage GFS_NOAH - \subpage RUCLSM - \subpage NoahMP + - \subpage CLM_LAKE_model \b Cumulus \b Parameterizations - \subpage GFS_SAMFdeep @@ -46,9 +47,6 @@ The UFS-SRW App. assembles the parameterizations in suites. - \subpage GFS_OCEAN - \subpage GFS_SFCSICE -\b CLM \b Lake \b Model - - \subpage CLM_LAKE_model - \b Others - \subpage GFS_SPP @@ -70,21 +68,21 @@ to the parameterization. - If the in-core saturation adjustment is used (\p do_sat_adj=.true.), it is invoked at shorter timesteps along with the dynamical solver. -The UFS Short Range Weather Application (SRW App) v2.1.0 supports four physicsphysics suites. +The UFS Short Range Weather Application (SRW App) v3.0.0 supports four physicsphysics suites. -Table 1. Physics suites and primary schemes supported in SRW v2.1.0 +Table 1. Physics suites and primary schemes supported in SRW v3.0.0 \tableofcontents -| Physics suites | GFS_v16 | HRRR | RRFS_v1beta | WoFS_v0 | -|------------------|--------------------|--------------------------------|--------------------|---------------| -|\b Deep \b Cu | \ref GFS_SAMFdeep | \a off | \a off | \a off | -|\b Shallow \b Cu | \ref GFS_SAMFshal | \ref MYNNEDMF | \ref MYNNEDMF | \ref MYNNEDMF | -|\b Microphysics | \ref GFDL_cloud | \ref THOMPSON | \ref THOMPSON | \ref NSSLMICRO_page | -|\b PBL/TURB | \ref GFS_SATMEDMFVDIFQ | \ref MYNNEDMF | \ref MYNNEDMF | \ref MYNNEDMF | -|\b Radiation | \ref GFS_RRTMG | \ref GFS_RRTMG | \ref GFS_RRTMG | \ref GFS_RRTMG | -|\b Surface \b Layer | \ref GFS_SFCLYR | \ref SFC_MYNNSFL | \ref SFC_MYNNSFL | \ref SFC_MYNNSFL | -|\b LSM | \ref GFS_NOAH | \ref RUCLSM | \ref NoahMP | \ref GFS_NOAH | -|\b Gravity \b Wave \b Drag| \ref GFS_UGWP_v0 | \ref GFS_drag_suite | \ref GFS_UGWP_v0 | \ref GFS_UGWP_v0 | -|\b Sea \b Ice | \ref GFS_SFCSICE | \ref RUCLSM | \ref GFS_SFCSICE | \ref GFS_SFCSICE | +| Physics suites | GFS_v16 | HRRR | RRFS_v1beta | WoFS_v0 | RAP | +|--------------------|--------------------|--------------------------------|--------------------|---------------|---------------| +|\b Deep \b Cu | \ref GFS_SAMFdeep | \a off | \a off | \a off | \ref CU_GF | +|\b Shallow \b Cu | \ref GFS_SAMFshal | \ref MYNNEDMF | \ref MYNNEDMF | \ref MYNNEDMF | \ref CU_GF | +|\b Microphysics | \ref GFDL_cloud | \ref THOMPSON | \ref THOMPSON | \ref NSSLMICRO_page | \ref THOMPSON| +|\b PBL/TURB | \ref GFS_SATMEDMFVDIFQ | \ref MYNNEDMF | \ref MYNNEDMF | \ref MYNNEDMF | \ref MYNNEDMF | +|\b Radiation | \ref GFS_RRTMG | \ref GFS_RRTMG | \ref GFS_RRTMG | \ref GFS_RRTMG | \ref GFS_RRTMG | +|\b Surface \b Layer | \ref GFS_SFCLYR | \ref SFC_MYNNSFL | \ref SFC_MYNNSFL | \ref SFC_MYNNSFL | \ref SFC_MYNNSFL | +|\b LSM | \ref GFS_NOAH | \ref RUCLSM and \ref CLM_LAKE_model | \ref NoahMP | \ref GFS_NOAH | \ref RUCLSM | +|\b Gravity \b Wave \b Drag| \ref GFS_UGWP_v0 | \ref GFS_drag_suite | \ref GFS_UGWP_v0 | \ref GFS_UGWP_v0 | \ref GFS_drag_suite | +|\b Ice and \b Snow | \ref GFS_SFCSICE | \ref RUCLSM | \ref GFS_SFCSICE | \ref GFS_SFCSICE | \ref RUCLSM | \tableofcontents diff --git a/physics/docs/pdftxt/SRW_mainpage.txt b/physics/docs/pdftxt/SRW_mainpage.txt index 59b551d55..8b3791c07 100644 --- a/physics/docs/pdftxt/SRW_mainpage.txt +++ b/physics/docs/pdftxt/SRW_mainpage.txt @@ -1,10 +1,10 @@ /** \mainpage Introduction -Welcome to the scientific documentation for the physical parameterizations available in the Unified Forecast System (UFS) Short-Range Weather (SRW) Application version 3.0 (available through https://github.com/ufs-community/ufs-srweather-app/) and the suites that can be configured using them. The SRW app targets predictions of atmospheric behavior on a +Welcome to the scientific documentation for the physical parameterizations available in the Unified Forecast System (UFS) Short-Range Weather (SRW) Application version 3.0.0 (available through https://github.com/ufs-community/ufs-srweather-app/) and the suites that can be configured using them. The SRW app targets predictions of atmospheric behavior on a limited spatial domain and on time scales from less than an hour out to several days. -The CCPP parameterizations are aggregated in suites by the host models. In this release, the UFS Short-Range Weather Application 3.0 +The CCPP parameterizations are aggregated in suites by the host models. In this release, the UFS Short-Range Weather Application 3.0.0 supports suites: - \ref GFS_v16_page - \ref HRRR_suite_page From c901390c8e758f63d1e2122d917579230d1def6d Mon Sep 17 00:00:00 2001 From: Man Zhang Date: Thu, 15 Jun 2023 11:43:23 -0600 Subject: [PATCH 298/380] address some review comments --- physics/docs/pdftxt/CLM_LAKE.txt | 8 +++--- physics/docs/pdftxt/CU_GF_deep.txt | 17 ++++++------- physics/docs/pdftxt/GFS_NOAHMP.txt | 6 ++--- physics/docs/pdftxt/GFS_SAMFdeep.txt | 3 +-- physics/docs/pdftxt/HRRR_suite.txt | 4 +-- physics/docs/pdftxt/RAP_suite.txt | 6 ++--- physics/docs/pdftxt/RRFS_v1beta_suite.txt | 4 +-- physics/docs/pdftxt/RUCLSM.txt | 9 ++++--- physics/docs/pdftxt/SRW_mainpage.txt | 10 +++++++- physics/docs/pdftxt/WoFS_v0_suite.txt | 5 ++-- physics/docs/pdftxt/suite_input.nml.txt | 30 ++++++++++++++++++----- 11 files changed, 63 insertions(+), 39 deletions(-) diff --git a/physics/docs/pdftxt/CLM_LAKE.txt b/physics/docs/pdftxt/CLM_LAKE.txt index c091d2b17..e0a8d9209 100644 --- a/physics/docs/pdftxt/CLM_LAKE.txt +++ b/physics/docs/pdftxt/CLM_LAKE.txt @@ -2,7 +2,7 @@ \page CLM_LAKE_model CLM Lake Model \section des_clmlake Description -CLM lake model is a multi-level one-dimensional lake model that has been implemented within the operational 3-km HRRR and +The Community Land Model (CLM) lake model is a multi-level one-dimensional lake model that has been implemented within the operational 3-km HRRR and 13-km RAP for small lakes (Benjamin et al. (2022) \cite gmd-15-6659-2022). It is the Community Land Model, version 4.5. Subin et al. (2012) \cite Subin_2012 describe the 1-d CLM lake model as applied within the Community Earth System Model (CESM) as a component of the overall CESM CLM (Lawrence et al. (2019) \cite Lawrence_2019). Gu et al. (2015) \cite Gu2015 @@ -31,14 +31,14 @@ to improve surface prediction in the vicinity of small lakes. The CLM lake model requires bathymetry for the lake points in the model domain. Grid points are assigned as lake points when the fraction of lake coverage in the grid cell exceeds 50% and when this point is disconnected from oceans. The lake water mask is therefore binary, set to either 1 or 0. This binary approach for models with higher horizontal resolution, for example, 3-km resolution in -the regional application of UFS (RRFS), is capable of capturing the effect of lakes on regional heat and moisture fluxes. +in the UFS SRW App, is capable of capturing the effect of lakes on regional heat and moisture fluxes. Lake depths for the RRFS lake configuration (Fig.1) are assigned from a global dataset provided by Kourzeneva et al.(2012) \cite Kourzeneva_2012, this dataset is referred to as GLOBv3 bathymetry in the UFS_UTL. \image html Lake_depths_RRFS3km.png "Figure 1: Lake depths for lakes in the 3-km RRFS domain." width=600 -To cold-start the CLM lake model in RRFS: +To cold-start the CLM lake model in the UFS SRW App: - Use the CLM option in the input.nml \n - lkm = 1 \n - iopt_lake = 2 @@ -47,7 +47,7 @@ To cold-start the CLM lake model in RRFS: - Temperature for soil under the lake is initialized from bottom lake temperature at the top to the substrate soil temperature at the bottom of soil layer - Lake ice at the top level is initialized from the GFS ice concentration -The differences of surface variables from the RRFS 6-h forecast with/without CLM lake model are shown in Figure 2 for 2-m temperature and in Figure 3 for 2-m dewpoint. +The differences of surface variables from the experimental RRFS 6-h forecast with/without CLM lake model are shown in Figure 2 for 2-m temperature and in Figure 3 for 2-m dewpoint. \image html diff_t2m_lake_rrfs.png "Figure 2: Differences of 2-m temperature between the RRFS coupled to the CLM model and the RRFS without CLM." width=600 \image html diff_td2m_lake_rrfs.png "Figure 3: Differences of 2-m dew point between the RRFS coupled to the CLM model and the RRFS without CLM." width=600 diff --git a/physics/docs/pdftxt/CU_GF_deep.txt b/physics/docs/pdftxt/CU_GF_deep.txt index f30cb28dc..365ba9ae0 100644 --- a/physics/docs/pdftxt/CU_GF_deep.txt +++ b/physics/docs/pdftxt/CU_GF_deep.txt @@ -8,20 +8,18 @@ follows the mass flux approach published by Grell (1993) \cite grell_1993. Further developments by Grell and \f$D\acute{e}v\acute{e}nyi\f$ (2002) \cite Grell_2002 included implementing stochastics through allowing parameter perturbations. In GF scale awareness, and the aerosol dependence through rain generation (following Berry (1968) \cite berry_1968 and evaporation formulations (following Jiang et al. (2010) \cite Jiang_2010 ), depending on the -cloud concentration nuclei at cloud base were added. GF included mixed phase physics impact, momentum transport, +cloud concentration nuclei at cloud base were added. The GF scheme includes mixed phase physics impact, momentum transport, a diurnal cycle closure (Bechtold et al. (2014) \cite bechtold_et_al_2014 ), and a trimodal spectral size to simulate the interaction -and transition from shallow, congestus and deep convection regimes. The vertical massflux distribution of shallow, congestus and -deep convection regimes is characterized by Probability Density Functions (PDF's). The three PDF's are meant to represent the average +and transition from shallow, congestus and deep convection regimes. The vertical mass flux distribution of shallow, congestus and +deep convection regimes is characterized by Probability Density Functions (PDFs). The three PDF's are meant to represent the average statistical mass flux characteristic of deep, congestus, and shallow (respectively) plumes in the grid area. Each PDF therefore represents a spectrum of plumes within the grid box. Forcing is different for each characteristic type. Entrainment and detrainment are derived -from the PDF's. The deep and congestus convection considers scale awareness (Arakawa et al. (2011) \cite Arakawa_2011 ), the shallow convection is not scale-aware. Aerosol dependence is implemented through dependence of rain generation and +from the PDF's. The deep and congestus convection considers scale awareness (Arakawa et al. (2011) \cite Arakawa_2011 ). However, the shallow convection is not scale-aware. Aerosol dependence is implemented through dependence of rain generation and evaporation formulations depending on the cloud concentration nuclei at cloud base (Berry 1968 \cite berry_1968, Jiang et al.(2010) \cite Jiang_2010, and Lee and Feingold (2010) \cite lee_and_feingold_2010 ). Wet scavenging is considered to add a memory impact. Aerosol dependence is considered experimental and is turned off at this point. GF is able to transport tracers. - -\section version_cugf_enh CCPP Physics Updates -\version CCPP v6.0.0 +\b CCPP \b v6.0.0 \b Updates: - GPU capabilities have been added - Cap suppressing (\p do_cap_suppress) based on radar data assimilation has been added. This is used only for the RAP suite @@ -38,9 +36,10 @@ transition as grid spacing decreases into a shallow convection scheme - Coupled to the grid scale precipitation and radiation schemes through passing of diagnosed cloud liquid and ice from simulated precipitating convective cloud and shallow convective clouds +\section version_cugf_enh CCPP Physics Updates + \version UFS-SRW v3.0.0 -- The choices of closures for deep/mid/shallow convection are now namelist options -- Updates for aerosol-awareness +- Updates for aerosol-awareness (experimental) \b The \b Implementation \b of \b GF \b in \b RRFS diff --git a/physics/docs/pdftxt/GFS_NOAHMP.txt b/physics/docs/pdftxt/GFS_NOAHMP.txt index 83e8c0650..386ae816c 100644 --- a/physics/docs/pdftxt/GFS_NOAHMP.txt +++ b/physics/docs/pdftxt/GFS_NOAHMP.txt @@ -4,11 +4,9 @@ This implementation of the NoahMP Land Surface Model (LSM) is adapted from the version implemented in WRF v3.7 with additions by NOAA EMC staff to work with the UFS Atmosphere model. Authoritative documentation of the NoahMP scheme can be accessed at the following links: -Technical documentation freely available at He et al. (2023) \cite He_2023. +- Technical documentation freely available at He et al. (2023) \cite He_2023. -To cite the technical documentation: He, C., P. Valayamkunnath, M. Barlage, F. Chen, D. Gochis, R. Cabell, T. Schneider, R. Rasmussen, G.-Y. Niu, Z.-L. Yang, D. Niyogi, and M. Ek (2023): The Community Noah-MP Land Surface Modeling System Technical Description Version 5.0, (No. NCAR/TN-575+STR). doi:10.5065/ew8g-yr95 - -A primary reference for the NoahMP LSM is Niu et al. (2011) \cite niu_et_al_2011. +- A primary reference for the NoahMP LSM is Niu et al. (2011) \cite niu_et_al_2011. \section noahmp_update CCPP Physics Updates \version UFS-SRW v3.0.0 diff --git a/physics/docs/pdftxt/GFS_SAMFdeep.txt b/physics/docs/pdftxt/GFS_SAMFdeep.txt index 346637b3b..d41763c37 100644 --- a/physics/docs/pdftxt/GFS_SAMFdeep.txt +++ b/physics/docs/pdftxt/GFS_SAMFdeep.txt @@ -65,8 +65,7 @@ rain conversion rate, entrainment and detrainment rates, overshooting layers, and maximum allowable cloudbase mass flux (as of June 2018). -\section v6_enh CCPP Physics Updates -\version CCPP v6.0.0 +\b CCPP \b v6.0.0 \b Updates \subsection ca_page Cellular Automata Stochastic Convective Organization Scheme diff --git a/physics/docs/pdftxt/HRRR_suite.txt b/physics/docs/pdftxt/HRRR_suite.txt index 33a1eb0b8..93601b62b 100644 --- a/physics/docs/pdftxt/HRRR_suite.txt +++ b/physics/docs/pdftxt/HRRR_suite.txt @@ -3,10 +3,10 @@ \section HRRR_suite_overview Overview -The HRRR suite contains the parameterizations used in the NOAA operational +The HRRR suite contains the evolving parameterizations used in the NOAA operational High-Resolution Rapid Refresh (HRRR) model, which runs at 3-km resolution. This suite is most applicable for runs at 3-km resolution since it does not -parameterize deep convection. +parameterize deep convection. It is one of the primary suite candidates for RRFS v1 operational implementation. For additional information about the HRRR model, visit: https://rapidrefresh.noaa.gov/hrrr/. diff --git a/physics/docs/pdftxt/RAP_suite.txt b/physics/docs/pdftxt/RAP_suite.txt index 0371050b0..26b9d31f3 100644 --- a/physics/docs/pdftxt/RAP_suite.txt +++ b/physics/docs/pdftxt/RAP_suite.txt @@ -3,9 +3,9 @@ \section rap_suite_overview Overview -The RAP suite contains the parameterizations used in the NOAA operational Rapid Refresh (RAP) model -which runs at 13-km resolution. Currently, the RAP suite is supported in SCM only. For additional -information about the RAP model, visit: https://rapidrefresh.noaa.gov. +The RAP suite contains the evolving parameterizations used in the NOAA operational Rapid Refresh (RAP) model +which runs at 13-km resolution. For additional +information about the RAP model, visit: https://rapidrefresh.noaa.gov. It is one of the primary suite candidates for RRFS v1 operational implementation. The RAP suite uses the parameterizations in the following order: - \ref SGSCLOUD_page diff --git a/physics/docs/pdftxt/RRFS_v1beta_suite.txt b/physics/docs/pdftxt/RRFS_v1beta_suite.txt index 2731e227e..ae400b982 100644 --- a/physics/docs/pdftxt/RRFS_v1beta_suite.txt +++ b/physics/docs/pdftxt/RRFS_v1beta_suite.txt @@ -3,8 +3,8 @@ \section RRFS_v1beta_suite_overview Overview -The RRFS_v1beta suite is the primary suite target for the upcoming operational implementation of -the Rapid Refresh Forecast System (RRFS), which is used in the UFS SRW App. This suite is most +The RRFS_v1beta suite is one of candicates for the future operational implementation of +the Rapid Refresh Forecast System (RRFS), which can be configured using the UFS SRW App. This suite is most applicable for runs at 3-km resolution since it does not parameterize deep convection. diff --git a/physics/docs/pdftxt/RUCLSM.txt b/physics/docs/pdftxt/RUCLSM.txt index 461348aa4..7a39faf84 100644 --- a/physics/docs/pdftxt/RUCLSM.txt +++ b/physics/docs/pdftxt/RUCLSM.txt @@ -10,7 +10,7 @@ processes in the RUC LSM (Smirnova et al. 2016 \cite Smirnova_2016 ) have proven the evolution of soil moisture, soil temperature, and snow in cycled models. Extension of the RAP domain to encompass all of North America and adjacent high-latitude ocean areas necessitated further development of the RUC LSM for application in the tundra permafrost regions and over Arctic sea ice (Smirnova et al. 2000 \cite Smirnova_2000). Other modifications include refinements in the snow model (snow "mosaic" approach, improvements in computation of snow cover fraction and snow thermal conductivity) and a more accurate specification of -albedo, roughness length, and other surface properties. Some of these recent modifications in the RUC LSM are described and evaluated in +albedo, roughness length, and other surface properties. Some of these modifications in the RUC LSM are described and evaluated in Smirnova et al. 2016 \cite Smirnova_2016 . The parameterizations in the RUC LSM describe complicated atmosphere–land surface interactions (Fig.1) in an intentionally simplified fashion to avoid @@ -38,9 +38,10 @@ These adjustments are available in the current CCPP public release. Coupling of the RUC LSM to physically-based stochastic snow model (He et al.(2021) \cite he_et_al_2021) is also available in the current public release. -The sensitivity of surface fluxes and turbine-height winds to the RUC LSM parameters has been explored by Geng Xia, NREL. This study -will determine the uncertainty range for the selected parameters in the RUC LSM and will be described in the journal paper. -## RUC LSM characteristics that differ from NOAH LSM: +The sensitivity of surface fluxes and turbine-height winds to the RUC LSM parameters has been explored by Geng Xia, NREL +to determine the uncertainty range for the selected parameters in the RUC LSM. + +## RUC LSM characteristics that differ from Noah LSM: \image html ruc_lsm_veg_soil.png "Figure 1: RUC LSM Vegetation and Soil Model (Courtesy of T.G. Smirnova) " width=900 \image html ruc_ranking.png "Figure 2: Model ranking as a function of normalized root mean square error of snow water equivalent and surface temperature (Courtesy of C. Menard)" width=900 - \b Implicit \b solution of energy and moisture budgets in the layer spanning the ground surface diff --git a/physics/docs/pdftxt/SRW_mainpage.txt b/physics/docs/pdftxt/SRW_mainpage.txt index 8b3791c07..5e854034c 100644 --- a/physics/docs/pdftxt/SRW_mainpage.txt +++ b/physics/docs/pdftxt/SRW_mainpage.txt @@ -1,7 +1,7 @@ /** \mainpage Introduction -Welcome to the scientific documentation for the physical parameterizations available in the Unified Forecast System (UFS) Short-Range Weather (SRW) Application version 3.0.0 (available through https://github.com/ufs-community/ufs-srweather-app/) and the suites that can be configured using them. The SRW app targets predictions of atmospheric behavior on a +Welcome to the scientific documentation for the physical parameterizations available in the Unified Forecast System (UFS) Short-Range Weather (SRW) Application version 3.0.0 (available through https://github.com/ufs-community/ufs-srweather-app/) and the suites that can be configured using them. The SRW App targets predictions of atmospheric behavior on a limited spatial domain and on time scales from less than an hour out to several days. The CCPP parameterizations are aggregated in suites by the host models. In this release, the UFS Short-Range Weather Application 3.0.0 @@ -12,5 +12,13 @@ supports suites: - \ref WoFS_v0_page - \ref rap_suite_page +\attention Here all supported suites are a recent snapshot of + +the UFS fork for CCPP . In this regard, GFS_v16 Suite is +not the same code as in the operational GFS v16. First of all, the operational GFS_v16 does not use CCPP at all. +Secondly, most of physics schemes hosted in CCPP repository have marched ahead since GFS was updated to version 16.0 on 22 March 2021. +This implication should be also applied to all other suites: as such, RAP/HRRR suites in this release are +the evolving version of the RAP/HRRR physics in operations. + */ diff --git a/physics/docs/pdftxt/WoFS_v0_suite.txt b/physics/docs/pdftxt/WoFS_v0_suite.txt index 8259ab770..4561109fa 100644 --- a/physics/docs/pdftxt/WoFS_v0_suite.txt +++ b/physics/docs/pdftxt/WoFS_v0_suite.txt @@ -4,8 +4,9 @@ \section wofs_v0_suite_overview Overview The WoFS_v0 suite is targeted for use in the upcoming operational implementation -of the NOAA's Warn-on-Forecast System (WoFS). This suite is most applicable for -runs at 3-km resolution since it does not parameterize deep convection. +of the NOAA's Warn-on-Forecast System (WoFS) and for the RRFS ensemble. +This suite is most applicable for runs at 3-km resolution since it does +not parameterize deep convection. The WoFS suite uses the parameterizations in the following order: - \ref SGSCLOUD_page diff --git a/physics/docs/pdftxt/suite_input.nml.txt b/physics/docs/pdftxt/suite_input.nml.txt index be3785b74..11d33db1c 100644 --- a/physics/docs/pdftxt/suite_input.nml.txt +++ b/physics/docs/pdftxt/suite_input.nml.txt @@ -50,9 +50,9 @@ show some variables in the namelist that must match the SDF. do_sfcperts gfs_rrtmg_pre flag for stochastic surface perturbations option .false. imp_physics choice of microphysics scheme choice of microphysics scheme: \n
      -
    • 11: GFDL microphysics scheme
    • 8: Thompson microphysics scheme
    • 10: Morrison-Gettelman microphysics scheme +
    • 11: GFDL microphysics scheme
    • 17: NSSL microphysics scheme with background CCN
    • 18: NSSL microphysics scheme with predicted CCN (compatibility)
    @@ -258,7 +258,7 @@ show some variables in the namelist that must match the SDF.
  • true: activate TKE advection
.false. -bl_mynn_tkebudget mynnedmf_wrapper flag to activate TKE budget 0 +tke_budget mynnedmf_wrapper flag to activating TKE budget 0 bl_mynn_cloudpdf mynnedmf_wrapper flag to determine which cloud PDF to use \n
  • 0: use Sommeria-Deardorff subgrid cloud PDF @@ -384,6 +384,9 @@ show some variables in the namelist that must match the SDF. t_sub gfdl_cloud_microphys temperature threshold for sublimation. Cloud ice, snow or graupel stops(starts) sublimation when temperature is lower(higher) then \p t_sub 184. mp_print gfdl_cloud_microphys \a .true. to turn on GFDL cloud microphysics debugging print out. (not supported in GFS physics) .false. ltaerosol mp_thompson flag for using aerosol climotology in Thompson MP scheme .false. +mraerosol flag for merra2 aerosol aware .false. +lradar flag for radar reflectivity .false. +nsfullradar_diag seconds between resetting radar reflectivity calculation .-999.0 ttendlim mp_thompson temperature tendency limiter per time step in K/s, set to < 0 to deactivate -999.0 ext_diag_thompson mp_thompson flag for extended diagnostic output from Thompson MP .false. thompson_ext_ndiag3d mp_thompson number of 3d arrays for extended diagnostic output from Thompson MP 37 @@ -394,9 +397,11 @@ show some variables in the namelist that must match the SDF. cnvcld see \a GFS_typedefs.F90 flag for convective cloud .false. lgfdlmprad gfs_rrtmg_pre flag for GFDL mp scheme and radiation consistency .false. nssl_cccn mp_nssl CCN concentration (m^-3) 0.6e9 -nssl_alphar mp_nssl rain PSD shape parameter 0.0 -nssl_alphah mp_nssl graupel PSD shape parameter 0.0 -nssl_alphahl mp_nssl hail PSD shape parameter 1.0 +nssl_alphah mp_nssl graupel shape parameter 0.0 +nssl_alphahl mp_nssl hail shape parameter 1.0 +nssl_alphar mp_nssl shape paramter for rain (imurain=1 only) 0.0 +nssl_ehw0_in mp_nssl constant or max assumed graupel-droplet collection efficiency 0.9 +nssl_ehlw0_in mp_nssl constant or max assumed hail-droplet collection efficiency 0.9 nssl_hail_on mp_nssl NSSL flag to activate the hail category .false. nssl_ccn_on mp_nssl NSSL flag to activate the CCN category .true. nssl_invertccn mp_nssl NSSL flag to treat CCN as activated or unactivated .true. @@ -508,15 +513,20 @@ show some variables in the namelist that must match the SDF.
  • 0: USGS
  • 1: IGBP(20 category): IGBP must be selected if NoahMP is used
  • 2: UMD (13 category) +
  • 3: NLCD40 (40 category, NOAH WRFv4 only) +
  • 4: USGS-RUC (28 category, NOAH WRFv4 only) +
  • 5: MODIS-RUC (21 category, NOAH WRFv4 only)
2 +nvegcat isot lsm_noah, lsm_ruc, \ref noahmpdrv flag for soil type dataset choice:\n
  • 0: Zobler soil type (9 category)
  • 1: STATSGO soil type (19 category): STATSGO must be selected if NoahMP is used +
  • 2: STAS-RUC soil type (19 category, NOAH WRFv4 only
0 - +exticeden lsm_noah,lsm_ruc flag for calculating frozen precip ice density outside of the LSM .false. iopt_dveg \ref noahmpdrv options for dynamic vegetation \n
  • 1: off (use table LAI; use FVEG = SHDFAC from input) @@ -613,7 +623,15 @@ show some variables in the namelist that must match the SDF.
  • 4: kb inversed
2 +mosaic_lu +mosaic_soil +isncond_opt +isncovr_opt \b Parameters \b related \b to \b other \b surface \b scheme \b options +lkm +iopt_lake +lakedepth_threshold +lakefrac_threshold nstf_name(5) sfc_nst NSST related paramters:\n
  • nstf_name(1): 0=NSST off, 1= NSST on but uncoupled, 2= NSST on and coupled From 57f72fbc73b9704a23285867645b8927fedc87fb Mon Sep 17 00:00:00 2001 From: Man Zhang Date: Wed, 5 Jul 2023 14:54:28 -0600 Subject: [PATCH 299/380] Scidoc updates --- physics/cu_gf_deep.F90 | 1 + physics/docs/library.bib | 19 +++++++- physics/docs/pdftxt/CU_GF_deep.txt | 28 +++-------- physics/docs/pdftxt/GFS_SATMEDMFVDIFQ.txt | 33 ++++++++----- physics/docs/pdftxt/suite_input.nml.txt | 58 ++++++++++++++++------- physics/satmedmfvdifq.F | 12 +++-- 6 files changed, 92 insertions(+), 59 deletions(-) diff --git a/physics/cu_gf_deep.F90 b/physics/cu_gf_deep.F90 index 67dd9bd3f..1b30063bd 100644 --- a/physics/cu_gf_deep.F90 +++ b/physics/cu_gf_deep.F90 @@ -28,6 +28,7 @@ module cu_gf_deep integer, parameter :: autoconv=1 !2 integer, parameter :: aeroevap=1 !3 real(kind=kind_phys), parameter :: scav_factor = 0.5 + real(kind=kind_phys), parameter :: dx_thresh = 6500. !> still 16 ensembles for clousres integer, parameter:: maxens3=16 diff --git a/physics/docs/library.bib b/physics/docs/library.bib index 7c01fbc65..34bb54e8f 100644 --- a/physics/docs/library.bib +++ b/physics/docs/library.bib @@ -1,13 +1,30 @@ %% This BibTeX bibliography file was created using BibDesk. %% https://bibdesk.sourceforge.io/ -%% Created for Man Zhang at 2023-06-07 10:17:09 -0600 +%% Created for Man Zhang at 2023-06-28 14:13:48 -0600 %% Saved with string encoding Unicode (UTF-8) +@article{Chen_2022, + author = {Xiaomin Chen and George H. Bryan and Andrew Hazelton and Frank D. Marks and Pat Fitzpatrick}, + date-added = {2023-06-28 14:13:19 -0600}, + date-modified = {2023-06-28 14:13:19 -0600}, + doi = {10.1175/waf-d-21-0168.1}, + journal = {Weather and Forecasting}, + month = {jun}, + number = {6}, + pages = {935--951}, + publisher = {American Meteorological Society}, + title = {Evaluation and Improvement of a {TKE}-Based Eddy-Diffusivity Mass-Flux ({EDMF}) Planetary Boundary Layer Scheme in Hurricane Conditions}, + url = {https://doi.org/10.1175%2Fwaf-d-21-0168.1}, + volume = {37}, + year = 2022, + bdsk-url-1 = {https://doi.org/10.1175%2Fwaf-d-21-0168.1}, + bdsk-url-2 = {https://doi.org/10.1175/waf-d-21-0168.1}} + @article{Lin_2022, author = {Jialin Lin and Taotao Qian and Peter Bechtold and Georg Grell and Guang J. Zhang and Ping Zhu and Saulo R. Freitas and Hannah Barnes and Jongil Han}, date-added = {2023-06-07 10:16:46 -0600}, diff --git a/physics/docs/pdftxt/CU_GF_deep.txt b/physics/docs/pdftxt/CU_GF_deep.txt index 365ba9ae0..1a02516f7 100644 --- a/physics/docs/pdftxt/CU_GF_deep.txt +++ b/physics/docs/pdftxt/CU_GF_deep.txt @@ -16,41 +16,25 @@ statistical mass flux characteristic of deep, congestus, and shallow (respective a spectrum of plumes within the grid box. Forcing is different for each characteristic type. Entrainment and detrainment are derived from the PDF's. The deep and congestus convection considers scale awareness (Arakawa et al. (2011) \cite Arakawa_2011 ). However, the shallow convection is not scale-aware. Aerosol dependence is implemented through dependence of rain generation and evaporation formulations depending on the cloud concentration nuclei at cloud base (Berry 1968 \cite berry_1968, -Jiang et al.(2010) \cite Jiang_2010, and Lee and Feingold (2010) \cite lee_and_feingold_2010 ). Wet scavenging is considered to add a memory impact. Aerosol dependence is considered experimental and -is turned off at this point. GF is able to transport tracers. +Jiang et al.(2010) \cite Jiang_2010, and Lee and Feingold (2010) \cite lee_and_feingold_2010 ). Wet scavenging is considered to add a memory impact. Aerosol dependence is considered experimental and is turned off at this point. GF is able to transport tracers. +Recently, GPU capabilities and cap suppressing (\p do_cap_suppress) based on radar data assimilation have been added,and they are used only for the RAP suite. -\b CCPP \b v6.0.0 \b Updates: - -- GPU capabilities have been added -- Cap suppressing (\p do_cap_suppress) based on radar data assimilation has been added. This is used only for the RAP suite -- Some fixed parameters have been made scale-aware -- Updated coupling between radiation and convection has been implemented - -\b Operational \b Impacts \b in \b RAP/HRRR - - - Uses mass-flux schemes, which are more physically realistic than (sounding) adjustment schemes - - Takes parameterization uncertainty into account by allowing parameters from multiple convective schemes which can be perturbed -internally or with temporal and spatial correlation patterns - - For higher resolutions (less than 10 km), in addition to scale awareness as in Arakawa et al. (2011) \cite Arakawa_2011 GF can -transition as grid spacing decreases into a shallow convection scheme - - Coupled to the grid scale precipitation and radiation schemes through passing of diagnosed cloud liquid and ice from simulated -precipitating convective cloud and shallow convective clouds +The impacts of GF scheme in operational RAP/HRRR include:(a)uses mass-flux schemes, which are more physically realistic than (sounding) adjustment schemes; +(b)takes parameterization uncertainty into account by allowing parameters from multiple convective schemes which can be perturbed +internally or with temporal and spatial correlation patterns; (c)for higher resolutions (less than 10 km), in addition to scale awareness as in Arakawa et al. (2011) \cite Arakawa_2011 GF can transition as grid spacing decreases into a shallow convection scheme; (d)Coupled to the grid scale precipitation and radiation schemes through passing of diagnosed cloud liquid and ice from simulated precipitating convective cloud and shallow convective clouds. \section version_cugf_enh CCPP Physics Updates \version UFS-SRW v3.0.0 -- Updates for aerosol-awareness (experimental) \b The \b Implementation \b of \b GF \b in \b RRFS - +- Updates for aerosol-awareness (experimental) - Scale-awareness is turned off when explicit microphysics is not active anywhere in the column - GF completely is turned off at grid points when MYNN produces shallow convection at that point - Radar reflectivity considers mass flux PDF as well as whether scale-awareness is turned on at the grid point in equation. \b The \b implementation \b of \b GF \b in \b HAFS \b is \b undergoing. - - \section intra_rough_gf Intraphysics Communication The GF scheme passes cloud hydrometeors to the grid-scale microphysics scheme (\ref THOMPSON ) through detrainment from each convective cloud layer containing convective cloud. The detrained condensate interacts with short- and longwave radiation by diff --git a/physics/docs/pdftxt/GFS_SATMEDMFVDIFQ.txt b/physics/docs/pdftxt/GFS_SATMEDMFVDIFQ.txt index 4e00d7c3c..3ae1a0234 100644 --- a/physics/docs/pdftxt/GFS_SATMEDMFVDIFQ.txt +++ b/physics/docs/pdftxt/GFS_SATMEDMFVDIFQ.txt @@ -25,27 +25,34 @@ to take into account nonlocal transport by large eddies(mfpbltq.f) - A new mass-flux paramterization for stratocumulus-top-induced turbulence mixing has been introduced (mfscuq.f; previously, it was an eddy diffusion form) - For local turbulence mixing, a TKE closure model is used. - - -\section v6_pbl_enh CCPP Physics Updates -\version CCPP v6.0.0 - -- Wind shear effect in characteristic mixing length calculation is included, which +- Wind shear effect in characteristic mixing length calculation is included, which reduces the mixing length in a strong shear environment such as a hurricane. -- To better predict surface inversion as well as capping inversion near the PBL top, -background diffusivity in the inversion layers is reduced as a function of surface +- To better predict surface inversion as well as capping inversion near the PBL top, +background diffusivity in the inversion layers is reduced as a function of surface roughness and green vegetation fraction. -- To reduce the PBL overgrowth, the PBL updraft overshoot is not only limited by -bulk Richardson number-based-PBL depth, but the virtual potential temperature at -top of the surface layer rather than that at the model first layer is also used as -the near-surface virtual potential temperature in the bulk-Richardson number +- To reduce the PBL overgrowth, the PBL updraft overshoot is not only limited by +bulk Richardson number-based-PBL depth, but the virtual potential temperature at +top of the surface layer rather than that at the model first layer is also used as +the near-surface virtual potential temperature in the bulk-Richardson number computation. This helps to largely suppress the unrealistic widespread popcorn-like precipitation. - Updraft entrainment rates for moisture, hydrometeors, and tracers are increased by about 30%. -- A positive definite total variation diminishing (TVD) mass-flux transport scheme for moisture, hydrometeors, +- A positive definite total variation diminishing (TVD) mass-flux transport scheme for moisture, hydrometeors, and tracers and a method for removing negative tracer mixing ratio values have been implemented. \sa NCEP Office Note 505 \cite https://doi.org/10.25923/cybh-w893 and 506 \cite https://doi.org/10.25923/5051-3r70 + +\section v6_pbl_enh CCPP Physics Updates +\version UFS-SRW v3.0.0 +- To reduce the negative hurricane intensity biases, a parameterization for environmental wind shear effect +is included in the GFS TKE-EDMF PBL and cumulus schemes. In addition, the entrainment rates are enhanced +proportional to the sub-cloud or PBL mean TKE (turbulent kinetic energy) when TKE is larger than a threshold +value. + +- To enhance the underestimated CAPE forecasts in the GFS, the entrainment rate in the TKE-EDMF PBL scheme is +increased as a function of vegetation fraction and surface roughness length. + + \section intra_satmedmfvdifq Intraphysics Communication - \ref arg_table_satmedmfvdifq_run diff --git a/physics/docs/pdftxt/suite_input.nml.txt b/physics/docs/pdftxt/suite_input.nml.txt index 11d33db1c..e986fc322 100644 --- a/physics/docs/pdftxt/suite_input.nml.txt +++ b/physics/docs/pdftxt/suite_input.nml.txt @@ -222,10 +222,13 @@ show some variables in the namelist that must match the SDF. xkzm_h \ref satmedmfvdifq background vertical diffusion for heat and q 1.0d0 xkzm_m \ref satmedmfvdifq background vertical diffusion for momentum 1.0d0 xkzm_s \ref satmedmfvdifq sigma threshold for background mom. diffusion 1.0d0 -dspfac \ref satmedmfvdifq TKE dissipative heating factor 1.0 +dspfac \ref satmedmfvdifq TKE dissipative heating factor 1.0 bl_upfr \ref satmedmfvdifq updraft fraction in boundary layer mass flux scheme 0.13 bl_dnfr \ref satmedmfvdifq downdraft fraction in boundary layer mass flux scheme 0.1 -grav_settling mynnedmf_wrapper flag to activate gravitational settling of cloud droplets as described in Nakanishi (2000) \cite nakanishi_2000 0 +rlmx \ref satmedmfvdifq maximum allowed mixing length in boundary layer mass flux scheme 300. +elmx \ref satmedmfvdifq maximum allowed dissipation mixing length in boundary layer mass flux scheme 300. +sfc_rlm \ref satmedmfvdifq choice of near surface mixing lenghth in boundary layer mass flux scheme 0 +tc_pbl \ref satmedmfvdifq control for TC applications in the PBL scheme 0 bl_mynn_mixlength mynnedmf_wrapper flag for different version of mixing length formulation \n
    • 0: Original form from Nakanishi and Niino (2009) \cite NAKANISHI_2009 . NO scale-awareness is applied to the master mixing length, regardless of "scaleware" setting @@ -518,7 +521,6 @@ show some variables in the namelist that must match the SDF.
    • 5: MODIS-RUC (21 category, NOAH WRFv4 only)
    2 -nvegcat isot lsm_noah, lsm_ruc, \ref noahmpdrv flag for soil type dataset choice:\n
    • 0: Zobler soil type (9 category) @@ -616,22 +618,42 @@ show some variables in the namelist that must match the SDF.
    1 iopt_trs \ref noahmpdrv options for thermal roughness scheme:\n -
      -
    • 1: z0h=z0m -
    • 2: canopy based czil -
    • 3: ec -
    • 4: kb inversed -
    - 2 -mosaic_lu -mosaic_soil -isncond_opt -isncovr_opt +
      +
    • 1: z0h=z0m +
    • 2: canopy based czil +
    • 3: ec +
    • 4: kb inversed +
    + 2 +mosaic_lu \ref lsm_ruc control for use of fractional landuse in RUC land surface model +
      +
    • 1: use of fractional landuse in RUC LSM +
    + 0 +mosaic_soil \ref lsm_ruc control for use of fractional soil in RUC land surface model +
      +
    • 1: use of fractional soil in RUC LSM +
    + 0 +isncond_opt \ref lsm_ruc control for soil thermal conductivity option in RUC land surface model +
      +
    • 1: constant +
    • 2: Sturm et al.(1997) \cite sturm_1997 +
    + 1 +isncovr_opt \ref lsm_ruc control for snow cover fraction option in RUC land surface model +
      +
    • 1: original formulation using threshold snow depth to compute snow fraction +
    • 2: Niu-Yang(2007) \cite Niu_2007 +
    • 3: updated Niu-Yang similar to Noah MP +
    + 1 \b Parameters \b related \b to \b other \b surface \b scheme \b options -lkm -iopt_lake -lakedepth_threshold -lakefrac_threshold +lkm \ref clm_lake 0: no lake; 1: lake; 2: lake&nsst 0 +iopt_lake \ref clm_lake 1: flake; 2: CLM lake 2 +lakedepth_threshold \ref clm_lake lakedepth must be greater than this value to enable a lake model 1.0 +lakefrac_threshold \ref clm_lake lakefrac must be greater than this value to enable a lake model 0.0 +use_lake2m \ref clm_lake use 2m T&Q from CLM lake model .false. nstf_name(5) sfc_nst NSST related paramters:\n
    • nstf_name(1): 0=NSST off, 1= NSST on but uncoupled, 2= NSST on and coupled diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index 75925a5f3..73fc4aff8 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -22,7 +22,7 @@ module satmedmfvdifq !! and to reduce the negative wind speed bias in upper troposphere !! !! Incorporate the LES-based changes for TC simulation -!! (Chen et al.,2022, https://doi.org/10.1175/WAF-D-21-0168.1) +!! (Chen et al.,2022 \cite Chen_2022) !! with additional improvements on MF working with Cu schemes !! Xiaomin Chen, 5/2/2022 !! @@ -443,7 +443,9 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & endif enddo ! -! compute a function for green vegetation fraction and surface roughness +!> - Compute a function for green vegetation fraction and surface roughness. +!! Entrainment rate in updraft is a function of vegetation fraction and surface +!! roughness length ! do i = 1,im tem = (sigmaf(i) - vegflo) / (vegfup - vegflo) @@ -745,7 +747,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & endif enddo ! -! compute mean tke within pbl +!> - Compute mean tke within pbl ! do i = 1, im sumx(i) = 0. @@ -766,8 +768,8 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & endif enddo ! -! compute wind shear term as a sink term for updraft and downdraft -! velocity +!> - Compute wind shear term as a sink term for updraft and downdraft +!! velocity ! kps = max(kmpbl, kmscu) do k = 2, kps From 8cd25865431326adcb0baba7cf692124abcea5d7 Mon Sep 17 00:00:00 2001 From: Man Zhang Date: Thu, 13 Jul 2023 10:45:18 -0600 Subject: [PATCH 300/380] narrative description for previous update --- physics/docs/pdftxt/GFS_SAMFdeep.txt | 2 -- physics/docs/pdftxt/THOMPSON.txt | 9 ++++----- 2 files changed, 4 insertions(+), 7 deletions(-) diff --git a/physics/docs/pdftxt/GFS_SAMFdeep.txt b/physics/docs/pdftxt/GFS_SAMFdeep.txt index d41763c37..1112cb05c 100644 --- a/physics/docs/pdftxt/GFS_SAMFdeep.txt +++ b/physics/docs/pdftxt/GFS_SAMFdeep.txt @@ -65,8 +65,6 @@ rain conversion rate, entrainment and detrainment rates, overshooting layers, and maximum allowable cloudbase mass flux (as of June 2018). -\b CCPP \b v6.0.0 \b Updates - \subsection ca_page Cellular Automata Stochastic Convective Organization Scheme \b Scientific \b Background diff --git a/physics/docs/pdftxt/THOMPSON.txt b/physics/docs/pdftxt/THOMPSON.txt index fed003ebd..4ad481887 100644 --- a/physics/docs/pdftxt/THOMPSON.txt +++ b/physics/docs/pdftxt/THOMPSON.txt @@ -70,10 +70,8 @@ for the model to provide useful guidance for aircraft icing forecasts - Can account for cloud phase changes and provides a sound physical basis for diagnosing precipitation type reaching the ground -\section v6_enh_thompson CCPP Physics Updates -\version CCPP v6.0.0 -Three mechanisms are available improve the stability of the scheme for weather forecast applications: +Recently, three mechanisms have been implemented to improve the stability of the scheme for weather forecast applications: \a inner \a loop, \a subcycle, and \a semi-Lagrangian \a sedimentation \a of \a rain \a and \a graupel. The inner loop and the subcycle are similar in that the physics time step is subdivided and the scheme is activated more often than others in the physics suite. However, they differ in implementation. @@ -82,9 +80,10 @@ Conversely, the subcycle method is controlled by CCPP Framework through the "sub The two methods should be used exclusively. The Semi-Lagrangian sedimentation of rain and graupel (based on Juang and Hong 2010 \cite Henry_Juang_2010 ) increases numerical stability by applying the subtime step only to sedimentation computation. Two namelist variables control the usage of the semi-Lagrangian sedimentation, \p sedi_semi and \p decfl. -\p sedi_semi is set to ‘true’ to activate the method. Decfl is a parameter that needs to avoid deformation of the arriving grids, currently, "10". +\p sedi_semi is set to ‘true’ to activate the method. \p Decfl is a parameter that needs to avoid deformation of the arriving grids, currently, "10". -\version SRW v3.0.0 +\section v6_enh_thompson CCPP Physics Updates +\version UFS-SRW v3.0.0 - The ice generation supersaturation requirement for nonaerosol option is reduced from 0.25 to 0.15. The purpose is to generate more ice in the upper level and reduce the OLR bias. From 2a56d372655acc6bf0a7da4fa0ccff3beb6727cf Mon Sep 17 00:00:00 2001 From: "Michael Kavulich, Jr" Date: Fri, 30 Jun 2023 13:39:16 -0600 Subject: [PATCH 301/380] Host large images remotely --- physics/docs/pdftxt/CLM_LAKE.txt | 6 +++--- physics/docs/pdftxt/RUCLSM.txt | 4 ++-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/physics/docs/pdftxt/CLM_LAKE.txt b/physics/docs/pdftxt/CLM_LAKE.txt index e0a8d9209..d78244cb2 100644 --- a/physics/docs/pdftxt/CLM_LAKE.txt +++ b/physics/docs/pdftxt/CLM_LAKE.txt @@ -36,7 +36,7 @@ in the UFS SRW App, is capable of capturing the effect of lakes on regional heat Lake depths for the RRFS lake configuration (Fig.1) are assigned from a global dataset provided by Kourzeneva et al.(2012) \cite Kourzeneva_2012, this dataset is referred to as GLOBv3 bathymetry in the UFS_UTL. -\image html Lake_depths_RRFS3km.png "Figure 1: Lake depths for lakes in the 3-km RRFS domain." width=600 +@image html https://user-images.githubusercontent.com/12705538/250180794-76af93a2-a7ba-4e9a-9478-5657198862b8.png "Figure 1: Lake depths for lakes in the 3-km RRFS domain." width=600 To cold-start the CLM lake model in the UFS SRW App: - Use the CLM option in the input.nml @@ -48,8 +48,8 @@ To cold-start the CLM lake model in the UFS SRW App: - Lake ice at the top level is initialized from the GFS ice concentration The differences of surface variables from the experimental RRFS 6-h forecast with/without CLM lake model are shown in Figure 2 for 2-m temperature and in Figure 3 for 2-m dewpoint. -\image html diff_t2m_lake_rrfs.png "Figure 2: Differences of 2-m temperature between the RRFS coupled to the CLM model and the RRFS without CLM." width=600 -\image html diff_td2m_lake_rrfs.png "Figure 3: Differences of 2-m dew point between the RRFS coupled to the CLM model and the RRFS without CLM." width=600 +@image html https://user-images.githubusercontent.com/12705538/250180790-63159300-33f6-4b34-9e9c-b65885213c30.png "Figure 2: Differences of 2-m temperature between the RRFS coupled to the CLM model and the RRFS without CLM." width=600 +@image html https://user-images.githubusercontent.com/12705538/250180787-8fc9a820-5f80-4f06-b50a-88b2d20ebc53.png "Figure 3: Differences of 2-m dew point between the RRFS coupled to the CLM model and the RRFS without CLM." width=600 diff --git a/physics/docs/pdftxt/RUCLSM.txt b/physics/docs/pdftxt/RUCLSM.txt index 7a39faf84..a836e7b93 100644 --- a/physics/docs/pdftxt/RUCLSM.txt +++ b/physics/docs/pdftxt/RUCLSM.txt @@ -43,7 +43,7 @@ to determine the uncertainty range for the selected parameters in the RUC LSM. ## RUC LSM characteristics that differ from Noah LSM: \image html ruc_lsm_veg_soil.png "Figure 1: RUC LSM Vegetation and Soil Model (Courtesy of T.G. Smirnova) " width=900 -\image html ruc_ranking.png "Figure 2: Model ranking as a function of normalized root mean square error of snow water equivalent and surface temperature (Courtesy of C. Menard)" width=900 +@image html https://user-images.githubusercontent.com/12705538/250180784-d50a3d4c-93db-4d8d-b12d-2c0ca22da5c3.png "Figure 2: Model ranking as a function of normalized root mean square error of snow water equivalent and surface temperature (Courtesy of C. Menard)" width=900 - \b Implicit \b solution of energy and moisture budgets in the layer spanning the ground surface - \b 9 \b soil \b levels with high vertical resolution near surface RUC LSM has more levels in soil than \ref GFS_NOAH model with higher resolution near the interface with the atmosphere @@ -80,7 +80,7 @@ Snow forms additional two layers on top of soil in RUC LSM \image html ruc_lsm_mosaic.png "Figure 4: 'Mosaic' approach for patchy snow (Courtesy of T.G. Smirnova) " width=900 - New: additional options to compute snow cover fraction (\p isncovr_opt =2 and 3, Niu and Yang (2007) \cite Niu_2007). These options allowed to reduce overprediction of number of grid cells fully covered with snow which further reduced cold-biases over snow. Figure 5 demonstrates that option 3 of snow cover fraction computation (\p isncovr_opt = 3) in the UFS-based regional model matches better the satellite data for the test case on 6 February 2022. - New: added an option to use of a new formulation of snow thermal conductivity (\p isncond_opt = 2, Sturm et al. (1997) \cite sturm_1997); -\image html sncov_rrfs_ruc.png "Figure 5: Snow cover fraction from MODIS (a,b), Regional UFS-based system (RRFS) original (c), and modified with isncover_opt=3 (d), 6 February 2022. (Courtesy of T.G. Smirnova)" width=900 +@image html https://user-images.githubusercontent.com/12705538/250180782-925303ec-7751-4d7e-be8f-b3f1323f35d4.png "Figure 5: Snow cover fraction from MODIS (a,b), Regional UFS-based system (RRFS) original (c), and modified with isncover_opt=3 (d), 6 February 2022. (Courtesy of T.G. Smirnova)" width=900 - Iterative snow melting algorithm; - Density of snow on the ground - a function of compaction parameter and snow depth and temperature; - Snow albedo - a function of temperature and snow fraction; From 9e35de10adecef6bdb21a53ea6d9e5350384c60c Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Mon, 24 Jul 2023 15:03:57 +0000 Subject: [PATCH 302/380] Changes to logging and initialization of the CLM Lake Model. 1. Use ice thickness hice(i) to find the level in the lake where ice is zero. 2. Do not allow lake temperature to be below freezing point if there is no ice. 3. If there is no snow or ice, do not allow surface lake temperature to be below freezing point. These changes fixed the problem with large errors in the energy budget at the beginning of the cold-start run with lakes. 4. Added flag to turn on debug print statements in the CLM lake model. --- physics/clm_lake.f90 | 295 ++++++++++++++++++++++++----------- physics/clm_lake.meta | 14 ++ physics/module_sf_ruclsm.F90 | 2 + 3 files changed, 223 insertions(+), 88 deletions(-) diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90 index 4fc4112ce..21843af58 100644 --- a/physics/clm_lake.f90 +++ b/physics/clm_lake.f90 @@ -42,6 +42,7 @@ MODULE clm_lake integer, parameter, public :: kind_lake = kind_dbl_prec logical :: LAKEDEBUG = .false. ! Enable lots of checks and debug prints and errors + logical :: DEBUG_PRINT = .false. ! Enable lots of checks and debug prints and errors logical, parameter :: PERGRO = .false. @@ -167,7 +168,7 @@ logical function limit_temperature_by_climatology(xlat_d,xlon_positive) .not. (xlon_d.gt.-112.104 .and. xlon_d.lt.-112.100))then if(xlat_d.gt.39.5 .and. xlat_d.lt.41.22) then - if(lakedebug) then + if(debug_print) then print *,'The Great Salt Lake south of 41.22 N, lat,lon',xlat_d,xlon_d endif limit_temperature_by_climatology = .true. @@ -175,7 +176,7 @@ logical function limit_temperature_by_climatology(xlat_d,xlon_positive) elseif(( xlat_d.ge.41.22 .and. xlat_d.lt.42.) .and. .not. & ! excludes Willard Bay (xlat_d.gt.41.352 .and. xlat_d.lt.41.354)) then - if(lakedebug) then + if(debug_print) then print *,'The Great Salt Lake north of 41.22 N xlat_d,xlon_d ',xlat_d,xlon_d endif !print *,'Ice fraction on the GSL ', i,j,lake_icefrac3d(i,:,j) @@ -200,30 +201,31 @@ subroutine is_salty(xlat_d,xlon_positive, cannot_freeze, salty) xlon_d = xlon_positive if(xlon_d>180) xlon_d = xlon_d - 360 + ! for the Great Salt Lake cannot_freeze = limit_temperature_by_climatology(xlat_d,xlon_d) salty = cannot_freeze - other_locations: if(include_all_salty_locations) then ! --- The Mono Lake in California, salinity is 75 ppt with freezing point at ! --- -4.2 C (Stan). The Mono Lake lat/long (37.9-38.2, -119.3 - 118.8) if (xlon_d.gt.-119.3.and. xlon_d.lt.-118.8) then if(xlat_d.gt.37.9 .and. xlat_d.lt.38.2) then salty = .true. - if(lakedebug) then + if(debug_print) then print *,'Salty Mono Lake, i,j',xlat_d,xlon_d endif endif ! xlat_d endif ! xlon_d + other_locations: if(include_all_salty_locations) then ! --- Caspian Sea and Dead Sea are salty too (Sam, Tanya) if ( xlat_d>36.5_kind_phys .and. xlat_d<47.1_kind_phys .and. xlon_d>46.8_kind_phys .and. xlon_d<55.0_kind_phys ) then - if(lakedebug) then + if(debug_print) then print *,'Salty Caspian Sea ',xlat_d,xlon_d endif salty = .true. end if if ( xlon_d>35.3 .and. xlon_d<35.6 .and. xlat_d>31.3 .and. xlat_d<31.8) then - if(lakedebug) then + if(debug_print) then print *,'Salty Dead Sea ',xlat_d,xlon_d endif salty = .true. @@ -239,7 +241,7 @@ end subroutine is_salty !! SUBROUTINE clm_lake_run( & ! Model time and metadata: - im, km, me, master, fhour, IDATE, kdt, & + flag_restart, im, km, me, master, fhour, IDATE, kdt, & ! Configuration and initialization: iopt_lake, iopt_lake_clm, min_lakeice, lakedepth_default, use_lakedepth, & @@ -280,6 +282,7 @@ SUBROUTINE clm_lake_run( & ! ! Model time and metadata: ! + LOGICAL , INTENT (IN) :: flag_restart INTEGER , INTENT (IN) :: im,km,me,master INTEGER, INTENT(IN) :: IDATE(4), kdt REAL(KIND_PHYS), INTENT(IN) :: fhour @@ -300,7 +303,7 @@ SUBROUTINE clm_lake_run( & ! REAL(KIND_PHYS), DIMENSION(:), INTENT(IN):: & tg3, pgr, zlvl, qvcurr, xlat_d, xlon_d, ch, cm, & - dlwsfci, dswsfci, oro_lakedepth, wind, rho0, tsfc, & + dlwsfci, dswsfci, oro_lakedepth, wind, rho0, & rainncprv, raincprv REAL(KIND_PHYS), DIMENSION(:,:), INTENT(in) :: gu0, gv0, prsi, gt0, phii LOGICAL, DIMENSION(:), INTENT(IN) :: flag_iter @@ -311,7 +314,7 @@ SUBROUTINE clm_lake_run( & ! REAL(KIND_PHYS), DIMENSION(:), INTENT(INOUT) :: & evap_wat, evap_ice, hflx_wat, hflx_ice, gflx_wat, gflx_ice, & - ep1d_water, ep1d_ice, tsurf_water, tsurf_ice, tsfc_wat, tisfc, & + ep1d_water, ep1d_ice, tsurf_water, tsurf_ice, tsfc_wat, tisfc, tsfc, & weasdi, snodi, hice, qss_water, qss_ice, & cmm_water, cmm_ice, chh_water, chh_ice, & uustar_water, uustar_ice, lake_t_snow, albedo, zorlw, & @@ -451,6 +454,7 @@ SUBROUTINE clm_lake_run( & dtime=dtp ! Initialize any uninitialized lake points. + if(.not.flag_restart) then call lakeini(kdt=kdt, ISLTYP=ISLTYP, gt0=gt0, snowd=snowd, weasd=weasd, & lakedepth_default=lakedepth_default, fhour=fhour, & oro_lakedepth=oro_lakedepth, savedtke12d=savedtke12d, snowdp2d=snowdp2d, & @@ -458,7 +462,7 @@ SUBROUTINE clm_lake_run( & lake_icefrac3d=lake_icefrac3d, z_lake3d=z_lake3d, dz_lake3d=dz_lake3d, & t_soisno3d=t_soisno3d, h2osoi_ice3d=h2osoi_ice3d, h2osoi_liq3d=h2osoi_liq3d, & h2osoi_vol3d=h2osoi_vol3d, z3d=z3d, dz3d=dz3d, zi3d=zi3d, watsat3d=watsat3d, & - csol3d=csol3d, tkmg3d=tkmg3d, fice=fice, min_lakeice=min_lakeice, & + csol3d=csol3d, tkmg3d=tkmg3d, fice=fice, hice=hice, min_lakeice=min_lakeice, & tsfc=tsfc, & use_lake_model=use_lake_model, use_lakedepth=use_lakedepth, tkdry3d=tkdry3d, & tksatu3d=tksatu3d, im=im, prsi=prsi, xlat_d=xlat_d, xlon_d=xlon_d, & @@ -480,6 +484,7 @@ SUBROUTINE clm_lake_run( & errflg=1 return endif + endif ! .not. restart lake_points=0 snow_points=0 @@ -498,14 +503,14 @@ SUBROUTINE clm_lake_run( & wght2 = day_of_month/month_length(month) if(wght2<0 .or. wght2>1) then - if(lakedebug) then + if(debug_print) then write(0,*) 'Warning: wght2 is not 0..1: ',wght2 endif wght2 = max(0.0_kind_lake,min(1.0_kind_lake,wght2)) endif wght1 = 1.0_kind_lake - wght2 - if(LAKEDEBUG .and. me==0) then + if(debug_print ) then print *,'month,num1,num2,wght1,wght2',month,num1,num2,wght1,wght2 endif @@ -516,13 +521,13 @@ SUBROUTINE clm_lake_run( & call is_salty(xlat_d(i),xlon_d(i),salty_flag,cannot_freeze_flag) if(salty_flag) then - salty(i) = 1 + salty(i) = 1 ! The Great Salt Lake and Mono Lake else salty(i) = 0 endif if(cannot_freeze_flag) then - cannot_freeze(i) = 1 + cannot_freeze(i) = 1 ! only the Great Salt Lake else cannot_freeze(i) = 0 endif @@ -570,13 +575,7 @@ SUBROUTINE clm_lake_run( & t_grnd(c) = t_grnd2d(i) do k = 1,nlevlake t_lake(c,k) = t_lake3d(i,k) - !-- If T of salty lakes is above the freezing point, keep them ice free - if(salty(i)==1 .and. t_lake(c,k) > tfrz .and. lake_icefrac3d(i,k) > 0.) then - lake_icefrac(c,k) = 0. - else - lake_icefrac(c,k) = lake_icefrac3d(i,k) - endif - !lake_icefrac(c,k) = lake_icefrac3d(i,k) + lake_icefrac(c,k) = lake_icefrac3d(i,k) z_lake(c,k) = z_lake3d(i,k) dz_lake(c,k) = dz_lake3d(i,k) enddo @@ -633,23 +632,29 @@ SUBROUTINE clm_lake_run( & do c = 1,column if(cannot_freeze(i) == 1) then - t_grnd(c) = max(274.5_kind_lake,t_grnd(c)) + ! The Great Salt Lake do k = 1,nlevlake - t_lake(c,k) = max(274.5_kind_lake,t_lake(c,k)) - lake_icefrac(c,k) = 0. + lake_icefrac(c,k) = 0._kind_lake enddo - endif - - if(salty(i)/=0) then - Tclim = tfrz + wght1*saltlk_T(num1) & - + wght2*saltlk_T(num2) - if(lakedebug) print *,'Tclim,tsfc,t_lake3d',i,Tclim,t_grnd(c),t_lake(c,:),t_soisno(c,:) - t_grnd(c) = min(Tclim+3.0_kind_lake,(max(t_grnd(c),Tclim-3.0_kind_lake))) - do k = 1,nlevlake - t_lake(c,k) = min(Tclim+3.0_kind_lake,(max(t_lake(c,k),Tclim-3.0_kind_lake))) - enddo - t_soisno(c,1) = min(Tclim+3.0_kind_lake,(max(t_soisno(c,1),Tclim-3.0_kind_lake))) - if(lakedebug) print *,'After Tclim,tsfc,t_lake3d',i,Tclim,t_grnd(c),t_lake(c,:),t_soisno(c,:) + ! bound lake temperture with the climatology + Tclim = tfrz + wght1*saltlk_T(num1) & + + wght2*saltlk_T(num2) + if(debug_print) print *,'GSL - Tclim,tsfc,t_lake3d',i,Tclim,t_grnd(c),t_lake(c,:),t_soisno(c,:) + t_grnd(c) = min(Tclim+3.0_kind_lake,(max(t_grnd(c),Tclim-3.0_kind_lake))) + do k = 1,nlevlake + t_lake(c,k) = min(Tclim+3.0_kind_lake,(max(t_lake(c,k),Tclim-3.0_kind_lake))) + enddo + t_soisno(c,1) = min(Tclim+3.0_kind_lake,(max(t_soisno(c,1),Tclim-3.0_kind_lake))) + if(debug_print) print *,'GSL - after Tclim,tsfc,t_lake3d',i,Tclim,t_grnd(c),t_lake(c,:),t_soisno(c,:) + elseif(salty(i) == 1) then + ! Mono Lake never freezes, its temperature is above freezing point = -4.2 C + t_grnd(c) = max(tfrz-4.2_kind_lake,t_grnd(c)) + do k = 1,nlevlake + lake_icefrac(c,k) = 0._kind_lake + t_lake(c,k) = max(tfrz-4.2_kind_lake,t_lake(c,k)) + enddo + t_soisno(c,1) = max(tfrz-4.2_kind_lake,t_soisno(c,1)) + if(debug_print) print *,'Mono - tsfc,t_lake3d',i,t_grnd(c),t_lake(c,:),t_soisno(c,:) endif savedtke12d(i) = savedtke1(c) @@ -689,7 +694,10 @@ SUBROUTINE clm_lake_run( & gflx_wat(I) = eflx_gnet(c) ![W/m/m] upward_heat_flux_in_soil_over_water ep1d_water(i) = eflx_lh_tot(c) ![W/m/m] surface_upward_potential_latent_heat_flux_over_water tsurf_water(I) = t_grnd(c) ![K] surface skin temperature after iteration over water + tsurf_ice(i) = t_grnd(i) ! surface_skin_temperature_after_iteration_over_ice tsfc_wat(i) = t_grnd(c) ![K] surface skin temperature over water + tisfc(i) = t_grnd(c) + tsfc(i) = t_grnd(c) lake_t2m(I) = t_ref2m(c) ![K] temperature_at_2m_from_clm_lake lake_q2m(I) = q_ref2m(c) ! [frac] specific_humidity_at_2m_from_clm_lake albedo(i) = ( 0.6 * lake_icefrac3d(i,1) ) + & ! mid_day_surface_albedo_over_lake @@ -716,7 +724,9 @@ SUBROUTINE clm_lake_run( & cmm_water(i) = cm(i)*wind(i) ! surface_drag_wind_speed_for_momentum_in_air_over_water ice_point: if(fice(i)>=min_lakeice) then + ! Icy lake ! Most ice variables are identical to water variables. + if(debug_print) print *,'Icy xlat_d(i),xlon_d(i),frac_ice,frac_grid ',xlat_d(i),xlon_d(i),frac_ice,frac_grid if(frac_ice .or. frac_grid) then evap_ice(i) = evap_wat(i) ! kinematic_surface_upward_latent_heat_flux_over_ice hflx_ice(i) = hflx_wat(i) ! kinematic_surface_upward_sensible_heat_flux_over_ice @@ -728,11 +738,13 @@ SUBROUTINE clm_lake_run( & ! uustar_ice(i) = uustar_water(i) ! surface_friction_velocity_over_ice endif - tsurf_ice(i) = tsurf_water(i) ! surface_skin_temperature_after_iteration_over_ice + tsurf_ice(i) = t_grnd(i) ! surface_skin_temperature_after_iteration_over_ice tisfc(i) = t_grnd(c) ! surface_skin_temperature_over_ice + tsfc(i) = t_grnd(c) ! surface_skin_temperature_over_ice weasdi(i) = h2osno(c) ! water_equivalent_accumulated_snow_depth_over_ice - snodi(i) = snowdp(c) ! surface_snow_thickness_water_equivalent_over_ice - tsurf_ice(i) = t_grnd(c) ! surface_skin_temperature_after_iteration_over_ice + snodi(i) = snowdp(c)*1.e3 ! surface_snow_thickness_water_equivalent_over_ice + weasd(i) = weasdi(i) + snowd(i) = snodi(c) ! surface_snow_thickness_water_equivalent_over_ice ! Ice points are icy: icy(i)=.true. ! flag_nonzero_sea_ice_surface_fraction @@ -754,8 +766,11 @@ SUBROUTINE clm_lake_run( & icy(i)=.false. weasdi(i) = 0 snodi(i) = 0 + weasd(i) = 0 + snowd(i) = 0 tisfc(i) = t_grnd(c) tsurf_ice(i) = tisfc(i) + tsfc(i) = t_grnd(c) hice(i) = 0 fice(i) = 0 endif ice_point @@ -774,7 +789,7 @@ SUBROUTINE clm_lake_run( & endif if_lake_is_here ENDDO lake_top_loop - if(LAKEDEBUG .and. lake_points>0 .and. (kdt<3 .or. mod(kdt,30)==3)) then + if(debug_print .and. lake_points>0 .and. (kdt<3 .or. mod(kdt,30)==3)) then 3082 format('lake points processed in timestep ',I0,' by rank ',I0,' = ',I0,' snow=',I0,' ice=',I0) print 3082,kdt,me,lake_points,snow_points,ice_points endif @@ -956,7 +971,7 @@ SUBROUTINE LakeMain(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, & !I t_lake,t_soisno,h2osoi_liq, & h2osoi_ice,savedtke1, & watsat, tksatu, tkmg, tkdry, csol, dtime, & - frac_iceold,qflx_snomelt,imelt,errmsg,errflg) + frac_iceold,qflx_snomelt,imelt,errmsg,errflg,xlat_d,xlon_d) if(errflg/=0) then return ! State is invalid now, so pass error to caller. endif @@ -1486,7 +1501,7 @@ SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q, qflx_evap_tot(p) = qflx_evap_soi(p) eflx_lh_tot(p) = htvp(c)*qflx_evap_soi(p) eflx_lh_grnd(p) = htvp(c)*qflx_evap_soi(p) - if(LAKEDEBUG) then + if(debug_print) then 1604 format('CLM_Lake ShalLakeFluxes: c=',I0,' sensible heat = ',F12.4,' latent heat =',F12.4, & ' ground temp = ', F12.4, ' h2osno = ', F12.4, ' at xlat_d=',F10.3,' xlon_d=',F10.3) print 1604, c, eflx_sh_tot(p), eflx_lh_tot(p), t_grnd(c), h2osno(c),xlat_d,xlon_d @@ -1564,7 +1579,7 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! t_lake,t_soisno,h2osoi_liq, & h2osoi_ice,savedtke1, & watsat, tksatu, tkmg, tkdry, csol, dtime, & - frac_iceold,qflx_snomelt,imelt,errmsg,errflg) + frac_iceold,qflx_snomelt,imelt,errmsg,errflg,xlat_d,xlon_d) !======================================================================================================= ! !DESCRIPTION: ! Calculates temperatures in the 20-25 layer column of (possible) snow, @@ -1652,6 +1667,7 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! implicit none !in: + real(kind_lake),intent(in) :: xlat_d,xlon_d integer, intent(inout) :: errflg real(kind_lake), intent(in) :: watsat(1,nlevsoil) ! volumetric soil water at saturation (porosity) real(kind_lake), intent(in) :: tksatu(1,nlevsoil) ! thermal conductivity, saturated soil [W/m-K] @@ -2015,6 +2031,15 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! + cfus*dz_lake(c,j)*(1._kind_lake-lake_icefrac(c,j)) !& ! + (cwat-cice_eff)*lake_icefrac(c)*tfrz*dz_lake(c,j) !enthalpy reconciliation term t_lake_bef(c,j) = t_lake(c,j) + if(debug_print) then + if (abs(xlat_d-52.1152).lt.0.1 .and. & + abs(xlon_d-260.405).lt.0.1)then + print *,' ocvts(c) at xlat_d,xlon_d',xlat_d,xlon_d + print *,'j,dz_lake(c,j) ', j,dz_lake(c,j) + print*,'cv_lake(c,j),lake_icefrac(c,j),t_lake(c,j),cfus,ocvts(c)', & + cv_lake(c,j),lake_icefrac(c,j),t_lake(c,j),cfus,ocvts(c) + endif + endif end do end do @@ -2030,6 +2055,15 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! ocvts(c) = ocvts(c) + cv(c,j)*(t_soisno(c,j)-tfrz) & + hfus*h2osoi_liq(c,j) !& ! + (cpliq-cpice)*h2osoi_ice(c,j)*tfrz !enthalpy reconciliation term + if(debug_print) then + if (abs(xlat_d-52.1152).lt.0.1 .and. & + abs(xlon_d-260.405).lt.0.1)then + print *,' ocvts(c) at xlat_d,xlon_d',xlat_d,xlon_d + print *,' j,jtop(c)',j,jtop(c),'h2osoi_liq(c,j) ',h2osoi_liq(c,j),'h2osoi_ice(c,j)',h2osoi_ice(c,j) + print *,' cv(c,j),t_soisno(c,j),hfus,ocvts(c)',c,j,cv(c,j),t_soisno(c,j),hfus,ocvts(c) + print *,' h2osno(c)',h2osno(c) + endif + endif if (j == 1 .and. h2osno(c) > 0._kind_lake .and. j == jtop(c)) then ocvts(c) = ocvts(c) - h2osno(c)*hfus end if @@ -2373,9 +2407,9 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! c = filter_shlakec(fc) if (rhow(c,j) > rhow(c,j+1) .or. & (lake_icefrac(c,j) < 1._kind_lake .and. lake_icefrac(c,j+1) > 0._kind_lake) ) then - if(LAKEDEBUG) then + if(debug_print) then if (i==1) then - print *, 'Convective Mixing in column ', c, '.' + print *, 'Convective Ice Mixing in column ', c, 'lake_icefrac(c,j) ',lake_icefrac(c,j),lake_icefrac(c,j+1) endif endif qav(c) = qav(c) + dz_lake(c,i)*(t_lake(c,i)-tfrz) * & @@ -2447,6 +2481,8 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! rhow(c,i) = (1._kind_lake - lake_icefrac(c,i)) * & 1000._kind_lake*( 1.0_kind_lake - 1.9549e-05_kind_lake*(abs(t_lake(c,i)-277._kind_lake))**1.68_kind_lake ) & + lake_icefrac(c,i)*denice + if (debug_print .and. lake_icefrac(c,j) > 0.)print *,'rhow(c,i),lake_icefrac(c,i),t_lake(c,i)', & + i,rhow(c,i),lake_icefrac(c,i),t_lake(c,i),denice end if end do end do @@ -2462,7 +2498,7 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! c = filter_shlakec(fc) cv_lake(c,j) = dz_lake(c,j) * (cwat*(1._kind_lake-lake_icefrac(c,j)) + cice_eff*lake_icefrac(c,j)) - if (LAKEDEBUG) then + if (debug_print .and. lake_icefrac(c,j) > 0.) then print *,'Lake Ice Fraction, c, level:', c, j, lake_icefrac(c,j) endif end do @@ -2485,6 +2521,15 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! + cfus*dz_lake(c,j)*(1._kind_lake-lake_icefrac(c,j)) !& ! + (cwat-cice_eff)*lake_icefrac(c)*tfrz*dz_lake(c,j) !enthalpy reconciliation term fin(c) = fin(c) + phi(c,j) + if(debug_print) then + if (abs(xlat_d-52.1152).lt.0.1 .and. & + abs(xlon_d-260.405).lt.0.1)then + print *,' ncvts(c) at xlat_d,xlon_d',xlat_d,xlon_d + print *,' new cv_lake(c,j),t_lake(c,j),cfus,lake_icefrac(c,j),ncvts(c),fin(c)', & + j,cv_lake(c,j),t_lake(c,j),cfus,lake_icefrac(c,j),ncvts(c),fin(c) + print *,' new dz_lake(c,j),fin(c),phi(c,j)',c,dz_lake(c,j),fin(c),phi(c,j) + endif + endif end do end do @@ -2499,6 +2544,15 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! ncvts(c) = ncvts(c) + cv(c,j)*(t_soisno(c,j)-tfrz) & + hfus*h2osoi_liq(c,j) !& ! + (cpliq-cpice)*h2osoi_ice(c,j)*tfrz !enthalpy reconciliation term + if(debug_print) then + if (abs(xlat_d-52.1152).lt.0.1 .and. & + abs(xlon_d-260.405).lt.0.1)then + print *,' ncvts(c) at xlat_d,xlon_d',xlat_d,xlon_d + print *,'new j,jtop(c)',j,jtop(c),'h2osoi_liq(c,j) ',h2osoi_liq(c,j),'h2osoi_ice(c,j)',h2osoi_ice(c,j) + print *,'new cv(c,j),t_soisno(c,j),hfus,ncvts(c)',c,j,cv(c,j),t_soisno(c,j),hfus,ncvts(c) + print *,'new h2osno(c)',h2osno(c) + endif + endif if (j == 1 .and. h2osno(c) > 0._kind_lake .and. j == jtop(c)) then ncvts(c) = ncvts(c) - h2osno(c)*hfus end if @@ -2514,21 +2568,44 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! p = filter_shlakep(fp) c = pcolumn(p) errsoi(c) = (ncvts(c)-ocvts(c)) / dtime - fin(c) - if( (LAKEDEBUG .and. abs(errsoi(c)) < 1._kind_lake) ) then -! .or. (.not.LAKEDEBUG .and. abs(errsoi(c)) < 10._kind_lake)) then + if(debug_print) then + if (abs(xlat_d-52.1152).lt.0.1 .and. & + abs(xlon_d-260.405).lt.0.1)then + print *,'xlat_d,xlon_d',xlat_d,xlon_d + print *,'errsoi(c),fin(c),ncvts(c),ocvts(c),dtime,lake_icefrac(c,:),h2osno(c)', & + errsoi(c),fin(c),ncvts(c),ocvts(c),dtime,lake_icefrac(c,:),h2osno(c) + endif + endif + if( .not.LAKEDEBUG ) then + if (abs(errsoi(c)) < 10._kind_lake) then + eflx_sh_tot(p) = eflx_sh_tot(p) - errsoi(c) + eflx_sh_grnd(p) = eflx_sh_grnd(p) - errsoi(c) + eflx_soil_grnd(p) = eflx_soil_grnd(p) + errsoi(c) + eflx_gnet(p) = eflx_gnet(p) + errsoi(c) + if(debug_print) then + if (abs(errsoi(c)) > 1.e-1_kind_lake) then + print *,'errsoi incorporated at xlat_d,xlon_d',xlat_d,xlon_d + print *,'errsoi incorporated into sensible heat in ShalLakeTemperature: c, (W/m^2):', c, errsoi(c) + end if + endif + errsoi(c) = 0._kind_lake + endif + elseif ( LAKEDEBUG) then + if (abs(errsoi(c)) < 1._kind_lake) then eflx_sh_tot(p) = eflx_sh_tot(p) - errsoi(c) eflx_sh_grnd(p) = eflx_sh_grnd(p) - errsoi(c) eflx_soil_grnd(p) = eflx_soil_grnd(p) + errsoi(c) eflx_gnet(p) = eflx_gnet(p) + errsoi(c) - ! if (abs(errsoi(c)) > 1.e-3_kind_lake) then if (abs(errsoi(c)) > 1.e-1_kind_lake) then print *,'errsoi incorporated into sensible heat in ShalLakeTemperature: c, (W/m^2):', c, errsoi(c) end if errsoi(c) = 0._kind_lake - else if(LAKEDEBUG) then + else print *,'Soil Energy Balance Error at column, ', c, 'G, fintotal, column E tendency = ', & - eflx_gnet(p), fin(c), (ncvts(c)-ocvts(c)) / dtime - end if + eflx_gnet(p), fin(c), (ncvts(c)-ocvts(c)) / dtime,'xlat_d,xlon_d',xlat_d,xlon_d + print *,'ncvts(c),ocvts(c),dtime,errsoi(c)',ncvts(c),ocvts(c),dtime,errsoi(c),'xlat_d,xlon_d',xlat_d,xlon_d + end if + end if ! LAKEDEBUG end do ! This loop assumes only one point per column. @@ -3483,7 +3560,7 @@ subroutine ShalLakeHydrology(dz_lake,forc_rain,forc_snow, & h2osno(c) = 0._kind_lake snl(c) = 0 ! The rest of the bookkeeping for the removed snow will be done below. - if (LAKEDEBUG) then + if (debug_print) then print *,'Snow layers removed above unfrozen lake for column, snowice:', & c, sumsnowice(c) endif @@ -3633,7 +3710,7 @@ subroutine ShalLakeHydrology(dz_lake,forc_rain,forc_snow, & ! Insure water balance using qflx_qrgwl qflx_qrgwl(c) = forc_rain(g) + forc_snow(g) - qflx_evap_tot(p) - (endwb(c)-begwb(c))/dtime - if (LAKEDEBUG) then + if (debug_print) then print *,'c, rain, snow, evap, endwb, begwb, qflx_qrgwl:', & c, forc_rain(g), forc_snow(g), qflx_evap_tot(p), endwb(c), begwb(c), qflx_qrgwl(c) endif @@ -5141,18 +5218,19 @@ end subroutine MoninObukIni !! subroutine clm_lake_init(con_pi,karman,con_g,con_sbc,con_t0c,rhowater,con_csol,con_cliq, & con_hfus,con_hvap,con_rd,con_cp,rholakeice,clm_lake_debug, & - con_eps_model,con_fvirt_model,errmsg,errflg) + clm_debug_print,con_eps_model,con_fvirt_model,errmsg,errflg) implicit none real(kind_phys), intent(in) :: con_pi,karman,con_g,con_sbc,con_t0c, & rhowater,con_csol,con_cliq, con_hfus,con_hvap,con_rd,con_cp, & rholakeice,con_eps_model,con_fvirt_model INTEGER, INTENT(OUT) :: errflg CHARACTER(*), INTENT(OUT) :: errmsg - logical, intent(in) :: clm_lake_debug + logical, intent(in) :: clm_lake_debug,clm_debug_print integer :: i, j LAKEDEBUG = clm_lake_debug - if(LAKEDEBUG) then + DEBUG_PRINT = clm_debug_print + if(debug_print) then write(0,*) 'clm_lake_init' endif @@ -5249,7 +5327,7 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, z_lake3d, dz_lake3d, t_soisno3d, h2osoi_ice3d, & h2osoi_liq3d, h2osoi_vol3d, z3d, dz3d, & zi3d, watsat3d, csol3d, tkmg3d, & - fice, min_lakeice, tsfc, & + fice, hice, min_lakeice, tsfc, & use_lake_model, use_lakedepth, & tkdry3d, tksatu3d, im, prsi, & xlat_d, xlon_d, clm_lake_initialized, & @@ -5276,7 +5354,7 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, INTEGER , INTENT (IN) :: im, me, master, km, kdt REAL(KIND_PHYS), INTENT(IN) :: min_lakeice, fhour - REAL(KIND_PHYS), DIMENSION(IM), INTENT(INOUT):: FICE + REAL(KIND_PHYS), DIMENSION(IM), INTENT(INOUT):: FICE, hice REAL(KIND_PHYS), DIMENSION(IM), INTENT(IN):: TG3, xlat_d, xlon_d REAL(KIND_PHYS), DIMENSION(IM), INTENT(IN):: tsfc REAL(KIND_PHYS), DIMENSION(IM) ,INTENT(INOUT) :: clm_lake_initialized @@ -5343,6 +5421,8 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, integer :: numb_lak ! for debug character*256 :: message real(kind_lake) :: ht + real(kind_lake) :: rhosn + real(kind_lake) :: depth logical :: climatology_limits @@ -5385,45 +5465,45 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, cycle endif - snowdp2d(i) = snowd(i)*1e-3 ! SNOW in kg/m^2 and snowdp in m - h2osno2d(i) = weasd(i) ! mm - snl2d(i) = defval do k = -nlevsnow+1,nlevsoil h2osoi_liq3d(i,k) = defval h2osoi_ice3d(i,k) = defval - t_soisno3d(i,k) = defval + h2osoi_vol3d(i,k) = defval + t_soisno3d(i,k) = defval z3d(i,k) = defval dz3d(i,k) = defval enddo do k = 1,nlevlake - t_lake3d(i,k) = defval + t_lake3d(i,k) = defval lake_icefrac3d(i,k) = defval z_lake3d(i,k) = defval dz_lake3d(i,k) = defval enddo - if(fice(i)>min_lakeice) then - lake_icefrac3d(i,1) = fice(i) - snowdp2d(i) = snowd(i)*1e-3 ! SNOW in kg/m^2 and snowdp in m - h2osno2d(i) = weasd(i) ! mm - else - fice(i) = 0. - snowd(i) = 0. - weasd(i) = 0. - snowdp2d(i) = 0. - h2osno2d(i) = 0. - endif + if (use_lake_model(i) == 1) then + ! for lake points only + z3d(i,:) = 0.0 + dz3d(i,:) = 0.0 + zi3d(i,:) = 0.0 + h2osoi_liq3d(i,:) = 0.0 + h2osoi_ice3d(i,:) = 0.0 + lake_icefrac3d(i,:) = 0.0 + h2osoi_vol3d(i,:) = 0.0 + snl2d(i) = 0.0 + + if(fice(i)>min_lakeice) then + lake_icefrac3d(i,1) = fice(i) + snowdp2d(i) = snowd(i)*1e-3 ! SNOW in kg/m^2 and snowdp in m + h2osno2d(i) = weasd(i) ! mm + else + fice(i) = 0. + snowd(i) = 0. + weasd(i) = 0. + snowdp2d(i) = 0. + h2osno2d(i) = 0. + endif - z3d(i,:) = 0.0 - dz3d(i,:) = 0.0 - zi3d(i,:) = 0.0 - h2osoi_liq3d(i,:) = 0.0 - h2osoi_ice3d(i,:) = 0.0 - lake_icefrac3d(i,:) = 0.0 - h2osoi_vol3d(i,:) = 0.0 - snl2d(i) = 0.0 - ! Soil hydraulic and thermal properties isl = ISLTYP(i) if (isl == 0 ) isl = 14 @@ -5559,19 +5639,45 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, return endif + if(lake_icefrac3d(i,1) > 0.) then + depth = 0. + do k=2,nlevlake + depth = depth + dz_lake3d(i,k) + if(hice(i) >= depth) then + lake_icefrac3d(i,k) = max(0.,lake_icefrac3d(i,1)+(0.-lake_icefrac3d(i,1))/z_lake3d(i,nlevlake)*depth) + else + lake_icefrac3d(i,k) = 0. + endif + end do + endif t_lake3d(i,1) = tsfc(i) t_grnd2d(i) = tsfc(i) + if (lake_icefrac3d(i,1) <= 0.) then + t_lake3d(i,1) = max(tfrz,tsfc(i)) + t_grnd2d(i) = max(tfrz,tsfc(i)) + endif do k = 2, nlevlake if(z_lake3d(i,k).le.depth_c) then - t_lake3d(i,k) = tsfc(i)+(277.0-tsfc(i))/depth_c*z_lake3d(i,k) + t_lake3d(i,k) = tsfc(i)+(277.2_kind_lake-tsfc(i))/depth_c*z_lake3d(i,k) else - t_lake3d(i,k) = 277.0 + t_lake3d(i,k) = 277.2_kind_lake end if + if (lake_icefrac3d(i,k) <= 0.) then + t_lake3d(i,k) = max(tfrz,t_lake3d(i,k)) + endif enddo ! initial t_soisno3d - t_soisno3d(i,1) = t_lake3d(i,nlevlake) + ! in snow + if(snowdp2d(i) > 0.) then + do k = snl2d(i)+1, 0 + t_soisno3d(i,k) =min(tfrz,tsfc(i)) + enddo + endif + + ! in soil + t_soisno3d(i,1) = t_lake3d(i,nlevlake) t_soisno3d(i,nlevsoil) = tg3(i) do k = 2, nlevsoil-1 t_soisno3d(i,k)=t_soisno3d(i,1)+(t_soisno3d(i,nlevsoil)-t_soisno3d(i,1))*dzsoi(k) @@ -5599,6 +5705,17 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, endif enddo + !tgs - in RAP and HRRR applications with cycled snow depth and snow + !water equivalent, the actual snow density could be computed. This is + !not used for now for consistency with the main Lake subroutine, where + !constant snow density (250.) is used. + if(h2osno2d(i).gt.0. .and. snowdp2d(i).gt.0.) then + rhosn = h2osno2d(i)/snowdp2d(i) + else + rhosn = snow_bd ! bdsno=250. + endif + + do k = -nlevsnow+1, 0 if (k > snl2d(i)) then h2osoi_ice3d(i,k) = dz3d(i,k)*snow_bd @@ -5607,10 +5724,12 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, end do clm_lake_initialized(i) = 1 + + endif !if ( use_lakedepth ) then ENDDO do_init - if(LAKEDEBUG .and. init_points>0) then + if(debug_print .and. init_points>0) then print *,'points initialized in clm_lake',init_points end if diff --git a/physics/clm_lake.meta b/physics/clm_lake.meta index bbaaded16..3de543078 100644 --- a/physics/clm_lake.meta +++ b/physics/clm_lake.meta @@ -7,6 +7,13 @@ [ccpp-arg-table] name = clm_lake_run type = scheme +[flag_restart] + standard_name = flag_for_restart + long_name = flag for restart (warmstart) or coldstart + units = flag + dimensions = () + type = logical + intent = in [im] standard_name = horizontal_loop_extent long_name = horizontal loop extent @@ -935,6 +942,13 @@ type = logical active = (control_for_lake_model_selection == 3) intent = in +[clm_debug_print] + standard_name = flag_for_printing_in_clm_lake_model + long_name = flag for printing in clm lake model + units = flag + dimensions = () + type = logical + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 6294bc068..160127e43 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -991,10 +991,12 @@ SUBROUTINE LSMRUC(xlat,xlon, & if(mosaic_lu == 1) then ! greenness factor: between 0 for min greenness and 1 for max greenness. factor = max(zero,min(one,(vegfra(i,j)-shdmin(i,j))/max(one,(shdmax(i,j)-shdmin(i,j))))) + if (debug_print ) then if (abs(xlat-testptlat).lt.0.1 .and. & abs(xlon-testptlon).lt.0.1)then print *,' lat,lon=',xlat,xlon,' factor=',factor endif + endif if((ivgtyp(i,j) == natural .or. ivgtyp(i,j) == crop) .and. factor > 0.75) then ! cropland or grassland, apply irrigation during the growing seaspon when fraction From 1fae3bc76e90a167e9929b28ec451586cdc42da4 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 27 Jul 2023 19:15:15 +0000 Subject: [PATCH 303/380] some missing changes from last commit --- physics/clm_lake.f90 | 51 +++++++++++++++++++++++++++----------------- 1 file changed, 31 insertions(+), 20 deletions(-) diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90 index 21843af58..c07773a57 100644 --- a/physics/clm_lake.f90 +++ b/physics/clm_lake.f90 @@ -454,7 +454,6 @@ SUBROUTINE clm_lake_run( & dtime=dtp ! Initialize any uninitialized lake points. - if(.not.flag_restart) then call lakeini(kdt=kdt, ISLTYP=ISLTYP, gt0=gt0, snowd=snowd, weasd=weasd, & lakedepth_default=lakedepth_default, fhour=fhour, & oro_lakedepth=oro_lakedepth, savedtke12d=savedtke12d, snowdp2d=snowdp2d, & @@ -484,7 +483,6 @@ SUBROUTINE clm_lake_run( & errflg=1 return endif - endif ! .not. restart lake_points=0 snow_points=0 @@ -2032,8 +2030,8 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! ! + (cwat-cice_eff)*lake_icefrac(c)*tfrz*dz_lake(c,j) !enthalpy reconciliation term t_lake_bef(c,j) = t_lake(c,j) if(debug_print) then - if (abs(xlat_d-52.1152).lt.0.1 .and. & - abs(xlon_d-260.405).lt.0.1)then + if (abs(xlat_d-51.393).lt.0.1 .and. & + abs(xlon_d-261.117).lt.0.1)then print *,' ocvts(c) at xlat_d,xlon_d',xlat_d,xlon_d print *,'j,dz_lake(c,j) ', j,dz_lake(c,j) print*,'cv_lake(c,j),lake_icefrac(c,j),t_lake(c,j),cfus,ocvts(c)', & @@ -2056,8 +2054,8 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! + hfus*h2osoi_liq(c,j) !& ! + (cpliq-cpice)*h2osoi_ice(c,j)*tfrz !enthalpy reconciliation term if(debug_print) then - if (abs(xlat_d-52.1152).lt.0.1 .and. & - abs(xlon_d-260.405).lt.0.1)then + if (abs(xlat_d-51.393).lt.0.1 .and. & + abs(xlon_d-261.117).lt.0.1)then print *,' ocvts(c) at xlat_d,xlon_d',xlat_d,xlon_d print *,' j,jtop(c)',j,jtop(c),'h2osoi_liq(c,j) ',h2osoi_liq(c,j),'h2osoi_ice(c,j)',h2osoi_ice(c,j) print *,' cv(c,j),t_soisno(c,j),hfus,ocvts(c)',c,j,cv(c,j),t_soisno(c,j),hfus,ocvts(c) @@ -2522,8 +2520,8 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! ! + (cwat-cice_eff)*lake_icefrac(c)*tfrz*dz_lake(c,j) !enthalpy reconciliation term fin(c) = fin(c) + phi(c,j) if(debug_print) then - if (abs(xlat_d-52.1152).lt.0.1 .and. & - abs(xlon_d-260.405).lt.0.1)then + if (abs(xlat_d-51.393).lt.0.1 .and. & + abs(xlon_d-261.117).lt.0.1)then print *,' ncvts(c) at xlat_d,xlon_d',xlat_d,xlon_d print *,' new cv_lake(c,j),t_lake(c,j),cfus,lake_icefrac(c,j),ncvts(c),fin(c)', & j,cv_lake(c,j),t_lake(c,j),cfus,lake_icefrac(c,j),ncvts(c),fin(c) @@ -2545,8 +2543,8 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! + hfus*h2osoi_liq(c,j) !& ! + (cpliq-cpice)*h2osoi_ice(c,j)*tfrz !enthalpy reconciliation term if(debug_print) then - if (abs(xlat_d-52.1152).lt.0.1 .and. & - abs(xlon_d-260.405).lt.0.1)then + if (abs(xlat_d-51.393).lt.0.1 .and. & + abs(xlon_d-261.117).lt.0.1)then print *,' ncvts(c) at xlat_d,xlon_d',xlat_d,xlon_d print *,'new j,jtop(c)',j,jtop(c),'h2osoi_liq(c,j) ',h2osoi_liq(c,j),'h2osoi_ice(c,j)',h2osoi_ice(c,j) print *,'new cv(c,j),t_soisno(c,j),hfus,ncvts(c)',c,j,cv(c,j),t_soisno(c,j),hfus,ncvts(c) @@ -2569,8 +2567,8 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! c = pcolumn(p) errsoi(c) = (ncvts(c)-ocvts(c)) / dtime - fin(c) if(debug_print) then - if (abs(xlat_d-52.1152).lt.0.1 .and. & - abs(xlon_d-260.405).lt.0.1)then + if (abs(xlat_d-51.393).lt.0.1 .and. & + abs(xlon_d-261.117).lt.0.1)then print *,'xlat_d,xlon_d',xlat_d,xlon_d print *,'errsoi(c),fin(c),ncvts(c),ocvts(c),dtime,lake_icefrac(c,:),h2osno(c)', & errsoi(c),fin(c),ncvts(c),ocvts(c),dtime,lake_icefrac(c,:),h2osno(c) @@ -2603,7 +2601,9 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! else print *,'Soil Energy Balance Error at column, ', c, 'G, fintotal, column E tendency = ', & eflx_gnet(p), fin(c), (ncvts(c)-ocvts(c)) / dtime,'xlat_d,xlon_d',xlat_d,xlon_d - print *,'ncvts(c),ocvts(c),dtime,errsoi(c)',ncvts(c),ocvts(c),dtime,errsoi(c),'xlat_d,xlon_d',xlat_d,xlon_d + print *,'errsoi(c),ncvts(c),ocvts(c)',errsoi(c),ncvts(c),ocvts(c),'xlat_d,xlon_d',xlat_d,xlon_d + print *,'lake_icefrac(c,:),h2osno(c)', lake_icefrac(c,:),h2osno(c) + print *,'t_lake(c,:),t_soisno(c,:)',t_lake(c,:),t_soisno(c,:) end if end if ! LAKEDEBUG end do @@ -5653,23 +5653,34 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, t_lake3d(i,1) = tsfc(i) t_grnd2d(i) = tsfc(i) + + ! initial lake temperature if (lake_icefrac3d(i,1) <= 0.) then - t_lake3d(i,1) = max(tfrz,tsfc(i)) - t_grnd2d(i) = max(tfrz,tsfc(i)) + ! no ice + t_lake3d(i,1) = max(tfrz,t_lake3d(i,1)) + t_grnd2d(i) = t_lake3d(i,1) + elseif (lake_icefrac3d(i,1) > 0. .and. lake_icefrac3d(i,1) < 1.) then + ! fractional ice + t_lake3d(i,1) = tfrz endif + do k = 2, nlevlake if(z_lake3d(i,k).le.depth_c) then - t_lake3d(i,k) = tsfc(i)+(277.2_kind_lake-tsfc(i))/depth_c*z_lake3d(i,k) + t_lake3d(i,k) = t_lake3d(i,1)+(277.2_kind_lake-t_lake3d(i,1))/depth_c*z_lake3d(i,k) + if (lake_icefrac3d(i,1) <= 0.) then + ! no ice + t_lake3d(i,k) = max(tfrz,t_lake3d(i,k)) + elseif (lake_icefrac3d(i,1) > 0. .and. lake_icefrac3d(i,1) < 1.) then + ! fractional ice + t_lake3d(i,k) = tfrz + endif else t_lake3d(i,k) = 277.2_kind_lake end if - if (lake_icefrac3d(i,k) <= 0.) then - t_lake3d(i,k) = max(tfrz,t_lake3d(i,k)) - endif enddo ! initial t_soisno3d - ! in snow + ! in snow on ice if(snowdp2d(i) > 0.) then do k = snl2d(i)+1, 0 t_soisno3d(i,k) =min(tfrz,tsfc(i)) From 180c43b9ccd6dc268d79fccfafcb83cf5b4917f6 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 27 Jul 2023 21:09:05 +0000 Subject: [PATCH 304/380] yet more changes missing in prior commits --- physics/clm_lake.f90 | 45 +++++++++++++++++--------------------------- 1 file changed, 17 insertions(+), 28 deletions(-) diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90 index c07773a57..262bad4e6 100644 --- a/physics/clm_lake.f90 +++ b/physics/clm_lake.f90 @@ -2030,8 +2030,8 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! ! + (cwat-cice_eff)*lake_icefrac(c)*tfrz*dz_lake(c,j) !enthalpy reconciliation term t_lake_bef(c,j) = t_lake(c,j) if(debug_print) then - if (abs(xlat_d-51.393).lt.0.1 .and. & - abs(xlon_d-261.117).lt.0.1)then + if (abs(xlat_d-52.1152).lt.0.1 .and. & + abs(xlon_d-260.405).lt.0.1)then print *,' ocvts(c) at xlat_d,xlon_d',xlat_d,xlon_d print *,'j,dz_lake(c,j) ', j,dz_lake(c,j) print*,'cv_lake(c,j),lake_icefrac(c,j),t_lake(c,j),cfus,ocvts(c)', & @@ -2054,8 +2054,8 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! + hfus*h2osoi_liq(c,j) !& ! + (cpliq-cpice)*h2osoi_ice(c,j)*tfrz !enthalpy reconciliation term if(debug_print) then - if (abs(xlat_d-51.393).lt.0.1 .and. & - abs(xlon_d-261.117).lt.0.1)then + if (abs(xlat_d-52.1152).lt.0.1 .and. & + abs(xlon_d-260.405).lt.0.1)then print *,' ocvts(c) at xlat_d,xlon_d',xlat_d,xlon_d print *,' j,jtop(c)',j,jtop(c),'h2osoi_liq(c,j) ',h2osoi_liq(c,j),'h2osoi_ice(c,j)',h2osoi_ice(c,j) print *,' cv(c,j),t_soisno(c,j),hfus,ocvts(c)',c,j,cv(c,j),t_soisno(c,j),hfus,ocvts(c) @@ -2520,8 +2520,8 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! ! + (cwat-cice_eff)*lake_icefrac(c)*tfrz*dz_lake(c,j) !enthalpy reconciliation term fin(c) = fin(c) + phi(c,j) if(debug_print) then - if (abs(xlat_d-51.393).lt.0.1 .and. & - abs(xlon_d-261.117).lt.0.1)then + if (abs(xlat_d-52.1152).lt.0.1 .and. & + abs(xlon_d-260.405).lt.0.1)then print *,' ncvts(c) at xlat_d,xlon_d',xlat_d,xlon_d print *,' new cv_lake(c,j),t_lake(c,j),cfus,lake_icefrac(c,j),ncvts(c),fin(c)', & j,cv_lake(c,j),t_lake(c,j),cfus,lake_icefrac(c,j),ncvts(c),fin(c) @@ -2543,8 +2543,8 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! + hfus*h2osoi_liq(c,j) !& ! + (cpliq-cpice)*h2osoi_ice(c,j)*tfrz !enthalpy reconciliation term if(debug_print) then - if (abs(xlat_d-51.393).lt.0.1 .and. & - abs(xlon_d-261.117).lt.0.1)then + if (abs(xlat_d-52.1152).lt.0.1 .and. & + abs(xlon_d-260.405).lt.0.1)then print *,' ncvts(c) at xlat_d,xlon_d',xlat_d,xlon_d print *,'new j,jtop(c)',j,jtop(c),'h2osoi_liq(c,j) ',h2osoi_liq(c,j),'h2osoi_ice(c,j)',h2osoi_ice(c,j) print *,'new cv(c,j),t_soisno(c,j),hfus,ncvts(c)',c,j,cv(c,j),t_soisno(c,j),hfus,ncvts(c) @@ -2567,8 +2567,8 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! c = pcolumn(p) errsoi(c) = (ncvts(c)-ocvts(c)) / dtime - fin(c) if(debug_print) then - if (abs(xlat_d-51.393).lt.0.1 .and. & - abs(xlon_d-261.117).lt.0.1)then + if (abs(xlat_d-52.1152).lt.0.1 .and. & + abs(xlon_d-260.405).lt.0.1)then print *,'xlat_d,xlon_d',xlat_d,xlon_d print *,'errsoi(c),fin(c),ncvts(c),ocvts(c),dtime,lake_icefrac(c,:),h2osno(c)', & errsoi(c),fin(c),ncvts(c),ocvts(c),dtime,lake_icefrac(c,:),h2osno(c) @@ -5653,34 +5653,23 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, t_lake3d(i,1) = tsfc(i) t_grnd2d(i) = tsfc(i) - - ! initial lake temperature if (lake_icefrac3d(i,1) <= 0.) then - ! no ice - t_lake3d(i,1) = max(tfrz,t_lake3d(i,1)) - t_grnd2d(i) = t_lake3d(i,1) - elseif (lake_icefrac3d(i,1) > 0. .and. lake_icefrac3d(i,1) < 1.) then - ! fractional ice - t_lake3d(i,1) = tfrz + t_lake3d(i,1) = max(tfrz,tsfc(i)) + t_grnd2d(i) = max(tfrz,tsfc(i)) endif - do k = 2, nlevlake if(z_lake3d(i,k).le.depth_c) then - t_lake3d(i,k) = t_lake3d(i,1)+(277.2_kind_lake-t_lake3d(i,1))/depth_c*z_lake3d(i,k) - if (lake_icefrac3d(i,1) <= 0.) then - ! no ice - t_lake3d(i,k) = max(tfrz,t_lake3d(i,k)) - elseif (lake_icefrac3d(i,1) > 0. .and. lake_icefrac3d(i,1) < 1.) then - ! fractional ice - t_lake3d(i,k) = tfrz - endif + t_lake3d(i,k) = tsfc(i)+(277.2_kind_lake-tsfc(i))/depth_c*z_lake3d(i,k) else t_lake3d(i,k) = 277.2_kind_lake end if + if (lake_icefrac3d(i,k) <= 0.) then + t_lake3d(i,k) = max(tfrz,t_lake3d(i,k)) + endif enddo ! initial t_soisno3d - ! in snow on ice + ! in snow if(snowdp2d(i) > 0.) then do k = snl2d(i)+1, 0 t_soisno3d(i,k) =min(tfrz,tsfc(i)) From ace56af857fd760e29c50f67850f3620ed2bdda4 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Fri, 28 Jul 2023 03:12:46 +0000 Subject: [PATCH 305/380] t_grnd(i) should be t_grnd(c) --- physics/clm_lake.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90 index 262bad4e6..844c4ce71 100644 --- a/physics/clm_lake.f90 +++ b/physics/clm_lake.f90 @@ -692,7 +692,7 @@ SUBROUTINE clm_lake_run( & gflx_wat(I) = eflx_gnet(c) ![W/m/m] upward_heat_flux_in_soil_over_water ep1d_water(i) = eflx_lh_tot(c) ![W/m/m] surface_upward_potential_latent_heat_flux_over_water tsurf_water(I) = t_grnd(c) ![K] surface skin temperature after iteration over water - tsurf_ice(i) = t_grnd(i) ! surface_skin_temperature_after_iteration_over_ice + tsurf_ice(i) = t_grnd(c) ! surface_skin_temperature_after_iteration_over_ice tsfc_wat(i) = t_grnd(c) ![K] surface skin temperature over water tisfc(i) = t_grnd(c) tsfc(i) = t_grnd(c) From c0c253f9fcec4c871b954533d912b1f3ec28b420 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Fri, 28 Jul 2023 15:19:25 +0000 Subject: [PATCH 306/380] fix another typo --- physics/clm_lake.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90 index 844c4ce71..edd9e2bd5 100644 --- a/physics/clm_lake.f90 +++ b/physics/clm_lake.f90 @@ -736,7 +736,7 @@ SUBROUTINE clm_lake_run( & ! uustar_ice(i) = uustar_water(i) ! surface_friction_velocity_over_ice endif - tsurf_ice(i) = t_grnd(i) ! surface_skin_temperature_after_iteration_over_ice + tsurf_ice(i) = t_grnd(c) ! surface_skin_temperature_after_iteration_over_ice tisfc(i) = t_grnd(c) ! surface_skin_temperature_over_ice tsfc(i) = t_grnd(c) ! surface_skin_temperature_over_ice weasdi(i) = h2osno(c) ! water_equivalent_accumulated_snow_depth_over_ice From 102d664840f70a86cab380295ac518bbcb58cbe4 Mon Sep 17 00:00:00 2001 From: "Michael Kavulich, Jr" Date: Mon, 31 Jul 2023 12:24:02 -0600 Subject: [PATCH 307/380] Some housekeeping: overwrite ccppsrw_doxyfile (no need to keep separate "v3" file), correct misspelled pages "shemes" --> "schemes" --- physics/docs/ccpp_doxyfile | 2 +- physics/docs/ccppsrw3_doxyfile | 557 ------------------ physics/docs/ccppsrw_doxyfile | 14 +- ...emes_list.txt => SRW_all_schemes_list.txt} | 0 ...l_shemes_list.txt => all_schemes_list.txt} | 0 5 files changed, 9 insertions(+), 564 deletions(-) delete mode 100644 physics/docs/ccppsrw3_doxyfile rename physics/docs/pdftxt/{SRW_all_shemes_list.txt => SRW_all_schemes_list.txt} (100%) rename physics/docs/pdftxt/{all_shemes_list.txt => all_schemes_list.txt} (100%) diff --git a/physics/docs/ccpp_doxyfile b/physics/docs/ccpp_doxyfile index 595ba2d85..9beb66ece 100644 --- a/physics/docs/ccpp_doxyfile +++ b/physics/docs/ccpp_doxyfile @@ -115,7 +115,7 @@ WARN_LOGFILE = #--------------------------------------------------------------------------- INPUT = pdftxt/mainpage.txt \ - pdftxt/all_shemes_list.txt \ + pdftxt/all_schemes_list.txt \ pdftxt/GFS_v16_suite.txt \ pdftxt/GFS_v17_p8_suite.txt \ pdftxt/RAP_suite.txt \ diff --git a/physics/docs/ccppsrw3_doxyfile b/physics/docs/ccppsrw3_doxyfile deleted file mode 100644 index b1cc3138c..000000000 --- a/physics/docs/ccppsrw3_doxyfile +++ /dev/null @@ -1,557 +0,0 @@ -# Doxyfile 1.9.3 - -DOXYFILE_ENCODING = UTF-8 -PROJECT_NAME = "CCPP SciDoc for UFS-SRW v3.0.0" -PROJECT_NUMBER = "SRW v3.0.0" -PROJECT_BRIEF = "Common Community Physics Package Developed at DTC" -PROJECT_LOGO = img/dtc_logo.png -OUTPUT_DIRECTORY = doc -CREATE_SUBDIRS = NO -ALLOW_UNICODE_NAMES = NO -OUTPUT_LANGUAGE = English -BRIEF_MEMBER_DESC = YES -REPEAT_BRIEF = NO -ABBREVIATE_BRIEF = -ALWAYS_DETAILED_SEC = NO -INLINE_INHERITED_MEMB = NO -FULL_PATH_NAMES = NO -STRIP_FROM_PATH = -STRIP_FROM_INC_PATH = -SHORT_NAMES = NO -JAVADOC_AUTOBRIEF = NO -JAVADOC_BANNER = NO -QT_AUTOBRIEF = NO -MULTILINE_CPP_IS_BRIEF = NO -PYTHON_DOCSTRING = YES -INHERIT_DOCS = YES -SEPARATE_MEMBER_PAGES = YES -TAB_SIZE = 4 -ALIASES = -OPTIMIZE_OUTPUT_FOR_C = NO -OPTIMIZE_OUTPUT_JAVA = NO -OPTIMIZE_FOR_FORTRAN = YES -OPTIMIZE_OUTPUT_VHDL = NO -OPTIMIZE_OUTPUT_SLICE = NO -EXTENSION_MAPPING = .f=FortranFree \ - .F=FortranFree \ - .F90=FortranFree \ - .f90=FortranFree -MARKDOWN_SUPPORT = YES -TOC_INCLUDE_HEADINGS = 5 -AUTOLINK_SUPPORT = YES -BUILTIN_STL_SUPPORT = NO -CPP_CLI_SUPPORT = NO -SIP_SUPPORT = NO -IDL_PROPERTY_SUPPORT = YES -DISTRIBUTE_GROUP_DOC = YES -GROUP_NESTED_COMPOUNDS = NO -SUBGROUPING = YES -INLINE_GROUPED_CLASSES = NO -INLINE_SIMPLE_STRUCTS = NO -TYPEDEF_HIDES_STRUCT = YES -LOOKUP_CACHE_SIZE = 0 -NUM_PROC_THREADS = 1 - -#--------------------------------------------------------------------------- -# Build related configuration options -#--------------------------------------------------------------------------- - -EXTRACT_ALL = YES -EXTRACT_PRIVATE = YES -EXTRACT_PRIV_VIRTUAL = NO -EXTRACT_PACKAGE = YES -EXTRACT_STATIC = YES -EXTRACT_LOCAL_CLASSES = YES -EXTRACT_LOCAL_METHODS = YES -EXTRACT_ANON_NSPACES = YES -RESOLVE_UNNAMED_PARAMS = YES -HIDE_UNDOC_MEMBERS = NO -HIDE_UNDOC_CLASSES = NO -HIDE_FRIEND_COMPOUNDS = NO -HIDE_IN_BODY_DOCS = NO -INTERNAL_DOCS = YES -CASE_SENSE_NAMES = NO -HIDE_SCOPE_NAMES = NO -HIDE_COMPOUND_REFERENCE= NO -SHOW_HEADERFILE = YES -SHOW_INCLUDE_FILES = NO -SHOW_GROUPED_MEMB_INC = NO -FORCE_LOCAL_INCLUDES = NO -INLINE_INFO = YES -SORT_MEMBER_DOCS = NO -SORT_BRIEF_DOCS = NO -SORT_MEMBERS_CTORS_1ST = NO -SORT_GROUP_NAMES = NO -SORT_BY_SCOPE_NAME = NO -STRICT_PROTO_MATCHING = NO -GENERATE_TODOLIST = YES -GENERATE_TESTLIST = YES -GENERATE_BUGLIST = YES -GENERATE_DEPRECATEDLIST= YES -ENABLED_SECTIONS = YES -MAX_INITIALIZER_LINES = 30 -SHOW_USED_FILES = NO -SHOW_FILES = NO -SHOW_NAMESPACES = YES -FILE_VERSION_FILTER = -LAYOUT_FILE = ccpp_dox_layout.xml -CITE_BIB_FILES = library.bib - -#--------------------------------------------------------------------------- -# Configuration options related to warning and progress messages -#--------------------------------------------------------------------------- -QUIET = NO -WARNINGS = YES -WARN_IF_UNDOCUMENTED = NO -WARN_IF_DOC_ERROR = YES -WARN_IF_INCOMPLETE_DOC = YES -WARN_NO_PARAMDOC = NO -WARN_AS_ERROR = NO -WARN_FORMAT = -WARN_LOGFILE = - -#--------------------------------------------------------------------------- -# Configuration options related to the input files -#--------------------------------------------------------------------------- - -INPUT = pdftxt/SRW_mainpage.txt \ - pdftxt/SRW_all_shemes_list.txt \ - pdftxt/GFS_v16_suite.txt \ - pdftxt/HRRR_suite.txt \ - pdftxt/RAP_suite.txt \ - pdftxt/RRFS_v1beta_suite.txt \ - pdftxt/WoFS_v0_suite.txt \ - pdftxt/RRFS_SGSCLOUD.txt \ - pdftxt/GFS_RRTMG.txt \ - pdftxt/GFS_SFCLYR.txt \ - pdftxt/MYNN_SFCLAYER.txt \ - pdftxt/GFS_NSST.txt \ - pdftxt/GFS_OCEAN.txt \ - pdftxt/GFS_NOAH.txt \ - pdftxt/GFS_SFCSICE.txt \ - pdftxt/GFS_SATMEDMFVDIFQ.txt \ - pdftxt/GFS_NOAHMP.txt \ - pdftxt/GFS_UGWPv0.txt \ - pdftxt/GFS_drag_suite.txt \ - pdftxt/GFS_GWDPS.txt \ - pdftxt/GFS_OZPHYS.txt \ - pdftxt/GFS_H2OPHYS.txt \ - pdftxt/GFS_SAMFdeep.txt \ - pdftxt/GFS_SAMFshal.txt \ - pdftxt/GFDL_cloud.txt \ - pdftxt/NSSLMICRO.txt \ - pdftxt/MYNN_EDMF.txt \ - pdftxt/CU_GF_deep.txt \ - pdftxt/RUCLSM.txt \ - pdftxt/THOMPSON.txt \ - pdftxt/suite_input.nml.txt \ - pdftxt/CLM_LAKE.txt \ - pdftxt/GFS_SPP.txt \ - ../fv_sat_adj.F90 \ - ../GFS_time_vary_pre.fv3.F90 \ - ../GFS_rad_time_vary.fv3.F90 \ - ../GFS_phys_time_vary.fv3.F90 \ - ../get_prs_fv3.F90 \ - ../get_phi_fv3.F90 \ - ../ozne_def.f \ - ../ozinterp.f90 \ - ../h2o_def.f \ - ../h2ointerp.f90 \ - ../aerclm_def.F \ - ../aerinterp.F90 \ - ../iccn_def.F \ - ../iccninterp.F90 \ - ../sfcsub.F \ - ../gcycle.F90 \ - ../GFS_suite_interstitial_1.F90 \ - ../GFS_suite_interstitial_2.F90 \ - ../GFS_suite_interstitial_3.F90 \ - ../GFS_suite_interstitial_4.F90 \ - ../GFS_suite_interstitial_5.F90 \ - ../GFS_suite_interstitial_phys_reset.F90 \ - ../GFS_suite_interstitial_rad_reset.F90 \ - ../GFS_suite_stateout_reset.F90 \ - ../GFS_suite_stateout_update.F90 \ - ../GFS_surface_composites_inter.F90 \ - ../GFS_surface_composites_pre.F90 \ - ../GFS_surface_composites_post.F90 \ - ../GFS_surface_loop_control_part1.F90 \ - ../GFS_surface_loop_control_part2.F90 \ - ../GFS_radiation_surface.F90 \ - ../GFS_rrtmg_pre.F90 \ - ../GFS_rrtmg_post.F90 \ - ../GFS_rrtmg_setup.F90 \ - ../rad_sw_pre.F90 \ - ../sgscloud_radpre.F90 \ - ../sgscloud_radpost.F90 \ - ../radsw_main.F90 \ - ../rrtmg_sw_post.F90 \ - ../rrtmg_lw_pre.F90 \ - ../radlw_main.F90 \ - ../rrtmg_lw_post.F90 \ - ../radiation_aerosols.f \ - ../radiation_astronomy.f \ - ../radiation_clouds.f \ - ../radiation_cloud_overlap.F90 \ - ../radiation_gases.f \ - ../radiation_surface.f \ - ../radlw_param.f \ - ../radlw_datatb.f \ - ../radsw_param.f \ - ../radsw_datatb.f \ - ../GFS_cloud_diagnostics.F90 \ - ../dcyc2t3.f \ - ../sfc_diff.f \ - ../sfc_diag.f \ - ../sfc_diag_post.F90 \ - ../sfc_nst.f \ - ../sfc_nst_pre.f \ - ../sfc_nst_post.f \ - ../sfc_ocean.F \ - ../clm_lake.f90 \ - ../module_nst_model.f90 \ - ../module_nst_parameters.f90 \ - ../module_nst_water_prop.f90 \ - ../lsm_noah.f \ - ../sflx.f \ - ../namelist_soilveg.f \ - ../set_soilveg.f \ - ../noahmpdrv.F90 \ - ../module_sf_noahmplsm.f90 \ - ../module_sf_noahmp_glacier.f90 \ - ../noahmp_tables.f90 \ - ../GFS_surface_generic_pre.F90 \ - ../GFS_surface_generic_post.F90 \ - ../surface_perturbation.F90 \ - ../GFS_DCNV_generic_pre.F90 \ - ../GFS_DCNV_generic_post.F90 \ - ../GFS_SCNV_generic_pre.F90 \ - ../GFS_SCNV_generic_post.F90 \ - ../sfc_sice.f \ - ../satmedmfvdifq.F \ - ../mfpbltq.f \ - ../mfscuq.f \ - ../tridi.f \ - ../GFS_GWD_generic_pre.F90 \ - ../GFS_GWD_generic_post.F90 \ - ../unified_ugwp.F90 \ - ../drag_suite.F90 \ - ../cires_tauamf_data.F90 \ - ../cires_orowam2017.f \ - ../cires_ugwp.F90 \ - ../cires_ugwp_initialize.F90 \ - ../cires_ugwp_module.F90 \ - ../cires_ugwp_post.F90 \ - ../cires_ugwp_triggers.F90 \ - ../cires_ugwp_module.F90 \ - ../gwdps.f \ - ../ugwp_driver_v0.F \ - ../ozphys_2015.f \ - ../h2ophys.f \ - ../samfdeepcnv.f \ - ../samfshalcnv.f \ - ../progsigma_calc.f90 \ - ../cnvc90.f \ - ../module_bfmicrophysics.f \ - ../gfdl_cloud_microphys.F90 \ - ../module_gfdl_cloud_microphys.F90 \ - ../GFS_MP_generic_pre.F90 \ - ../GFS_MP_generic_post.F90 \ - ../GFS_PBL_generic_common.F90 \ - ../GFS_PBL_generic_pre.F90 \ - ../GFS_PBL_generic_post.F90 \ - ../calpreciptype.f90 \ - ../GFS_stochastics.F90 \ - ../cu_gf_driver.F90 \ - ../cu_gf_driver_pre.F90 \ - ../cu_gf_deep.F90 \ - ../cu_gf_sh.F90 \ - ../cu_gf_driver_post.F90 \ - ../mynnedmf_wrapper.F90 \ - ../module_bl_mynn.F90 \ - ../bl_mynn_common.f90 \ - ../mynnsfc_wrapper.F90 \ - ../module_sf_mynn.F90 \ - ../lsm_ruc.F90 \ - ../module_sf_ruclsm.F90 \ - ../namelist_soilveg_ruc.F90 \ - ../set_soilveg_ruc.F90 \ - ../module_soil_pre.F90 \ - ../mp_thompson_pre.F90 \ - ../module_mp_thompson_make_number_concentrations.F90 \ - ../mp_thompson.F90 \ - ../module_mp_thompson.F90 \ - ../module_mp_radar.F90 \ - ../mp_thompson_post.F90 \ - ../mp_nssl.F90 \ - ../module_mp_nssl_2mom.F90 \ - ../funcphys.f90 \ - ../physcons.F90 \ - ../radcons.f90 \ - ../mersenne_twister.f \ - ../maximum_hourly_diagnostics.F90 \ - ../phys_tend.F90 - -INPUT_ENCODING = UTF-8 -FILE_PATTERNS = *.f \ - *.F \ - *.F90 \ - *.f90 \ - *.nml \ - *.txt -RECURSIVE = YES -EXCLUDE = -EXCLUDE_SYMLINKS = NO -EXCLUDE_PATTERNS = -EXCLUDE_SYMBOLS = -EXAMPLE_PATH = pdftxt/RE300 \ - doc/html -EXAMPLE_PATTERNS = -EXAMPLE_RECURSIVE = NO -IMAGE_PATH = img -INPUT_FILTER = -FILTER_PATTERNS = -FILTER_SOURCE_FILES = NO -FILTER_SOURCE_PATTERNS = -USE_MDFILE_AS_MAINPAGE = - -#--------------------------------------------------------------------------- -# Configuration options related to source browsing -#--------------------------------------------------------------------------- - -SOURCE_BROWSER = NO -INLINE_SOURCES = NO -STRIP_CODE_COMMENTS = YES -REFERENCED_BY_RELATION = YES -REFERENCES_RELATION = YES -REFERENCES_LINK_SOURCE = YES -SOURCE_TOOLTIPS = YES -USE_HTAGS = NO -VERBATIM_HEADERS = YES -CLANG_ASSISTED_PARSING = NO -CLANG_ADD_INC_PATHS = YES -CLANG_OPTIONS = -CLANG_DATABASE_PATH = - -#--------------------------------------------------------------------------- -# Configuration options related to the alphabetical class index -#--------------------------------------------------------------------------- - -ALPHABETICAL_INDEX = NO -IGNORE_PREFIX = - -#--------------------------------------------------------------------------- -# Configuration options related to the HTML output -#--------------------------------------------------------------------------- - -GENERATE_HTML = YES -HTML_OUTPUT = html -HTML_FILE_EXTENSION = .html -HTML_HEADER = _doxygen/header.html -HTML_FOOTER = _doxygen/footer.html -HTML_STYLESHEET = -HTML_EXTRA_STYLESHEET = _doxygen/doxygen-awesome.css \ - _doxygen/doxygen-awesome-sidebar-only.css \ - _doxygen/doxygen-awesome-sidebar-only-darkmode-toggle.css \ - _doxygen/doxygen-awesome-ccpp.css -HTML_EXTRA_FILES = _doxygen/doxygen-awesome-darkmode-toggle.js \ - _doxygen/doxygen-awesome-ccpp.js -HTML_COLORSTYLE_HUE = 209 -HTML_COLORSTYLE_SAT = 255 -HTML_COLORSTYLE_GAMMA = 113 -HTML_TIMESTAMP = NO -HTML_DYNAMIC_MENUS = YES -HTML_DYNAMIC_SECTIONS = NO -HTML_INDEX_NUM_ENTRIES = 100 -GENERATE_DOCSET = NO -DOCSET_FEEDNAME = "Doxygen generated docs" -DOCSET_FEEDURL = -DOCSET_BUNDLE_ID = org.doxygen.Project -DOCSET_PUBLISHER_ID = org.doxygen.Publisher -DOCSET_PUBLISHER_NAME = Publisher -GENERATE_HTMLHELP = NO -CHM_FILE = -HHC_LOCATION = -GENERATE_CHI = NO -CHM_INDEX_ENCODING = -BINARY_TOC = NO -TOC_EXPAND = NO -GENERATE_QHP = NO -QCH_FILE = -QHP_NAMESPACE = org.doxygen.Project -QHP_VIRTUAL_FOLDER = doc -QHP_CUST_FILTER_NAME = -QHP_CUST_FILTER_ATTRS = -QHP_SECT_FILTER_ATTRS = -QHG_LOCATION = -GENERATE_ECLIPSEHELP = NO -ECLIPSE_DOC_ID = org.doxygen.Project -DISABLE_INDEX = YES -GENERATE_TREEVIEW = YES -FULL_SIDEBAR = NO -ENUM_VALUES_PER_LINE = 4 -TREEVIEW_WIDTH = 335 -EXT_LINKS_IN_WINDOW = NO -OBFUSCATE_EMAILS = YES -HTML_FORMULA_FORMAT = SVG -FORMULA_FONTSIZE = 10 -FORMULA_TRANSPARENT = YES -FORMULA_MACROFILE = -USE_MATHJAX = YES -MATHJAX_VERSION = MathJax_2 -MATHJAX_FORMAT = HTML-CSS -#MATHJAX_RELPATH = https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.2 -MATHJAX_RELPATH = https://cdn.jsdelivr.net/npm/mathjax@2 -MATHJAX_EXTENSIONS = -MATHJAX_CODEFILE = -SEARCHENGINE = YES -SERVER_BASED_SEARCH = NO -EXTERNAL_SEARCH = NO -SEARCHENGINE_URL = -SEARCHDATA_FILE = searchdata.xml -EXTERNAL_SEARCH_ID = -EXTRA_SEARCH_MAPPINGS = - -#--------------------------------------------------------------------------- -# Configuration options related to the LaTeX output -#--------------------------------------------------------------------------- - -GENERATE_LATEX = YES -LATEX_OUTPUT = latex -LATEX_CMD_NAME = latex -MAKEINDEX_CMD_NAME = makeindex -LATEX_MAKEINDEX_CMD = makeindex -COMPACT_LATEX = YES -PAPER_TYPE = a4 -EXTRA_PACKAGES = amsmath -LATEX_HEADER = -LATEX_FOOTER = -LATEX_EXTRA_STYLESHEET = -LATEX_EXTRA_FILES = -PDF_HYPERLINKS = YES -USE_PDFLATEX = YES -LATEX_BATCHMODE = NO -LATEX_HIDE_INDICES = YES -LATEX_BIB_STYLE = plainnat -LATEX_TIMESTAMP = NO -LATEX_EMOJI_DIRECTORY = - -#--------------------------------------------------------------------------- -# Configuration options related to the RTF output -#--------------------------------------------------------------------------- - -GENERATE_RTF = NO -RTF_OUTPUT = rtf -COMPACT_RTF = NO -RTF_HYPERLINKS = NO -RTF_STYLESHEET_FILE = -RTF_EXTENSIONS_FILE = - -#--------------------------------------------------------------------------- -# Configuration options related to the man page output -#--------------------------------------------------------------------------- - -GENERATE_MAN = NO -MAN_OUTPUT = man -MAN_EXTENSION = .3 -MAN_SUBDIR = -MAN_LINKS = NO - -#--------------------------------------------------------------------------- -# Configuration options related to the XML output -#--------------------------------------------------------------------------- - -GENERATE_XML = NO -XML_OUTPUT = xml -XML_PROGRAMLISTING = YES -XML_NS_MEMB_FILE_SCOPE = NO - -#--------------------------------------------------------------------------- -# Configuration options related to the DOCBOOK output -#--------------------------------------------------------------------------- - -GENERATE_DOCBOOK = NO -DOCBOOK_OUTPUT = docbook - -#--------------------------------------------------------------------------- -# Configuration options for the AutoGen Definitions output -#--------------------------------------------------------------------------- - -GENERATE_AUTOGEN_DEF = NO - -#--------------------------------------------------------------------------- -# Configuration options related to the Perl module output -#--------------------------------------------------------------------------- - -GENERATE_PERLMOD = NO -PERLMOD_LATEX = NO -PERLMOD_PRETTY = YES -PERLMOD_MAKEVAR_PREFIX = - -#--------------------------------------------------------------------------- -# Configuration options related to the preprocessor -#--------------------------------------------------------------------------- - -ENABLE_PREPROCESSING = NO -MACRO_EXPANSION = NO -EXPAND_ONLY_PREDEF = NO -SEARCH_INCLUDES = YES -INCLUDE_PATH = -INCLUDE_FILE_PATTERNS = -PREDEFINED = CCPP \ - MULTI_GASES \ - 0 -EXPAND_AS_DEFINED = -SKIP_FUNCTION_MACROS = YES - -#--------------------------------------------------------------------------- -# Configuration options related to external references -#--------------------------------------------------------------------------- - -TAGFILES = -GENERATE_TAGFILE = -ALLEXTERNALS = NO -EXTERNAL_GROUPS = YES -EXTERNAL_PAGES = YES - -#--------------------------------------------------------------------------- -# Configuration options related to the dot tool -#--------------------------------------------------------------------------- - -DIA_PATH = -HIDE_UNDOC_RELATIONS = YES -HAVE_DOT = YES -DOT_NUM_THREADS = 0 -DOT_FONTNAME = Source Sans Pro -DOT_FONTSIZE = -DOT_FONTPATH = -CLASS_GRAPH = YES -COLLABORATION_GRAPH = YES -GROUP_GRAPHS = YES -UML_LOOK = YES -UML_LIMIT_NUM_FIELDS = 10 -DOT_UML_DETAILS = NO -DOT_WRAP_THRESHOLD = 17 -TEMPLATE_RELATIONS = NO -INCLUDE_GRAPH = YES -INCLUDED_BY_GRAPH = NO -CALL_GRAPH = YES -CALLER_GRAPH = YES -GRAPHICAL_HIERARCHY = YES -DIRECTORY_GRAPH = YES -DIR_GRAPH_MAX_DEPTH = 1 -DOT_IMAGE_FORMAT = SVG -INTERACTIVE_SVG = NO -DOT_PATH = /Users/man.zhang/homebrew/bin/dot -DOTFILE_DIRS = -MSCFILE_DIRS = -DIAFILE_DIRS = -PLANTUML_JAR_PATH = -PLANTUML_CFG_FILE = -PLANTUML_INCLUDE_PATH = -DOT_GRAPH_MAX_NODES = 1000 -MAX_DOT_GRAPH_DEPTH = 0 -DOT_TRANSPARENT = YES -DOT_MULTI_TARGETS = YES -GENERATE_LEGEND = YES -DOT_CLEANUP = YES diff --git a/physics/docs/ccppsrw_doxyfile b/physics/docs/ccppsrw_doxyfile index 09ebccf86..5c9c797b5 100644 --- a/physics/docs/ccppsrw_doxyfile +++ b/physics/docs/ccppsrw_doxyfile @@ -1,8 +1,8 @@ # Doxyfile 1.9.3 DOXYFILE_ENCODING = UTF-8 -PROJECT_NAME = "CCPP Scidoc for SRW v2.1.0" -PROJECT_NUMBER = "SRW v2.1.0" +PROJECT_NAME = "CCPP SciDoc for UFS-SRW v3.0.0" +PROJECT_NUMBER = "SRW v3.0.0" PROJECT_BRIEF = "Common Community Physics Package Developed at DTC" PROJECT_LOGO = img/dtc_logo.png OUTPUT_DIRECTORY = doc @@ -115,9 +115,10 @@ WARN_LOGFILE = #--------------------------------------------------------------------------- INPUT = pdftxt/SRW_mainpage.txt \ - pdftxt/SRW_all_shemes_list.txt \ + pdftxt/SRW_all_schemes_list.txt \ pdftxt/GFS_v16_suite.txt \ pdftxt/HRRR_suite.txt \ + pdftxt/RAP_suite.txt \ pdftxt/RRFS_v1beta_suite.txt \ pdftxt/WoFS_v0_suite.txt \ pdftxt/RRFS_SGSCLOUD.txt \ @@ -144,6 +145,7 @@ INPUT = pdftxt/SRW_mainpage.txt \ pdftxt/RUCLSM.txt \ pdftxt/THOMPSON.txt \ pdftxt/suite_input.nml.txt \ + pdftxt/CLM_LAKE.txt \ pdftxt/GFS_SPP.txt \ ../fv_sat_adj.F90 \ ../GFS_time_vary_pre.fv3.F90 \ @@ -206,6 +208,7 @@ INPUT = pdftxt/SRW_mainpage.txt \ ../sfc_nst_pre.f \ ../sfc_nst_post.f \ ../sfc_ocean.F \ + ../clm_lake.f90 \ ../module_nst_model.f90 \ ../module_nst_parameters.f90 \ ../module_nst_water_prop.f90 \ @@ -283,7 +286,6 @@ INPUT = pdftxt/SRW_mainpage.txt \ ../mp_nssl.F90 \ ../module_mp_nssl_2mom.F90 \ ../funcphys.f90 \ - ../physparam.f \ ../physcons.F90 \ ../radcons.f90 \ ../mersenne_twister.f \ @@ -302,7 +304,7 @@ EXCLUDE = EXCLUDE_SYMLINKS = NO EXCLUDE_PATTERNS = EXCLUDE_SYMBOLS = -EXAMPLE_PATH = pdftxt/RE210 \ +EXAMPLE_PATH = pdftxt/RE300 \ doc/html EXAMPLE_PATTERNS = EXAMPLE_RECURSIVE = NO @@ -540,7 +542,7 @@ DIRECTORY_GRAPH = YES DIR_GRAPH_MAX_DEPTH = 1 DOT_IMAGE_FORMAT = SVG INTERACTIVE_SVG = NO -DOT_PATH = +DOT_PATH = /Users/man.zhang/homebrew/bin/dot DOTFILE_DIRS = MSCFILE_DIRS = DIAFILE_DIRS = diff --git a/physics/docs/pdftxt/SRW_all_shemes_list.txt b/physics/docs/pdftxt/SRW_all_schemes_list.txt similarity index 100% rename from physics/docs/pdftxt/SRW_all_shemes_list.txt rename to physics/docs/pdftxt/SRW_all_schemes_list.txt diff --git a/physics/docs/pdftxt/all_shemes_list.txt b/physics/docs/pdftxt/all_schemes_list.txt similarity index 100% rename from physics/docs/pdftxt/all_shemes_list.txt rename to physics/docs/pdftxt/all_schemes_list.txt From 0154a658ba4752da9c00f1ab24b1a039787e3a7f Mon Sep 17 00:00:00 2001 From: "Michael Kavulich, Jr" Date: Tue, 1 Aug 2023 10:20:26 -0600 Subject: [PATCH 308/380] Remove old namelists, remove "develop" from names --- ...elop.FV3_GFS_v16 => input.nml.FV3_GFS_v16} | 0 ...ml.develop.FV3_HRRR => input.nml.FV3_HRRR} | 0 ....nml.develop.FV3_RAP => input.nml.FV3_RAP} | 0 ..._RRFS_v1beta => input.nml.FV3_RRFS_v1beta} | 0 ...elop.FV3_WoFS_v0 => input.nml.FV3_WoFS_v0} | 0 .../RE300/namelists/input.nml.v21.FV3_GFS_v16 | 336 ------------------ .../RE300/namelists/input.nml.v21.FV3_HRRR | 299 ---------------- .../namelists/input.nml.v21.FV3_RRFS_v1beta | 291 --------------- .../RE300/namelists/input.nml.v21.FV3_WoFS_v0 | 297 ---------------- 9 files changed, 1223 deletions(-) rename physics/docs/pdftxt/RE300/namelists/{input.nml.develop.FV3_GFS_v16 => input.nml.FV3_GFS_v16} (100%) rename physics/docs/pdftxt/RE300/namelists/{input.nml.develop.FV3_HRRR => input.nml.FV3_HRRR} (100%) rename physics/docs/pdftxt/RE300/namelists/{input.nml.develop.FV3_RAP => input.nml.FV3_RAP} (100%) rename physics/docs/pdftxt/RE300/namelists/{input.nml.develop.FV3_RRFS_v1beta => input.nml.FV3_RRFS_v1beta} (100%) rename physics/docs/pdftxt/RE300/namelists/{input.nml.develop.FV3_WoFS_v0 => input.nml.FV3_WoFS_v0} (100%) delete mode 100644 physics/docs/pdftxt/RE300/namelists/input.nml.v21.FV3_GFS_v16 delete mode 100644 physics/docs/pdftxt/RE300/namelists/input.nml.v21.FV3_HRRR delete mode 100644 physics/docs/pdftxt/RE300/namelists/input.nml.v21.FV3_RRFS_v1beta delete mode 100644 physics/docs/pdftxt/RE300/namelists/input.nml.v21.FV3_WoFS_v0 diff --git a/physics/docs/pdftxt/RE300/namelists/input.nml.develop.FV3_GFS_v16 b/physics/docs/pdftxt/RE300/namelists/input.nml.FV3_GFS_v16 similarity index 100% rename from physics/docs/pdftxt/RE300/namelists/input.nml.develop.FV3_GFS_v16 rename to physics/docs/pdftxt/RE300/namelists/input.nml.FV3_GFS_v16 diff --git a/physics/docs/pdftxt/RE300/namelists/input.nml.develop.FV3_HRRR b/physics/docs/pdftxt/RE300/namelists/input.nml.FV3_HRRR similarity index 100% rename from physics/docs/pdftxt/RE300/namelists/input.nml.develop.FV3_HRRR rename to physics/docs/pdftxt/RE300/namelists/input.nml.FV3_HRRR diff --git a/physics/docs/pdftxt/RE300/namelists/input.nml.develop.FV3_RAP b/physics/docs/pdftxt/RE300/namelists/input.nml.FV3_RAP similarity index 100% rename from physics/docs/pdftxt/RE300/namelists/input.nml.develop.FV3_RAP rename to physics/docs/pdftxt/RE300/namelists/input.nml.FV3_RAP diff --git a/physics/docs/pdftxt/RE300/namelists/input.nml.develop.FV3_RRFS_v1beta b/physics/docs/pdftxt/RE300/namelists/input.nml.FV3_RRFS_v1beta similarity index 100% rename from physics/docs/pdftxt/RE300/namelists/input.nml.develop.FV3_RRFS_v1beta rename to physics/docs/pdftxt/RE300/namelists/input.nml.FV3_RRFS_v1beta diff --git a/physics/docs/pdftxt/RE300/namelists/input.nml.develop.FV3_WoFS_v0 b/physics/docs/pdftxt/RE300/namelists/input.nml.FV3_WoFS_v0 similarity index 100% rename from physics/docs/pdftxt/RE300/namelists/input.nml.develop.FV3_WoFS_v0 rename to physics/docs/pdftxt/RE300/namelists/input.nml.FV3_WoFS_v0 diff --git a/physics/docs/pdftxt/RE300/namelists/input.nml.v21.FV3_GFS_v16 b/physics/docs/pdftxt/RE300/namelists/input.nml.v21.FV3_GFS_v16 deleted file mode 100644 index 6dc85900b..000000000 --- a/physics/docs/pdftxt/RE300/namelists/input.nml.v21.FV3_GFS_v16 +++ /dev/null @@ -1,336 +0,0 @@ -&amip_interp_nml - data_set = 'reynolds_oi' - date_out_of_range = 'climo' - interp_oi_sst = .true. - no_anom_sst = .false. - use_ncep_ice = .false. - use_ncep_sst = .true. -/ - -&atmos_model_nml - blocksize = 40 - ccpp_suite = 'FV3_GFS_v16' - chksum_debug = .false. - dycore_only = .false. -/ - -&cires_ugwp_nml - knob_ugwp_azdir = 2, 4, 4, 4 - knob_ugwp_doaxyz = 1 - knob_ugwp_doheat = 1 - knob_ugwp_dokdis = 1 - knob_ugwp_effac = 1, 1, 1, 1 - knob_ugwp_ndx4lh = 1 - knob_ugwp_solver = 2 - knob_ugwp_source = 1, 1, 0, 0 - knob_ugwp_stoch = 0, 0, 0, 0 - knob_ugwp_version = 0 - knob_ugwp_wvspec = 1, 25, 25, 25 - launch_level = 27 -/ - -&diag_manager_nml - prepend_date = .false. -/ - -&external_ic_nml - checker_tr = .false. - filtered_terrain = .true. - gfs_dwinds = .true. - levp = 65 - nt_checker = 0 -/ - -&fms_io_nml - checksum_required = .false. - max_files_r = 100 - max_files_w = 100 -/ - -&fms_nml - clock_grain = 'ROUTINE' - domains_stack_size = 5000000 - print_memory_usage = .false. -/ - -&fv_core_nml - a_imp = 1.0 - adjust_dry_mass = .false. - agrid_vel_rst = .false. - bc_update_interval = 6 - beta = 0.0 - consv_am = .false. - consv_te = 0.0 - d2_bg = 0.0 - d2_bg_k1 = 0.2 - d2_bg_k2 = 0.0 - d4_bg = 0.12 - d_con = 1.0 - d_ext = 0.0 - dddmp = 0.1 - delt_max = 0.008 - dnats = 1 - do_sat_adj = .true. - do_schmidt = .true. - do_vort_damp = .true. - dwind_2d = .false. - dz_min = 2 - external_eta = .true. - external_ic = .true. - fill = .true. - full_zs_filter = .false. - fv_debug = .false. - fv_sg_adj = 450 - gfs_phil = .false. - hord_dp = -5 - hord_mt = 5 - hord_tm = 5 - hord_tr = 10 - hord_vt = 5 - hydrostatic = .false. - io_layout = 1, 1 - k_split = 6 - ke_bg = 0.0 - kord_mt = 9 - kord_tm = -9 - kord_tr = 9 - kord_wz = 9 - layout = 5, 2 - make_nh = .false. - mountain = .false. - n_split = 6 - n_sponge = 10 - n_zs_filter = 0 - na_init = 0 - ncep_ic = .false. - nggps_ic = .true. - no_dycore = .false. - nord = 3 - npx = 220 - npy = 132 - npz = 64 - nrows_blend = 10 - ntiles = 1 - nudge_dz = .false. - nudge_qv = .true. - nwat = 6 - p_fac = 0.1 - phys_hydrostatic = .false. - print_freq = 6 - psm_bc = 1 - range_warn = .false. - read_increment = .false. - regional = .true. - regional_bcs_from_gsi = .false. - res_latlon_dynamics = '' - reset_eta = .false. - rf_cutoff = 750.0 - stretch_fac = 0.999 - target_lat = 38.5 - target_lon = -97.5 - tau = 10.0 - use_hydro_pressure = .false. - vtdm4 = 0.02 - warm_start = .false. - write_restart_with_bcs = .false. - z_tracer = .true. -/ - -&fv_grid_nml - grid_file = 'INPUT/grid_spec.nc' -/ - -&gfdl_cloud_microphysics_nml - c_cracw = 0.8 - c_paut = 0.5 - c_pgacs = 0.01 - c_psaci = 0.05 - ccn_l = 300.0 - ccn_o = 100.0 - const_vg = .false. - const_vi = .false. - const_vr = .false. - const_vs = .false. - de_ice = .false. - do_qa = .true. - do_sedi_heat = .false. - dw_land = 0.16 - dw_ocean = 0.1 - fast_sat_adj = .true. - fix_negative = .true. - icloud_f = 1 - mono_prof = .true. - mp_time = 150.0 - prog_ccn = .false. - qi0_crt = 8e-05 - qi_lim = 1.0 - ql_gen = 0.001 - ql_mlt = 0.001 - qs0_crt = 0.001 - rad_graupel = .true. - rad_rain = .true. - rad_snow = .true. - reiflag = 2 - rh_inc = 0.3 - rh_inr = 0.3 - rh_ins = 0.3 - rthresh = 1e-05 - sedi_transport = .true. - tau_g2v = 900.0 - tau_i2s = 1000.0 - tau_l2v = 225.0 - tau_v2l = 150.0 - use_ccn = .true. - use_ppm = .false. - vg_max = 12.0 - vi_max = 1.0 - vr_max = 12.0 - vs_max = 2.0 - z_slope_ice = .true. - z_slope_liq = .true. -/ - -&gfs_physics_nml - cal_pre = .false. - cdmbgwd = 4.0, 0.15, 1.0, 1.0 - cnvcld = .true. - cnvgwd = .true. - debug = .false. - do_shum = .false. - do_skeb = .false. - do_spp = .false. - do_sppt = .false. - do_tofd = .true. - do_ugwp = .false. - dspheat = .true. - effr_in = .true. - fhcyc = 0 - fhlwr = 3600.0 - fhswr = 3600.0 - fhzero = 1.0 - h2o_phys = .true. - hybedmf = .false. - iaer = 5111 - ialb = 1 - iau_inc_files = '' - icliq_sw = 2 - ico2 = 2 - iems = 1 - imfdeepcnv = 2 - imfshalcnv = 2 - imp_physics = 11 - iopt_alb = 2 - iopt_btr = 1 - iopt_crs = 1 - iopt_dveg = 1 - iopt_frz = 1 - iopt_inf = 1 - iopt_rad = 1 - iopt_run = 1 - iopt_sfc = 1 - iopt_snf = 4 - iopt_stc = 1 - iopt_tbot = 2 - iopt_trs = 2 - iovr = 3 - isatmedmf = 1 - isol = 2 - isot = 1 - isubc_lw = 2 - isubc_sw = 2 - ivegsrc = 1 - ldiag3d = .false. - ldiag_ugwp = .false. - lgfdlmprad = .true. - lheatstrg = .true. - lndp_type = 0 - lsm = 1 - lsoil = 4 - lwhtr = .true. - n_var_lndp = 0 - n_var_spp = 0 - nsradar_reset = 3600 - nst_anl = .true. - nstf_name = 2, 1, 0, 0, 0 - oz_phys = .false. - oz_phys_2015 = .true. - pdfcld = .false. - prautco = 0.00015, 0.00015 - pre_rad = .false. - print_diff_pgr = .false. - prslrd0 = 0.0 - psautco = 0.0008, 0.0005 - random_clds = .false. - redrag = .true. - satmedmf = .true. - sfclay_compute_flux = .false. - shal_cnv = .true. - swhtr = .true. - trans_trac = .true. - use_ufo = .true. -/ - -&interpolator_nml - interp_method = 'conserve_great_circle' -/ - -&mpp_io_nml - deflate_level = 1 - shuffle = 1 -/ - -&nam_sfcperts -/ - -&nam_sppperts -/ - -&nam_stochy -/ - -&namsfc - fabsl = 99999 - faisl = 99999 - faiss = 99999 - fnacna = '' - fnaisc = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/CFSR.SEAICE.1982.2012.monthly.clim.grb' - fnglac = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/global_glacier.2x2.grb' - fnmskh = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/seaice_newland.grb' - fnmxic = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/global_maxice.2x2.grb' - fnsmcc = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/global_soilmgldas.t126.384.190.grb' - fnsnoa = '' - fnsnoc = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/global_snoclim.1.875.grb' - fntsfa = '' - fntsfc = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/RTGSST.1982.2012.monthly.clim.grb' - fnzorc = 'igbp' - fsicl = 99999 - fsics = 99999 - fslpl = 99999 - fsmcl = 99999, 99999, 99999 - fsnol = 99999 - fsnos = 99999 - fsotl = 99999 - ftsfl = 99999 - ftsfs = 90 - fvetl = 99999 - fvmnl = 99999 - fvmxl = 99999 - landice = .true. - ldebug = .false. -/ - -&namsfc_dict - fnabsc = '../fix_lam/C403.maximum_snow_albedo.tileX.nc' - fnalbc = '../fix_lam/C403.snowfree_albedo.tileX.nc' - fnalbc2 = '../fix_lam/C403.facsf.tileX.nc' - fnslpc = '../fix_lam/C403.slope_type.tileX.nc' - fnsotc = '../fix_lam/C403.soil_type.tileX.nc' - fntg3c = '../fix_lam/C403.substrate_temperature.tileX.nc' - fnvegc = '../fix_lam/C403.vegetation_greenness.tileX.nc' - fnvetc = '../fix_lam/C403.vegetation_type.tileX.nc' - fnvmnc = '../fix_lam/C403.vegetation_greenness.tileX.nc' - fnvmxc = '../fix_lam/C403.vegetation_greenness.tileX.nc' -/ - -&surf_map_nml -/ diff --git a/physics/docs/pdftxt/RE300/namelists/input.nml.v21.FV3_HRRR b/physics/docs/pdftxt/RE300/namelists/input.nml.v21.FV3_HRRR deleted file mode 100644 index cd9408a4d..000000000 --- a/physics/docs/pdftxt/RE300/namelists/input.nml.v21.FV3_HRRR +++ /dev/null @@ -1,299 +0,0 @@ -&amip_interp_nml - data_set = 'reynolds_oi' - date_out_of_range = 'climo' - interp_oi_sst = .true. - no_anom_sst = .false. - use_ncep_ice = .false. - use_ncep_sst = .true. -/ - -&atmos_model_nml - blocksize = 40 - ccpp_suite = 'FV3_HRRR' - chksum_debug = .false. - dycore_only = .false. -/ - -&cires_ugwp_nml - knob_ugwp_azdir = 2, 4, 4, 4 - knob_ugwp_doaxyz = 1 - knob_ugwp_doheat = 1 - knob_ugwp_dokdis = 1 - knob_ugwp_effac = 1, 1, 1, 1 - knob_ugwp_ndx4lh = 1 - knob_ugwp_solver = 2 - knob_ugwp_source = 1, 1, 0, 0 - knob_ugwp_stoch = 0, 0, 0, 0 - knob_ugwp_version = 0 - knob_ugwp_wvspec = 1, 25, 25, 25 - launch_level = 25 -/ - -&diag_manager_nml - prepend_date = .false. -/ - -&external_ic_nml - checker_tr = .false. - filtered_terrain = .true. - gfs_dwinds = .true. - levp = 65 - nt_checker = 0 -/ - -&fms_io_nml - checksum_required = .false. - max_files_r = 100 - max_files_w = 100 -/ - -&fms_nml - clock_grain = 'ROUTINE' - domains_stack_size = 5000000 - print_memory_usage = .false. -/ - -&fv_core_nml - a_imp = 1.0 - adjust_dry_mass = .false. - bc_update_interval = 6 - beta = 0.0 - consv_am = .false. - consv_te = 0.0 - d2_bg = 0.0 - d2_bg_k1 = 0.2 - d2_bg_k2 = 0.04 - d4_bg = 0.12 - d_con = 1.0 - d_ext = 0.0 - dddmp = 0.1 - delt_max = 0.008 - dnats = 0 - do_sat_adj = .false. - do_schmidt = .true. - do_vort_damp = .true. - dwind_2d = .false. - dz_min = 2 - external_eta = .true. - external_ic = .true. - fill = .true. - full_zs_filter = .false. - fv_debug = .false. - fv_sg_adj = 300 - gfs_phil = .false. - hord_dp = -5 - hord_mt = 5 - hord_tm = 5 - hord_tr = 10 - hord_vt = 5 - hydrostatic = .false. - io_layout = 1, 1 - k_split = 2 - ke_bg = 0.0 - kord_mt = 9 - kord_tm = -9 - kord_tr = 9 - kord_wz = 9 - layout = 5, 2 - make_nh = .true. - mountain = .false. - n_split = 5 - n_sponge = 24 - n_zs_filter = 0 - na_init = 1 - ncep_ic = .false. - nggps_ic = .true. - no_dycore = .false. - nord = 3 - nord_tr = 2 - npx = 220 - npy = 132 - npz = 64 - nrows_blend = 10 - ntiles = 1 - nudge_qv = .false. - nwat = 6 - p_fac = 0.1 - phys_hydrostatic = .false. - print_freq = 6 - psm_bc = 1 - range_warn = .true. - read_increment = .false. - regional = .true. - regional_bcs_from_gsi = .false. - res_latlon_dynamics = 'fv3_increment.nc' - reset_eta = .false. - rf_cutoff = 2000.0 - stretch_fac = 0.999 - target_lat = 38.5 - target_lon = -97.5 - tau = 5.0 - use_hydro_pressure = .false. - vtdm4 = 0.02 - warm_start = .false. - write_restart_with_bcs = .false. - z_tracer = .true. -/ - -&fv_grid_nml - grid_file = 'INPUT/grid_spec.nc' -/ - -&gfs_physics_nml - bl_mynn_edmf = 1 - bl_mynn_edmf_mom = 1 - bl_mynn_tkeadvect = .true. - cal_pre = .false. - cdmbgwd = 3.5, 1.0 - cnvcld = .false. - cnvgwd = .false. - cplflx = .false. - debug = .false. - do_deep = .false. - do_gsl_drag_ls_bl = .true. - do_gsl_drag_ss = .true. - do_gsl_drag_tofd = .true. - do_mynnedmf = .true. - do_mynnsfclay = .true. - do_shum = .false. - do_skeb = .false. - do_spp = .false. - do_sppt = .false. - dspheat = .true. - effr_in = .true. - fhcyc = 0 - fhlwr = 1200.0 - fhswr = 1200.0 - fhzero = 1.0 - gwd_opt = 3 - h2o_phys = .true. - hybedmf = .false. - iaer = 5111 - ialb = 1 - iau_delthrs = 6 - iau_inc_files = '' - iaufhrs = 30 - icliq_sw = 2 - icloud_bl = 1 - ico2 = 2 - iems = 1 - imfdeepcnv = -1 - imfshalcnv = -1 - imp_physics = 8 - iopt_alb = 2 - iopt_btr = 1 - iopt_crs = 1 - iopt_dveg = 2 - iopt_frz = 1 - iopt_inf = 1 - iopt_rad = 1 - iopt_run = 1 - iopt_sfc = 1 - iopt_snf = 4 - iopt_stc = 1 - iopt_tbot = 2 - iopt_trs = 2 - iovr = 3 - isol = 2 - isot = 1 - isubc_lw = 2 - isubc_sw = 2 - ivegsrc = 1 - kice = 9 - ldiag3d = .false. - lheatstrg = .false. - lndp_type = 0 - lradar = .true. - lsm = 3 - lsoil = 4 - lsoil_lsm = 9 - ltaerosol = .true. - lwhtr = .true. - n_var_lndp = 0 - n_var_spp = 0 - nsradar_reset = 3600 - nst_anl = .true. - nstf_name = 2, 1, 0, 0, 0 - oz_phys = .false. - oz_phys_2015 = .true. - pdfcld = .false. - pre_rad = .false. - print_diff_pgr = .false. - prslrd0 = 0.0 - random_clds = .false. - redrag = .true. - satmedmf = .false. - sfclay_compute_flux = .true. - shal_cnv = .false. - swhtr = .true. - trans_trac = .true. - ttendlim = -999 - use_ufo = .true. -/ - -&interpolator_nml - interp_method = 'conserve_great_circle' -/ - -&nam_sfcperts -/ - -&nam_sppperts -/ - -&nam_stochy -/ - -&namsfc - fabsl = 99999 - faisl = 99999 - faiss = 99999 - fnacna = '' - fnaisc = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/CFSR.SEAICE.1982.2012.monthly.clim.grb' - fnglac = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/global_glacier.2x2.grb' - fnmskh = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/seaice_newland.grb' - fnmxic = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/global_maxice.2x2.grb' - fnsmcc = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/global_soilmgldas.t126.384.190.grb' - fnsnoa = '' - fnsnoc = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/global_snoclim.1.875.grb' - fntsfa = '' - fntsfc = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/RTGSST.1982.2012.monthly.clim.grb' - fnzorc = 'igbp' - fsicl = 99999 - fsics = 99999 - fslpl = 99999 - fsmcl = 99999, 99999, 99999 - fsnol = 99999 - fsnos = 99999 - fsotl = 99999 - ftsfl = 99999 - ftsfs = 90 - fvetl = 99999 - fvmnl = 99999 - fvmxl = 99999 - ldebug = .true. -/ - -&namsfc_dict - fnabsc = '../fix_lam/C403.maximum_snow_albedo.tileX.nc' - fnalbc = '../fix_lam/C403.snowfree_albedo.tileX.nc' - fnalbc2 = '../fix_lam/C403.facsf.tileX.nc' - fnslpc = '../fix_lam/C403.slope_type.tileX.nc' - fnsotc = '../fix_lam/C403.soil_type.tileX.nc' - fntg3c = '../fix_lam/C403.substrate_temperature.tileX.nc' - fnvegc = '../fix_lam/C403.vegetation_greenness.tileX.nc' - fnvetc = '../fix_lam/C403.vegetation_type.tileX.nc' - fnvmnc = '../fix_lam/C403.vegetation_greenness.tileX.nc' - fnvmxc = '../fix_lam/C403.vegetation_greenness.tileX.nc' -/ - -&surf_map_nml - cd2 = -1 - cd4 = 0.12 - max_slope = 0.4 - n_del2_strong = 0 - n_del2_weak = 2 - n_del4 = 1 - peak_fac = 1.0 - zero_ocean = .false. -/ diff --git a/physics/docs/pdftxt/RE300/namelists/input.nml.v21.FV3_RRFS_v1beta b/physics/docs/pdftxt/RE300/namelists/input.nml.v21.FV3_RRFS_v1beta deleted file mode 100644 index 97e775107..000000000 --- a/physics/docs/pdftxt/RE300/namelists/input.nml.v21.FV3_RRFS_v1beta +++ /dev/null @@ -1,291 +0,0 @@ -&amip_interp_nml - data_set = 'reynolds_oi' - date_out_of_range = 'climo' - interp_oi_sst = .true. - no_anom_sst = .false. - use_ncep_ice = .false. - use_ncep_sst = .true. -/ - -&atmos_model_nml - blocksize = 40 - ccpp_suite = 'FV3_RRFS_v1beta' - chksum_debug = .false. - dycore_only = .false. -/ - -&cires_ugwp_nml - knob_ugwp_azdir = 2, 4, 4, 4 - knob_ugwp_doaxyz = 1 - knob_ugwp_doheat = 1 - knob_ugwp_dokdis = 1 - knob_ugwp_effac = 1, 1, 1, 1 - knob_ugwp_ndx4lh = 1 - knob_ugwp_solver = 2 - knob_ugwp_source = 1, 1, 0, 0 - knob_ugwp_stoch = 0, 0, 0, 0 - knob_ugwp_version = 0 - knob_ugwp_wvspec = 1, 25, 25, 25 - launch_level = 25 -/ - -&diag_manager_nml - prepend_date = .false. -/ - -&external_ic_nml - checker_tr = .false. - filtered_terrain = .true. - gfs_dwinds = .true. - levp = 65 - nt_checker = 0 -/ - -&fms_io_nml - checksum_required = .false. - max_files_r = 100 - max_files_w = 100 -/ - -&fms_nml - clock_grain = 'ROUTINE' - domains_stack_size = 5000000 - print_memory_usage = .false. -/ - -&fv_core_nml - a_imp = 1.0 - adjust_dry_mass = .false. - bc_update_interval = 6 - beta = 0.0 - consv_am = .false. - consv_te = 0.0 - d2_bg = 0.0 - d2_bg_k1 = 0.2 - d2_bg_k2 = 0.04 - d4_bg = 0.12 - d_con = 1.0 - d_ext = 0.0 - dddmp = 0.1 - delt_max = 0.008 - dnats = 0 - do_sat_adj = .false. - do_schmidt = .true. - do_vort_damp = .true. - dwind_2d = .false. - dz_min = 2 - external_eta = .true. - external_ic = .true. - fill = .true. - full_zs_filter = .false. - fv_debug = .false. - fv_sg_adj = 300 - gfs_phil = .false. - hord_dp = 6 - hord_mt = 6 - hord_tm = 6 - hord_tr = 10 - hord_vt = 6 - hydrostatic = .false. - io_layout = 1, 1 - k_split = 2 - ke_bg = 0.0 - kord_mt = 9 - kord_tm = -9 - kord_tr = 9 - kord_wz = 9 - layout = 5, 2 - make_nh = .true. - mountain = .false. - n_split = 5 - n_sponge = 24 - n_zs_filter = 0 - na_init = 1 - ncep_ic = .false. - nggps_ic = .true. - no_dycore = .false. - nord = 3 - npx = 220 - npy = 132 - npz = 64 - nrows_blend = 10 - ntiles = 1 - nudge_qv = .false. - nwat = 6 - p_fac = 0.1 - phys_hydrostatic = .false. - print_freq = 6 - psm_bc = 1 - range_warn = .true. - read_increment = .false. - regional = .true. - regional_bcs_from_gsi = .false. - res_latlon_dynamics = 'fv3_increment.nc' - reset_eta = .false. - rf_cutoff = 2000.0 - stretch_fac = 0.999 - target_lat = 38.5 - target_lon = -97.5 - tau = 5.0 - use_hydro_pressure = .false. - vtdm4 = 0.02 - warm_start = .false. - write_restart_with_bcs = .false. - z_tracer = .true. -/ - -&fv_grid_nml - grid_file = 'INPUT/grid_spec.nc' -/ - -&gfs_physics_nml - bl_mynn_edmf = 1 - bl_mynn_edmf_mom = 1 - bl_mynn_tkeadvect = .true. - cal_pre = .false. - cdmbgwd = 3.5, 0.25 - cnvcld = .false. - cnvgwd = .false. - cplflx = .false. - debug = .false. - do_deep = .false. - do_mynnedmf = .true. - do_mynnsfclay = .true. - do_shum = .false. - do_skeb = .false. - do_spp = .false. - do_sppt = .false. - dspheat = .true. - effr_in = .true. - fhcyc = 0 - fhlwr = 1200.0 - fhswr = 1200.0 - fhzero = 1.0 - h2o_phys = .true. - hybedmf = .false. - iaer = 111 - ialb = 1 - iau_delthrs = 6 - iau_inc_files = '' - iaufhrs = 30 - icloud_bl = 1 - ico2 = 2 - iems = 1 - imfdeepcnv = -1 - imfshalcnv = -1 - imp_physics = 8 - iopt_alb = 2 - iopt_btr = 1 - iopt_crs = 1 - iopt_dveg = 2 - iopt_frz = 1 - iopt_inf = 1 - iopt_rad = 1 - iopt_run = 1 - iopt_sfc = 1 - iopt_snf = 4 - iopt_stc = 1 - iopt_tbot = 2 - iopt_trs = 2 - isol = 2 - isot = 1 - isubc_lw = 2 - isubc_sw = 2 - ivegsrc = 1 - ldiag3d = .false. - lheatstrg = .false. - lndp_type = 0 - lradar = .true. - lsm = 2 - lsoil = 4 - lsoil_lsm = 4 - ltaerosol = .true. - lwhtr = .true. - n_var_lndp = 0 - n_var_spp = 0 - nsradar_reset = 3600 - nst_anl = .true. - nstf_name = 2, 1, 0, 0, 0 - oz_phys = .false. - oz_phys_2015 = .true. - pdfcld = .false. - pre_rad = .false. - print_diff_pgr = .false. - prslrd0 = 0.0 - random_clds = .false. - redrag = .true. - satmedmf = .false. - sfclay_compute_flux = .false. - shal_cnv = .false. - swhtr = .true. - trans_trac = .true. - ttendlim = -999 - use_ufo = .true. -/ - -&interpolator_nml - interp_method = 'conserve_great_circle' -/ - -&nam_sfcperts -/ - -&nam_sppperts -/ - -&nam_stochy -/ - -&namsfc - fabsl = 99999 - faisl = 99999 - faiss = 99999 - fnacna = '' - fnaisc = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/CFSR.SEAICE.1982.2012.monthly.clim.grb' - fnglac = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/global_glacier.2x2.grb' - fnmskh = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/seaice_newland.grb' - fnmxic = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/global_maxice.2x2.grb' - fnsmcc = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/global_soilmgldas.t126.384.190.grb' - fnsnoa = '' - fnsnoc = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/global_snoclim.1.875.grb' - fntsfa = '' - fntsfc = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/RTGSST.1982.2012.monthly.clim.grb' - fnzorc = 'igbp' - fsicl = 99999 - fsics = 99999 - fslpl = 99999 - fsmcl = 99999, 99999, 99999 - fsnol = 99999 - fsnos = 99999 - fsotl = 99999 - ftsfl = 99999 - ftsfs = 90 - fvetl = 99999 - fvmnl = 99999 - fvmxl = 99999 - ldebug = .true. -/ - -&namsfc_dict - fnabsc = '../fix_lam/C403.maximum_snow_albedo.tileX.nc' - fnalbc = '../fix_lam/C403.snowfree_albedo.tileX.nc' - fnalbc2 = '../fix_lam/C403.facsf.tileX.nc' - fnslpc = '../fix_lam/C403.slope_type.tileX.nc' - fnsotc = '../fix_lam/C403.soil_type.tileX.nc' - fntg3c = '../fix_lam/C403.substrate_temperature.tileX.nc' - fnvegc = '../fix_lam/C403.vegetation_greenness.tileX.nc' - fnvetc = '../fix_lam/C403.vegetation_type.tileX.nc' - fnvmnc = '../fix_lam/C403.vegetation_greenness.tileX.nc' - fnvmxc = '../fix_lam/C403.vegetation_greenness.tileX.nc' -/ - -&surf_map_nml - cd2 = -1 - cd4 = 0.12 - max_slope = 0.4 - n_del2_strong = 0 - n_del2_weak = 2 - n_del4 = 1 - peak_fac = 1.0 - zero_ocean = .false. -/ diff --git a/physics/docs/pdftxt/RE300/namelists/input.nml.v21.FV3_WoFS_v0 b/physics/docs/pdftxt/RE300/namelists/input.nml.v21.FV3_WoFS_v0 deleted file mode 100644 index 94cc34d0f..000000000 --- a/physics/docs/pdftxt/RE300/namelists/input.nml.v21.FV3_WoFS_v0 +++ /dev/null @@ -1,297 +0,0 @@ -&amip_interp_nml - data_set = 'reynolds_oi' - date_out_of_range = 'climo' - interp_oi_sst = .true. - no_anom_sst = .false. - use_ncep_ice = .false. - use_ncep_sst = .true. -/ - -&atmos_model_nml - blocksize = 40 - ccpp_suite = 'FV3_WoFS_v0' - chksum_debug = .false. - dycore_only = .false. -/ - -&cires_ugwp_nml - knob_ugwp_azdir = 2, 4, 4, 4 - knob_ugwp_doaxyz = 1 - knob_ugwp_doheat = 1 - knob_ugwp_dokdis = 1 - knob_ugwp_effac = 1, 1, 1, 1 - knob_ugwp_ndx4lh = 1 - knob_ugwp_solver = 2 - knob_ugwp_source = 1, 1, 0, 0 - knob_ugwp_stoch = 0, 0, 0, 0 - knob_ugwp_version = 0 - knob_ugwp_wvspec = 1, 25, 25, 25 - launch_level = 25 -/ - -&diag_manager_nml - prepend_date = .false. -/ - -&external_ic_nml - checker_tr = .false. - filtered_terrain = .true. - gfs_dwinds = .true. - levp = 65 - nt_checker = 0 -/ - -&fms_io_nml - checksum_required = .false. - max_files_r = 100 - max_files_w = 100 -/ - -&fms_nml - clock_grain = 'ROUTINE' - domains_stack_size = 5000000 - print_memory_usage = .false. -/ - -&fv_core_nml - a_imp = 1.0 - adjust_dry_mass = .false. - bc_update_interval = 6 - beta = 0.0 - consv_am = .false. - consv_te = 0.0 - d2_bg = 0.0 - d2_bg_k1 = 0.2 - d2_bg_k2 = 0.04 - d4_bg = 0.12 - d_con = 1.0 - d_ext = 0.0 - dddmp = 0.1 - delt_max = 0.008 - dnats = 0 - do_sat_adj = .false. - do_schmidt = .true. - do_vort_damp = .true. - dwind_2d = .false. - dz_min = 2 - external_eta = .true. - external_ic = .true. - fill = .true. - full_zs_filter = .false. - fv_debug = .false. - fv_sg_adj = 300 - gfs_phil = .false. - hord_dp = 6 - hord_mt = 6 - hord_tm = 6 - hord_tr = 10 - hord_vt = 6 - hydrostatic = .false. - io_layout = 1, 1 - k_split = 2 - ke_bg = 0.0 - kord_mt = 9 - kord_tm = -9 - kord_tr = 9 - kord_wz = 9 - layout = 5, 2 - make_nh = .true. - mountain = .false. - n_split = 5 - n_sponge = 24 - n_zs_filter = 0 - na_init = 1 - ncep_ic = .false. - nggps_ic = .true. - no_dycore = .false. - nord = 3 - npx = 220 - npy = 132 - npz = 64 - nrows_blend = 10 - ntiles = 1 - nudge_qv = .false. - nwat = 7 - p_fac = 0.1 - phys_hydrostatic = .false. - print_freq = 6 - psm_bc = 1 - range_warn = .true. - read_increment = .false. - regional = .true. - regional_bcs_from_gsi = .false. - res_latlon_dynamics = 'fv3_increment.nc' - reset_eta = .false. - rf_cutoff = 2000.0 - stretch_fac = 0.999 - target_lat = 38.5 - target_lon = -97.5 - tau = 5.0 - use_hydro_pressure = .false. - vtdm4 = 0.02 - warm_start = .false. - write_restart_with_bcs = .false. - z_tracer = .true. -/ - -&fv_diagnostics_nml - do_hailcast = .true. -/ - -&fv_grid_nml - grid_file = 'INPUT/grid_spec.nc' -/ - -&gfs_physics_nml - bl_mynn_edmf = 1 - bl_mynn_edmf_mom = 1 - bl_mynn_tkeadvect = .true. - cal_pre = .false. - cdmbgwd = 3.5, 0.25 - cnvcld = .false. - cnvgwd = .false. - cplflx = .false. - debug = .false. - do_deep = .false. - do_mynnedmf = .true. - do_mynnsfclay = .true. - do_shum = .false. - do_skeb = .false. - do_spp = .false. - do_sppt = .false. - dspheat = .true. - effr_in = .true. - fhcyc = 0 - fhlwr = 1200.0 - fhswr = 1200.0 - fhzero = 1.0 - h2o_phys = .true. - hybedmf = .false. - iaer = 111 - ialb = 1 - iau_delthrs = 6 - iau_inc_files = '' - iaufhrs = 30 - icloud_bl = 1 - ico2 = 2 - iems = 1 - imfdeepcnv = -1 - imfshalcnv = -1 - imp_physics = 17 - iopt_alb = 2 - iopt_btr = 1 - iopt_crs = 1 - iopt_dveg = 2 - iopt_frz = 1 - iopt_inf = 1 - iopt_rad = 1 - iopt_run = 1 - iopt_sfc = 1 - iopt_snf = 4 - iopt_stc = 1 - iopt_tbot = 2 - isol = 2 - isot = 1 - isubc_lw = 2 - isubc_sw = 2 - ivegsrc = 1 - ldiag3d = .false. - lheatstrg = .false. - lndp_type = 0 - lradar = .true. - lsm = 1 - lsoil = 4 - lsoil_lsm = 4 - ltaerosol = .true. - lwhtr = .true. - n_var_lndp = 0 - n_var_spp = 0 - nsradar_reset = 3600 - nssl_cccn = 600000000.0 - nssl_ccn_on = .true. - nssl_hail_on = .true. - nst_anl = .true. - nstf_name = 2, 1, 0, 0, 0 - oz_phys = .false. - oz_phys_2015 = .true. - pdfcld = .false. - pre_rad = .false. - print_diff_pgr = .false. - prslrd0 = 0.0 - random_clds = .false. - redrag = .true. - satmedmf = .false. - sfclay_compute_flux = .false. - shal_cnv = .false. - swhtr = .true. - trans_trac = .true. - ttendlim = -999 - use_ufo = .true. -/ - -&interpolator_nml - interp_method = 'conserve_great_circle' -/ - -&nam_sfcperts -/ - -&nam_sppperts -/ - -&nam_stochy -/ - -&namsfc - fabsl = 99999 - faisl = 99999 - faiss = 99999 - fnacna = '' - fnaisc = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/CFSR.SEAICE.1982.2012.monthly.clim.grb' - fnglac = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/global_glacier.2x2.grb' - fnmskh = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/seaice_newland.grb' - fnmxic = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/global_maxice.2x2.grb' - fnsmcc = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/global_soilmgldas.t126.384.190.grb' - fnsnoa = '' - fnsnoc = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/global_snoclim.1.875.grb' - fntsfa = '' - fntsfc = '../../../../../../../../../../det/UFS_SRW_App/v2p0/fix/fix_am/RTGSST.1982.2012.monthly.clim.grb' - fnzorc = 'igbp' - fsicl = 99999 - fsics = 99999 - fslpl = 99999 - fsmcl = 99999, 99999, 99999 - fsnol = 99999 - fsnos = 99999 - fsotl = 99999 - ftsfl = 99999 - ftsfs = 90 - fvetl = 99999 - fvmnl = 99999 - fvmxl = 99999 - ldebug = .true. -/ - -&namsfc_dict - fnabsc = '../fix_lam/C403.maximum_snow_albedo.tileX.nc' - fnalbc = '../fix_lam/C403.snowfree_albedo.tileX.nc' - fnalbc2 = '../fix_lam/C403.facsf.tileX.nc' - fnslpc = '../fix_lam/C403.slope_type.tileX.nc' - fnsotc = '../fix_lam/C403.soil_type.tileX.nc' - fntg3c = '../fix_lam/C403.substrate_temperature.tileX.nc' - fnvegc = '../fix_lam/C403.vegetation_greenness.tileX.nc' - fnvetc = '../fix_lam/C403.vegetation_type.tileX.nc' - fnvmnc = '../fix_lam/C403.vegetation_greenness.tileX.nc' - fnvmxc = '../fix_lam/C403.vegetation_greenness.tileX.nc' -/ - -&surf_map_nml - cd2 = -1 - cd4 = 0.12 - max_slope = 0.4 - n_del2_strong = 0 - n_del2_weak = 2 - n_del4 = 1 - peak_fac = 1.0 - zero_ocean = .false. -/ From 8f447558d9638c713be4c5aa285d6d6e4f3f09d6 Mon Sep 17 00:00:00 2001 From: "Michael Kavulich, Jr" Date: Tue, 1 Aug 2023 10:40:35 -0600 Subject: [PATCH 309/380] Incorporate changes to FV3_HRRR namelist suggested by Tanya --- .../pdftxt/RE300/namelists/input.nml.FV3_HRRR | 29 +++++++++++-------- 1 file changed, 17 insertions(+), 12 deletions(-) diff --git a/physics/docs/pdftxt/RE300/namelists/input.nml.FV3_HRRR b/physics/docs/pdftxt/RE300/namelists/input.nml.FV3_HRRR index 8a7d621f3..e30bd44c6 100644 --- a/physics/docs/pdftxt/RE300/namelists/input.nml.FV3_HRRR +++ b/physics/docs/pdftxt/RE300/namelists/input.nml.FV3_HRRR @@ -65,7 +65,7 @@ d2_bg_k1 = 0.2 d2_bg_k2 = 0.04 d4_bg = 0.12 - d_con = 1.0 + d_con = 0.5 d_ext = 0.0 dddmp = 0.1 delt_max = 0.008 @@ -82,11 +82,11 @@ fv_debug = .false. fv_sg_adj = 300 gfs_phil = .false. - hord_dp = -5 - hord_mt = 5 - hord_tm = 5 - hord_tr = 10 - hord_vt = 5 + hord_dp = 6 + hord_mt = 6 + hord_tm = 6 + hord_tr = 8 + hord_vt = 6 hydrostatic = .false. io_layout = 1, 1 k_split = 2 @@ -99,14 +99,14 @@ make_nh = .true. mountain = .false. n_split = 5 - n_sponge = 24 + n_sponge = 9 n_zs_filter = 0 na_init = 1 ncep_ic = .false. nggps_ic = .true. no_dycore = .false. nord = 3 - nord_tr = 2 + nord_tr = 0 npx = 220 npy = 132 npz = 64 @@ -150,6 +150,7 @@ cnvgwd = .false. cplflx = .false. debug = .false. + diag_log = .true. do_deep = .false. do_gsl_drag_ls_bl = .true. do_gsl_drag_ss = .true. @@ -166,14 +167,14 @@ h2o_phys = .true. hybedmf = .false. iaer = 5111 - ialb = 1 + ialb = 2 iau_delthrs = 6 iau_inc_files = '' iaufhrs = 30 icliq_sw = 2 icloud_bl = 1 ico2 = 2 - iems = 1 + iems = 2 imfdeepcnv = -1 imfshalcnv = -1 imp_physics = 8 @@ -191,12 +192,15 @@ iopt_tbot = 2 iopt_trs = 2 iovr = 3 + isncond_opt = 2 + isncovr_opt = 3 isol = 2 isot = 1 isubc_lw = 2 isubc_sw = 2 ivegsrc = 1 kice = 9 + kice = 9 ldiag3d = .false. lheatstrg = .false. lradar = .true. @@ -205,9 +209,9 @@ lsoil_lsm = 9 ltaerosol = .true. lwhtr = .true. + mosaic_lu = 0 + mosaic_soil = 0 nsfullradar_diag = 3600 - nst_anl = .true. - nstf_name = 2, 1, 0, 0, 0 oz_phys = .false. oz_phys_2015 = .true. pdfcld = .false. @@ -220,6 +224,7 @@ sfclay_compute_flux = .true. shal_cnv = .false. swhtr = .true. + thsfc_loc = .false. trans_trac = .true. ttendlim = -999 use_ufo = .true. From aaa02d82af9309ea3df4880ad9d5eb9eb949b25d Mon Sep 17 00:00:00 2001 From: "Michael Kavulich, Jr" Date: Tue, 1 Aug 2023 11:02:55 -0600 Subject: [PATCH 310/380] Address Ligia/Weiwei's comments --- physics/docs/pdftxt/CU_GF_deep.txt | 8 ++++---- physics/docs/pdftxt/RRFS_v1beta_suite.txt | 2 +- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/physics/docs/pdftxt/CU_GF_deep.txt b/physics/docs/pdftxt/CU_GF_deep.txt index 1a02516f7..3b01a05a4 100644 --- a/physics/docs/pdftxt/CU_GF_deep.txt +++ b/physics/docs/pdftxt/CU_GF_deep.txt @@ -6,17 +6,17 @@ The Grell-Freitas (GF) scheme, as described in Grell and Freitas (2014) \cite gr Freitas et al. (2018) \cite freitas_et_al_2018, Freitas et al. (2021) \cite freitas_et_al_2021, and Lin et al. (2022) \cite Lin_2022 follows the mass flux approach published by Grell (1993) \cite grell_1993. Further developments by Grell and \f$D\acute{e}v\acute{e}nyi\f$ (2002) \cite Grell_2002 included implementing -stochastics through allowing parameter perturbations. In GF scale awareness, and the aerosol dependence through rain generation (following +stochastics through allowing parameter perturbations. The GF scheme takes into account aerosol dependence through rain generation (following Berry (1968) \cite berry_1968 and evaporation formulations (following Jiang et al. (2010) \cite Jiang_2010 ), depending on the cloud concentration nuclei at cloud base were added. The GF scheme includes mixed phase physics impact, momentum transport, a diurnal cycle closure (Bechtold et al. (2014) \cite bechtold_et_al_2014 ), and a trimodal spectral size to simulate the interaction and transition from shallow, congestus and deep convection regimes. The vertical mass flux distribution of shallow, congestus and -deep convection regimes is characterized by Probability Density Functions (PDFs). The three PDF's are meant to represent the average +deep convection regimes is characterized by Probability Density Functions (PDFs). The three PDFs are meant to represent the average statistical mass flux characteristic of deep, congestus, and shallow (respectively) plumes in the grid area. Each PDF therefore represents a spectrum of plumes within the grid box. Forcing is different for each characteristic type. Entrainment and detrainment are derived -from the PDF's. The deep and congestus convection considers scale awareness (Arakawa et al. (2011) \cite Arakawa_2011 ). However, the shallow convection is not scale-aware. Aerosol dependence is implemented through dependence of rain generation and +from the PDFs. Aerosol dependence (considered experimental and not supported in this release) is implemented through dependence of rain generation and evaporation formulations depending on the cloud concentration nuclei at cloud base (Berry 1968 \cite berry_1968, -Jiang et al.(2010) \cite Jiang_2010, and Lee and Feingold (2010) \cite lee_and_feingold_2010 ). Wet scavenging is considered to add a memory impact. Aerosol dependence is considered experimental and is turned off at this point. GF is able to transport tracers. +Jiang et al.(2010) \cite Jiang_2010, and Lee and Feingold (2010) \cite lee_and_feingold_2010 ). Wet scavenging is considered to add a memory impact. GF is able to transport tracers. Recently, GPU capabilities and cap suppressing (\p do_cap_suppress) based on radar data assimilation have been added,and they are used only for the RAP suite. The impacts of GF scheme in operational RAP/HRRR include:(a)uses mass-flux schemes, which are more physically realistic than (sounding) adjustment schemes; diff --git a/physics/docs/pdftxt/RRFS_v1beta_suite.txt b/physics/docs/pdftxt/RRFS_v1beta_suite.txt index ae400b982..b2e4ba676 100644 --- a/physics/docs/pdftxt/RRFS_v1beta_suite.txt +++ b/physics/docs/pdftxt/RRFS_v1beta_suite.txt @@ -3,7 +3,7 @@ \section RRFS_v1beta_suite_overview Overview -The RRFS_v1beta suite is one of candicates for the future operational implementation of +The RRFS_v1beta suite is one of the candidates for the future operational implementation of the Rapid Refresh Forecast System (RRFS), which can be configured using the UFS SRW App. This suite is most applicable for runs at 3-km resolution since it does not parameterize deep convection. From dbcd50fee66582d9b58fb03872b4ce34ab23531d Mon Sep 17 00:00:00 2001 From: "Michael Kavulich, Jr" Date: Tue, 1 Aug 2023 15:08:15 -0600 Subject: [PATCH 311/380] Remove hard-coded path in doxyfile --- physics/docs/ccppsrw_doxyfile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/docs/ccppsrw_doxyfile b/physics/docs/ccppsrw_doxyfile index 5c9c797b5..a45fad88f 100644 --- a/physics/docs/ccppsrw_doxyfile +++ b/physics/docs/ccppsrw_doxyfile @@ -542,7 +542,7 @@ DIRECTORY_GRAPH = YES DIR_GRAPH_MAX_DEPTH = 1 DOT_IMAGE_FORMAT = SVG INTERACTIVE_SVG = NO -DOT_PATH = /Users/man.zhang/homebrew/bin/dot +DOT_PATH = DOTFILE_DIRS = MSCFILE_DIRS = DIAFILE_DIRS = From 8188e26897b91083b315a0c8f83e32f54209c96d Mon Sep 17 00:00:00 2001 From: dustinswales Date: Tue, 1 Aug 2023 16:01:38 -0600 Subject: [PATCH 312/380] Split ozone physics into time_vary and run components --- physics/GFS_rrtmg_setup.meta | 12 +- physics/GFS_rrtmgp_setup.meta | 12 +- physics/ozphys_2015.F90 | 181 ++--------------------------- physics/ozphys_2015.meta | 205 +-------------------------------- physics/ozphys_time_vary.F90 | 177 +++++++++++++++++++++++++++++ physics/ozphys_time_vary.meta | 207 ++++++++++++++++++++++++++++++++++ 6 files changed, 406 insertions(+), 388 deletions(-) create mode 100644 physics/ozphys_time_vary.F90 create mode 100644 physics/ozphys_time_vary.meta diff --git a/physics/GFS_rrtmg_setup.meta b/physics/GFS_rrtmg_setup.meta index 42b999c82..f92d6f8db 100644 --- a/physics/GFS_rrtmg_setup.meta +++ b/physics/GFS_rrtmg_setup.meta @@ -174,22 +174,22 @@ type = integer intent = in [levozp] - standard_name = number_of_levels_in_ozone_data - long_name = number of levels in ozone data + standard_name = number_of_levels_in_ozone_climotology_data + long_name = number of levels in ozone climotology data units = count dimensions = () type = integer intent = in [timeozp] - standard_name = number_of_times_in_ozone_data - long_name = number of times in ozone data + standard_name = number_of_times_in_ozone_climotology_data + long_name = number of times in ozone climotology data units = count dimensions = () type = integer intent = in [latsozp] - standard_name = number_of_latitudes_in_ozone_data - long_name = number of latitude in ozone data + standard_name = number_of_latitudes_in_ozone_climotology_data + long_name = number of latitude in ozone climotology data units = count dimensions = () type = integer diff --git a/physics/GFS_rrtmgp_setup.meta b/physics/GFS_rrtmgp_setup.meta index 567294d4a..c8ed60650 100644 --- a/physics/GFS_rrtmgp_setup.meta +++ b/physics/GFS_rrtmgp_setup.meta @@ -267,22 +267,22 @@ type = integer intent = inout [levozp] - standard_name = number_of_levels_in_ozone_data - long_name = number of levels in ozone data + standard_name = number_of_levels_in_ozone_climotology_data + long_name = number of levels in ozone climotology data units = count dimensions = () type = integer intent = in [timeozp] - standard_name = number_of_times_in_ozone_data - long_name = number of times in ozone data + standard_name = number_of_times_in_ozone_climotology_data + long_name = number of times in ozone climotology data units = count dimensions = () type = integer intent = in [latsozp] - standard_name = number_of_latitudes_in_ozone_data - long_name = number of latitude in ozone data + standard_name = number_of_latitudes_in_ozone_climotology_data + long_name = number of latitude in ozone climotology data units = count dimensions = () type = integer diff --git a/physics/ozphys_2015.F90 b/physics/ozphys_2015.F90 index fda87611c..82ade0cbd 100644 --- a/physics/ozphys_2015.F90 +++ b/physics/ozphys_2015.F90 @@ -5,176 +5,13 @@ module ozphys_2015 use machine, only : kind_phys, kind_dbl_prec, kind_sngl_prec implicit none - public ozphys_2015_init, ozphys_2015_timestep_init, ozphys_2015_run + public ozphys_2015_run contains ! ########################################################################################### !>\defgroup GFS_ozphys_2015 GFS Ozone Photochemistry (2015) Module !! This module contains the CCPP-compliant Ozone 2015 photochemistry scheme. !> @{ -!> \section arg_table_ozphys_2015_init Argument Table -!! \htmlinclude ozphys_2015_init.html -!! -! ########################################################################################### - subroutine ozphys_2015_init(oz_phys_2015, nPts, latsozp, oz_lat, dlat, jindx1, jindx2, & - ddy, errmsg, errflg) - ! Inputs - logical, intent(in) :: & - oz_phys_2015 ! Control flag for NRL 2015 ozone physics scheme - integer, intent(in) :: & - nPts, & ! Horizontal dimension - latsozp ! Number of latitudes in ozone data - real(kind_phys), intent(in), dimension(:) :: & - oz_lat, & ! Latitudes of ozone data - dlat ! Latitudes of grid - ! Outputs - integer, intent(out), dimension(:) :: & - jindx1, & ! Interpolation index (low) for ozone data - jindx2 ! Interpolation index (high) for ozone data - real(kind_phys), intent(out), dimension(:) :: & - ddy ! Interpolation high index for ozone data - character(len=*), intent(out) :: & - errmsg ! CCPP error message - integer, intent(out) :: & - errflg ! CCPP error flag - - ! Local - integer i,j - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - ! Sanity check - if (.not.oz_phys_2015) then - write (errmsg,'(*(a))') 'Logic error: oz_phys_2015 == .false.' - errflg = 1 - return - endif - - ! Set indices - do j=1,nPts - jindx2(j) = latsozp + 1 - do i=1,latsozp - if (dlat(j) < oz_lat(i)) then - jindx2(j) = i - exit - endif - enddo - jindx1(j) = max(jindx2(j)-1,1) - jindx2(j) = min(jindx2(j),latsozp) - if (jindx2(j) .ne. jindx1(j)) then - ddy(j) = (dlat(j) - oz_lat(jindx1(j))) / (oz_lat(jindx2(j)) - oz_lat(jindx1(j))) - else - ddy(j) = 1.0 - endif - enddo - - end subroutine ozphys_2015_init - -! ########################################################################################### -!> \section arg_table_ozphys_2015_timestep_init Argument Table -!! \htmlinclude ozphys_2015_timestep_init.html -!! -! ########################################################################################### - subroutine ozphys_2015_timestep_init(nPts, idate, fhour, jindx1, jindx2, latsozp, levozp, & - oz_coeff, timeoz, ozplin, oz_time, oz_lat, ddy, ozplout, errmsg, errflg) - ! Inputs - integer, intent(in) :: & - nPts, & ! Horizontal dimension - latsozp, & ! Number of latitudes in ozone data - levozp, & ! Number of vertical layers in ozone data - oz_coeff, & ! Number of coefficients in ozone data - timeoz ! Number of times in ozone data - integer, intent(in),dimension(:) :: & - idate, & ! Initial date with different size and ordering - jindx1, & ! Interpolation index (low) for ozone - jindx2 ! Interpolation index (high) for ozone - real(kind_phys), intent(in) :: & - fhour ! Forecast hour - real(kind_phys), intent(in), dimension(:) :: & - ddy, & ! Interpolation high index for ozone data - oz_lat, & ! Latitudes for ozone data - oz_time ! Time for ozone data - real(kind_phys), intent(in), dimension(:,:,:,:) :: & - ozplin ! Ozone data - - ! Outputs - real(kind_phys), intent(out), dimension(:,:,:) :: & - ozplout ! Ozone forcing data - character(len=*), intent(out) :: & - errmsg ! CCPP error message - integer, intent(out) :: & - errflg ! CCPP error flag - - ! Local - integer :: idat(8),jdat(8),iday,j,j1,j2,l,nc,n1,n2,jdow,jdoy,& - jday,w3kindreal,w3kindint - real(kind_phys) :: tem, tx1, tx2, rjday - real(8) :: rinc(5) - real(4) :: rinc4(5) - !real(kind_dbl_prec) :: rinc(5) - !real(kind_sngl_prec) :: rinc4(5) - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - ! - idat=0 - idat(1)=idate(4) - idat(2)=idate(2) - idat(3)=idate(3) - idat(5)=idate(1) - rinc=0. - rinc(2)=fhour - call w3kind(w3kindreal,w3kindint) - if(w3kindreal==4) then - rinc4=rinc - CALL w3movdat(rinc4,idat,jdat) - else - CALL w3movdat(rinc,idat,jdat) - endif - ! - jdow = 0 - jdoy = 0 - jday = 0 - call w3doxdat(jdat,jdow,jdoy,jday) - rjday = jdoy + jdat(5) / 24. - IF (RJDAY < oz_time(1)) RJDAY = RJDAY + 365. - ! - n2 = timeoz + 1 - do j=2,timeoz - if (rjday < oz_time(j)) then - n2 = j - exit - endif - enddo - n1 = n2 - 1 - - tx1 = (oz_time(n2) - rjday) / (oz_time(n2) - oz_time(n1)) - tx2 = 1.0 - tx1 - - if (n2 > timeoz) n2 = n2 - timeoz - ! - do nc=1,oz_coeff - do L=1,levozp - do J=1,npts - J1 = jindx1(J) - J2 = jindx2(J) - TEM = 1.0 - ddy(J) - ozplout(j,L,nc) = tx1*(TEM*ozplin(J1,L,nc,n1)+ddy(J)*ozplin(J2,L,nc,n1)) & - + tx2*(TEM*ozplin(J1,L,nc,n2)+ddy(J)*ozplin(J2,L,nc,n2)) - enddo - enddo - enddo - - ! - return - - end subroutine ozphys_2015_timestep_init - -! ########################################################################################### !> The operational GFS currently parameterizes ozone production and !! destruction based on monthly mean coefficients ( !! \c ozprdlos_2015_new_sbuvO3_tclm15_nuchem.f77) provided by Naval @@ -187,11 +24,11 @@ end subroutine ozphys_2015_timestep_init !> - This code assumes that both prsl and po3 are from bottom to top !! as are all other variables. !> - This code is specifically for NRL parameterization and -!! climatological T and O3 are in location 5 and 6 of prdout array -!!\author June 2015 - Shrinivas Moorthi -!!\author May 2023 - Dustin Swales +!! climatological T and O3 are in location 5 and 6 of oz_data array +!!\author June 2015 - Shrinivas Moorthi +!!\modified May 2023 - Dustin Swales ! ########################################################################################### - subroutine ozphys_2015_run ( im, levs, ko3, dt, oz, tin, po3, prsl, prdout, pl_coeff, & + subroutine ozphys_2015_run ( im, levs, ko3, dt, oz, tin, po3, prsl, oz_data, pl_coeff, & delp, ldiag3d, dtend, dtidx, ntoz, index_of_process_prod_loss, & index_of_process_ozmix, index_of_process_temp, index_of_process_overhead_ozone, & con_g, errmsg, errflg) @@ -222,7 +59,7 @@ subroutine ozphys_2015_run ( im, levs, ko3, dt, oz, tin, po3, prsl, prdout, pl_c tin, & ! Temperature of new-state (K) delp ! Difference between mid-layer pressures (Pa) real(kind_phys), intent(in), dimension(:,:,:) :: & - prdout ! Ozone forcing data + oz_data ! Ozone forcing data ! In/Outs real(kind=kind_phys), intent(inout), dimension(:,:,:) :: & @@ -298,7 +135,7 @@ subroutine ozphys_2015_run ( im, levs, ko3, dt, oz, tin, po3, prsl, prdout, pl_c do j=1,pl_coeff do i=1,im if (flg(i)) then - prod(i,j) = wk2(i) * prdout(i,k,j) + wk3(i) * prdout(i,k+1,j) + prod(i,j) = wk2(i) * oz_data(i,k,j) + wk3(i) * oz_data(i,k+1,j) endif enddo enddo @@ -307,10 +144,10 @@ subroutine ozphys_2015_run ( im, levs, ko3, dt, oz, tin, po3, prsl, prdout, pl_c do j=1,pl_coeff do i=1,im if (wk1(i) < po3(ko3)) then - prod(i,j) = prdout(i,ko3,j) + prod(i,j) = oz_data(i,ko3,j) endif if (wk1(i) >= po3(1)) then - prod(i,j) = prdout(i,1,j) + prod(i,j) = oz_data(i,1,j) endif enddo enddo diff --git a/physics/ozphys_2015.meta b/physics/ozphys_2015.meta index eab24baf1..ea82defaa 100644 --- a/physics/ozphys_2015.meta +++ b/physics/ozphys_2015.meta @@ -3,209 +3,6 @@ type = scheme dependencies = machine.F -######################################################################## -[ccpp-arg-table] - name = ozphys_2015_init - type = scheme -[nPts] - standard_name = horizontal_dimension - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in -[latsozp] - standard_name = number_of_latitudes_in_ozone_data - long_name = number of latitude in ozone data - units = count - dimensions = () - type = integer - intent = in -[oz_phys_2015] - standard_name = flag_for_nrl_2015_ozone_scheme - long_name = flag for new (2015) ozone physics - units = flag - dimensions = () - type = logical - intent = in -[oz_lat] - standard_name = ozone_data_latitude - long_name = ozone data latitude - units = deg - dimensions = (number_of_latitudes_in_ozone_data) - type = real - kind = kind_phys - intent = in -[dlat] - standard_name = latitude_in_degree - long_name = latitude in degree north - units = degree_north - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in -[jindx1] - standard_name = lower_latitude_index_of_ozone_forcing_for_interpolation - long_name = interpolation low index for ozone - units = index - dimensions = (horizontal_dimension) - type = integer - intent = out -[jindx2] - standard_name = upper_latitude_index_of_ozone_forcing_for_interpolation - long_name = interpolation high index for ozone - units = index - dimensions = (horizontal_dimension) - type = integer - intent = out -[ddy] - standard_name = latitude_interpolation_weight_for_ozone_forcing - long_name = interpolation high index for ozone - units = none - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = out -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - -######################################################################## -[ccpp-arg-table] - name = ozphys_2015_timestep_init - type = scheme -[nPts] - standard_name = horizontal_dimension - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in -[idate] - standard_name = date_and_time_at_model_initialization_in_united_states_order - long_name = initial date with different size and ordering - units = none - dimensions = (4) - type = integer - intent = in -[fhour] - standard_name = forecast_time - long_name = current forecast time - units = h - dimensions = () - type = real - kind = kind_phys - intent = in -[jindx1] - standard_name = lower_latitude_index_of_ozone_forcing_for_interpolation - long_name = interpolation low index for ozone - units = index - dimensions = (horizontal_dimension) - type = integer - intent = in -[jindx2] - standard_name = upper_latitude_index_of_ozone_forcing_for_interpolation - long_name = interpolation high index for ozone - units = index - dimensions = (horizontal_dimension) - type = integer - intent = in -[latsozp] - standard_name = number_of_latitudes_in_ozone_data - long_name = number of latitude in ozone data - units = count - dimensions = () - type = integer - intent = in -[levozp] - standard_name = number_of_levels_in_ozone_data - long_name = number of levels in ozone data - units = count - dimensions = () - type = integer - intent = in -[oz_coeff] - standard_name = number_of_coefficients_in_ozone_data - long_name = number of coefficients in ozone data - units = count - dimensions = () - type = integer - intent = in -[timeoz] - standard_name = number_of_times_in_ozone_data - long_name = number of times in ozone data - units = count - dimensions = () - type = integer - intent = in -[ozplin] - standard_name = ozone_data - long_name = ozone data - units = 1 - dimensions = (number_of_latitudes_in_ozone_data,number_of_levels_in_ozone_data,number_of_coefficients_in_ozone_data,number_of_times_in_ozone_data) - type = real - kind = kind_phys - intent = in -[oz_time] - standard_name = ozone_data_time - long_name = ozone data time - units = none - dimensions = (13) - type = real - kind = kind_phys - intent = in -[oz_lat] - standard_name = ozone_data_latitude - long_name = ozone data latitude - units = deg - dimensions = (number_of_latitudes_in_ozone_data) - type = real - kind = kind_phys - intent = in -[ddy] - standard_name = latitude_interpolation_weight_for_ozone_forcing - long_name = interpolation high index for ozone - units = none - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in -[ozplout] - standard_name = ozone_forcing - long_name = ozone forcing data - units = mixed - dimensions = (horizontal_dimension,number_of_levels_in_ozone_data,number_of_coefficients_in_ozone_data) - type = real - kind = kind_phys - intent = out -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - ######################################################################## [ccpp-arg-table] name = ozphys_2015_run @@ -271,7 +68,7 @@ type = real kind = kind_phys intent = in -[prdout] +[oz_data] standard_name = ozone_forcing long_name = ozone forcing data units = mixed diff --git a/physics/ozphys_time_vary.F90 b/physics/ozphys_time_vary.F90 new file mode 100644 index 000000000..5b36f88b9 --- /dev/null +++ b/physics/ozphys_time_vary.F90 @@ -0,0 +1,177 @@ +! ########################################################################################### +!> \file ozphys_time_vary.F90 +!! +! ########################################################################################### +module ozphys_time_vary + use machine, only : kind_phys, kind_dbl_prec, kind_sngl_prec + implicit none + public ozphys_time_vary_init, ozphys_time_vary_timestep_init +contains + +! ########################################################################################### +!>\defgroup GFS Ozone Photochemistry (2015) Module +!! This module contains the CCPP-compliant Ozone 2015 photochemistry scheme. +!> @{ +!> \section arg_table_ozphys_time_vary_init Argument Table +!! \htmlinclude ozphys_time_vary_init.html +!! +! ########################################################################################### + subroutine ozphys_time_vary_init(oz_phys, nPts, latsozp, oz_lat, dlat, jindx1, jindx2, & + ddy, errmsg, errflg) + ! Inputs + logical, intent(in) :: & + oz_phys ! Control flag for NRL ozone scheme + integer, intent(in) :: & + nPts, & ! Horizontal dimension + latsozp ! Number of latitudes in ozone data + real(kind_phys), intent(in), dimension(:) :: & + oz_lat, & ! Latitudes of ozone data + dlat ! Latitudes of grid + ! Outputs + integer, intent(inout), dimension(:) :: & + jindx1, & ! Interpolation index (low) for ozone data + jindx2 ! Interpolation index (high) for ozone data + real(kind_phys), intent(inout), dimension(:) :: & + ddy ! Interpolation high index for ozone data + character(len=*), intent(out) :: & + errmsg ! CCPP error message + integer, intent(out) :: & + errflg ! CCPP error flag + + ! Local + integer i,j + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! Sanity check + if (.not.oz_phys) then + write (errmsg,'(*(a))') 'Logic error: oz_phys == .false.' + errflg = 1 + return + endif + + ! Set indices + do j=1,nPts + jindx2(j) = latsozp + 1 + do i=1,latsozp + if (dlat(j) < oz_lat(i)) then + jindx2(j) = i + exit + endif + enddo + jindx1(j) = max(jindx2(j)-1,1) + jindx2(j) = min(jindx2(j),latsozp) + if (jindx2(j) .ne. jindx1(j)) then + ddy(j) = (dlat(j) - oz_lat(jindx1(j))) / (oz_lat(jindx2(j)) - oz_lat(jindx1(j))) + else + ddy(j) = 1.0 + endif + enddo + + end subroutine ozphys_time_vary_init + +! ########################################################################################### +!> \section arg_table_ozphys_time_vary_timestep_init Argument Table +!! \htmlinclude ozphys_time_vary_timestep_init.html +!! +! ########################################################################################### + subroutine ozphys_time_vary_timestep_init(nPts, idate, fhour, jindx1, jindx2, latsozp, & + levozp, oz_coeff, timeoz, ozplin, oz_time, oz_lat, ddy, oz_data, errmsg, errflg) + ! Inputs + integer, intent(in) :: & + nPts, & ! Horizontal dimension + latsozp, & ! Number of latitudes in ozone data + levozp, & ! Number of vertical layers in ozone data + oz_coeff, & ! Number of coefficients in ozone data + timeoz ! Number of times in ozone data + integer, intent(in),dimension(:) :: & + idate, & ! Initial date with different size and ordering + jindx1, & ! Interpolation index (low) for ozone + jindx2 ! Interpolation index (high) for ozone + real(kind_phys), intent(in) :: & + fhour ! Forecast hour + real(kind_phys), intent(in), dimension(:) :: & + ddy, & ! Interpolation high index for ozone data + oz_lat, & ! Latitudes for ozone data + oz_time ! Time for ozone data + real(kind_phys), intent(in), dimension(:,:,:,:) :: & + ozplin ! Ozone data + + ! Outputs + real(kind_phys), intent(inout), dimension(:,:,:) :: & + oz_data ! Ozone forcing data + character(len=*), intent(out) :: & + errmsg ! CCPP error message + integer, intent(out) :: & + errflg ! CCPP error flag + + ! Local + integer :: idat(8),jdat(8),iday,j,j1,j2,l,nc,n1,n2,jdow,jdoy,& + jday,w3kindreal,w3kindint + real(kind_phys) :: tem, tx1, tx2, rjday + real(8) :: rinc(5) + real(4) :: rinc4(5) + !real(kind_dbl_prec) :: rinc(5) + !real(kind_sngl_prec) :: rinc4(5) + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! + idat=0 + idat(1)=idate(4) + idat(2)=idate(2) + idat(3)=idate(3) + idat(5)=idate(1) + rinc=0. + rinc(2)=fhour + call w3kind(w3kindreal,w3kindint) + if(w3kindreal==4) then + rinc4=rinc + CALL w3movdat(rinc4,idat,jdat) + else + CALL w3movdat(rinc,idat,jdat) + endif + ! + jdow = 0 + jdoy = 0 + jday = 0 + call w3doxdat(jdat,jdow,jdoy,jday) + rjday = jdoy + jdat(5) / 24. + IF (RJDAY < oz_time(1)) RJDAY = RJDAY + 365. + ! + n2 = timeoz + 1 + do j=2,timeoz + if (rjday < oz_time(j)) then + n2 = j + exit + endif + enddo + n1 = n2 - 1 + + tx1 = (oz_time(n2) - rjday) / (oz_time(n2) - oz_time(n1)) + tx2 = 1.0 - tx1 + + if (n2 > timeoz) n2 = n2 - timeoz + ! + do nc=1,oz_coeff + do L=1,levozp + do J=1,npts + J1 = jindx1(J) + J2 = jindx2(J) + TEM = 1.0 - ddy(J) + oz_data(j,L,nc) = tx1*(TEM*ozplin(J1,L,nc,n1)+ddy(J)*ozplin(J2,L,nc,n1)) & + + tx2*(TEM*ozplin(J1,L,nc,n2)+ddy(J)*ozplin(J2,L,nc,n2)) + enddo + enddo + enddo + + ! + return + + end subroutine ozphys_time_vary_timestep_init +!> @} +end module ozphys_time_vary diff --git a/physics/ozphys_time_vary.meta b/physics/ozphys_time_vary.meta new file mode 100644 index 000000000..93aa4a3b0 --- /dev/null +++ b/physics/ozphys_time_vary.meta @@ -0,0 +1,207 @@ +[ccpp-table-properties] + name = ozphys_time_vary + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = ozphys_time_vary_init + type = scheme +[nPts] + standard_name = horizontal_dimension + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in +[latsozp] + standard_name = number_of_latitudes_in_ozone_data + long_name = number of latitude in ozone data + units = count + dimensions = () + type = integer + intent = in +[oz_phys] + standard_name = flag_for_nrl_2015_ozone_scheme + long_name = flag for new (2015) ozone physics + units = flag + dimensions = () + type = logical + intent = in +[oz_lat] + standard_name = ozone_data_latitude + long_name = ozone data latitude + units = deg + dimensions = (number_of_latitudes_in_ozone_data) + type = real + kind = kind_phys + intent = in +[dlat] + standard_name = latitude_in_degree + long_name = latitude in degree north + units = degree_north + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in +[jindx1] + standard_name = lower_latitude_index_of_ozone_forcing_for_interpolation + long_name = interpolation low index for ozone + units = index + dimensions = (horizontal_dimension) + type = integer + intent = inout +[jindx2] + standard_name = upper_latitude_index_of_ozone_forcing_for_interpolation + long_name = interpolation high index for ozone + units = index + dimensions = (horizontal_dimension) + type = integer + intent = inout +[ddy] + standard_name = latitude_interpolation_weight_for_ozone_forcing + long_name = interpolation high index for ozone + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out + +######################################################################## +[ccpp-arg-table] + name = ozphys_time_vary_timestep_init + type = scheme +[nPts] + standard_name = horizontal_dimension + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in +[idate] + standard_name = date_and_time_at_model_initialization_in_united_states_order + long_name = initial date with different size and ordering + units = none + dimensions = (4) + type = integer + intent = in +[fhour] + standard_name = forecast_time + long_name = current forecast time + units = h + dimensions = () + type = real + kind = kind_phys + intent = in +[jindx1] + standard_name = lower_latitude_index_of_ozone_forcing_for_interpolation + long_name = interpolation low index for ozone + units = index + dimensions = (horizontal_dimension) + type = integer + intent = in +[jindx2] + standard_name = upper_latitude_index_of_ozone_forcing_for_interpolation + long_name = interpolation high index for ozone + units = index + dimensions = (horizontal_dimension) + type = integer + intent = in +[latsozp] + standard_name = number_of_latitudes_in_ozone_data + long_name = number of latitude in ozone data + units = count + dimensions = () + type = integer + intent = in +[levozp] + standard_name = number_of_levels_in_ozone_data + long_name = number of levels in ozone data + units = count + dimensions = () + type = integer + intent = in +[oz_coeff] + standard_name = number_of_coefficients_in_ozone_data + long_name = number of coefficients in ozone data + units = count + dimensions = () + type = integer + intent = in +[timeoz] + standard_name = number_of_times_in_ozone_data + long_name = number of times in ozone data + units = count + dimensions = () + type = integer + intent = in +[ozplin] + standard_name = ozone_data + long_name = ozone data + units = 1 + dimensions = (number_of_latitudes_in_ozone_data,number_of_levels_in_ozone_data,number_of_coefficients_in_ozone_data,number_of_times_in_ozone_data) + type = real + kind = kind_phys + intent = in +[oz_time] + standard_name = ozone_data_time + long_name = ozone data time + units = none + dimensions = (13) + type = real + kind = kind_phys + intent = in +[oz_lat] + standard_name = ozone_data_latitude + long_name = ozone data latitude + units = deg + dimensions = (number_of_latitudes_in_ozone_data) + type = real + kind = kind_phys + intent = in +[ddy] + standard_name = latitude_interpolation_weight_for_ozone_forcing + long_name = interpolation high index for ozone + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in +[oz_data] + standard_name = ozone_forcing + long_name = ozone forcing data + units = mixed + dimensions = (horizontal_dimension,number_of_levels_in_ozone_data,number_of_coefficients_in_ozone_data) + type = real + kind = kind_phys + intent = inout +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out From 39dccc8e2ade0918f1823b6d7bdb5abb0d101898 Mon Sep 17 00:00:00 2001 From: "Michael Kavulich, Jr" Date: Tue, 1 Aug 2023 16:06:29 -0600 Subject: [PATCH 313/380] Various formatting fixes, grammar and wording changes --- physics/clm_lake.f90 | 2 +- physics/docs/pdftxt/CLM_LAKE.txt | 16 ++++++++-------- physics/docs/pdftxt/CU_GF_deep.txt | 12 ++++++------ physics/docs/pdftxt/GFS_NOAHMP.txt | 2 +- physics/docs/pdftxt/GFS_SATMEDMFVDIFQ.txt | 4 ++-- physics/docs/pdftxt/RUCLSM.txt | 6 +++--- physics/docs/pdftxt/WoFS_v0_suite.txt | 2 +- 7 files changed, 22 insertions(+), 22 deletions(-) diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90 index 1728d28b5..093fb407c 100644 --- a/physics/clm_lake.f90 +++ b/physics/clm_lake.f90 @@ -2746,7 +2746,7 @@ end subroutine SoilThermProp_Lake ! DESCRIPTION: !> Calculation of the phase change within snow, soil, & lake layers: !!\n (1) Check the conditions for which the phase change may take place, - !! i.e., the layer temperature is great than the freezing point + !! i.e., the layer temperature is greater than the freezing point !! and the ice mass is not equal to zero (i.e. melting), !! or the layer temperature is less than the freezing point !! and the liquid water mass is greater than the allowable supercooled diff --git a/physics/docs/pdftxt/CLM_LAKE.txt b/physics/docs/pdftxt/CLM_LAKE.txt index d78244cb2..e22b096ec 100644 --- a/physics/docs/pdftxt/CLM_LAKE.txt +++ b/physics/docs/pdftxt/CLM_LAKE.txt @@ -3,14 +3,14 @@ \section des_clmlake Description The Community Land Model (CLM) lake model is a multi-level one-dimensional lake model that has been implemented within the operational 3-km HRRR and -13-km RAP for small lakes (Benjamin et al. (2022) \cite gmd-15-6659-2022). It is the Community Land Model, version 4.5. +13-km RAP for small lakes (Benjamin et al. (2022) \cite gmd-15-6659-2022). This implementation is from the Community Land Model version 4.5 (Oleson et al. (2013) \cite Oleson2013). Subin et al. (2012) \cite Subin_2012 describe the 1-d CLM lake model as applied within the Community Earth System Model (CESM) as a component of the overall CESM CLM (Lawrence et al. (2019) \cite Lawrence_2019). Gu et al. (2015) \cite Gu2015 describe the introduction of the CLM lake model into the WRF model and inital experiments using its 1-d solution for both lakes Superior (average depth of 147 m) and Erie (average depth of 19 m). The atmospheric inputs into the model are temperature, water vapor, horizontal wind components from the lowest atmospheric level -and short-wave and longwave radiative fluxes. The CLM lake model then provides latent heat and sensible heat fluxes back to the +and shortwave and longwave radiative fluxes. The CLM lake model then provides latent heat and sensible heat fluxes back to the atmosphere. It also computes 2-m temperature/moisture, skin temperature, lake temperature, ice fraction, ice thickness, snow water equivalent and snow depth. The CLM lake model divides the vertical lake profile into 10 layers driven by wind-driven eddies. The thickness of the top layer is fixed to 10-cm and the rest of the lake depth is divided evenly into the other 9 layers. Energy @@ -23,22 +23,22 @@ Testing of the CLM lake model within RAP/HRRR applications showed computational 0.1% in run time. The lake/snow variables have to be continuously transfered within the CLM lake model from one forecast to another, constrained by the atmospheric data assimilation. The lake-cycling initialization in RAP/HRRR has been effective overall, owing to accurate houly estimates of near-surface temperature, moisture and winds, and shortwave and longwave estimates provided to the 1-d CLM -lake model every time step (Benjamin et al. (2022) \cite gmd-15-6659-2022). Cycling technique showed improvements over initializing -lake temperatures from the SST analysis, problematic for small water bodies. The improvements are particularly eminent during transition -periods between cold and warm seasons, and in the regions with anomalies in weather conditions. The CLM lake model has the potential +lake model every time step (Benjamin et al. (2022) \cite gmd-15-6659-2022). Cycling techniques showed improvements over initializing +lake temperatures from the SST analysis, which is problematic for small water bodies. The improvements are particularly eminent during transition +periods between cold and warm seasons, and in the regions with anomalous weather conditions. The CLM lake model has the potential to improve surface prediction in the vicinity of small lakes. The CLM lake model requires bathymetry for the lake points in the model domain. Grid points are assigned as lake points when the fraction of lake coverage in the grid cell exceeds 50% and when this point is disconnected from oceans. The lake water mask is -therefore binary, set to either 1 or 0. This binary approach for models with higher horizontal resolution, for example, 3-km resolution in -in the UFS SRW App, is capable of capturing the effect of lakes on regional heat and moisture fluxes. +therefore binary, set to either 1 or 0. This binary approach for models with higher horizontal resolution --- for example, 3-km resolution in +in the UFS SRW App --- is capable of capturing the effect of lakes on regional heat and moisture fluxes. Lake depths for the RRFS lake configuration (Fig.1) are assigned from a global dataset provided by Kourzeneva et al.(2012) \cite Kourzeneva_2012, this dataset is referred to as GLOBv3 bathymetry in the UFS_UTL. @image html https://user-images.githubusercontent.com/12705538/250180794-76af93a2-a7ba-4e9a-9478-5657198862b8.png "Figure 1: Lake depths for lakes in the 3-km RRFS domain." width=600 -To cold-start the CLM lake model in the UFS SRW App: +To cold-start the CLM lake model in the UFS weather model: - Use the CLM option in the input.nml \n - lkm = 1 \n - iopt_lake = 2 diff --git a/physics/docs/pdftxt/CU_GF_deep.txt b/physics/docs/pdftxt/CU_GF_deep.txt index 3b01a05a4..4b504863d 100644 --- a/physics/docs/pdftxt/CU_GF_deep.txt +++ b/physics/docs/pdftxt/CU_GF_deep.txt @@ -17,23 +17,23 @@ a spectrum of plumes within the grid box. Forcing is different for each characte from the PDFs. Aerosol dependence (considered experimental and not supported in this release) is implemented through dependence of rain generation and evaporation formulations depending on the cloud concentration nuclei at cloud base (Berry 1968 \cite berry_1968, Jiang et al.(2010) \cite Jiang_2010, and Lee and Feingold (2010) \cite lee_and_feingold_2010 ). Wet scavenging is considered to add a memory impact. GF is able to transport tracers. -Recently, GPU capabilities and cap suppressing (\p do_cap_suppress) based on radar data assimilation have been added,and they are used only for the RAP suite. +Recently, GPU capabilities and cap suppressing (\p do_cap_suppress) based on radar data assimilation have been added, and they are used only for the RAP suite. -The impacts of GF scheme in operational RAP/HRRR include:(a)uses mass-flux schemes, which are more physically realistic than (sounding) adjustment schemes; +The impacts of GF scheme in operational RAP/HRRR include: (a)uses mass-flux schemes, which are more physically realistic than (sounding) adjustment schemes; (b)takes parameterization uncertainty into account by allowing parameters from multiple convective schemes which can be perturbed -internally or with temporal and spatial correlation patterns; (c)for higher resolutions (less than 10 km), in addition to scale awareness as in Arakawa et al. (2011) \cite Arakawa_2011 GF can transition as grid spacing decreases into a shallow convection scheme; (d)Coupled to the grid scale precipitation and radiation schemes through passing of diagnosed cloud liquid and ice from simulated precipitating convective cloud and shallow convective clouds. +internally or with temporal and spatial correlation patterns; (c)for higher resolutions (less than 10 km), in addition to scale awareness as in Arakawa et al. (2011) \cite Arakawa_2011 GF can transition as grid spacing decreases into a shallow convection scheme; (d)Coupled to the grid-scale precipitation and radiation schemes through passing of diagnosed cloud liquid and ice from simulated precipitating convective cloud and shallow convective clouds. \section version_cugf_enh CCPP Physics Updates \version UFS-SRW v3.0.0 -\b The \b Implementation \b of \b GF \b in \b RRFS +The Implementation of GF in RRFS prototypes - Updates for aerosol-awareness (experimental) - Scale-awareness is turned off when explicit microphysics is not active anywhere in the column -- GF completely is turned off at grid points when MYNN produces shallow convection at that point +- GF is completely turned off at grid points when MYNN produces shallow convection at that point - Radar reflectivity considers mass flux PDF as well as whether scale-awareness is turned on at the grid point in equation. -\b The \b implementation \b of \b GF \b in \b HAFS \b is \b undergoing. +The implementation of GF in HAFS is ongoing. \section intra_rough_gf Intraphysics Communication The GF scheme passes cloud hydrometeors to the grid-scale microphysics scheme (\ref THOMPSON ) through detrainment from each diff --git a/physics/docs/pdftxt/GFS_NOAHMP.txt b/physics/docs/pdftxt/GFS_NOAHMP.txt index 386ae816c..e48b7cafc 100644 --- a/physics/docs/pdftxt/GFS_NOAHMP.txt +++ b/physics/docs/pdftxt/GFS_NOAHMP.txt @@ -10,7 +10,7 @@ This implementation of the NoahMP Land Surface Model (LSM) is adapted from the v \section noahmp_update CCPP Physics Updates \version UFS-SRW v3.0.0 -- As part of a larger-scale effort to unify how microphysics outputs (in particular snow) are used in the land models and outputs, an addition option for using the unified frozen precipitation fraction in NoahMP was added +- As part of a larger-scale effort to unify how microphysics outputs (in particular snow) are used in the land models and outputs, an additional option for using the unified frozen precipitation fraction in NoahMP was added - Diagnostic 2-meter temperature and humidity are based on vegetation and bare-ground tiles - Bug fixes for GFS-based thermal roughness length scheme diff --git a/physics/docs/pdftxt/GFS_SATMEDMFVDIFQ.txt b/physics/docs/pdftxt/GFS_SATMEDMFVDIFQ.txt index 3ae1a0234..d5bc9489c 100644 --- a/physics/docs/pdftxt/GFS_SATMEDMFVDIFQ.txt +++ b/physics/docs/pdftxt/GFS_SATMEDMFVDIFQ.txt @@ -31,8 +31,8 @@ reduces the mixing length in a strong shear environment such as a hurricane. background diffusivity in the inversion layers is reduced as a function of surface roughness and green vegetation fraction. - To reduce the PBL overgrowth, the PBL updraft overshoot is not only limited by -bulk Richardson number-based-PBL depth, but the virtual potential temperature at -top of the surface layer rather than that at the model first layer is also used as +bulk Richardson number-based PBL depth, but the virtual potential temperature at +the top of the surface layer rather than that at the model first layer is also used as the near-surface virtual potential temperature in the bulk-Richardson number computation. This helps to largely suppress the unrealistic widespread popcorn-like precipitation. - Updraft entrainment rates for moisture, hydrometeors, and tracers are increased by about 30%. diff --git a/physics/docs/pdftxt/RUCLSM.txt b/physics/docs/pdftxt/RUCLSM.txt index a836e7b93..e8212df21 100644 --- a/physics/docs/pdftxt/RUCLSM.txt +++ b/physics/docs/pdftxt/RUCLSM.txt @@ -17,7 +17,7 @@ The parameterizations in the RUC LSM describe complicated atmosphere–land surf excessive sensitivity to multiple uncertain surface parameters. Nevertheless, the RUC LSM, when coupled with the hourly-assimilating atmospheric model, demonstrated over years of ongoing cycling (Benjamin et al. 2004a,b \cite Benjamin_2004a \cite Benjamin_2004b ; Berbery et al. 1999 \cite Berbery_1999) that it can produce a realistic evolution of hydrologic and time-varying soil fields (i.e., soil moisture and temperature) that cannot be directly -observed over large areas, as well as the evolution of snow cover on the ground surface. This result is possible only if the soil–vegetation–snow +observed over large areas, as well as the evolution of snow cover on the ground surface. This result is possible only if the soil–vegetation–snow component of the coupled model, constrained only by atmospheric boundary conditions and the specification of surface characteristics, has sufficient skill to avoid long-term drift. @@ -28,7 +28,7 @@ included in phase 2(d) of the Project for the Intercomparison of Land Surface Pr Luo et al. 2003 \cite Luo_2003 ). The RUC LSM was also tested during the Snow Models Intercomparison Project (SnowMIP, SnowMIP2, ESM-SnowMIP), with emphasis on snow parameterizations for both grassland and forest locations in different parts of the world (Etchevers et al. 2002, 2004 \cite Etchevers_2002 \cite Etchevers_2004; Essery et al. 2009 \cite Essery_2009 ; Rutter et al. 2009 \cite Rutter_2009 , -Krinner et al. 2018 \cite Krinner_2018 ). The analysis of RUC LSM performance over 10 reference sites in ESM-SnowMIP rated it on the 4th place +Krinner et al. 2018 \cite Krinner_2018 ). The analysis of RUC LSM performance over 10 reference sites in ESM-SnowMIP rated it 4th place among the 26 participating models. The results were published in Menard et al.(2021) \cite Menard_2021 and Essery et al. (2020) \cite essery_et_al_2020. RUC LSM received high rankings in ESM-SnowMIP experiement in terms of multi-year snow cover and surface temperature simulations for several sites located in different parts of the world (Fig.2, Menard et al.2021 \cite Menard_2021). @@ -61,7 +61,7 @@ specifying surface parameters for the dominant soil and land-use category in the grid box, RUC LSM has an option to take into account the sub-grid scale heterogeneity in the computation of such parameters as roughness length, emissivity, soil porosity, soil heat capacity and others. The difference in roughness between the mosaic and dominant category presented on Figure 3, is positive from contribution of the forests, which helped to -reduce high biases of surface wind speeds in these regions. In the cropland regions, roughness lenghth has also a seasonal variability depending on the growing phase of the plants. This again helped to improve the wind forecasts during the warm season. +reduce high biases of surface wind speeds in these regions. In cropland regions, roughness length also has a seasonal variability depending on the growing phase of the plants. This again helped to improve the wind forecasts during the warm season. Turning on sub-grid-scale heterogeneity option requries: \p mosaic_lu = 1 and \p mosaic_soil = 1 in the namelist, and fractions of soil and vegetation types in a grid cell. \image html ruc_lsm_heterogeneity.png "Figure 3: sub-grid scale heterogeneity of surface parameters in RUC LSM (Courtesy of T.G. Smirnova)" width=900 diff --git a/physics/docs/pdftxt/WoFS_v0_suite.txt b/physics/docs/pdftxt/WoFS_v0_suite.txt index 4561109fa..385ad7b7d 100644 --- a/physics/docs/pdftxt/WoFS_v0_suite.txt +++ b/physics/docs/pdftxt/WoFS_v0_suite.txt @@ -5,7 +5,7 @@ The WoFS_v0 suite is targeted for use in the upcoming operational implementation of the NOAA's Warn-on-Forecast System (WoFS) and for the RRFS ensemble. -This suite is most applicable for runs at 3-km resolution since it does +This suite is most applicable for runs at 3-km resolution and higher since it does not parameterize deep convection. The WoFS suite uses the parameterizations in the following order: From 6b12f193deb43fc42915b85a731564f716fcf03b Mon Sep 17 00:00:00 2001 From: "Michael Kavulich, Jr" Date: Tue, 1 Aug 2023 16:16:15 -0600 Subject: [PATCH 314/380] Less ambiguous wording regarding resolution --- physics/docs/pdftxt/WoFS_v0_suite.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/docs/pdftxt/WoFS_v0_suite.txt b/physics/docs/pdftxt/WoFS_v0_suite.txt index 385ad7b7d..788c98323 100644 --- a/physics/docs/pdftxt/WoFS_v0_suite.txt +++ b/physics/docs/pdftxt/WoFS_v0_suite.txt @@ -5,7 +5,7 @@ The WoFS_v0 suite is targeted for use in the upcoming operational implementation of the NOAA's Warn-on-Forecast System (WoFS) and for the RRFS ensemble. -This suite is most applicable for runs at 3-km resolution and higher since it does +This suite is most applicable for runs at <=3-km resolution and higher since it does not parameterize deep convection. The WoFS suite uses the parameterizations in the following order: From 6884732dc149a496e53354079f2d931fb7b265f1 Mon Sep 17 00:00:00 2001 From: "Michael Kavulich, Jr" Date: Tue, 1 Aug 2023 16:18:41 -0600 Subject: [PATCH 315/380] *actually* fix ambiguous wording --- physics/docs/pdftxt/WoFS_v0_suite.txt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/docs/pdftxt/WoFS_v0_suite.txt b/physics/docs/pdftxt/WoFS_v0_suite.txt index 788c98323..bf868a461 100644 --- a/physics/docs/pdftxt/WoFS_v0_suite.txt +++ b/physics/docs/pdftxt/WoFS_v0_suite.txt @@ -4,8 +4,8 @@ \section wofs_v0_suite_overview Overview The WoFS_v0 suite is targeted for use in the upcoming operational implementation -of the NOAA's Warn-on-Forecast System (WoFS) and for the RRFS ensemble. -This suite is most applicable for runs at <=3-km resolution and higher since it does +of the NOAA's Warn-on-Forecast System (WoFS) and for the RRFS ensemble. +This suite is most applicable for runs at <= 3-km resolution since it does not parameterize deep convection. The WoFS suite uses the parameterizations in the following order: From 0bfac2ac51d8c460b84cc49fd5240407bcaea6ba Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Wed, 2 Aug 2023 17:03:36 +0000 Subject: [PATCH 316/380] Some cleanup. Now working --- physics/GFS_rrtmg_pre.F90 | 2 +- physics/ozphys_2015.F90 | 52 +++++++++++++++++++++++++++++++---- physics/ozphys_2015.meta | 34 +++++++++++++++++++++++ physics/ozphys_time_vary.F90 | 22 ++++----------- physics/ozphys_time_vary.meta | 7 ----- 5 files changed, 87 insertions(+), 30 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 4a2c3b290..f2183919f 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -44,7 +44,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& gasvmr_o2, gasvmr_co, gasvmr_cfc11, gasvmr_cfc12, gasvmr_cfc22, & gasvmr_ccl4, gasvmr_cfc113, aerodp,ext550, clouds6, clouds7, clouds8, & clouds9, cldsa, cldfra, cldfra2d, lwp_ex,iwp_ex, lwp_fc,iwp_fc, & - faersw1, faersw2, faersw3, faerlw1, faerlw2, faerlw3, alpha, rrfs_sd & + faersw1, faersw2, faersw3, faerlw1, faerlw2, faerlw3, alpha, rrfs_sd, & aero_dir_fdb, fdb_coef, spp_wts_rad, spp_rad, ico2, latsozc, levozc, & blatc, dphiozc, errmsg, errflg) diff --git a/physics/ozphys_2015.F90 b/physics/ozphys_2015.F90 index 82ade0cbd..110ba02e2 100644 --- a/physics/ozphys_2015.F90 +++ b/physics/ozphys_2015.F90 @@ -5,7 +5,7 @@ module ozphys_2015 use machine, only : kind_phys, kind_dbl_prec, kind_sngl_prec implicit none - public ozphys_2015_run + public ozphys_2015_init, ozphys_2015_run contains ! ########################################################################################### @@ -17,8 +17,6 @@ module ozphys_2015 !! \c ozprdlos_2015_new_sbuvO3_tclm15_nuchem.f77) provided by Naval !! Research Laboratory through CHEM2D chemistry model !! (McCormack et al. (2006) \cite mccormack_et_al_2006). -!! \section arg_table_ozphys_2015_run Argument Table -!! \htmlinclude ozphys_2015_run.html !! !> \section genal_ozphys_2015 GFS ozphys_2015_run General Algorithm !> - This code assumes that both prsl and po3 are from bottom to top @@ -28,13 +26,50 @@ module ozphys_2015 !!\author June 2015 - Shrinivas Moorthi !!\modified May 2023 - Dustin Swales ! ########################################################################################### - subroutine ozphys_2015_run ( im, levs, ko3, dt, oz, tin, po3, prsl, oz_data, pl_coeff, & - delp, ldiag3d, dtend, dtidx, ntoz, index_of_process_prod_loss, & + +! ########################################################################################### +! SUBROUTINE ozphys_2015_init +! ########################################################################################### +!! \section arg_table_ozphys_2015_init Argument Table +!! \htmlinclude ozphys_2015_init.html +!! + subroutine ozphys_2015_init(oz_phys, errmsg, errflg) + ! Inputs + logical, intent(in) :: & + oz_phys + ! Outputs + character(len=*), intent(out) :: & + errmsg + integer, intent(out) :: & + errflg + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! Sanity check + if (.not.oz_phys) then + write (errmsg,'(*(a))') 'Logic error: oz_phys_2015 == .false.' + errflg = 1 + return + endif + + end subroutine ozphys_2015_init + +! ########################################################################################### +! SUBROUTINE ozphys_2015_run +! ########################################################################################### +!! \section arg_table_ozphys_2015_run Argument Table +!! \htmlinclude ozphys_2015_run.html +!! + subroutine ozphys_2015_run (oz_phys, im, levs, ko3, dt, oz, tin, po3, prsl, oz_data, & + pl_coeff, delp, ldiag3d, dtend, dtidx, ntoz, index_of_process_prod_loss, & index_of_process_ozmix, index_of_process_temp, index_of_process_overhead_ozone, & con_g, errmsg, errflg) ! Inputs logical, intent(in) :: & + oz_phys, & ! ldiag3d ! Flag to output GFS diagnostic tendencies real(kind_phys),intent(in) :: & con_g ! Physical constant: Gravitational acceleration (ms-2) @@ -88,6 +123,13 @@ subroutine ozphys_2015_run ( im, levs, ko3, dt, oz, tin, po3, prsl, oz_data, pl_ errmsg = '' errflg = 0 + ! Sanity checkt + if (.not.oz_phys) then + write (errmsg,'(*(a))') 'Logic error: oz_phys_2015 == .false.' + errflg = 1 + return + endif + ! Are UFS diagnostic tendencies requested? If so, set up bookeeping indices... if(ldiag3d) then idtend(1) = dtidx(100+ntoz,index_of_process_prod_loss) ! was ozp1 diff --git a/physics/ozphys_2015.meta b/physics/ozphys_2015.meta index ea82defaa..4b19f2c04 100644 --- a/physics/ozphys_2015.meta +++ b/physics/ozphys_2015.meta @@ -3,10 +3,44 @@ type = scheme dependencies = machine.F +######################################################################## +[ccpp-arg-table] + name = ozphys_2015_init + type = scheme +[oz_phys] + standard_name = flag_for_nrl_2015_ozone_scheme + long_name = flag for new (2015) ozone physics + units = flag + dimensions = () + type = logical + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out + ######################################################################## [ccpp-arg-table] name = ozphys_2015_run type = scheme +[oz_phys] + standard_name = flag_for_nrl_2015_ozone_scheme + long_name = flag for new (2015) ozone physics + units = flag + dimensions = () + type = logical + intent = in [im] standard_name = horizontal_loop_extent long_name = horizontal loop extent diff --git a/physics/ozphys_time_vary.F90 b/physics/ozphys_time_vary.F90 index 5b36f88b9..a0a778c36 100644 --- a/physics/ozphys_time_vary.F90 +++ b/physics/ozphys_time_vary.F90 @@ -9,18 +9,16 @@ module ozphys_time_vary contains ! ########################################################################################### -!>\defgroup GFS Ozone Photochemistry (2015) Module -!! This module contains the CCPP-compliant Ozone 2015 photochemistry scheme. +!>\defgroup GFS Ozone Data Module +!! This module updates the ozone data used by physics. !> @{ !> \section arg_table_ozphys_time_vary_init Argument Table !! \htmlinclude ozphys_time_vary_init.html !! ! ########################################################################################### - subroutine ozphys_time_vary_init(oz_phys, nPts, latsozp, oz_lat, dlat, jindx1, jindx2, & + subroutine ozphys_time_vary_init(nPts, latsozp, oz_lat, dlat, jindx1, jindx2, & ddy, errmsg, errflg) ! Inputs - logical, intent(in) :: & - oz_phys ! Control flag for NRL ozone scheme integer, intent(in) :: & nPts, & ! Horizontal dimension latsozp ! Number of latitudes in ozone data @@ -44,13 +42,6 @@ subroutine ozphys_time_vary_init(oz_phys, nPts, latsozp, oz_lat, dlat, jindx1, j ! Initialize CCPP error handling variables errmsg = '' errflg = 0 - - ! Sanity check - if (.not.oz_phys) then - write (errmsg,'(*(a))') 'Logic error: oz_phys == .false.' - errflg = 1 - return - endif ! Set indices do j=1,nPts @@ -111,10 +102,8 @@ subroutine ozphys_time_vary_timestep_init(nPts, idate, fhour, jindx1, jindx2, la integer :: idat(8),jdat(8),iday,j,j1,j2,l,nc,n1,n2,jdow,jdoy,& jday,w3kindreal,w3kindint real(kind_phys) :: tem, tx1, tx2, rjday - real(8) :: rinc(5) - real(4) :: rinc4(5) - !real(kind_dbl_prec) :: rinc(5) - !real(kind_sngl_prec) :: rinc4(5) + real(kind_dbl_prec) :: rinc(5) + real(kind_sngl_prec) :: rinc4(5) ! Initialize CCPP error handling variables errmsg = '' @@ -169,7 +158,6 @@ subroutine ozphys_time_vary_timestep_init(nPts, idate, fhour, jindx1, jindx2, la enddo enddo - ! return end subroutine ozphys_time_vary_timestep_init diff --git a/physics/ozphys_time_vary.meta b/physics/ozphys_time_vary.meta index 93aa4a3b0..75b8b8e4f 100644 --- a/physics/ozphys_time_vary.meta +++ b/physics/ozphys_time_vary.meta @@ -21,13 +21,6 @@ dimensions = () type = integer intent = in -[oz_phys] - standard_name = flag_for_nrl_2015_ozone_scheme - long_name = flag for new (2015) ozone physics - units = flag - dimensions = () - type = logical - intent = in [oz_lat] standard_name = ozone_data_latitude long_name = ozone data latitude From 724c20ff7d71ed26899642a810e84b294482cc7f Mon Sep 17 00:00:00 2001 From: "Michael Kavulich, Jr" Date: Thu, 3 Aug 2023 16:39:29 -0600 Subject: [PATCH 317/380] Weiwei's suggested changes --- physics/docs/pdftxt/CLM_LAKE.txt | 3 ++- physics/docs/pdftxt/CU_GF_deep.txt | 16 ++++------------ 2 files changed, 6 insertions(+), 13 deletions(-) diff --git a/physics/docs/pdftxt/CLM_LAKE.txt b/physics/docs/pdftxt/CLM_LAKE.txt index e22b096ec..f80e55b25 100644 --- a/physics/docs/pdftxt/CLM_LAKE.txt +++ b/physics/docs/pdftxt/CLM_LAKE.txt @@ -38,7 +38,8 @@ this dataset is referred to as GLOBv3 bathymetry in the UFS_UTL. @image html https://user-images.githubusercontent.com/12705538/250180794-76af93a2-a7ba-4e9a-9478-5657198862b8.png "Figure 1: Lake depths for lakes in the 3-km RRFS domain." width=600 -To cold-start the CLM lake model in the UFS weather model: +To cold-start the CLM lake model in regional configurations of the UFS: + - Use the CLM option in the input.nml \n - lkm = 1 \n - iopt_lake = 2 diff --git a/physics/docs/pdftxt/CU_GF_deep.txt b/physics/docs/pdftxt/CU_GF_deep.txt index 4b504863d..412dab5f0 100644 --- a/physics/docs/pdftxt/CU_GF_deep.txt +++ b/physics/docs/pdftxt/CU_GF_deep.txt @@ -6,18 +6,10 @@ The Grell-Freitas (GF) scheme, as described in Grell and Freitas (2014) \cite gr Freitas et al. (2018) \cite freitas_et_al_2018, Freitas et al. (2021) \cite freitas_et_al_2021, and Lin et al. (2022) \cite Lin_2022 follows the mass flux approach published by Grell (1993) \cite grell_1993. Further developments by Grell and \f$D\acute{e}v\acute{e}nyi\f$ (2002) \cite Grell_2002 included implementing -stochastics through allowing parameter perturbations. The GF scheme takes into account aerosol dependence through rain generation (following -Berry (1968) \cite berry_1968 and evaporation formulations (following Jiang et al. (2010) \cite Jiang_2010 ), depending on the -cloud concentration nuclei at cloud base were added. The GF scheme includes mixed phase physics impact, momentum transport, - a diurnal cycle closure (Bechtold et al. (2014) \cite bechtold_et_al_2014 ), and a trimodal spectral size to simulate the interaction -and transition from shallow, congestus and deep convection regimes. The vertical mass flux distribution of shallow, congestus and -deep convection regimes is characterized by Probability Density Functions (PDFs). The three PDFs are meant to represent the average -statistical mass flux characteristic of deep, congestus, and shallow (respectively) plumes in the grid area. Each PDF therefore represents -a spectrum of plumes within the grid box. Forcing is different for each characteristic type. Entrainment and detrainment are derived -from the PDFs. Aerosol dependence (considered experimental and not supported in this release) is implemented through dependence of rain generation and -evaporation formulations depending on the cloud concentration nuclei at cloud base (Berry 1968 \cite berry_1968, -Jiang et al.(2010) \cite Jiang_2010, and Lee and Feingold (2010) \cite lee_and_feingold_2010 ). Wet scavenging is considered to add a memory impact. GF is able to transport tracers. -Recently, GPU capabilities and cap suppressing (\p do_cap_suppress) based on radar data assimilation have been added, and they are used only for the RAP suite. +stochastics through allowing parameter perturbations. +The GF scheme includes mixed phase physics impact, momentum transport, a diurnal cycle closure (Bechtold et al. (2014) \cite bechtold_et_al_2014 ), and a trimodal spectral size to simulate the interaction and transition from shallow, congestus and deep convection regimes. +The vertical mass flux distribution of shallow, congestus and deep convection regimes is characterized by Probability Density Functions (PDFs). The three PDFs are meant to represent the average statistical mass flux characteristic of deep, congestus, and shallow (respectively) plumes in the grid area. Each PDF therefore represents a spectrum of plumes within the grid box. Forcing is different for each characteristic type. Entrainment and detrainment are derived from the PDFs. +The GF scheme takes into account aerosol dependence (considered experimental and not supported in this release), which is implemented through rain generation (following Berry (1968) \cite berry_1968 and evaporation formulations depending on the cloud concentration nuclei at cloud base (Jiang et al. (2010) \cite Jiang_2010, and Lee and Feingold (2010) \cite lee_and_feingold_2010). Wet scavenging is considered to add a memory impact. GF is able to transport tracers. Recently, GPU capabilities and cap suppressing (\p do_cap_suppress) based on radar data assimilation have been added, and they are used only for the RAP suite. The impacts of GF scheme in operational RAP/HRRR include: (a)uses mass-flux schemes, which are more physically realistic than (sounding) adjustment schemes; (b)takes parameterization uncertainty into account by allowing parameters from multiple convective schemes which can be perturbed From bea77c8dd21b60b8af7603e494aed45abcccec40 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Thu, 10 Aug 2023 17:32:59 +0000 Subject: [PATCH 318/380] More reorganization. --- physics/GFS_physics_diagnostics.F90 | 97 +++++++++++++++++++ physics/GFS_physics_diagnostics.meta | 140 +++++++++++++++++++++++++++ physics/ozphys_2015.F90 | 80 ++++++--------- physics/ozphys_2015.meta | 91 +++++++---------- physics/ozphys_time_vary.F90 | 4 +- physics/physcons.F90 | 1 + 6 files changed, 300 insertions(+), 113 deletions(-) create mode 100644 physics/GFS_physics_diagnostics.F90 create mode 100644 physics/GFS_physics_diagnostics.meta diff --git a/physics/GFS_physics_diagnostics.F90 b/physics/GFS_physics_diagnostics.F90 new file mode 100644 index 000000000..0c6197bc2 --- /dev/null +++ b/physics/GFS_physics_diagnostics.F90 @@ -0,0 +1,97 @@ +! ########################################################################################### +!> \file GFS_physics_diagnostics.F90 +!! +! ########################################################################################### +module GFS_physics_diagnostics + use machine, only : kind_phys, kind_dbl_prec, kind_sngl_prec + implicit none + public GFS_physics_diagnostics_init, GFS_physics_diagnostics_run +contains + +! ########################################################################################### +! SUBROUTINE GFS_physics_diagnostics_init +! ########################################################################################### +!! \section arg_table_GFS_physics_diagnostics_init Argument Table +!! \htmlinclude GFS_physics_diagnostics_init.html +!! + subroutine GFS_physics_diagnostics_init(errmsg, errflg) + + ! Outputs + character(len=*), intent(out) :: & + errmsg ! CCPP error message + integer, intent(out) :: & + errflg ! CCPP error flag + + end subroutine GFS_physics_diagnostics_init + +! ########################################################################################### +! SUBROUTINE GFS_physics_diagnostics_run +! ########################################################################################### +!! \section arg_table_GFS_physics_diagnostics_run Argument Table +!! \htmlinclude GFS_physics_diagnostics_run.html +!! + subroutine GFS_physics_diagnostics_run(nCol, nLev, ntoz, dtidx, ip_prod_loss, ip_ozmix, & + ip_temp, ip_overhead_ozone, do3_dt_prd, do3_dt_ozmx, do3_dt_temp, do3_dt_ohoz, dtend,& + errmsg, errflg) + ! Inputs + integer, intent(in) :: & + nCol, & ! Horizontal dimension + nLev, & ! Number of vertical layers + ntoz, & ! Index for ozone mixing ratio + ip_prod_loss, & ! Index for process in diagnostic tendency output + ip_ozmix, & ! Index for process in diagnostic tendency output + ip_temp, & ! Index for process in diagnostic tendency output + ip_overhead_ozone ! Index for process in diagnostic tendency output + integer, intent(in), dimension(:,:) :: & + dtidx ! Bookkeeping indices for GFS diagnostic tendencies + + ! Inputs (optional) + real(kind=kind_phys), intent(in), dimension(:,:), pointer, optional :: & + do3_dt_prd, & ! Physics tendency: production and loss effect + do3_dt_ozmx, & ! Physics tendency: ozone mixing ratio effect + do3_dt_temp, & ! Physics tendency: temperature effect + do3_dt_ohoz ! Physics tendency: overhead ozone effect + + ! Outputs + real(kind=kind_phys), intent(inout), dimension(:,:,:) :: & + dtend ! Diagnostic tendencies for state variables + character(len=*), intent(out) :: & + errmsg ! CCPP error message + integer, intent(out) :: & + errflg ! CCPP error flag + + ! Locals + integer :: idtend + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! ####################################################################################### + ! + ! Ozone physics diagnostics + ! + ! ####################################################################################### + idtend = dtidx(100+ntoz,ip_prod_loss) + if (idtend >= 1 .and. associated(do3_dt_prd)) then + dtend(:,:,idtend) = dtend(:,:,idtend) + do3_dt_prd + endif + ! + idtend = dtidx(100+ntoz,ip_ozmix) + if (idtend >= 1 .and. associated(do3_dt_ozmx)) then + dtend(:,:,idtend) = dtend(:,:,idtend) + do3_dt_ozmx + endif + ! + idtend = dtidx(100+ntoz,ip_temp) + if (idtend >= 1 .and. associated(do3_dt_temp)) then + dtend(:,:,idtend) = dtend(:,:,idtend) + do3_dt_temp + endif + ! + idtend = dtidx(100+ntoz,ip_overhead_ozone) + if (idtend >= 1 .and. associated(do3_dt_ohoz)) then + dtend(:,:,idtend) = dtend(:,:,idtend) + do3_dt_ohoz + endif + + end subroutine GFS_physics_diagnostics_run + +end module GFS_physics_diagnostics diff --git a/physics/GFS_physics_diagnostics.meta b/physics/GFS_physics_diagnostics.meta new file mode 100644 index 000000000..b6036b0c9 --- /dev/null +++ b/physics/GFS_physics_diagnostics.meta @@ -0,0 +1,140 @@ +[ccpp-table-properties] + name = GFS_physics_diagnostics + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = GFS_physics_diagnostics_init + type = scheme +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out + +######################################################################## +[ccpp-arg-table] + name = GFS_physics_diagnostics_run + type = scheme +[nCol] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[nLev] + standard_name = vertical_layer_dimension + long_name = number of vertical layers + units = count + dimensions = () + type = integer + intent = in +[dtend] + standard_name = cumulative_change_of_state_variables + long_name = diagnostic tendencies for state variables + units = mixed + dimensions = (horizontal_loop_extent,vertical_layer_dimension,cumulative_change_of_state_variables_outer_index_max) + type = real + kind = kind_phys + intent = inout +[dtidx] + standard_name = cumulative_change_of_state_variables_outer_index + long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index + units = index + dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes) + type = integer + intent = in +[ntoz] + standard_name = index_of_ozone_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for ozone mixing ratio + units = index + dimensions = () + type = integer + intent = in +[ip_prod_loss] + standard_name = index_of_production_and_loss_process_in_cumulative_change_index + long_name = index of production and loss effect in photochemistry process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[ip_ozmix] + standard_name = index_of_ozone_mixing_ratio_process_in_cumulative_change_index + long_name = index of ozone mixing ratio effect in photochemistry process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[ip_temp] + standard_name = index_of_temperature_process_in_cumulative_change_index + long_name = index of temperature effect in photochemistry process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[ip_overhead_ozone] + standard_name = index_of_overhead_process_in_cumulative_change_index + long_name = index of overhead ozone effect in photochemistry process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[do3_dt_prd] + standard_name = ozone_tendency_due_to_production_and_loss_rate + long_name = ozone tendency due to production and loss rate + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[do3_dt_ozmx] + standard_name = ozone_tendency_due_to_ozone_mixing_ratio + long_name = ozone tendency due to ozone mixing ratio + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[do3_dt_temp] + standard_name = ozone_tendency_due_to_temperature + long_name = ozone tendency due to temperature + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[do3_dt_ohoz] + standard_name = ozone_tendency_due_to_overhead_ozone_column + long_name = ozone tendency due to overhead ozone column + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out \ No newline at end of file diff --git a/physics/ozphys_2015.F90 b/physics/ozphys_2015.F90 index 110ba02e2..9898c71e4 100644 --- a/physics/ozphys_2015.F90 +++ b/physics/ozphys_2015.F90 @@ -63,42 +63,35 @@ end subroutine ozphys_2015_init !! \htmlinclude ozphys_2015_run.html !! subroutine ozphys_2015_run (oz_phys, im, levs, ko3, dt, oz, tin, po3, prsl, oz_data, & - pl_coeff, delp, ldiag3d, dtend, dtidx, ntoz, index_of_process_prod_loss, & - index_of_process_ozmix, index_of_process_temp, index_of_process_overhead_ozone, & - con_g, errmsg, errflg) + pl_coeff, delp, con_1ovg, do3_dt_prd, do3_dt_ozmx, do3_dt_temp, do3_dt_ohoz, errmsg, errflg) ! Inputs logical, intent(in) :: & - oz_phys, & ! - ldiag3d ! Flag to output GFS diagnostic tendencies + oz_phys ! Flag for ozone_physics_2015 scheme. real(kind_phys),intent(in) :: & - con_g ! Physical constant: Gravitational acceleration (ms-2) + con_1ovg ! Physical constant: One divided by gravitational acceleration (m-1 s2) integer, intent(in) :: & - im, & ! Horizontal dimension - levs, & ! Number of vertical layers - ko3, & ! Number of vertical layers in ozone forcing data - pl_coeff, & ! Number of coefficients in ozone forcing data - ntoz, & ! Index for ozone mixing ratio - index_of_process_prod_loss, & ! Index for process in diagnostic tendency output - index_of_process_ozmix, & ! Index for process in diagnostic tendency output - index_of_process_temp, & ! Index for process in diagnostic tendency output - index_of_process_overhead_ozone ! Index for process in diagnostic tendency output - integer, intent(in), dimension(:,:) :: & - dtidx ! Bookkeeping indices for GFS diagnostic tendencies + im, & ! Horizontal dimension + levs, & ! Number of vertical layers + ko3, & ! Number of vertical layers in ozone forcing data + pl_coeff ! Number of coefficients in ozone forcing data real(kind_phys), intent(in) :: & - dt ! Physics timestep (seconds) + dt ! Physics timestep (seconds) real(kind_phys), intent(in), dimension(:) :: & - po3 ! Natural log of ozone forcing data pressure levels + po3 ! Natural log of ozone forcing data pressure levels real(kind_phys), intent(in), dimension(:,:) :: & - prsl, & ! Air-pressure (Pa) - tin, & ! Temperature of new-state (K) - delp ! Difference between mid-layer pressures (Pa) + prsl, & ! Air-pressure (Pa) + tin, & ! Temperature of new-state (K) + delp ! Difference between mid-layer pressures (Pa) real(kind_phys), intent(in), dimension(:,:,:) :: & - oz_data ! Ozone forcing data + oz_data ! Ozone forcing data - ! In/Outs - real(kind=kind_phys), intent(inout), dimension(:,:,:) :: & - dtend ! Diagnostic tendencies for state variables + ! Outputs (optional) + real(kind=kind_phys), intent(inout), dimension(:,:), pointer, optional :: & + do3_dt_prd, & ! Physics tendency: production and loss effect + do3_dt_ozmx, & ! Physics tendency: ozone mixing ratio effect + do3_dt_temp, & ! Physics tendency: temperature effect + do3_dt_ohoz ! Physics tendency: overhead ozone effect ! Outputs real(kind=kind_phys), intent(inout), dimension(:,:) :: & @@ -110,9 +103,7 @@ subroutine ozphys_2015_run (oz_phys, im, levs, ko3, dt, oz, tin, po3, prsl, oz_d ! Locals integer :: k, kmax, kmin, l, i, j - integer, dimension(4) :: idtend logical, dimension(im) :: flg - real :: gravi real(kind_phys) :: pmax, pmin, tem, temp real(kind_phys), dimension(im) :: wk1, wk2, wk3, ozib real(kind_phys), dimension(im,pl_coeff) :: prod @@ -130,19 +121,8 @@ subroutine ozphys_2015_run (oz_phys, im, levs, ko3, dt, oz, tin, po3, prsl, oz_d return endif - ! Are UFS diagnostic tendencies requested? If so, set up bookeeping indices... - if(ldiag3d) then - idtend(1) = dtidx(100+ntoz,index_of_process_prod_loss) ! was ozp1 - idtend(2) = dtidx(100+ntoz,index_of_process_ozmix) ! was ozp2 - idtend(3) = dtidx(100+ntoz,index_of_process_temp) ! was ozp3 - idtend(4) = dtidx(100+ntoz,index_of_process_overhead_ozone) ! was ozp4 - else - idtend=0 - endif - ! Temporaries ozi = oz - gravi=1.0/con_g colo3(:,levs+1) = 0.0 coloz(:,levs+1) = 0.0 @@ -194,8 +174,8 @@ subroutine ozphys_2015_run (oz_phys, im, levs, ko3, dt, oz, tin, po3, prsl, oz_d enddo enddo do i=1,im - colo3(i,l) = colo3(i,l+1) + ozi(i,l) * delp(i,l)*gravi - coloz(i,l) = coloz(i,l+1) + prod(i,6) * delp(i,l)*gravi + colo3(i,l) = colo3(i,l+1) + ozi(i,l) * delp(i,l)*con_1ovg + coloz(i,l) = coloz(i,l+1) + prod(i,6) * delp(i,l)*con_1ovg prod(i,2) = min(prod(i,2), 0.0) enddo do i=1,im @@ -204,18 +184,12 @@ subroutine ozphys_2015_run (oz_phys, im, levs, ko3, dt, oz, tin, po3, prsl, oz_d + prod(i,4) * (colo3(i,l)-coloz(i,l)) oz(i,l) = (ozib(i) + tem*dt) / (1.0 - prod(i,2)*dt) enddo - if(idtend(1)>=1) then - dtend(:,l,idtend(1)) = dtend(:,l,idtend(1)) + (prod(:,1)-prod(:,2)*prod(:,6))*dt - endif - if(idtend(2)>=1) then - dtend(:,l,idtend(2)) = dtend(:,l,idtend(2)) + (oz(:,l) - ozib(:)) - endif - if(idtend(3)>=1) then - dtend(:,l,idtend(3)) = dtend(:,l,idtend(3)) + prod(:,3)*(tin(:,l)-prod(:,5))*dt - endif - if(idtend(4)>=1) then - dtend(:,l,idtend(4)) = dtend(:,l,idtend(4)) + prod(:,4) * (colo3(:,l)-coloz(:,l))*dt - endif + + ! Diagnostics (optional) + if (associated(do3_dt_prd)) do3_dt_prd(:,l) = (prod(:,1)-prod(:,2)*prod(:,6))*dt + if (associated(do3_dt_ozmx)) do3_dt_ozmx(:,l) = (oz(:,l) - ozib(:)) + if (associated(do3_dt_temp)) do3_dt_temp(:,l) = prod(:,3)*(tin(:,l)-prod(:,5))*dt + if (associated(do3_dt_ohoz)) do3_dt_ohoz(:,l) = prod(:,4) * (colo3(:,l)-coloz(:,l))*dt enddo return diff --git a/physics/ozphys_2015.meta b/physics/ozphys_2015.meta index 4b19f2c04..1d8fba74e 100644 --- a/physics/ozphys_2015.meta +++ b/physics/ozphys_2015.meta @@ -125,71 +125,46 @@ type = real kind = kind_phys intent = in -[ldiag3d] - standard_name = flag_for_diagnostics_3D - long_name = flag for calculating 3-D diagnostic fields - units = flag +[con_1ovg] + standard_name = one_divided_by_the_gravitational_acceleration + long_name = inverse of gravitational acceleration + units = s2 m-1 dimensions = () - type = logical + type = real + kind = kind_phys intent = in -[dtend] - standard_name = cumulative_change_of_state_variables - long_name = diagnostic tendencies for state variables - units = mixed - dimensions = (horizontal_loop_extent,vertical_layer_dimension,cumulative_change_of_state_variables_outer_index_max) +[do3_dt_prd] + standard_name = ozone_tendency_due_to_production_and_loss_rate + long_name = ozone tendency due to production and loss rate + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout -[dtidx] - standard_name = cumulative_change_of_state_variables_outer_index - long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index - units = index - dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes) - type = integer - intent = in -[ntoz] - standard_name = index_of_ozone_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for ozone mixing ratio - units = index - dimensions = () - type = integer - intent = in -[index_of_process_prod_loss] - standard_name = index_of_production_and_loss_process_in_cumulative_change_index - long_name = index of production and loss effect in photochemistry process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_process_ozmix] - standard_name = index_of_ozone_mixing_ratio_process_in_cumulative_change_index - long_name = index of ozone mixing ratio effect in photochemistry process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_process_temp] - standard_name = index_of_temperature_process_in_cumulative_change_index - long_name = index of temperature effect in photochemistry process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_process_overhead_ozone] - standard_name = index_of_overhead_process_in_cumulative_change_index - long_name = index of overhead ozone effect in photochemistry process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[con_g] - standard_name = gravitational_acceleration - long_name = gravitational acceleration - units = m s-2 - dimensions = () +[do3_dt_ozmx] + standard_name = ozone_tendency_due_to_ozone_mixing_ratio + long_name = ozone tendency due to ozone mixing ratio + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys - intent = in + intent = inout +[do3_dt_temp] + standard_name = ozone_tendency_due_to_temperature + long_name = ozone tendency due to temperature + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[do3_dt_ohoz] + standard_name = ozone_tendency_due_to_overhead_ozone_column + long_name = ozone tendency due to overhead ozone column + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/ozphys_time_vary.F90 b/physics/ozphys_time_vary.F90 index a0a778c36..ddac1dcd4 100644 --- a/physics/ozphys_time_vary.F90 +++ b/physics/ozphys_time_vary.F90 @@ -16,8 +16,8 @@ module ozphys_time_vary !! \htmlinclude ozphys_time_vary_init.html !! ! ########################################################################################### - subroutine ozphys_time_vary_init(nPts, latsozp, oz_lat, dlat, jindx1, jindx2, & - ddy, errmsg, errflg) + subroutine ozphys_time_vary_init(nPts, latsozp, oz_lat, dlat, jindx1, jindx2, ddy, & + errmsg, errflg) ! Inputs integer, intent(in) :: & nPts, & ! Horizontal dimension diff --git a/physics/physcons.F90 b/physics/physcons.F90 index e7ec8fb77..19a03ef20 100644 --- a/physics/physcons.F90 +++ b/physics/physcons.F90 @@ -97,6 +97,7 @@ module physcons real(kind=kind_phys),parameter:: con_dldt =con_cvap-con_cliq real(kind=kind_phys),parameter:: con_xpona =-con_dldt/con_rv real(kind=kind_phys),parameter:: con_xponb =-con_dldt/con_rv+con_hvap/(con_rv*con_ttp) + real(kind=kind_phys),parameter:: con_1ovg = 1._kind_phys/con_g !> \name Other Physics/Chemistry constants (source: 2002 CODATA) real(kind=kind_phys),parameter:: con_c =2.99792458e+8_kind_phys !< speed of light (\f$m/s\f$) From 816f607d78a4e89e79f405865f7dfceee3b225fd Mon Sep 17 00:00:00 2001 From: "Michael Kavulich, Jr" Date: Mon, 14 Aug 2023 11:01:43 -0600 Subject: [PATCH 319/380] More fixes from Weiwei --- physics/docs/pdftxt/CLM_LAKE.txt | 2 +- physics/docs/pdftxt/CU_GF_deep.txt | 2 +- physics/docs/pdftxt/SRW_all_schemes_list.txt | 2 +- physics/docs/pdftxt/SRW_mainpage.txt | 13 ++++++------- physics/docs/pdftxt/THOMPSON.txt | 4 ++-- 5 files changed, 11 insertions(+), 12 deletions(-) diff --git a/physics/docs/pdftxt/CLM_LAKE.txt b/physics/docs/pdftxt/CLM_LAKE.txt index f80e55b25..498797511 100644 --- a/physics/docs/pdftxt/CLM_LAKE.txt +++ b/physics/docs/pdftxt/CLM_LAKE.txt @@ -22,7 +22,7 @@ in the lake. Testing of the CLM lake model within RAP/HRRR applications showed computational efficiency of the model with no change of even 0.1% in run time. The lake/snow variables have to be continuously transfered within the CLM lake model from one forecast to another, constrained by the atmospheric data assimilation. The lake-cycling initialization in RAP/HRRR has been effective overall, owing to -accurate houly estimates of near-surface temperature, moisture and winds, and shortwave and longwave estimates provided to the 1-d CLM +accurate hourly estimates of near-surface temperature, moisture and winds, and shortwave and longwave estimates provided to the 1-d CLM lake model every time step (Benjamin et al. (2022) \cite gmd-15-6659-2022). Cycling techniques showed improvements over initializing lake temperatures from the SST analysis, which is problematic for small water bodies. The improvements are particularly eminent during transition periods between cold and warm seasons, and in the regions with anomalous weather conditions. The CLM lake model has the potential diff --git a/physics/docs/pdftxt/CU_GF_deep.txt b/physics/docs/pdftxt/CU_GF_deep.txt index 412dab5f0..ca06666e5 100644 --- a/physics/docs/pdftxt/CU_GF_deep.txt +++ b/physics/docs/pdftxt/CU_GF_deep.txt @@ -9,7 +9,7 @@ Further developments by Grell and \f$D\acute{e}v\acute{e}nyi\f$ (2002) \cite Gre stochastics through allowing parameter perturbations. The GF scheme includes mixed phase physics impact, momentum transport, a diurnal cycle closure (Bechtold et al. (2014) \cite bechtold_et_al_2014 ), and a trimodal spectral size to simulate the interaction and transition from shallow, congestus and deep convection regimes. The vertical mass flux distribution of shallow, congestus and deep convection regimes is characterized by Probability Density Functions (PDFs). The three PDFs are meant to represent the average statistical mass flux characteristic of deep, congestus, and shallow (respectively) plumes in the grid area. Each PDF therefore represents a spectrum of plumes within the grid box. Forcing is different for each characteristic type. Entrainment and detrainment are derived from the PDFs. -The GF scheme takes into account aerosol dependence (considered experimental and not supported in this release), which is implemented through rain generation (following Berry (1968) \cite berry_1968 and evaporation formulations depending on the cloud concentration nuclei at cloud base (Jiang et al. (2010) \cite Jiang_2010, and Lee and Feingold (2010) \cite lee_and_feingold_2010). Wet scavenging is considered to add a memory impact. GF is able to transport tracers. Recently, GPU capabilities and cap suppressing (\p do_cap_suppress) based on radar data assimilation have been added, and they are used only for the RAP suite. +The GF scheme takes into account aerosol dependence (considered experimental and not supported in this release), which is implemented through rain generation (following Berry (1968) \cite berry_1968 and evaporation formulations depending on the cloud concentration nuclei at cloud base (Jiang et al. (2010) \cite Jiang_2010), and Lee and Feingold (2010) \cite lee_and_feingold_2010). Wet scavenging is considered to add a memory impact. GF is able to transport tracers. Recently, GPU capabilities and cap suppressing (\p do_cap_suppress) based on radar data assimilation have been added, and they are used only for the RAP suite. The impacts of GF scheme in operational RAP/HRRR include: (a)uses mass-flux schemes, which are more physically realistic than (sounding) adjustment schemes; (b)takes parameterization uncertainty into account by allowing parameters from multiple convective schemes which can be perturbed diff --git a/physics/docs/pdftxt/SRW_all_schemes_list.txt b/physics/docs/pdftxt/SRW_all_schemes_list.txt index 16a1727e6..d9ef65315 100644 --- a/physics/docs/pdftxt/SRW_all_schemes_list.txt +++ b/physics/docs/pdftxt/SRW_all_schemes_list.txt @@ -68,7 +68,7 @@ to the parameterization. - If the in-core saturation adjustment is used (\p do_sat_adj=.true.), it is invoked at shorter timesteps along with the dynamical solver. -The UFS Short Range Weather Application (SRW App) v3.0.0 supports four physicsphysics suites. +The UFS Short Range Weather Application (SRW App) v3.0.0 supports four physics suites. Table 1. Physics suites and primary schemes supported in SRW v3.0.0 \tableofcontents diff --git a/physics/docs/pdftxt/SRW_mainpage.txt b/physics/docs/pdftxt/SRW_mainpage.txt index 5e854034c..1f756c3ff 100644 --- a/physics/docs/pdftxt/SRW_mainpage.txt +++ b/physics/docs/pdftxt/SRW_mainpage.txt @@ -12,13 +12,12 @@ supports suites: - \ref WoFS_v0_page - \ref rap_suite_page -\attention Here all supported suites are a recent snapshot of - -the UFS fork for CCPP . In this regard, GFS_v16 Suite is -not the same code as in the operational GFS v16. First of all, the operational GFS_v16 does not use CCPP at all. -Secondly, most of physics schemes hosted in CCPP repository have marched ahead since GFS was updated to version 16.0 on 22 March 2021. -This implication should be also applied to all other suites: as such, RAP/HRRR suites in this release are +\attention Important note:
      All supported suites are a recent snapshot of +the UFS fork for CCPP . In this regard, they may differ substantially from the suites used in operational models. For example, the GFS_v16 Suite is +not the same code as in the operational GFS v16. While the suite is nominally the same, using the same schemes as the operational version, most +of the individual physics schemes hosted in the CCPP repository have changed, including new development and bug fixes compared to the versions included +in GFS version 16.0, which was released on 22 March 2021. +This implication should be also applied to all other suites: RAP/HRRR suites in this release do not correspond directly to the the evolving version of the RAP/HRRR physics in operations. - */ diff --git a/physics/docs/pdftxt/THOMPSON.txt b/physics/docs/pdftxt/THOMPSON.txt index 4ad481887..914a95922 100644 --- a/physics/docs/pdftxt/THOMPSON.txt +++ b/physics/docs/pdftxt/THOMPSON.txt @@ -89,8 +89,8 @@ Two namelist variables control the usage of the semi-Lagrangian sedimentation, \ the upper level and reduce the OLR bias. - For the non-aerosol option of the scheme, the cloud number concentration is divided into two parts (over land and others). The number -concentration over the ocean is reduced to a smaller numer (50/L) from its default (100/L). The purpose is to reduce the bias in surface -downward shortwave radiative flux off the coastal regional including the Southeast Pacific. +concentration over the ocean is reduced to a smaller number (50/L) from its default (100/L). The purpose is to reduce the bias in surface +downward shortwave radiative flux off the coastal region including the Southeast Pacific. \section intra_thompson Intraphysics Communication - \ref arg_table_mp_thompson_run From 9c342a5f5841656629d85589fec5507657a561f7 Mon Sep 17 00:00:00 2001 From: "Timothy S. Sliwinski" Date: Tue, 15 Aug 2023 00:23:30 +0000 Subject: [PATCH 320/380] Adding OpenACC statements to accelerate MYNN surface scheme performance through GPU offloading Overview: --------- With very minimal changes to the original code of the scheme, the MYNN surface scheme has been enhanced with OpenACC statements which introduce the capability for offloading computational execution to OpenACC-supported accelerator devices (e.g. Nvidia GPUs). Since the scheme operates by looping multiple times over independent vertical columns, the overall computational strategy maps well to GPU hardware where multiple iterations of each loop can be run in parallel with SIMD methods. Data movement has been optimized to ensure data transfers from host memory to device memory are limited as data movement is a significant source of latency when performing offloading to accelerator devices. Performance increases on a GPU ranged from a 3.3x slowdown to a 41.9x speedup versus CPU execution (See the Performance section for more information). MYNN Scheme Code Changes: ------------------------- A few minor code changes were unavoidable due to certain limitations on what OpenACC is able to execute on the accelerator within kernel and parallel blocks. A complete list of these changes is below: 1. Adding preprocessor directives to disable multiple standard output statements, including those used for debug output. The challenges of these are different depending on the view from the host or accelerator. When run in parallel on the accelerator, these statements are not guaranteed to be presented to the user in-order. Also, in limited cases, these statements would have to output variables that were not transferred to the GPU because they were not necessary for computation, introducing additional transfer overhead to ensure they were present only for these output statements. Further, with hundreds of threads executing at once, the output could be quite large and unwieldy. That said, some of these statements could have been run on the host to alleviate the problems introduced by parallelization on the device. However, this would have necessitated device-to-host transfers of variables to ensure values being output were correct while introducing additional transfer overhead costs to performance. Disabling these for accelerators only seemed the best course of action. These are disabled based on the presence of the __OPENACC compile time variable to ensure these are only disabled when the code is compiled for accelerator usage and does not affect CPU execution. 2. Changing the CCPP errmsg variable declaration on line 349 of module_sf_mynn.F90 to be a fixed 200 length character array. Since this variable is set at times in the middle of accelerator kernel regions, it must be present on the accelerator. However, when defined with "len=*", it is an assumed-size array, which OpenACC does not support on the accelerator. Rather than disable this variable completely, changing it to a fixed length allows it to be transferred to/from the accelerator and used. This change is enforced by preprocessor directives based on the presence of the __OPENACC compile time variable and ensures this change only occurs when the code is compiled for accelerator usage, therefore it does not affect CPU execution. 3. Adding preprocessor directives to "move" return statement on line 1399 of module_sf_mynn.F90 out of the main i-loop and instead execute it at line 2006 if errflg is set to 1. This change is necessary as OpenACC accelerator code cannot execute branching such as this, so this conditional return statement can only be executed by the host. This change is enforced by preprocessor directives based on the presence of the __OPENACC compile time variable and ensures this change only occurs when the code is compiled for accelerator usage, therefore it does not affect CPU execution. 4. Commenting out the zLhux local variable in the zolri function over lines 3671 to 3724. The zLhux variable appears to have been used only to capture values of zolri over multiple iterations, but is never used or passed along after this collection is completed. Since this array would be an assumed-size array based on the value of nmax at runtime, it would have been unsupported by OpenACC. But, since it is unused, the choice was made to simply comment out the variable and all lines related to it, allow the remaining code of the function to executed on the accelerator. Performance: ------------ Performance testing was performed on a single Nvidia P100 GPU versus a single 10-core Haswell CPU on Hera. Since the MYNN Surface scheme is a serial code, parallelization on the 10-core Haswell was performed using simple data partitioning across the 10 cores using OpenMP threads such that each thread received a near equal amount of data. When data movement was fully optimized for the accelerator -- meaning all CCPP Physics input variables were pre-loaded on the GPU as they would be when the CCPP infrastructure fully supports accelerator offloading -- GPU performance speedups range between 11.8X and 41.8X over the 10-core Haswell when the number of vertical columns (i) was varied between 150k and 750k, respectively. Performance Timings (optimized data movement) Columns (i) \ Compute | CPU | GPU | GPU Speedup | --------------------------------------------------------------------------- 150,000 | 263 ms | 22 ms | 11.9x | --------------------------------------------------------------------------- 450,000 | 766 ms | 28 ms | 27.0x | --------------------------------------------------------------------------- 750,000 | 1314 ms | 31 ms | 41.9x | --------------------------------------------------------------------------- However, standalone performance -- meaning all CCPP Physics input variables were initially loaded onto the GPU only after being declared in the MYNN subroutine calls -- was slightly less performant than the 10-core Haswell due to the additional overhead incurred by the data transfers. In this case, the decreasing performance lag for the GPU behind the CPU as the number of columns increases is due to the GPU performing better with more data (i.e. higher computational throughput) than the CPU despite more data needing to be transferred to the device. Performance Timings (standalone) Columns (i) \ Compute | CPU | GPU | GPU Speedup | ------------------------------------------------------------------------------- 150,000 | 263 ms | 862 ms | -3.3x | ------------------------------------------------------------------------------- 450,000 | 766 ms | 1767 ms | -2.3x | ------------------------------------------------------------------------------- 750,000 | 1314 ms | 2776 ms | -2.1x | ------------------------------------------------------------------------------- With these results, it is clear that this scheme will perform at its best on accelerators once the CCPP infrastructure also supports OpenACC. Contact Information: -------------------- This enhancement was performed by Timothy Sliwinski at NOAA GSL. Questions regarding these changes should be directed to timothy.s.sliwinski@noaa.gov --- physics/module_sf_mynn.F90 | 331 ++++++++++++++++++++++++++++++++++-- physics/mynnsfc_wrapper.F90 | 31 ++++ 2 files changed, 351 insertions(+), 11 deletions(-) diff --git a/physics/module_sf_mynn.F90 b/physics/module_sf_mynn.F90 index c60247cf6..399b1ee83 100644 --- a/physics/module_sf_mynn.F90 +++ b/physics/module_sf_mynn.F90 @@ -106,6 +106,7 @@ MODULE module_sf_mynn REAL(kind_phys), DIMENSION(0:1000 ),SAVE :: psim_stab,psim_unstab, & psih_stab,psih_unstab +!$acc declare create(psim_stab, psim_unstab, psih_stab, psih_unstab) CONTAINS @@ -344,7 +345,12 @@ SUBROUTINE SFCLAY_mynn( & & qsfc_wat, qsfc_lnd, qsfc_ice ! CCPP error handling +#ifndef _OPENACC character(len=*), intent(inout) :: errmsg +#else +!Necessary since OpenACC does not support assumed-size arrays + character(len=200), intent(inout) :: errmsg +#endif integer, intent(inout) :: errflg !ADDITIONAL OUTPUT @@ -371,6 +377,20 @@ SUBROUTINE SFCLAY_mynn( & errflg = 0 errmsg = '' +!$acc enter data copyin( dz8w,U3D,V3D,QV3D,QC3D,P3D,T3D, & +!$acc pattern_spp_sfc, errmsg) + +!$acc enter data copyin( UST_WAT(:), UST_LND(:), UST_ICE(:), & +!$acc MOL(:), QFLX(:), HFLX(:), & +!$acc QSFC(:), QSFC_WAT(:), QSFC_LND(:), & +!$acc QSFC_ICE(:)) + +!$acc enter data create( dz8w1d(:), dz2w1d(:), U1D(:), & +!$acc V1D(:), U1D2(:), V1D2(:), & +!$acc QV1D(:), QC1D(:), P1D(:), & +!$acc T1D(:), rstoch1D(:), qstar(:)) + + IF (debug_code >= 1) THEN write(*,*)"======= printing of constants:" write(*,*)"cp=", cp," g=", grav @@ -382,6 +402,10 @@ SUBROUTINE SFCLAY_mynn( & itf=ite !MIN0(ite,ide-1) ktf=kte !MIN0(kte,kde-1) +!$acc parallel loop present(dz8w,U3D,V3D,QV3D,QC3D,P3D,T3D, & +!$acc pattern_spp_sfc,dz8w1d,dz2w1d,U1D, & +!$acc V1D,U1D2,V1D2,QV1D,QC1D,P1D,T1D, & +!$acc rstoch1D,qstar) DO i=its,ite dz8w1d(I) = dz8w(i,kts) dz2w1d(I) = dz8w(i,kts+1) @@ -403,6 +427,9 @@ SUBROUTINE SFCLAY_mynn( & ENDDO IF (itimestep==1 .AND. iter==1) THEN +!$acc parallel loop present(U1D,V1D,UST_WAT,UST_LND,UST_ICE,MOL, & +!$acc QFLX,HFLX,QV3D,QSFC,QSFC_WAT, & +!$acc QSFC_LND,QSFC_ICE) DO i=its,ite IF (.not. flag_restart) THEN !Everything here is used before calculated @@ -432,6 +459,9 @@ SUBROUTINE SFCLAY_mynn( & ENDDO ENDIF +!$acc exit data delete( dz8w,U3D,V3D,QV3D,QC3D,P3D,T3D, & +!$acc pattern_spp_sfc, QC1D) + CALL SFCLAY1D_mynn(flag_iter, & J,U1D,V1D,T1D,QV1D,P1D,dz8w1d, & U1D2,V1D2,dz2w1d, & @@ -471,6 +501,16 @@ SUBROUTINE SFCLAY_mynn( & its,ite, jts,jte, kts,kte, & errmsg, errflg ) +!$acc exit data copyout( UST_WAT(:), UST_LND(:), UST_ICE(:), & +!$acc MOL(:), QFLX(:), HFLX(:), & +!$acc QSFC(:), QSFC_WAT(:), QSFC_LND(:), & +!$acc QSFC_ICE(:), errmsg) + +!$acc exit data delete( dz8w1d(:), dz2w1d(:), U1D(:), & +!$acc V1D(:), U1D2(:), V1D2(:), & +!$acc QV1D(:), T1D(:), P1D(:), & +!$acc rstoch1D(:), qstar(:)) + END SUBROUTINE SFCLAY_MYNN !------------------------------------------------------------------- @@ -626,7 +666,12 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !JOE-end ! CCPP error handling +#ifndef _OPENACC character(len=*), intent(inout) :: errmsg +#else +! Necessary since OpenACC does not support assumed-size arrays + character(len=200), intent(inout) :: errmsg +#endif integer, intent(inout) :: errflg !---------------------------------------------------------------- @@ -679,6 +724,58 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & errflg = 0 errmsg = '' !------------------------------------------------------------------- +!$acc update device(psim_stab, psim_unstab, psih_stab, psih_unstab) + +!$acc enter data create( ZA, ZA2, THV1D, TH1D, TC1D, TV1D, & +!$acc RHO1D, QVSH, PSIH2, PSIM10, PSIH10, WSPDI, & +!$acc GOVRTH, PSFC, THCON, & +!$acc zratio_lnd, zratio_ice, zratio_wat, & +!$acc TSK_lnd, TSK_ice, TSK_wat, & +!$acc THSK_lnd, THSK_ice, THSK_wat, & +!$acc THVSK_lnd, THVSK_ice, THVSK_wat, & +!$acc GZ1OZ0_lnd, GZ1OZ0_ice, GZ1OZ0_wat, & +!$acc GZ1OZt_lnd, GZ1OZt_ice, GZ1OZt_wat, & +!$acc GZ2OZ0_lnd, GZ2OZ0_ice, GZ2OZ0_wat, & +!$acc GZ2OZt_lnd, GZ2OZt_ice, GZ2OZt_wat, & +!$acc GZ10OZ0_lnd, GZ10OZ0_ice, GZ10OZ0_wat, & +!$acc GZ10OZt_lnd, GZ10OZt_ice, GZ10OZt_wat, & +!$acc ZNTstoch_lnd, ZNTstoch_ice, ZNTstoch_wat, & +!$acc ZT_lnd, ZT_ice, ZT_wat, & +!$acc ZQ_lnd, ZQ_ice, ZQ_wat, & +!$acc PSIQ_lnd, PSIQ_ice, PSIQ_wat, & +!$acc PSIQ2_lnd, PSIQ2_ice, PSIQ2_wat, & +!$acc QSFCMR_lnd, QSFCMR_ice, QSFCMR_wat ) + +!$acc enter data copyin(flag_iter, dry, wet, icy, CPM, MAVAIL, & +!$acc QFX, FLHC, FLQC, CHS, CH, CHS2, CQS2, USTM, & +!$acc HFX, LH, wstar, qstar, PBLH, ZOL, MOL, RMOL, & +!$acc T2, TH2, Q2, QV1D, PSFCPA, & +!$acc WSPD, U10, V10, U1D, V1D, U1D2, V1D2, & +!$acc T1D, P1D, rstoch1D, sigmaf, & +!$acc shdmax, vegtype, z0pert, ztpert, dx, QGH, & +!$acc dz2w1d, dz8w1d, & +!$acc stress_wat, stress_lnd, stress_ice, & +!$acc rb_wat, rb_lnd, rb_ice, & +!$acc tskin_wat, tskin_lnd, tskin_ice, & +!$acc tsurf_wat, tsurf_lnd, tsurf_ice, & +!$acc psim, psih, & +!$acc UST_wat, UST_lnd, UST_ice, & +!$acc ZNT_wat, ZNT_lnd, ZNT_ice, & +!$acc QSFC, QSFC_lnd, QSFC_wat, QSFC_ice, & +!$acc QFLX, QFLX_lnd, QFLX_wat, QFLX_ice, & +!$acc HFLX, HFLX_lnd, HFLX_wat, HFLX_ice, & +!$acc PSIX_wat, PSIX_lnd, PSIX_ice, & +!$acc PSIX10_wat, PSIX10_lnd, PSIX10_ice, & +!$acc PSIT2_lnd, PSIT2_wat, PSIT2_ice, & +!$acc PSIT_lnd, PSIT_wat, PSIT_ice, & +!$acc ch_lnd, ch_wat, ch_ice, & +!$acc cm_lnd, cm_wat, cm_ice, & +!$acc snowh_lnd, errmsg) + +!$acc parallel loop present(PSFCPA, PSFC, QSFC, T1D, flag_iter, & +!$acc QSFC_wat, QSFCMR_wat, wet, TSK_wat, tskin_wat, & +!$acc QSFC_lnd, QSFCMR_lnd, dry, TSK_lnd, tskin_lnd, & +!$acc QSFC_ice, QSFCMR_ice, icy, TSK_ice, tskin_ice) DO I=its,ite ! PSFC ( in cmb) is used later in saturation checks @@ -700,7 +797,9 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ENDIF QSFC_wat(I)=EP2*E1/(PSFC(I)-ep3*E1) !specific humidity QSFCMR_wat(I)=EP2*E1/(PSFC(I)-E1) !mixing ratio +#ifndef _OPENACC IF(QSFC_wat(I)>1..or.QSFC_wat(I)<0.) print *,' QSFC_wat(I)',itimestep,i,QSFC_wat(I),TSK_wat(i) +#endif ENDIF IF (dry(i)) THEN TSK_lnd(I) = tskin_lnd(i) @@ -720,7 +819,9 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & QSFC_lnd(I)=0.5*(QSFC_lnd(I) + QSFC(I)) QSFCMR_lnd(I)=QSFC_lnd(I)/(1.-QSFC_lnd(I)) !mixing ratio endif ! lsm +#ifndef _OPENACC IF(QSFC_lnd(I)>1..or.QSFC_lnd(I)<0.) print *,' QSFC_lnd(I)',itimestep,i,QSFC_lnd(I),Tskin_lnd(i),tsurf_lnd(i),qsfc(i) +#endif ENDIF IF (icy(i)) THEN TSK_ice(I) = tskin_ice(i) @@ -738,7 +839,9 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & QSFC_ice(I)=EP2*E1/(PSFC(I)-ep3*E1) !specific humidity QSFCMR_ice(I)=EP2*E1/(PSFC(I)-E1) !mixing ratio endif ! lsm +#ifndef _OPENACC IF(QSFC_ice(I)>1..or.QSFC_ice(I)<0.) print *,' QSFC_ice(I)',itimestep,i,QSFC_ice(I),TSK_ice(i) +#endif ENDIF ELSE @@ -791,6 +894,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & endif ! flag_iter ENDDO +#ifndef _OPENACC IF (debug_code >= 1) THEN write(0,*)"ITIMESTEP=",ITIMESTEP," iter=",iter DO I=its,ite @@ -815,7 +919,12 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ENDIF ENDDO ENDIF +#endif +!$acc parallel loop present(PSFC, PSFCPA, QVSH, QV1D, THCON, flag_iter, & +!$acc dry, tskin_lnd, TSK_lnd, tsurf_lnd, THSK_lnd, THVSK_lnd, qsfc_lnd, & +!$acc icy, tskin_ice, TSK_ice, tsurf_ice, THSK_ice, THVSK_ice, qsfc_ice, & +!$acc wet, tskin_wat, TSK_wat, tsurf_wat, THSK_wat, THVSK_wat) DO I=its,ite ! PSFC ( in cmb) is used later in saturation checks PSFC(I)=PSFCPA(I)/1000. @@ -829,8 +938,10 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ! CONVERT SKIN TEMPERATURES TO POTENTIAL TEMPERATURE: THSK_lnd(I) = TSK_lnd(I)*THCON(I) !(K) THVSK_lnd(I) = THSK_lnd(I)*(1.+EP1*qsfc_lnd(I)) +#ifndef _OPENACC if(THVSK_lnd(I) < 170. .or. THVSK_lnd(I) > 360.) & print *,'THVSK_lnd(I)',itimestep,i,THVSK_lnd(I),THSK_lnd(i),tsurf_lnd(i),tskin_lnd(i),qsfc_lnd(i) +#endif endif if(icy(i)) then TSK_ice(I) = tskin_ice(i) @@ -838,8 +949,10 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ! CONVERT SKIN TEMPERATURES TO POTENTIAL TEMPERATURE: THSK_ice(I) = TSK_ice(I)*THCON(I) !(K) THVSK_ice(I) = THSK_ice(I)*(1.+EP1*qsfc_ice(I)) !(K) +#ifndef _OPENACC if(THVSK_ice(I) < 170. .or. THVSK_ice(I) > 360.) & print *,'THVSK_ice(I)',itimestep,i,THVSK_ice(I),THSK_ice(i),tsurf_ice(i),tskin_ice(i),qsfc_ice(i) +#endif endif if(wet(i)) then TSK_wat(I) = tskin_wat(i) @@ -847,24 +960,29 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ! CONVERT SKIN TEMPERATURES TO POTENTIAL TEMPERATURE: THSK_wat(I) = TSK_wat(I)*THCON(I) !(K) THVSK_wat(I) = THSK_wat(I)*(1.+EP1*QVSH(I)) !(K) +#ifndef _OPENACC if(THVSK_wat(I) < 170. .or. THVSK_wat(I) > 360.) & print *,'THVSK_wat(I)',i,THVSK_wat(I),THSK_wat(i),tsurf_wat(i),tskin_wat(i),qsfc_wat(i) +#endif endif endif ! flag_iter ENDDO +!$acc parallel loop present(TH1D, T1D, P1D, TC1D) DO I=its,ite ! CONVERT LOWEST LAYER TEMPERATURE TO POTENTIAL TEMPERATURE: TH1D(I)=T1D(I)*(100000./P1D(I))**ROVCP !(Theta, K) TC1D(I)=T1D(I)-273.15 !(T, Celsius) ENDDO +!$acc parallel loop present(THV1D, TH1D, QVSH, TV1D, T1D) DO I=its,ite ! CONVERT TO VIRTUAL TEMPERATURE THV1D(I)=TH1D(I)*(1.+EP1*QVSH(I)) !(K) TV1D(I)=T1D(I)*(1.+EP1*QVSH(I)) !(K) ENDDO +!$acc parallel loop present(RHO1D, P1D, TV1D, TH1D, ZA, ZA2, dz2w1d, dz8w1d, GOVRTH) DO I=its,ite RHO1D(I)=P1D(I)/(Rd*TV1D(I)) !now using value calculated in sfc driver ZA(I)=0.5*dz8w1d(I) !height of first half-sigma level @@ -873,11 +991,13 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ENDDO !tgs - should QFX and HFX be separate for land, ice and water? +!$acc parallel loop present(QFX, QFLX, RHO1D, HFX, HFLX) DO I=its,ite QFX(i)=QFLX(i)*RHO1D(I) HFX(i)=HFLX(i)*RHO1D(I)*cp ENDDO +#ifndef _OPENACC IF (debug_code ==2) THEN !write(*,*)"ITIMESTEP=",ITIMESTEP DO I=its,ite @@ -890,7 +1010,9 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & write(*,*)"RHO1D=", RHO1D(i)," GOVRTH=",GOVRTH(i) ENDDO ENDIF +#endif +!$acc parallel loop present(T1D,P1D,QGH,QV1D,CPM) DO I=its,ite ! QGH CHANGED TO USE LOWEST-LEVEL AIR TEMP ! Q2SAT = QGH IN LSM @@ -908,6 +1030,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & CPM(I)=CP*(1.+0.84*QV1D(I)) ENDDO +#ifndef _OPENACC IF (debug_code == 2) THEN write(*,*)"ITIMESTEP=",ITIMESTEP DO I=its,ite @@ -925,7 +1048,13 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & endif ENDDO ENDIF +#endif +!$acc parallel loop present(flag_iter,U1D,V1D,WSPD,wet,dry,icy, & +!$acc THV1D,THVSK_wat,THVSK_lnd,THVSK_ice, & +!$acc hfx,RHO1D,qfx,WSTAR,pblh,dx,GOVRTH,ZA, & +!$acc TSK_wat,TSK_lnd,TSK_ice, & +!$acc rb_wat,rb_lnd,rb_ice) DO I=its,ite if( flag_iter(i) ) then ! DH* 20200401 - note. A weird bug in Intel 18 on hera prevents using the @@ -1041,6 +1170,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & WSPD(I) = MAX(WSPD_ice,WSPD_wat) WSPD(I) = MAX(WSPD_lnd,WSPD(I)) +#ifndef _OPENACC IF (debug_code == 2) THEN write(*,*)"===== After rb calc in mynn sfc layer:" write(*,*)"ITIMESTEP=",ITIMESTEP @@ -1049,6 +1179,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & IF (wet(i))write(*,*)"rb_wat=", rb_wat(I)," DTHVDZ=",DTHVDZ IF (dry(i))write(*,*)"rb_lnd=", rb_lnd(I)," DTHVDZ=",DTHVDZ ENDIF +#endif ! IF PREVIOUSLY UNSTABLE, DO NOT LET INTO REGIMES 1 AND 2 (STABLE) !if (itimestep .GT. 1) THEN @@ -1067,6 +1198,29 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !-------------------------------------------------------------------- !-------------------------------------------------------------------- +!$acc parallel loop present(flag_iter, errmsg, & +!$acc wet, dry, icy, & +!$acc ZT_wat, ZT_lnd, ZT_ice, & +!$acc ZNT_wat, ZNT_lnd, ZNT_ice, & +!$acc ZNTstoch_wat, ZNTstoch_lnd, ZNTstoch_ice, & +!$acc UST_wat, UST_lnd, UST_ice, & +!$acc ZQ_wat, ZQ_lnd, ZQ_ice, & +!$acc snowh_lnd, & +!$acc THVSK_wat, THVSK_lnd, THVSK_ice, & +!$acc qsfc_wat, qsfc_lnd, qsfc_ice, & +!$acc GZ1OZ0_wat, GZ1OZt_wat, GZ2OZ0_wat, GZ2OZt_wat, GZ10OZ0_wat, GZ10OZt_wat, & +!$acc GZ1OZ0_lnd, GZ1OZt_lnd, GZ2OZ0_lnd, GZ2OZt_lnd, GZ10OZ0_lnd, GZ10OZt_lnd, & +!$acc GZ1OZ0_ice, GZ1OZt_ice, GZ2OZ0_ice, GZ2OZt_ice, GZ10OZ0_ice, GZ10OZt_ice, & +!$acc zratio_wat, zratio_lnd, zratio_ice, & +!$acc stress_wat, stress_lnd, stress_ice, & +!$acc rb_wat, rb_lnd, rb_ice, & +!$acc psim, psih, psim10, psih10, psih2, & +!$acc psix_wat, psix10_wat, psit_wat, psit2_wat, psiq_wat, psiq2_wat, & +!$acc psix_lnd, psix10_lnd, psit_lnd, psit2_lnd, psiq_lnd, psiq2_lnd, & +!$acc psix_ice, psix10_ice, psit_ice, psit2_ice, psiq_ice, psiq2_ice, & +!$acc WSPD, WSPDI, U1D, V1D, TC1D, THV1D, rstoch1D, USTM, ZA, ZOL, QVSH, & +!$acc shdmax, vegtype, z0pert, ztpert, mol, rmol, qstar, sigmaf) + DO I=its,ite if( flag_iter(i) ) then @@ -1082,10 +1236,12 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & if (sfc_z0_type >= 0) then ! Avoid calculation is using wave model ! CALCULATE z0 (znt) !-------------------------------------- +#ifndef _OPENACC IF (debug_code == 2) THEN write(*,*)"=============Input to ZNT over water:" write(*,*)"u*:",UST_wat(i)," wspd=",WSPD(i)," visc=",visc," za=",ZA(I) ENDIF +#endif IF ( PRESENT(ISFTCFLX) ) THEN IF ( ISFTCFLX .EQ. 0 ) THEN IF (COARE_OPT .EQ. 3.0) THEN @@ -1122,10 +1278,12 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ZNTstoch_wat(I) = ZNT_wat(I) endif +#ifndef _OPENACC IF (debug_code > 1) THEN write(*,*)"==========Output ZNT over water:" write(*,*)"ZNT:",ZNTstoch_wat(i) ENDIF +#endif !COMPUTE ROUGHNESS REYNOLDS NUMBER (restar) USING NEW ZNT ! AHW: Garrattt formula: Calculate roughness Reynolds number @@ -1136,10 +1294,12 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !-------------------------------------- !CALCULATE z_t and z_q !-------------------------------------- +#ifndef _OPENACC IF (debug_code > 1) THEN write(*,*)"=============Input to ZT over water:" write(*,*)"u*:",UST_wat(i)," restar=",restar," visc=",visc ENDIF +#endif IF ( PRESENT(ISFTCFLX) ) THEN IF ( ISFTCFLX .EQ. 0 ) THEN @@ -1183,10 +1343,12 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & rstoch1D(i),spp_sfc) ENDIF ENDIF +#ifndef _OPENACC IF (debug_code > 1) THEN write(*,*)"=============Output ZT & ZQ over water:" write(*,*)"ZT:",ZT_wat(i)," ZQ:",ZQ_wat(i) ENDIF +#endif GZ1OZ0_wat(I)= LOG((ZA(I)+ZNTstoch_wat(I))/ZNTstoch_wat(I)) GZ1OZt_wat(I)= LOG((ZA(I)+ZNTstoch_wat(i))/ZT_wat(i)) @@ -1232,7 +1394,10 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ! or initialized to zero, but certainly not set correctly errmsg = 'Logic error: qstar is not set correctly when calling Yang_2008' errflg = 1 +#ifndef _OPENACC +! Necessary since OpenACC does not support branching in parallel code return +#endif CALL Yang_2008(ZNTSTOCH_lnd(i),ZT_lnd(i),ZQ_lnd(i),UST_lnd(i),MOL(I),& qstar(I),restar,visc) ELSEIF ( IZ0TLND .EQ. 3 ) THEN @@ -1249,6 +1414,8 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & UST_lnd(I),KARMAN,1.0_kind_phys,0,spp_sfc,rstoch1D(i)) ENDIF ENDIF + +#ifndef _OPENACC IF (ZNTstoch_lnd(i) < 1E-8 .OR. Zt_lnd(i) < 1E-10) THEN write(0,*)"===(land) capture bad input in mynn sfc layer, i=:",i write(0,*)" ZNT=", ZNTstoch_lnd(i)," ZT=",Zt_lnd(i) @@ -1257,7 +1424,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & " ust=", ust_lnd(i)," snowh=", snowh_lnd(i),"psfcpa=",PSFCPA(i), & " dz=",dz8w1d(i)," qflx=",qflx_lnd(i)," hflx=",hflx_lnd(i)," hpbl=",pblh(i) ENDIF - +#endif GZ1OZ0_lnd(I)= LOG((ZA(I)+ZNTstoch_lnd(I))/ZNTstoch_lnd(I)) GZ1OZt_lnd(I)= LOG((ZA(I)+ZNTstoch_lnd(i))/ZT_lnd(i)) @@ -1323,6 +1490,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ZOL(I)=MAX(ZOL(I),0.0_kind_phys) ZOL(I)=MIN(ZOL(I),20._kind_phys) +#ifndef _OPENACC IF (debug_code >= 1) THEN IF (ZNTstoch_wat(i) < 1E-8 .OR. Zt_wat(i) < 1E-10) THEN write(0,*)"===(wet) capture bad input in mynn sfc layer, i=:",i @@ -1333,6 +1501,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) ENDIF ENDIF +#endif !Use Pedros iterative function to find z/L !zol(I)=zolri(rb_wat(I),ZA(I),ZNTstoch_wat(I),ZT_wat(I),ZOL(I),psi_opt) @@ -1390,6 +1559,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ZOL(I)=MAX(ZOL(I),-20.0_kind_phys) ZOL(I)=MIN(ZOL(I),0.0_kind_phys) +#ifndef _OPENACC IF (debug_code >= 1) THEN IF (ZNTstoch_wat(i) < 1E-8 .OR. Zt_wat(i) < 1E-10) THEN write(0,*)"===(wet) capture bad input in mynn sfc layer, i=:",i @@ -1400,6 +1570,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) ENDIF ENDIF +#endif !Use Pedros iterative function to find z/L !zol(I)=zolri(rb_wat(I),ZA(I),ZNTstoch_wat(I),ZT_wat(I),ZOL(I),psi_opt) @@ -1460,6 +1631,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ZOL(I)=MAX(ZOL(I),0.0_kind_phys) ZOL(I)=MIN(ZOL(I),20._kind_phys) +#ifndef _OPENACC IF (debug_code >= 1) THEN IF (ZNTstoch_lnd(i) < 1E-8 .OR. Zt_lnd(i) < 1E-10) THEN write(0,*)"===(land) capture bad input in mynn sfc layer, i=:",i @@ -1470,6 +1642,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) ENDIF ENDIF +#endif !Use Pedros iterative function to find z/L !zol(I)=zolri(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),ZT_lnd(I),ZOL(I),psi_opt) @@ -1526,6 +1699,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ZOL(I)=MAX(ZOL(I),-20.0_kind_phys) ZOL(I)=MIN(ZOL(I),0.0_kind_phys) +#ifndef _OPENACC IF (debug_code >= 1) THEN IF (ZNTstoch_lnd(i) < 1E-8 .OR. Zt_lnd(i) < 1E-10) THEN write(0,*)"===(land) capture bad input in mynn sfc layer, i=:",i @@ -1536,6 +1710,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) ENDIF ENDIF +#endif !Use Pedros iterative function to find z/L !zol(I)=zolri(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),ZT_lnd(I),ZOL(I),psi_opt) @@ -1595,6 +1770,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ZOL(I)=MAX(ZOL(I),0.0_kind_phys) ZOL(I)=MIN(ZOL(I),20._kind_phys) +#ifndef _OPENACC IF (debug_code >= 1) THEN IF (ZNTstoch_ice(i) < 1E-8 .OR. Zt_ice(i) < 1E-10) THEN write(0,*)"===(ice) capture bad input in mynn sfc layer, i=:",i @@ -1605,6 +1781,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) ENDIF ENDIF +#endif !Use Pedros iterative function to find z/L !zol(I)=zolri(rb_ice(I),ZA(I),ZNTstoch_ice(I),ZT_ice(I),ZOL(I),psi_opt) @@ -1661,6 +1838,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ZOL(I)=MAX(ZOL(I),-20.0_kind_phys) ZOL(I)=MIN(ZOL(I),0.0_kind_phys) +#ifndef _OPENACC IF (debug_code >= 1) THEN IF (ZNTstoch_ice(i) < 1E-8 .OR. Zt_ice(i) < 1E-10) THEN write(0,*)"===(ice) capture bad input in mynn sfc layer, i=:",i @@ -1671,6 +1849,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) ENDIF ENDIF +#endif !Use Pedros iterative function to find z/L !zol(I)=zolri(rb_ice(I),ZA(I),ZNTstoch_ice(I),ZT_ice(I),ZOL(I),psi_opt) @@ -1821,6 +2000,14 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & endif ! flag_iter ENDDO ! end i-loop +#ifdef _OPENACC + ! Necessary since OpenACC does not support branching in parallel code + IF (errflg == 1) THEN + return + ENDIF +#endif + +#ifndef _OPENACC IF (debug_code == 2) THEN DO I=its,ite IF(wet(i))write(*,*)"==== AT END OF MAIN LOOP, i=",i, "(wet)" @@ -1841,10 +2028,29 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & write(*,*)"=============================================" ENDDO ! end i-loop ENDIF +#endif !---------------------------------------------------------- ! COMPUTE SURFACE HEAT AND MOISTURE FLUXES !---------------------------------------------------------- +!$acc parallel loop present(flag_iter, dry, wet, icy, & +!$acc QFX, HFX, FLHC, FLQC, LH, CHS, CH, CHS2, CQS2, & +!$acc RHO1D, MAVAIL, USTM, & +!$acc UST_lnd, UST_wat, UST_ice, & +!$acc PSIQ_lnd, PSIT_lnd, PSIX_lnd, & +!$acc PSIQ_wat, PSIT_wat, PSIX_wat, & +!$acc PSIQ_ice, PSIT_ice, PSIX_ice, & +!$acc PSIQ2_lnd, PSIT2_lnd, & +!$acc PSIQ2_wat, PSIT2_wat, & +!$acc PSIQ2_ice, PSIT2_ice, & +!$acc QSFC, QSFC_lnd, QSFC_wat, QSFC_ice, & +!$acc QFLX, QFLX_lnd, QFLX_wat, QFLX_ice, & +!$acc HFLX, HFLX_lnd, HFLX_wat, HFLX_ice, & +!$acc QSFCMR_lnd, QSFCMR_wat, QSFCMR_ice, & +!$acc QV1D, WSPD, WSPDI, CPM, TH1D, & +!$acc THSK_lnd, THSK_wat, THSK_ice, & +!$acc ch_lnd, ch_wat, ch_ice, & +!$acc cm_lnd, cm_wat, cm_ice) DO I=its,ite if( flag_iter(i) ) then @@ -2008,12 +2214,14 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ENDIF +#ifndef _OPENACC IF (debug_code > 1) THEN write(*,*)"QFX=",QFX(I),"FLQC=",FLQC(I) if(icy(i))write(*,*)"ice, MAVAIL:",MAVAIL(I)," u*=",UST_ice(I)," psiq=",PSIQ_ice(i) if(dry(i))write(*,*)"lnd, MAVAIL:",MAVAIL(I)," u*=",UST_lnd(I)," psiq=",PSIQ_lnd(i) if(wet(i))write(*,*)"ocn, MAVAIL:",MAVAIL(I)," u*=",UST_wat(I)," psiq=",PSIQ_wat(i) ENDIF +#endif ! The exchange coefficient for cloud water is assumed to be the ! same as that for heat. CH is multiplied by WSPD. @@ -2040,6 +2248,18 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ENDDO ! end i-loop IF (compute_diag) then + !$acc parallel loop present(flag_iter, dry, wet, icy, & + !$acc ZA, ZA2, T2, TH2, TH1D, Q2, QV1D, PSFCPA, & + !$acc THSK_lnd, THSK_wat, THSK_ice, & + !$acc QSFC_lnd, QSFC_wat, QSFC_ice, & + !$acc U10, V10, U1D, V1D, U1D2, V1D2, & + !$acc ZNTstoch_lnd, ZNTstoch_lnd, ZNTstoch_ice, & + !$acc PSIX_lnd, PSIX_wat, PSIX_ice, & + !$acc PSIX10_lnd, PSIX10_wat, PSIX10_ice, & + !$acc PSIT2_lnd, PSIT2_wat, PSIT2_ice, & + !$acc PSIT_lnd, PSIT_wat, PSIT_ice, & + !$acc PSIQ2_lnd, PSIQ2_wat, PSIQ2_ice, & + !$acc PSIQ_lnd, PSIQ_wat, PSIQ_ice) DO I=its,ite if( flag_iter(i) ) then !----------------------------------------------------- @@ -2154,6 +2374,16 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ! DEBUG - SUSPICIOUS VALUES !----------------------------------------------------- IF ( debug_code == 2) THEN + !$acc parallel loop present(dry, wet, icy, CPM, MAVAIL, & + !$acc HFX, LH, wstar, RHO1D, PBLH, ZOL, ZA, MOL, & + !$acc PSIM, PSIH, WSTAR, T1D, TH1D, THV1D, QVSH, & + !$acc UST_wat, UST_lnd, UST_ice, & + !$acc THSK_wat, THSK_lnd, THSK_ice, & + !$acc THVSK_wat, THVSK_lnd, THVSK_ice, & + !$acc ZNTstoch_wat, ZNTstoch_lnd, ZNTstoch_ice, & + !$acc ZT_wat, ZT_lnd, ZT_ice, & + !$acc QSFC_wat, QSFC_lnd, QSFC_ice, & + !$acc PSIX_wat, PSIX_lnd, PSIX_ice) DO I=its,ite yesno = 0 IF (compute_flux) THEN @@ -2258,6 +2488,54 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ENDDO ! end i-loop ENDIF ! end debug option +!$acc exit data copyout(CPM, FLHC, FLQC, CHS, CH, CHS2, CQS2,& +!$acc USTM, wstar, qstar, ZOL, MOL, RMOL, & +!$acc HFX, QFX, LH, QSFC, QFLX, HFLX, & +!$acc T2, TH2, Q2, WSPD, U10, V10, & +!$acc QGH, psim, psih, & +!$acc stress_wat, stress_lnd, stress_ice, & +!$acc rb_wat, rb_lnd, rb_ice, & +!$acc UST_wat, UST_lnd, UST_ice, & +!$acc ZNT_wat, ZNT_lnd, ZNT_ice, & +!$acc QSFC_lnd, QSFC_wat, QSFC_ice, & +!$acc QFLX_lnd, QFLX_wat, QFLX_ice, & +!$acc HFLX_lnd, HFLX_wat, HFLX_ice, & +!$acc PSIX_wat, PSIX_lnd, PSIX_ice, & +!$acc PSIX10_wat, PSIX10_lnd, PSIX10_ice, & +!$acc PSIT2_lnd, PSIT2_wat, PSIT2_ice, & +!$acc PSIT_lnd, PSIT_wat, PSIT_ice, & +!$acc ch_lnd, ch_wat, ch_ice, & +!$acc cm_lnd, cm_wat, cm_ice, & +!$acc errmsg) + +!$acc exit data delete( flag_iter, dry, wet, icy, dx, & +!$acc MAVAIL, PBLH, PSFCPA, z0pert, ztpert, & +!$acc QV1D, U1D, V1D, U1D2, V1D2, T1D, P1D, & +!$acc rstoch1D, sigmaf, shdmax, vegtype, & +!$acc dz2w1d, dz8w1d, snowh_lnd, & +!$acc tskin_wat, tskin_lnd, tskin_ice, & +!$acc tsurf_wat, tsurf_lnd, tsurf_ice) + +!$acc exit data delete( ZA, ZA2, THV1D, TH1D, TC1D, TV1D, & +!$acc RHO1D, QVSH, PSIH2, PSIM10, PSIH10, WSPDI, & +!$acc GOVRTH, PSFC, THCON, & +!$acc zratio_lnd, zratio_ice, zratio_wat, & +!$acc TSK_lnd, TSK_ice, TSK_wat, & +!$acc THSK_lnd, THSK_ice, THSK_wat, & +!$acc THVSK_lnd, THVSK_ice, THVSK_wat, & +!$acc GZ1OZ0_lnd, GZ1OZ0_ice, GZ1OZ0_wat, & +!$acc GZ1OZt_lnd, GZ1OZt_ice, GZ1OZt_wat, & +!$acc GZ2OZ0_lnd, GZ2OZ0_ice, GZ2OZ0_wat, & +!$acc GZ2OZt_lnd, GZ2OZt_ice, GZ2OZt_wat, & +!$acc GZ10OZ0_lnd, GZ10OZ0_ice, GZ10OZ0_wat, & +!$acc GZ10OZt_lnd, GZ10OZt_ice, GZ10OZt_wat, & +!$acc ZNTstoch_lnd, ZNTstoch_ice, ZNTstoch_wat, & +!$acc ZT_lnd, ZT_ice, ZT_wat, & +!$acc ZQ_lnd, ZQ_ice, ZQ_wat, & +!$acc PSIQ_lnd, PSIQ_ice, PSIQ_wat, & +!$acc PSIQ2_lnd, PSIQ2_ice, PSIQ2_wat, & +!$acc QSFCMR_lnd, QSFCMR_ice, QSFCMR_wat ) + END SUBROUTINE SFCLAY1D_mynn !------------------------------------------------------------------- !>\ingroup mynn_sfc @@ -2272,6 +2550,7 @@ END SUBROUTINE SFCLAY1D_mynn SUBROUTINE zilitinkevich_1995(Z_0,Zt,Zq,restar,ustar,KARMAN,& & landsea,IZ0TLND2,spp_sfc,rstoch) + !$acc routine seq IMPLICIT NONE REAL(kind_phys), INTENT(IN) :: Z_0,restar,ustar,KARMAN,landsea INTEGER, OPTIONAL, INTENT(IN) :: IZ0TLND2 @@ -2341,6 +2620,7 @@ SUBROUTINE davis_etal_2008(Z_0,ustar) !This is an update version from Davis et al. 2008, which !corrects a small-bias in Z_0 (AHW real-time 2012). + !$acc routine seq IMPLICIT NONE REAL(kind_phys), INTENT(IN) :: ustar REAL(kind_phys), INTENT(OUT) :: Z_0 @@ -2368,7 +2648,7 @@ END SUBROUTINE davis_etal_2008 !>This formulation for roughness length was designed account for. !!wave steepness. SUBROUTINE Taylor_Yelland_2001(Z_0,ustar,wsp10) - + !$acc routine seq IMPLICIT NONE REAL(kind_phys), INTENT(IN) :: ustar,wsp10 REAL(kind_phys), INTENT(OUT) :: Z_0 @@ -2396,7 +2676,7 @@ END SUBROUTINE Taylor_Yelland_2001 !! The Charnock parameter CZC is varied from .011 to .018. !! between 10-m wsp = 10 and 18.. SUBROUTINE charnock_1955(Z_0,ustar,wsp10,visc,zu) - + !$acc routine seq IMPLICIT NONE REAL(kind_phys), INTENT(IN) :: ustar, visc, wsp10, zu REAL(kind_phys), INTENT(OUT) :: Z_0 @@ -2421,7 +2701,7 @@ END SUBROUTINE charnock_1955 !!The Charnock parameter CZC is varied from about .005 to .028 !!between 10-m wind speeds of 6 and 19 m/s. SUBROUTINE edson_etal_2013(Z_0,ustar,wsp10,visc,zu) - + !$acc routine seq IMPLICIT NONE REAL(kind_phys), INTENT(IN) :: ustar, visc, wsp10, zu REAL(kind_phys), INTENT(OUT) :: Z_0 @@ -2450,7 +2730,7 @@ END SUBROUTINE edson_etal_2013 !!data. The formula for land uses a constant ratio (Z_0/7.4) taken !!from Garratt (1992). SUBROUTINE garratt_1992(Zt,Zq,Z_0,Ren,landsea) - + !$acc routine seq IMPLICIT NONE REAL(kind_phys), INTENT(IN) :: Ren, Z_0,landsea REAL(kind_phys), INTENT(OUT) :: Zt,Zq @@ -2486,7 +2766,7 @@ END SUBROUTINE garratt_1992 !! !!This is for use over water only. SUBROUTINE fairall_etal_2003(Zt,Zq,Ren,ustar,visc,rstoch,spp_sfc) - + !$acc routine seq IMPLICIT NONE REAL(kind_phys), INTENT(IN) :: Ren,ustar,visc,rstoch INTEGER, INTENT(IN) :: spp_sfc @@ -2530,7 +2810,7 @@ END SUBROUTINE fairall_etal_2003 !! The actual reference is unknown. This was passed along by Jim Edson (personal communication). !! This is for use over water only, preferably open ocean. SUBROUTINE fairall_etal_2014(Zt,Zq,Ren,ustar,visc,rstoch,spp_sfc) - + !$acc routine seq IMPLICIT NONE REAL(kind_phys), INTENT(IN) :: Ren,ustar,visc,rstoch INTEGER, INTENT(IN) :: spp_sfc @@ -2578,6 +2858,7 @@ END SUBROUTINE fairall_etal_2014 !!This should only be used over land! SUBROUTINE Yang_2008(Z_0,Zt,Zq,ustar,tstar,qst,Ren,visc) + !$acc routine seq IMPLICIT NONE REAL(kind_phys), INTENT(IN) :: Z_0, Ren, ustar, tstar, qst, visc REAL(kind_phys) :: ht, &! roughness height at critical Reynolds number @@ -2613,6 +2894,7 @@ END SUBROUTINE Yang_2008 !>\ingroup mynn_sfc SUBROUTINE GFS_z0_lnd(z0max,shdmax,z1,vegtype,ivegsrc,z0pert) + !$acc routine seq REAL(kind_phys), INTENT(OUT) :: z0max REAL(kind_phys), INTENT(IN) :: shdmax,z1,z0pert INTEGER, INTENT(IN) :: vegtype,ivegsrc @@ -2673,6 +2955,7 @@ END SUBROUTINE GFS_z0_lnd !>\ingroup mynn_sfc SUBROUTINE GFS_zt_lnd(ztmax,z0max,sigmaf,ztpert,ustar_lnd) + !$acc routine seq REAL(kind_phys), INTENT(OUT) :: ztmax REAL(kind_phys), INTENT(IN) :: z0max,sigmaf,ztpert,ustar_lnd REAL(kind_phys) :: czilc, tem1, tem2 @@ -2701,6 +2984,7 @@ END SUBROUTINE GFS_zt_lnd !>\ingroup mynn_sfc SUBROUTINE GFS_z0_wat(z0rl_wat,ustar_wat,WSPD,z1,sfc_z0_type,redrag) + !$acc routine seq REAL(kind_phys), INTENT(OUT) :: z0rl_wat REAL(kind_phys), INTENT(INOUT):: ustar_wat REAL(kind_phys), INTENT(IN) :: wspd,z1 @@ -2753,11 +3037,16 @@ END SUBROUTINE GFS_z0_wat !-------------------------------------------------------------------- !>\ingroup mynn_sfc SUBROUTINE GFS_zt_wat(ztmax,z0rl_wat,restar,WSPD,z1,sfc_z0_type,errmsg,errflg) - + !$acc routine seq real(kind_phys), INTENT(OUT) :: ztmax real(kind_phys), INTENT(IN) :: wspd,z1,z0rl_wat,restar INTEGER, INTENT(IN) :: sfc_z0_type +#ifndef _OPENACC character(len=*), intent(out) :: errmsg +#else +! Necessary since OpenACC does not support assumed-size arrays + character(len=200), intent(out) :: errmsg +#endif integer, intent(out) :: errflg real(kind_phys) :: z0,z0max,wind10m,rat,ustar_wat real(kind_phys), PARAMETER :: charnock = 0.014, z0s_max=.317e-2 @@ -2798,6 +3087,7 @@ SUBROUTINE GFS_zt_wat(ztmax,z0rl_wat,restar,WSPD,z1,sfc_z0_type,errmsg,errflg) errflg = 1 errmsg = 'ERROR(GFS_zt_wat): sfc_z0_type not valid.' return + endif END SUBROUTINE GFS_zt_wat @@ -2807,6 +3097,7 @@ END SUBROUTINE GFS_zt_wat !! Weiguo Wang, 2019-0425 SUBROUTINE znot_m_v6(uref, znotm) + !$acc routine seq use machine , only : kind_phys IMPLICIT NONE ! Calculate areodynamical roughness over water with input 10-m wind @@ -2856,6 +3147,7 @@ END SUBROUTINE znot_m_v6 !! SUBROUTINE znot_t_v6(uref, znott) + !$acc routine seq IMPLICIT NONE !> Calculate scalar roughness over water with input 10-m wind !! For low-to-moderate winds, try to match the Ck-U10 relationship from COARE algorithm @@ -2922,6 +3214,7 @@ END SUBROUTINE znot_t_v6 !! SUBROUTINE znot_m_v7(uref, znotm) + !$acc routine seq IMPLICIT NONE !> Calculate areodynamical roughness over water with input 10-m wind !! For low-to-moderate winds, try to match the Cd-U10 relationship from COARE V3.5 (Edson et al. 2013) @@ -2971,6 +3264,7 @@ END SUBROUTINE znot_m_v7 !! SUBROUTINE znot_t_v7(uref, znott) + !$acc routine seq IMPLICIT NONE !> Calculate scalar roughness over water with input 10-m wind !! For low-to-moderate winds, try to match the Ck-U10 relationship from COARE algorithm @@ -3040,6 +3334,7 @@ END SUBROUTINE znot_t_v7 !! This should only be used over snow/ice! SUBROUTINE Andreas_2002(Z_0,bvisc,ustar,Zt,Zq) + !$acc routine seq IMPLICIT NONE REAL(kind_phys), INTENT(IN) :: Z_0, bvisc, ustar REAL(kind_phys), INTENT(OUT) :: Zt, Zq @@ -3313,6 +3608,7 @@ END SUBROUTINE PSI_CB2005 !! and Holtslag (1991) for stable conditions. SUBROUTINE Li_etal_2010(zL, Rib, zaz0, z0zt) + !$acc routine seq IMPLICIT NONE REAL(kind_phys), INTENT(OUT) :: zL REAL(kind_phys), INTENT(IN) :: Rib, zaz0, z0zt @@ -3471,6 +3767,7 @@ REAL(kind_phys) function zolri2(zol2,ri2,za,z0,zt,psi_opt) REAL(kind_phys) function zolrib(ri,za,z0,zt,logz0,logzt,zol1,psi_opt) + !$acc routine seq ! This iterative algorithm to compute z/L from bulk-Ri IMPLICIT NONE @@ -3480,7 +3777,7 @@ REAL(kind_phys) function zolrib(ri,za,z0,zt,logz0,logzt,zol1,psi_opt) REAL(kind_phys) :: zol20,zol3,zolt,zolold INTEGER :: n INTEGER, PARAMETER :: nmax = 20 - REAL(kind_phys), DIMENSION(nmax):: zLhux + !REAL(kind_phys), DIMENSION(nmax):: zLhux REAL(kind_phys) :: psit2,psix2 !print*,"+++++++INCOMING: z/L=",zol1," ri=",ri @@ -3522,7 +3819,7 @@ REAL(kind_phys) function zolrib(ri,za,z0,zt,logz0,logzt,zol1,psi_opt) endif !print*,"n=",n," psit2=",psit2," psix2=",psix2 zolrib=ri*psix2**2/psit2 - zLhux(n)=zolrib + !zLhux(n)=zolrib n=n+1 enddo @@ -3530,7 +3827,7 @@ REAL(kind_phys) function zolrib(ri,za,z0,zt,logz0,logzt,zol1,psi_opt) !print*,"iter FAIL, n=",n," Ri=",ri," z/L=",zolri !if convergence fails, use approximate values: CALL Li_etal_2010(zolrib, ri, za/z0, z0/zt) - zLhux(n)=zolrib + !zLhux(n)=zolrib !print*,"FAILED, n=",n," Ri=",ri," z0=",z0 !print*,"z/L=",zLhux(1:nmax) else @@ -3595,6 +3892,7 @@ END SUBROUTINE psi_init ! !>\ingroup mynn_sfc real(kind_phys) function psim_stable_full(zolf) + !$acc routine seq real(kind_phys) :: zolf !psim_stable_full=-6.1*log(zolf+(1+zolf**2.5)**(1./2.5)) @@ -3605,6 +3903,7 @@ real(kind_phys) function psim_stable_full(zolf) !>\ingroup mynn_sfc real(kind_phys) function psih_stable_full(zolf) + !$acc routine seq real(kind_phys) :: zolf !psih_stable_full=-5.3*log(zolf+(1+zolf**1.1)**(1./1.1)) @@ -3615,6 +3914,7 @@ real(kind_phys) function psih_stable_full(zolf) !>\ingroup mynn_sfc real(kind_phys) function psim_unstable_full(zolf) + !$acc routine seq real(kind_phys) :: zolf,x,ym,psimc,psimk x=(1.-16.*zolf)**.25 @@ -3633,6 +3933,7 @@ real(kind_phys) function psim_unstable_full(zolf) !>\ingroup mynn_sfc real(kind_phys) function psih_unstable_full(zolf) + !$acc routine seq real(kind_phys) :: zolf,y,yh,psihc,psihk y=(1.-16.*zolf)**.5 @@ -3654,6 +3955,7 @@ real(kind_phys) function psih_unstable_full(zolf) !>\ingroup mynn_sfc !! REAL(kind_phys) function psim_stable_full_gfs(zolf) + !$acc routine seq REAL(kind_phys) :: zolf REAL(kind_phys), PARAMETER :: alpha4 = 20. REAL(kind_phys) :: aa @@ -3667,6 +3969,7 @@ REAL(kind_phys) function psim_stable_full_gfs(zolf) !>\ingroup mynn_sfc !! real(kind_phys) function psih_stable_full_gfs(zolf) + !$acc routine seq real(kind_phys) :: zolf real(kind_phys), PARAMETER :: alpha4 = 20. real(kind_phys) :: bb @@ -3680,6 +3983,7 @@ real(kind_phys) function psih_stable_full_gfs(zolf) !>\ingroup mynn_sfc !! real(kind_phys) function psim_unstable_full_gfs(zolf) + !$acc routine seq real(kind_phys) :: zolf real(kind_phys) :: hl1,tem1 real(kind_phys), PARAMETER :: a0=-3.975, a1=12.32, & @@ -3700,6 +4004,7 @@ real(kind_phys) function psim_unstable_full_gfs(zolf) !>\ingroup mynn_sfc !! real(kind_phys) function psih_unstable_full_gfs(zolf) + !$acc routine seq real(kind_phys) :: zolf real(kind_phys) :: hl1,tem1 real(kind_phys), PARAMETER :: a0p=-7.941, a1p=24.75, & @@ -3720,6 +4025,7 @@ real(kind_phys) function psih_unstable_full_gfs(zolf) !>\ingroup mynn_sfc !! look-up table functions - or, if beyond -10 < z/L < 10, recalculate real(kind_phys) function psim_stable(zolf,psi_opt) + !$acc routine seq integer :: nzol,psi_opt real(kind_phys) :: rzol,zolf @@ -3740,6 +4046,7 @@ real(kind_phys) function psim_stable(zolf,psi_opt) !>\ingroup mynn_sfc real(kind_phys) function psih_stable(zolf,psi_opt) + !$acc routine seq integer :: nzol,psi_opt real(kind_phys) :: rzol,zolf @@ -3760,6 +4067,7 @@ real(kind_phys) function psih_stable(zolf,psi_opt) !>\ingroup mynn_sfc real(kind_phys) function psim_unstable(zolf,psi_opt) + !$acc routine seq integer :: nzol,psi_opt real(kind_phys) :: rzol,zolf @@ -3780,6 +4088,7 @@ real(kind_phys) function psim_unstable(zolf,psi_opt) !>\ingroup mynn_sfc real(kind_phys) function psih_unstable(zolf,psi_opt) + !$acc routine seq integer :: nzol,psi_opt real(kind_phys) :: rzol,zolf diff --git a/physics/mynnsfc_wrapper.F90 b/physics/mynnsfc_wrapper.F90 index 1a970c9f4..3c033e65e 100644 --- a/physics/mynnsfc_wrapper.F90 +++ b/physics/mynnsfc_wrapper.F90 @@ -191,6 +191,16 @@ SUBROUTINE mynnsfc_wrapper_run( & & IMS,IME,JMS,JME,KMS,KME, & & ITS,ITE,JTS,JTE,KTS,KTE +!$acc enter data create(hfx, znt, psim, psih, chs, & +!$acc mavail, xland, GZ1OZ0, cpm, qgh, & +!$acc qfx, snowh_wat) + +!$acc enter data create(dz, th, qv) + +!$acc enter data copyin(rmol, phii, t3d, exner, qvsh, slmsk, xland) + +!$acc enter data copyin(dry, wet, icy, znt_lnd, znt_wat, znt_ice, qsfc_lnd, qsfc_ice, qsfc_lnd_ruc, qsfc_ice_ruc) + ! Initialize CCPP error handling variables errmsg = '' errflg = 0 @@ -203,6 +213,7 @@ SUBROUTINE mynnsfc_wrapper_run( & ! write(0,*)"iter=",iter ! endif +!$acc kernels ! prep MYNN-only variables dz(:,:) = 0 th(:,:) = 0 @@ -210,6 +221,9 @@ SUBROUTINE mynnsfc_wrapper_run( & hfx(:) = 0 qfx(:) = 0 rmol(:) = 0 +!$acc end kernels + +!$acc parallel loop collapse(2) present(dz, phii, th, t3d, exner, qv, qvsh) do k=1,2 !levs do i=1,im dz(i,k)=(phii(i,k+1) - phii(i,k))*g_inv @@ -219,6 +233,7 @@ SUBROUTINE mynnsfc_wrapper_run( & enddo enddo +!$acc parallel loop present(slmsk, xland, qgh, mavail, cpm, snowh_wat) do i=1,im if (slmsk(i)==1. .or. slmsk(i)==2.)then !sea/land/ice mask (=0/1/2) in FV3 xland(i)=1.0 !but land/water = (1/2) in SFCLAY_mynn @@ -235,6 +250,7 @@ SUBROUTINE mynnsfc_wrapper_run( & snowh_wat(i) = 0.0 enddo +!$acc kernels ! cm -> m where (dry) znt_lnd=znt_lnd*0.01 where (wet) znt_wat=znt_wat*0.01 @@ -245,6 +261,7 @@ SUBROUTINE mynnsfc_wrapper_run( & where (dry) qsfc_lnd = qsfc_lnd_ruc/(1.+qsfc_lnd_ruc) ! spec. hum where (icy) qsfc_ice = qsfc_ice_ruc/(1.+qsfc_ice_ruc) ! spec. hum. end if +!$acc end kernels ! if (lprnt) then ! write(0,*)"CALLING SFCLAY_mynn; input:" @@ -274,6 +291,8 @@ SUBROUTINE mynnsfc_wrapper_run( & ! write(0,*)"PBLH=",pblh(1)," xland=",xland(1) ! endif +!$acc exit data delete(qsfc_lnd_ruc, qsfc_ice_ruc) +!$acc exit data delete(phii, qvsh, slmsk) CALL SFCLAY_mynn( & u3d=u,v3d=v,t3d=t3d,qv3d=qv,p3d=prsl,dz8w=dz, & @@ -318,6 +337,13 @@ SUBROUTINE mynnsfc_wrapper_run( & errmsg=errmsg, errflg=errflg ) if (errflg/=0) return +!$acc exit data delete(hfx, znt, psim, psih, chs, & +!$acc mavail, xland, GZ1OZ0, cpm, qgh, & +!$acc qfx, snowh_wat, t3d, exner) +!$acc exit data delete(dz, th, qv) +!$acc exit data copyout(rmol) +!$acc exit data copyout(qsfc_lnd, qsfc_ice) + !! POST MYNN SURFACE LAYER (INTERSTITIAL) WORK: !do i = 1, im ! !* Taken from sfc_nst.f @@ -336,10 +362,15 @@ SUBROUTINE mynnsfc_wrapper_run( & ! znt_ice(i)=znt_ice(i)*100. !enddo +!$acc kernels ! m -> cm where (dry) znt_lnd=znt_lnd*100. where (wet) znt_wat=znt_wat*100. where (icy) znt_ice=znt_ice*100. +!$acc end kernels + +!$acc exit data delete(dry, wet, icy) +!$acc exit data copyout(znt_lnd, znt_wat, znt_ice) ! if (lprnt) then ! write(0,*) From 62298180c7269038931db60549b4ed1a4e6a2b9e Mon Sep 17 00:00:00 2001 From: Jili Dong Date: Mon, 21 Aug 2023 19:19:51 +0000 Subject: [PATCH 321/380] add SPP support for G-F deep convection --- physics/cu_gf_deep.F90 | 7 +++---- physics/cu_gf_driver.F90 | 26 ++++++++++++++++++++------ physics/cu_gf_driver.meta | 15 +++++++++++++++ physics/module_mp_thompson.F90 | 2 +- physics/mp_thompson.F90 | 2 +- physics/mp_thompson.meta | 2 +- 6 files changed, 41 insertions(+), 13 deletions(-) diff --git a/physics/cu_gf_deep.F90 b/physics/cu_gf_deep.F90 index 67dd9bd3f..a4253906c 100644 --- a/physics/cu_gf_deep.F90 +++ b/physics/cu_gf_deep.F90 @@ -4707,11 +4707,10 @@ subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,k if(draft == 1) then lev_start=min(.9,.1+csum*.013) kb_adj=max(kb,2) - tunning=max(p(kklev+1),.5*(p(kpbli)+p(kt))) - tunning=p(kklev) -! tunning=p(kklev+1) !p(kpbli+1) !p(kklev) !p(kt)+(p(kpbli)-p(kt))*lev_start -! tunning=.5*(p(kb_adj)+p(kt)) !p(kpbli+1) !p(kklev) !p(kt)+(p(kpbli)-p(kt))*lev_start +! trash is the depth of the cloud trash=-p(kt)+p(kb_adj) + tunning=p(kklev) + if(rand_vmas.ne.0.) tunning=p(kklev-1)+.1*rand_vmas*trash beta_deep=1.3 +(1.-trash/1200.) tunning =min(0.95, (tunning-p(kb_adj))/(p(kt)-p(kb_adj))) !=.6 tunning =max(0.02, tunning) diff --git a/physics/cu_gf_driver.F90 b/physics/cu_gf_driver.F90 index f82569b99..5e42fb777 100644 --- a/physics/cu_gf_driver.F90 +++ b/physics/cu_gf_driver.F90 @@ -67,6 +67,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& fhour,fh_dfi_radar,ix_dfi_radar,num_dfi_radar,cap_suppress, & dfi_radar_max_intervals,ldiag3d,qci_conv,do_cap_suppress, & maxupmf,maxMF,do_mynnedmf,ichoice_in,ichoicem_in,ichoice_s_in, & + spp_cu_deep,spp_wts_cu_deep, & errmsg,errflg) !------------------------------------------------------------- implicit none @@ -80,6 +81,10 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& integer :: ichoice=0 ! 0 2 5 13 8 integer :: ichoicem=13 ! 0 2 5 13 integer :: ichoice_s=3 ! 0 1 2 3 + integer, intent(in) :: spp_cu_deep ! flag for using SPP perturbations + real(kind_phys), dimension(:,:), intent(in) :: & + & spp_wts_cu_deep + real(kind=kind_phys) :: spp_wts_cu_deep_tmp logical, intent(in) :: do_cap_suppress real(kind=kind_phys), parameter :: aodc0=0.14 @@ -313,9 +318,18 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ! these should be coming in from outside ! ! cactiv(:) = 0 - rand_mom(:) = 0. - rand_vmas(:) = 0. - rand_clos(:,:) = 0. + if (spp_cu_deep == 0) then + rand_mom(:) = 0. + rand_vmas(:) = 0. + rand_clos(:,:) = 0. + else + do i=1,im + spp_wts_cu_deep_tmp=min(max(-1.0, spp_wts_cu_deep(i,1)),1.0) + rand_mom(i) = spp_wts_cu_deep_tmp + rand_vmas(i) = spp_wts_cu_deep_tmp + rand_clos(i,:) = spp_wts_cu_deep_tmp + end do + end if !$acc end kernels ! its=1 @@ -630,7 +644,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& enddo !$acc end kernels if (dx(its)<6500.) then - ichoice=10 +! ichoice=10 imid_gf=0 endif ! @@ -734,7 +748,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,rand_mom & ! for stochastics mom, if temporal and spatial patterns exist ,rand_vmas & ! for stochastics vertmass, if temporal and spatial patterns exist ,rand_clos & ! for stochastics closures, if temporal and spatial patterns exist - ,0 & ! flag to what you want perturbed + ,spp_cu_deep & ! flag to what you want perturbed ! 1 = momentum transport ! 2 = normalized vertical mass flux profile ! 3 = closures @@ -816,7 +830,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,rand_mom & ! for stochastics mom, if temporal and spatial patterns exist ,rand_vmas & ! for stochastics vertmass, if temporal and spatial patterns exist ,rand_clos & ! for stochastics closures, if temporal and spatial patterns exist - ,0 & ! flag to what you want perturbed + ,spp_cu_deep & ! flag to what you want perturbed ! 1 = momentum transport ! 2 = normalized vertical mass flux profile ! 3 = closures diff --git a/physics/cu_gf_driver.meta b/physics/cu_gf_driver.meta index 8b1a46e2d..08e9de201 100644 --- a/physics/cu_gf_driver.meta +++ b/physics/cu_gf_driver.meta @@ -597,6 +597,21 @@ dimensions = () type = integer intent = in +[spp_wts_cu_deep] + standard_name = spp_weights_for_cu_deep_scheme + long_name = spp weights for cu deep scheme + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[spp_cu_deep] + standard_name = control_for_deep_convection_spp_perturbations + long_name = control for deep convection spp perturbations + units = count + dimensions = () + type = integer + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index 4d823d2f4..ca913c6e3 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -1046,7 +1046,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & INTEGER, INTENT(IN) :: rand_perturb_on, kme_stoch, n_var_spp REAL, DIMENSION(:,:), INTENT(IN) :: rand_pert REAL, DIMENSION(:), INTENT(IN) :: spp_prt_list, spp_stddev_cutoff - CHARACTER(len=3), DIMENSION(:), INTENT(IN) :: spp_var_list + CHARACTER(len=10), DIMENSION(:), INTENT(IN) :: spp_var_list INTEGER, INTENT(IN):: has_reqc, has_reqi, has_reqs #if ( WRF_CHEM == 1 ) REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & diff --git a/physics/mp_thompson.F90 b/physics/mp_thompson.F90 index 6a95a706c..c456e87cd 100644 --- a/physics/mp_thompson.F90 +++ b/physics/mp_thompson.F90 @@ -409,7 +409,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & integer, intent(in) :: n_var_spp real(kind_phys), intent(in) :: spp_wts_mp(:,:) real(kind_phys), intent(in) :: spp_prt_list(:) - character(len=3), intent(in) :: spp_var_list(:) + character(len=10), intent(in) :: spp_var_list(:) real(kind_phys), intent(in) :: spp_stddev_cutoff(:) logical, intent (in) :: cplchm diff --git a/physics/mp_thompson.meta b/physics/mp_thompson.meta index 691698281..5918e4dd9 100644 --- a/physics/mp_thompson.meta +++ b/physics/mp_thompson.meta @@ -725,7 +725,7 @@ units = none dimensions = (number_of_perturbed_spp_schemes) type = character - kind = len=3 + kind = len=10 intent = in [cplchm] standard_name = flag_for_chemistry_coupling From 96f60024a50b5c9b1701b83cd0fa3ece5c94ba21 Mon Sep 17 00:00:00 2001 From: Jili Dong Date: Wed, 23 Aug 2023 15:36:30 +0000 Subject: [PATCH 322/380] minor change on explicitly delcaring data type --- physics/cu_gf_driver.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/cu_gf_driver.F90 b/physics/cu_gf_driver.F90 index 5e42fb777..3b700cc5a 100644 --- a/physics/cu_gf_driver.F90 +++ b/physics/cu_gf_driver.F90 @@ -324,7 +324,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& rand_clos(:,:) = 0. else do i=1,im - spp_wts_cu_deep_tmp=min(max(-1.0, spp_wts_cu_deep(i,1)),1.0) + spp_wts_cu_deep_tmp=min(max(-1.0_kind_phys, spp_wts_cu_deep(i,1)),1.0_kind_phys) rand_mom(i) = spp_wts_cu_deep_tmp rand_vmas(i) = spp_wts_cu_deep_tmp rand_clos(i,:) = spp_wts_cu_deep_tmp From a03c68443ccc2d3debc0b23b23843dfd027d6d7b Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Thu, 24 Aug 2023 14:46:44 +0000 Subject: [PATCH 323/380] Change 1D GS arrays from fixed size to allocated --- physics/module_mp_nssl_2mom.F90 | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/physics/module_mp_nssl_2mom.F90 b/physics/module_mp_nssl_2mom.F90 index cac1218a9..20239833a 100644 --- a/physics/module_mp_nssl_2mom.F90 +++ b/physics/module_mp_nssl_2mom.F90 @@ -2326,7 +2326,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw real, dimension(its:ite, 1, na) :: xfall real, dimension(kts:kte, nproc) :: thproclocal integer, parameter :: nor = 0, ng = 0 - integer :: nx,ny,nz + integer :: nx,ny,nz,ngs integer ix,jy,kz,i,j,k,il,n integer :: infdo real :: ssival, ssifac, t8s, t9s, qvapor @@ -2915,6 +2915,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! ENDIF ! .false. + + ngs = 128 + IF ( isedonly /= 1 ) THEN ! call nssl_2mom_gs: main gather-scatter routine to calculate microphysics @@ -2939,7 +2942,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw & timevtcalc,axtra2d, makediag & & ,has_wetscav, rainprod2d, evapprod2d & & ,errmsg,errflg & - & ,elec2,its,ids,ide,jds,jde & + & ,elec2,its,ids,ide,jds,jde,ngs & & ) @@ -2964,7 +2967,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw & ,an,dn1,t77 & & ,pn,wn & & ,axtra2d, makediag & - & ,ssat,t00,t77,flag_qndrop) + & ,ssat,t00,t77,flag_qndrop,ngs) ! recalculate dn1 after temperature changes DO kz = kts,kte @@ -8999,7 +9002,7 @@ SUBROUTINE NUCOND & & ,an,dn,p2 & & ,pn,w & & ,axtra,io_flag & - & ,ssfilt,t00,t77,flag_qndrop & + & ,ssfilt,t00,t77,flag_qndrop,ngs & & ) @@ -9064,7 +9067,7 @@ SUBROUTINE NUCOND & real, parameter :: cwmas20 = 1000.*0.523599*(2.*20.e-6)**3 ! mass of 20-micron radius droplet, for sat. adj. integer nxmpb,nzmpb,nxz integer mgs,ngs,numgs,inumgs - parameter (ngs=500) +! parameter (ngs=1 ) integer ngscnt,igs(ngs),kgs(ngs) integer kgsp(ngs),kgsm(ngs) integer nsvcnt @@ -9095,7 +9098,7 @@ SUBROUTINE NUCOND & integer ifilt ! =1 to filter ssat, =0 to set ssfilt=ssat parameter ( ifilt = 0 ) real temp1,temp2 ! ,ssold - real :: ssmax(ngs) = 0.0 ! maximum SS experienced by a parcel + real :: ssmax(ngs) ! maximum SS experienced by a parcel real ssmx real dnnet,dqnet ! real cnu,rnu,snu,cinu @@ -11598,7 +11601,7 @@ subroutine nssl_2mom_gs & & ,timevtcalc,axtra,io_flag & & , has_wetscav,rainprod2d, evapprod2d & & ,errmsg,errflg & - & ,elec,its,ids,ide,jds,jde & + & ,elec,its,ids,ide,jds,jde,ngs & & ) @@ -11830,7 +11833,7 @@ subroutine nssl_2mom_gs & ! integer nxmpb,nzmpb,nxz integer jgs,mgs,ngs,numgs - parameter (ngs=500) !500) +! parameter (ngs=1 ) !500) integer, parameter :: ngsz = 500 integer ntt parameter (ntt=300) From 95e9ff2268ad03f3004da886634812c5f7bdf32c Mon Sep 17 00:00:00 2001 From: "Timothy S. Sliwinski" Date: Thu, 24 Aug 2023 16:10:55 +0000 Subject: [PATCH 324/380] Reworking how errmsg is treated in device code to remove some preprocessor variable substitutions through the use of new local variables. The changes in this commit affect 3 main areas of module_sf_mynn.F90: 1.) Subroutine SFCLAY_mynn 2.) Subroutine SFCLAY1D_mynn 3.) Subroutine GFS_zt_wat Each of these areas are described in more detail below. 1.) SFCLAY_mynn In the SFCLAY_mynn subroutine, it was possible to remove all #ifdef substitutions of errmsg(len=*) for errmsg(len=200) because errmsg is not used in any code regions of this subroutine that may be run on an accelerator device. Since this is the case, errmsg(len=*) is perfectly acceptable, and can be left alone. The OpenACC data statements within the subroutine were also updated to remove references to errmsg as well since, again, it was not necessary to have errmsg on the device for this subroutine. 2.) SFCLAY1D_mynn - Creation of device_errmsg and device_errflg and proper syncing with errmsg and errflg In the SFCLAY1D_mynn subroutine, it was also possible to remove all #ifdef substitutions by instead creating a new local variable called device_errmsg that is a copy of errmsg but with a fixed size of 512 such that it is acceptable for use on the device. This is necessary because at certain points in the subroutine, loops that are good to be offloaded to the device set errmsg under certain conditions. Since these areas cannot be isolated from the parent loop without a major rework of the loop, we must preserve a way for errmsg to be set on the device. Since device_errmsg is a fixed size, we can do that. However, this complicates the code a bit for error handling purposes as we now have errmsg and device_errmsg which must be synced properly to ensure error messages are returned to CCPP as expected. Therefore, we must keep track of when device_errmsg is set so we can know to sync device_errmsg with errmsg. This is done by making a new local variable called device_errflg to be device_errmsg's complement on the device as errflg is errmsg's complement on the host. When device_errflg is set to a nonzero integer, we then know that device_errmsg must be synced with errmsg. This is simple to do at the end of the subroutine after the device_errmsg on the device is copyout-ed by OpenACC, and a new IF-block has been added for this general case. - Special case of mid-loop return (line 1417), and the creation of device_special_errflg and device_special_errmsg However, there is a special case we must handle a bit differently. In the mid-loop return statement near line 1417, we also must perform this sync to ensure the proper errmsg is returned in the event this return is needed. Therefore, a similar IF-block has been created within the corresponding #ifdef near line 2027 to ensure errmsg has the proper value before the subroutine returns. However, since this block is in the middle of the entire code and only executed on the host, we must first perform an OpenACC sync operation to make sure the device_errmsg and the device_errflg on the host matches the device_errmsg and device_errflg on the host, otherwise the incorrect values could lead to the return statement not executing as expected. This special case seems simple, but an extra trap lay exposed. If device_errmsg and device_errflg is set on the device at any point now before this IF-block, then the return statement we moved out of the loop will now be executed for *ANY* error message, whether that was the intended course or not. Therefore, we need to ensure this special case is only triggered for this specific case. Unfortunately, there appears no other way than to create two additional variables (device_special_errmsg and device_special_errflg) to isolate this case from all other error cases. With these installed in place of just device_errmsg and device_errflg, this special return case is now properly handled. - Complete Ifdef/Ifndef removal not possible Overall, due to the nature of this special case, we have no choice but to leave the #ifdef and #ifndef preprocessor statements in place as they are the only things capable of moving this return statement out of the loop without additional invasive changes to how the code operates. 3.) GFS_zt_wat In the GFS_zt_wat subroutine, since this subroutine is called on the device from within the main I-loop of SFCLAY1D_mynn, we have no choice but to change all errmsg and errflg usage to device_errmsg or device_errflg, otherwise this subroutine and the entire parent loop could not be run on the device. Therefore, all errmsg and errflg lines have been commented out and new, comparable lines using device_errmsg and device_errflg added in their place. Additionally, the subroutine call variable list was updated. --- physics/module_sf_mynn.F90 | 99 ++++++++++++++++++++++++++------------ 1 file changed, 67 insertions(+), 32 deletions(-) diff --git a/physics/module_sf_mynn.F90 b/physics/module_sf_mynn.F90 index 399b1ee83..dd181c99c 100644 --- a/physics/module_sf_mynn.F90 +++ b/physics/module_sf_mynn.F90 @@ -345,12 +345,7 @@ SUBROUTINE SFCLAY_mynn( & & qsfc_wat, qsfc_lnd, qsfc_ice ! CCPP error handling -#ifndef _OPENACC character(len=*), intent(inout) :: errmsg -#else -!Necessary since OpenACC does not support assumed-size arrays - character(len=200), intent(inout) :: errmsg -#endif integer, intent(inout) :: errflg !ADDITIONAL OUTPUT @@ -378,7 +373,7 @@ SUBROUTINE SFCLAY_mynn( & errmsg = '' !$acc enter data copyin( dz8w,U3D,V3D,QV3D,QC3D,P3D,T3D, & -!$acc pattern_spp_sfc, errmsg) +!$acc pattern_spp_sfc) !$acc enter data copyin( UST_WAT(:), UST_LND(:), UST_ICE(:), & !$acc MOL(:), QFLX(:), HFLX(:), & @@ -504,7 +499,7 @@ SUBROUTINE SFCLAY_mynn( & !$acc exit data copyout( UST_WAT(:), UST_LND(:), UST_ICE(:), & !$acc MOL(:), QFLX(:), HFLX(:), & !$acc QSFC(:), QSFC_WAT(:), QSFC_LND(:), & -!$acc QSFC_ICE(:), errmsg) +!$acc QSFC_ICE(:)) !$acc exit data delete( dz8w1d(:), dz2w1d(:), U1D(:), & !$acc V1D(:), U1D2(:), V1D2(:), & @@ -666,14 +661,25 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !JOE-end ! CCPP error handling -#ifndef _OPENACC character(len=*), intent(inout) :: errmsg -#else -! Necessary since OpenACC does not support assumed-size arrays - character(len=200), intent(inout) :: errmsg -#endif integer, intent(inout) :: errflg +! Local fixed-size errmsg character array for error messages on accelerator +! devices distinct from the host (e.g. GPUs). Necessary since OpenACC does +! not support assumed-size (len=*) arrays like errmsg. Additional +! device_errflg integer to denote when device_errmsg needs to be synced +! with errmsg. + character(len=512) :: device_errmsg + integer :: device_errflg + +! Special versions of the fixed-size errmsg character array for error messages +! on the device and it's errflag counterpart. These are necessary to ensure +! the return statements at lines 1417 and 2030 are executed only for this +! special case, and not any and all error messages set on the device. + character(len=512) :: device_special_errmsg + integer :: device_special_errflg + + !---------------------------------------------------------------- ! LOCAL VARS !---------------------------------------------------------------- @@ -723,6 +729,10 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ! Initialize error-handling errflg = 0 errmsg = '' + device_errflg = errflg + device_errmsg = errmsg + device_special_errflg = errflg + device_special_errmsg = errmsg !------------------------------------------------------------------- !$acc update device(psim_stab, psim_unstab, psih_stab, psih_unstab) @@ -770,7 +780,9 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !$acc PSIT_lnd, PSIT_wat, PSIT_ice, & !$acc ch_lnd, ch_wat, ch_ice, & !$acc cm_lnd, cm_wat, cm_ice, & -!$acc snowh_lnd, errmsg) +!$acc snowh_lnd, & +!$acc device_errmsg, device_errflg, & +!$acc device_special_errmsg, device_special_errflg) !$acc parallel loop present(PSFCPA, PSFC, QSFC, T1D, flag_iter, & !$acc QSFC_wat, QSFCMR_wat, wet, TSK_wat, tskin_wat, & @@ -1198,7 +1210,9 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !-------------------------------------------------------------------- !-------------------------------------------------------------------- -!$acc parallel loop present(flag_iter, errmsg, & +!$acc parallel loop present(flag_iter, & +!$acc device_errmsg, device_errflg, & +!$acc device_special_errmsg, device_special_errflg, & !$acc wet, dry, icy, & !$acc ZT_wat, ZT_lnd, ZT_ice, & !$acc ZNT_wat, ZNT_lnd, ZNT_ice, & @@ -1330,7 +1344,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ENDIF ELSEIF ( ISFTCFLX .EQ. 4 ) THEN !GFS zt formulation - CALL GFS_zt_wat(ZT_wat(i),ZNTstoch_wat(i),restar,WSPD(i),ZA(i),sfc_z0_type,errmsg,errflg) + CALL GFS_zt_wat(ZT_wat(i),ZNTstoch_wat(i),restar,WSPD(i),ZA(i),sfc_z0_type,device_errmsg,device_errflg) ZQ_wat(i)=ZT_wat(i) ENDIF ELSE @@ -1392,10 +1406,14 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ELSEIF ( IZ0TLND .EQ. 2 ) THEN ! DH note - at this point, qstar is either not initialized ! or initialized to zero, but certainly not set correctly - errmsg = 'Logic error: qstar is not set correctly when calling Yang_2008' - errflg = 1 + device_special_errmsg = 'Logic error: qstar is not set correctly when calling Yang_2008' + device_special_errflg = 1 #ifndef _OPENACC ! Necessary since OpenACC does not support branching in parallel code +! Must sync errmsg and errflg with device_errmsg and device_errflg, respectively +! so that proper error message and error flag codes are returned. + errmsg = device_special_errmsg + errflg = device_special_errflg return #endif CALL Yang_2008(ZNTSTOCH_lnd(i),ZT_lnd(i),ZQ_lnd(i),UST_lnd(i),MOL(I),& @@ -2001,8 +2019,14 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ENDDO ! end i-loop #ifdef _OPENACC - ! Necessary since OpenACC does not support branching in parallel code - IF (errflg == 1) THEN +! Necessary since OpenACC does not support branching in parallel code. +! Must sync host errflg, errmsg to determine if return must be triggered +! and correct error message and error flag code returned. +! This code is being executed on the HOST side only, pulling data from DEVICE. +!$acc exit data copyout(device_special_errflg, device_special_errmsg) + IF (device_special_errflg /= 0) THEN + errflg = device_special_errflg + errmsg = device_special_errmsg return ENDIF #endif @@ -2506,7 +2530,13 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !$acc PSIT_lnd, PSIT_wat, PSIT_ice, & !$acc ch_lnd, ch_wat, ch_ice, & !$acc cm_lnd, cm_wat, cm_ice, & -!$acc errmsg) +!$acc device_errmsg, device_errflg) + +! Final sync of device and host error flags and messages +IF (device_errflg /= 0) THEN + errflg = device_errflg + errmsg = device_errmsg +ENDIF !$acc exit data delete( flag_iter, dry, wet, icy, dx, & !$acc MAVAIL, PBLH, PSFCPA, z0pert, ztpert, & @@ -3036,24 +3066,27 @@ SUBROUTINE GFS_z0_wat(z0rl_wat,ustar_wat,WSPD,z1,sfc_z0_type,redrag) END SUBROUTINE GFS_z0_wat !-------------------------------------------------------------------- !>\ingroup mynn_sfc - SUBROUTINE GFS_zt_wat(ztmax,z0rl_wat,restar,WSPD,z1,sfc_z0_type,errmsg,errflg) + SUBROUTINE GFS_zt_wat(ztmax,z0rl_wat,restar,WSPD,z1,sfc_z0_type,device_errmsg,device_errflg) !$acc routine seq real(kind_phys), INTENT(OUT) :: ztmax real(kind_phys), INTENT(IN) :: wspd,z1,z0rl_wat,restar INTEGER, INTENT(IN) :: sfc_z0_type -#ifndef _OPENACC - character(len=*), intent(out) :: errmsg -#else -! Necessary since OpenACC does not support assumed-size arrays - character(len=200), intent(out) :: errmsg -#endif - integer, intent(out) :: errflg + +! Using device_errmsg and device_errflg rather than the CCPP errmsg and errflg +! so that this subroutine can be run on an accelerator device with OpenACC. +! character(len=*), intent(out) :: errmsg +! integer, intent(out) :: errflg + character(len=512), intent(out) :: device_errmsg + integer, intent(out) :: device_errflg + real(kind_phys) :: z0,z0max,wind10m,rat,ustar_wat real(kind_phys), PARAMETER :: charnock = 0.014, z0s_max=.317e-2 ! Initialize error-handling - errflg = 0 - errmsg = '' +! errflg = 0 +! errmsg = '' + device_errflg = 0 + device_errmsg = '' ! z0 = 0.01 * z0rl_wat !Already converted to meters in the wrapper @@ -3084,8 +3117,10 @@ SUBROUTINE GFS_zt_wat(ztmax,z0rl_wat,restar,WSPD,z1,sfc_z0_type,errmsg,errflg) call znot_t_v7(wind10m, ztmax) ! 10-m wind,m/s, ztmax(m) else if (sfc_z0_type > 0) then write(0,*)'no option for sfc_z0_type=',sfc_z0_type - errflg = 1 - errmsg = 'ERROR(GFS_zt_wat): sfc_z0_type not valid.' +! errflg = 1 +! errmsg = 'ERROR(GFS_zt_wat): sfc_z0_type not valid.' + device_errflg = 1 + device_errmsg = 'ERROR(GFS_zt_wat): sfc_z0_type not valid.' return endif From 36a313e91bd7089a3069a72d1326d200e4bbcde0 Mon Sep 17 00:00:00 2001 From: "Timothy S. Sliwinski" Date: Mon, 28 Aug 2023 21:11:38 +0000 Subject: [PATCH 325/380] Removing preprocessor directives to re-enable print statements on GPU for debug and other conditions. Original problem: ----------------- Following feedback that debug information was still desirable for OpenACC device- executed code where possible, this change removes all preprocessor directives which were guarding against the compilation of statements which wrote to standard output. These directives were originally used because debug statements and other standard output had the potential to greatly reduce performance because of the need to copy over certain variables from the host to the device just for debug output purposes. Additionally, when statements were located within parallel-execution regions, the output was not guaranteed to be presented in any specific order and the additional IF-branches in the code also would have reduced performance as branching is not efficient when on SIMD architectures. Resolutions: ------------ However, with a bit of extra work, a few of these issues are alleviated to allow output to work again as requested. First, on the data optimization side of the problem, the impact of pulling in variables just for debugging was minimized by ensuring the data was pulled in and resident on the GPU for the entire subroutine execution. While this increases the memory footprint on the device which may have very limited memory, it reduces the data transfer related performance hit. Next, in the cases where debug output was not within parallel regions but still needing to be executed on the GPU to show the proper values at that state of the overall program execution, OpenACC serial regions were used. These allow the data to not have to be transferred off the GPU mid-execution of the program just to be shown as debug output and also partially solve the problem of out-of-order output. Since debug regions are guarded by IF blocks, these serial regions do not significantly impact performance when debug output is turned off (debug_code=0). However, slowdown is significant for any other debug-levels which should be acceptable for debugging situations. Performance Changes: -------------------- Overall, these changes accomplish the goal of re-enabling debugging output, but not completely without a cost. Overall runtime was slightly impacted on the GPU when tested with 150k and 750k vertical columns (the value of ite used in the i-loops) and debugging turned off (debug_code=0). For 150k columns, the GPU decreased in speed from the original baseline of 22ms to 30ms. For 750k columns, the GPU decreased in speed from the original baseline of 31ms to 70ms. The impact is greater for the larger number of columns due to the impact of the number of times the mid-loop IF branches are evaluated on the GPU. While these are slight declines in performance, these are still significant speedups over the CPU-only tests (8.7x and 18.7x speedups for 150k and 750k, respectively). Compilation Time Changes: ------------------------- One additional noted observation regarding performance is compilation time. When all debug output is disabled (debug_code=0), compilation time is approximately 90 seconds with the additional serial blocks, IF-branches, and so forth as each of these require more work from the OpenACC compiler to generate code for the GPU. This problem is compounded when the debug_code option is increase to either 1 (some debug output) or 2 (full debug output). At a value of 1, compilation time jumps up to approximately 12.5 minutes on the Hera GPU nodes. At a value of 2, compilation time increases further to approximately 18.5 minutes on the same GPU nodes. The explanation for this is the need for the OpenACC compiler to enable greater amounts of serial and branching code that (again) are less optimal on the GPU and so the compiler must do more work to try to optimize them as best it can. --- physics/module_sf_mynn.F90 | 112 ++++++++++++++++--------------------- 1 file changed, 49 insertions(+), 63 deletions(-) diff --git a/physics/module_sf_mynn.F90 b/physics/module_sf_mynn.F90 index dd181c99c..eecc5493c 100644 --- a/physics/module_sf_mynn.F90 +++ b/physics/module_sf_mynn.F90 @@ -780,11 +780,11 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !$acc PSIT_lnd, PSIT_wat, PSIT_ice, & !$acc ch_lnd, ch_wat, ch_ice, & !$acc cm_lnd, cm_wat, cm_ice, & -!$acc snowh_lnd, & +!$acc snowh_lnd, snowh_wat, snowh_ice, & !$acc device_errmsg, device_errflg, & !$acc device_special_errmsg, device_special_errflg) -!$acc parallel loop present(PSFCPA, PSFC, QSFC, T1D, flag_iter, & +!$acc parallel loop present(PSFCPA, PSFC, QSFC, T1D, flag_iter, tsurf_lnd, & !$acc QSFC_wat, QSFCMR_wat, wet, TSK_wat, tskin_wat, & !$acc QSFC_lnd, QSFCMR_lnd, dry, TSK_lnd, tskin_lnd, & !$acc QSFC_ice, QSFCMR_ice, icy, TSK_ice, tskin_ice) @@ -809,9 +809,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ENDIF QSFC_wat(I)=EP2*E1/(PSFC(I)-ep3*E1) !specific humidity QSFCMR_wat(I)=EP2*E1/(PSFC(I)-E1) !mixing ratio -#ifndef _OPENACC IF(QSFC_wat(I)>1..or.QSFC_wat(I)<0.) print *,' QSFC_wat(I)',itimestep,i,QSFC_wat(I),TSK_wat(i) -#endif ENDIF IF (dry(i)) THEN TSK_lnd(I) = tskin_lnd(i) @@ -831,9 +829,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & QSFC_lnd(I)=0.5*(QSFC_lnd(I) + QSFC(I)) QSFCMR_lnd(I)=QSFC_lnd(I)/(1.-QSFC_lnd(I)) !mixing ratio endif ! lsm -#ifndef _OPENACC IF(QSFC_lnd(I)>1..or.QSFC_lnd(I)<0.) print *,' QSFC_lnd(I)',itimestep,i,QSFC_lnd(I),Tskin_lnd(i),tsurf_lnd(i),qsfc(i) -#endif ENDIF IF (icy(i)) THEN TSK_ice(I) = tskin_ice(i) @@ -851,9 +847,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & QSFC_ice(I)=EP2*E1/(PSFC(I)-ep3*E1) !specific humidity QSFCMR_ice(I)=EP2*E1/(PSFC(I)-E1) !mixing ratio endif ! lsm -#ifndef _OPENACC IF(QSFC_ice(I)>1..or.QSFC_ice(I)<0.) print *,' QSFC_ice(I)',itimestep,i,QSFC_ice(I),TSK_ice(i) -#endif ENDIF ELSE @@ -906,7 +900,10 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & endif ! flag_iter ENDDO -#ifndef _OPENACC +!$acc serial present(pblh, PSFCPA, dz8w1d, qflx, hflx, & +!$acc dry, tskin_lnd, tsurf_lnd, qsfc_lnd, znt_lnd, ust_lnd, snowh_lnd, & +!$acc icy, tskin_ice, tsurf_ice, qsfc_ice, znt_ice, ust_ice, snowh_ice, & +!$acc wet, tskin_wat, tsurf_wat, qsfc_wat, znt_wat, ust_wat, snowh_wat) IF (debug_code >= 1) THEN write(0,*)"ITIMESTEP=",ITIMESTEP," iter=",iter DO I=its,ite @@ -931,12 +928,12 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ENDIF ENDDO ENDIF -#endif +!$acc end serial !$acc parallel loop present(PSFC, PSFCPA, QVSH, QV1D, THCON, flag_iter, & !$acc dry, tskin_lnd, TSK_lnd, tsurf_lnd, THSK_lnd, THVSK_lnd, qsfc_lnd, & !$acc icy, tskin_ice, TSK_ice, tsurf_ice, THSK_ice, THVSK_ice, qsfc_ice, & -!$acc wet, tskin_wat, TSK_wat, tsurf_wat, THSK_wat, THVSK_wat) +!$acc wet, tskin_wat, TSK_wat, tsurf_wat, THSK_wat, THVSK_wat, qsfc_wat) DO I=its,ite ! PSFC ( in cmb) is used later in saturation checks PSFC(I)=PSFCPA(I)/1000. @@ -950,10 +947,8 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ! CONVERT SKIN TEMPERATURES TO POTENTIAL TEMPERATURE: THSK_lnd(I) = TSK_lnd(I)*THCON(I) !(K) THVSK_lnd(I) = THSK_lnd(I)*(1.+EP1*qsfc_lnd(I)) -#ifndef _OPENACC if(THVSK_lnd(I) < 170. .or. THVSK_lnd(I) > 360.) & print *,'THVSK_lnd(I)',itimestep,i,THVSK_lnd(I),THSK_lnd(i),tsurf_lnd(i),tskin_lnd(i),qsfc_lnd(i) -#endif endif if(icy(i)) then TSK_ice(I) = tskin_ice(i) @@ -961,10 +956,8 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ! CONVERT SKIN TEMPERATURES TO POTENTIAL TEMPERATURE: THSK_ice(I) = TSK_ice(I)*THCON(I) !(K) THVSK_ice(I) = THSK_ice(I)*(1.+EP1*qsfc_ice(I)) !(K) -#ifndef _OPENACC if(THVSK_ice(I) < 170. .or. THVSK_ice(I) > 360.) & print *,'THVSK_ice(I)',itimestep,i,THVSK_ice(I),THSK_ice(i),tsurf_ice(i),tskin_ice(i),qsfc_ice(i) -#endif endif if(wet(i)) then TSK_wat(I) = tskin_wat(i) @@ -972,10 +965,8 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ! CONVERT SKIN TEMPERATURES TO POTENTIAL TEMPERATURE: THSK_wat(I) = TSK_wat(I)*THCON(I) !(K) THVSK_wat(I) = THSK_wat(I)*(1.+EP1*QVSH(I)) !(K) -#ifndef _OPENACC if(THVSK_wat(I) < 170. .or. THVSK_wat(I) > 360.) & print *,'THVSK_wat(I)',i,THVSK_wat(I),THSK_wat(i),tsurf_wat(i),tskin_wat(i),qsfc_wat(i) -#endif endif endif ! flag_iter ENDDO @@ -1009,7 +1000,10 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & HFX(i)=HFLX(i)*RHO1D(I)*cp ENDDO -#ifndef _OPENACC +!$acc serial present(THV1D, TV1D, RHO1D, GOVRTH, & +!$acc dry, tsk_lnd, thvsk_lnd, & +!$acc icy, tsk_ice, thvsk_ice, & +!$acc wet, tsk_wat, thvsk_wat) IF (debug_code ==2) THEN !write(*,*)"ITIMESTEP=",ITIMESTEP DO I=its,ite @@ -1022,7 +1016,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & write(*,*)"RHO1D=", RHO1D(i)," GOVRTH=",GOVRTH(i) ENDDO ENDIF -#endif +!$acc end serial !$acc parallel loop present(T1D,P1D,QGH,QV1D,CPM) DO I=its,ite @@ -1042,7 +1036,10 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & CPM(I)=CP*(1.+0.84*QV1D(I)) ENDDO -#ifndef _OPENACC +!$acc serial present(QGH, & +!$acc wet, QSFC_wat, QSFCMR_wat, & +!$acc dry, QSFC_lnd, QSFCMR_lnd, & +!$acc icy, QSFC_ice, QSFCMR_ice) IF (debug_code == 2) THEN write(*,*)"ITIMESTEP=",ITIMESTEP DO I=its,ite @@ -1060,7 +1057,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & endif ENDDO ENDIF -#endif +!$acc end serial !$acc parallel loop present(flag_iter,U1D,V1D,WSPD,wet,dry,icy, & !$acc THV1D,THVSK_wat,THVSK_lnd,THVSK_ice, & @@ -1182,7 +1179,6 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & WSPD(I) = MAX(WSPD_ice,WSPD_wat) WSPD(I) = MAX(WSPD_lnd,WSPD(I)) -#ifndef _OPENACC IF (debug_code == 2) THEN write(*,*)"===== After rb calc in mynn sfc layer:" write(*,*)"ITIMESTEP=",ITIMESTEP @@ -1191,7 +1187,6 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & IF (wet(i))write(*,*)"rb_wat=", rb_wat(I)," DTHVDZ=",DTHVDZ IF (dry(i))write(*,*)"rb_lnd=", rb_lnd(I)," DTHVDZ=",DTHVDZ ENDIF -#endif ! IF PREVIOUSLY UNSTABLE, DO NOT LET INTO REGIMES 1 AND 2 (STABLE) !if (itimestep .GT. 1) THEN @@ -1210,7 +1205,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !-------------------------------------------------------------------- !-------------------------------------------------------------------- -!$acc parallel loop present(flag_iter, & +!$acc parallel loop present(flag_iter, PSFCPA, dz8w1d, pblh, & !$acc device_errmsg, device_errflg, & !$acc device_special_errmsg, device_special_errflg, & !$acc wet, dry, icy, & @@ -1219,8 +1214,10 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !$acc ZNTstoch_wat, ZNTstoch_lnd, ZNTstoch_ice, & !$acc UST_wat, UST_lnd, UST_ice, & !$acc ZQ_wat, ZQ_lnd, ZQ_ice, & -!$acc snowh_lnd, & +!$acc snowh_wat, snowh_lnd, snowh_ice, & !$acc THVSK_wat, THVSK_lnd, THVSK_ice, & +!$acc tskin_wat, tskin_lnd, tskin_ice, & +!$acc tsurf_wat, tsurf_lnd, tsurf_ice, & !$acc qsfc_wat, qsfc_lnd, qsfc_ice, & !$acc GZ1OZ0_wat, GZ1OZt_wat, GZ2OZ0_wat, GZ2OZt_wat, GZ10OZ0_wat, GZ10OZt_wat, & !$acc GZ1OZ0_lnd, GZ1OZt_lnd, GZ2OZ0_lnd, GZ2OZt_lnd, GZ10OZ0_lnd, GZ10OZt_lnd, & @@ -1228,12 +1225,14 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !$acc zratio_wat, zratio_lnd, zratio_ice, & !$acc stress_wat, stress_lnd, stress_ice, & !$acc rb_wat, rb_lnd, rb_ice, & +!$acc qflx, qflx_lnd, & +!$acc hflx, hflx_lnd, & !$acc psim, psih, psim10, psih10, psih2, & !$acc psix_wat, psix10_wat, psit_wat, psit2_wat, psiq_wat, psiq2_wat, & !$acc psix_lnd, psix10_lnd, psit_lnd, psit2_lnd, psiq_lnd, psiq2_lnd, & !$acc psix_ice, psix10_ice, psit_ice, psit2_ice, psiq_ice, psiq2_ice, & !$acc WSPD, WSPDI, U1D, V1D, TC1D, THV1D, rstoch1D, USTM, ZA, ZOL, QVSH, & -!$acc shdmax, vegtype, z0pert, ztpert, mol, rmol, qstar, sigmaf) +!$acc shdmax, vegtype, z0pert, ztpert, mol, rmol, wstar, qstar, sigmaf) DO I=its,ite if( flag_iter(i) ) then @@ -1250,12 +1249,12 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & if (sfc_z0_type >= 0) then ! Avoid calculation is using wave model ! CALCULATE z0 (znt) !-------------------------------------- -#ifndef _OPENACC + IF (debug_code == 2) THEN write(*,*)"=============Input to ZNT over water:" write(*,*)"u*:",UST_wat(i)," wspd=",WSPD(i)," visc=",visc," za=",ZA(I) ENDIF -#endif + IF ( PRESENT(ISFTCFLX) ) THEN IF ( ISFTCFLX .EQ. 0 ) THEN IF (COARE_OPT .EQ. 3.0) THEN @@ -1292,12 +1291,10 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ZNTstoch_wat(I) = ZNT_wat(I) endif -#ifndef _OPENACC IF (debug_code > 1) THEN write(*,*)"==========Output ZNT over water:" write(*,*)"ZNT:",ZNTstoch_wat(i) ENDIF -#endif !COMPUTE ROUGHNESS REYNOLDS NUMBER (restar) USING NEW ZNT ! AHW: Garrattt formula: Calculate roughness Reynolds number @@ -1308,12 +1305,10 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !-------------------------------------- !CALCULATE z_t and z_q !-------------------------------------- -#ifndef _OPENACC IF (debug_code > 1) THEN write(*,*)"=============Input to ZT over water:" write(*,*)"u*:",UST_wat(i)," restar=",restar," visc=",visc ENDIF -#endif IF ( PRESENT(ISFTCFLX) ) THEN IF ( ISFTCFLX .EQ. 0 ) THEN @@ -1357,12 +1352,11 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & rstoch1D(i),spp_sfc) ENDIF ENDIF -#ifndef _OPENACC + IF (debug_code > 1) THEN write(*,*)"=============Output ZT & ZQ over water:" write(*,*)"ZT:",ZT_wat(i)," ZQ:",ZQ_wat(i) ENDIF -#endif GZ1OZ0_wat(I)= LOG((ZA(I)+ZNTstoch_wat(I))/ZNTstoch_wat(I)) GZ1OZt_wat(I)= LOG((ZA(I)+ZNTstoch_wat(i))/ZT_wat(i)) @@ -1433,7 +1427,6 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ENDIF ENDIF -#ifndef _OPENACC IF (ZNTstoch_lnd(i) < 1E-8 .OR. Zt_lnd(i) < 1E-10) THEN write(0,*)"===(land) capture bad input in mynn sfc layer, i=:",i write(0,*)" ZNT=", ZNTstoch_lnd(i)," ZT=",Zt_lnd(i) @@ -1442,7 +1435,6 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & " ust=", ust_lnd(i)," snowh=", snowh_lnd(i),"psfcpa=",PSFCPA(i), & " dz=",dz8w1d(i)," qflx=",qflx_lnd(i)," hflx=",hflx_lnd(i)," hpbl=",pblh(i) ENDIF -#endif GZ1OZ0_lnd(I)= LOG((ZA(I)+ZNTstoch_lnd(I))/ZNTstoch_lnd(I)) GZ1OZt_lnd(I)= LOG((ZA(I)+ZNTstoch_lnd(i))/ZT_lnd(i)) @@ -1508,7 +1500,6 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ZOL(I)=MAX(ZOL(I),0.0_kind_phys) ZOL(I)=MIN(ZOL(I),20._kind_phys) -#ifndef _OPENACC IF (debug_code >= 1) THEN IF (ZNTstoch_wat(i) < 1E-8 .OR. Zt_wat(i) < 1E-10) THEN write(0,*)"===(wet) capture bad input in mynn sfc layer, i=:",i @@ -1519,7 +1510,6 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) ENDIF ENDIF -#endif !Use Pedros iterative function to find z/L !zol(I)=zolri(rb_wat(I),ZA(I),ZNTstoch_wat(I),ZT_wat(I),ZOL(I),psi_opt) @@ -1577,7 +1567,6 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ZOL(I)=MAX(ZOL(I),-20.0_kind_phys) ZOL(I)=MIN(ZOL(I),0.0_kind_phys) -#ifndef _OPENACC IF (debug_code >= 1) THEN IF (ZNTstoch_wat(i) < 1E-8 .OR. Zt_wat(i) < 1E-10) THEN write(0,*)"===(wet) capture bad input in mynn sfc layer, i=:",i @@ -1588,7 +1577,6 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) ENDIF ENDIF -#endif !Use Pedros iterative function to find z/L !zol(I)=zolri(rb_wat(I),ZA(I),ZNTstoch_wat(I),ZT_wat(I),ZOL(I),psi_opt) @@ -1649,7 +1637,6 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ZOL(I)=MAX(ZOL(I),0.0_kind_phys) ZOL(I)=MIN(ZOL(I),20._kind_phys) -#ifndef _OPENACC IF (debug_code >= 1) THEN IF (ZNTstoch_lnd(i) < 1E-8 .OR. Zt_lnd(i) < 1E-10) THEN write(0,*)"===(land) capture bad input in mynn sfc layer, i=:",i @@ -1660,7 +1647,6 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) ENDIF ENDIF -#endif !Use Pedros iterative function to find z/L !zol(I)=zolri(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),ZT_lnd(I),ZOL(I),psi_opt) @@ -1717,7 +1703,6 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ZOL(I)=MAX(ZOL(I),-20.0_kind_phys) ZOL(I)=MIN(ZOL(I),0.0_kind_phys) -#ifndef _OPENACC IF (debug_code >= 1) THEN IF (ZNTstoch_lnd(i) < 1E-8 .OR. Zt_lnd(i) < 1E-10) THEN write(0,*)"===(land) capture bad input in mynn sfc layer, i=:",i @@ -1728,7 +1713,6 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) ENDIF ENDIF -#endif !Use Pedros iterative function to find z/L !zol(I)=zolri(rb_lnd(I),ZA(I),ZNTstoch_lnd(I),ZT_lnd(I),ZOL(I),psi_opt) @@ -1788,7 +1772,6 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ZOL(I)=MAX(ZOL(I),0.0_kind_phys) ZOL(I)=MIN(ZOL(I),20._kind_phys) -#ifndef _OPENACC IF (debug_code >= 1) THEN IF (ZNTstoch_ice(i) < 1E-8 .OR. Zt_ice(i) < 1E-10) THEN write(0,*)"===(ice) capture bad input in mynn sfc layer, i=:",i @@ -1799,7 +1782,6 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) ENDIF ENDIF -#endif !Use Pedros iterative function to find z/L !zol(I)=zolri(rb_ice(I),ZA(I),ZNTstoch_ice(I),ZT_ice(I),ZOL(I),psi_opt) @@ -1856,7 +1838,6 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ZOL(I)=MAX(ZOL(I),-20.0_kind_phys) ZOL(I)=MIN(ZOL(I),0.0_kind_phys) -#ifndef _OPENACC IF (debug_code >= 1) THEN IF (ZNTstoch_ice(i) < 1E-8 .OR. Zt_ice(i) < 1E-10) THEN write(0,*)"===(ice) capture bad input in mynn sfc layer, i=:",i @@ -1867,7 +1848,6 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & " dz=",dz8w1d(i)," qflx=",qflx(i)," hflx=",hflx(i)," hpbl=",pblh(i) ENDIF ENDIF -#endif !Use Pedros iterative function to find z/L !zol(I)=zolri(rb_ice(I),ZA(I),ZNTstoch_ice(I),ZT_ice(I),ZOL(I),psi_opt) @@ -2031,7 +2011,13 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ENDIF #endif -#ifndef _OPENACC +!$acc serial present(wet, dry, icy, & +!$acc PSIM, PSIH, CPM, RHO1D, ZOL, wspd, MOL, & +!$acc wstar, qstar, THV1D, HFX, MAVAIL, QVSH, & +!$acc THVSK_wat, THVSK_lnd, THVSK_ice, & +!$acc UST_wat, UST_lnd, UST_ice, & +!$acc ZNTstoch_wat, ZNTstoch_lnd, ZNTstoch_ice, & +!$acc zt_wat, zt_lnd, zt_ice) IF (debug_code == 2) THEN DO I=its,ite IF(wet(i))write(*,*)"==== AT END OF MAIN LOOP, i=",i, "(wet)" @@ -2052,7 +2038,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & write(*,*)"=============================================" ENDDO ! end i-loop ENDIF -#endif +!$acc end serial !---------------------------------------------------------- ! COMPUTE SURFACE HEAT AND MOISTURE FLUXES @@ -2238,14 +2224,12 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ENDIF -#ifndef _OPENACC IF (debug_code > 1) THEN write(*,*)"QFX=",QFX(I),"FLQC=",FLQC(I) if(icy(i))write(*,*)"ice, MAVAIL:",MAVAIL(I)," u*=",UST_ice(I)," psiq=",PSIQ_ice(i) if(dry(i))write(*,*)"lnd, MAVAIL:",MAVAIL(I)," u*=",UST_lnd(I)," psiq=",PSIQ_lnd(i) if(wet(i))write(*,*)"ocn, MAVAIL:",MAVAIL(I)," u*=",UST_wat(I)," psiq=",PSIQ_wat(i) ENDIF -#endif ! The exchange coefficient for cloud water is assumed to be the ! same as that for heat. CH is multiplied by WSPD. @@ -2397,17 +2381,17 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !----------------------------------------------------- ! DEBUG - SUSPICIOUS VALUES !----------------------------------------------------- +!$acc serial present(dry, wet, icy, CPM, MAVAIL, & +!$acc HFX, LH, wstar, RHO1D, PBLH, ZOL, ZA, MOL, & +!$acc PSIM, PSIH, WSTAR, T1D, TH1D, THV1D, QVSH, & +!$acc UST_wat, UST_lnd, UST_ice, & +!$acc THSK_wat, THSK_lnd, THSK_ice, & +!$acc THVSK_wat, THVSK_lnd, THVSK_ice, & +!$acc ZNTstoch_wat, ZNTstoch_lnd, ZNTstoch_ice, & +!$acc ZT_wat, ZT_lnd, ZT_ice, & +!$acc QSFC_wat, QSFC_lnd, QSFC_ice, & +!$acc PSIX_wat, PSIX_lnd, PSIX_ice) IF ( debug_code == 2) THEN - !$acc parallel loop present(dry, wet, icy, CPM, MAVAIL, & - !$acc HFX, LH, wstar, RHO1D, PBLH, ZOL, ZA, MOL, & - !$acc PSIM, PSIH, WSTAR, T1D, TH1D, THV1D, QVSH, & - !$acc UST_wat, UST_lnd, UST_ice, & - !$acc THSK_wat, THSK_lnd, THSK_ice, & - !$acc THVSK_wat, THVSK_lnd, THVSK_ice, & - !$acc ZNTstoch_wat, ZNTstoch_lnd, ZNTstoch_ice, & - !$acc ZT_wat, ZT_lnd, ZT_ice, & - !$acc QSFC_wat, QSFC_lnd, QSFC_ice, & - !$acc PSIX_wat, PSIX_lnd, PSIX_ice) DO I=its,ite yesno = 0 IF (compute_flux) THEN @@ -2511,6 +2495,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ENDIF ENDDO ! end i-loop ENDIF ! end debug option +!$acc end serial !$acc exit data copyout(CPM, FLHC, FLQC, CHS, CH, CHS2, CQS2,& !$acc USTM, wstar, qstar, ZOL, MOL, RMOL, & @@ -2542,7 +2527,8 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !$acc MAVAIL, PBLH, PSFCPA, z0pert, ztpert, & !$acc QV1D, U1D, V1D, U1D2, V1D2, T1D, P1D, & !$acc rstoch1D, sigmaf, shdmax, vegtype, & -!$acc dz2w1d, dz8w1d, snowh_lnd, & +!$acc dz2w1d, dz8w1d, & +!$acc snowh_wat, snowh_lnd, snowh_ice, & !$acc tskin_wat, tskin_lnd, tskin_ice, & !$acc tsurf_wat, tsurf_lnd, tsurf_ice) From 315d3cc74f5d5edad379f9968c361f5f3c513725 Mon Sep 17 00:00:00 2001 From: Samuel Trahan Date: Wed, 6 Sep 2023 00:17:12 -0600 Subject: [PATCH 326/380] stop FV3_HRRR_c3 from crashing with gnu debug --- physics/cu_c3_deep.F90 | 298 ++++++++++++++++++++--------------------- physics/cu_c3_sh.F90 | 22 +-- 2 files changed, 160 insertions(+), 160 deletions(-) diff --git a/physics/cu_c3_deep.F90 b/physics/cu_c3_deep.F90 index c3a4b2c4e..7927f1cfb 100644 --- a/physics/cu_c3_deep.F90 +++ b/physics/cu_c3_deep.F90 @@ -159,12 +159,12 @@ subroutine cu_c3_deep_run( & nranflag,itf,ktf,its,ite, kts,kte,ipr,imid integer, intent (in ) :: & ichoice - real(kind=kind_phys), dimension (its:ite,4) & + real(kind=kind_phys), dimension (its:,:) & ,intent (in ) :: rand_clos - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (in ) :: rand_mom,rand_vmas !$acc declare copyin(rand_clos,rand_mom,rand_vmas) - real(kind=kind_phys), intent(in), dimension (its:ite) :: ca_deep(:) + real(kind=kind_phys), intent(in), dimension (its:) :: ca_deep(:) integer, intent(in) :: do_capsuppress real(kind=kind_phys), intent(in), dimension(:) :: cap_suppress_j !$acc declare create(cap_suppress_j) @@ -177,28 +177,28 @@ subroutine cu_c3_deep_run( & ! outq = output q tendency (per s) ! outqc = output qc tendency (per s) ! pre = output precip - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (inout ) :: & cnvwt,outu,outv,outt,outq,outqc,cupclw - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (out ) :: & frh_out,rainevap - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (in ) :: & tmf, qmicro, sigmain, forceqv_spechum - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (inout ) :: & pre,xmb_out !$acc declare copy(cnvwt,outu,outv,outt,outq,outqc,cupclw,frh_out,pre,xmb_out) - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (in ) :: & hfx,qfx,xmbm_in,xmbs_in !$acc declare copyin(hfx,qfx,xmbm_in,xmbs_in) - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (inout ) :: & kbcon,ktop !$acc declare copy(kbcon,ktop) - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (in ) :: & kpbl,tropics !$acc declare copyin(kpbl,tropics) @@ -207,26 +207,26 @@ subroutine cu_c3_deep_run( & ! omega (omeg), windspeed (us,vs), and a flag (ierr) to turn off ! convection for this call only and at that particular gridpoint ! - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (in ) :: & dhdt,rho,t,po,us,vs,tn,delp !$acc declare copyin(dhdt,rho,t,po,us,vs,tn) - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (inout ) :: & omeg !$acc declare copy(omeg) - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (inout) :: & q,qo,zuo,zdo,zdm !$acc declare sigmaout - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (out) :: & sigmaout - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (in ) :: & dx,z1,psur,xland !$acc declare copyin(dx,z1,psur,xland) - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (inout ) :: & mconv,ccn !$acc declare copy(mconv,ccn) @@ -372,8 +372,8 @@ subroutine cu_c3_deep_run( & !$acc kzdown,kdet,k22,jmin,kstabi,kstabm,k22x,xland1, & !$acc ktopdby,kbconx,ierr2,ierr3,kbmax) - integer, dimension (its:ite), intent(inout) :: ierr - integer, dimension (its:ite), intent(in) :: csum + integer, dimension (its:), intent(inout) :: ierr + integer, dimension (its:), intent(in) :: csum logical, intent(in) :: do_ca, progsigma logical, intent(in) :: flag_init, flag_restart !$acc declare copy(ierr) copyin(csum) @@ -421,7 +421,7 @@ subroutine cu_c3_deep_run( & !$acc tn_bl, qo_bl, qeso_bl, heo_bl, heso_bl, & !$acc qeso_cup_bl,qo_cup_bl, heo_cup_bl,heso_cup_bl, & !$acc gammao_cup_bl,tn_cup_bl,hco_bl,dbyo_bl,xf_dicycle) - real(kind=kind_phys), intent(inout), dimension(its:ite,10) :: forcing + real(kind=kind_phys), intent(inout), dimension(its:,:) :: forcing !$acc declare copy(forcing) integer :: turn,pmin_lev(its:ite),start_level(its:ite),ktopkeep(its:ite) real(kind=kind_phys), dimension (its:ite,kts:kte) :: dtempdz @@ -2418,16 +2418,16 @@ subroutine rain_evap_below_cloudbase(itf,ktf, its,ite, kts,kte,ierr, & integer ,intent(in) :: itf,ktf, its,ite, kts,kte - integer, dimension(its:ite) ,intent(in) :: ierr,kbcon - real(kind=kind_phys), dimension(its:ite) ,intent(in) ::psur,xland,pwavo,edto,pwevo,xmb - real(kind=kind_phys), dimension(its:ite,kts:kte),intent(in) :: po_cup,qo_cup,qes_cup - real(kind=kind_phys), dimension(its:ite) ,intent(inout) :: pre - real(kind=kind_phys), dimension(its:ite,kts:kte),intent(inout) :: outt,outq !,outbuoy + integer, dimension(its:) ,intent(in) :: ierr,kbcon + real(kind=kind_phys), dimension(its:) ,intent(in) ::psur,xland,pwavo,edto,pwevo,xmb + real(kind=kind_phys), dimension(its:,kts:),intent(in) :: po_cup,qo_cup,qes_cup + real(kind=kind_phys), dimension(its:) ,intent(inout) :: pre + real(kind=kind_phys), dimension(its:,kts:),intent(inout) :: outt,outq !,outbuoy !$acc declare copyin(ierr,kbcon,psur,xland,pwavo,edto,pwevo,xmb,po_cup,qo_cup,qes_cup) !$acc declare copy(pre,outt,outq) - !real, dimension(its:ite) ,intent(out) :: tot_evap_bcb - !real, dimension(its:ite,kts:kte),intent(out) :: evap_bcb,net_prec_bcb + !real, dimension(its:) ,intent(out) :: tot_evap_bcb + !real, dimension(its:,kts:),intent(out) :: evap_bcb,net_prec_bcb !-- locals integer :: i,k @@ -2511,30 +2511,30 @@ subroutine cup_dd_edt(ierr,us,vs,z,ktop,kbcon,edt,p,pwav, & ! ! ierr error value, maybe modified in this routine ! - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (in ) :: & rho,us,vs,z,p,pw - real(kind=kind_phys), dimension (its:ite,1) & + real(kind=kind_phys), dimension (its:,: ) & ,intent (out ) :: & edtc - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (out ) :: & pefc - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (out ) :: & edt - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (in ) :: & pwav,pwev,psum2,psumh,edtmax,edtmin - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (in ) :: & ktop,kbcon,xland1 real(kind=kind_phys), intent (in ) :: & !HCB ccnclean - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (inout ) :: & ccn - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (inout) :: & ierr !$acc declare copyin(rho,us,vs,z,p,pw,pwav,pwev,psum2,psumh,edtmax,edtmin,ktop,kbcon) @@ -2671,7 +2671,7 @@ subroutine cup_dd_moisture(ierrc,zd,hcd,hes_cup,qcd,qes_cup, & ! pwev = total normalized integrated evaoprate (i2) ! entr= entrainment rate ! - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (in ) :: & zd,hes_cup,hcd,qes_cup,q_cup,z_cup, & dd_massentr,dd_massdetr,gamma_cup,q,he,p_cup @@ -2679,18 +2679,18 @@ subroutine cup_dd_moisture(ierrc,zd,hcd,hes_cup,qcd,qes_cup, & integer & ,intent (in ) :: & iloop - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (in ) :: & jmin !$acc declare copyin(jmin) - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (inout) :: & ierr !$acc declare copy(ierr) - real(kind=kind_phys), dimension (its:ite,kts:kte)& + real(kind=kind_phys), dimension (its:,kts:)& ,intent (out ) :: & qcd,qrcd,pwd - real(kind=kind_phys), dimension (its:ite)& + real(kind=kind_phys), dimension (its:)& ,intent (out ) :: & pwev,bu !$acc declare copyout(qcd,qrcd,pwd,pwev,bu) @@ -2812,23 +2812,23 @@ subroutine cup_env(z,qes,he,hes,t,q,p,z1, & its,ite, kts,kte ! ! - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (in ) :: & p,t,q !$acc declare copyin(p,t,q) - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (out ) :: & hes,qes !$acc declare copyout(hes,qes) - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (inout) :: & he,z !$acc declare copy(he,z) - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (in ) :: & psur,z1 !$acc declare copyin(psur,z1) - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (inout) :: & ierr !$acc declare copy(ierr) @@ -2966,19 +2966,19 @@ subroutine cup_env_clev(t,qes,q,he,hes,z,p,qes_cup,q_cup, & itf,ktf, & its,ite, kts,kte ! - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (in ) :: & qes,q,he,hes,z,p,t !$acc declare copyin(qes,q,he,hes,z,p,t) - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (out ) :: & qes_cup,q_cup,he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup !$acc declare copyout(qes_cup,q_cup,he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup) - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (in ) :: & psur,z1 !$acc declare copyin(psur,z1) - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (inout) :: & ierr !$acc declare copy(ierr) @@ -3077,33 +3077,33 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 ! k22 = updraft originating level ! ichoice = flag if only want one closure (usually set to zero!) ! - real(kind=kind_phys), dimension (its:ite,1:maxens3) & + real(kind=kind_phys), dimension (its:,1:) & ,intent (inout) :: & pr_ens - real(kind=kind_phys), dimension (its:ite,1:maxens3) & + real(kind=kind_phys), dimension (its:,1:) & ,intent (inout ) :: & xf_ens !$acc declare copy(pr_ens,xf_ens) - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (in ) :: & zd,zu,p_cup,zdm - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (in ) :: & omeg - real(kind=kind_phys), dimension (its:ite,1) & + real(kind=kind_phys), dimension (its:,:) & ,intent (in ) :: & xaa0 - real(kind=kind_phys), dimension (its:ite,4) & + real(kind=kind_phys), dimension (its:,:) & ,intent (in ) :: & rand_clos - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (in ) :: & aa1,edt,edtm,omegac,sigmab - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (in ) :: & mconv,axx !$acc declare copyin(zd,zu,p_cup,zdm,omeg,xaa0,rand_clos,aa1,edt,edtm,mconv,axx) - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (inout) :: & aa0,closure_n !$acc declare copy(aa0,closure_n) @@ -3113,13 +3113,13 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 real(kind=kind_phys) & ,intent (in ) :: & dtime - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (inout ) :: & k22,kbcon,ktop - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (in ) :: & xland - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (inout) :: & ierr,ierr2,ierr3 !$acc declare copy(k22,kbcon,ktop,ierr,ierr2,ierr3) copyin(xland) @@ -3129,10 +3129,10 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 integer, intent(in) :: dicycle logical, intent (in) :: progsigma - real(kind=kind_phys), intent(in) , dimension (its:ite) :: aa1_bl,tau_ecmwf - real(kind=kind_phys), intent(inout), dimension (its:ite) :: xf_dicycle - real(kind=kind_phys), intent(out), dimension (its:ite) :: xf_progsigma - real(kind=kind_phys), intent(inout), dimension (its:ite,10) :: forcing + real(kind=kind_phys), intent(in) , dimension (its:) :: aa1_bl,tau_ecmwf + real(kind=kind_phys), intent(inout), dimension (its:) :: xf_dicycle + real(kind=kind_phys), intent(out), dimension (its:) :: xf_progsigma + real(kind=kind_phys), intent(inout), dimension (its:,:) :: forcing !$acc declare copyin(aa1_bl,tau_ecmwf) copy(xf_dicycle,forcing) !- local var real(kind=kind_phys) :: xff_dicycle @@ -3487,31 +3487,31 @@ subroutine cup_kbcon(ierrc,cap_inc,iloop_in,k22,kbcon,he_cup,hes_cup, & ! ! ierr error value, maybe modified in this routine ! - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (in ) :: & he_cup,hes_cup,p_cup !$acc declare copyin(he_cup,hes_cup,p_cup) - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (in ) :: & entr_rate,ztexec,zqexec,cap_inc,cap_max !$acc declare copyin(entr_rate,ztexec,zqexec,cap_inc,cap_max) - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (inout ) :: & hkb !,cap_max !$acc declare copy(hkb) - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (in ) :: & kbmax !$acc declare copyin(kbmax) - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (inout) :: & kbcon,k22,ierr !$acc declare copy(kbcon,k22,ierr) integer & ,intent (in ) :: & iloop_in - character*50 :: ierrc(its:ite) - real(kind=kind_phys), dimension (its:ite,kts:kte),intent (in) :: z_cup,heo + character*50 :: ierrc(its:) + real(kind=kind_phys), dimension (its:,kts:),intent (in) :: z_cup,heo !$acc declare copyin(z_cup,heo) integer, dimension (its:ite) :: iloop,start_level !$acc declare create(iloop,start_level) @@ -3645,18 +3645,18 @@ subroutine cup_maximi(array,ks,ke,maxx,ierr, & ! x output array with return values ! kt output array of levels ! ks,kend check-range - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (in ) :: & array !$acc declare copyin(array) - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (in ) :: & ierr,ke !$acc declare copyin(ierr,ke) integer & ,intent (in ) :: & ks - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (out ) :: & maxx !$acc declare copyout(maxx) @@ -3708,15 +3708,15 @@ subroutine cup_minimi(array,ks,kend,kt,ierr, & ! x output array with return values ! kt output array of levels ! ks,kend check-range - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (in ) :: & array !$acc declare copyin(array) - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (in ) :: & ierr,ks,kend !$acc declare copyin(ierr,ks,kend) - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (out ) :: & kt !$acc declare copyout(kt) @@ -3771,10 +3771,10 @@ subroutine cup_up_aa0(aa0,z,zu,dby,gamma_cup,t_cup, & ! z = heights of model levels ! ierr error value, maybe modified in this routine ! - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (in ) :: & z,zu,gamma_cup,t_cup,dby - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (in ) :: & kbcon,ktop !$acc declare copyin(z,zu,gamma_cup,t_cup,dby,kbcon,ktop) @@ -3783,11 +3783,11 @@ subroutine cup_up_aa0(aa0,z,zu,dby,gamma_cup,t_cup, & ! - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (inout) :: & ierr !$acc declare copy(ierr) - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (out ) :: & aa0 !$acc declare copyout(aa0) @@ -3830,15 +3830,15 @@ subroutine neg_check(name,j,dt,q,outq,outt,outu,outv, & outqc,pret,its,ite,kts,kte,itf,ktf,ktop) integer, intent(in ) :: j,its,ite,kts,kte,itf,ktf - integer, dimension (its:ite ), intent(in ) :: ktop + integer, dimension (its: ), intent(in ) :: ktop - real(kind=kind_phys), dimension (its:ite,kts:kte ) , & + real(kind=kind_phys), dimension (its:,kts: ) , & intent(inout ) :: & outq,outt,outqc,outu,outv - real(kind=kind_phys), dimension (its:ite,kts:kte ) , & + real(kind=kind_phys), dimension (its:,kts: ) , & intent(inout ) :: & q - real(kind=kind_phys), dimension (its:ite ) , & + real(kind=kind_phys), dimension (its: ) , & intent(inout ) :: & pret !$acc declare copy(outq,outt,outqc,outu,outv,q,pret) @@ -3979,38 +3979,38 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & ! pw = pw -epsilon*pd (ensemble dependent) ! ierr error value, maybe modified in this routine ! - real(kind=kind_phys), dimension (its:ite,1:maxens3) & + real(kind=kind_phys), dimension (its:,:) & ,intent (inout) :: & xf_ens,pr_ens - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (inout ) :: & outtem,outq,outqc - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (in ) :: & zu,pwd,p_cup - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (in ) :: & sig,xmbm_in,xmbs_in,edt,sigmab,dx - real(kind=kind_phys), dimension (its:ite,2) & + real(kind=kind_phys), dimension (its:,:) & ,intent (in ) :: & xff_mid - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (inout ) :: & pre,xmb - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (inout ) :: & closure_n - real(kind=kind_phys), dimension (its:ite,kts:kte,1) & + real(kind=kind_phys), dimension (its:,kts:,:) & ,intent (in ) :: & dellat,dellaqc,dellaq,pw - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (in ) :: & ktop,xland1 - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (inout) :: & ierr,ierr2,ierr3 integer, intent(in) :: dicycle - real(kind=kind_phys), intent(in), dimension (its:ite) :: xf_dicycle, xf_progsigma + real(kind=kind_phys), intent(in), dimension (its:) :: xf_dicycle, xf_progsigma !$acc declare copyin(zu,pwd,p_cup,sig,xmbm_in,xmbs_in,edt,xff_mid,dellat,dellaqc,dellaq,pw,ktop,xland1,xf_dicycle) !$acc declare copy(xf_ens,pr_ens,outtem,outq,outqc,pre,xmb,closure_n,ierr,ierr2,ierr3) ! @@ -4248,15 +4248,15 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & ! zu = normalized updraft mass flux ! gamma_cup = gamma on model cloud levels ! - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (in ) :: & p_cup,rho,q,zu,gamma_cup,qe_cup, & up_massentr,up_massdetr,dby,qes_cup,z_cup - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (in ) :: & zqexec,c0 ! entr= entrainment rate - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (in ) :: & kbcon,ktop,k22,xland1 !$acc declare copyin(p_cup,rho,q,zu,gamma_cup,qe_cup,up_massentr,up_massdetr,dby,qes_cup,z_cup,zqexec,c0,kbcon,ktop,k22,xland1) @@ -4268,7 +4268,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & ! ierr error value, maybe modified in this routine - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (inout) :: & ierr !$acc declare copy(ierr) @@ -4281,11 +4281,11 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & ! pwav = totan normalized integrated condensate (i1) ! c0 = conversion rate (cloud to rain) - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (out ) :: & qc,qrc,pw,clw_all !$acc declare copy(qc,qrc,pw,clw_all) - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (inout) :: & c1d !$acc declare copy(c1d) @@ -4295,11 +4295,11 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & real(kind=kind_phys), dimension (its:ite) :: & pwavh !$acc declare create(pwavh) - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (out ) :: & pwav,psum,psumh !$acc declare copyout(pwav,psum,psumh) - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (in ) :: & ccn !$acc declare copyin(ccn) @@ -4329,7 +4329,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & is_deep = (name == 'deep') !$acc kernels - prop_b(kts:kte)=0 + prop_b(kts:)=0 !$acc end kernels iall=0 clwdet=0.1 !0.02 @@ -4646,11 +4646,11 @@ subroutine rates_up_pdf(rand_vmas,ipr,name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo implicit none character *(*), intent (in) :: name integer, intent(in) :: ipr,its,ite,itf,kts,kte,ktf - real(kind=kind_phys), dimension (its:ite,kts:kte),intent (inout) :: entr_rate_2d,zuo - real(kind=kind_phys), dimension (its:ite,kts:kte),intent (in) ::p_cup, heo,heso_cup,z_cup - real(kind=kind_phys), dimension (its:ite),intent (in) :: hkbo,rand_vmas - integer, dimension (its:ite),intent (in) :: kstabi,k22,kpbl,csum,xland,pmin_lev - integer, dimension (its:ite),intent (inout) :: kbcon,ierr,ktop,ktopdby + real(kind=kind_phys), dimension (its:,kts:),intent (inout) :: entr_rate_2d,zuo + real(kind=kind_phys), dimension (its:,kts:),intent (in) ::p_cup, heo,heso_cup,z_cup + real(kind=kind_phys), dimension (its:),intent (in) :: hkbo,rand_vmas + integer, dimension (its:),intent (in) :: kstabi,k22,kpbl,csum,xland,pmin_lev + integer, dimension (its:),intent (inout) :: kbcon,ierr,ktop,ktopdby !$acc declare copy(entr_rate_2d,zuo,kbcon,ierr,ktop,ktopdby) & !$acc copyin(p_cup, heo,heso_cup,z_cup,hkbo,rand_vmas,kstabi,k22,kpbl,csum,xland,pmin_lev) @@ -4737,7 +4737,7 @@ subroutine rates_up_pdf(rand_vmas,ipr,name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo ktop(i)= 0 else call get_zu_zd_pdf_fim(kklev,p_cup(i,:),rand_vmas(i),zubeg,ipr,xland(i),zuh2,1,ierr(i),k22(i), & - kfinalzu+1,zuo(i,kts:kte),kts,kte,ktf,beta_u,kbcon(i),csum(i),pmin_lev(i)) + kfinalzu+1,zuo(i,kts:),kts,kte,ktf,beta_u,kbcon(i),csum(i),pmin_lev(i)) endif endif ! end deep if ( is_mid ) then @@ -4748,7 +4748,7 @@ subroutine rates_up_pdf(rand_vmas,ipr,name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo kfinalzu=ktop(i) ktopdby(i)=ktop(i)+1 call get_zu_zd_pdf_fim(kklev,p_cup(i,:),rand_vmas(i),zubeg,ipr,xland(i),zuh2,3, & - ierr(i),k22(i),ktopdby(i)+1,zuo(i,kts:kte),kts,kte,ktf,beta_u,kbcon(i),csum(i),pmin_lev(i)) + ierr(i),k22(i),ktopdby(i)+1,zuo(i,kts:),kts,kte,ktf,beta_u,kbcon(i),csum(i),pmin_lev(i)) endif endif ! mid if ( is_shallow ) then @@ -4759,7 +4759,7 @@ subroutine rates_up_pdf(rand_vmas,ipr,name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo kfinalzu=ktop(i) ktopdby(i)=ktop(i)+1 call get_zu_zd_pdf_fim(kbcon(i),p_cup(i,:),rand_vmas(i),zubeg,ipr,xland(i),zuh2,2,ierr(i),k22(i), & - ktopdby(i)+1,zuo(i,kts:kte),kts,kte,ktf,beta_u,kbcon(i),csum(i),pmin_lev(i)) + ktopdby(i)+1,zuo(i,kts:),kts,kte,ktf,beta_u,kbcon(i),csum(i),pmin_lev(i)) endif endif ! shal @@ -4782,8 +4782,8 @@ subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,k real(kind=kind_phys), parameter :: beta_dd=4.0,g_beta_dd=6. integer, intent(in) ::ipr,xland,kb,kklev,kt,kts,kte,ktf,kpbli,csum,pmin_lev real(kind=kind_phys), intent(in) ::max_mass,zubeg - real(kind=kind_phys), intent(inout) :: zu(kts:kte) - real(kind=kind_phys), intent(in) :: p(kts:kte) + real(kind=kind_phys), intent(inout) :: zu(kts:) + real(kind=kind_phys), intent(in) :: p(kts:) real(kind=kind_phys) :: trash,beta_deep,zuh(kts:kte),zuh2(1:40) integer, intent(inout) :: ierr integer, intent(in) ::draft @@ -5057,20 +5057,20 @@ subroutine cup_up_aa1bl(aa0,t,tn,q,qo,dtime, & ! z = heights of model levels ! ierr error value, maybe modified in this routine ! - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (in ) :: & z_cup,zu,gamma_cup,t_cup,dby,t,tn,q,qo - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (in ) :: & kbcon,ktop real(kind=kind_phys), intent(in) :: dtime ! ! input and output ! - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (inout) :: & ierr - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (out ) :: & aa0 ! @@ -5107,14 +5107,14 @@ subroutine get_inversion_layers(ierr,p_cup,t_cup,z_cup,qo_cup,qeso_cup,k_inv_lay implicit none integer ,intent (in ) :: itf,ktf,its,ite,kts,kte - integer, dimension (its:ite) ,intent (in ) :: ierr,kstart,kend + integer, dimension (its:) ,intent (in ) :: ierr,kstart,kend !$acc declare copyin(ierr,kstart,kend) integer, dimension (its:ite) :: kend_p3 !$acc declare create(kend_p3) - real(kind=kind_phys), dimension (its:ite,kts:kte), intent (in ) :: p_cup,t_cup,z_cup,qo_cup,qeso_cup - real(kind=kind_phys), dimension (its:ite,kts:kte), intent (out) :: dtempdz - integer, dimension (its:ite,kts:kte), intent (out) :: k_inv_layers + real(kind=kind_phys), dimension (its:,kts:), intent (in ) :: p_cup,t_cup,z_cup,qo_cup,qeso_cup + real(kind=kind_phys), dimension (its:,kts:), intent (out) :: dtempdz + integer, dimension (its:,kts:), intent (out) :: k_inv_layers !$acc declare copyin(p_cup,t_cup,z_cup,qo_cup,qeso_cup) !$acc declare copyout(dtempdz,k_inv_layers) !-local vars @@ -5308,15 +5308,15 @@ subroutine get_lateral_massflux(itf,ktf, its,ite, kts,kte implicit none integer, intent (in) :: draft integer, intent(in):: itf,ktf, its,ite, kts,kte - integer, intent(in) , dimension(its:ite) :: ierr,ktop,kbcon,k22 + integer, intent(in) , dimension(its:) :: ierr,ktop,kbcon,k22 !$acc declare copyin(ierr,ktop,kbcon,k22) - !real(kind=kind_phys), intent(in), optional , dimension(its:ite):: lambau - real(kind=kind_phys), intent(inout), optional , dimension(its:ite):: lambau - real(kind=kind_phys), intent(in) , dimension(its:ite,kts:kte) :: zo_cup,zuo - real(kind=kind_phys), intent(inout), dimension(its:ite,kts:kte) :: cd,entr_rate_2d - real(kind=kind_phys), intent( out), dimension(its:ite,kts:kte) :: up_massentro, up_massdetro & + !real(kind=kind_phys), intent(in), optional , dimension(its:):: lambau + real(kind=kind_phys), intent(inout), optional , dimension(its:):: lambau + real(kind=kind_phys), intent(in) , dimension(its:,kts:) :: zo_cup,zuo + real(kind=kind_phys), intent(inout), dimension(its:,kts:) :: cd,entr_rate_2d + real(kind=kind_phys), intent( out), dimension(its:,kts:) :: up_massentro, up_massdetro & ,up_massentr, up_massdetr - real(kind=kind_phys), intent( out), dimension(its:ite,kts:kte), optional :: & + real(kind=kind_phys), intent( out), dimension(its:,kts:), optional :: & up_massentru,up_massdetru !$acc declare copy(lambau,cd,entr_rate_2d) copyin(zo_cup,zuo) copyout(up_massentro, up_massdetro,up_massentr, up_massdetr) !$acc declare copyout(up_massentro, up_massdetro,up_massentr, up_massdetr, up_massentru,up_massdetru) @@ -5437,10 +5437,10 @@ subroutine get_partition_liq_ice(ierr,tn,po_cup, p_liq_ice,melting_layer implicit none character *(*), intent (in) :: cumulus integer ,intent (in ) :: itf,ktf, its,ite, kts,kte - real(kind=kind_phys), intent (in ), dimension(its:ite,kts:kte) :: tn,po_cup - real(kind=kind_phys), intent (inout), dimension(its:ite,kts:kte) :: p_liq_ice,melting_layer + real(kind=kind_phys), intent (in ), dimension(its:,kts:) :: tn,po_cup + real(kind=kind_phys), intent (inout), dimension(its:,kts:) :: p_liq_ice,melting_layer !$acc declare copyin(tn,po_cup) copy(p_liq_ice,melting_layer) - integer , intent (in ), dimension(its:ite) :: ierr + integer , intent (in ), dimension(its:) :: ierr !$acc declare copyin(ierr) integer :: i,k real(kind=kind_phys) :: dp @@ -5539,11 +5539,11 @@ subroutine get_melting_profile(ierr,tn_cup,po_cup, p_liq_ice,melting_layer,qrco implicit none character *(*), intent (in) :: cumulus integer ,intent (in ) :: itf,ktf, its,ite, kts,kte - integer ,intent (in ), dimension(its:ite) :: ierr - real(kind=kind_phys) ,intent (in ), dimension(its:ite) :: edto - real(kind=kind_phys) ,intent (in ), dimension(its:ite,kts:kte) :: tn_cup,po_cup,qrco,pwo & + integer ,intent (in ), dimension(its:) :: ierr + real(kind=kind_phys) ,intent (in ), dimension(its:) :: edto + real(kind=kind_phys) ,intent (in ), dimension(its:,kts:) :: tn_cup,po_cup,qrco,pwo & ,pwdo,p_liq_ice,melting_layer - real(kind=kind_phys) ,intent (inout), dimension(its:ite,kts:kte) :: melting + real(kind=kind_phys) ,intent (inout), dimension(its:,kts:) :: melting !$acc declare copyin(ierr,edto,tn_cup,po_cup,qrco,pwo,pwdo,p_liq_ice,melting_layer,melting) integer :: i,k real(kind=kind_phys) :: dp @@ -5615,13 +5615,13 @@ subroutine get_cloud_top(name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo,heso_cup,z_c kstabi,k22,kbcon,its,ite,itf,kts,kte,ktf,zuo,kpbl,klcl,hcot) implicit none integer, intent(in) :: its,ite,itf,kts,kte,ktf - real(kind=kind_phys), dimension (its:ite,kts:kte),intent (inout) :: entr_rate_2d,zuo - real(kind=kind_phys), dimension (its:ite,kts:kte),intent (in) ::p_cup, heo,heso_cup,z_cup - real(kind=kind_phys), dimension (its:ite),intent (in) :: hkbo - integer, dimension (its:ite),intent (in) :: kstabi,k22,kbcon,kpbl,klcl - integer, dimension (its:ite),intent (inout) :: ierr,ktop + real(kind=kind_phys), dimension (its:,kts:),intent (inout) :: entr_rate_2d,zuo + real(kind=kind_phys), dimension (its:,kts:),intent (in) ::p_cup, heo,heso_cup,z_cup + real(kind=kind_phys), dimension (its:),intent (in) :: hkbo + integer, dimension (its:),intent (in) :: kstabi,k22,kbcon,kpbl,klcl + integer, dimension (its:),intent (inout) :: ierr,ktop !$acc declare copy(entr_rate_2d,zuo,ierr,ktop) copyin(p_cup, heo,heso_cup,z_cup,hkbo,kstabi,k22,kbcon,kpbl,klcl) - real(kind=kind_phys), dimension (its:ite,kts:kte) :: hcot + real(kind=kind_phys), dimension (its:,kts:) :: hcot !$acc declare create(hcot) character *(*), intent (in) :: name real(kind=kind_phys) :: dz,dh, dbythresh @@ -5644,7 +5644,7 @@ subroutine get_cloud_top(name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo,heso_cup,z_c kfinalzu=ktf-2 ktop(i)=kfinalzu if(ierr(i).eq.0)then - dby (kts:kte)=0.0 + dby (kts:)=0.0 start_level(i)=kbcon(i) !-- hcot below kbcon @@ -5704,16 +5704,16 @@ subroutine calculate_updraft_velocity(its,itf,ktf,ite,kts,kte,ierr,progsigma, implicit none logical, intent(in) :: progsigma integer, intent(in) :: itf,its,ktf,ite,kts,kte - integer, dimension (its:ite), intent(inout) :: ierr - real(kind=kind_phys), dimension (its:ite,kts:kte),intent (in) :: zo,entr_rate_2d, & + integer, dimension (its:), intent(inout) :: ierr + real(kind=kind_phys), dimension (its:,kts:),intent (in) :: zo,entr_rate_2d, & cd,po,qeso,to,qo,dbyo,clw_all,qlk,delp,zu - integer, dimension (its:ite),intent(in) :: k22,kbcon,ktcon + integer, dimension (its:),intent(in) :: k22,kbcon,ktcon real(kind=kind_phys), dimension (its:ite) :: sumx real(kind=kind_phys) ,intent (in) :: fv,rd,el2orc real(kind=kind_phys), dimension (its:ite,kts:kte) :: drag, buo, zi, del - real(kind=kind_phys), dimension (its:ite,kts:kte),intent (out) :: wu2,omega_u, & + real(kind=kind_phys), dimension (its:,kts:),intent (out) :: wu2,omega_u, & zeta,zdqca - real(kind=kind_phys), dimension (its:ite),intent(out) :: wc,omegac + real(kind=kind_phys), dimension (its:),intent(out) :: wc,omegac real(kind=kind_phys) :: rho,bb1,bb2,dz,dp,ptem,tem1,ptem1,tem,rfact,gamma,val integer :: i,k diff --git a/physics/cu_c3_sh.F90 b/physics/cu_c3_sh.F90 index 0ea0f28ae..2568a26e6 100644 --- a/physics/cu_c3_sh.F90 +++ b/physics/cu_c3_sh.F90 @@ -95,23 +95,23 @@ subroutine cu_c3_sh_run ( & ! outq = output q tendency (per s) ! outqc = output qc tendency (per s) ! pre = output precip - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (inout ) :: & cnvwt,outt,outq,outqc,cupclw,zuo,outu,outv !$acc declare copy(cnvwt,outt,outq,outqc,cupclw,zuo,outu,outv) - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (in ) :: & tmf, qmicro, sigmain, forceqv_spechum - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (out ) :: & xmb_out - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (inout ) :: & ierr - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (out ) :: & kbcon,ktop,k22 - integer, dimension (its:ite) & + integer, dimension (its:) & ,intent (in ) :: & kpbl,tropics !$acc declare copyout(xmb_out,kbcon,ktop,k22) copyin(kpbl,tropics) copy(ierr) @@ -119,13 +119,13 @@ subroutine cu_c3_sh_run ( & ! basic environmental input includes a flag (ierr) to turn off ! convection for this call only and at that particular gridpoint ! - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (in ) :: & t,po,tn,dhdt,rho,us,vs,delp - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (inout) :: & q,qo - real(kind=kind_phys), dimension (its:ite) & + real(kind=kind_phys), dimension (its:) & ,intent (in ) :: & xland,z1,psur,hfx,qfx,dx @@ -133,7 +133,7 @@ subroutine cu_c3_sh_run ( & ,intent (in ) :: & dtime,tcrit,fv,r_d !$acc declare sigmaout - real(kind=kind_phys), dimension (its:ite,kts:kte) & + real(kind=kind_phys), dimension (its:,kts:) & ,intent (out) :: & sigmaout @@ -245,7 +245,7 @@ subroutine cu_c3_sh_run ( & real(kind=kind_phys) buo_flux,pgeoh,dp,entup,detup,totmas real(kind=kind_phys) xff_shal(3),blqe,xkshal - character*50 :: ierrc(its:ite) + character*50 :: ierrc(its:) real(kind=kind_phys), dimension (its:ite,kts:kte) :: & up_massentr,up_massdetr,up_massentro,up_massdetro,up_massentru,up_massdetru !$acc declare create(up_massentr,up_massdetr,up_massentro,up_massdetro,up_massentru,up_massdetru) From 26ca9f9c3d08aa5ddc5cb414c1a0377d1fb5fae2 Mon Sep 17 00:00:00 2001 From: dustinswales Date: Wed, 6 Sep 2023 10:57:28 -0600 Subject: [PATCH 327/380] Renamed file --- ...s_diagnostics.F90 => GFS_physics_post.F90} | 30 +++++++++---------- ...diagnostics.meta => GFS_physics_post.meta} | 6 ++-- physics/ozphys_2015.F90 | 1 + 3 files changed, 19 insertions(+), 18 deletions(-) rename physics/{GFS_physics_diagnostics.F90 => GFS_physics_post.F90} (81%) rename physics/{GFS_physics_diagnostics.meta => GFS_physics_post.meta} (97%) diff --git a/physics/GFS_physics_diagnostics.F90 b/physics/GFS_physics_post.F90 similarity index 81% rename from physics/GFS_physics_diagnostics.F90 rename to physics/GFS_physics_post.F90 index 0c6197bc2..d034c1999 100644 --- a/physics/GFS_physics_diagnostics.F90 +++ b/physics/GFS_physics_post.F90 @@ -1,20 +1,20 @@ ! ########################################################################################### -!> \file GFS_physics_diagnostics.F90 +!> \file GFS_physics_post.F90 !! ! ########################################################################################### -module GFS_physics_diagnostics +module GFS_physics_post use machine, only : kind_phys, kind_dbl_prec, kind_sngl_prec implicit none - public GFS_physics_diagnostics_init, GFS_physics_diagnostics_run + public GFS_physics_post_init, GFS_physics_post_run contains ! ########################################################################################### -! SUBROUTINE GFS_physics_diagnostics_init +! SUBROUTINE GFS_physics_post_init ! ########################################################################################### -!! \section arg_table_GFS_physics_diagnostics_init Argument Table -!! \htmlinclude GFS_physics_diagnostics_init.html +!! \section arg_table_GFS_physics_post_init Argument Table +!! \htmlinclude GFS_physics_post_init.html !! - subroutine GFS_physics_diagnostics_init(errmsg, errflg) + subroutine GFS_physics_post_init(errmsg, errflg) ! Outputs character(len=*), intent(out) :: & @@ -22,15 +22,15 @@ subroutine GFS_physics_diagnostics_init(errmsg, errflg) integer, intent(out) :: & errflg ! CCPP error flag - end subroutine GFS_physics_diagnostics_init + end subroutine GFS_physics_post_init ! ########################################################################################### -! SUBROUTINE GFS_physics_diagnostics_run +! SUBROUTINE GFS_physics_post_run ! ########################################################################################### -!! \section arg_table_GFS_physics_diagnostics_run Argument Table -!! \htmlinclude GFS_physics_diagnostics_run.html +!! \section arg_table_GFS_physics_post_run Argument Table +!! \htmlinclude GFS_physics_post_run.html !! - subroutine GFS_physics_diagnostics_run(nCol, nLev, ntoz, dtidx, ip_prod_loss, ip_ozmix, & + subroutine GFS_physics_post_run(nCol, nLev, ntoz, dtidx, ip_prod_loss, ip_ozmix, & ip_temp, ip_overhead_ozone, do3_dt_prd, do3_dt_ozmx, do3_dt_temp, do3_dt_ohoz, dtend,& errmsg, errflg) ! Inputs @@ -69,7 +69,7 @@ subroutine GFS_physics_diagnostics_run(nCol, nLev, ntoz, dtidx, ip_prod_loss, ip ! ####################################################################################### ! - ! Ozone physics diagnostics + ! Ozone physics diagnostic ! ! ####################################################################################### idtend = dtidx(100+ntoz,ip_prod_loss) @@ -92,6 +92,6 @@ subroutine GFS_physics_diagnostics_run(nCol, nLev, ntoz, dtidx, ip_prod_loss, ip dtend(:,:,idtend) = dtend(:,:,idtend) + do3_dt_ohoz endif - end subroutine GFS_physics_diagnostics_run + end subroutine GFS_physics_post_run -end module GFS_physics_diagnostics +end module GFS_physics_post diff --git a/physics/GFS_physics_diagnostics.meta b/physics/GFS_physics_post.meta similarity index 97% rename from physics/GFS_physics_diagnostics.meta rename to physics/GFS_physics_post.meta index b6036b0c9..8b5120b9e 100644 --- a/physics/GFS_physics_diagnostics.meta +++ b/physics/GFS_physics_post.meta @@ -1,11 +1,11 @@ [ccpp-table-properties] - name = GFS_physics_diagnostics + name = GFS_physics_post type = scheme dependencies = machine.F ######################################################################## [ccpp-arg-table] - name = GFS_physics_diagnostics_init + name = GFS_physics_post_init type = scheme [errmsg] standard_name = ccpp_error_message @@ -25,7 +25,7 @@ ######################################################################## [ccpp-arg-table] - name = GFS_physics_diagnostics_run + name = GFS_physics_post_run type = scheme [nCol] standard_name = horizontal_loop_extent diff --git a/physics/ozphys_2015.F90 b/physics/ozphys_2015.F90 index 9898c71e4..47386bd6e 100644 --- a/physics/ozphys_2015.F90 +++ b/physics/ozphys_2015.F90 @@ -17,6 +17,7 @@ module ozphys_2015 !! \c ozprdlos_2015_new_sbuvO3_tclm15_nuchem.f77) provided by Naval !! Research Laboratory through CHEM2D chemistry model !! (McCormack et al. (2006) \cite mccormack_et_al_2006). +!! (https://doi.org/10.5194/acp-6-4943-2006) !! !> \section genal_ozphys_2015 GFS ozphys_2015_run General Algorithm !> - This code assumes that both prsl and po3 are from bottom to top From c0ec619536bd29740627cb2dc1da106b61dd435c Mon Sep 17 00:00:00 2001 From: Michael Toy Date: Tue, 19 Sep 2023 02:36:14 +0000 Subject: [PATCH 328/380] Added tendency limiter for mesosphere and horizontal wave number filter for orographic gravity wave drag in UGWP -- Issue #95 --- physics/drag_suite.F90 | 26 ++++++++++++++++++++++++-- 1 file changed, 24 insertions(+), 2 deletions(-) diff --git a/physics/drag_suite.F90 b/physics/drag_suite.F90 index 22f122e71..ff68f4216 100644 --- a/physics/drag_suite.F90 +++ b/physics/drag_suite.F90 @@ -460,6 +460,8 @@ subroutine drag_suite_run( & real(kind=kind_phys), parameter :: ce = 0.8 real(kind=kind_phys), parameter :: cg = 0.5 real(kind=kind_phys), parameter :: sgmalolev = 0.5 ! max sigma lvl for dtfac + real(kind=kind_phys), parameter :: plolevmeso = 70.0 ! pres lvl for mesosphere OGWD reduction (Pa) + real(kind=kind_phys), parameter :: facmeso = 0.5 ! fractional velocity reduction for OGWD integer,parameter :: kpblmin = 2 ! @@ -472,7 +474,7 @@ subroutine drag_suite_run( & rcsks,wdir,ti,rdz,tem2,dw2,shr2, & bvf2,rdelks,wtkbj,tem,gfobnv,hd,fro, & rim,temc,tem1,efact,temv,dtaux,dtauy, & - dtauxb,dtauyb,eng0,eng1 + dtauxb,dtauyb,eng0,eng1,ksmax,dtfac_meso ! logical :: ldrag(im),icrilv(im), & flag(im),kloop1(im) @@ -887,6 +889,14 @@ subroutine drag_suite_run( & ldrag(i) = ldrag(i) .or. bnv2(i,1).le.0.0 ldrag(i) = ldrag(i) .or. ulow(i).eq.1.0 ldrag(i) = ldrag(i) .or. var_stoch(i) .le. 0.0 +! Check if mesoscale gravity waves will propagate vertically or be evanescent +! and not impart a drag force -- consider the maximum sub-grid horizontal +! topographic wavelength to be one-half the horizontal grid spacing -- calculate +! ksmax accordingly + ksmax = 4.0*pi/dx(i) ! based on wavelength = 0.5*dx(i) + if ( bnv2(i,1).gt.0.0 ) then + ldrag(i) = ldrag(i) .or. sqrt(bnv2(i,1))*rulow(i).lt.ksmax + endif ! ! set all ri low level values to the low level value ! @@ -1106,7 +1116,19 @@ subroutine drag_suite_run( & enddo ! do k = kts,km - taud_ms(i,k) = taud_ms(i,k)*dtfac(i)* ls_taper(i) *(1.-rstoch(i)) + + ! Check if well into mesosphere -- if so, perform similar reduction of + ! velocity tendency due to mesoscale GWD to prevent sudden reversal of + ! wind direction (similar to above) + dtfac_meso = 1.0 + if (prsl(i,k).le.plolevmeso) then + if (taud_ms(i,k).ne.0.) & + dtfac_meso = min(dtfac_meso,facmeso*abs(velco(i,k) & + /(deltim*rcs*taud_ms(i,k)))) + end if + + taud_ms(i,k) = taud_ms(i,k)*dtfac(i)*dtfac_meso* & + ls_taper(i) *(1.-rstoch(i)) taud_bl(i,k) = taud_bl(i,k)*dtfac(i)* ls_taper(i) *(1.-rstoch(i)) dtaux = taud_ms(i,k) * xn(i) From ab84c01a110bbf13490fcf3243effe06cb26608d Mon Sep 17 00:00:00 2001 From: "Haiqin.Li" Date: Wed, 20 Sep 2023 01:29:56 +0000 Subject: [PATCH 329/380] "GF radar reflectivity, dust bug fix, and C3 updates" --- physics/GFS_rrtmg_pre.F90 | 2 +- physics/cu_c3_deep.F90 | 16 +++-- physics/cu_c3_driver.F90 | 4 +- physics/cu_c3_sh.F90 | 10 ++-- physics/cu_gf_driver_post.F90 | 11 ++-- physics/smoke_dust/dust_data_mod.F90 | 32 ++++------ physics/smoke_dust/dust_fengsha_mod.F90 | 70 +++++++++++++++++----- physics/smoke_dust/rrfs_smoke_wrapper.F90 | 22 ++++--- physics/smoke_dust/rrfs_smoke_wrapper.meta | 36 +++++++++-- 9 files changed, 138 insertions(+), 65 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 4f4de181a..fff4ae0b9 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -976,7 +976,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& & imp_physics_mg, iovr, iovr_rand, iovr_maxrand, iovr_max, & & iovr_dcorr, iovr_exp, iovr_exprand, idcor, idcor_con, & & idcor_hogan, idcor_oreopoulos, lcrick, lcnorm, & - & imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_gf, do_mynnedmf, & + & imfdeepcnv, imfdeepcnv_gf, imfdeepcnv_c3, do_mynnedmf, & & lgfdlmprad, & & uni_cld, lmfshal, lmfdeep2, cldcov, clouds1, & & effrl, effri, effrr, effrs, effr_in, & diff --git a/physics/cu_c3_deep.F90 b/physics/cu_c3_deep.F90 index c3a4b2c4e..d1b490c77 100644 --- a/physics/cu_c3_deep.F90 +++ b/physics/cu_c3_deep.F90 @@ -2078,9 +2078,9 @@ subroutine cu_c3_deep_run( & !> - Call rain_evap_below_cloudbase() to calculate evaporation below cloud base - call rain_evap_below_cloudbase(itf,ktf,its,ite, & - kts,kte,ierr,kbcon,xmb,psur,xland,qo_cup, & - po_cup,qes_cup,pwavo,edto,pwevo,pre,outt,outq) !,outbuoy) +! call rain_evap_below_cloudbase(itf,ktf,its,ite, & +! kts,kte,ierr,kbcon,xmb,psur,xland,qo_cup, & +! po_cup,qes_cup,pwavo,edto,pwevo,pre,outt,outq) !,outbuoy) k=1 !$acc kernels @@ -2137,7 +2137,7 @@ subroutine cu_c3_deep_run( & do k = ktop(i), 1, -1 rain = pwo(i,k) + edto(i) * pwdo(i,k) rn(i) = rn(i) + rain * xmb(i) * .001 * dtime - !if(po(i,k).gt.400.)then + if(k.gt.jmin(i))then if(flg(i))then q1=qo(i,k)+(outq(i,k))*dtime t1=tn(i,k)+(outt(i,k))*dtime @@ -2162,7 +2162,7 @@ subroutine cu_c3_deep_run( & pre(i)=max(pre(i),0.) delqev(i) = delqev(i) + .001*dp*qevap(i)/g endif - !endif ! 400mb + endif endif enddo ! pre(i)=1000.*rn(i)/dtime @@ -4429,7 +4429,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & ! !now do the rest ! - kklev(i)=maxloc(zu(i,:),1) + kklev(i)=maxloc(zu(i,2:ktop(i)),1) !$acc loop seq do k=kbcon(i)+1,ktop(i) if(t(i,k) > 273.16) then @@ -4489,6 +4489,10 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & endif if(k.gt.kbcon(i)+1)c1d(i,k)=clwdet*up_massdetr(i,k-1) if(k.gt.kbcon(i)+1)c1d_b(i,k)=clwdet*up_massdetr(i,k-1) + !if(is_deep.and.k.gt.kklev(i))then + c1d(i,k)=0.005 + c1d_b(i,k)=0.005 + !endif if(autoconv.eq.2) then ! diff --git a/physics/cu_c3_driver.F90 b/physics/cu_c3_driver.F90 index fd4d37b0b..270e01989 100644 --- a/physics/cu_c3_driver.F90 +++ b/physics/cu_c3_driver.F90 @@ -340,8 +340,8 @@ subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ! !> - Set tuning constants for radiation coupling ! - tun_rad_shall(:)=.01 - tun_rad_mid(:)=.3 !.02 + tun_rad_shall(:)=.012 + tun_rad_mid(:)=.15 !.02 tun_rad_deep(:)=.3 !.065 edt(:)=0. edtm(:)=0. diff --git a/physics/cu_c3_sh.F90 b/physics/cu_c3_sh.F90 index 0ea0f28ae..d2b9a71b2 100644 --- a/physics/cu_c3_sh.F90 +++ b/physics/cu_c3_sh.F90 @@ -6,12 +6,12 @@ module cu_c3_sh use progsigma, only : progsigma_calc !real(kind=kind_phys), parameter:: c1_shal=0.0015! .0005 - real(kind=kind_phys), parameter:: c1_shal=0. !0.005! .0005 real(kind=kind_phys), parameter:: g =9.81 real(kind=kind_phys), parameter:: cp =1004. real(kind=kind_phys), parameter:: xlv=2.5e6 real(kind=kind_phys), parameter:: r_v=461. - real(kind=kind_phys), parameter:: c0_shal=.001 + real(kind=kind_phys) :: c0_shal=.004 + real(kind=kind_phys) :: c1_shal=0. !0.005! .0005 real(kind=kind_phys), parameter:: fluxtune=1.5 contains @@ -274,6 +274,8 @@ subroutine cu_c3_sh_run ( & ktopx(i)=0 if(xland(i).gt.1.5 .or. xland(i).lt.0.5)then xland1(i)=0 + c0_shal=.001 + c1_shal=.001 ! ierr(i)=100 endif pre(i)=0. @@ -669,11 +671,11 @@ subroutine cu_c3_sh_run ( & if(qco(i,k)>=trash ) then dz=z_cup(i,k)-z_cup(i,k-1) ! cloud liquid water - c1d(i,k)=.02*up_massdetr(i,k-1) + c1d(i,k)=c1_shal! 0. !.02*up_massdetr(i,k-1) qrco(i,k)= (qco(i,k)-trash)/(1.+(c0_shal+c1d(i,k))*dz) if(qrco(i,k).lt.0.)then ! hli new test 02/12/19 qrco(i,k)=0. - c1d(i,k)=0. + !c1d(i,k)=0. endif pwo(i,k)=c0_shal*dz*qrco(i,k)*zuo(i,k) clw_all(i,k)=qco(i,k)-trash !LB total cloud before rain and detrain diff --git a/physics/cu_gf_driver_post.F90 b/physics/cu_gf_driver_post.F90 index 56da0feba..8c5896164 100644 --- a/physics/cu_gf_driver_post.F90 +++ b/physics/cu_gf_driver_post.F90 @@ -66,20 +66,21 @@ subroutine cu_gf_driver_post_run (im, km, t, q, prevst, prevsq, cactiv, cactiv_m conv_act_m(i)=0.0 endif ! reflectivity parameterization for parameterized convection (reference:Unipost MDLFLD.f) - if(sqrt(garea(i)).lt.6500.)then + !if(sqrt(garea(i)).lt.6500.)then ze = 0.0 ze_conv = 0.0 dbz_sum = 0.0 - cuprate = raincv(i) * 3600.0 / dt ! cu precip rate (mm/h) - ze_conv = 300.0 * cuprate**1.4 - if (maxupmf(i).gt.0.05) then + cuprate = max(0.1,1.e3*raincv(i) * 3600.0 / dt) ! cu precip rate (mm/h) + if(cuprate .lt. 0.05) cuprate=0. + ze_conv = 300.0 * cuprate**1.5 + if (maxupmf(i).gt.0.1 .and. cuprate.gt.0.) then do k = 1, km ze = 10._kind_phys ** (0.1 * refl_10cm(i,k)) dbz_sum = max(dbzmin, 10.0 * log10(ze + ze_conv)) refl_10cm(i,k) = dbz_sum enddo endif - endif + !endif enddo !$acc end kernels diff --git a/physics/smoke_dust/dust_data_mod.F90 b/physics/smoke_dust/dust_data_mod.F90 index a710701f1..eb809378d 100755 --- a/physics/smoke_dust/dust_data_mod.F90 +++ b/physics/smoke_dust/dust_data_mod.F90 @@ -44,24 +44,10 @@ module dust_data_mod ! Never used: ! real(kind_phys), parameter :: fengsha_alpha = 0.3 ! real(kind_phys), parameter :: fengsha_gamma = 1.3 + ! -- FENGSHA threshold velocities based on Dale A. Gillette's data integer, parameter :: fengsha_maxstypes = 13 -! real(kind_phys), dimension(fengsha_maxstypes) :: dust_uthres = & -! (/ 0.065, & ! Sand - 1 -! 0.20, & ! Loamy Sand - 2 -! 0.52, & ! Sandy Loam - 3 -! 0.50, & ! Silt Loam - 4 -! 0.50, & ! Silt - 5 -! 0.60, & ! Loam - 6 -! 0.73, & ! Sandy Clay Loam - 7 -! 0.73, & ! Silty Clay Loam - 8 -! 0.80, & ! Clay Loam - 9 -! 0.95, & ! Sandy Clay - 10 -! 0.95, & ! Silty Clay - 11 -! 1.00, & ! Clay - 12 -! 9.999 /) ! Other - 13 -! dust_uthres = 0.065, 0.18, 0.27, 0.30, 0.35, 0.38, 0.35, 0.41, 0.41, -! 0.45,0.50,0.45,9999.0 + real(kind_phys), dimension(fengsha_maxstypes), parameter :: dust_uthres = & (/ 0.065, & ! Sand - 1 0.18, & ! Loamy Sand - 2 @@ -76,12 +62,16 @@ module dust_data_mod 0.50, & ! Silty Clay - 11 0.45, & ! Clay - 12 9999.0 /) ! Other - 13 - ! -- FENGSHA uses precalculated drag partition from ASCAT. See: Prigent et al. (2012,2015) - integer, parameter :: dust_calcdrag = 1 - real(kind_phys) :: dust_alpha = 2.2 + ! -- FENGSHA uses precalculated drag partition + integer, parameter :: dust_calcdrag = 1 + ! -- FENGSHA dust moisture parameterization 1:fecan - 2:shao + integer :: dust_moist_opt = 1 + + real(kind_phys) :: dust_alpha = 1.0 real(kind_phys) :: dust_gamma = 1.0 - + real(kind_phys) :: dust_moist_correction = 1.0 + real(kind_phys) :: dust_drylimit_factor = 1.0 ! -- sea salt parameters integer, dimension(nsalt), parameter :: spoint = (/ 1, 2, 2, 2, 2, 2, 3, 3, 3 /) ! 1 Clay, 2 Silt, 3 Sand @@ -93,7 +83,7 @@ module dust_data_mod (/ 1., 0.2, 0.2, 0.2, 0.2, 0.2, 0.333, 0.333, 0.333 /) - ! -- soil vagatation parameters + ! -- soil vegatation parameters integer, parameter :: max_soiltyp = 30 real(kind_phys), dimension(max_soiltyp), parameter :: & maxsmc = (/ 0.421, 0.464, 0.468, 0.434, 0.406, 0.465, & diff --git a/physics/smoke_dust/dust_fengsha_mod.F90 b/physics/smoke_dust/dust_fengsha_mod.F90 index 54a64239d..1e24c8947 100755 --- a/physics/smoke_dust/dust_fengsha_mod.F90 +++ b/physics/smoke_dust/dust_fengsha_mod.F90 @@ -61,6 +61,8 @@ subroutine gocart_dust_fengsha_driver(dt, & REAL(kind_phys), INTENT(IN) :: dt ! time step REAL(kind_phys), INTENT(IN) :: g ! gravity (m/s**2) + + ! Local variables integer :: nmx,i,j,k,imx,jmx,lmx integer :: ilwi @@ -75,6 +77,7 @@ subroutine gocart_dust_fengsha_driver(dt, & real(kind_phys), DIMENSION (num_emis_dust) :: distribution real(kind_phys), dimension (3) :: massfrac real(kind_phys) :: erodtot + real(kind_phys) :: moist_volumetric ! conversion values conver=1.e-9 @@ -174,10 +177,13 @@ subroutine gocart_dust_fengsha_driver(dt, & endif endif + ! soil moisture correction factor + moist_volumetric = dust_moist_correction * smois(i,2,j) + ! Call dust emission routine. call source_dust(imx,jmx, lmx, nmx, dt, tc, ustar, massfrac, & - erodtot, dxy, smois(i,1,j), airden, airmas, bems, g, dust_alpha, dust_gamma, & + erodtot, dxy, moist_volumetric, airden, airmas, bems, g, dust_alpha, dust_gamma, & R, uthr(i,j)) ! convert back to concentration @@ -457,10 +463,16 @@ subroutine DustEmissionFENGSHA(slc, clay, sand, silt, & ! Now compute size-dependent total emission flux ! ---------------------------------------------- - ! Fecan moisture correction - ! ------------------------- - h = moistureCorrectionFecan(slc, sand, clay, rhop) - + + if (dust_moist_opt .eq. 1) then + + ! Fecan moisture correction + ! ------------------------- + h = moistureCorrectionFecan(slc, sand, clay) + else + ! shao soil moisture correction + h = moistureCorrectionShao(slc) + end if ! Adjust threshold ! ---------------- u_thresh = uthrs * h @@ -478,7 +490,7 @@ subroutine DustEmissionFENGSHA(slc, clay, sand, silt, & end subroutine DustEmissionFENGSHA !----------------------------------------------------------------- - real function soilMoistureConvertVol2Grav(vsoil, sandfrac, rhop) + real function soilMoistureConvertVol2Grav(vsoil, sandfrac) ! !USES: implicit NONE @@ -486,7 +498,6 @@ real function soilMoistureConvertVol2Grav(vsoil, sandfrac, rhop) ! !INPUT PARAMETERS: REAL(kind_phys), intent(in) :: vsoil ! volumetric soil moisture fraction [1] REAL(kind_phys), intent(in) :: sandfrac ! fractional sand content [1] - REAL(kind_phys), intent(in) :: rhop ! dry dust density [kg m-3] ! !DESCRIPTION: Convert soil moisture fraction from volumetric to gravimetric. ! @@ -500,20 +511,21 @@ real function soilMoistureConvertVol2Grav(vsoil, sandfrac, rhop) ! !CONSTANTS: REAL(kind_phys), parameter :: rhow = 1000. ! density of water [kg m-3] - + REAL(kind_phys), parameter :: rhop = 1700. ! density of dry soil !EOP !------------------------------------------------------------------------- ! Begin... ! Saturated volumetric water content (sand-dependent) ! [m3 m-3] - vsat = 0.489 - 0.00126 * ( 100. * sandfrac ) + vsat = 0.489 - 0.126 * sandfrac + ! Gravimetric soil content - soilMoistureConvertVol2Grav = vsoil * rhow / (rhop * (1. - vsat)) + soilMoistureConvertVol2Grav = 100.0 * (vsoil * rhow / rhop / ( 1. - vsat)) end function soilMoistureConvertVol2Grav !---------------------------------------------------------------- - real function moistureCorrectionFecan(slc, sand, clay, rhop) + real function moistureCorrectionFecan(slc, sand, clay) ! !USES: implicit NONE @@ -522,7 +534,6 @@ real function moistureCorrectionFecan(slc, sand, clay, rhop) REAL(kind_phys), intent(in) :: slc ! liquid water content of top soil layer, volumetric fraction [1] REAL(kind_phys), intent(in) :: sand ! fractional sand content [1] REAL(kind_phys), intent(in) :: clay ! fractional clay content [1] - REAL(kind_phys), intent(in) :: rhop ! dry dust density [kg m-3] ! !DESCRIPTION: Compute correction factor to account for Fecal soil moisture ! @@ -540,15 +551,46 @@ real function moistureCorrectionFecan(slc, sand, clay, rhop) ! Begin... ! Convert soil moisture from volumetric to gravimetric - grvsoilm = soilMoistureConvertVol2Grav(slc, sand, 2650.) + grvsoilm = soilMoistureConvertVol2Grav(slc, sand) ! Compute fecan dry limit - drylimit = clay * (14.0 * clay + 17.0) + drylimit = dust_drylimit_factor * clay * (14.0 * clay + 17.0) ! Compute soil moisture correction moistureCorrectionFecan = sqrt(1.0 + 1.21 * max(0., grvsoilm - drylimit)**0.68) end function moistureCorrectionFecan +!---------------------------------------------------------------- + real function moistureCorrectionShao(slc) + +! !USES: + implicit NONE + +! !INPUT PARAMETERS: + REAL(kind_phys), intent(in) :: slc ! liquid water content of top soil layer, volumetric fraction [1] + +! !DESCRIPTION: Compute correction factor to account for Fecal soil moisture +! +! !REVISION HISTORY: +! +! 02Apr2020, B.Baker/NOAA - Original implementation +! 01Apr2020, R.Montuoro/NOAA - Adapted for GOCART process library + +! !Local Variables + real :: grvsoilm + real :: drylimit + +!EOP +!--------------------------------------------------------------- +! Begin... + + if (slc < 0.03) then + moistureCorrectionShao = exp(22.7 * slc) + else + moistureCorrectionShao = exp(95.3 * slc - 2.029) + end if + + end function moistureCorrectionShao !--------------------------------------------------------------- real function DustFluxV2HRatioMB95(clay, kvhmax) diff --git a/physics/smoke_dust/rrfs_smoke_wrapper.F90 b/physics/smoke_dust/rrfs_smoke_wrapper.F90 index 1f9ef6340..7b69fc9e3 100755 --- a/physics/smoke_dust/rrfs_smoke_wrapper.F90 +++ b/physics/smoke_dust/rrfs_smoke_wrapper.F90 @@ -12,7 +12,8 @@ module rrfs_smoke_wrapper num_moist, num_chem, num_emis_seas, num_emis_dust, & DUST_OPT_FENGSHA, p_qv, p_atm_shum, p_atm_cldq, & p_smoke, p_dust_1, p_coarse_pm, epsilc - use dust_data_mod, only : dust_alpha, dust_gamma + use dust_data_mod, only : dust_alpha, dust_gamma, dust_moist_opt, & + dust_moist_correction, dust_drylimit_factor use plume_data_mod, only : p_frp_std, p_frp_hr, num_frp_plume use seas_mod, only : gocart_seasalt_driver use dust_fengsha_mod, only : gocart_dust_fengsha_driver @@ -49,6 +50,7 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, ebb_smoke_hr, frp_hr, frp_std_hr, & coef_bb, ebu_smoke,fhist, min_fplume, max_fplume, hwp, wetness, & smoke_ext, dust_ext, ndvel, ddvel_inout,rrfs_sd, & + dust_moist_opt_in, dust_moist_correction_in, dust_drylimit_factor_in, & dust_alpha_in, dust_gamma_in, fire_in, & seas_opt_in, dust_opt_in, drydep_opt_in, coarsepm_settling_in, & do_plumerise_in, plumerisefire_frq_in, addsmoke_flag_in, & @@ -91,12 +93,15 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, real(kind_phys), dimension(:,:), intent(out) :: smoke_ext, dust_ext real(kind_phys), dimension(:,:), intent(inout) :: nwfa, nifa real(kind_phys), dimension(:,:), intent(inout) :: ddvel_inout - real (kind=kind_phys), dimension(:), intent(in) :: wetness - integer, intent(in ) :: imp_physics, imp_physics_thompson - real (kind=kind_phys), intent(in) :: dust_alpha_in, dust_gamma_in, wetdep_ls_alpha_in - integer, intent(in) :: seas_opt_in, dust_opt_in, drydep_opt_in, & - coarsepm_settling_in, plumerisefire_frq_in, & - addsmoke_flag_in, wetdep_ls_opt_in + real(kind_phys), dimension(:), intent(in) :: wetness + real(kind_phys), intent(in) :: dust_alpha_in, dust_gamma_in, wetdep_ls_alpha_in + real(kind_phys), intent(in) :: dust_moist_correction_in + real(kind_phys), intent(in) :: dust_drylimit_factor_in + integer, intent(in) :: dust_moist_opt_in + integer, intent(in) :: imp_physics, imp_physics_thompson + integer, intent(in) :: seas_opt_in, dust_opt_in, drydep_opt_in, & + coarsepm_settling_in, plumerisefire_frq_in, & + addsmoke_flag_in, wetdep_ls_opt_in logical, intent(in ) :: do_plumerise_in, rrfs_sd character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -314,6 +319,9 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, ! Set at compile time in dust_data_mod: dust_alpha = dust_alpha_in dust_gamma = dust_gamma_in + dust_moist_opt = dust_moist_opt_in + dust_moist_correction = dust_moist_correction_in + dust_drylimit_factor = dust_drylimit_factor_in call gocart_dust_fengsha_driver(dt,chem,rho_phy,smois,p8w,ssm, & isltyp,vegfrac,snowh,xland,dxy,g,emis_dust,ust,znt, & clayf,sandf,rdrag,uthr, & diff --git a/physics/smoke_dust/rrfs_smoke_wrapper.meta b/physics/smoke_dust/rrfs_smoke_wrapper.meta index bf2fddd60..a0a641246 100755 --- a/physics/smoke_dust/rrfs_smoke_wrapper.meta +++ b/physics/smoke_dust/rrfs_smoke_wrapper.meta @@ -210,17 +210,17 @@ kind = kind_phys intent = in [nsoil] - standard_name = vertical_dimension_of_soil - long_name = soil vertical layer dimension + standard_name = vertical_dimension_of_soil_internal_to_land_surface_scheme + long_name = number of soil layers internal to land surface model units = count dimensions = () type = integer intent = in [smc] - standard_name = volume_fraction_of_condensed_water_in_soil - long_name = volumetric fraction of soil moisture + standard_name = volume_fraction_of_soil_moisture_for_land_surface_model + long_name = volumetric fraction of soil moisture for lsm units = frac - dimensions = (horizontal_loop_extent,vertical_dimension_of_soil) + dimensions = (horizontal_dimension,vertical_dimension_of_soil_internal_to_land_surface_scheme) type = real kind = kind_phys intent = inout @@ -612,6 +612,32 @@ dimensions = () type = logical intent = in +[dust_moist_opt_in] + standard_name = control_for_dust_soil_moisture_option + long_name = smoke dust moisture parameterization 1 - fecan 2 - shao + units = index + dimensions = () + type = integer + active = (do_smoke_coupling) + intent = in +[dust_moist_correction_in] + standard_name = dust_moist_correction_fengsha_dust_scheme + long_name = moisture correction term for fengsha dust emission + units = none + dimensions = () + type = real + kind = kind_phys + active = (do_smoke_coupling) + intent = in +[dust_drylimit_factor_in] + standard_name = dust_drylimit_factor_fengsha_dust_scheme + long_name = moisture correction term for drylimit in fengsha dust emission + units = none + dimensions = () + type = real + kind = kind_phys + active = (do_smoke_coupling) + intent = in [dust_alpha_in] standard_name = alpha_fengsha_dust_scheme long_name = alpha paramter for fengsha dust scheme From 5612a96edecac3fe931cdc3a8754dfd6e1532df0 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 21 Sep 2023 20:53:34 +0000 Subject: [PATCH 330/380] Fix race condition in GFS_phys_time_vary.fv3.F90 error detection --- physics/GFS_phys_time_vary.fv3.F90 | 67 +++++++++++++++++++++++------- physics/noahmp_tables.f90 | 18 ++++---- 2 files changed, 60 insertions(+), 25 deletions(-) diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index a10c10d1b..04348f6dc 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -61,6 +61,22 @@ module GFS_phys_time_vary contains + subroutine copy_error(myerrmsg, myerrflg, errmsg, errflg) + implicit none + character(*), intent(in) :: myerrmsg + integer, intent(in) :: myerrflg + character(*), intent(out) :: errmsg + integer, intent(inout) :: errflg + if(myerrflg == 0) return + if(errflg /= 0) return + !$OMP CRITICAL + if(errflg == 0) then + errmsg = myerrmsg + errflg = myerrflg + endif + !$OMP END CRITICAL + end subroutine copy_error + !> \section arg_table_GFS_phys_time_vary_init Argument Table !! \htmlinclude GFS_phys_time_vary_init.html !! @@ -192,6 +208,9 @@ subroutine GFS_phys_time_vary_init ( real(kind=kind_phys), dimension(:), allocatable :: dzsno real(kind=kind_phys), dimension(:), allocatable :: dzsnso + integer :: myerrflg + character(255) :: myerrmsg + ! Initialize CCPP error handling variables errmsg = '' errflg = 0 @@ -215,7 +234,7 @@ subroutine GFS_phys_time_vary_init ( !$OMP shared (do_ugwp_v1,jindx1_tau,jindx2_tau,ddy_j1tau,ddy_j2tau) & !$OMP shared (isot,ivegsrc,nlunit,sncovr,sncovr_ice,lsm,lsm_ruc) & !$OMP shared (min_seaice,fice,landfrac,vtype,weasd,snupx,salp_data) & -!$OMP private (ix,i,j,rsnow,vegtyp) +!$OMP private (ix,i,j,rsnow,vegtyp,myerrmsg,myerrflg) !$OMP sections @@ -227,16 +246,18 @@ subroutine GFS_phys_time_vary_init ( ! oz_coeff in GFS_typedefs.F90 match what is set by read_o3data ! in GFS_typedefs.F90: allocate (Tbd%ozpl (IM,levozp,oz_coeff)) if (size(ozpl, dim=2).ne.levozp) then - write(errmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", & + myerrflg = 1 + write(myerrmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", & "levozp from read_o3data does not match value in GFS_typedefs.F90: ", & levozp, " /= ", size(ozpl, dim=2) - errflg = 1 + call copy_error(myerrmsg, myerrflg, errmsg, errflg) end if if (size(ozpl, dim=3).ne.oz_coeff) then - write(errmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", & + myerrflg = 1 + write(myerrmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", & "oz_coeff from read_o3data does not match value in GFS_typedefs.F90: ", & oz_coeff, " /= ", size(ozpl, dim=3) - errflg = 1 + call copy_error(myerrmsg, myerrflg, errmsg, errflg) end if !$OMP section @@ -247,16 +268,18 @@ subroutine GFS_phys_time_vary_init ( ! h2o_coeff in GFS_typedefs.F90 match what is set by read_o3data ! in GFS_typedefs.F90: allocate (Tbd%h2opl (IM,levh2o,h2o_coeff)) if (size(h2opl, dim=2).ne.levh2o) then - write(errmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", & + write(myerrmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", & "levh2o from read_h2odata does not match value in GFS_typedefs.F90: ", & levh2o, " /= ", size(h2opl, dim=2) - errflg = 1 + myerrflg = 1 + call copy_error(myerrmsg, myerrflg, errmsg, errflg) end if if (size(h2opl, dim=3).ne.h2o_coeff) then - write(errmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", & + write(myerrmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", & "h2o_coeff from read_h2odata does not match value in GFS_typedefs.F90: ", & h2o_coeff, " /= ", size(h2opl, dim=3) - errflg = 1 + myerrflg = 1 + call copy_error(myerrmsg, myerrflg, errmsg, errflg) end if !$OMP section @@ -264,7 +287,9 @@ subroutine GFS_phys_time_vary_init ( !> added coupled gocart and radiation option to initializing aer_nm if (iaerclm) then ntrcaer = ntrcaerm - call read_aerdata (me,master,iflip,idate,errmsg,errflg) + myerrflg = 0 + call read_aerdata (me,master,iflip,idate,myerrmsg,myerrflg) + call copy_error(myerrmsg, myerrflg, errmsg, errflg) else if(iaermdl ==2 ) then do ix=1,ntrcaerm do j=1,levs @@ -289,16 +314,22 @@ subroutine GFS_phys_time_vary_init ( !$OMP section !> - Call tau_amf dats for ugwp_v1 if (do_ugwp_v1) then - call read_tau_amf(me, master, errmsg, errflg) + myerrflg = 0 + call read_tau_amf(me, master, myerrmsg, myerrflg) + call copy_error(myerrmsg, myerrflg, errmsg, errflg) endif !$OMP section !> - Initialize soil vegetation (needed for sncovr calculation further down) - call set_soilveg(me, isot, ivegsrc, nlunit, errmsg, errflg) + myerrflg = 0 + call set_soilveg(me, isot, ivegsrc, nlunit, myerrmsg, myerrflg) + call copy_error(myerrmsg, myerrflg, errmsg, errflg) !$OMP section !> - read in NoahMP table (needed for NoahMP init) - call read_mp_table_parameters(errmsg, errflg) + myerrflg = 0 + call read_mp_table_parameters(myerrmsg, myerrflg) + call copy_error(myerrmsg, myerrflg, errmsg, errflg) !$OMP end sections @@ -393,7 +424,9 @@ subroutine GFS_phys_time_vary_init ( if (errflg/=0) return if (iaerclm) then + ! This call is outside the OpenMP section, so it should access errmsg & errflg directly. call read_aerdataf (me, master, iflip, idate, fhour, errmsg, errflg) + ! If it is moved to an OpenMP section, it must use myerrmsg, myerrflg, and copy_error. if (errflg/=0) return end if @@ -479,7 +512,8 @@ subroutine GFS_phys_time_vary_init ( !$omp shared(dwsat_table,dksat_table,psisat_table,smoiseq) & !$OMP shared(smcwtdxy,deeprechxy,rechxy,errmsg,errflg) & !$OMP private(vegtyp,masslai,masssai,snd,dzsno,dzsnso,isnow) & -!$OMP private(soiltyp,bexp,smcmax,smcwlt,dwsat,dksat,psisat,ddz) +!$OMP private(soiltyp,bexp,smcmax,smcwlt,dwsat,dksat,psisat) & +!$OMP private(myerrmsg,myerrflg,ddz) do ix=1,im if (landfrac(ix) >= drythresh) then tvxy(ix) = tsfcl(ix) @@ -594,8 +628,9 @@ subroutine GFS_phys_time_vary_init ( dzsno(-1) = 0.20_kind_phys dzsno(0) = snd - 0.05_kind_phys - 0.20_kind_phys else - errmsg = 'Error in GFS_phys_time_vary.fv3.F90: Problem with the logic assigning snow layers in Noah MP initialization' - errflg = 1 + myerrmsg = 'Error in GFS_phys_time_vary.fv3.F90: Problem with the logic assigning snow layers in Noah MP initialization' + myerrflg = 1 + call copy_error(myerrmsg, myerrflg, errmsg, errflg) endif ! Now we have the snowxy field diff --git a/physics/noahmp_tables.f90 b/physics/noahmp_tables.f90 index 3b06d7f53..7b536a1d7 100644 --- a/physics/noahmp_tables.f90 +++ b/physics/noahmp_tables.f90 @@ -783,7 +783,7 @@ subroutine read_mp_table_parameters(errmsg, errflg) open(15, status='old', form='formatted', action='read', iostat=ierr) end if if ( ierr /= 0 ) then - errmsg = 'warning: cannot find file noahmptable.tb' + errmsg = 'warning: cannot find file noahmptable.tbl' errflg = 1 return ! write(*,'("warning: cannot find file noahmptable.tbl")') @@ -914,7 +914,7 @@ subroutine read_mp_table_parameters(errmsg, errflg) open(15, status='old', form='formatted', action='read', iostat=ierr) end if if ( ierr /= 0 ) then - errmsg = 'warning: cannot find file noahmptable.tb' + errmsg = 'warning: cannot find file noahmptable.tbl' errflg = 1 return ! write(*,'("warning: cannot find file noahmptable.tbl")') @@ -957,7 +957,7 @@ subroutine read_mp_table_parameters(errmsg, errflg) open(15, status='old', form='formatted', action='read', iostat=ierr) end if if ( ierr /= 0 ) then - errmsg = 'warning: cannot find file noahmptable.tb' + errmsg = 'warning: cannot find file noahmptable.tbl' errflg = 1 return ! write(*,'("warning: cannot find file noahmptable.tbl")') @@ -982,7 +982,7 @@ subroutine read_mp_table_parameters(errmsg, errflg) open(15, status='old', form='formatted', action='read', iostat=ierr) end if if (ierr /= 0) then - errmsg = 'warning: cannot find file noahmptable.tb' + errmsg = 'warning: cannot find file noahmptable.tbl' errflg = 1 return ! write(*,'("warning: cannot find file noahmptable.tbl")') @@ -1011,7 +1011,7 @@ subroutine read_mp_table_parameters(errmsg, errflg) open(15, status='old', form='formatted', action='read', iostat=ierr) end if if (ierr /= 0) then - errmsg = 'warning: cannot find file noahmptable.tb' + errmsg = 'warning: cannot find file noahmptable.tbl' errflg = 1 return ! write(*,'("warning: cannot find file noahmptable.tbl")') @@ -1069,7 +1069,7 @@ subroutine read_mp_table_parameters(errmsg, errflg) open(15, status='old', form='formatted', action='read', iostat=ierr) end if if (ierr /= 0) then - errmsg = 'warning: cannot find file noahmptable.tb' + errmsg = 'warning: cannot find file noahmptable.tbl' errflg = 1 return ! write(*,'("warning: cannot find file noahmptable.tbl")') @@ -1096,7 +1096,7 @@ subroutine read_mp_table_parameters(errmsg, errflg) open(15, status='old', form='formatted', action='read', iostat=ierr) end if if (ierr /= 0) then - errmsg = 'warning: cannot find file noahmptable.tb' + errmsg = 'warning: cannot find file noahmptable.tbl' errflg = 1 return ! write(*,'("warning: cannot find file noahmptable.tbl")') @@ -1249,7 +1249,7 @@ subroutine read_mp_table_parameters(errmsg, errflg) open(15, status='old', form='formatted', action='read', iostat=ierr) end if if (ierr /= 0) then - errmsg = 'warning: cannot find file noahmptable.tb' + errmsg = 'warning: cannot find file noahmptable.tbl' errflg = 1 return ! write(*,'("warning: cannot find file noahmptable.tbl")') @@ -1278,7 +1278,7 @@ subroutine read_mp_table_parameters(errmsg, errflg) open(15, status='old', form='formatted', action='read', iostat=ierr) end if if (ierr /= 0) then - errmsg = 'warning: cannot find file noahmptable.tb' + errmsg = 'warning: cannot find file noahmptable.tbl' errflg = 1 return ! write(*,'("warning: cannot find file noahmptable.tbl")') From 3ec61d39e75bf9f83a1e232e762909964a687767 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 21 Sep 2023 22:23:47 +0000 Subject: [PATCH 331/380] detect empty errmsg in GFS_phys_time_vary.fv3.F90 --- physics/GFS_phys_time_vary.fv3.F90 | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index 04348f6dc..e6bf24186 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -67,14 +67,14 @@ subroutine copy_error(myerrmsg, myerrflg, errmsg, errflg) integer, intent(in) :: myerrflg character(*), intent(out) :: errmsg integer, intent(inout) :: errflg - if(myerrflg == 0) return - if(errflg /= 0) return - !$OMP CRITICAL - if(errflg == 0) then - errmsg = myerrmsg - errflg = myerrflg + if(myerrflg /= 0 .and. errflg == 0) then + !$OMP CRITICAL + if(errflg == 0) then + errmsg = myerrmsg + errflg = myerrflg + endif + !$OMP END CRITICAL endif - !$OMP END CRITICAL end subroutine copy_error !> \section arg_table_GFS_phys_time_vary_init Argument Table @@ -209,7 +209,7 @@ subroutine GFS_phys_time_vary_init ( real(kind=kind_phys), dimension(:), allocatable :: dzsnso integer :: myerrflg - character(255) :: myerrmsg + character(len=255) :: myerrmsg ! Initialize CCPP error handling variables errmsg = '' @@ -288,6 +288,7 @@ subroutine GFS_phys_time_vary_init ( if (iaerclm) then ntrcaer = ntrcaerm myerrflg = 0 + myerrmsg = 'read_aerdata failed without a message' call read_aerdata (me,master,iflip,idate,myerrmsg,myerrflg) call copy_error(myerrmsg, myerrflg, errmsg, errflg) else if(iaermdl ==2 ) then @@ -315,6 +316,7 @@ subroutine GFS_phys_time_vary_init ( !> - Call tau_amf dats for ugwp_v1 if (do_ugwp_v1) then myerrflg = 0 + myerrmsg = 'read_tau_amf failed without a message' call read_tau_amf(me, master, myerrmsg, myerrflg) call copy_error(myerrmsg, myerrflg, errmsg, errflg) endif @@ -322,12 +324,14 @@ subroutine GFS_phys_time_vary_init ( !$OMP section !> - Initialize soil vegetation (needed for sncovr calculation further down) myerrflg = 0 + myerrmsg = 'set_soilveg failed without a message' call set_soilveg(me, isot, ivegsrc, nlunit, myerrmsg, myerrflg) call copy_error(myerrmsg, myerrflg, errmsg, errflg) !$OMP section !> - read in NoahMP table (needed for NoahMP init) myerrflg = 0 + myerrmsg = 'read_mp_table_parameters failed without a message' call read_mp_table_parameters(myerrmsg, myerrflg) call copy_error(myerrmsg, myerrflg, errmsg, errflg) From 7912a1954983010f1f2ee5ce552139b8dda0b669 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 21 Sep 2023 22:24:02 +0000 Subject: [PATCH 332/380] Initialize err variables in set_soilveg.f --- physics/set_soilveg.f | 3 +++ 1 file changed, 3 insertions(+) diff --git a/physics/set_soilveg.f b/physics/set_soilveg.f index 37f2c2a73..35f4ace37 100644 --- a/physics/set_soilveg.f +++ b/physics/set_soilveg.f @@ -44,6 +44,9 @@ subroutine set_soilveg(me,isot,ivet,nlunit,errmsg,errflg) & DEFINED_SLOPE, FXEXP_DATA, NROOT_DATA, REFKDT_DATA, Z0_DATA, & CZIL_DATA, LAI_DATA, CSOIL_DATA + errmsg = '' + errflg = 0 + cmy end locals if(ivet.eq.2) then From 7332c8e7ac3d5eec9d48947ec9c1bbd035d9dfeb Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 21 Sep 2023 23:32:27 +0000 Subject: [PATCH 333/380] initialize errmsg & errflg in noahmp_tables.f90 --- physics/noahmp_tables.f90 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/physics/noahmp_tables.f90 b/physics/noahmp_tables.f90 index 7b536a1d7..753c8ff24 100644 --- a/physics/noahmp_tables.f90 +++ b/physics/noahmp_tables.f90 @@ -484,6 +484,9 @@ subroutine read_mp_table_parameters(errmsg, errflg) sr2006_psi_e_a, sr2006_psi_e_b, sr2006_psi_e_c, sr2006_smcmax_a, & sr2006_smcmax_b + errmsg = '' + errflg = 0 + ! initialize our variables to bad values, so that if the namelist read fails, we come to a screeching halt as soon as we try to use anything. ! vegetation parameters isurban_table = -99999 From 374996ecc45f138ff48ed1812fee3dc59837c556 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Fri, 22 Sep 2023 13:42:46 +0000 Subject: [PATCH 334/380] only read h2odata, ozdata and noahmp table when they are needed --- physics/GFS_phys_time_vary.fv3.F90 | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index e6bf24186..4100bdf6e 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -226,7 +226,7 @@ subroutine GFS_phys_time_vary_init ( !$OMP shared (xlat_d,xlon_d,imap,jmap,errmsg,errflg) & !$OMP shared (levozp,oz_coeff,oz_pres,ozpl) & !$OMP shared (levh2o,h2o_coeff,h2o_pres,h2opl) & -!$OMP shared (iamin, iamax, jamin, jamax) & +!$OMP shared (iamin, iamax, jamin, jamax, lsm_noahmp) & !$OMP shared (iaerclm,iaermdl,ntrcaer,aer_nm,iflip,iccn) & !$OMP shared (jindx1_o3,jindx2_o3,ddy_o3,jindx1_h,jindx2_h,ddy_h) & !$OMP shared (jindx1_aer,jindx2_aer,ddy_aer,iindx1_aer,iindx2_aer,ddx_aer) & @@ -240,6 +240,7 @@ subroutine GFS_phys_time_vary_init ( !$OMP section !> - Call read_o3data() to read ozone data + need_o3data: if(ntoz > 0) then call read_o3data (ntoz, me, master) ! Consistency check that the hardcoded values for levozp and @@ -259,9 +260,11 @@ subroutine GFS_phys_time_vary_init ( oz_coeff, " /= ", size(ozpl, dim=3) call copy_error(myerrmsg, myerrflg, errmsg, errflg) end if + endif need_o3data !$OMP section !> - Call read_h2odata() to read stratospheric water vapor data + need_h2odata: if(h2o_phys) then call read_h2odata (h2o_phys, me, master) ! Consistency check that the hardcoded values for levh2o and @@ -281,6 +284,7 @@ subroutine GFS_phys_time_vary_init ( myerrflg = 1 call copy_error(myerrmsg, myerrflg, errmsg, errflg) end if + endif need_h2odata !$OMP section !> - Call read_aerdata() to read aerosol climatology, Anning added coupled @@ -330,10 +334,12 @@ subroutine GFS_phys_time_vary_init ( !$OMP section !> - read in NoahMP table (needed for NoahMP init) - myerrflg = 0 - myerrmsg = 'read_mp_table_parameters failed without a message' - call read_mp_table_parameters(myerrmsg, myerrflg) - call copy_error(myerrmsg, myerrflg, errmsg, errflg) + if(lsm == lsm_noahmp) then + myerrflg = 0 + myerrmsg = 'read_mp_table_parameters failed without a message' + call read_mp_table_parameters(myerrmsg, myerrflg) + call copy_error(myerrmsg, myerrflg, errmsg, errflg) + endif !$OMP end sections From 5377c7c0ab39f275804749a50f31f0e03f7abab4 Mon Sep 17 00:00:00 2001 From: "anning.cheng" Date: Fri, 22 Sep 2023 10:08:02 -0400 Subject: [PATCH 335/380] passing nc back from microphysics --- physics/module_mp_thompson.F90 | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index ca913c6e3..271db11d0 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -1509,6 +1509,14 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & enddo endif + if (merra2_aerosol_aware) then + do k = kts, kte + nc(i,k,j) = nc1d(k) + nwfa(i,k,j) = nwfa1d(k) + nifa(i,k,j) = nifa1d(k) + enddo + endif + do k = kts, kte qv(i,k,j) = qv1d(k) qc(i,k,j) = qc1d(k) From f324aa52e64b325965b1552916c733946610ddd2 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Fri, 22 Sep 2023 20:21:45 -0500 Subject: [PATCH 336/380] Update variable name in mp_nssl.F90 --- physics/mp_nssl.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/mp_nssl.F90 b/physics/mp_nssl.F90 index b81afaafb..aacf4c3dd 100644 --- a/physics/mp_nssl.F90 +++ b/physics/mp_nssl.F90 @@ -134,7 +134,7 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & ! write(0,*) 'call nssl_2mom_init' CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=ipc,mixphase=0, & - ihvol=ihailv,nssl_ehw0=nssl_ehw0_in,nssl_ehlw0=nssl_ehlw0_in,errmsg=errmsg, & + ihvol=ihailv,nssl_ehw0=nssl_ehw0,nssl_ehlw0=nssl_ehlw0,errmsg=errmsg, & nssl_alphar=nssl_alphar, & nssl_alphah=nssl_alphah, & nssl_alphahl=nssl_alphahl, & From cfd848540b64a55d5b2cc625683ca511889cfd6e Mon Sep 17 00:00:00 2001 From: "Haiqin.Li" Date: Sat, 23 Sep 2023 02:49:23 +0000 Subject: [PATCH 337/380] "to address the reviewer's comments" --- physics/cu_c3_deep.F90 | 2 -- physics/cu_c3_driver.F90 | 9 ++------- physics/cu_c3_driver_post.F90 | 9 ++++----- physics/cu_gf_driver.F90 | 5 ++--- physics/cu_gf_driver_post.F90 | 2 -- 5 files changed, 8 insertions(+), 19 deletions(-) diff --git a/physics/cu_c3_deep.F90 b/physics/cu_c3_deep.F90 index d1b490c77..b8a1dd838 100644 --- a/physics/cu_c3_deep.F90 +++ b/physics/cu_c3_deep.F90 @@ -4489,10 +4489,8 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & endif if(k.gt.kbcon(i)+1)c1d(i,k)=clwdet*up_massdetr(i,k-1) if(k.gt.kbcon(i)+1)c1d_b(i,k)=clwdet*up_massdetr(i,k-1) - !if(is_deep.and.k.gt.kklev(i))then c1d(i,k)=0.005 c1d_b(i,k)=0.005 - !endif if(autoconv.eq.2) then ! diff --git a/physics/cu_c3_driver.F90 b/physics/cu_c3_driver.F90 index 270e01989..cc2906ad5 100644 --- a/physics/cu_c3_driver.F90 +++ b/physics/cu_c3_driver.F90 @@ -644,7 +644,6 @@ subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& enddo !$acc end kernels if (dx(its)<6500.) then - ichoice=10 imid_gf=0 endif ! @@ -680,10 +679,6 @@ subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& do i=its,itf if(xmbs(i).gt.0.)then cutens(i)=1. - if (dx(i)<6500.) then - ierrm(i)=555 - ierr (i)=555 - endif endif enddo !$acc end kernels @@ -1041,8 +1036,8 @@ subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& gdc(i,16,10)=pret(i)*3600. maxupmf(i)=0. - if(forcing(i,6).gt.0.)then - maxupmf(i)=maxval(xmb(i)*zu(i,kts:ktf)/forcing(i,6)) + if(forcing2(i,6).gt.0.)then + maxupmf(i)=maxval(xmb(i)*zu(i,kts:ktf)/forcing2(i,6)) endif if(ktop(i).gt.2 .and.pret(i).gt.0.)dt_mf(i,ktop(i)-1)=ud_mf(i,ktop(i)) diff --git a/physics/cu_c3_driver_post.F90 b/physics/cu_c3_driver_post.F90 index 74957a6b2..528f3d466 100644 --- a/physics/cu_c3_driver_post.F90 +++ b/physics/cu_c3_driver_post.F90 @@ -66,20 +66,19 @@ subroutine cu_c3_driver_post_run (im, km, t, q, prevst, prevsq, cactiv, cactiv_m conv_act_m(i)=0.0 endif ! reflectivity parameterization for parameterized convection (reference:Unipost MDLFLD.f) - if(sqrt(garea(i)).lt.6500.)then ze = 0.0 ze_conv = 0.0 dbz_sum = 0.0 - cuprate = raincv(i) * 3600.0 / dt ! cu precip rate (mm/h) - ze_conv = 300.0 * cuprate**1.4 - if (maxupmf(i).gt.0.05) then + cuprate = max(0.1,1.e3*raincv(i) * 3600.0 / dt) ! cu precip rate (mm/h) + if(cuprate .lt. 0.05) cuprate=0. + ze_conv = 300.0 * cuprate**1.5 + if (maxupmf(i).gt.0.1 .and. cuprate.gt.0.) then do k = 1, km ze = 10._kind_phys ** (0.1 * refl_10cm(i,k)) dbz_sum = max(dbzmin, 10.0 * log10(ze + ze_conv)) refl_10cm(i,k) = dbz_sum enddo endif - endif enddo !$acc end kernels diff --git a/physics/cu_gf_driver.F90 b/physics/cu_gf_driver.F90 index 3b700cc5a..f3f5042fc 100644 --- a/physics/cu_gf_driver.F90 +++ b/physics/cu_gf_driver.F90 @@ -644,7 +644,6 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& enddo !$acc end kernels if (dx(its)<6500.) then -! ichoice=10 imid_gf=0 endif ! @@ -1015,8 +1014,8 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& gdc(i,16,10)=pret(i)*3600. maxupmf(i)=0. - if(forcing(i,6).gt.0.)then - maxupmf(i)=maxval(xmb(i)*zu(i,kts:ktf)/forcing(i,6)) + if(forcing2(i,6).gt.0.)then + maxupmf(i)=maxval(xmb(i)*zu(i,kts:ktf)/forcing2(i,6)) endif if(ktop(i).gt.2 .and.pret(i).gt.0.)dt_mf(i,ktop(i)-1)=ud_mf(i,ktop(i)) diff --git a/physics/cu_gf_driver_post.F90 b/physics/cu_gf_driver_post.F90 index 8c5896164..59f43618c 100644 --- a/physics/cu_gf_driver_post.F90 +++ b/physics/cu_gf_driver_post.F90 @@ -66,7 +66,6 @@ subroutine cu_gf_driver_post_run (im, km, t, q, prevst, prevsq, cactiv, cactiv_m conv_act_m(i)=0.0 endif ! reflectivity parameterization for parameterized convection (reference:Unipost MDLFLD.f) - !if(sqrt(garea(i)).lt.6500.)then ze = 0.0 ze_conv = 0.0 dbz_sum = 0.0 @@ -80,7 +79,6 @@ subroutine cu_gf_driver_post_run (im, km, t, q, prevst, prevsq, cactiv, cactiv_m refl_10cm(i,k) = dbz_sum enddo endif - !endif enddo !$acc end kernels From fda90e0d45e13458d89425ec9bb4d1ef454e1fa8 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Sat, 23 Sep 2023 16:19:01 -0500 Subject: [PATCH 338/380] Update for NSSL 2/3-moment cloud physics --- physics/module_mp_nssl_2mom.F90 | 1157 +++++++++++++++++++++---------- 1 file changed, 795 insertions(+), 362 deletions(-) diff --git a/physics/module_mp_nssl_2mom.F90 b/physics/module_mp_nssl_2mom.F90 index 6439d81d3..72ff9b1b1 100644 --- a/physics/module_mp_nssl_2mom.F90 +++ b/physics/module_mp_nssl_2mom.F90 @@ -8,7 +8,7 @@ !--------------------------------------------------------------------- -! code snapshot: "Apr 10 2023" at "13:17:29" +! code snapshot: "Sep 22 2023" at "22:01:53" !--------------------------------------------------------------------- !--------------------------------------------------------------------- ! IMPORTANT: Best results are attained using the 5th-order WENO (Weighted Essentially Non-Oscillatory) advection option (4) for scalars: @@ -33,9 +33,7 @@ !! !! Added info on graupel density and soaking is in Mansell and Ziegler (2013, JAS) !! -!! Average graupel particle density is predicted, which affects fall speed as well. -!! Hail density prediction is by default disabled in this version, but may be enabled -!! at some point if there is interest. +!! Average graupel and hail particle densities are predicted, which affects fall speed as well. !! !! Maintainer: Ted Mansell, National Severe Storms Laboratory !! @@ -76,6 +74,13 @@ ! ! !--------------------------------------------------------------------- +! Apr. 2023 +! - Update to 3-moment for rain, graupel, and hail +! - Change default graupel/hail fall speeds to icdx/icdxhl=6 (Milbrandt & Morrison 2013) +! and also set default ehw0=0.9 and ehlw0=0.9 to compensate for lower fall speeds. +! - Change default hail conversion to ihlcnh=-1, and then =1 for 2-mom or =3 for 3-mom, +! using wet growth diameter to convert large graupel +!--------------------------------------------------------------------- ! Sept. 2021: ! Fixes: ! Restored previous formulation of snow reflectivity, as it was realized that the last change incorrectly assumed a fixed @@ -225,7 +230,7 @@ MODULE module_mp_nssl_2mom real, private :: rho_qr = 1000., cnor = 8.0e5 ! cnor is set in namelist!! rain params real, private :: rho_qs = 100., cnos = 3.0e6 ! set in namelist!! snow params real, private :: rho_qh = 500., cnoh = 4.0e5 ! set in namelist!! graupel params - real, private :: rho_qhl= 900., cnohl = 4.0e4 ! set in namelist!! hail params + real, private :: rho_qhl= 800., cnohl = 4.0e4 ! set in namelist!! hail params real, private :: hdnmn = 170.0 ! minimum graupel density (for variable density graupel) real, private :: hldnmn = 500.0 ! minimum hail density (for variable density hail) @@ -287,8 +292,10 @@ MODULE module_mp_nssl_2mom real, private :: graupelfallfac = 1.0 ! factor to adjust graupel fall speed real, private :: hailfallfac = 1.0 ! factor to adjust hail fall speed integer, private :: icefallopt = 3 ! 1= default, 2 = Ferrier ice fall speed; 3 = adjusted Ferrier (slightly high Vt) - integer, private :: icdx = 3 ! (graupel) 0=Ferrier; 1=leave drag coef. cd fixed; 2=vary by density, 4=set by user with cdxmin,cdxmax,etc. - integer, private :: icdxhl = 3 ! (hail) 0=Ferrier; 1=leave drag coef. cd fixed; 2=vary by density, 4=set by user with cdxmin,cdxmax,etc. + integer, private :: icdx = 6 ! (graupel) 0=Ferrier; 1=leave drag coef. cd fixed; 2=vary by density, 4=set by user with cdxmin,cdxmax,etc. + ! 6= Milbrandt and Morrison (2013) density-based fall speed + integer, private :: icdxhl = 6 ! (hail) 0=Ferrier; 1=leave drag coef. cd fixed; 2=vary by density, 4=set by user with cdxmin,cdxmax,etc. + ! 6= Milbrandt and Morrison (2013) density-based fall speed real :: axh = 75.7149, bxh = 0.5 real :: axf = 75.7149, bxf = 0.5 real :: axhl = 206.984, bxhl = 0.6384 @@ -340,7 +347,7 @@ MODULE module_mp_nssl_2mom ! (first nucleation is done with a KW sat. adj. step) integer, private :: issfilt = 0 ! flag to turn on filtering of supersaturation field integer, private :: icnuclimit = 0 ! limit droplet nucleation based on Konwar et al. (2012) and Chandrakar et al. (2016) - integer, private :: irenuc = 2 ! =1 to always allow renucleation of droplets within the cloud + integer, private :: irenuc = 2 ! =1 to always allow renucleation of droplets within the cloud (do no use, obsolete) ! =2 renucleation following Twomey/Cohard&Pinty ! =7 New renucleation that requires prediction of the number of activated nuclei ! i.e., not only at cloud base @@ -439,6 +446,7 @@ MODULE module_mp_nssl_2mom real , private :: ehs0 = 0.1, ehs1 = 0.1 ! graupel-snow coll. eff. parameters: ehs0*exp(ehs1*min(temcg(mgs),0.0)) ! set ehs1 = 0 to get a constant value of ehs0 integer :: iessopt = 1 ! 1 = Original (no factor); 2 = factor based on wvel; 3 = factor based on SSI + ! 4 = as 3 but sets min factor of 0.1 and goes to full value at 0.5% SSI real , private :: ess0 = 0.5, ess1 = 0.05 ! snow aggregation coefficients: ess0*exp(ess1*min(temcg(mgs),0.0)) ! set ess1 = 0 to get a constant value of ess0 real , private :: esstem1 = -15. ! lower temperature where snow aggregation turns on @@ -535,17 +543,18 @@ MODULE module_mp_nssl_2mom real, parameter :: alpharmax = 8. ! limited for rwvent calculation - integer, private :: ihlcnh = 1 ! which graupel -> hail conversion to use + integer, private :: ihlcnh = -1 ! which graupel -> hail conversion to use ! 1 = Milbrandt and Yau (2005) using Ziegler 1985 wet growth diameter ! 2 = Straka and Mansell (2005) conversion using size threshold ! 3 = Conversion using wet growth diameter real, private :: hlcnhdia = 1.e-3 ! threshold diameter for graupel -> hail conversion for ihlcnh = 1 option. real, private :: hlcnhqmin = 0.1e-3 ! minimum graupel mass content for graupel -> hail conversion (ihlcnh = 1) - real , private :: hldia1 = 20.0e-3 ! threshold diameter for graupel -> hail conversion for ihlcnh = 2 option. - integer :: incwet = 0 ! flag to do wet growth only on D > D_wet + real , private :: hldia1 = 10.0e-3 ! threshold diameter for graupel -> hail conversion for ihlcnh = 2 option. + integer, private :: incwet = 0 ! flag to do wet growth only on D > D_wet integer, private :: iusedw = 0 ! flag to use experimental wet growth ice diameter for gr -> hl conversion (=1 turns on) real , private :: dwmin = 5.0e-3 ! Minimum diameter with iusedw (can stay at 0 or be set to something larger) real , private :: dwetmin = 5.0e-3 ! Minimum diameter with iusedw (can stay at 0 or be set to something larger) + real , private :: dwmax = 15.e-3 ! for ihlcnh, always convert this size and larger whether or not there is wet growth real , private :: dwtempmin = 242. ! lowest temperature to allow wet growth conversion to hail real , private :: dwehwmin = 0. ! Minimum ehw to use to find wet growth diameter (if > ehw0, then wet growth diam becomes smaller) real , private :: dg0thresh = 0.15 ! graupel wet growth diameter above which we say do not bother @@ -576,7 +585,7 @@ MODULE module_mp_nssl_2mom ! = 2 DTD mass-weighted version based on MY code ! = 3 Milbrandt version (from Cohard and Pinty code integer :: dmropt = 0 ! extra option for crcnw - integer :: dmhlopt = 1 ! options for graupel -> conversion + integer :: dmhlopt = 0 ! options for graupel -> hail conversion integer :: irescalerainopt = 3 ! 0 = default option ! 1 = qx(mgs,lc) > qxmin(lc) ! 2 = qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < 3.0 @@ -593,7 +602,7 @@ MODULE module_mp_nssl_2mom integer :: ivhmltsoak = 1 ! 0=off, 1=on : flag to simulate soaking (graupel/hail) during melting ! when liquid fraction is not predicted - logical :: iwetsoak = .true. ! soak and freeze during wet growth or not + logical, private :: iwetsoak = .true. ! soak and freeze during wet growth or not integer, private :: ioldlimiter = 0 ! test switch for new(=0) or old(=1) size limiter at the end of GS for 3-moment categories integer, private :: isnowfall = 2 ! Option for choosing between snow fall speed parameters ! 1 = original Zrnic et al. (Mansell et al. 2010) @@ -800,7 +809,7 @@ MODULE module_mp_nssl_2mom double precision gmoi(0:ngm0) ! ,gmod(0:ngm1,0:ngm2),gmdi(0:ngm1,0:ngm2) integer, parameter :: nqiacralpha = 300 !480 ! 240 ! 120 ! 15 - integer, parameter :: nqiacrratio = 100 ! 500 !50 ! 25 + integer, parameter :: nqiacrratio = 400 ! 500 !50 ! 25 ! real, parameter :: maxratiolu = 25. real, parameter :: maxratiolu = 100. ! 25. real, parameter :: maxalphalu = 15. @@ -899,7 +908,7 @@ MODULE module_mp_nssl_2mom ! parameter( xvcmn=4.188e-18 ) ! mks min volume = 3 micron radius real, parameter :: xvcmn=0.523599*(2.*cwradn)**3 ! mks min volume = 2.5 micron radius - real, parameter :: xvcmx=0.523599*(2.*xcradmx)**3 ! mks min volume = 2.5 micron radius + real, parameter :: xvcmx=0.523599*(2.*xcradmx)**3 ! mks max volume = 60 micron radius real, parameter :: cwmasn = 1000.*xvcmn ! minimum mass, defined by radius of 5.0e-6 real, parameter :: cwmasx = 1000.*xvcmx ! maximum mass, defined by radius of 50.0e-6 real, parameter :: cwmasn5 = 1000.*0.523599*(2.*5.0e-6)**3 ! 5.23e-13 @@ -947,7 +956,7 @@ MODULE module_mp_nssl_2mom real :: cp = 1004.0, rd = 287.04 real :: rw = 461.5 ! gas const. for water vapor REAL, PRIVATE :: cpl = 4190.0 - REAL, PRIVATE :: cpigb = 2106.0 + REAL, PRIVATE :: cpigb = 2106.0 real :: cpi real :: cap real :: tfrcbw @@ -962,8 +971,8 @@ MODULE module_mp_nssl_2mom ! GHB: Needed for eqtset=2 in cm1 ! REAL, PRIVATE :: cv = cp - rd - real, private, parameter :: cv = 717.0 ! specific heat at constant volume - air - REAL, PRIVATE, parameter :: cvv = 1408.5 + real, private, parameter :: cv = 717.0 ! specific heat at constant volume - air + REAL, PRIVATE, parameter :: cvv = 1408.5 ! GHB real, parameter :: bfnu0 = (rnu + 2.0)/(rnu + 1.0) @@ -992,6 +1001,8 @@ MODULE module_mp_nssl_2mom logical, parameter :: do_satadj_for_wrfchem = .true. + integer, parameter :: ac_opt = 0 ! option flag for alternate aerosol (for NUWRF only) + logical, private :: nuaccoinp = .false. ! Note to users: Many of these options are for development and not guaranteed to perform well. ! Some may not be functional depending on the version of the code. @@ -1101,7 +1112,7 @@ MODULE module_mp_nssl_2mom rescale_low_alphah, & rescale_low_alphahl, & rescale_high_alpha, & - ihlcnh, hldia1,iusedw, dwehwmin, dwmin, dwtempmin, & + ihlcnh, hldia1,iusedw, dwehwmin, dwmin, dwmax, dwtempmin, dg0thresh, & icvhl2h, hldnmn,hdnmn, & hlcnhdia, hlcnhqmin, & isedonly, & @@ -1194,13 +1205,14 @@ SUBROUTINE nssl_2mom_init_const( & RETURN END SUBROUTINE nssl_2mom_init_const + + ! ##################################################################### ! ##################################################################### !>\ingroup mod_nsslmp !! NSSL MP setup routine (sets local options and array indices) SUBROUTINE nssl_2mom_init( & & ims,ime, jms,jme, kms,kme, nssl_params, ipctmp, mixphase,ihvol,idoniconlytmp, & - & igvol, & & nssl_graupelfallfac, & & nssl_hailfallfac, & & nssl_ehw0, & @@ -1214,6 +1226,7 @@ SUBROUTINE nssl_2mom_init( & & nssl_alphah, & & nssl_alphahl, & & nssl_alphar, & + & nssl_density_on, nssl_hail_on, nssl_ccn_on, nssl_icecrystals_on, ccn_is_ccna, & & errmsg, errflg, & & infileunit, & & myrank, mpiroot & @@ -1233,9 +1246,11 @@ SUBROUTINE nssl_2mom_init( & & nssl_alphahl, & & nssl_alphar integer, intent(in), optional :: & - & nssl_icdx, igvol, & + & nssl_icdx, & & nssl_icdxhl, myrank, mpiroot, & & nssl_ufccn + logical, intent(in), optional :: nssl_density_on, nssl_hail_on, nssl_ccn_on, nssl_icecrystals_on + integer, intent(inout), optional :: ccn_is_ccna integer, intent(in),optional :: infileunit @@ -1243,16 +1258,20 @@ SUBROUTINE nssl_2mom_init( & character(len=*), intent( out) :: errmsg integer, intent( out) :: errflg integer, intent(in), optional :: ims,ime, jms,jme, kms,kme + real, intent(in), dimension(20), optional :: nssl_params - integer, intent(in) :: ipctmp,mixphase,ihvol + integer, intent(in) :: ipctmp,mixphase + integer, optional, intent(in) :: ihvol logical, optional, intent(in) :: idoniconlytmp integer :: igvol_local = 1 logical :: wrote_namelist = .false. logical :: wrf_dm_on_monitor + integer :: hail_on = -1, density_on = -1, icecrystals_on = 1 + integer :: ccn_on = -1 double precision :: arg real :: temq @@ -1277,9 +1296,37 @@ SUBROUTINE nssl_2mom_init( & turn_on_ccna = .false. turn_on_cina = .false. - IF ( present( igvol ) ) THEN - igvol_local = igvol +! IF ( present( igvol ) ) THEN +! igvol_local = igvol +! ENDIF + + IF ( present( nssl_hail_on ) ) THEN + IF ( nssl_hail_on ) THEN + hail_on = 1 + ELSE + hail_on = 0 + ENDIF + ENDIF + + IF ( present( nssl_density_on ) ) THEN + IF ( nssl_density_on ) THEN + density_on = 1 + ELSE + density_on = 0 + ENDIF ENDIF + + IF ( present( nssl_icecrystals_on ) ) THEN + IF ( nssl_icecrystals_on ) THEN + icecrystals_on = 1 + ELSE + icecrystals_on = 0 + ! renucfrac = 1.0 ! why was this set to 1? + ffrzs = 1.0 + ENDIF + ENDIF + + ! ! set some global values from namelist input ! @@ -1295,7 +1342,6 @@ SUBROUTINE nssl_2mom_init( & rho_qh = nssl_params(8) rho_qhl = nssl_params(9) rho_qs = nssl_params(10) - IF ( Nint(nssl_params(13)) == 1 ) THEN ! hack to switch CCN field to CCNA (activated ccn) ! invertccn = .true. @@ -1306,29 +1352,56 @@ SUBROUTINE nssl_2mom_init( & IF ( present(nssl_ufccn) ) iufccn = nssl_ufccn ENDIF - + alphar = nssl_params(15) ! ipelec = Nint(nssl_params(11)) ! isaund = Nint(nssl_params(12)) + + IF ( present(nssl_graupelfallfac) ) graupelfallfac = nssl_graupelfallfac IF ( present(nssl_hailfallfac) ) hailfallfac = nssl_hailfallfac - IF ( present(nssl_ehw0) ) ehw0 = nssl_ehw0 - IF ( present(nssl_ehlw0) ) ehlw0 = nssl_ehlw0 + IF ( present(nssl_ehw0) ) THEN + IF ( nssl_ehw0 > 0.0 ) ehw0 = nssl_ehw0 + ENDIF + IF ( present(nssl_ehlw0) ) THEN + IF ( nssl_ehlw0 > 0.0 ) ehlw0 = nssl_ehlw0 + ENDIF IF ( present(nssl_icdx) ) icdx = nssl_icdx IF ( present(nssl_icdxhl) ) icdxhl = nssl_icdxhl IF ( present(nssl_icefallfac) ) icefallfac = nssl_icefallfac IF ( present(nssl_snowfallfac) ) snowfallfac = nssl_snowfallfac - IF ( present(nssl_cccn) ) ccn = nssl_cccn - IF ( present(nssl_alphah) ) alphah = nssl_alphah - IF ( present(nssl_alphahl) ) alphahl = nssl_alphahl - IF ( present(nssl_alphar) ) alphar = nssl_alphar + IF ( present(nssl_cccn) ) THEN + IF (nssl_cccn > 1 ) ccn = nssl_cccn + ENDIF + IF ( present(nssl_alphah) ) THEN + IF ( nssl_alphah > -1. ) alphah = nssl_alphah + ENDIF + IF ( present(nssl_alphahl) ) THEN + IF ( nssl_alphahl > -1. ) alphahl = nssl_alphahl + ENDIF + IF ( present(nssl_alphar) ) THEN + IF ( nssl_alphar > -1.0 ) alphar = nssl_alphar + ENDIF + + ipconc = ipctmp + + IF ( ipconc < 5 ) THEN + ihlcnh = 0 + ENDIF + IF ( ihlcnh <= 0 ) THEN + IF ( ipconc == 5 ) THEN + ihlcnh = 3 + ELSEIF ( ipconc >= 6 ) THEN + ihlcnh = 3 + ENDIF + ENDIF - IF ( .true. ) THEN ! set to true to enable internal namelist read + IF ( .false. ) THEN ! set to true to enable internal namelist read open(15,file='input.nml',status='old',form='formatted',action='read') rewind(15) read(15,NML=nssl_mp_params,iostat=istat) @@ -1359,8 +1432,34 @@ SUBROUTINE nssl_2mom_init( & ENDIF ENDIF + IF ( present( nssl_ccn_on ) ) THEN + IF ( nssl_ccn_on ) THEN + ccn_on = 1 + ELSE + ccn_on = 0 + irenuc = 2 + ENDIF + ENDIF + IF ( irenuc >= 5 ) THEN turn_on_ccna = .true. + IF ( present( nssl_ccn_on ) ) THEN + IF ( .not. nssl_ccn_on ) THEN + errmsg = 'NSSL_MP Error: Must have nssl_ccn_on=1 for irenuc >= 5!' + errflg = 1 + return + ENDIF + ENDIF + ENDIF + + IF ( present( ccn_is_ccna ) .and. ccn_on == 1 ) THEN + IF ( ccn_is_ccna > 0 ) THEN + turn_on_ccna = .true. + ELSE + IF ( irenuc >= 5 ) THEN + ccn_is_ccna = 1 + ENDIF + ENDIF ENDIF cwccn = ccn @@ -1374,25 +1473,42 @@ SUBROUTINE nssl_2mom_init( & lh = lh + 1 lhl = lhl + 1 ENDIF - IF ( ihvol <= -1 .or. ihvol == 2 ) THEN - IF ( ihvol == -1 .or. ihvol == -2 ) THEN - lhab = lhab - 1 ! turns off hail - lhl = 0 - ! past me thought it would be a good idea to change graupel factors when hail is off.... - ! ehw0 = 0.75 - ! iehw = 2 - ! dfrz = Max( dfrz, 0.5e-3 ) - ENDIF - IF ( ihvol == -2 .or. ihvol == 2 ) THEN ! ice crystals are turned off - ! a value of 2? means to turn off ice crystals but turn on hail - renucfrac = 1.0 - ffrzs = 1.0 - ! idoci = 0 ! try this later + IF ( hail_on == -1 ) THEN ! hail_on is not set + hail_on = 1 + IF ( ihvol <= -1 .or. ihvol == 2 ) THEN + IF ( ihvol == -1 .or. ihvol == -2 ) THEN + lhab = lhab - 1 ! turns off hail + lhl = 0 + hail_on = 0 + ! past me thought it would be a good idea to change graupel factors when hail is off.... + ! ehw0 = 0.75 + ! iehw = 2 + ! dfrz = Max( dfrz, 0.5e-3 ) + ENDIF + IF ( ihvol == -2 .or. ihvol == 2 .or. icecrystals_on == 0 ) THEN ! ice crystals are turned off + ! a value of 2? means to turn off ice crystals but turn on hail + ! renucfrac = 1.0 ! why? + ffrzs = 1.0 + ! idoci = 0 ! try this later + ENDIF + ENDIF + + ELSE ! hail_on is set + IF ( hail_on == 0 ) THEN + lhab = lhab - 1 ! turns off hail + lhl = 0 + ELSE + ! assume default that hail is on ENDIF ENDIF + + IF ( density_on == -1 ) THEN ! density flag not set, so default is to predict it + density_on = 1 + ENDIF + IF ( iresetmoments == 0 ) iresetmoments = 1 ! lhl -! write(0,*) 'wrf_init: lhab,lhl = ',lhab,lhl +! write(0,*) 'wrf_init: lhab,lhl,hail_on,density_on = ',lhab,lhl,hail_on,density_on ! IF ( ipelec > 0 ) idonic = .true. @@ -1551,8 +1667,6 @@ SUBROUTINE nssl_2mom_init( & qiacrratio(0,:) = 1.0 - isub = Min( 0, Max(-1,ihvol) ) ! is -1 or 0 - lccn = 0 lccnuf = 0 lccna = 0 @@ -1576,14 +1690,13 @@ SUBROUTINE nssl_2mom_init( & ! lccn = 9 - ipconc = ipctmp IF ( ipconc == 0 ) THEN - IF ( ihvol >= 0 ) THEN + IF ( hail_on == 1 ) THEN ! turn on graupel density for 1-moment scheme lvh = 9 ltmp = 9 denscale(lvh) = 1 - ELSE ! no hail + ELSE ! no hail, 'LFO' scheme ltmp = lhab lhl = 0 ENDIF @@ -1601,17 +1714,17 @@ SUBROUTINE nssl_2mom_init( & lns = ltmp+5 !13 lnh = ltmp+6 !14 ltmp = lnh - IF ( ihvol >= 0 ) THEN + IF ( hail_on == 1 ) THEN ltmp = ltmp + 1 lnhl = ltmp ! lhab+7 ! 15 ENDIF - IF ( igvol_local >= 1 ) THEN + IF ( density_on >= 1 ) THEN ltmp = ltmp + 1 lvh = ltmp ! lhab+8 + isub ! 16 + isub ! isub adjusts to 15 if hail is off ! ltmp = lvh ENDIF denscale(lccn:ltmp) = 1 - IF ( ihvol >= 1 ) THEN + IF ( density_on == 1 .and. hail_on == 1 ) THEN ltmp = ltmp + 1 lvhl = ltmp ! ltmp = lvhl @@ -1647,13 +1760,13 @@ SUBROUTINE nssl_2mom_init( & ltmp = ltmp + 1 lnhl = ltmp ! lhab+7 ! 15 ENDIF - IF ( igvol_local >= 1 ) THEN + IF ( density_on == 1 ) THEN ltmp = ltmp + 1 lvh = ltmp ! lhab+8 + isub ! 16 + isub ! isub adjusts to 15 if hail is off ENDIF ! ltmp = lvh denscale(lccn:ltmp) = 1 - IF ( ihvol >= 1 ) THEN + IF ( density_on == 1 .and. hail_on == 1 ) THEN ltmp = ltmp + 1 lvhl = ltmp ! ltmp = lvhl @@ -1673,19 +1786,14 @@ SUBROUTINE nssl_2mom_init( & lzh = ltmp ltmp = ltmp + 1 lzr = ltmp - ltmp = ltmp + 1 IF ( lhl > 1 ) THEN ltmp = ltmp + 1 lzhl = ltmp ENDIF + ! write(0,*) 'ipcon,lzr = ',ipconc,lzr,lzh,lzhl ENDIF ! ltmp = lvh ! denscale(lccn:lvh) = 1 - IF ( ihvol >= 1 ) THEN - lvhl = ltmp+1 - ltmp = lvhl - denscale(lvhl) = 1 - ENDIF IF ( mixedphase ) THEN ltmp = ltmp + 1 lsw = ltmp @@ -1705,7 +1813,8 @@ SUBROUTINE nssl_2mom_init( & - + ! write(0,*) 'wrf_init: lh,lhl,lzh,lzhl = ',lh,lhl,lzh,lzhl + ! write(0,*) 'wrf_init: ipconc = ',ipconc ! write(0,*) 'wrf_init: irenuc, turn_on_ccna = ',irenuc, turn_on_ccna IF ( turn_on_ccna ) THEN ltmp = ltmp + 1 @@ -2171,19 +2280,24 @@ END SUBROUTINE nssl_2mom_init !! Driver subroutine that copies state data to local 2D arrays for microphysics calls SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw, chl, & cn, vhw, vhl, cna, cni, f_cn, f_cna, f_cina, & + f_qc, f_qr, f_qi, f_qs, f_qh, f_qhl, & cnuf, f_cnuf, & zrw, zhw, zhl, f_zrw, f_zhw, f_zhl, f_vhw, f_vhl, & qsw, qhw, qhlw, & tt, th, pii, p, w, dn, dz, dtp, itimestep, & + is_theta_or_temp, & ntmul, ntcnt, lastloop, & RAINNC,RAINNCV, & dx, dy, & axtra, & SNOWNC, SNOWNCV, GRPLNC, GRPLNCV, & SR,HAILNC, HAILNCV, & + hail_maxk1, hail_max2d, nwp_diagnostics, & tkediss, & re_cloud, re_ice, re_snow, re_rain, & + re_graup, re_hail, & has_reqc, has_reqi, has_reqs, has_reqr, & + has_reqg, has_reqh, & rainncw2, rainnci2, & dbz, vzf,compdbz, & rscghis_2d,rscghis_2dp,rscghis_2dn, & @@ -2217,6 +2331,8 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw + + implicit none @@ -2234,6 +2350,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw zrw, zhw, zhl, & qsw, qhw, qhlw, & qi,qhl,ccw,crw,cci,csw,chw,chl,vhw,vhl + integer, optional, intent(in) :: is_theta_or_temp logical, optional, intent(in) :: f_zrw, f_zhw, f_zhl, f_vhw, f_vhl ! not used yet real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: dbz, vzf, cn, cna, cni, cnuf real, dimension(ims:ime, jms:jme), optional, intent(inout):: compdbz @@ -2268,16 +2385,21 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout) :: axtra ! WRF variables - real, dimension(ims:ime, jms:jme), intent(inout):: & + real, dimension(ims:ime, jms:jme) :: & RAINNC,RAINNCV ! accumulated precip (NC) and rate (NCV) real, dimension(ims:ime, jms:jme), optional, intent(inout):: & SNOWNC,SNOWNCV,GRPLNC,GRPLNCV,SR ! accumulated precip (NC) and rate (NCV) real, dimension(ims:ime, jms:jme), optional, intent(inout):: & HAILNC,HAILNCV ! accumulated precip (NC) and rate (NCV) + real, dimension(ims:ime, jms:jme), optional, intent(inout) :: hail_maxk1, hail_max2d + integer, optional, intent(in) :: nwp_diagnostics +! for cm1, set nproctot=44 (or as needed) to get domain total rates integer, parameter :: nproc = 1 - REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(INOUT):: re_cloud, re_ice, re_snow, re_rain + double precision :: proctot(nproc),proctotmpi(nproc) + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(INOUT):: re_cloud, re_ice, re_snow, & + re_rain, re_graup, re_hail REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(IN):: tkediss - INTEGER, INTENT(IN), optional :: has_reqc, has_reqi, has_reqs, has_reqr + INTEGER, INTENT(IN), optional :: has_reqc, has_reqi, has_reqs, has_reqr, has_reqg, has_reqh real, dimension(ims:ime, jms:jme), intent(out), optional :: & rainncw2, rainnci2 ! liquid rain, ice, accumulation rates real, optional, intent(in) :: dx,dy @@ -2286,6 +2408,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw integer, intent(in), optional :: ntmul, ntcnt logical, optional, intent(in) :: lastloop logical, optional, intent(in) :: diagflag, f_cna, f_cn, f_cina, f_cnuf + logical, optional, intent(in) :: f_qc, f_qr, f_qi, f_qs, f_qh, f_qhl integer, optional, intent(in) :: ipelectmp, ke_diag ! CCPP error handling @@ -2298,7 +2421,11 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw LOGICAL :: flag_qndrop ! wrf-chem LOGICAL :: flag_qnifa , flag_qnwfa logical :: flag_cnuf = .false. + logical :: flag_ccn = .false. + logical :: flag_qi = .true. + logical :: has_reqg_local = .false., has_reqh_local = .false. logical :: flag + logical :: nwp_diagflag = .false. real :: cinchange, t7max,testmax,wmax ! 20130903 acd_ck_washout start @@ -2323,9 +2450,11 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw real, dimension(its:ite, kts:kte) :: rainprod2d, evapprod2d,tke2d real, dimension(its:ite, 1, kts:kte, na) :: an, ancuten real, dimension(its:ite, 1, kts:kte, nxtra) :: axtra2d + real, dimension(its:ite, 1, kts:kte, 3) :: alpha2d real, dimension(its:ite, 1, kts:kte) :: t0,t1,t2,t3,t4,t5,t6,t7,t8,t9 real, dimension(its:ite, 1, kts:kte) :: dn1,t00,t77,ssat,pn,wn,dz2d,dz2dinv,dbz2d,vzf2d real, dimension(its:ite, 1, na) :: xfall + real, dimension(its:ite, 1) :: hailmax1d,hailmaxk1 real, dimension(kts:kte, nproc) :: thproclocal integer, parameter :: nor = 0, ng = 0 integer :: nx,ny,nz,ngs @@ -2374,15 +2503,6 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw integer :: loopcnt, loopmax, outerloopcnt logical :: lastlooptmp -#ifdef MPI - -#if defined(MPI) - integer, parameter :: ntot = 50 - double precision mpitotindp(ntot), mpitotoutdp(ntot) - INTEGER :: mpi_error_code = 1 -#endif -#endif - ! ------------------------------------------------------------------- @@ -2397,11 +2517,35 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw flag_qnifa = .false. flag_qnwfa = .false. flag_cnuf = .false. + flag_ccn = .false. + nwp_diagflag = .false. IF ( PRESENT ( nssl_progn ) ) flag_qndrop = nssl_progn IF ( present ( f_cnuf ) ) flag_cnuf = f_cnuf + IF ( present ( nwp_diagnostics ) ) nwp_diagflag = ( nwp_diagnostics > 0 ) + + IF ( present ( f_cn ) .and. present( cn ) ) THEN + flag_ccn = f_cn + ELSEIF ( present( cn ) ) THEN + flag_ccn = .true. + ENDIF + + IF ( present( f_qi ) ) THEN + flag_qi = f_qi + ELSE + IF ( ffrzs < 1.0 ) THEN + flag_qi = .true. + ELSE + flag_qi = .false. + ENDIF + ENDIF + + IF ( .not. flag_qi .and. ffrzs < 1.0 ) ffrzs = 1.0 + IF ( PRESENT ( has_reqg ) ) has_reqg_local = has_reqg > 0 + IF ( PRESENT ( has_reqh ) ) has_reqh_local = has_reqh > 0 + loopmax = 1 outerloopcnt = 1 lastlooptmp = .true. @@ -2411,7 +2555,13 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw lastlooptmp = lastloop ENDIF - ! --- + + has_wetscav = .false. + IF ( wrfchem_flag > 0 ) THEN + IF ( PRESENT( wetscav_on ) ) THEN + has_wetscav = wetscav_on + ENDIF + ENDIF IF ( present( f_cna ) ) THEN f_cnatmp = f_cna @@ -2462,8 +2612,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw nx = ite-its+1 ny = 1 ! set up as 2D slabs nz = kte-kts+1 + ngs = Max(nz,64) - IF ( .not. present( cn ) ) THEN + IF ( .not. flag_ccn ) THEN renucfrac = 1.0 ENDIF @@ -2527,30 +2678,32 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw DO jy = jts,jye - xfall(:,:,:) = 0.0 - ! write(0,*) 'N2M: load an, jy,lccn = ',jy,lccn,qccn IF ( present( pcc2 ) .and. makediag ) THEN axtra2d(its:ite,1,kts:kte,:) = 0.0 ENDIF + IF ( nwp_diagflag ) THEN + alpha2d(its:ite,1,kts:kte,1) = alphar + alpha2d(its:ite,1,kts:kte,2) = alphah + alpha2d(its:ite,1,kts:kte,3) = alphahl + ENDIF + + ! copy from 3D array to 2D slab DO kz = kts,kte DO ix = its,ite - IF ( present( tt ) ) THEN an(ix,1,kz,lt) = tt(ix,kz,jy)/pii(ix,kz,jy) ELSE an(ix,1,kz,lt) = th(ix,kz,jy) ENDIF - - an(ix,1,kz,lv) = qv(ix,kz,jy) an(ix,1,kz,lc) = qc(ix,kz,jy) an(ix,1,kz,lr) = qr(ix,kz,jy) - IF ( present( qi ) ) THEN + IF ( flag_qi ) THEN an(ix,1,kz,li) = qi(ix,kz,jy) ELSE an(ix,1,kz,li) = 0.0 @@ -2561,7 +2714,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( lccn > 1 ) THEN IF ( is_aerosol_aware .and. flag_qnwfa ) THEN ! - ELSEIF ( present( cn ) ) THEN + ELSEIF ( flag_ccn ) THEN IF ( lccna > 1 .and. .not. ( present( cna ) .and. f_cnatmp ) ) THEN an(ix,1,kz,lccna) = cn(ix,kz,jy) an(ix,1,kz,lccn) = qccn ! cn(ix,kz,jy) @@ -2690,6 +2843,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! ssival = Min(t8s,max(an(ix,1,kz,lv),0.0))/t9s ! qv/qvi + if ( ssival .gt. 1.0 ) then ! IF ( icenucopt == 1 ) THEN @@ -2750,7 +2904,8 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! naer needs units of cm**-3, so mult by 1.e-6 ! dp1 = 1.e3*0.0000594*(273.16 - t0(ix,1,kz))**3.33 * (1.e-6*cin*dn(ix,1,kz))**(0.0264*(273.16 - t0(ix,1,kz)) + 0.0033) - dp1 = 1.e3*dn1(ix,1,kz)/rho00*0.0000594*(273.16 - t0(ix,1,kz))**3.33 * (1.e-6*naer)**(0.0264*(273.16 - t0(ix,1,kz)) + 0.0033) + tmp = 1.e-6*naer + dp1 = 1.e3*dn1(ix,1,kz)/rho00*0.0000594*(273.16 - t0(ix,1,kz))**3.33 * tmp**(0.0264*(273.16 - t0(ix,1,kz)) + 0.0033) t7(ix,1,kz) = Min(dp1, 1.0d30) ELSE @@ -2767,16 +2922,12 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDDO ! ix ENDDO ! kz - has_wetscav = .false. - IF ( wrfchem_flag > 0 ) THEN - IF ( PRESENT( wetscav_on ) ) THEN - has_wetscav = wetscav_on - IF ( has_wetscav ) THEN - IF ( PRESENT( rainprod ) ) rainprod2d(its:ite,kts:kte) = 0 - IF ( PRESENT( evapprod ) ) evapprod2d(its:ite,kts:kte) = 0 - ENDIF - ENDIF - ENDIF + IF ( wrfchem_flag > 0 ) THEN + IF ( has_wetscav ) THEN + IF ( PRESENT( rainprod ) ) rainprod2d(its:ite,kts:kte) = 0 + IF ( PRESENT( evapprod ) ) evapprod2d(its:ite,kts:kte) = 0 + ENDIF + ENDIF ! transform from number mixing ratios to number conc. @@ -2917,9 +3068,6 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! ENDIF ! .false. - - ngs = 128 - IF ( isedonly /= 1 ) THEN ! call nssl_2mom_gs: main gather-scatter routine to calculate microphysics @@ -2940,11 +3088,11 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! & ln,ipc,lvol,lz,lliq, & & cdx, & & xdn0,dbz2d,tke2d, & - & thproclocal,nproc,dx1,dy1, & + & thproclocal,nproc,dx1,dy1,ngs, & & timevtcalc,axtra2d, makediag & - & ,has_wetscav, rainprod2d, evapprod2d & + & ,has_wetscav, rainprod2d, evapprod2d, alpha2d & & ,errmsg,errflg & - & ,elec2,its,ids,ide,jds,jde,ngs & + & ,elec2,its,ids,ide,jds,jde & & ) @@ -2967,9 +3115,10 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw & ,dz2d & & ,t0,t9 & & ,an,dn1,t77 & - & ,pn,wn & + & ,pn,wn & + & ,ngs & & ,axtra2d, makediag & - & ,ssat,t00,t77,flag_qndrop,ngs) + & ,ssat,t00,t77,flag_qndrop) ! recalculate dn1 after temperature changes DO kz = kts,kte @@ -2985,14 +3134,12 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDDO ! loopcnt=1,loopmax - IF ( present( pcc2 ) .and. makediag ) THEN DO kz = kts,kte DO ix = its,ite ! example of using the 'axtra2d' array to get rates out of the microphysics routine for output. ! Search for 'axtra' to find example code below ! pcc2(ix,kz,jy) = axtra2d(ix,1,kz,1) - ENDDO ENDDO ENDIF @@ -3056,7 +3203,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw call calc_eff_radius & & (nx,ny,nz,na,jy & & ,nor,nor & - & ,t1=t1,t2=t2,t3=t3,t4=t4 & + & ,t1=t1,t2=t2,t3=t3,t4=t4,t5=t5,t6=t6,f_t5=has_reqg_local, f_t6=has_reqh_local & & ,an=an,dn=dn1 ) DO kz = kts,kte @@ -3078,12 +3225,46 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDDO ENDIF ENDIF + + IF ( present(has_reqg) .and. present( re_graup ) ) THEN + IF ( has_reqg /= 0 ) THEN + DO kz = kts,kte + DO ix = its,ite + re_graup(ix,kz,jy) = MAX(50.E-6, MIN(t5(ix,1,kz), 10.E-3)) + ENDDO + ENDDO + ENDIF + ENDIF + + IF ( present(has_reqh) .and. present( re_hail ) ) THEN + IF ( has_reqh /= 0 ) THEN + DO kz = kts,kte + DO ix = its,ite + re_hail(ix,kz,jy) = MAX(50.E-6, MIN(t5(ix,1,kz), 40.E-3)) + ENDDO + ENDDO + ENDIF + ENDIF ENDIF ENDIF + IF ( present( hail_maxk1 ) .and. present( hail_max2d ) .and. nwp_diagflag ) THEN + DO ix = its,ite + hailmax1d(ix,1) = hail_max2d(ix,jy) + hailmaxk1(ix,1) = hail_maxk1(ix,jy) + ENDDO + call hailmaxd(dtp,nx,ny,nz,an,na,nor,nor,alpha2d,dn1, & + hailmax1d,hailmaxk1,1 ) + + DO ix = its,ite + hail_max2d(ix,jy) = hailmax1d(ix,1) + hail_maxk1(ix,jy) = hailmaxk1(ix,1) + ENDDO +! ENDIF + ENDIF ! transform concentrations back to mixing ratios DO il = lnb,na @@ -3111,14 +3292,14 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw qv(ix,kz,jy) = an(ix,1,kz,lv) qc(ix,kz,jy) = an(ix,1,kz,lc) qr(ix,kz,jy) = an(ix,1,kz,lr) - IF ( present(qi) ) qi(ix,kz,jy) = an(ix,1,kz,li) + IF ( flag_qi ) qi(ix,kz,jy) = an(ix,1,kz,li) qs(ix,kz,jy) = an(ix,1,kz,ls) qh(ix,kz,jy) = an(ix,1,kz,lh) IF ( lhl > 1 ) qhl(ix,kz,jy) = an(ix,1,kz,lhl) IF ( lccn > 1 .and. is_aerosol_aware .and. flag_qnwfa ) THEN ! not used here - ELSEIF ( present( cn ) .and. lccn > 1 .and. .not. flag_qndrop) THEN + ELSEIF ( flag_ccn .and. lccn > 1 .and. .not. flag_qndrop) THEN IF ( lccna > 1 .and. .not. ( present( cna ) .and. f_cnatmp ) ) THEN cn(ix,kz,jy) = Max(0.0, an(ix,1,kz,lccna) ) ELSE @@ -3185,7 +3366,8 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDDO ENDDO - + + ENDDO ! jy @@ -3824,8 +4006,242 @@ Function delabk(ba,bb,nua,nub,mua,mub,k) RETURN END Function delabk + + + +! ####################################################################### +! HAILMAXD - calculated maximum expected hail size +! ####################################################################### +!>\ingroup mod_nsslmp +!! Hail max size subroutine. + subroutine hailmaxd(dtp,nx,ny,nz,an,na,nor,norz,alpha2d,dn, & + & hailmax1d,hailmaxk1,jslab ) +! +! Calculate maximum hail size from the tail of of the distribution. The value +! of thresh_conc sets the minimum concentration in the integral over (Dmax, Inf). +! This uses the lookup tables for incomplete gamma functions and simply search for +! the expected value (and linearly interpolate) on D. +! +! Written by ERM 7/2023 +! +! +! + implicit none + + integer nx,ny,nz,nor,norz,ngt,jgs,na,ia + integer id ! =1 use density, =0 no density +! integer :: its,ite ! x-range to calculate + integer ng1 + parameter(ng1 = 1) + + real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) + real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + +! real gz(-nor+ng1:nz+nor),z1d(-nor+ng1:nz+nor,4) + real dtp + real alpha2d(-nor+1:nx+nor,1,-norz+1:nz+norz,3) ! array for PSD shape parameters + real :: hailmax1d(nx,ny),hailmaxk1(nx,ny) + integer infdo + integer jslab ! which line of xfall to use + + integer ix,jy,kz,ndfall,n,k,il,in + double precision :: tmp, ratio, del, g1palp + real, parameter :: dz = 200. + + real :: db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1) + + real :: rhovtzx(nz,nx) + + real :: alp, diam, diam1, hwdn + +! real, parameter :: cmin = 0.001 ! threshold number per m^3 for maximum diamter (threshold from diag_nwp) + DOUBLE PRECISION, PARAMETER:: thresh_conc = 0.0005d0 ! number conc. of graupel/hail per cubic meter + real :: cwchtmp,cwchltmp, maxdia + +!----------------------------------------------------------------------------- + + integer :: ixb, jyb, kzb + integer :: ixe, jye, kze + integer :: plo, phi + integer :: ialp, i, j + + logical :: debug_mpi = .TRUE. + +! ################################################################### + + + IF ( lh > 1 ) THEN + cwchtmp = ((3. + dnu(lh))*(2. + dnu(lh))*(1.0 + dnu(lh)))**(-1./3.) + ENDIF + IF ( lhl > 1 ) THEN + cwchltmp = ((3. + dnu(lhl))*(2. + dnu(lhl))*(1.0 + dnu(lhl)))**(-1./3.) + ENDIF + + + kzb = 1 + kze = nz + + ixb = 1 ! aliased its + ixe = nx ! aliased ite + + + jy = jslab + jgs = jy + + +! hailmax1d(:,jy) = 0.0 +! hailmaxk1(:,jy) = 0.0 + + if ( ndebug .gt. 0 ) write(0,*) 'dbg = 3a' + + +! first graupel, even if hail is also predicted, since graupel can sometime be large on its own + IF ( lh > 1 .and. lnh > 1 ) THEN + DO kz = kzb,kze + DO ix = ixb,ixe + IF ( an(ix,jy,kz,lh) .gt. qxmin(lh) .and. an(ix,jy,kz,lnh) .gt. thresh_conc ) THEN + IF ( lvh .gt. 1 ) THEN + hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) + ELSE + hwdn = rho_qh + ENDIF + tmp = 1. + alpha2d(ix,1,kz,2) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = dn(ix,jy,kz)*an(ix,jy,kz,lh)/(hwdn*an(ix,jy,kz,lnh)) + diam = (6.0*tmp/(3.14159))**(1./3.) + IF ( lzh > 1 ) THEN ! 3moment + cwchtmp = ((3. + alpha2d(ix,1,kz,2))*(2. + alpha2d(ix,1,kz,2))*(1.0 + alpha2d(ix,1,kz,2)))**(-1./3.) + ENDIF + diam1 = diam*cwchtmp ! characteristic diameter, i.e., 1/lambda + ! want cxd1 = thresh_conc + ! tmp = gaminterp(ratio,alpha(mgs,lh),1,1) + ! cxd1 = cx(mgs,lh)*(tmp)/g1palp + ! tmp = thresh_conc*g1palp/cx + ! + tmp = thresh_conc*g1palp/an(ix,jy,kz,lnh) + alp = alpha2d(ix,1,kz,2) + ! gamxinflu(i,j,luindex,ilh) + j = Int(Max(0.0,Min(maxalphalu,alp))*dqiacralphainv) + ratio = 0.0 + maxdia = 0.0 + ! eventually could replace with bisection search, but final value of i is usually small + ! compared to nqiacrratio + DO i = 0,nqiacrratio-1 + IF ( gamxinflu(i,j,1,1) >= tmp .and. tmp >= gamxinflu(i+1,j,1,1) ) THEN + ! interpolate here for FWIW + ratio = i*dqiacrratio + del = tmp - gamxinflu(i,j,1,1) + ratio = (float(i) + del/(gamxinflu(i+1,j,1,1) - gamxinflu(i,j,1,1)))*dqiacrratio + exit + ENDIF + ENDDO + + IF ( ratio > 0.0 ) THEN + maxdia = ratio*diam1 ! units of m + ENDIF + + IF ( kz == kzb ) THEN + hailmaxk1(ix,jy) = Max( maxdia, hailmaxk1(ix,jy) ) +! IF ( maxdia > 0.1 ) THEN +! IF ( an(ix,jy,kz,lh) > 1.e-4 ) THEN +! write(0,*) 'maxdia,tmp,alp,ratio,diam,diam1= ',maxdia,tmp,alp,ratio,diam*100.,diam1*100. +! write(0,*) 'hwdn, cxhl, qx, g1palp = ',hwdn, an(ix,jy,kz,lnhl), an(ix,jy,kz,lhl), g1palp +! write(0,*) 'j,gamxinflu(0,2,4) = ',j,gamxinflu(0,j,1,1),gamxinflu(2,j,1,1), & +! gamxinflu(4,j,1,1) +! ENDIF + ENDIF + + hailmax1d(ix,jy) = Max(maxdia, hailmax1d(ix,jy) ) + + ! + + ENDIF + + ENDDO + ENDDO + + ENDIF ! lh + +! And diam for hail if present + IF ( lhl > 1 .and. lnhl > 1 ) THEN + DO kz = kzb,kze + DO ix = ixb,ixe + IF ( an(ix,jy,kz,lhl) .gt. qxmin(lhl) .and. an(ix,jy,kz,lnhl) .gt. thresh_conc ) THEN + IF ( lvhl .gt. 1 ) THEN + hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl) + ELSE + hwdn = rho_qhl + ENDIF + + tmp = 1. + alpha2d(ix,1,kz,3) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/(hwdn*an(ix,jy,kz,lnhl)) + diam = (6.0*tmp/(3.14159))**(1./3.) + IF ( lzhl > 1 ) THEN ! 3moment + cwchltmp = ((3. + alpha2d(ix,1,kz,3))*(2. + alpha2d(ix,1,kz,3))*(1.0 + alpha2d(ix,1,kz,3)))**(-1./3.) + ENDIF + diam1 = diam*cwchltmp ! characteristic diameter, i.e., 1/lambda + ! want cxd1 = thresh_conc + ! tmp = gaminterp(ratio,alpha(mgs,lh),1,1) + ! cxd1 = cx(mgs,lh)*(tmp)/g1palp + ! tmp = thresh_conc*g1palp/cx + ! + tmp = thresh_conc*g1palp/an(ix,jy,kz,lnhl) + alp = alpha2d(ix,1,kz,3) + ! gamxinflu(i,j,luindex,ilh) + j = Int(Max(0.0,Min(maxalphalu,alp))*dqiacralphainv) + ratio = 0.0 + maxdia = 0.0 + ! eventually could replace with bisection search, but final value of i is usually small + ! compared to nqiacrratio + DO i = 0,nqiacrratio-1 + IF ( gamxinflu(i,j,1,1) >= tmp .and. tmp >= gamxinflu(i+1,j,1,1) ) THEN + ! interpolate here for FWIW + ratio = i*dqiacrratio + del = tmp - gamxinflu(i,j,1,1) + ratio = (float(i) + del/(gamxinflu(i+1,j,1,1) - gamxinflu(i,j,1,1)))*dqiacrratio + exit + ENDIF + ENDDO + + IF ( ratio > 0.0 ) THEN + maxdia = ratio*diam1 ! units of m + ENDIF + + IF ( kz == kzb ) THEN + hailmaxk1(ix,jy) = Max( maxdia, hailmaxk1(ix,jy) ) +! IF ( maxdia > 0.1 ) THEN +! IF ( an(ix,jy,kz,lhl) > 1.e-4 ) THEN +! write(0,*) 'maxdia,tmp,alp,ratio,diam,diam1= ',maxdia,tmp,alp,ratio,diam*100.,diam1*100. +! write(0,*) 'hwdn, cxhl, qx, g1palp = ',hwdn, an(ix,jy,kz,lnhl), an(ix,jy,kz,lhl), g1palp +! write(0,*) 'j,gamxinflu(0,2,4) = ',j,gamxinflu(0,j,1,1),gamxinflu(2,j,1,1), & +! gamxinflu(4,j,1,1) +! ENDIF + ENDIF + + hailmax1d(ix,jy) = Max(maxdia, hailmax1d(ix,jy) ) + + ! + + ENDIF + + ENDDO + ENDDO + + ENDIF + + + END SUBROUTINE HAILMAXD +! ####################################################################### +! ####################################################################### !>\ingroup mod_nsslmp !! Sedimentation driver subroutine. Calls fallout column by column subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & @@ -4872,9 +5288,6 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & an(ix,jy,kz,lnr) = nrx ! *dninv ! convert to number mixing ratio - IF ( lzr > 1 ) THEN ! set reflectivity moment - an(ix,jy,kz,lzr) = 36.*g1r*dn(ix,kz)**2*q**2/(pi**2*xdnr**2*nrx) ! *dninv - ENDIF ELSEIF ( an(ix,jy,kz,lr) <= qxmin(lr) .or. & ( an(ix,jy,kz,lnr) <= cxmin .and. an(ix,jy,kz,lr) <= qxmin_init(lr)) ) THEN an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lr) @@ -4883,6 +5296,15 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & ENDIF ENDIF + IF ( lzr > 1 ) THEN ! set reflectivity moment + IF ( an(ix,jy,kz,lr) > qxmin_init(lr) .and. an(ix,jy,kz,lzr) < zxmin .and. & + an(ix,jy,kz,lnr) > cxmin ) THEN + q = an(ix,jy,kz,lr) + nrx = an(ix,jy,kz,lnr) + an(ix,jy,kz,lzr) = 36.*g1r*dn(ix,kz)**2*q**2/(pi**2*xdnr**2*nrx) ! *dninv + ENDIF + ENDIF + ! snow IF ( lns > 1 ) THEN IF ( an(ix,jy,kz,lns) <= 0.1*cxmin .and. an(ix,jy,kz,ls) > qxmin_init(ls) ) THEN @@ -4936,9 +5358,6 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & an(ix,jy,kz,lvh) = 0.0 ENDIF - IF ( lzh > 1 ) THEN ! set reflectivity moment - an(ix,jy,kz,lzh) = 36.*g1h*dn(ix,kz)**2*q**2/(pi**2*xdnh**2*nrx) ! *dninv - ENDIF ELSEIF ( an(ix,jy,kz,lh) <= qxmin(lh) .or. & ( an(ix,jy,kz,lnh) <= cxmin .and. an(ix,jy,kz,lh) <= qxmin_init(lh)) ) THEN @@ -4948,6 +5367,15 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & ENDIF ENDIF + IF ( lzh > 1 ) THEN ! set reflectivity moment + IF ( an(ix,jy,kz,lh) > qxmin_init(lh) .and. an(ix,jy,kz,lzh) < zxmin .and. & + an(ix,jy,kz,lnh) > cxmin ) THEN + q = an(ix,jy,kz,lh) + nrx = an(ix,jy,kz,lnh) + an(ix,jy,kz,lzh) = 36.*g1h*dn(ix,kz)**2*q**2/(pi**2*xdnh**2*nrx) ! *dninv + ENDIF + ENDIF + ! hail IF ( lnhl > 1 .and. lhl > 1 ) THEN @@ -4968,10 +5396,6 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & an(ix,jy,kz,lnhl) = nrx ! *dninv ! convert to number mixing ratio - IF ( lzhl > 1 ) THEN ! set reflectivity moment - an(ix,jy,kz,lzhl) = 36.*g1hl*dn(ix,kz)**2*q**2/(pi**2*xdnhl**2*nrx) ! *dninv - ENDIF - ELSEIF ( an(ix,jy,kz,lhl) <= qxmin(lhl) .or. & ( an(ix,jy,kz,lnhl) <= cxmin .and. an(ix,jy,kz,lhl) <= qxmin_init(lhl)) ) THEN @@ -4980,6 +5404,15 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & ENDIF ENDIF + + IF ( lzhl > 1 ) THEN ! set reflectivity moment + IF ( an(ix,jy,kz,lhl) > qxmin_init(lhl) .and. an(ix,jy,kz,lzhl) < zxmin .and. & + an(ix,jy,kz,lnhl) > cxmin ) THEN + q = an(ix,jy,kz,lhl) + nrx = an(ix,jy,kz,lnhl) + an(ix,jy,kz,lzhl) = 36.*g1hl*dn(ix,kz)**2*q**2/(pi**2*xdnhl**2*nrx) ! *dninv + ENDIF + ENDIF ! ENDIF @@ -5250,7 +5683,7 @@ END subroutine calcnfromcuten SUBROUTINE calc_eff_radius & & (nx,ny,nz,na,jyslab & & ,nor,norz & - & ,t1,t2,t3,t4 & + & ,t1,t2,t3,t4,t5,t6, f_t5,f_t6 & & ,qcw,qci,qsw,qrw & & ,ccw,cci,csw,crw & & ,an,dn ) @@ -5272,6 +5705,9 @@ SUBROUTINE calc_eff_radius & real,optional :: t2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) real,optional :: t3(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) real,optional :: t4(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real,optional :: t5(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real,optional :: t6(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + logical, optional :: f_t5, f_t6 ! flags to fill t5/t6 for graupel/hail real, optional :: an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) @@ -7495,7 +7931,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*1000.*1000) an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) - ELSEIF ( zx(mgs,il) <= 0.0 .and. cx(mgs,il) > 0.0 ) THEN + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > cxmin ) THEN ! have mass and concentration but no reflectivity, so set reflectivity, using default alpha g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) chw = cx(mgs,il) @@ -7511,7 +7947,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(xdn(mgs,lr)**2*chw) an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) - ELSEIF ( zx(mgs,il) <= 0.0 .and. cx(mgs,il) <= 0.0 ) THEN + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN ! How did this happen? ! set values according to dBZ of -10, or Z = 0.1 ! write(91,*) 'alpha = ',alpha(mgs,il) @@ -7710,7 +8146,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ! zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw zx(mgs,il) = Min(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(chw*(pi*xdn(mgs,il))**2) ) an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) - ELSEIF ( zx(mgs,il) <= 0.0 .and. cx(mgs,il) <= 0.0 ) THEN + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN ! How did this happen? ! write(91,*) 'ziegfall: something screwy with moments: il = ',il ! write(91,*) 'q,n,z = ', 1.e3*qx(mgs,il),cx(mgs,il),zx(mgs,il) @@ -7737,7 +8173,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ENDIF ENDIF - IF ( qx(mgs,il) .gt. qxmin(il) .and. cx(mgs,il) .gt. 0.0 ) THEN + IF ( qx(mgs,il) .gt. qxmin(il) .and. cx(mgs,il) .gt. cxmin ) THEN chw = cx(mgs,il) qr = qx(mgs,il) z = zx(mgs,il) @@ -9003,8 +9439,9 @@ SUBROUTINE NUCOND & & ,t0,t9 & & ,an,dn,p2 & & ,pn,w & + & ,ngs & & ,axtra,io_flag & - & ,ssfilt,t00,t77,flag_qndrop,ngs & + & ,ssfilt,t00,t77,flag_qndrop & & ) @@ -9061,6 +9498,7 @@ SUBROUTINE NUCOND & logical :: io_flag real :: dv + real :: ccnefactwo, sstmp, cn1, cnuctmp ! ! declarations microphysics and for gather/scatter @@ -9069,7 +9507,6 @@ SUBROUTINE NUCOND & real, parameter :: cwmas20 = 1000.*0.523599*(2.*20.e-6)**3 ! mass of 20-micron radius droplet, for sat. adj. integer nxmpb,nzmpb,nxz integer mgs,ngs,numgs,inumgs -! parameter (ngs=1 ) integer ngscnt,igs(ngs),kgs(ngs) integer kgsp(ngs),kgsm(ngs) integer nsvcnt @@ -9088,6 +9525,7 @@ SUBROUTINE NUCOND & real ccnc(ngs), ccna(ngs), cnuc(ngs), cwnccn(ngs) + real :: ccnc_nu(ngs), ccnc_ac(ngs), ccnc_co(ngs) real ccncuf(ngs) real sscb ! 'cloud base' SS threshold parameter ( sscb = 2.0 ) @@ -9100,7 +9538,7 @@ SUBROUTINE NUCOND & integer ifilt ! =1 to filter ssat, =0 to set ssfilt=ssat parameter ( ifilt = 0 ) real temp1,temp2 ! ,ssold - real :: ssmax(ngs) ! maximum SS experienced by a parcel + real :: ssmax(ngs) ! maximum SS experienced by a parcel real ssmx real dnnet,dqnet ! real cnu,rnu,snu,cinu @@ -9224,7 +9662,6 @@ SUBROUTINE NUCOND & integer :: count - ! ------------------------------------------------------------------------------- itile = nxi jtile = ny @@ -9238,6 +9675,7 @@ SUBROUTINE NUCOND & kzbeg = 1 nzbeg = 1 + IF ( ac_opt > 0 ) ccnefactwo = (1.63e-3/(cck * beta(3./2., cck/2.)))**(1.0/(cck + 2.0)) f5 = 237.3 * 17.27 * 2.5e6 / cp ! combined constants for rain condensation (Soong and Ogura 73) jy = 1 @@ -9463,12 +9901,16 @@ SUBROUTINE NUCOND & ELSE ssmax(mgs) = 0.0 ENDIF - IF ( lccn .gt. 1 ) THEN - ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn) + IF ( lccn .gt. 1 .and. ac_opt == 0 ) THEN + IF ( lccnuf .gt. 1 .and. i_uf_or_ccn > 0 ) THEN + ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn) + an(igs(mgs),jy,kgs(mgs),lccnuf) + ELSE + ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn) + ENDIF ELSE ccnc(mgs) = cwnccn(mgs) ENDIF - IF ( lccnuf .gt. 1 ) THEN + IF ( lccnuf .gt. 1 .and. i_uf_or_ccn == 0 ) THEN ccncuf(mgs) = an(igs(mgs),jy,kgs(mgs),lccnuf) ELSE ccncuf(mgs) = 0.0 @@ -9534,7 +9976,7 @@ SUBROUTINE NUCOND & il = lr DO mgs = 1,ngscnt - IF ( zx(mgs,il) <= 0.0 ) THEN + IF ( zx(mgs,il) <= zxmin ) THEN qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il) qx(mgs,il) = 0.0 cx(mgs,il) = 0.0 @@ -9577,7 +10019,7 @@ SUBROUTINE NUCOND & ENDIF ! an(igs(mgs),jgs,kgs(mgs),ln(il)) = zx(mgs,il) - ELSEIF ( zx(mgs,il) <= 0.0 .and. cx(mgs,il) > 0.0 ) THEN + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > 0.0 ) THEN ! have mass and concentration but no reflectivity, so set reflectivity, using default alpha IF ( imurain == 3 ) THEN g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) @@ -9593,7 +10035,7 @@ SUBROUTINE NUCOND & ENDIF - ELSEIF ( zx(mgs,il) <= 0.0 .and. cx(mgs,il) <= 0.0 ) THEN + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN ! How did this happen? ! set values according to dBZ of -10, or Z = 0.1 ! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 @@ -9773,6 +10215,8 @@ SUBROUTINE NUCOND & ssfkp1(mgs) = ssfilt(igs(mgs),jgs,Min(nz-1,kgs(mgs)+1)) ssfkm1(mgs) = ssfilt(igs(mgs),jgs,Max(1,kgs(mgs)-1)) +! IF ( wvel(mgs) /= 0.0 ) write(0,*) 'mgs,wvel1,ssf = ',mgs,wvel(mgs),ssf(mgs) + ENDDO @@ -9782,7 +10226,7 @@ SUBROUTINE NUCOND & ! cloud water variables ! - if ( ndebug .gt. 0 )write(0,*) 'ICEZVD_DR: Set cloud water variables' + if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_DR: Set cloud water variables' do mgs = 1,ngscnt xv(mgs,lc) = 0.0 @@ -9914,15 +10358,14 @@ SUBROUTINE NUCOND & ENDIF qx(mgs,lc) = 0. IF ( restoreccn ) THEN - IF ( irenuc <= 2 ) THEN - IF ( .not. invertccn ) THEN - ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + restoreccnfrac*cx(mgs,lc) ) ) - ELSE - ccnc(mgs) = ccnc(mgs) + restoreccnfrac*cx(mgs,lc) - ENDIF - ENDIF - IF ( lccna > 1 ) THEN - ccna(mgs) = ccna(mgs) - restoreccnfrac*cx(mgs,lc) + IF ( lccna > 1 ) THEN + ccna(mgs) = ccna(mgs) - restoreccnfrac*cx(mgs,lc) + ELSEIF ( irenuc <= 2 ) THEN + IF ( .not. invertccn ) THEN + ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + restoreccnfrac*cx(mgs,lc) ) ) + ELSE + ccnc(mgs) = ccnc(mgs) + restoreccnfrac*cx(mgs,lc) + ENDIF ENDIF ENDIF cx(mgs,lc) = 0. @@ -9932,7 +10375,9 @@ SUBROUTINE NUCOND & qx(mgs,lc) = qx(mgs,lc) - QEVAP IF ( qx(mgs,lc) .le. 0. ) THEN IF ( restoreccn ) THEN - IF ( irenuc <= 2 ) THEN + IF ( lccna > 1 ) THEN + ccna(mgs) = ccna(mgs) - restoreccnfrac*cx(mgs,lc) + ELSEIF ( irenuc <= 2 ) THEN ! ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) ) ! ccnc(mgs) = ccnc(mgs) + cx(mgs,lc) IF ( .not. invertccn ) THEN @@ -9941,15 +10386,14 @@ SUBROUTINE NUCOND & ccnc(mgs) = ccnc(mgs) + restoreccnfrac*cx(mgs,lc) ENDIF ENDIF - IF ( lccna > 1 ) THEN - ccna(mgs) = ccna(mgs) - restoreccnfrac*cx(mgs,lc) - ENDIF ENDIF cx(mgs,lc) = 0. ELSE tmp = 0.9*QEVAP*cx(mgs,lc)/qctmp ! let droplets get smaller but also remove some. A factor of 1.0 would maintain same size IF ( restoreccn ) THEN - IF ( irenuc <= 2 ) THEN + IF ( lccna > 1 ) THEN + ccna(mgs) = ccna(mgs) - restoreccnfrac*tmp + ELSEIF ( irenuc <= 2 ) THEN ! ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + tmp ) ) ! ccnc(mgs) = ccnc(mgs) + tmp IF ( .not. invertccn ) THEN @@ -9958,9 +10402,6 @@ SUBROUTINE NUCOND & ccnc(mgs) = ccnc(mgs) + restoreccnfrac*tmp ENDIF ENDIF - IF ( lccna > 1 ) THEN - ccna(mgs) = ccna(mgs) - restoreccnfrac*tmp - ENDIF ENDIF cx(mgs,lc) = cx(mgs,lc) - tmp ENDIF @@ -10300,7 +10741,8 @@ SUBROUTINE NUCOND & ! IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 5.0 .and. ccnc(mgs) > 0.1*cwnccn(mgs) ) THEN ! this one works ! IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 ) THEN ! test -- fails ! IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 .and. ccnc(mgs) > 0.1*cwnccn(mgs)) THEN ! test -- is OK - IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 .and. ccnc(mgs) > 0.05*cwnccn(mgs)) THEN ! test + IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 .and. & + ( ccnc(mgs) > 0.05*cwnccn(mgs) .or. ( ac_opt > 0 .and. ccnc_ac(mgs) - cx(mgs,lc) > 0.0 ) ) ) THEN ! test ! IF ( ssf(mgs) > ssmx ) THEN ! original condition CALL QVEXCESS(ngs,mgs,qwvp,qv0,qx(1,lc),pres,thetap,theta0,dcloud, & & pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ssmx,pk,ngscnt) @@ -10311,7 +10753,7 @@ SUBROUTINE NUCOND & ELSE dcloud = 0.0 ENDIF - + thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) qwvp(mgs) = qwvp(mgs) - DCLOUD qx(mgs,lc) = qx(mgs,lc) + DCLOUD @@ -10336,11 +10778,16 @@ SUBROUTINE NUCOND & IF ( .not. flag_qndrop ) THEN ! { do not calculate number of droplets if using wrf-chem + IF ( ac_opt == 0 ) THEN + cnuctmp = cnuc(mgs) + ELSE + cnuctmp = ccnc_ac(mgs) + ENDIF ! IF ( ssmax(mgs) .lt. sscb .and. qx(mgs,lc) .gt. qxmin(lc)) THEN IF ( dcloud .gt. qxmin(lc) .and. wvel(mgs) > 0.0) THEN ! CN(mgs) = CCNE*wvel(mgs)**cnexp ! *Min(1.0,1./dtp) ! 0.3465 - CN(mgs) = CCNE0*cnuc(mgs)**(2./(2.+cck))*wvel(mgs)**cnexp ! *Min(1.0,1./dtp) ! 0.3465 + CN(mgs) = CCNE0*cnuctmp**(2./(2.+cck))*wvel(mgs)**cnexp ! *Min(1.0,1./dtp) ! 0.3465 IF ( ny .le. 2 .and. cn(mgs) .gt. 0.0 & & .and. ncdebug .ge. 1 ) THEN write(iunit,*) 'CN: ',cn(mgs)*1.e-6, cx(mgs,lc)*1.e-6, qx(mgs,lc)*1.e3, & @@ -10362,12 +10809,16 @@ SUBROUTINE NUCOND & ENDIF IF ( cn(mgs) .gt. 0.0 ) THEN - IF ( cn(mgs) .gt. ccnc(mgs) ) THEN - cn(mgs) = ccnc(mgs) -! ccnc(mgs) = 0.0 + IF ( ac_opt == 0 ) THEN + IF ( cn(mgs) .gt. ccnc(mgs) ) THEN + cn(mgs) = ccnc(mgs) +! ccnc(mgs) = 0.0 + ENDIF + ELSE + cn(mgs) = Min( cn(mgs), ccnc_ac(mgs) ) ENDIF ! cx(mgs,lc) = cx(mgs,lc) + cn(mgs) - IF ( irenuc <= 2 ) ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + IF ( irenuc <= 2 .and. lccna < 1 ) ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) ccna(mgs) = ccna(mgs) + cn(mgs) ENDIF @@ -10413,7 +10864,8 @@ SUBROUTINE NUCOND & DSSDZ=0. r2dzm=0.50/dz3d(igs(mgs),jy,kgs(mgs)) - IF ( irenuc >= 0 .and. .not. flag_qndrop) THEN ! turn off nucleation when flag_qndrop (using WRF-CHEM for activation) + + IF ( irenuc >= 0 .and. ac_opt == 0 .and. .not. flag_qndrop ) THEN ! turn off nucleation when flag_qndrop (using WRF-CHEM for activation) IF ( irenuc < 2 ) THEN !{ @@ -10490,6 +10942,7 @@ SUBROUTINE NUCOND & ! nucleation CN(mgs) = Min(cn(mgs), ccnc(mgs)) cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass + CN(mgs) = Min( CN(mgs), Max(0.0, (cnuc(mgs) - ccna(mgs) )) ) IF ( .false. .and. ny <= 2 ) THEN write(0,*) 'i,k, cwmasn = ',igs(mgs),kgs(mgs),cwmasn @@ -10517,7 +10970,7 @@ SUBROUTINE NUCOND & cx(mgs,lc) = cx(mgs,lc) + cn(mgs) - ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + IF ( lccna < 1 ) ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) ELSEIF ( irenuc == 3 ) THEN !} { ! Phillips Donner Garner 2007 @@ -10704,17 +11157,22 @@ SUBROUTINE NUCOND & ! 6/13/2016: Phillips et al. appears not to decrement CCN, but only increments CCNa. ! This would allow an initially non-homogeneous (vertically, e.g.) initial value of CCN/rho_air ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) - ELSEIF ( irenuc == 7 ) THEN !} { + ELSEIF ( irenuc == 7 .or. irenuc == 17 ) THEN !} { ! simple Twomey scheme but limit activation to try to do most activation near cloud base, but keep some CCN available for renuclation ! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) cn(mgs) = 0.0 + IF ( irenuc == 7 ) THEN + frac = 0.9 + ELSE + frac = 0.98 + ENDIF ! IF ( ccna(mgs) < 0.7*cnuc(mgs) .and. ccnc(mgs) > 0.69*cnuc(mgs) - ccna(mgs)) THEN ! here, assume we are near cloud base and use Twomey formulation - IF ( ccna(mgs) < 0.9*cnuc(mgs) ) THEN ! { here, assume we are near cloud base and use Twomey formulation - CN(mgs) = Min( 0.91*cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465 + IF ( ccna(mgs) < frac*cnuc(mgs) ) THEN ! { here, assume we are near cloud base and use Twomey formulation + CN(mgs) = Min( (frac+0.01)*cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465 ! IF ( cn(mgs) + ccna(mgs) > 0.71*cnuc ) THEN ! prevent this branch from activating more than 70% of CCN - CN(mgs) = Min( CN(mgs), Max(0.0, (0.9*cnuc(mgs) - ccna(mgs) )) ) + CN(mgs) = Min( CN(mgs), Max(0.0, (frac*cnuc(mgs) - ccna(mgs) )) ) ! CN(mgs) = Min( CN(mgs), Max(0.0, 0.71*ccnc(mgs) - ccna(mgs) ) ) ! write(0,*) '1: k,cn = ',kgs(mgs),cn(mgs),ssf(mgs) !! IF ( ccncuf(mgs) > 0.0 .and. cn(mgs) < 1.e-3 .and. ssmax(mgs) > 1.0 ) THEN @@ -10854,7 +11312,7 @@ SUBROUTINE NUCOND & IF ( cn(mgs) > 0.0 ) THEN cx(mgs,lc) = cx(mgs,lc) + cn(mgs) - ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) ! create some small droplets at minimum size (CP 2000), although it adds very little liquid @@ -10873,8 +11331,6 @@ SUBROUTINE NUCOND & ccna(mgs) = ccna(mgs) + cn(mgs) - - ENDIF ! irenuc >= 0 .and. .not. flag_qndrop IF( cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .LE. qxmin(lc)) cx(mgs,lc)=0. @@ -10927,7 +11383,11 @@ SUBROUTINE NUCOND & ELSEIF ( imaxsupopt == 4 ) THEN cn(mgs) = Min( Max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/Max( cwmasn5, Max(cwmas20,xmas(mgs,lc)) ) ) ENDIF - ccnc(mgs) = Max( 0.0, ccnc(mgs) - cn(mgs) ) + IF ( lccna > 1 ) THEN + ccna(mgs) = ccna(mgs) + cn(mgs) + ELSE + ccnc(mgs) = Max( 0.0, ccnc(mgs) - cn(mgs) ) + ENDIF cx(mgs,lc) = cx(mgs,lc) + cn(mgs) ENDIF @@ -11041,10 +11501,12 @@ SUBROUTINE NUCOND & IF ( ipconc .ge. 2 ) THEN an(igs(mgs),jy,kgs(mgs),lnc) = Max(cx(mgs,lc) , 0.0) IF ( lss > 1 ) an(igs(mgs),jy,kgs(mgs),lss) = Max( 0.0, ssmax(mgs) ) - IF ( lccn .gt. 1 ) THEN - an(igs(mgs),jy,kgs(mgs),lccn) = Max(0.0, ccnc(mgs) ) + IF ( ac_opt == 0 ) THEN + IF ( lccn .gt. 1 .and. lccna .lt. 1 ) THEN + an(igs(mgs),jy,kgs(mgs),lccn) = Max(0.0, ccnc(mgs) ) + ENDIF ENDIF - IF ( lccnuf .gt. 1 ) THEN + IF ( lccnuf .gt. 1 .and. .not. ( lccna .gt. 1 .and. i_uf_or_ccn > 0 ) ) THEN an(igs(mgs),jy,kgs(mgs),lccnuf) = Max(0.0, ccncuf(mgs) ) ENDIF IF ( lccna .gt. 1 ) THEN @@ -11522,20 +11984,25 @@ SUBROUTINE NUCOND & an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lc) an(ix,jy,kz,lc)= 0.0 IF ( ipconc .ge. 2 ) THEN - IF ( lccn .gt. 1 ) THEN - an(ix,jy,kz,lccn) = & - & an(ix,jy,kz,lccn) + Max(0.0,an(ix,jy,kz,lnc)) + IF ( lccn .gt. 1 .or. ac_opt == 1 ) THEN + IF ( irenuc < 5 .and. lccna <= 1 ) THEN + IF ( ac_opt == 0 ) THEN + an(ix,jy,kz,lccn) = an(ix,jy,kz,lccn) + Max(0.0,an(ix,jy,kz,lnc)) + ENDIF + ELSEIF ( lccna > 1 ) THEN + an(ix,jy,kz,lccna) = Max( 0.0, an(ix,jy,kz,lccna) - Max(0.0,an(ix,jy,kz,lnc)) ) + ENDIF ENDIF an(ix,jy,kz,lnc) = 0.0 IF ( lccn > 1 ) an(ix,jy,kz,lccn) = Max( 0.0, an(ix,jy,kz,lccn) ) - IF ( lccna > 0 ) THEN ! apply exponential decay to activated CCN to restore to environmental value + IF ( lccna > 0 .and. ac_opt == 0 ) THEN ! apply exponential decay to activated CCN to restore to environmental value IF ( restoreccn ) THEN tmp = an(ix,jy,kz,li) + an(ix,jy,kz,ls) IF ( an(ix,jy,kz,lccna) > 1. .and. tmp < qxmin(li) ) an(ix,jy,kz,lccna) = an(ix,jy,kz,lccna)*Exp(-dtp/ccntimeconst) ENDIF - ELSEIF ( lccn > 1 .and. restoreccn ) THEN + ELSEIF ( lccn > 1 .and. restoreccn .and. ac_opt == 0 ) THEN ! in this case, we are treating the ccn field as ccna tmp = an(ix,jy,kz,li) + an(ix,jy,kz,ls) ! IF ( ny == 2 .and. ix == nx/2 ) THEN @@ -11599,11 +12066,11 @@ subroutine nssl_2mom_gs & ! & ln,ipc,lvol,lz,lliq, & & cdx, & & xdn0,tmp3d,tkediss & - & ,thproc,numproc,dx1,dy1 & + & ,thproc,numproc,dx1,dy1,ngs & & ,timevtcalc,axtra,io_flag & - & , has_wetscav,rainprod2d, evapprod2d & + & , has_wetscav,rainprod2d, evapprod2d, alpha2d & & ,errmsg,errflg & - & ,elec,its,ids,ide,jds,jde,ngs & + & ,elec,its,ids,ide,jds,jde & & ) @@ -11689,6 +12156,11 @@ subroutine nssl_2mom_gs & real rainprod2d(-nor+1:nx+nor,-norz+ng1:nz+norz) real evapprod2d(-nor+1:nx+nor,-norz+ng1:nz+norz) + + real :: alpha2d(-nor+1:nx+nor,-norz+ng1:nz+norz,3) + + real, parameter :: tfrdry = 243.15 + logical lrescalelow(lc:lhab) real tkediss(-nor+1:nx+nor,-norz+ng1:nz+norz) real axtra(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz,nxtra) @@ -11835,7 +12307,6 @@ subroutine nssl_2mom_gs & ! integer nxmpb,nzmpb,nxz integer jgs,mgs,ngs,numgs -! parameter (ngs=1 ) !500) integer, parameter :: ngsz = 500 integer ntt parameter (ntt=300) @@ -12215,13 +12686,12 @@ subroutine nssl_2mom_gs & real qrcnw(ngs), qwcnr(ngs) real zrcnw(ngs),zracr(ngs),zracw(ngs),zrcev(ngs) - real qracw(ngs) ! qwacr(ngs), real qiacw(ngs) !, qwaci(ngs) real qsacw(ngs) ! ,qwacs(ngs), real qhacw(ngs) ! qwach(ngs), - real :: qhlacw(ngs), qxacwtmp, qxacrtmp ! + real :: qhlacw(ngs), qxacwtmp, qxacrtmp, qxacitmp, qxacstmp ! real vhacw(ngs), vsacw(ngs), vhlacw(ngs), vhlacr(ngs) real qfcev(ngs) @@ -12287,7 +12757,8 @@ subroutine nssl_2mom_gs & real zfmlr(ngs), zfdsv(ngs), zfsbv(ngs), zhlcnf(ngs), zfshr(ngs), zfshrr(ngs) real zhmlrtmp,zhmlr0inf,zhlmlr0inf real zhmlrr(ngs),zhlmlrr(ngs),zhshrr(ngs),zhlshrr(ngs),zfmlrr(ngs) - real zsmlr(ngs), zsmlrr(ngs), zsshr(ngs), zsshrr(ngs) +! real zsmlr(ngs) + real zsmlrr(ngs), zsshr(ngs), zsshrr(ngs) real zhcns(ngs), zhcni(ngs) real zhwdn(ngs), zfwdn(ngs) ! change in Z due to density changes real zhldn(ngs) ! change in Z due to density changes @@ -12664,6 +13135,7 @@ subroutine nssl_2mom_gs & real :: term1,term2,term3,term4 real :: qaacw ! combined qsacw-qhacw for WSM6 variation + real :: cwchtmp real, parameter :: c1r=19.0, c2r=0.6, c3r=1.8, c4r=17.0 ! rain real, parameter :: c1h=5.5, c2h=0.7, c3h=4.5, c4h=8.5 ! Graupel @@ -12993,7 +13465,6 @@ subroutine nssl_2mom_gs & do ix = nxmpb,itile pqs(1) = t00(ix,jy,kz) -! pqs(kz) = t00(ix,jy,kz) theta(1) = an(ix,jy,kz,lt) temg(1) = t0(ix,jy,kz) @@ -13011,22 +13482,8 @@ subroutine nssl_2mom_gs & qss(1) = qvs(1) -! IF ( jy .eq. 1 .and. ix .eq. 24 ) THEN -! write(91,*) 'kz,qv,th: ',kz,an(ix,jy,kz,lv),an(ix,jy,kz,lt),pqs(kz),tabqvs(ltemq),qvs(kz) -! ENDIF - if ( temg(1) .lt. tfr ) then -! if( qcw(kz) .le. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) -! > qss(kz) = qis(kz) -! if( qcw(kz) .gt. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) -! > qss(kz) = (qcw(kz)*qvs(kz) + qci(kz)*qis(kz)) / -! > (qcw(kz) + qci(kz)) - qss(1) = qis(1) - else -! IF ( an(ix,jy,kz,lv) .gt. qss(kz) ) THEN -! write(iunit,*) 'qss exceeded at ',ix,jy,kz,qss(kz),an(ix,jy,kz,lv),temg(kz) -! write(iunit,*) 'other temg = ',theta(kz)*(pinit(kz)+p2(ix,jy,kz)) -! ENDIF + qss(1) = qis(1) end if ! ishail = .false. @@ -13316,7 +13773,6 @@ subroutine nssl_2mom_gs & - ! ! 6th moments ! @@ -13622,20 +14078,54 @@ subroutine nssl_2mom_gs & end do - IF ( ipconc == 5 .and. imydiagalpha > 1 ) THEN + IF ( ipconc == 5 .and. imydiagalpha == 2 ) THEN + cwchtmp = ((3. + dnu(lh))*(2. + dnu(lh))*(1.0 + dnu(lh)))**(-1./3.) + DO mgs = 1,ngscnt !IF ( igs(mgs) == 19 ) write(0,*) 'k,qr,qh,cr,ch = ',kgs(mgs),qx(mgs,lr),cx(mgs,lr),qx(mgs,lh),cx(mgs,lh) IF ( qx(mgs,lr) .gt. qxmin(lr) .and. cx(mgs,lr) > cxmin ) THEN xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) ! xdia(mgs,lr,3) = (xv(mgs,lr)*6.0*cwc1)**(1./3.) - alpha(mgs,lr) = Min(alphamax, c1r*tanh(c2r*(xdia(mgs,lr,3)*1000. - c3r)) + c4r) + ! alpha(mgs,lr) = Min(alphamax, c1r*tanh(c2r*(xdia(mgs,lr,3)*1000. - c3r)) + c4r) ! IF ( igs(mgs) == 19 ) write(0,*) 'imy: i,k,alpr,xdia = ',igs(mgs),kgs(mgs),alpha(mgs,lr),xdia(mgs,lr,3)*1000. + + ! M&M-C 2010: + tmp = 4. + alphar + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 1. + alphar + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = (x/y)**(1./3.)*xdia(mgs,lr,3)*cwchtmp + + alpha(mgs,lr) = Min(15., 11.8*(1000.*tmp - 0.7)**2 + 2.) ENDIF IF ( qx(mgs,lh) .gt. qxmin(lh) .and. cx(mgs,lh) > cxmin ) THEN +! MY 2005: xv(mgs,lh) = rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) ! xdia(mgs,lh,3) = (xv(mgs,lh)*6.*piinv)**(1./3.) ! mwfac*xdia(mgs,lh,1) ! (xv(mgs,lh)*cwc0*6.0)**(1./3.) - alpha(mgs,lh) = Min(alphamax, c1h*tanh(c2h*(xdia(mgs,lh,3)*1000. - c3h)) + c4h) +! alpha(mgs,lh) = Min(alphamax, c1h*tanh(c2h*(xdia(mgs,lh,3)*1000. - c3h)) + c4h) + + ! M&M-C 2010: + tmp = 4. + dnu(lh) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 1. + dnu(lh) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = (x/y)**(1./3.)*xdia(mgs,lh,3)*cwchtmp + + alpha(mgs,lh) = Min(15., 11.8*(1000.*tmp - 0.7)**2 + 2.) + ! alphan(mgs,lh) = alpha(mgs,lh) ! IF ( igs(mgs) == 19 ) write(0,*) 'imy: i,k,alph,xdia = ',igs(mgs),kgs(mgs),alpha(mgs,lh),xdia(mgs,lh,3)*1000. il = lh @@ -13731,6 +14221,8 @@ subroutine nssl_2mom_gs & ! CALL cld_cpu('Z-MOMENT-1') + IF ( ipconc >= 6 ) THEN + ! set base g1x in case rain is not 3-moment IF ( ipconc >= 6 .and. imurain == 3 ) THEN il = lr @@ -13825,7 +14317,7 @@ subroutine nssl_2mom_gs & qr = qx(mgs,il) cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*xdn(mgs,lr)**2) ! an(igs(mgs),jgs,kgs(mgs),ln(il)) = zx(mgs,il) - ELSEIF ( zx(mgs,il) <= 0.0 .and. cx(mgs,il) > 0.0 ) THEN + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > 0.0 ) THEN ! have mass and concentration but no reflectivity, so set reflectivity, using default alpha g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) chw = cx(mgs,il) @@ -13833,7 +14325,7 @@ subroutine nssl_2mom_gs & zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(xdn(mgs,lr)**2*chw) an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr) - ELSEIF ( zx(mgs,il) <= 0.0 .and. cx(mgs,il) <= 0.0 ) THEN + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN ! How did this happen? ! set values according to dBZ of -10, or Z = 0.1 ! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 @@ -13850,7 +14342,6 @@ subroutine nssl_2mom_gs & IF ( zx(mgs,lr) > 0.0 ) THEN xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(1000.*cx(mgs,lr)) vr = xv(mgs,lr) -! z = 36.*(alpha(kz)+2.0)*a(ix,jy,kz,lnr)*vr**2/((alpha(kz)+1.0)*pi**2) qr = qx(mgs,lr) nrx = cx(mgs,lr) z = zx(mgs,lr) @@ -13862,7 +14353,6 @@ subroutine nssl_2mom_gs & IF ( z .gt. 0.0 ) THEN ! alpha(mgs,lr) = 3. alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. -! print*,'kz, alp, alpha(kz) = ',kz,alp,alpha(kz),rd,z,xv DO i = 1,20 IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) ) @@ -13991,6 +14481,7 @@ subroutine nssl_2mom_gs & ! CALL cld_cpu('Z-MOMENT-1r') ENDIF ! } + ENDIF ! ipconc >= 6 ! Find shape parameters for graupel and hail IF ( ipconc .ge. 6 ) THEN @@ -14073,7 +14564,7 @@ subroutine nssl_2mom_gs & ! cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(z*(pi*xdn(mgs,il))**2) - ELSEIF ( zx(mgs,il) <= 0.0 .and. cx(mgs,il) > cxmin ) THEN + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > cxmin ) THEN ! have mass and concentration but no reflectivity, so set reflectivity, using default alpha ! g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & ! & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) @@ -14086,7 +14577,7 @@ subroutine nssl_2mom_gs & zx(mgs,il) = Max(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(chw*(pi*xdn(mgs,il))**2) ) an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) - ELSEIF ( zx(mgs,il) <= 0.0 .and. cx(mgs,il) <= 0.0 ) THEN + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN ! How did this happen? ! set values according to dBZ of -10, or Z = 0.1 ! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 @@ -14740,7 +15231,6 @@ subroutine nssl_2mom_gs & ! eiw(mgs) = 0.0 eii(mgs) = 0.0 - ehsclsn(mgs) = 0.0 ehiclsn(mgs) = 0.0 ehlsclsn(mgs) = 0.0 @@ -14975,7 +15465,7 @@ subroutine nssl_2mom_gs & fac = fac*(ssi(mgs) - 1.0)/0.02 ehsfac(mgs) = (ssi(mgs) - 1.0)/0.02 ENDIF - ELSEIF ( iessopt == 4 ) THEN ! factor based on ice supersat + ELSEIF ( iessopt == 4 ) THEN ! factor based on ice supersat; very roughly based on Hosler et al. 1957 (J. Met.) IF ( ssi(mgs) <= 1.0 ) THEN fac = 0.1 ehsfac(mgs) = 0.1 @@ -15339,6 +15829,7 @@ subroutine nssl_2mom_gs & do mgs = 1,ngscnt qraci(mgs) = 0.0 craci(mgs) = 0.0 + qracs(mgs) = 0.0 IF ( eri(mgs) .gt. 0.0 .and. iacr .ge. 1 .and. xdia(mgs,lr,3) .gt. 2.*rwradmn ) THEN IF ( ipconc .ge. 3 ) THEN @@ -15386,7 +15877,7 @@ subroutine nssl_2mom_gs & ! IF ( ipconc < 3 ) THEN do mgs = 1,ngscnt - qracs(mgs) = 0.0 + qracs(mgs) = 0.0 IF ( ers(mgs) .gt. 0.0 .and. ipconc < 3 ) THEN IF ( lwsm6 .and. ipconc == 0 ) THEN vt = vt2ave(mgs) @@ -16666,7 +17157,7 @@ subroutine nssl_2mom_gs & ! Ziegler (1985) autoconversion ! ! - IF ( ipconc .ge. 2 .and. ircnw /= -1) THEN ! DTD: added flag for autoconversion. If -1, turns off autoconversion + IF ( ipconc .ge. 2 ) THEN if (ndebug .gt. 0 ) write(0,*) 'conc 26a' DO mgs = 1,ngscnt @@ -16749,6 +17240,7 @@ subroutine nssl_2mom_gs & IF ( crcnw(mgs) < 1.e-30 ) qrcnw(mgs) = 0.0 + IF ( ipconc >= 6 ) THEN IF ( lzr > 1 .and. qrcnw(mgs) > 0.0 ) THEN ! vr = rho0(mgs)*qrcnw(mgs)/(1000.*crcnw(mgs)) ! zrcnw(mgs) = 36.*(xnu(lr)+2.0)*crcnw(mgs)*vr**2/((xnu(lr)+1.0)*pi**2) @@ -16788,6 +17280,7 @@ subroutine nssl_2mom_gs & endif ! z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2) ENDIF + ENDIF ! ipconc >= 6 ! IF ( crcnw(mgs) .gt. cautn(mgs) .and. crcnw(mgs) .gt. 1.0 ) ! : THEN ! write(0,*) 'crcnw,cautn ',crcnw(mgs)/cautn(mgs), @@ -16998,7 +17491,7 @@ subroutine nssl_2mom_gs & ELSE !{ - IF ( lzr > 1 ) THEN + IF ( ipconc >= 6 .and. lzr > 1 ) THEN ! interpolate along x, i.e., ratio; tmp1 = ziacrratio(i,j) + delx*dqiacrratioinv*(ziacrratio(ip1,j) - ziacrratio(i,j)) tmp2 = ziacrratio(i,jp1) + delx*dqiacrratioinv*(ziacrratio(ip1,jp1) - ziacrratio(i,jp1)) @@ -17016,7 +17509,7 @@ subroutine nssl_2mom_gs & crfrzs(mgs) = crfrz(mgs) qrfrzs(mgs) = qrfrz(mgs) - IF ( lzr > 1 ) THEN + IF ( ipconc >= 6 .and. lzr > 1 ) THEN zrfrzs(mgs) = zrfrz(mgs) zrfrzf(mgs) = 0. ENDIF @@ -17031,7 +17524,7 @@ subroutine nssl_2mom_gs & crfrzf(mgs) = 0.0 qrfrzf(mgs) = 0.0 - IF ( lzr > 1 ) THEN + IF (ipconc >= 6 .and. lzr > 1 ) THEN zrfrzs(mgs) = zrfrz(mgs) zrfrzf(mgs) = 0. ENDIF @@ -17074,7 +17567,7 @@ subroutine nssl_2mom_gs & crfrzs(mgs) = crfrzs(mgs) - crfrzf(mgs) qrfrzs(mgs) = qrfrzs(mgs) - qrfrzf(mgs) - IF ( lzr > 1 ) THEN + IF ( ipconc >= 6 .and. lzr > 1 ) THEN zrfrzs(mgs) = zrfrz(mgs) ! interpolate along x, i.e., ratio; tmp1 = ziacrratio(i,j) + delx*dqiacrratioinv*(ziacrratio(ip1,j) - ziacrratio(i,j)) @@ -17103,7 +17596,7 @@ subroutine nssl_2mom_gs & crfrz(mgs) = fac*crfrz(mgs) crfrzs(mgs) = fac*crfrzs(mgs) crfrzf(mgs) = fac*crfrzf(mgs) - IF ( lzr > 1 ) THEN + IF ( ipconc >= 6 .and. lzr > 1 ) THEN zrfrz(mgs) = fac*zrfrz(mgs) zrfrzf(mgs) = fac*zrfrzf(mgs) ENDIF @@ -17651,7 +18144,7 @@ subroutine nssl_2mom_gs & x = 1. + alpha(mgs,lr) - IF ( lzr > 1 ) THEN ! 3 moment + IF ( ipconc >= 6 .and. lzr > 1 ) THEN ! 3 moment tmp = 1. + alpr ! alpha(mgs,lr) i = Int(dgami*(tmp)) del = tmp - dgam*i @@ -17676,6 +18169,7 @@ subroutine nssl_2mom_gs & & 0.308*fvent(mgs)*y* & & Sqrt(ax(lr)*rhovt(mgs))*(vent1/vent2) + rwventz(mgs) = 0.0 ! rwventz(mgs) = & ! & 0.78*x + & @@ -17694,6 +18188,7 @@ subroutine nssl_2mom_gs & & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) + IF ( ipconc >= 7 ) THEN alpr = Min(alpharmax,alpha(mgs,lr) ) tmp = alpr + 5.5 + br/2. @@ -17708,7 +18203,7 @@ subroutine nssl_2mom_gs & & 0.308*fvent(mgs)* & & Sqrt(ax(lr)*rhovt(mgs))*(y/gf1palp(mgs))*(xdia(mgs,lr,1)**((1.0+br)/2.0)) - + ENDIF ENDIF ! iferwisventr @@ -17752,6 +18247,9 @@ subroutine nssl_2mom_gs & hwventa = (0.78)*gmoi(igmhwa) hwventb = (0.308)*gmoi(igmhwb) ! hwventc = (4.0*gr/(3.0*cdx(lh)))**(0.25) + hwvent(:) = 0.0 + hwventy(:) = 0.0 + do mgs = 1,ngscnt IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN hwventc = (4.0*gr/(3.0*cdxgs(mgs,lh)))**(0.25) @@ -17909,7 +18407,7 @@ subroutine nssl_2mom_gs & vffzf(:) = 0.0 vhlfzhl(:) = 0.0 qsfzs(:) = 0.0 - zsmlr(:) = 0.0 +! zsmlr(:) = 0.0 zhmlr(:) = 0.0 zhmlrr(:) = 0.0 zsmlrr(:) = 0.0 @@ -18110,20 +18608,8 @@ subroutine nssl_2mom_gs & ! ENDIF - - IF ( lzr .gt. 1 .and. qx(mgs,ls) > qxmin(ls) ) THEN - tmp = qx(mgs,ls)/cx(mgs,ls) -! alp = Max( -0.8, alpha(mgs,lh) ) - alp = xnu(ls) - g1 = 36.*(alp+2.0)/((alp+1.0)*pi**2) - - zsmlr(mgs) = g1*(rho0(mgs)/(xdn(mgs,ls)))**2*( tmp * qsmlr(mgs) ) -! zhmlr(mgs) = (xdn0(lr)/(xdn(mgs,lh)))**2*( zx(mgs,lh) * qhmlr(mgs) ) - - ENDIF - IF ( chmlr(mgs) < 0.0 .and. (ibinhmlr < 1 .or. lzh < 1) ) THEN ! { already done if ibinhmlr > 0 - IF ( lzr .gt. 1 .and. lzh < 1 .and. qx(mgs,lh) > qxmin(lh) ) THEN ! Only compute if rain is 3-moment but graupel is not, otherwise is computed later + IF ( ipconc >= 6 .and. lzr .gt. 1 .and. lzh < 1 .and. qx(mgs,lh) > qxmin(lh) ) THEN ! Only compute if rain is 3-moment but graupel is not, otherwise is computed later tmp = qx(mgs,lh)/cx(mgs,lh) alp = alpha(mgs,lh) g1 = g1x(mgs,lh) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) @@ -18236,7 +18722,7 @@ subroutine nssl_2mom_gs & ENDIF !} - IF ( lzhl .gt. 1 .and. ibinhlmlr <= 0 ) THEN + IF ( ipconc >= 8 .and. lzhl .gt. 1 .and. ibinhlmlr <= 0 ) THEN IF ( cx(mgs,lhl) > 0.0 ) THEN tmp = qx(mgs,lhl)/cx(mgs,lhl) @@ -18575,6 +19061,9 @@ subroutine nssl_2mom_gs & qsdpv(mgs) = 0.0 ENDIF + qhsbv(mgs) = 0.0 + qhdpv(mgs) = 0.0 + IF ( qx(mgs,lh) > qxmin(lh) ) THEN IF ( temg(mgs) < tfr .or. .not. qhmlr(mgs) < 0.0 ) THEN ! no liquid from melting, so evaporation is greater. Thus can calculate sublimation rate qhsbv(mgs) = max( min(qhdsv(mgs), 0.0), -qhmxd(mgs) ) @@ -18587,12 +19076,14 @@ subroutine nssl_2mom_gs & ! & evapfac*min( & ! & fmlt1e(mgs)*cx(mgs,lh)*hwvent(mgs)*xdia(mgs,lh,1), 0.0 ) - qhcev(mgs) = evapfac* & - & 2.0*pi*(qx(mgs,lv)-qss0(mgs))*cx(mgs,lh)*xdia(mgs,lh,1)*hwvent(mgs)/(qss0(mgs)*(fav(mgs)+fbv(mgs))) + qhcev(mgs) = evapfac*2.0*pi*(qx(mgs,lv)-qss0(mgs))* & + & cx(mgs,lh)*xdia(mgs,lh,1)*hwvent(mgs)/(qss0(mgs)*(fav(mgs)+fbv(mgs))) - qhcev(mgs) = max(qhcev(mgs), -qhmxd(mgs)) + qhcev(mgs) = max(qhcev(mgs), -qhmxd(mgs)) + IF ( temg(mgs) > tfr ) qhcev(mgs) = Min(0.0, qhcev(mgs) ) ENDIF + ENDIF qhlsbv(mgs) = 0.0 @@ -18605,10 +19096,11 @@ subroutine nssl_2mom_gs & ENDIF IF ( qhlmlr(mgs) < 0.0 .and. .not. mixedphase ) THEN ! Liquid is forming, so find the evaporation that was subtracted from melting (if it is not condensing) - qhlcev(mgs) = evapfac* & - & 2.0*pi*(qx(mgs,lv)-qss0(mgs))*cx(mgs,lhl)*xdia(mgs,lhl,1)*hlvent(mgs)/(qss0(mgs)*(fav(mgs)+fbv(mgs))) + qhlcev(mgs) = evapfac*2.0*pi*(qx(mgs,lv)-qss0(mgs))* & + & cx(mgs,lhl)*xdia(mgs,lhl,1)*hlvent(mgs)/(qss0(mgs)*(fav(mgs)+fbv(mgs))) qhlcev(mgs) = max(qhlcev(mgs), -qhlmxd(mgs)) + IF ( temg(mgs) > tfr ) qhlcev(mgs) = Min(0.0, qhlcev(mgs) ) ENDIF ENDIF @@ -18777,7 +19269,7 @@ subroutine nssl_2mom_gs & ! do mgs = 1,ngscnt - IF ( temg(mgs) < tfr ) THEN + IF ( tfrdry < temg(mgs) .and. temg(mgs) < tfr ) THEN ! ! qswet(mgs) = ! > ( xdia(mgs,ls,1)*swvent(mgs)*cx(mgs,ls)*fwet1(mgs) @@ -18815,7 +19307,6 @@ subroutine nssl_2mom_gs & qhwet(mgs) = qhdry(mgs) qhlwet(mgs) = qhldry(mgs) - ENDIF ! ! qhlwet(mgs) = qhldry(mgs) @@ -19222,14 +19713,22 @@ subroutine nssl_2mom_gs & ELSE IF (((qhacw(mgs) + qhacr(mgs))*dtp > qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin .and. temg(mgs) .le. tfr-2.0 & .and. temg(mgs) .gt. dwtempmin ) .or. ( wetgrowth(mgs) .and. qx(mgs,lh) > hlcnhqmin ) ) THEN - dw = 0.01*( Exp( -temcg(mgs)/( 1.1e4 * rho0(mgs)*ehw(mgs)*qx(mgs,lc) - 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0 ) ) - 1.0 ) - dwr = 0.01*( Exp( -temcg(mgs)/( 1.1e4 * rho0(mgs)*(ehw(mgs)*qx(mgs,lc)+ehr(mgs)*qx(mgs,lr)) - & - 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0 ) ) - 1.0 ) +! dw = 0.01*( Exp( -temcg(mgs)/( 1.1e4 * rho0(mgs)*ehw(mgs)*qx(mgs,lc) - 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0 ) ) - 1.0 ) +! dwr = 0.01*( Exp( -temcg(mgs)/( 1.1e4 * rho0(mgs)*(ehw(mgs)*qx(mgs,lc)+ehr(mgs)*qx(mgs,lr)) - & +! 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0 ) ) - 1.0 ) + x = 1.1e4 * rho0(mgs)*(ehw(mgs)*qx(mgs,lc)+ehr(mgs)*qx(mgs,lr)) - & + 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0 + IF ( x > 1.e-20 ) THEN + arg = Min(70.0, (-temcg(mgs)/x )) ! prevent overflow of the exp function in 32 bit + dwr = 0.01*(exp(arg) - 1.0) + ELSE + dwr = 1.e30 + ENDIF d = dwr - IF ( dwr < 0.2 .and. dwr > 0.0 ) THEN + IF ( dwr < 0.2 .and. dwr > 0.0 .and. rho0(mgs)*(qx(mgs,lc)+qx(mgs,lr)) > 1.e-4 ) THEN + sqrtrhovt = Sqrt( rhovt(mgs) ) fventh = sqrtrhovt*(fpndl(mgs)**(1./3.)) * (fakvisc(mgs))**(-0.5) fventm = sqrtrhovt*(fschm(mgs)**(1./3.)) * (fakvisc(mgs))**(-0.5) - sqrtrhovt = Sqrt( rhovt(mgs) ) ltemq = (tfr-163.15)/fqsat+1.5 qvs0 = pqs(mgs)*tabqvs(ltemq) denomdp = felf(mgs) + fcw(mgs)*temcg(mgs) @@ -19242,6 +19741,7 @@ subroutine nssl_2mom_gs & h4 = ehr(mgs)* qx(mgs,lr) ! iterate to find minimum diameter for wet growth. Start with value of dwr DO n = 1,10 + d = Max(d, 1.e-4) dold = d vth = axx(mgs,lh)*d**bxx(mgs,lh) x2 = fventh*sqrtrhovt*Sqrt(d*vth) @@ -19266,32 +19766,26 @@ subroutine nssl_2mom_gs & ELSE - d = 8.*ah*h1*dtpinv/ & + ! Based on Farley and Orville (1986), eq. 5-9 but neglecting the Ci*(T0-Ts) term in (8) since we want Ts=T0 + ! Simplified mass rates as dm_w/dt = pi/4*d**2*(Vh - Vc)*rhoair*qc*ehw, etc. + d = 8.*ah*h1/ & ( ( Max(0.001,vth - vtxbar(mgs,lc,1))*h3 + & Max(0.001,vth - vtxbar(mgs,lr,1))*h4) *rho0(mgs)*denomdp + & Max(0.001,vth - vtxbar(mgs,li,1))*h2) + ENDIF -! write(0,*) 'iter,d,dwr = ',n,d,dwr -! write(91,*) 'parts = ',( -ah*ftka*temcg - ah*felv*fwvdf*dn(i,j,k)*(qvamb - qvs0) ),( Max(0.001,vth - 0.01*vwmw)*ehw* qcmks*dn(i,j,k)/denominv + Max(0.001,vth - 0.01*vimw)*ehi*qimks*dn(i,j,k)*fci*temcg) -!! write(91,*) 'partsr = ',( -ah*ftka*temcg - ah*felv*fwvdf*dn(i,j,k)*(qvamb - qvs0) ),( ( Max(0.001,vth - 0.01*vwmw)*ehw* qcmks + Max(0.001,vth - 0.01*vrmw)*ehr* qrmks) *dn(i,j,k)/denominv + & -!! Max(0.001,vth - 0.01*vimw)*ehi*qimks*dn(i,j,k)*fci*temcg) -! write(91,*) 'parts2 = ',vth - IF ( Abs(dold - d)/dold < 0.05 .or. ( n > 3 .and. d > dg0thresh ) ) EXIT ENDDO ENDIF - dg0(mgs) = Max( d, dwmin ) -! IF ( .false. .and. ny == 2 .and. dwr < 0.5 .and. dwr > 0. ) THEN -! write(0,*) 'i,k,dg0 = ',igs(mgs), kgs(mgs), dg0(mgs) -! write(0,*) 'h1,h2,h3,h4 = ',h1,h2,h3,h4 -! write(0,*) 'dw,dwr = ',dw,dwr -! write(0,*) 'wetgrowth = ',wetgrowth(mgs) -! write(0,*) 'temc,Dh, Dhl = ',temcg(mgs),xdia(mgs,lh,3),xdia(mgs,lhl,3) -! ENDIF + dg0(mgs) = Min( dwmax, Max( d, dwmin ) ) ELSE - dg0(mgs) = dg0thresh + 0.0001 + IF ( qx(mgs,lh) > qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin .and. temg(mgs) .le. tfr-2.0 ) THEN + dg0(mgs) = dwmax + ELSE + dg0(mgs) = dg0thresh + 0.0001 + ENDIF ENDIF IF ( ihlcnh == 3 .and. (qhacw(mgs) + qhacr(mgs))*dtp > qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin & @@ -19301,10 +19795,6 @@ subroutine nssl_2mom_gs & ENDIF ENDIF -! write(0,*) 'notwet growth graupel,hail,Dw,Dwr = ',wetgrowth(mgs) , wetgrowthhl(mgs), dh0 ,tmp,tmp1 -! write(0,*) 'temc,Dh, Dhl = ',temcg(mgs),xdia(mgs,lh,3),xdia(mgs,lhl,3) -! write(0,*) 'qc,qi = ', qx(mgs,lc) , qx(mgs,li) - wtest = (dg0(mgs) > 0.0 .and. dg0(mgs) < dg0thresh ) @@ -19339,18 +19829,6 @@ subroutine nssl_2mom_gs & tmp = qhacw(mgs) + qhacr(mgs) + qhaci(mgs) + qhacs(mgs) ! qtmp = Min( 1.0, xdia(mgs,lh,3)/(2.0*dh0) )*(tmp) qtmp = Min( 100.0, xdia(mgs,lh,3)/(2.0*dh0) )*(tmp) -! IF ( .false. .and. qx(mgs,lhl) + qtmp*dtp .lt. 0.5e-3 ) THEN -! hdia1 = Max(dh0, xdia(mgs,lh,3) ) -! qtmp = qtmp + Min(qxmxd(mgs,lh), Max( 0.0, & -! & ((pi*xdn(mgs,lh)*cx(mgs,lh)) / (6.0*rho0(mgs)*dtp)) & -! & *exp(-hdia1/xdia(mgs,lh,1)) & -! & *( (hdia1**3) + 3.0*(hdia1**2)*xdia(mgs,lh,1) & -! & + 6.0*(hdia1)*(xdia(mgs,lh,1)**2) + 6.0*(xdia(mgs,lh,1)**3) ) ) ) - -! ENDIF - -! qhlcnh(mgs) = Min( 0.5*(qx(mgs,lh))+tmp, xdia(mgs,lh,3)/(2.0*dh0)*(tmp) ) -! qhlcnh(mgs) = Min( qxmxd(mgs,lh), xdia(mgs,lh,3)/(2.0*dh0)*(tmp) ) qhlcnh(mgs) = Min( qxmxd(mgs,lh), qtmp ) IF ( ipconc .ge. 5 ) THEN !{ @@ -19360,8 +19838,6 @@ subroutine nssl_2mom_gs & chlcnhhl(mgs) = Min( cxmxd(mgs,lh), rho0(mgs)*qhlcnh(mgs)/(pi*xdn(mgs,lh)*dh0**3/6.0) ) r = rho0(mgs)*qhlcnh(mgs)/(xdn(mgs,lh)*xv(mgs,lh)) ! number of graupel particles at mean volume diameter -! chlcnh(mgs) = Min( Max( 1./8.*r , chlcnh(mgs)), r ) -! chlcnh(mgs) = Min( chlcnh(mgs), r ) chlcnh(mgs) = Max( chlcnhhl(mgs), r ) ENDIF !} @@ -19395,11 +19871,10 @@ subroutine nssl_2mom_gs & qxd1 = qx(mgs,lh)*(tmp2) qhlcnh(mgs) = dtpinv*qxd1 flim = 1.0 -! tmp3 = Min( dtp*(qfacw(mgs) + qfacr(mgs) ), qxmxd(mgs,lf) ) tmp3 = qxmxd(mgs,lh) IF (qxd1 > tmp3 ) THEN - flim = tmp3/(qxd1) - qhlcnh(mgs) = flim*qhlcnh(mgs) +! flim = tmp3/(qxd1) +! qhlcnh(mgs) = flim*qhlcnh(mgs) ENDIF @@ -19416,10 +19891,10 @@ subroutine nssl_2mom_gs & chlcnhhl(mgs) = chlcnh(mgs) IF ( qx(mgs,lhl) > qxmin(lhl) .and. dmhlopt > 0 ) THEN - dh0 = rho0(mgs)*qhlcnh(mgs)/chlcnhhl(mgs) - IF ( dh0 < xmas(mgs,lhl) ) THEN + tmp = rho0(mgs)*qhlcnh(mgs)/chlcnhhl(mgs) + IF ( tmp < xmas(mgs,lhl) ) THEN ! dh0 = ( qxd1*dh0 + qx(mgs,lhl)*xmas(mgs,lhl))/( qxd1 + qx(mgs,lhl)) ! weighted average - dh0 = (( qxd1*dh0**(1./3.) + qx(mgs,lhl)*xmas(mgs,lhl)**(1./3.))/( qxd1 + qx(mgs,lhl)))**3 ! weighted average + dh0 = (( qxd1*tmp**(1./3.) + qx(mgs,lhl)*xmas(mgs,lhl)**(1./3.))/( qxd1 + qx(mgs,lhl)))**3 ! weighted average chlcnhhl(mgs) = Min( chlcnhhl(mgs), rho0(mgs)*qhlcnh(mgs)/dh0 ) ELSE ! dh0 = Max( dh0, xmas(mgs,lhl) ) ! when enough hail is established, do not dilute the size @@ -19428,7 +19903,7 @@ subroutine nssl_2mom_gs & ! reflectivity - IF ( lzh > 1 .and. lzhl > 1 ) THEN + IF ( ipconc >= 6 .and. lzh > 1 .and. lzhl > 1 ) THEN tmp3 = gaminterp(ratio,alpha(mgs,lh),11,1) zxd1 = flim*zx(mgs,lh)*(tmp3) zhlcnh(mgs) = dtpinv*zxd1 @@ -19440,17 +19915,6 @@ subroutine nssl_2mom_gs & qhlcnh(mgs) = 0.0 ENDIF -! IF ( cxd1 < 0.0 .or. qxd1 < 0.0 ) THEN -! write(0,*) 'cxd1,qxd1 = ',cxd1,qxd1 -! write(0,*) 'dw,temcg = ',dw,temcg(mgs),ratio -! ENDIF - -! write(0,*) 'dw,temcg = ',dw,temcg(mgs),ratio -! write(0,*) 'qhlcnh,qh = ',qhlcnh(mgs),qx(mgs,lh),qxd1 -! write(0,*) 'chlcnh,ch = ',chlcnh(mgs),cx(mgs,lh),cxd1 -! write(0,*) 'zhlcnh,zh = ',zhlcnh(mgs),zx(mgs,lh),zxd1 -! write(0,*) 'tmp1,2,3 = ',tmp,tmp2,tmp3 - vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh) vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh)) @@ -19494,17 +19958,6 @@ subroutine nssl_2mom_gs & ELSE zxd1 = 0 ENDIF -! IF ( cxd1 < 0.0 .or. qxd1 < 0.0 ) THEN -! write(0,*) 'cxd1,qxd1 = ',cxd1,qxd1 -! write(0,*) 'dw,temcg = ',dw,temcg(mgs),ratio -! ENDIF - -! write(0,*) 'dw,temcg = ',dw,temcg(mgs),ratio -! write(0,*) 'qhlcnh,qh = ',qhlcnh(mgs),qx(mgs,lh),qxd1 -! write(0,*) 'chlcnh,ch = ',chlcnh(mgs),cx(mgs,lh),cxd1 -! write(0,*) 'zhlcnh,zh = ',zhlcnh(mgs),zx(mgs,lh),zxd1 -! write(0,*) 'tmp1,2,3 = ',tmp,tmp2,tmp3 - vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh) vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh)) @@ -20765,6 +21218,14 @@ subroutine nssl_2mom_gs & pqlwlghld(:) = 0.0 pqlwhli(:) = 0.0 pqlwhld(:) = 0.0 + IF ( ipconc > 5 ) THEN + pzhwi(:) = 0.0 + pzhwd(:) = 0.0 + pzrwi(:) = 0.0 + pzrwd(:) = 0.0 + pzhli(:) = 0.0 + pzhld(:) = 0.0 + ENDIF ! @@ -21337,8 +21798,8 @@ subroutine nssl_2mom_gs & ! zhshr(mgs) = (xdn0(lr)/(xdn(mgs,lh)))**2*( zx(mgs,lh) * qhshr(mgs) ) - qtmp = qhdpv(mgs) + qhcev(mgs) - ctmp = chdpv(mgs) + chcev(mgs) + qtmp = qhdpv(mgs) + qhcev(mgs) + qhsbv(mgs) + ctmp = chdpv(mgs) + chcev(mgs) + chsbv(mgs) zhdsv(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qtmp - tmp**2 * ctmp ) @@ -21484,7 +21945,6 @@ subroutine nssl_2mom_gs & pzhwd(mgs) = 0.0 & & + (1-il5(mgs))*zhmlr(mgs) & & + zhshr(mgs) & -! > + il5(mgs)*chsbv(mgs) & & + Min( 0.0, zhdsv(mgs) ) & & - il5(mgs)*zhlcnh(mgs) @@ -21674,7 +22134,7 @@ subroutine nssl_2mom_gs & zrachl(mgs) = 0.0 zsshr(mgs) = 0.0 zsshrr(mgs) = 0.0 - zsmlr(mgs) = 0.0 +! zsmlr(mgs) = 0.0 zsmlrr(mgs) = 0.0 IF ( qx(mgs,ls) .gt. qxmin(ls) .and. ( csmlr(mgs) /= 0.0 .or. csshr(mgs) /= 0.0 .or. & @@ -21682,8 +22142,8 @@ subroutine nssl_2mom_gs & tmp = qx(mgs,ls)/cx(mgs,ls) g1 = 36.*(xnu(ls)+2.0)/((xnu(ls)+1.0)*pi**2) IF ( .not. mixedphase ) THEN - zsmlr(mgs) = (xdn(mgs,ls)/xdn(mgs,lr))**2*g1*(rho0(mgs)/(xdn(mgs,ls)))**2* & - & ( 2.*tmp * qsmlr(mgs) - tmp**2 * csmlr(mgs) ) +! zsmlr(mgs) = (xdn(mgs,ls)/xdn(mgs,lr))**2*g1*(rho0(mgs)/(xdn(mgs,ls)))**2* & +! & ( 2.*tmp * qsmlr(mgs) - tmp**2 * csmlr(mgs) ) IF ( csmlrr(mgs) /= 0.0 ) THEN z1 = g1smlr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qsmlr(mgs)**2/ csmlrr(mgs) ) @@ -22534,7 +22994,6 @@ subroutine nssl_2mom_gs & end do end if - IF ( has_wetscav ) THEN DO mgs = 1,ngscnt evapprod2d(igs(mgs),kgs(mgs)) = -(qrcev(mgs) + qssbv(mgs) + qhsbv(mgs) + qhlsbv(mgs)) @@ -22776,41 +23235,9 @@ subroutine nssl_2mom_gs & tqvcon = temg(mgs)-cbw ltemq = (temg(mgs)-163.15)/fqsat+1.5 ltemq = Min( nqsat, Max(1,ltemq) ) -! IF ( ltemq .lt. 1 .or. ltemq .gt. nqsat ) THEN -! C$PAR CRITICAL SECTION -! write(iunit,*) 'out of range ltemq!',temgtmp,temg(mgs), -! : thetap(mgs),theta0(mgs),pres(mgs),theta(mgs), -! : ltemq,igs(mgs),jy,kgs(mgs) -! write(iunit,*) an(igs(mgs),jy,kgs(mgs),lt), -! : ab(igs(mgs),jy,kgs(mgs),lt), -! : t0(igs(mgs),jy,kgs(mgs)) -! write(iunit,*) fcc3(mgs),qx(mgs,lc),qitmp(mgs),dtp,ptem(mgs) -! STOP -! C$PAR END CRITICAL SECTION -! END IF + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) qis(mgs) = pqs(mgs)*tabqis(ltemq) -! qss(kz) = qvs(kz) -! if ( temg(kz) .lt. tfr ) then -! if( qcw(kz) .le. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) -! > qss(kz) = qis(kz) -! if( qcw(kz) .gt. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) -! > qss(kz) = (qcw(kz)*qvs(kz) + qci(kz)*qis(kz)) / -! > (qcw(kz) + qci(kz)) -! qss(kz) = qis(kz) -! end if -! dont get enough condensation with qcw .le./.gt. qxmin(lc) -! if ( temg(mgs) .lt. tfr ) then -! if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) -! > qss(mgs) = qvs(mgs) -! if( qx(mgs,lc) .eq. 0.0 .and. qitmp(mgs) .gt. qxmin(li)) -! > qss(mgs) = qis(mgs) -! if( qx(mgs,lc) .gt. 0.0 .and. qitmp(mgs) .gt. qxmin(li)) -! > qss(mgs) = (qx(mgs,lc)*qvs(mgs) + qitmp(mgs)*qis(mgs)) / -! > (qx(mgs,lc) + qitmp(mgs)) -! else -! qss(mgs) = qvs(mgs) -! end if qss(mgs) = qvs(mgs) if ( temg(mgs) .lt. tfr ) then if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) & @@ -23049,7 +23476,6 @@ subroutine nssl_2mom_gs & - if (ndebug .gt. 0 ) write(0,*) 'gs 11' do mgs = 1,ngscnt @@ -23212,7 +23638,7 @@ subroutine nssl_2mom_gs & qr = qx(mgs,il) cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*xdn(mgs,lr)**2) ! an(igs(mgs),jgs,kgs(mgs),ln(il)) = zx(mgs,il) - ELSEIF ( zx(mgs,il) <= 0.0 .and. cx(mgs,il) > 0.0 ) THEN + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > 0.0 ) THEN ! have mass and concentration but no reflectivity, so set reflectivity, using default alpha g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) chw = cx(mgs,il) @@ -23220,7 +23646,7 @@ subroutine nssl_2mom_gs & zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(xdn(mgs,lr)**2*chw) an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr) - ELSEIF ( zx(mgs,il) <= 0.0 .and. cx(mgs,il) <= 0.0 ) THEN + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN ! How did this happen? ! set values according to dBZ of -10, or Z = 0.1 ! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 @@ -23237,7 +23663,6 @@ subroutine nssl_2mom_gs & IF ( zx(mgs,lr) > 0.0 ) THEN xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(1000.*cx(mgs,lr)) vr = xv(mgs,lr) -! z = 36.*(alpha(kz)+2.0)*a(ix,jy,kz,lnr)*vr**2/((alpha(kz)+1.0)*pi**2) qr = qx(mgs,lr) nrx = cx(mgs,lr) z = zx(mgs,lr) @@ -23247,9 +23672,7 @@ subroutine nssl_2mom_gs & ! determine shape parameter alpha by iteration IF ( z .gt. 0.0 ) THEN -! alpha(mgs,lr) = 3. alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1. -! write(0,*) 'kz, alp, alpha(kz) = ',kz,alp,alpha(kz),rd,z,xv DO i = 1,20 IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) ) @@ -23425,7 +23848,7 @@ subroutine nssl_2mom_gs & cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(z*(pi*xdn(mgs,il))**2) - ELSEIF ( zx(mgs,il) <= 0.0 .and. cx(mgs,il) > 0.0 ) THEN + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > 0.0 ) THEN ! have mass and concentration but no reflectivity, so set reflectivity, using default alpha ! g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & ! & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) @@ -23438,7 +23861,7 @@ subroutine nssl_2mom_gs & zx(mgs,il) = Max(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(chw*(pi*xdn(mgs,il))**2) ) an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) - ELSEIF ( zx(mgs,il) <= 0.0 .and. cx(mgs,il) <= 0.0 ) THEN + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN ! How did this happen? ! set values according to dBZ of -10, or Z = 0.1 ! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 @@ -23580,6 +24003,16 @@ subroutine nssl_2mom_gs & ENDIF !} + IF ( lzr > 1 ) THEN + alpha2d(igs(mgs),kgs(mgs),1) = Max(alphamin, Min(alphamax, alpha(mgs,lr) )) + ENDIF + IF ( lzh > 1 ) THEN + alpha2d(igs(mgs),kgs(mgs),2) = Max(alphamin, Min(alphamax, alpha(mgs,lh) )) + ENDIF + IF ( lzhl > 1 ) THEN + alpha2d(igs(mgs),kgs(mgs),3) = Max(alphamin, Min(alphamax, alpha(mgs,lhl) )) + ENDIF + IF ( il == lhl .and. lnhlf > 1 ) THEN ! update chxf in case cx has changed chxf(mgs,lhl) = frac*cx(mgs,lhl) @@ -23608,7 +24041,7 @@ subroutine nssl_2mom_gs & ENDIF ! } } - + ENDIF ! }} ENDIF ! } From 0cb137e1822f076e98a468edc8a386fc280c225a Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Sun, 24 Sep 2023 15:49:28 -0500 Subject: [PATCH 339/380] Update NSSL documentation and references for 3-moment option --- physics/docs/library.bib | 17 +++++++++++------ physics/docs/pdftxt/NSSLMICRO.txt | 4 ++-- physics/docs/pdftxt/suite_input.nml.txt | 3 ++- 3 files changed, 15 insertions(+), 9 deletions(-) diff --git a/physics/docs/library.bib b/physics/docs/library.bib index 34bb54e8f..4260fc3c2 100644 --- a/physics/docs/library.bib +++ b/physics/docs/library.bib @@ -3760,8 +3760,6 @@ @inproceedings{yudin_et_al_2019 @article{mansell_2013, author = {Edward R. Mansell and Conrad L. Ziegler}, - date-added = {2015-02-26 22:32:59 +0000}, - date-modified = {2020-02-10 23:06:41 +0000}, doi = {10.1175/JAS-D-12-0264.1}, journal = {Journal of the Atmospheric Sciences}, keywords = {storm electrification, microphysics 2-moment}, @@ -3774,8 +3772,6 @@ @article{mansell_2013 @article{mansell_2010, author = {Edward R. Mansell}, - date-added = {2011-02-22 10:34:11 -0600}, - date-modified = {2011-02-22 10:35:34 -0600}, doi = {10.1175/2010JAS3341.1}, journal = {Journal of the Atmospheric Sciences}, keywords = {advection, microphysics 2-moment}, @@ -3787,8 +3783,6 @@ @article{mansell_2010 @article{mansell_etal_2010, author = {E. R. Mansell and C. L. Ziegler and E. C. Bruning}, - date-added = {2007-08-20 15:44:13 -0500}, - date-modified = {2010-04-13 16:55:16 -0500}, doi = {10.1175/2009JAS2965.1}, journal = {Journal of the Atmospheric Sciences}, keywords = {storm electrification, microphysics 2-moment}, @@ -3798,6 +3792,17 @@ @article{mansell_etal_2010 year = {2010}, bdsk-url-1 = {https://doi.org/10.1175/2009JAS2965.1}} +@article{mansell:2020, + Author = {Edward R. Mansell and Dawson, II, Daniel T. and Jerry M. Straka}, + Doi = {10.1175/JAS-D-19-0268.1}, + Journal = jas, + Keywords = {microphysics 3-moment}, + Pages = {3361-3385}, + Title = {Bin-emulating Hail Melting in 3-moment bulk microphysics}, + Volume = {77}, + Year = {2020}, + Bdsk-Url-1 = {https://dx.doi.org/10.1175/JAS-D-12-0264.1}, + @inproceedings{yudin_et_al_2020, author = {Yudin, V. A. and Yang, F. and Karol, S. I. and Fuller-Rowell T. J. and Kubaryk, A. and Juang, H. and Kar, S. and Alpert, J. C. and Li, Z.}, booktitle = {1st UFS Users' Workshop}, diff --git a/physics/docs/pdftxt/NSSLMICRO.txt b/physics/docs/pdftxt/NSSLMICRO.txt index 3d35c9fd2..44d1f069b 100644 --- a/physics/docs/pdftxt/NSSLMICRO.txt +++ b/physics/docs/pdftxt/NSSLMICRO.txt @@ -2,7 +2,7 @@ \page NSSLMICRO_page NSSL 2-moment Cloud Microphysics Scheme \section nssl2m_descrp Description -The NSSL two-moment bulk microphysical parameterization scheme that describes form and phase changes among a range of liquid and ice hydrometeors, as described in Mansell et al. (2010) \cite Mansell_etal_2010 and Mansell and Ziegler (2013) \cite Mansell_2013. The microphysical parameterization predicts the mass mixing ratio and number concentration of cloud droplets, raindrops, cloud ice crystals (columns), snow particles (including large crystals and aggregates), graupel, and (optionally) hail. +The NSSL 2/3-moment bulk microphysical parameterization scheme that describes form and phase changes among a range of liquid and ice hydrometeors, as described in Mansell et al. (2010) \cite Mansell_etal_2010, Mansell and Ziegler (2013) \cite Mansell_2013, and Mansell et al. (2020) \cite Mansell_etal_2020. The microphysical parameterization predicts the mass mixing ratio and number concentration of cloud droplets, raindrops, cloud ice crystals (columns), snow particles (including large crystals and aggregates), graupel, and (optionally) hail. Optionally, a third moment (reflectivity or 6th moment) of rain, graupel, and hail can be activated. The graupel and hail particle densities are also calculated by predicting the total particle volume. The graupel category therefore emulates a range of characteristics from high-density frozen drops (includes small hail) to low-density graupel (from rimed ice crystals/snow) in its size and density spectrum. The hail category is designed to simulate larger hail sizes. Hail is only produced from higher-density large graupel. @@ -10,7 +10,7 @@ Hydrometeor size distributions are assumed to follow a gamma functional form. Mi Cloud concentration nuclei (CCN) concentration is predicted as in Mansell et al. (2010) \cite Mansell_etal_2010 with a bulk activation spectrum approximating small aerosols. The model tracks the number of unactivated CCN, and the local CCN concentration is depleted as droplets are activated, either at cloud base or in cloud. The CCN are subjected to advection and subgrid turbulent mixing but have no other interactions with hydrometeors; for example, scavenging by raindrops is omitted. CCN are restored by droplet evaporation and by a gradual regeneration when no hydrometeors are present. Aerosol sensitivity is enhanced by explicitly treating droplet condensation instead of using a saturation adjustment. Supersaturation (within reason) is allowed to persist in updraft with low droplet concentration. -Excessive size sorting (common in 2-moment schemes) is effectively controlled by an adaptive breakup method that prevents reflectivity growth by sedimentation (Mansell 2010 \cite Mansell_2010). +Excessive size sorting (common in 2-moment schemes) is effectively controlled by an adaptive breakup method that prevents reflectivity growth by sedimentation (Mansell 2010 \cite Mansell_2010). Activating the 3-moment scheme provides a natural sedimentation feedback that narrows the size spectrum as size-sorting procedes without the the artificial breakup induced by the 2-moment scheme. The NSSL scheme is designed with deep (severe) convection in mind at grid spacings of up to 4 km, but can also be run at larger grid spacing as needed for nesting etc. It is also able to capture non-severe and winter weather. diff --git a/physics/docs/pdftxt/suite_input.nml.txt b/physics/docs/pdftxt/suite_input.nml.txt index e986fc322..c4bb5003b 100644 --- a/physics/docs/pdftxt/suite_input.nml.txt +++ b/physics/docs/pdftxt/suite_input.nml.txt @@ -54,7 +54,7 @@ show some variables in the namelist that must match the SDF.
    • 10: Morrison-Gettelman microphysics scheme
    • 11: GFDL microphysics scheme
    • 17: NSSL microphysics scheme with background CCN -
    • 18: NSSL microphysics scheme with predicted CCN (compatibility) +
    • 18: NSSL microphysics scheme with predicted CCN (compatibility: 18 = 17 + nssl_ccn_on=.true.)
    99 \b Parameters \b related \b to \b radiation \b scheme \b options @@ -406,6 +406,7 @@ show some variables in the namelist that must match the SDF. nssl_ehw0_in mp_nssl constant or max assumed graupel-droplet collection efficiency 0.9 nssl_ehlw0_in mp_nssl constant or max assumed hail-droplet collection efficiency 0.9 nssl_hail_on mp_nssl NSSL flag to activate the hail category .false. +nssl_3moment mp_nssl NSSL flag to activate 3-moment for rain/graupel (and hail if activated).false. nssl_ccn_on mp_nssl NSSL flag to activate the CCN category .true. nssl_invertccn mp_nssl NSSL flag to treat CCN as activated or unactivated .true. nssl_ehw0 mp_nssl NSSL graupel-droplet collection efficiency 0.9 From 9b9f55320455a3bca522f1c059b2919922bee2c4 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Sun, 24 Sep 2023 16:33:05 -0500 Subject: [PATCH 340/380] module_mp_nssl_2mom.F90 : set ngs with constant --- physics/module_mp_nssl_2mom.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/module_mp_nssl_2mom.F90 b/physics/module_mp_nssl_2mom.F90 index 72ff9b1b1..a373ddaf9 100644 --- a/physics/module_mp_nssl_2mom.F90 +++ b/physics/module_mp_nssl_2mom.F90 @@ -2612,7 +2612,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw nx = ite-its+1 ny = 1 ! set up as 2D slabs nz = kte-kts+1 - ngs = Max(nz,64) + ngs = 64 IF ( .not. flag_ccn ) THEN renucfrac = 1.0 From 6ee6df60ca69743bab195fc4b04a891e91bdaeaf Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Mon, 25 Sep 2023 12:33:46 -0500 Subject: [PATCH 341/380] module_mp_nssl_2mom.F90: removed unneeded lines --- physics/module_mp_nssl_2mom.F90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/physics/module_mp_nssl_2mom.F90 b/physics/module_mp_nssl_2mom.F90 index a373ddaf9..a40a62f02 100644 --- a/physics/module_mp_nssl_2mom.F90 +++ b/physics/module_mp_nssl_2mom.F90 @@ -21238,7 +21238,6 @@ subroutine nssl_2mom_gs & pqwvi(mgs) = & & -Min(0.0, qrcev(mgs)) & & -Min(0.0, qhcev(mgs)) & - & -Min(0.0, qfcev(mgs)) & & -Min(0.0, qhlcev(mgs)) & & -Min(0.0, qscev(mgs)) & ! > +il5(mgs)*(-qhsbv(mgs) - qhlsbv(mgs) ) & @@ -21249,7 +21248,6 @@ subroutine nssl_2mom_gs & pqwvd(mgs) = & & -Max(0.0, qrcev(mgs)) & & -Max(0.0, qhcev(mgs)) & - & -Max(0.0, qfcev(mgs)) & & -Max(0.0, qhlcev(mgs)) & & -Max(0.0, qscev(mgs)) & & +il5(mgs)*(-qiint(mgs) & From dbd5f58b1f04f8d31a445ca477a1cc1169707303 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Wed, 27 Sep 2023 01:19:48 +0000 Subject: [PATCH 342/380] remove all constant 3D variables from clm lake --- physics/clm_lake.f90 | 202 ++++++++++++++++-------------------------- physics/clm_lake.meta | 78 ++-------------- 2 files changed, 86 insertions(+), 194 deletions(-) diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90 index 4fa6dacb6..c6fa56320 100644 --- a/physics/clm_lake.f90 +++ b/physics/clm_lake.f90 @@ -229,6 +229,31 @@ end subroutine is_salty !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine calculate_z_dz_lake(i,input_lakedepth,clm_lakedepth,z_lake,dz_lake) + implicit none + integer, intent(in) :: i + real(kind_phys), intent(inout) :: clm_lakedepth(:) ! lake depth used by clm + real(kind_phys), intent(in) :: input_lakedepth(:) ! lake depth before correction (m) + real(kind_lake) :: z_lake(nlevlake) ! layer depth for lake (m) + real(kind_lake) :: dz_lake(nlevlake) ! layer thickness for lake (m) + real(kind_lake) :: depthratio + + if (input_lakedepth(i) == spval) then + clm_lakedepth(i) = zlak(nlevlake) + 0.5_kind_lake*dzlak(nlevlake) + z_lake(1:nlevlake) = zlak(1:nlevlake) + dz_lake(1:nlevlake) = dzlak(1:nlevlake) + else + depthratio = input_lakedepth(i) / (zlak(nlevlake) + 0.5_kind_lake*dzlak(nlevlake)) + z_lake(1) = zlak(1) + dz_lake(1) = dzlak(1) + dz_lake(2:nlevlake) = dzlak(2:nlevlake)*depthratio + z_lake(2:nlevlake) = zlak(2:nlevlake)*depthratio + dz_lake(1)*(1._kind_lake - depthratio) + end if + + end subroutine calculate_z_dz_lake + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !> \section arg_table_clm_lake_run Argument Table !! \htmlinclude clm_lake_run.html !! @@ -258,8 +283,8 @@ SUBROUTINE clm_lake_run( & salty, savedtke12d, snowdp2d, h2osno2d, snl2d, t_grnd2d, t_lake3d, & lake_icefrac3d, t_soisno3d, h2osoi_ice3d, h2osoi_liq3d, h2osoi_vol3d, & - z3d, dz3d, zi3d, z_lake3d, dz_lake3d, watsat3d, csol3d, sand3d, clay3d, & - tkmg3d, tkdry3d, tksatu3d, clm_lakedepth, cannot_freeze, & + z3d, dz3d, zi3d, & + input_lakedepth, clm_lakedepth, cannot_freeze, & ! Error reporting: errflg, errmsg) @@ -336,14 +361,8 @@ SUBROUTINE clm_lake_run( & dz3d real(kind_phys), dimension( :,-nlevsnow+0: ) ,INTENT(inout) :: zi3d - REAL(KIND_PHYS), DIMENSION( :,: ),INTENT(INOUT) :: z_lake3d - REAL(KIND_PHYS), DIMENSION( :,: ),INTENT(INOUT) :: dz_lake3d - REAL(KIND_PHYS), DIMENSION( :,: ),INTENT(INOUT) :: watsat3d - REAL(KIND_PHYS), DIMENSION( :,: ),INTENT(INOUT) :: csol3d, sand3d, clay3d - REAL(KIND_PHYS), DIMENSION( :,: ),INTENT(INOUT) :: tkmg3d - REAL(KIND_PHYS), DIMENSION( :,: ),INTENT(INOUT) :: tkdry3d - REAL(KIND_PHYS), DIMENSION( :,: ),INTENT(INOUT) :: tksatu3d REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(INOUT) :: clm_lakedepth + REAL(KIND_PHYS), DIMENSION( : ) ,INTENT(INOUT) :: input_lakedepth ! ! Error reporting: @@ -430,10 +449,10 @@ SUBROUTINE clm_lake_run( & character*255 :: message logical, parameter :: feedback_to_atmosphere = .true. ! FIXME: REMOVE - real(kind_lake) :: to_radians, lat_d, lon_d, qss + real(kind_lake) :: to_radians, lat_d, lon_d, qss, tkm, bd - integer :: month,num1,num2,day_of_month - real(kind_lake) :: wght1,wght2,Tclim + integer :: month,num1,num2,day_of_month,isl + real(kind_lake) :: wght1,wght2,Tclim,depthratio logical salty_flag, cannot_freeze_flag @@ -451,31 +470,19 @@ SUBROUTINE clm_lake_run( & lakedepth_default=lakedepth_default, fhour=fhour, & oro_lakedepth=oro_lakedepth, savedtke12d=savedtke12d, snowdp2d=snowdp2d, & h2osno2d=h2osno2d, snl2d=snl2d, t_grnd2d=t_grnd2d, t_lake3d=t_lake3d, & - lake_icefrac3d=lake_icefrac3d, z_lake3d=z_lake3d, dz_lake3d=dz_lake3d, & + lake_icefrac3d=lake_icefrac3d, & t_soisno3d=t_soisno3d, h2osoi_ice3d=h2osoi_ice3d, h2osoi_liq3d=h2osoi_liq3d, & - h2osoi_vol3d=h2osoi_vol3d, z3d=z3d, dz3d=dz3d, zi3d=zi3d, watsat3d=watsat3d, & - csol3d=csol3d, tkmg3d=tkmg3d, fice=fice, hice=hice, min_lakeice=min_lakeice, & + h2osoi_vol3d=h2osoi_vol3d, z3d=z3d, dz3d=dz3d, zi3d=zi3d, & + fice=fice, hice=hice, min_lakeice=min_lakeice, & tsfc=tsfc, & - use_lake_model=use_lake_model, use_lakedepth=use_lakedepth, tkdry3d=tkdry3d, & - tksatu3d=tksatu3d, im=im, prsi=prsi, xlat_d=xlat_d, xlon_d=xlon_d, & - clm_lake_initialized=clm_lake_initialized, sand3d=sand3d, clay3d=clay3d, & + use_lake_model=use_lake_model, use_lakedepth=use_lakedepth, & + im=im, prsi=prsi, xlat_d=xlat_d, xlon_d=xlon_d, & + clm_lake_initialized=clm_lake_initialized, input_lakedepth=input_lakedepth, & tg3=tg3, clm_lakedepth=clm_lakedepth, km=km, me=me, master=master, & errmsg=errmsg, errflg=errflg) if(errflg/=0) then return endif - if(any(clay3d>0 .and. clay3d<1)) then - write(message,*) 'Invalid clay3d. Abort.' - errmsg=trim(message) - errflg=1 - return - endif - if(any(dz_lake3d>0 .and. dz_lake3d<.1)) then - write(message,*) 'Invalid dz_lake3d. Abort.' - errmsg=trim(message) - errflg=1 - return - endif lake_points=0 snow_points=0 @@ -540,6 +547,13 @@ SUBROUTINE clm_lake_run( & lake_points = lake_points+1 + call calculate_z_dz_lake(i,input_lakedepth,clm_lakedepth,z_lake(1,:),dz_lake(1,:)) + + do c = 2,column + z_lake(c,:) = z_lake(1,:) + dz_lake(c,:) = z_lake(1,:) + enddo + do c = 1,column forc_t(c) = SFCTMP ! [K] @@ -567,8 +581,6 @@ SUBROUTINE clm_lake_run( & do k = 1,nlevlake t_lake(c,k) = t_lake3d(i,k) lake_icefrac(c,k) = lake_icefrac3d(i,k) - z_lake(c,k) = z_lake3d(i,k) - dz_lake(c,k) = dz_lake3d(i,k) enddo do k = -nlevsnow+1,nlevsoil t_soisno(c,k) = t_soisno3d(i,k) @@ -582,11 +594,18 @@ SUBROUTINE clm_lake_run( & zi(c,k) = zi3d(i,k) enddo do k = 1,nlevsoil - watsat(c,k) = watsat3d(i,k) - csol(c,k) = csol3d(i,k) - tkmg(c,k) = tkmg3d(i,k) - tkdry(c,k) = tkdry3d(i,k) - tksatu(c,k) = tksatu3d(i,k) + ! Soil hydraulic and thermal properties + isl = ISLTYP(i) + if (isl == 0 ) isl = 14 + if (isl == 14 ) isl = isl + 1 + + watsat(c,k) = 0.489_kind_lake - 0.00126_kind_lake*sand(isl) + csol(c,k) = (2.128_kind_lake*sand(isl)+2.385_kind_lake*clay(isl)) / (sand(isl)+clay(isl))*1.e6_kind_lake ! J/(m3 K) + tkm = (8.80_kind_lake*sand(isl)+2.92_kind_lake*clay(isl))/(sand(isl)+clay(isl)) ! W/(m K) + bd = (1._kind_lake-watsat(c,k))*2.7e3_kind_lake + tkmg(c,k) = tkm ** (1._kind_lake- watsat(c,k)) + tkdry(c,k) = (0.135_kind_lake*bd + 64.7_kind_lake) / (2.7e3_kind_lake - 0.947_kind_lake*bd) + tksatu(c,k) = tkmg(c,k)*0.57_kind_lake**watsat(c,k) enddo enddo @@ -747,7 +766,7 @@ SUBROUTINE clm_lake_run( & hice(I) = 0 ! sea_ice_thickness do k=1,nlevlake if(lake_icefrac3d(i,k)>0) then - hice(i) = hice(i) + dz_lake3d(i,k) + hice(i) = hice(i) + dz_lake(c,k) endif end do else ! Not an ice point @@ -5315,14 +5334,14 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, weasd, lakedepth_default, fhour, & oro_lakedepth, savedtke12d, snowdp2d, h2osno2d, & !o snl2d, t_grnd2d, t_lake3d, lake_icefrac3d, & - z_lake3d, dz_lake3d, t_soisno3d, h2osoi_ice3d, & + t_soisno3d, h2osoi_ice3d, & h2osoi_liq3d, h2osoi_vol3d, z3d, dz3d, & - zi3d, watsat3d, csol3d, tkmg3d, & + zi3d, & fice, hice, min_lakeice, tsfc, & use_lake_model, use_lakedepth, & - tkdry3d, tksatu3d, im, prsi, & + im, prsi, & xlat_d, xlon_d, clm_lake_initialized, & - sand3d, clay3d, tg3, clm_lakedepth, & + input_lakedepth, tg3, clm_lakedepth, & km, me, master, errmsg, errflg) !> Some fields in lakeini are not available during initialization, @@ -5360,6 +5379,7 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, real(kind_phys), intent(in) :: lakedepth_default real(kind_phys), dimension(IM),intent(inout) :: clm_lakedepth + real(kind_phys), dimension(IM),intent(inout) :: input_lakedepth real(kind_phys), dimension(IM),intent(in) :: oro_lakedepth real(kind_phys), dimension(IM),intent(out) :: savedtke12d real(kind_phys), dimension(IM),intent(out) :: snowdp2d, & @@ -5368,43 +5388,24 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, t_grnd2d real(kind_phys), dimension(IM,nlevlake),INTENT(out) :: t_lake3d, & - lake_icefrac3d, & - z_lake3d, & - dz_lake3d + lake_icefrac3d real(kind_phys), dimension(IM,-nlevsnow+1:nlevsoil ),INTENT(out) :: t_soisno3d, & h2osoi_ice3d, & h2osoi_liq3d, & h2osoi_vol3d, & z3d, & dz3d - real(kind_phys), dimension(IM,nlevsoil),INTENT(out) :: watsat3d, & - csol3d, & - tkmg3d, & - tkdry3d, & - tksatu3d - real(kind_phys), dimension(IM,nlevsoil),INTENT(inout) :: clay3d, & - sand3d real(kind_phys), dimension( IM,-nlevsnow+0:nlevsoil ),INTENT(out) :: zi3d !LOGICAL, DIMENSION( : ),intent(out) :: lake !REAL(KIND_PHYS), OPTIONAL, DIMENSION( : ), INTENT(IN) :: lake_depth ! no separate variable for this in CCPP - real(kind_lake), dimension( 1:im,1:nlevsoil ) :: bsw3d, & - bsw23d, & - psisat3d, & - vwcsat3d, & - watdry3d, & - watopt3d, & - hksat3d, & - sucsat3d integer :: n,i,j,k,ib,lev,bottom ! indices real(kind_lake),dimension(1:im ) :: bd2d ! bulk density of dry soil material [kg/m^3] real(kind_lake),dimension(1:im ) :: tkm2d ! mineral conductivity real(kind_lake),dimension(1:im ) :: xksat2d ! maximum hydraulic conductivity of soil [mm/s] real(kind_lake),dimension(1:im ) :: depthratio2d ! ratio of lake depth to standard deep lake depth - real(kind_lake),dimension(1:im ) :: clay2d ! temporary - real(kind_lake),dimension(1:im ) :: sand2d ! temporary logical,parameter :: arbinit = .false. real(kind_lake),parameter :: defval = -999.0 @@ -5413,16 +5414,19 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, character*256 :: message real(kind_lake) :: ht real(kind_lake) :: rhosn - real(kind_lake) :: depth + real(kind_lake) :: depth, lakedepth logical :: climatology_limits + real(kind_lake) :: z_lake(nlevlake) ! layer depth for lake (m) + real(kind_lake) :: dz_lake(nlevlake) ! layer thickness for lake (m) + integer, parameter :: xcheck=38 integer, parameter :: ycheck=92 integer :: used_lakedepth_default, init_points, month, julday integer :: mon, iday, num2, num1, juld, day2, day1, wght1, wght2 - real(kind_lake) :: Tclim + real(kind_lake) :: Tclim, watsat used_lakedepth_default=0 @@ -5456,6 +5460,8 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, cycle endif + input_lakedepth=clm_lakedepth + snl2d(i) = defval do k = -nlevsnow+1,nlevsoil h2osoi_liq3d(i,k) = defval @@ -5468,8 +5474,6 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, do k = 1,nlevlake t_lake3d(i,k) = defval lake_icefrac3d(i,k) = defval - z_lake3d(i,k) = defval - dz_lake3d(i,k) = defval enddo if (use_lake_model(i) == 1) then @@ -5499,60 +5503,9 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, isl = ISLTYP(i) if (isl == 0 ) isl = 14 if (isl == 14 ) isl = isl + 1 - do k = 1,nlevsoil - sand3d(i,k) = sand(isl) - clay3d(i,k) = clay(isl) - - ! Cannot continue if either of these checks fail. - if(clay3d(i,k)>0 .and. clay3d(i,k)<1) then - write(message,*) 'bad clay3d ',clay3d(i,k) - write(0,'(A)') trim(message) - errmsg = trim(message) - errflg = 1 - return - endif - if(sand3d(i,k)>0 .and. sand3d(i,k)<1) then - write(message,*) 'bad sand3d ',sand3d(i,k) - write(0,'(A)') trim(message) - errmsg = trim(message) - errflg = 1 - return - endif - enddo - do k = 1,nlevsoil - clay2d(i) = clay3d(i,k) - sand2d(i) = sand3d(i,k) - watsat3d(i,k) = 0.489_kind_lake - 0.00126_kind_lake*sand2d(i) - bd2d(i) = (1._kind_lake-watsat3d(i,k))*2.7e3_kind_lake - xksat2d(i) = 0.0070556_kind_lake *( 10._kind_lake**(-0.884_kind_lake+0.0153_kind_lake*sand2d(i)) ) ! mm/s - tkm2d(i) = (8.80_kind_lake*sand2d(i)+2.92_kind_lake*clay2d(i))/(sand2d(i)+clay2d(i)) ! W/(m K) - - bsw3d(i,k) = 2.91_kind_lake + 0.159_kind_lake*clay2d(i) - bsw23d(i,k) = -(3.10_kind_lake + 0.157_kind_lake*clay2d(i) - 0.003_kind_lake*sand2d(i)) - psisat3d(i,k) = -(exp((1.54_kind_lake - 0.0095_kind_lake*sand2d(i) + 0.0063_kind_lake*(100.0_kind_lake-sand2d(i) & - -clay2d(i)))*log(10.0_kind_lake))*9.8e-5_kind_lake) - vwcsat3d(i,k) = (50.5_kind_lake - 0.142_kind_lake*sand2d(i) - 0.037_kind_lake*clay2d(i))/100.0_kind_lake - hksat3d(i,k) = xksat2d(i) - sucsat3d(i,k) = 10._kind_lake * ( 10._kind_lake**(1.88_kind_lake-0.0131_kind_lake*sand2d(i)) ) - tkmg3d(i,k) = tkm2d(i) ** (1._kind_lake- watsat3d(i,k)) - tksatu3d(i,k) = tkmg3d(i,k)*0.57_kind_lake**watsat3d(i,k) - tkdry3d(i,k) = (0.135_kind_lake*bd2d(i) + 64.7_kind_lake) / (2.7e3_kind_lake - 0.947_kind_lake*bd2d(i)) - csol3d(i,k) = (2.128_kind_lake*sand2d(i)+2.385_kind_lake*clay2d(i)) / (sand2d(i)+clay2d(i))*1.e6_kind_lake ! J/(m3 K) - watdry3d(i,k) = watsat3d(i,k) * (316230._kind_lake/sucsat3d(i,k)) ** (-1._kind_lake/bsw3d(i,k)) - watopt3d(i,k) = watsat3d(i,k) * (158490._kind_lake/sucsat3d(i,k)) ** (-1._kind_lake/bsw3d(i,k)) - end do - if (clm_lakedepth(i) == spval) then - clm_lakedepth(i) = zlak(nlevlake) + 0.5_kind_lake*dzlak(nlevlake) - z_lake3d(i,1:nlevlake) = zlak(1:nlevlake) - dz_lake3d(i,1:nlevlake) = dzlak(1:nlevlake) - else - depthratio2d(i) = clm_lakedepth(i) / (zlak(nlevlake) + 0.5_kind_lake*dzlak(nlevlake)) - z_lake3d(i,1) = zlak(1) - dz_lake3d(i,1) = dzlak(1) - dz_lake3d(i,2:nlevlake) = dzlak(2:nlevlake)*depthratio2d(i) - z_lake3d(i,2:nlevlake) = zlak(2:nlevlake)*depthratio2d(i) + dz_lake3d(i,1)*(1._kind_lake - depthratio2d(i)) - end if + call calculate_z_dz_lake(i,input_lakedepth,clm_lakedepth,z_lake,dz_lake) + z3d(i,1:nlevsoil) = zsoi(1:nlevsoil) zi3d(i,0:nlevsoil) = zisoi(0:nlevsoil) dz3d(i,1:nlevsoil) = dzsoi(1:nlevsoil) @@ -5633,9 +5586,9 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, if(lake_icefrac3d(i,1) > 0.) then depth = 0. do k=2,nlevlake - depth = depth + dz_lake3d(i,k) + depth = depth + dz_lake(k) if(hice(i) >= depth) then - lake_icefrac3d(i,k) = max(0.,lake_icefrac3d(i,1)+(0.-lake_icefrac3d(i,1))/z_lake3d(i,nlevlake)*depth) + lake_icefrac3d(i,k) = max(0.,lake_icefrac3d(i,1)+(0.-lake_icefrac3d(i,1))/z_lake(nlevlake)*depth) else lake_icefrac3d(i,k) = 0. endif @@ -5649,8 +5602,8 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, t_grnd2d(i) = max(tfrz,tsfc(i)) endif do k = 2, nlevlake - if(z_lake3d(i,k).le.depth_c) then - t_lake3d(i,k) = tsfc(i)+(277.2_kind_lake-tsfc(i))/depth_c*z_lake3d(i,k) + if(z_lake(k).le.depth_c) then + t_lake3d(i,k) = tsfc(i)+(277.2_kind_lake-tsfc(i))/depth_c*z_lake(k) else t_lake3d(i,k) = 277.2_kind_lake end if @@ -5684,7 +5637,8 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, do k = 1,nlevsoil h2osoi_vol3d(i,k) = 1.0_kind_lake - h2osoi_vol3d(i,k) = min(h2osoi_vol3d(i,k),watsat3d(i,k)) + watsat = 0.489_kind_lake - 0.00126_kind_lake*sand(isl) + h2osoi_vol3d(i,k) = min(h2osoi_vol3d(i,k),watsat) ! soil layers if (t_soisno3d(i,k) <= tfrz) then diff --git a/physics/clm_lake.meta b/physics/clm_lake.meta index 3de543078..11a44286a 100644 --- a/physics/clm_lake.meta +++ b/physics/clm_lake.meta @@ -289,6 +289,14 @@ type = real kind = kind_phys intent = in +[input_lakedepth] + standard_name = lake_depth_before_correction + long_name = lake depth_before_correction + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout [wind] standard_name = wind_speed_at_lowest_model_layer long_name = wind speed at lowest model level @@ -716,76 +724,6 @@ type = real kind = kind_phys intent = inout -[z_lake3d] - standard_name = depth_of_lake_interface_layers - long_name = depth of lake interface layers - units = fraction - dimensions = (horizontal_loop_extent, lake_vertical_dimension_for_clm_lake_model) - type = real - kind = kind_phys - intent = inout -[dz_lake3d] - standard_name = thickness_of_lake_layers - long_name = thickness of lake layers - units = fraction - dimensions = (horizontal_loop_extent, lake_vertical_dimension_for_clm_lake_model) - type = real - kind = kind_phys - intent = inout -[watsat3d] - standard_name = saturated_volumetric_soil_water_in_lake_model - long_name = saturated volumetric soil water in lake model - units = m - dimensions = (horizontal_loop_extent, lake_vertical_dimension_for_clm_lake_model) - type = real - kind = kind_phys - intent = inout -[csol3d] - standard_name = soil_heat_capacity_in_lake_model - long_name = soil heat capacity in lake model - units = m - dimensions = (horizontal_loop_extent, lake_vertical_dimension_for_clm_lake_model) - type = real - kind = kind_phys - intent = inout -[sand3d] - standard_name = clm_lake_percent_sand - long_name = percent sand in clm lake model - units = percent - dimensions = (horizontal_loop_extent,soil_vertical_dimension_for_clm_lake_model) - type = integer - intent = inout -[clay3d] - standard_name = clm_lake_percent_clay - long_name = percent clay in clm lake model - units = percent - dimensions = (horizontal_loop_extent,soil_vertical_dimension_for_clm_lake_model) - type = integer - intent = inout -[tkmg3d] - standard_name = soil_mineral_thermal_conductivity_in_lake_model - long_name = soil mineral thermal conductivity in lake model - units = m - dimensions = (horizontal_loop_extent, lake_vertical_dimension_for_clm_lake_model) - type = real - kind = kind_phys - intent = inout -[tkdry3d] - standard_name = dry_soil_thermal_conductivity_in_lake_model - long_name = dry soil thermal conductivity in lake model - units = m - dimensions = (horizontal_loop_extent, lake_vertical_dimension_for_clm_lake_model) - type = real - kind = kind_phys - intent = inout -[tksatu3d] - standard_name = saturated_soil_thermal_conductivity_in_lake_model - long_name = saturated soil thermal conductivity in lake model - units = m - dimensions = (horizontal_loop_extent, lake_vertical_dimension_for_clm_lake_model) - type = real - kind = kind_phys - intent = inout [clm_lakedepth] standard_name = clm_lake_depth long_name = clm internal copy of lake depth with 10.0 replaced by default lake depth From 75ec62308ae51ea48b03ecd438b8a1eb71c8b929 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Wed, 27 Sep 2023 14:40:02 +0000 Subject: [PATCH 343/380] calculate constants only once per i --- physics/clm_lake.f90 | 28 +++++++++++++--------------- 1 file changed, 13 insertions(+), 15 deletions(-) diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90 index c6fa56320..da4712810 100644 --- a/physics/clm_lake.f90 +++ b/physics/clm_lake.f90 @@ -554,6 +554,19 @@ SUBROUTINE clm_lake_run( & dz_lake(c,:) = z_lake(1,:) enddo + ! Soil hydraulic and thermal properties + isl = ISLTYP(i) + if (isl == 0 ) isl = 14 + if (isl == 14 ) isl = isl + 1 + + watsat = 0.489_kind_lake - 0.00126_kind_lake*sand(isl) + csol = (2.128_kind_lake*sand(isl)+2.385_kind_lake*clay(isl)) / (sand(isl)+clay(isl))*1.e6_kind_lake ! J/(m3 K) + tkm = (8.80_kind_lake*sand(isl)+2.92_kind_lake*clay(isl))/(sand(isl)+clay(isl)) ! W/(m K) + bd = (1._kind_lake-watsat(1,1))*2.7e3_kind_lake + tkmg = tkm ** (1._kind_lake- watsat(1,1)) + tkdry = (0.135_kind_lake*bd + 64.7_kind_lake) / (2.7e3_kind_lake - 0.947_kind_lake*bd) + tksatu = tkmg(1,1)*0.57_kind_lake**watsat(1,1) + do c = 1,column forc_t(c) = SFCTMP ! [K] @@ -593,21 +606,6 @@ SUBROUTINE clm_lake_run( & do k = -nlevsnow+0,nlevsoil zi(c,k) = zi3d(i,k) enddo - do k = 1,nlevsoil - ! Soil hydraulic and thermal properties - isl = ISLTYP(i) - if (isl == 0 ) isl = 14 - if (isl == 14 ) isl = isl + 1 - - watsat(c,k) = 0.489_kind_lake - 0.00126_kind_lake*sand(isl) - csol(c,k) = (2.128_kind_lake*sand(isl)+2.385_kind_lake*clay(isl)) / (sand(isl)+clay(isl))*1.e6_kind_lake ! J/(m3 K) - tkm = (8.80_kind_lake*sand(isl)+2.92_kind_lake*clay(isl))/(sand(isl)+clay(isl)) ! W/(m K) - bd = (1._kind_lake-watsat(c,k))*2.7e3_kind_lake - tkmg(c,k) = tkm ** (1._kind_lake- watsat(c,k)) - tkdry(c,k) = (0.135_kind_lake*bd + 64.7_kind_lake) / (2.7e3_kind_lake - 0.947_kind_lake*bd) - tksatu(c,k) = tkmg(c,k)*0.57_kind_lake**watsat(c,k) - enddo - enddo eflx_lwrad_net = -9999 From 7a8f6934f40390de915f4d8828d2119da9f99956 Mon Sep 17 00:00:00 2001 From: "Haiqin.Li" Date: Wed, 27 Sep 2023 18:56:22 +0000 Subject: [PATCH 344/380] "to address the reviewers' comments" --- physics/cu_c3_deep.F90 | 4 ---- physics/cu_c3_driver.F90 | 32 -------------------------------- physics/cu_c3_driver_post.F90 | 2 +- physics/cu_gf_driver.F90 | 32 -------------------------------- physics/cu_gf_driver_post.F90 | 2 +- 5 files changed, 2 insertions(+), 70 deletions(-) diff --git a/physics/cu_c3_deep.F90 b/physics/cu_c3_deep.F90 index b8a1dd838..e6d238b69 100644 --- a/physics/cu_c3_deep.F90 +++ b/physics/cu_c3_deep.F90 @@ -2078,10 +2078,6 @@ subroutine cu_c3_deep_run( & !> - Call rain_evap_below_cloudbase() to calculate evaporation below cloud base -! call rain_evap_below_cloudbase(itf,ktf,its,ite, & -! kts,kte,ierr,kbcon,xmb,psur,xland,qo_cup, & -! po_cup,qes_cup,pwavo,edto,pwevo,pre,outt,outq) !,outbuoy) - k=1 !$acc kernels do i=its,itf diff --git a/physics/cu_c3_driver.F90 b/physics/cu_c3_driver.F90 index cc2906ad5..8592e08f9 100644 --- a/physics/cu_c3_driver.F90 +++ b/physics/cu_c3_driver.F90 @@ -949,38 +949,6 @@ subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& !gdc(i,k,8)=(outq(i,k))*86400.*xlv/cp gdc(i,k,8)=(outqm(i,k)+outqs(i,k)+outq(i,k))*86400.*xlv/cp gdc(i,k,9)=gdc(i,k,2)+gdc(i,k,3)+gdc(i,k,4) -! -!> - Calculate subsidence effect on clw -! -! dsubclw=0. -! dsubclwm=0. -! dsubclws=0. -! dp=100.*(p2d(i,k)-p2d(i,k+1)) -! if (clcw(i,k) .gt. -999.0 .and. clcw(i,k+1) .gt. -999.0 )then -! clwtot = cliw(i,k) + clcw(i,k) -! clwtot1= cliw(i,k+1) + clcw(i,k+1) -! dsubclw=((-edt(i)*zd(i,k+1)+zu(i,k+1))*clwtot1 & -! -(-edt(i)*zd(i,k) +zu(i,k)) *clwtot )*g/dp -! dsubclwm=((-edtm(i)*zdm(i,k+1)+zum(i,k+1))*clwtot1 & -! -(-edtm(i)*zdm(i,k) +zum(i,k)) *clwtot )*g/dp -! dsubclws=(zus(i,k+1)*clwtot1-zus(i,k)*clwtot)*g/dp -! dsubclw=dsubclw+(zu(i,k+1)*clwtot1-zu(i,k)*clwtot)*g/dp -! dsubclwm=dsubclwm+(zum(i,k+1)*clwtot1-zum(i,k)*clwtot)*g/dp -! dsubclws=dsubclws+(zus(i,k+1)*clwtot1-zus(i,k)*clwtot)*g/dp -! endif -! tem = dt*(outqcs(i,k)*cutens(i)+outqc(i,k)*cuten(i) & -! +outqcm(i,k)*cutenm(i) & -! +dsubclw*xmb(i)+dsubclws*xmbs(i)+dsubclwm*xmbm(i) & -! ) -! tem1 = max(0.0, min(1.0, (tcr-t(i,k))*tcrf)) -! if (clcw(i,k) .gt. -999.0) then -! cliw(i,k) = max(0.,cliw(i,k) + tem * tem1) ! ice -! clcw(i,k) = max(0.,clcw(i,k) + tem *(1.0-tem1)) ! water -! else -! cliw(i,k) = max(0.,cliw(i,k) + tem) -! endif -! -! enddo !> - FCT treats subsidence effect to cloud ice/water (begin) dp=100.*(p2d(i,k)-p2d(i,k+1)) diff --git a/physics/cu_c3_driver_post.F90 b/physics/cu_c3_driver_post.F90 index 528f3d466..d5d2dee3b 100644 --- a/physics/cu_c3_driver_post.F90 +++ b/physics/cu_c3_driver_post.F90 @@ -69,7 +69,7 @@ subroutine cu_c3_driver_post_run (im, km, t, q, prevst, prevsq, cactiv, cactiv_m ze = 0.0 ze_conv = 0.0 dbz_sum = 0.0 - cuprate = max(0.1,1.e3*raincv(i) * 3600.0 / dt) ! cu precip rate (mm/h) + cuprate = 1.e3*raincv(i) * 3600.0 / dt ! cu precip rate (mm/h) if(cuprate .lt. 0.05) cuprate=0. ze_conv = 300.0 * cuprate**1.5 if (maxupmf(i).gt.0.1 .and. cuprate.gt.0.) then diff --git a/physics/cu_gf_driver.F90 b/physics/cu_gf_driver.F90 index f3f5042fc..d85b7ac52 100644 --- a/physics/cu_gf_driver.F90 +++ b/physics/cu_gf_driver.F90 @@ -927,38 +927,6 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& !gdc(i,k,8)=(outq(i,k))*86400.*xlv/cp gdc(i,k,8)=(outqm(i,k)+outqs(i,k)+outq(i,k))*86400.*xlv/cp gdc(i,k,9)=gdc(i,k,2)+gdc(i,k,3)+gdc(i,k,4) -! -!> - Calculate subsidence effect on clw -! -! dsubclw=0. -! dsubclwm=0. -! dsubclws=0. -! dp=100.*(p2d(i,k)-p2d(i,k+1)) -! if (clcw(i,k) .gt. -999.0 .and. clcw(i,k+1) .gt. -999.0 )then -! clwtot = cliw(i,k) + clcw(i,k) -! clwtot1= cliw(i,k+1) + clcw(i,k+1) -! dsubclw=((-edt(i)*zd(i,k+1)+zu(i,k+1))*clwtot1 & -! -(-edt(i)*zd(i,k) +zu(i,k)) *clwtot )*g/dp -! dsubclwm=((-edtm(i)*zdm(i,k+1)+zum(i,k+1))*clwtot1 & -! -(-edtm(i)*zdm(i,k) +zum(i,k)) *clwtot )*g/dp -! dsubclws=(zus(i,k+1)*clwtot1-zus(i,k)*clwtot)*g/dp -! dsubclw=dsubclw+(zu(i,k+1)*clwtot1-zu(i,k)*clwtot)*g/dp -! dsubclwm=dsubclwm+(zum(i,k+1)*clwtot1-zum(i,k)*clwtot)*g/dp -! dsubclws=dsubclws+(zus(i,k+1)*clwtot1-zus(i,k)*clwtot)*g/dp -! endif -! tem = dt*(outqcs(i,k)*cutens(i)+outqc(i,k)*cuten(i) & -! +outqcm(i,k)*cutenm(i) & -! +dsubclw*xmb(i)+dsubclws*xmbs(i)+dsubclwm*xmbm(i) & -! ) -! tem1 = max(0.0, min(1.0, (tcr-t(i,k))*tcrf)) -! if (clcw(i,k) .gt. -999.0) then -! cliw(i,k) = max(0.,cliw(i,k) + tem * tem1) ! ice -! clcw(i,k) = max(0.,clcw(i,k) + tem *(1.0-tem1)) ! water -! else -! cliw(i,k) = max(0.,cliw(i,k) + tem) -! endif -! -! enddo !> - FCT treats subsidence effect to cloud ice/water (begin) dp=100.*(p2d(i,k)-p2d(i,k+1)) diff --git a/physics/cu_gf_driver_post.F90 b/physics/cu_gf_driver_post.F90 index 59f43618c..5adf3ac42 100644 --- a/physics/cu_gf_driver_post.F90 +++ b/physics/cu_gf_driver_post.F90 @@ -69,7 +69,7 @@ subroutine cu_gf_driver_post_run (im, km, t, q, prevst, prevsq, cactiv, cactiv_m ze = 0.0 ze_conv = 0.0 dbz_sum = 0.0 - cuprate = max(0.1,1.e3*raincv(i) * 3600.0 / dt) ! cu precip rate (mm/h) + cuprate = 1.e3*raincv(i) * 3600.0 / dt ! cu precip rate (mm/h) if(cuprate .lt. 0.05) cuprate=0. ze_conv = 300.0 * cuprate**1.5 if (maxupmf(i).gt.0.1 .and. cuprate.gt.0.) then From a110a5b93bce92bab083fdaa07bd21ba5cae8720 Mon Sep 17 00:00:00 2001 From: dustinswales Date: Wed, 27 Sep 2023 14:04:50 -0600 Subject: [PATCH 345/380] Getting real close... --- physics/GFS_phys_time_vary.fv3.F90 | 105 ++++-- physics/GFS_phys_time_vary.fv3.meta | 83 ++++- physics/GFS_rrtmg_pre.F90 | 19 +- physics/GFS_rrtmg_pre.meta | 39 +-- physics/GFS_rrtmg_setup.F90 | 26 +- physics/GFS_rrtmg_setup.meta | 30 +- physics/GFS_rrtmgp_pre.F90 | 22 +- physics/GFS_rrtmgp_pre.meta | 35 +- physics/GFS_rrtmgp_setup.F90 | 20 +- physics/GFS_rrtmgp_setup.meta | 30 +- physics/module_ozphys.F90 | 476 ++++++++++++++++++++++++++++ physics/module_ozphys.meta | 24 ++ physics/ozphys_2015.F90 | 126 +++----- physics/ozphys_2015.meta | 62 +--- physics/ozphys_time_vary.F90 | 165 ---------- physics/ozphys_time_vary.meta | 200 ------------ physics/radiation_gases.f | 313 ++---------------- physics/rrtmgp_lw_main.F90 | 1 - 18 files changed, 815 insertions(+), 961 deletions(-) create mode 100644 physics/module_ozphys.F90 create mode 100644 physics/module_ozphys.meta delete mode 100644 physics/ozphys_time_vary.F90 delete mode 100644 physics/ozphys_time_vary.meta diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index d82f22399..af2dd9b00 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -10,10 +10,12 @@ module GFS_phys_time_vary use omp_lib #endif - use machine, only : kind_phys + use machine, only : kind_phys, kind_dbl_prec, kind_sngl_prec use mersenne_twister, only: random_setseed, random_number + use module_ozphys, only: ty_ozphys + use h2o_def, only : levh2o, h2o_coeff, h2o_lat, h2o_pres, h2o_time, h2oplin use h2ointerp, only : read_h2odata, setindxh2o, h2ointerpol @@ -64,9 +66,9 @@ module GFS_phys_time_vary !>\section gen_GFS_phys_time_vary_init GFS_phys_time_vary_init General Algorithm !> @{ subroutine GFS_phys_time_vary_init ( & - me, master, h2o_phys, iaerclm, iccn, iaermdl, iflip, im, levs, & + me, master, ntoz, h2o_phys, iaerclm, iccn, iaermdl, iflip, im, levs, & nx, ny, idate, xlat_d, xlon_d, & - jindx1_h, jindx2_h, ddy_h, h2opl,fhour, & + jindx1_o3, jindx2_o3, ddy_o3, jindx1_h, jindx2_h, ddy_h, h2opl,fhour, & jindx1_aer, jindx2_aer, ddy_aer, iindx1_aer, iindx2_aer, ddx_aer, aer_nm, & jindx1_ci, jindx2_ci, ddy_ci, iindx1_ci, iindx2_ci, ddx_ci, imap, jmap, & do_ugwp_v1, jindx1_tau, jindx2_tau, ddy_j1tau, ddy_j2tau, & @@ -79,12 +81,12 @@ subroutine GFS_phys_time_vary_init ( smcwtdxy, deeprechxy, rechxy, snowxy, snicexy, snliqxy, tsnoxy , smoiseq, zsnsoxy, & slc, smc, stc, tsfcl, snowd, canopy, tg3, stype, con_t0c, lsm_cold_start, nthrds, & lkm, use_lake_model, lakefrac, lakedepth, iopt_lake, iopt_lake_clm, iopt_lake_flake, & - lakefrac_threshold, lakedepth_threshold, errmsg, errflg) + lakefrac_threshold, lakedepth_threshold, ozphys, errmsg, errflg) implicit none ! Interface variables - integer, intent(in) :: me, master, iccn, iflip, im, nx, ny, levs, iaermdl + integer, intent(in) :: me, master, ntoz, iccn, iflip, im, nx, ny, levs, iaermdl logical, intent(in) :: h2o_phys, iaerclm, lsm_cold_start integer, intent(in) :: idate(:), iopt_lake, iopt_lake_clm, iopt_lake_flake real(kind_phys), intent(in) :: fhour, lakefrac_threshold, lakedepth_threshold @@ -93,8 +95,8 @@ subroutine GFS_phys_time_vary_init ( integer, intent(in) :: lkm integer, intent(inout) :: use_lake_model(:) real(kind=kind_phys), intent(in ) :: lakefrac(:), lakedepth(:) - integer, intent(inout) :: jindx1_h(:), jindx2_h(:) - real(kind_phys), intent(inout) :: ddy_h(:) + integer, intent(inout) :: jindx1_o3(:), jindx2_o3(:), jindx1_h(:), jindx2_h(:) + real(kind_phys), intent(inout) :: ddy_o3(:), ddy_h(:) real(kind_phys), intent(in) :: h2opl(:,:,:) integer, intent(inout) :: jindx1_aer(:), jindx2_aer(:), iindx1_aer(:), iindx2_aer(:) @@ -113,6 +115,7 @@ subroutine GFS_phys_time_vary_init ( real(kind_phys), intent(in) :: min_seaice, fice(:) real(kind_phys), intent(in) :: landfrac(:) real(kind_phys), intent(inout) :: weasd(:) + type(ty_ozphys), intent(in) :: ozphys ! NoahMP - only allocated when NoahMP is used integer, intent(in) :: lsoil, lsnow_lsm_lbound, lsnow_lsm_ubound @@ -200,21 +203,30 @@ subroutine GFS_phys_time_vary_init ( jamax=-999 !$OMP parallel num_threads(nthrds) default(none) & -!$OMP shared (me,master,h2o_phys,im,nx,ny,levs,idate) & +!$OMP shared (me,master,ntoz,h2o_phys,im,nx,ny,levs,idate) & !$OMP shared (xlat_d,xlon_d,imap,jmap,errmsg,errflg) & !$OMP shared (levh2o,h2o_coeff,h2o_pres,h2opl) & !$OMP shared (iamin, iamax, jamin, jamax) & !$OMP shared (iaerclm,iaermdl,ntrcaer,aer_nm,iflip,iccn) & -!$OMP shared (jindx1_h,jindx2_h,ddy_h) & +!$OMP shared (jindx1_o3,jindx2_o3,ddy_o3,jindx1_h,jindx2_h,ddy_h) & !$OMP shared (jindx1_aer,jindx2_aer,ddy_aer,iindx1_aer,iindx2_aer,ddx_aer) & !$OMP shared (jindx1_ci,jindx2_ci,ddy_ci,iindx1_ci,iindx2_ci,ddx_ci) & !$OMP shared (do_ugwp_v1,jindx1_tau,jindx2_tau,ddy_j1tau,ddy_j2tau) & !$OMP shared (isot,ivegsrc,nlunit,sncovr,sncovr_ice,lsm,lsm_ruc) & !$OMP shared (min_seaice,fice,landfrac,vtype,weasd,snupx,salp_data) & +!$OMP shared (ozphys) & !$OMP private (ix,i,j,rsnow,vegtyp) !$OMP sections +!$OMP section +!> - Setup spatial interpolation indices for ozone physics. + if (ntoz > 0) then + !$OMP CRITICAL + call ozphys%setup_forcing(xlat_d, jindx1_o3, jindx2_o3, ddy_o3) + !$OMP END CRITICAL + endif + !$OMP section !> - Call read_h2odata() to read stratospheric water vapor data call read_h2odata (h2o_phys, me, master) @@ -710,8 +722,8 @@ end subroutine GFS_phys_time_vary_init !> @{ subroutine GFS_phys_time_vary_timestep_init ( & me, master, cnx, cny, isc, jsc, nrcm, im, levs, kdt, idate, nsswr, fhswr, lsswr, fhour, & - imfdeepcnv, cal_pre, random_clds, nscyc, h2o_phys, iaerclm, iccn, clstp, & - jindx1_h, jindx2_h, ddy_h, h2opl, iflip, & + imfdeepcnv, cal_pre, random_clds, nscyc, ntoz, h2o_phys, iaerclm, iccn, clstp, & + jindx1_o3, jindx2_o3, ddy_o3, ozpl, jindx1_h, jindx2_h, ddy_h, h2opl, iflip, & jindx1_aer, jindx2_aer, ddy_aer, iindx1_aer, iindx2_aer, ddx_aer, aer_nm, & jindx1_ci, jindx2_ci, ddy_ci, iindx1_ci, iindx2_ci, ddx_ci, in_nm, ccn_nm, fn_nml, & imap, jmap, prsl, seed0, rann, nthrds, nx, ny, nsst, tile_num, nlunit, lsoil, lsoil_lsm,& @@ -719,21 +731,21 @@ subroutine GFS_phys_time_vary_timestep_init ( lakefrac, min_seaice, min_lakeice, smc, slc, stc, smois, sh2o, tslb, tiice, tg3, tref, & tsfc, tsfco, tisfc, hice, fice, facsf, facwf, alvsf, alvwf, alnsf, alnwf, zorli, zorll, & zorlo, weasd, slope, snoalb, canopy, vfrac, vtype, stype,scolor, shdmin, shdmax, snowd, & - cv, cvb, cvt, oro, oro_uf, xlat_d, xlon_d, slmsk, landfrac, & + cv, cvb, cvt, oro, oro_uf, xlat_d, xlon_d, slmsk, landfrac, ozphys, & do_ugwp_v1, jindx1_tau, jindx2_tau, ddy_j1tau, ddy_j2tau, tau_amf, errmsg, errflg) implicit none ! Interface variables integer, intent(in) :: me, master, cnx, cny, isc, jsc, nrcm, im, levs, kdt, & - nsswr, imfdeepcnv, iccn, nscyc, iflip + nsswr, imfdeepcnv, iccn, nscyc, ntoz, iflip integer, intent(in) :: idate(:) real(kind_phys), intent(in) :: fhswr, fhour logical, intent(in) :: lsswr, cal_pre, random_clds, h2o_phys, iaerclm real(kind_phys), intent(out) :: clstp - integer, intent(in) :: jindx1_h(:), jindx2_h(:) - real(kind_phys), intent(in) :: ddy_h(:) - real(kind_phys), intent(inout) :: h2opl(:,:,:) + integer, intent(in) :: jindx1_o3(:), jindx2_o3(:), jindx1_h(:), jindx2_h(:) + real(kind_phys), intent(in) :: ddy_o3(:), ddy_h(:) + real(kind_phys), intent(inout) :: ozpl(:,:,:), h2opl(:,:,:) integer, intent(in) :: jindx1_aer(:), jindx2_aer(:), iindx1_aer(:), iindx2_aer(:) real(kind_phys), intent(in) :: ddy_aer(:), ddx_aer(:) real(kind_phys), intent(inout) :: aer_nm(:,:,:) @@ -749,6 +761,7 @@ subroutine GFS_phys_time_vary_timestep_init ( integer, intent(in) :: jindx1_tau(:), jindx2_tau(:) real(kind_phys), intent(in) :: ddy_j1tau(:), ddy_j2tau(:) real(kind_phys), intent(inout) :: tau_amf(:) + type(ty_ozphys), intent(in) :: ozphys ! For gcycle only integer, intent(in) :: nthrds, nx, ny, nsst, tile_num, nlunit, lsoil @@ -771,10 +784,13 @@ subroutine GFS_phys_time_vary_timestep_init ( integer, intent(out) :: errflg ! Local variables - integer :: i, j, k, iseed, iskip, ix - real(kind=kind_phys) :: wrk(1) - real(kind=kind_phys) :: rannie(cny) - real(kind=kind_phys) :: rndval(cnx*cny*nrcm) + integer :: i, j, k, iseed, iskip, ix, idat(8), jdat(8), iday, j1, j2, nc, n1, n2, jdow, & + jdoy, jday, w3kindreal, w3kindint + real(kind_phys) :: wrk(1), tem, tx1, tx2, rjday + real(kind_phys) :: rannie(cny) + real(kind_phys) :: rndval(cnx*cny*nrcm) + real(kind_dbl_prec) :: rinc(5) + real(kind_sngl_prec) :: rinc4(5) ! Initialize CCPP error handling variables errmsg = '' @@ -790,15 +806,56 @@ subroutine GFS_phys_time_vary_timestep_init ( !$OMP parallel num_threads(nthrds) default(none) & !$OMP shared(kdt,nsswr,lsswr,clstp,imfdeepcnv,cal_pre,random_clds) & !$OMP shared(fhswr,fhour,seed0,cnx,cny,nrcm,wrk,rannie,rndval) & -!$OMP shared(rann,im,isc,jsc,imap,jmap,me,idate) & -!$OMP shared(h2o_phys,jindx1_h,jindx2_h,h2opl,ddy_h,iaerclm,master) & +!$OMP shared(rann,im,isc,jsc,imap,jmap,ntoz,me,idate,jindx1_o3,jindx2_o3) & +!$OMP shared(ozpl,ddy_o3,h2o_phys,jindx1_h,jindx2_h,h2opl,ddy_h,iaerclm,master) & !$OMP shared(levs,prsl,iccn,jindx1_ci,jindx2_ci,ddy_ci,iindx1_ci,iindx2_ci) & !$OMP shared(ddx_ci,in_nm,ccn_nm,do_ugwp_v1,jindx1_tau,jindx2_tau,ddy_j1tau) & -!$OMP shared(ddy_j2tau,tau_amf,iflip) & -!$OMP private(iseed,iskip,i,j,k) +!$OMP shared(ddy_j2tau,tau_amf,iflip,ozphys) & +!$OMP private(iseed,iskip,i,j,rjday,idat,rinc,w3kindreal,w3kindint,jdat)& +!$OMP private(jdow,jdoy,jday,rinc4,n1,n2) !$OMP sections +!$OMP section +!> - Compute temporal interpolation indices for updating gas concentrations. + idat=0 + idat(1)=idate(4) + idat(2)=idate(2) + idat(3)=idate(3) + idat(5)=idate(1) + rinc=0. + rinc(2)=fhour + call w3kind(w3kindreal,w3kindint) + if(w3kindreal==4) then + rinc4=rinc + CALL w3movdat(rinc4,idat,jdat) + else + CALL w3movdat(rinc,idat,jdat) + endif + jdow = 0 + jdoy = 0 + jday = 0 + call w3doxdat(jdat,jdow,jdoy,jday) + rjday = jdoy + jdat(5) / 24. + if (rjday < ozphys%time(1)) rjday = rjday + 365. + + n2 = ozphys%ntime + 1 + do j=2,ozphys%ntime + if (rjday < ozphys%time(j)) then + n2 = j + exit + endif + enddo + n1 = n2 - 1 + if (n2 > ozphys%ntime) n2 = n2 - ozphys%ntime + + !> - Update ozone concentration. + if (ntoz > 0) then + !$OMP CRITICAL + call ozphys%update_forcing(jindx1_o3, jindx2_o3, ddy_o3, rjday, n1, n2, ozpl) + !$OMP END CRITICAL + endif + !$OMP section !--- switch for saving convective clouds - cnvc90.f diff --git a/physics/GFS_phys_time_vary.fv3.meta b/physics/GFS_phys_time_vary.fv3.meta index 6ef6e226c..bf5a3fa04 100644 --- a/physics/GFS_phys_time_vary.fv3.meta +++ b/physics/GFS_phys_time_vary.fv3.meta @@ -2,7 +2,7 @@ name = GFS_phys_time_vary type = scheme dependencies = aerclm_def.F,aerinterp.F90,gcycle.F90,h2o_def.f,h2ointerp.f90,iccn_def.F,iccninterp.F90,machine.F,mersenne_twister.f - dependencies = namelist_soilveg.f,set_soilveg.f,sfcsub.F,cires_tauamf_data.F90,noahmp_tables.f90 + dependencies = namelist_soilveg.f,set_soilveg.f,sfcsub.F,cires_tauamf_data.F90,noahmp_tables.f90,module_ozphys.F90 ######################################################################## [ccpp-arg-table] @@ -72,6 +72,36 @@ dimensions = () type = integer intent = in + intent = in +[ntoz] + standard_name = index_of_ozone_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for ozone mixing ratio + units = index + dimensions = () + type = integer + intent = in +[jindx1_o3] + standard_name = lower_latitude_index_of_ozone_forcing_for_interpolation + long_name = interpolation low index for ozone + units = index + dimensions = (horizontal_dimension) + type = integer + intent = in +[jindx2_o3] + standard_name = upper_latitude_index_of_ozone_forcing_for_interpolation + long_name = interpolation high index for ozone + units = index + dimensions = (horizontal_dimension) + type = integer + intent = in +[ddy_o3] + standard_name = latitude_interpolation_weight_for_ozone_forcing + long_name = interpolation high index for ozone + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in [nx] standard_name = number_of_points_in_x_direction_for_this_MPI_rank long_name = number of points in x direction for this MPI rank @@ -932,6 +962,13 @@ type = real kind = kind_phys intent = in +[ozphys] + standard_name = dataset_for_ozone_physics + long_name = dataset for NRL ozone physics + units = mixed + dimensions = () + type = ty_ozphys + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -1107,6 +1144,13 @@ dimensions = () type = integer intent = in +[ntoz] + standard_name = index_of_ozone_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for ozone mixing ratio + units = index + dimensions = () + type = integer + intent = in [h2o_phys] standard_name = flag_for_stratospheric_water_vapor_physics long_name = flag for stratospheric water vapor physics @@ -1136,6 +1180,36 @@ type = real kind = kind_phys intent = out +[jindx1_o3] + standard_name = lower_latitude_index_of_ozone_forcing_for_interpolation + long_name = interpolation low index for ozone + units = index + dimensions = (horizontal_dimension) + type = integer + intent = in +[jindx2_o3] + standard_name = upper_latitude_index_of_ozone_forcing_for_interpolation + long_name = interpolation high index for ozone + units = index + dimensions = (horizontal_dimension) + type = integer + intent = in +[ddy_o3] + standard_name = latitude_interpolation_weight_for_ozone_forcing + long_name = interpolation high index for ozone + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in +[ozpl] + standard_name = ozone_forcing + long_name = ozone forcing data + units = mixed + dimensions = (horizontal_dimension,number_of_levels_in_ozone_data,number_of_coefficients_in_ozone_data) + type = real + kind = kind_phys + intent = inout [jindx1_h] standard_name = lower_latitude_index_of_stratospheric_water_vapor_forcing_for_interpolation long_name = interpolation low index for stratospheric water vapor @@ -1868,6 +1942,13 @@ type = real kind = kind_phys intent = inout +[ozphys] + standard_name = dataset_for_ozone_physics + long_name = dataset for NRL ozone physics + units = mixed + dimensions = () + type = ty_ozphys + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index f2183919f..69be4f8d0 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -45,8 +45,8 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& gasvmr_ccl4, gasvmr_cfc113, aerodp,ext550, clouds6, clouds7, clouds8, & clouds9, cldsa, cldfra, cldfra2d, lwp_ex,iwp_ex, lwp_fc,iwp_fc, & faersw1, faersw2, faersw3, faerlw1, faerlw2, faerlw3, alpha, rrfs_sd, & - aero_dir_fdb, fdb_coef, spp_wts_rad, spp_rad, ico2, latsozc, levozc, & - blatc, dphiozc, errmsg, errflg) + aero_dir_fdb, fdb_coef, spp_wts_rad, spp_rad, ico2, ozphys, & + errmsg, errflg) use machine, only: kind_phys @@ -54,7 +54,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& use funcphys, only: fpvs use module_radiation_astronomy,only: coszmn ! sol_init, sol_update - use module_radiation_gases, only: NF_VGAS, getgases, getozn ! gas_init, gas_update, + use module_radiation_gases, only: NF_VGAS, getgases ! gas_init, gas_update, use module_radiation_aerosols, only: NF_AESW, NF_AELW, setaer, & ! aer_init, aer_update, & NSPC1 use module_radiation_clouds, only: NF_CLDS, & ! cld_init @@ -81,6 +81,8 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& make_IceNumber, & make_DropletNumber, & make_RainNumber + ! For NRL Ozone + use module_ozphys, only: ty_ozphys implicit none integer, intent(in) :: im, levs, lm, lmk, lmp, ltp, & @@ -102,8 +104,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& imp_physics_mg, imp_physics_wsm6, & imp_physics_nssl, & imp_physics_fer_hires, & - yearlen, icloud, iaermdl, iaerflg, & - latsozc, levozc + yearlen, icloud, iaermdl, iaerflg integer, intent(in) :: & iovr, & ! choice of cloud-overlap method @@ -134,7 +135,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& integer, intent(in) :: spp_rad real(kind_phys), intent(in) :: spp_wts_rad(:,:) - real(kind=kind_phys), intent(in) :: fhswr, fhlwr, solhr, sup, julian, sppt_amp, dcorr_con, blatc, dphiozc + real(kind=kind_phys), intent(in) :: fhswr, fhlwr, solhr, sup, julian, sppt_amp, dcorr_con real(kind=kind_phys), intent(in) :: con_eps, epsm1, fvirt, rog, rocp, con_rd, con_pi, con_g, con_ttp, con_thgni real(kind=kind_phys), dimension(:), intent(in) :: xlat_d, xlat, xlon, & @@ -252,6 +253,9 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& integer :: iflag integer :: islmsk + ! For NRL Ozone + type(ty_ozphys),intent(in) :: ozphys + integer :: ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte @@ -422,7 +426,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& !> - Get layer ozone mass mixing ratio (if use ozone climatology data, -!! call getozn()). if (ntoz > 0) then ! interactive ozone generation do k=1,lmk @@ -431,7 +434,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& enddo enddo else ! climatological ozone - call getozn (prslk1, xlat, im, lmk, top_at_1, latsozc, levozc, blatc, dphiozc, olyr) + call ozphys%oz_clim(xlat, prslk1, con_pi, olyr) endif ! end_if_ntoz !> - Call coszmn(), to compute cosine of zenith angle (only when SW is called) diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 038f59c27..a29b0ac3c 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -2,7 +2,7 @@ name = GFS_rrtmg_pre type = scheme dependencies = funcphys.f90,iounitdef.f,machine.F,module_bfmicrophysics.f,module_mp_radar.F90,module_mp_thompson.F90 - dependencies = module_mp_thompson_make_number_concentrations.F90,radcons.f90,radiation_aerosols.f + dependencies = module_mp_thompson_make_number_concentrations.F90,radcons.f90,radiation_aerosols.f,module_ozphys.F90 dependencies = radiation_astronomy.f,radiation_clouds.f,radiation_gases.f,radlw_param.f,radsw_param.f,surface_perturbation.F90,radiation_cloud_overlap.F90 ######################################################################## @@ -247,6 +247,13 @@ dimensions = () type = integer intent = in +[ozphys] + standard_name = dataset_for_ozone_physics + long_name = dataset for NRL ozone physics + units = mixed + dimensions = () + type = ty_ozphys + intent = in [iaermdl] standard_name = control_for_aerosol_radiation_scheme long_name = control of aerosol scheme in radiation @@ -1503,36 +1510,6 @@ dimensions = () type = integer intent = in -[latsozc] - standard_name = number_of_latitudes_in_ozone_climotology_data - long_name = number of latitude in ozone climotology data - units = count - dimensions = () - type = integer - intent = in -[levozc] - standard_name = number_of_levels_in_ozone_climotology_data - long_name = number of levels in ozone climotology data - units = count - dimensions = () - type = integer - intent = in -[dphiozc] - standard_name = ozone_data_parameter_1 - long_name = ozone data parameter 1 - units = none - dimensions = () - type = real - kind = kind_phys - intent = in -[blatc] - standard_name = ozone_data_parameter_2 - long_name = ozone data parameter 2 - units = none - dimensions = () - type = real - kind = kind_phys - intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/GFS_rrtmg_setup.F90 b/physics/GFS_rrtmg_setup.F90 index 30917b961..908a364dc 100644 --- a/physics/GFS_rrtmg_setup.F90 +++ b/physics/GFS_rrtmg_setup.F90 @@ -7,7 +7,7 @@ module GFS_rrtmg_setup use machine, only: kind_phys - + use module_ozphys, only: ty_ozphys implicit none public GFS_rrtmg_setup_init, GFS_rrtmg_setup_timestep_init, GFS_rrtmg_setup_finalize @@ -44,7 +44,7 @@ subroutine GFS_rrtmg_setup_init ( si, levr, ictm, isol, solar_file, ico2, & iaermdl, iaerflg, aeros_file, con_pi, con_t0c, con_c, con_boltz, & con_plnk, con_solr_2008, con_solr_2002, con_g, con_rd, co2usr_file, & co2cyc_file, rad_hr_units, inc_minor_gas, icliq_lw, isubcsw, isubclw,& - iswmode, latsozp, levozp, timeozp, ipsd0, ltp, lextop, errmsg, errflg) + iswmode, ipsd0, ltp, lextop, errmsg, errflg) ! ================= subprogram documentation block ================ ! ! ! ! subprogram: GFS_rrtmg_setup_init - a subprogram to initialize radiation ! @@ -155,8 +155,7 @@ subroutine GFS_rrtmg_setup_init ( si, levr, ictm, isol, solar_file, ico2, & integer, intent(in) :: levr, ictm, isol, ico2, iaer, ntcw, num_p3d, & ltp, npdf3d, ntoz, iovr, iovr_rand, iovr_maxrand, iovr_max, & iovr_dcorr, iovr_exp, iovr_exprand, icliq_sw, imp_physics, & - iflip, me, rad_hr_units, icliq_lw, isubcsw, isubclw, iswmode, & - latsozp, levozp, timeozp + iflip, me, rad_hr_units, icliq_lw, isubcsw, isubclw, iswmode integer, intent(in) :: idate(:) logical, intent(in) :: lcrick, lcnorm, lnoprec, do_RRTMGP, lalw1bd, & inc_minor_gas, lextop @@ -219,8 +218,7 @@ subroutine GFS_rrtmg_setup_init ( si, levr, ictm, isol, solar_file, ico2, & con_pi ) call aer_init ( levr, me, iaermdl, iaerflg, lalw1bd, aeros_file, & con_pi, con_t0c, con_c, con_boltz, con_plnk, errflg, errmsg) - call gas_init ( me, co2usr_file, co2cyc_file, ico2, ictm, ntoz, & - con_pi, latsozp, levozp, timeozp, errflg, errmsg) + call gas_init ( me, co2usr_file, co2cyc_file, ico2, ictm, con_pi, errflg, errmsg ) call cld_init ( si, levr, imp_physics, me, con_g, con_rd, errflg, errmsg) call rlwinit ( me, rad_hr_units, inc_minor_gas, icliq_lw, isubcsw, & iovr, iovr_rand, iovr_maxrand, iovr_max, iovr_dcorr, & @@ -246,7 +244,8 @@ end subroutine GFS_rrtmg_setup_init !! subroutine GFS_rrtmg_setup_timestep_init (idate, jdate, deltsw, deltim, & lsswr, me, iaermdl, iaerflg, isol, aeros_file, slag, sdec, cdec, & - solcon, con_pi, co2dat_file, co2gbl_file, ictm, ico2, ntoz, errmsg, errflg) + solcon, con_pi, co2dat_file, co2gbl_file, ictm, ico2, ntoz, ozphys,& + errmsg, errflg) implicit none @@ -259,6 +258,7 @@ subroutine GFS_rrtmg_setup_timestep_init (idate, jdate, deltsw, deltim, & logical, intent(in) :: lsswr integer, intent(in) :: me integer, intent(in) :: iaermdl, iaerflg, isol, ictm, ico2, ntoz + type(ty_ozphys), intent(inout) :: ozphys character(len=26), intent(in) :: aeros_file, co2dat_file, co2gbl_file real(kind=kind_phys), intent(out) :: slag real(kind=kind_phys), intent(out) :: sdec @@ -279,7 +279,7 @@ subroutine GFS_rrtmg_setup_timestep_init (idate, jdate, deltsw, deltim, & errflg = 0 call radupdate(idate,jdate,deltsw,deltim,lsswr,me,iaermdl, iaerflg,isol,aeros_file,& - slag,sdec,cdec,solcon,con_pi,co2dat_file,co2gbl_file,ictm,ico2,ntoz,errflg,errmsg) + slag,sdec,cdec,solcon,con_pi,co2dat_file,co2gbl_file,ictm,ico2,ntoz,ozphys,errflg,errmsg) end subroutine GFS_rrtmg_setup_timestep_init @@ -327,7 +327,7 @@ end subroutine GFS_rrtmg_setup_finalize !----------------------------------- subroutine radupdate( idate,jdate,deltsw,deltim,lsswr,me, iaermdl,& iaerflg, isol, aeros_file, slag,sdec,cdec,solcon, con_pi, & - co2dat_file,co2gbl_file, ictm, ico2, ntoz, errflg, errmsg) + co2dat_file,co2gbl_file, ictm, ico2, ntoz, ozphys, errflg, errmsg) !................................... ! ================= subprogram documentation block ================ ! @@ -371,6 +371,7 @@ subroutine radupdate( idate,jdate,deltsw,deltim,lsswr,me, iaermdl,& ! --- inputs: integer, intent(in) :: idate(:), jdate(:), me, iaermdl, iaerflg, isol, ictm, ntoz, ico2 + type(ty_ozphys),intent(inout) :: ozphys logical, intent(in) :: lsswr character(len=26),intent(in) :: aeros_file,co2dat_file,co2gbl_file @@ -463,8 +464,11 @@ subroutine radupdate( idate,jdate,deltsw,deltim,lsswr,me, iaermdl,& lco2_chg = .false. endif - call gas_update ( kyear,kmon,kday,khour,loz1st,lco2_chg, me, co2dat_file, & - co2gbl_file, ictm, ico2, ntoz, errflg, errmsg ) + call gas_update ( kyear,kmon,kday,khour,lco2_chg, me, co2dat_file, & + co2gbl_file, ictm, ico2, errflg, errmsg ) + if (ntoz == 0) then + call ozphys%update_clim(kmon, kday, khour, loz1st) + endif if ( loz1st ) loz1st = .false. diff --git a/physics/GFS_rrtmg_setup.meta b/physics/GFS_rrtmg_setup.meta index f92d6f8db..35713757b 100644 --- a/physics/GFS_rrtmg_setup.meta +++ b/physics/GFS_rrtmg_setup.meta @@ -2,7 +2,7 @@ name = GFS_rrtmg_setup type = scheme dependencies = iounitdef.f,module_bfmicrophysics.f,radcons.f90,radiation_aerosols.f,radiation_astronomy.f,radiation_clouds.f - dependencies = module_mp_thompson.F90,radiation_gases.f,radlw_main.F90,radlw_param.f,radsw_main.F90,radsw_param.f,machine.F + dependencies = module_mp_thompson.F90,radiation_gases.f,radlw_main.F90,radlw_param.f,radsw_main.F90,radsw_param.f,machine.F,module_ozphys.F90 ######################################################################## [ccpp-arg-table] @@ -173,27 +173,6 @@ dimensions = () type = integer intent = in -[levozp] - standard_name = number_of_levels_in_ozone_climotology_data - long_name = number of levels in ozone climotology data - units = count - dimensions = () - type = integer - intent = in -[timeozp] - standard_name = number_of_times_in_ozone_climotology_data - long_name = number of times in ozone climotology data - units = count - dimensions = () - type = integer - intent = in -[latsozp] - standard_name = number_of_latitudes_in_ozone_climotology_data - long_name = number of latitude in ozone climotology data - units = count - dimensions = () - type = integer - intent = in [icliq_sw] standard_name = control_for_shortwave_radiation_liquid_clouds long_name = sw optical property for liquid clouds @@ -530,6 +509,13 @@ dimensions = () type = integer intent = in +[ozphys] + standard_name = dataset_for_ozone_physics + long_name = dataset for NRL ozone physics + units = mixed + dimensions = () + type = ty_ozphys + intent = inout [con_pi] standard_name = pi long_name = ratio of a circle's circumference to its diameter diff --git a/physics/GFS_rrtmgp_pre.F90 b/physics/GFS_rrtmgp_pre.F90 index dd72a6a1c..9dcc002a0 100644 --- a/physics/GFS_rrtmgp_pre.F90 +++ b/physics/GFS_rrtmgp_pre.F90 @@ -8,7 +8,8 @@ module GFS_rrtmgp_pre use machine, only: kind_phys use funcphys, only: fpvs use module_radiation_astronomy, only: coszmn - use module_radiation_gases, only: NF_VGAS, getgases, getozn + use module_radiation_gases, only: NF_VGAS, getgases + use module_ozphys, only: ty_ozphys use mo_gas_concentrations, only: ty_gas_concs use radiation_tools, only: check_error_msg,cmp_tlev use rrtmgp_lw_gas_optics, only: lw_gas_props @@ -117,25 +118,23 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, doSWrad, doLWrad, fhswr, fhl vmr_n2o, vmr_co2, tsfg, tsfa, qs_lay, q_lay, tv_lay, & relhum, deltaZ, deltaZc, deltaP, active_gases_array, & tsfc_radtime, coszen, coszdg, top_at_1, iSFC, iTOA, nDay, idxday, semis, & - sfc_emiss_byband, ico2, latsozc, levozc, blatc, dphiozc, con_pi, errmsg, errflg) + sfc_emiss_byband, ico2, ozphys, con_pi, errmsg, errflg) - ! Inputs + ! Inputs integer, intent(in) :: & me, & ! MPI rank nCol, & ! Number of horizontal grid points nLev, & ! Number of vertical layers ico2, & ! Flag for co2 radiation scheme - i_o3, & ! Index into tracer array for ozone - latsozc, & ! - levozc + i_o3 ! Index into tracer array for ozone + type(ty_ozphys),intent(in) :: & + ozphys logical, intent(in) :: & doSWrad, & ! Call SW radiation? doLWrad ! Call LW radiation real(kind_phys), intent(in) :: & fhswr, & ! Frequency of SW radiation call. - fhlwr, & ! Frequency of LW radiation call. - blatc, & ! - dphiozc + fhlwr ! Frequency of LW radiation call. real(kind_phys), intent(in) :: & con_g, & ! Physical constant: gravitational constant con_rd, & ! Physical constant: gas-constant for dry air @@ -353,9 +352,8 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, doSWrad, doLWrad, fhswr, fhl enddo enddo ! OR Use climatological ozone data - else - call getozn (prslk(1:NCOL,:), xlat, nCol, nLev, top_at_1, latsozc, levozc, blatc, & - dphiozc, o3_lay) + else + call ozphys%oz_clim(xlat, prslk, con_pi, o3_lay) endif ! ####################################################################################### diff --git a/physics/GFS_rrtmgp_pre.meta b/physics/GFS_rrtmgp_pre.meta index 1a96eee1b..4e2aa3a56 100644 --- a/physics/GFS_rrtmgp_pre.meta +++ b/physics/GFS_rrtmgp_pre.meta @@ -2,7 +2,7 @@ name = GFS_rrtmgp_pre type = scheme dependencies = funcphys.f90,iounitdef.f,machine.F,module_bfmicrophysics.f,physcons.F90,radcons.f90,radiation_aerosols.f - dependencies = radiation_astronomy.f,radiation_gases.f,radiation_tools.F90,rrtmg_lw_cloud_optics.F90 + dependencies = radiation_astronomy.f,radiation_gases.f,radiation_tools.F90,rrtmg_lw_cloud_optics.F90,module_ozphys.F90 ######################################################################## [ccpp-arg-table] @@ -503,35 +503,12 @@ dimensions = (horizontal_loop_extent) type = integer intent = inout -[latsozc] - standard_name = number_of_latitudes_in_ozone_climotology_data - long_name = number of latitude in ozone climotology data - units = count - dimensions = () - type = integer - intent = in -[levozc] - standard_name = number_of_levels_in_ozone_climotology_data - long_name = number of levels in ozone climotology data - units = count - dimensions = () - type = integer - intent = in -[dphiozc] - standard_name = ozone_data_parameter_1 - long_name = ozone data parameter 1 - units = none - dimensions = () - type = real - kind = kind_phys - intent = in -[blatc] - standard_name = ozone_data_parameter_2 - long_name = ozone data parameter 2 - units = none +[ozphys] + standard_name = dataset_for_ozone_physics + long_name = dataset for NRL ozone physics + units = mixed dimensions = () - type = real - kind = kind_phys + type = ty_ozphys intent = in [errmsg] standard_name = ccpp_error_message diff --git a/physics/GFS_rrtmgp_setup.F90 b/physics/GFS_rrtmgp_setup.F90 index 7b5479e60..3e4f57d13 100644 --- a/physics/GFS_rrtmgp_setup.F90 +++ b/physics/GFS_rrtmgp_setup.F90 @@ -6,6 +6,7 @@ module GFS_rrtmgp_setup use module_radiation_astronomy, only : sol_init, sol_update use module_radiation_aerosols, only : aer_init, aer_update use module_radiation_gases, only : gas_init, gas_update + use module_ozphys, only : ty_ozphys implicit none public GFS_rrtmgp_setup_init, GFS_rrtmgp_setup_timestep_init, GFS_rrtmgp_setup_finalize @@ -37,7 +38,7 @@ module GFS_rrtmgp_setup subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires, & imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, imp_physics_zhao_carr, & imp_physics_zhao_carr_pdf, imp_physics_mg, si, levr, ictm, isol, ico2, iaer, & - ntcw, ntoz, iovr, latsozp, levozp, timeozp, isubc_sw, isubc_lw, lalw1bd, idate, & + ntcw, ntoz, iovr, isubc_sw, isubc_lw, lalw1bd, idate, & me, aeros_file, iaermdl, iaerflg, con_pi, con_t0c, con_c, con_boltz, con_plnk, & solar_file, con_solr_2008, con_solr_2002, co2usr_file, co2cyc_file, ipsd0, & errmsg, errflg) @@ -57,8 +58,7 @@ subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires, con_pi, con_t0c, con_c, con_boltz, con_plnk, con_solr_2008, con_solr_2002 real(kind_phys), dimension(:), intent(in) :: & si - integer, intent(in) :: levr, ictm, isol, ico2, iaer, & - ntcw, ntoz, iovr, isubc_sw, isubc_lw, latsozp, levozp, timeozp, me + integer, intent(in) :: levr, ictm, isol, ico2, iaer, ntcw, ntoz, iovr, isubc_sw, isubc_lw, me logical, intent(in) :: & lalw1bd integer, intent(in), dimension(:) :: & @@ -129,8 +129,7 @@ subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires, call sol_init ( me, isol, solar_file, con_solr_2008, con_solr_2002, con_pi ) call aer_init ( levr, me, iaermdl, iaerflg, lalw1bd, aeros_file, con_pi, con_t0c, & con_c, con_boltz, con_plnk, errflg, errmsg) - call gas_init ( me, co2usr_file, co2cyc_file, ico2, ictm, ntoz, con_pi, latsozp, & - levozp, timeozp, errflg, errmsg ) + call gas_init ( me, co2usr_file, co2cyc_file, ico2, ictm, con_pi, errflg, errmsg ) if ( me == 0 ) then print *,' return from rad_initialize (GFS_rrtmgp_setup_init) - after calling radinit' @@ -149,7 +148,7 @@ end subroutine GFS_rrtmgp_setup_init !! subroutine GFS_rrtmgp_setup_timestep_init (idate, jdate, deltsw, deltim, doSWrad, me, & iaermdl, aeros_file, isol, slag, sdec, cdec, solcon, con_pi, co2dat_file, & - co2gbl_file, ictm, ico2, ntoz, errmsg, errflg) + co2gbl_file, ictm, ico2, ntoz, ozphys, errmsg, errflg) ! Inputs integer, intent(in) :: idate(:) @@ -161,7 +160,7 @@ subroutine GFS_rrtmgp_setup_timestep_init (idate, jdate, deltsw, deltim, doSWrad integer, intent(in) :: me integer, intent(in) :: iaermdl,isol,ictm,ico2,ntoz character(len=26), intent(in) :: aeros_file,co2dat_file,co2gbl_file - + type(ty_ozphys),intent(inout) :: ozphys ! Outputs real(kind_phys), intent(out) :: slag real(kind_phys), intent(out) :: sdec @@ -241,8 +240,11 @@ subroutine GFS_rrtmgp_setup_timestep_init (idate, jdate, deltsw, deltim, doSWrad else lco2_chg = .false. endif - call gas_update (kyear, kmon, kday, khour, loz1st, lco2_chg, me, co2dat_file, & - co2gbl_file, ictm, ico2, ntoz, errflg, errmsg ) + call gas_update (kyear, kmon, kday, khour, lco2_chg, me, co2dat_file, co2gbl_file, ictm,& + ico2, errflg, errmsg ) + if (ntoz == 0) then + call ozphys%update_clim(kmon, kday, khour, loz1st) + endif if ( loz1st ) loz1st = .false. diff --git a/physics/GFS_rrtmgp_setup.meta b/physics/GFS_rrtmgp_setup.meta index c8ed60650..96f7e24e7 100644 --- a/physics/GFS_rrtmgp_setup.meta +++ b/physics/GFS_rrtmgp_setup.meta @@ -2,7 +2,7 @@ name = GFS_rrtmgp_setup type = scheme dependencies = iounitdef.f,machine.F,module_bfmicrophysics.f,radiation_aerosols.f,radiation_astronomy.f - dependencies = module_mp_thompson.F90,radiation_gases.f + dependencies = module_mp_thompson.F90,radiation_gases.f,module_ozphys.F90 ######################################################################## [ccpp-arg-table] @@ -266,27 +266,6 @@ dimensions = () type = integer intent = inout -[levozp] - standard_name = number_of_levels_in_ozone_climotology_data - long_name = number of levels in ozone climotology data - units = count - dimensions = () - type = integer - intent = in -[timeozp] - standard_name = number_of_times_in_ozone_climotology_data - long_name = number of times in ozone climotology data - units = count - dimensions = () - type = integer - intent = in -[latsozp] - standard_name = number_of_latitudes_in_ozone_climotology_data - long_name = number of latitude in ozone climotology data - units = count - dimensions = () - type = integer - intent = in [iaermdl] standard_name = control_for_aerosol_radiation_scheme long_name = control of aerosol scheme in radiation @@ -410,6 +389,13 @@ dimensions = () type = integer intent = in +[ozphys] + standard_name = dataset_for_ozone_physics + long_name = dataset for NRL ozone physics + units = mixed + dimensions = () + type = ty_ozphys + intent = inout [iaermdl] standard_name = control_for_aerosol_radiation_scheme long_name = control of aerosol scheme in radiation diff --git a/physics/module_ozphys.F90 b/physics/module_ozphys.F90 new file mode 100644 index 000000000..966d27113 --- /dev/null +++ b/physics/module_ozphys.F90 @@ -0,0 +1,476 @@ +! ######################################################################################### +!> \section arg_table_module_ozphys Argument table +!! \htmlinclude module_ozphys.html +!! +! ######################################################################################### +module module_ozphys + use machine, only : kind_phys + use funcphys, only : fpkapx + implicit none + + public ty_ozphys + +! ######################################################################################### +!> \section arg_table_ty_ozphys Argument Table +!! \htmlinclude ty_ozphys.html +!! +!! All data field are ordered from surface-to-toa (j=1=isfc) +!! +! ######################################################################################### + type ty_ozphys + ! Prognostic ozone. + integer :: nlat !< Number of latitudes. + integer :: nlev !< Number of vertical layers. + integer :: ntime !< Number of times. + integer :: ncf !< Number of coefficients. + real(kind_phys), allocatable :: lat(:) !< Latitude. + real(kind_phys), allocatable :: pres(:) !< Pressure levels. + real(kind_phys), allocatable :: po3(:) !< Natural log pressure of levels. + real(kind_phys), allocatable :: time(:) !< Time. + real(kind_phys), allocatable :: data(:,:,:,:) !< Ozone forcing data (raw) + ! Climotological ozone. + integer :: nlatc !< Number of latitudes. + integer :: nlevc !< Number of vertical layers. + integer :: ntimec !< Number of times. + real(kind_phys) :: blatc !< Parameter for ozone climotology + real(kind_phys) :: dphiozc !< Parameter for ozone climotology + real(kind_phys), allocatable :: pkstr(:) !< + real(kind_phys), allocatable :: pstr(:) !< + real(kind_phys), allocatable :: datac(:,:,:) !< Ozone climotological data + integer :: k1oz !< Lower interpolation index in datac(dim=3), time dim + integer :: k2oz !< Upper interpolation index in datac(dim=3), time dim + real(kind_phys) :: facoz !< Parameter for ozone climotology + contains + procedure, public :: load_forcing + procedure, public :: load_clim + procedure, public :: setup_forcing + procedure, public :: update_forcing + procedure, public :: update_clim + procedure, public :: oz_prog_2015 + procedure, public :: oz_prog_2006 + procedure, public :: oz_clim + end type ty_ozphys + +contains + ! ######################################################################################### + ! Procedure (type-bound) for loading ozone forcing data. + ! ######################################################################################### + function load_forcing(this, file, fileID) result (err_message) + class(ty_ozphys), intent(inout) :: this + integer, intent(in) :: fileID + character(len=*), intent(in) :: file + character(len=128) :: err_message + integer :: i1, i2, i3 + real(kind=4), dimension(:), allocatable :: lat4, pres4, time4, tempin + real(kind=4) :: blatc4 + + ! Get dimensions from data file + open(unit=fileID,file=trim(file), form='unformatted', convert='big_endian') + read (fileID) this%ncf, this%nlat, this%nlev, this%ntime + rewind(fileID) + + allocate (this%lat(this%nlat)) + allocate (this%pres(this%nlev)) + allocate (this%po3(this%nlev)) + allocate (this%time(this%ntime+1)) + allocate (this%data(this%nlat,this%nlev,this%ncf,this%ntime)) + + allocate(lat4(this%nlat), pres4(this%nlev), time4(this%ntime+1)) + read (fileID) this%ncf, this%nlat, this%nlev, this%ntime, lat4, pres4, time4 + + ! Store + this%pres(:) = pres4(:) + this%po3(:) = log(100.0*this%pres(:)) ! from mb to ln(Pa) + this%lat(:) = lat4(:) + this%time(:) = time4(:) + deallocate(lat4, pres4, time4) + + allocate(tempin(this%nlat)) + do i1=1,this%ntime + do i2=1,this%ncf + do i3=1,this%nlev + read(fileID) tempin + this%data(:,i3,i2,i1) = tempin(:) + enddo + enddo + enddo + deallocate(tempin) + close(fileID) + + end function load_forcing + + ! ######################################################################################### + ! Procedure for setting up interpolation indices between data and model grid. + ! ######################################################################################### + subroutine setup_forcing(this, lat, idx1, idx2, idxh) + class(ty_ozphys), intent(in) :: this + real(kind_phys), intent(in) :: lat(:) + integer, intent(out) :: idx1(:), idx2(:) + real(kind_phys), intent(out) :: idxh(:) + integer :: i,j + + do j=1,size(lat) + idx2(j) = this%nlat + 1 + do i=1,this%nlat + if (lat(j) < this%lat(i)) then + idx2(j) = i + exit + endif + enddo + idx1(j) = max(idx2(j)-1,1) + idx2(j) = min(idx2(j),this%nlat) + if (idx2(j) .ne. idx1(j)) then + idxh(j) = (lat(j) - this%lat(idx1(j))) / (this%lat(idx2(j)) - this%lat(idx1(j))) + else + idxh(j) = 1.0 + endif + enddo + + end subroutine setup_forcing + + ! ######################################################################################### + ! Procedure (type-bound) for updating ozone data. + ! ######################################################################################### + subroutine update_forcing(this, idx1, idx2, idxh, rjday, idxt1, idxt2, ozpl) + class(ty_ozphys), intent(in) :: this + integer, intent(in) :: idx1(:), idx2(:) + real(kind_phys), intent(in) :: idxh(:) + real(kind_phys), intent(in) :: rjday + integer, intent(in) :: idxt1, idxt2 + real(kind_phys), intent(out) :: ozpl(:,:,:) + integer :: nc, l, j, j1, j2 + real(kind_phys) :: tem, tx1, tx2 + + tx1 = (this%time(idxt2) - rjday) / (this%time(idxt2) - this%time(idxt1)) + tx2 = 1.0 - tx1 + + do nc=1,this%ncf + do l=1,this%nlev + do j=1,size(ozpl(:,1,1)) + j1 = idx1(j) + j2 = idx2(j) + tem = 1.0 - idxh(j) + ozpl(j,l,nc) = tx1*(tem*this%data(j1,l,nc,idxt1)+idxh(j)*this%data(j2,l,nc,idxt1)) & + + tx2*(tem*this%data(j1,l,nc,idxt2)+idxh(j)*this%data(j2,l,nc,idxt2)) + enddo + enddo + enddo + + end subroutine update_forcing + + ! ######################################################################################### + ! Procedure (type-bound) for NRL prognostic ozone (2015). + ! ######################################################################################### + subroutine oz_prog_2015(this, con_1ovg, dt, p, t, dp, ozpl, oz, do3_dt_prd, do3_dt_ozmx, & + do3_dt_temp, do3_dt_ohoz) + class(ty_ozphys), intent(in) :: this + real(kind_phys),intent(in) :: & + con_1ovg ! Physical constant: One divided by gravitational acceleration (m-1 s2) + real(kind_phys), intent(in) :: & + dt ! Model timestep (sec) + real(kind_phys), intent(in), dimension(:,:) :: & + p, & ! Model Pressure (Pa) + t, & ! Model temperature (K) + dp ! Model layer thickness (Pa) + real(kind_phys), intent(in), dimension(:,:,:) :: & + ozpl ! Ozone forcing data + real(kind_phys), intent(inout), dimension(:,:) :: & + oz ! Ozone concentration updated by physics + real(kind_phys), intent(inout), dimension(:,:), pointer, optional :: & + do3_dt_prd, & ! Physics tendency: production and loss effect + do3_dt_ozmx, & ! Physics tendency: ozone mixing ratio effect + do3_dt_temp, & ! Physics tendency: temperature effect + do3_dt_ohoz ! Physics tendency: overhead ozone effect + + integer :: k, kmax, kmin, iLev, iCol, nCol, nLev, iCf + logical, dimension(size(p,1)) :: flg + real(kind_phys) :: pmax, pmin, tem, temp + real(kind_phys), dimension(size(p,1)) :: wk1, wk2, wk3, ozib + real(kind_phys), dimension(size(p,1),this%ncf) :: prod + real(kind_phys), dimension(size(p,1),size(p,2)) :: ozi + real(kind_phys), dimension(size(p,1),size(p,2)+1) :: colo3, coloz + + ! Dimensions + nCol = size(p,1) + nLev = size(p,2) + + ! Temporaries + ozi = oz + + colo3(:,nLev+1) = 0.0 + coloz(:,nLev+1) = 0.0 + + do iLev=nLev,1,-1 + pmin = 1.0e10 + pmax = -1.0e10 + + do iCol=1,nCol + wk1(iCol) = log(p(iCol,iLev)) + pmin = min(wk1(iCol), pmin) + pmax = max(wk1(iCol), pmax) + prod(iCol,:) = 0._kind_phys + enddo + kmax = 1 + kmin = 1 + do k=1,this%nlev-1 + if (pmin < this%po3(k)) kmax = k + if (pmax < this%po3(k)) kmin = k + enddo + ! + do k=kmin,kmax + temp = 1.0 / (this%po3(k) - this%po3(k+1)) + do iCol=1,nCol + flg(iCol) = .false. + if (wk1(iCol) < this%po3(k) .and. wk1(iCol) >= this%po3(k+1)) then + flg(iCol) = .true. + wk2(iCol) = (wk1(iCol) - this%po3(k+1)) * temp + wk3(iCol) = 1.0 - wk2(iCol) + endif + enddo + do iCf=1,this%ncf + do iCol=1,nCol + if (flg(iCol)) then + prod(iCol,iCf) = wk2(iCol) * ozpl(iCol,k,iCf) + wk3(iCol) * ozpl(iCol,k+1,iCf) + endif + enddo + enddo + enddo + + do iCf=1,this%ncf + do iCol=1,nCol + if (wk1(iCol) < this%po3(this%nlev)) then + prod(iCol,iCf) = ozpl(iCol,this%nlev,iCf) + endif + if (wk1(iCol) >= this%po3(1)) then + prod(iCol,iCf) = ozpl(iCol,1,iCf) + endif + enddo + enddo + do iCol=1,nCol + colo3(iCol,iLev) = colo3(iCol,iLev+1) + ozi(iCol,iLev) * dp(iCol,iLev)*con_1ovg + coloz(iCol,iLev) = coloz(iCol,iLev+1) + prod(iCol,6) * dp(iCol,iLev)*con_1ovg + prod(iCol,2) = min(prod(iCol,2), 0.0) + enddo + do iCol=1,nCol + ozib(iCol) = ozi(iCol,iLev) ! no filling + tem = prod(iCol,1) - prod(iCol,2) * prod(iCol,6) & + + prod(iCol,3) * (t(iCol,iLev) - prod(iCol,5)) & + + prod(iCol,4) * (colo3(iCol,iLev)-coloz(iCol,iLev)) + oz(iCol,iLev) = (ozib(iCol) + tem*dt) / (1.0 - prod(iCol,2)*dt) + enddo + + ! Diagnostics (optional) + if (associated(do3_dt_prd)) do3_dt_prd(:,iLev) = (prod(:,1)-prod(:,2)*prod(:,6))*dt + if (associated(do3_dt_ozmx)) do3_dt_ozmx(:,iLev) = (oz(:,iLev) - ozib(:)) + if (associated(do3_dt_temp)) do3_dt_temp(:,iLev) = prod(:,3)*(t(:,iLev)-prod(:,5))*dt + if (associated(do3_dt_ohoz)) do3_dt_ohoz(:,iLev) = prod(:,4) * (colo3(:,iLev)-coloz(:,iLev))*dt + enddo + + return + end subroutine oz_prog_2015 + + ! ######################################################################################### + ! Procedure (type-bound) for NRL prognostic ozone (2006). + ! ######################################################################################### + subroutine oz_prog_2006(this) + class(ty_ozphys), intent(in) :: this + return + end subroutine oz_prog_2006 + + ! ######################################################################################### + ! Procedure (type-bound) for NRL updating climotological ozone. + ! Build this up from getozn. + ! ######################################################################################### + subroutine oz_clim(this, lat, prslk, con_pi, oz) + class(ty_ozphys), intent(in) :: this + real(kind_phys), intent(in) :: & + con_pi ! Physics constant: Pi + real(kind_phys), intent(in), dimension(:) :: & + lat ! Grid latitude + real(kind_phys), intent(in), dimension(:,:) :: & + prslk ! Exner function + real(kind_phys), intent(out), dimension(:,:) :: & + oz ! Ozone concentration updated by climotology + + integer :: nCol, iCol, nLev, iLev, j, j1, j2, l, ll + real(kind_phys) :: elte, deglat, tem, tem1, tem2, tem3, tem4, temp + real(kind_phys), allocatable :: o3i(:,:),wk1(:) + logical :: top_at_1 + + nCol = size(prslk(:,1)) + nLev = size(prslk(1,:)) + allocate(o3i(nCol, this%nlevc),wk1(nCol)) + + ! What is vertical ordering? + top_at_1 = (prslk(1,1) .lt. prslk(1, nLev)) + + elte = this%blatc + (this%nlatc-1)*this%dphiozc + + do iCol = 1, nCol + deglat = lat(iCol) * 180.0 / con_pi + if (deglat > this%blatc .and. deglat < elte) then + tem1 = (deglat - this%blatc) / this%dphiozc + 1 + j1 = tem1 + j2 = j1 + 1 + tem1 = tem1 - j1 + elseif (deglat <= this%blatc) then + j1 = 1 + j2 = 1 + tem1 = 1.0 + elseif (deglat >= elte) then + j1 = this%nlatc + j2 = this%nlatc + tem1 = 1.0 + endif + + tem2 = 1.0 - tem1 + do j = 1, this%nlevc + tem3 = tem2*this%datac(j1,j,this%k1oz) + tem1*this%datac(j2,j,this%k1oz) + tem4 = tem2*this%datac(j1,j,this%k2oz) + tem1*this%datac(j2,j,this%k2oz) + o3i(iCol,j) = tem4*this%facoz + tem3*(1.0 - this%facoz) + enddo + enddo + + do iLev = 1, nLev + ll = iLev + if (.not. top_at_1) ll = nLev - iLev + 1 + + do iCol = 1, nCol + wk1(iCol) = prslk(iCol,ll) + enddo + + do j = 1, this%nlevc-1 + temp = 1.0 / (this%pkstr(j+1) - this%pkstr(j)) + do iCol = 1, nCol + if (wk1(iCol) > this%pkstr(j) .and. wk1(iCol) <= this%pkstr(j+1)) then + tem = (this%pkstr(j+1) - wk1(iCol)) * temp + oz(iCol,ll) = tem * o3i(iCol,j) + (1.0 - tem) * o3i(iCol,j+1) + endif + enddo + enddo + + do iCol = 1, nCol + if (wk1(iCol) > this%pkstr(this%nlevc)) oz(iCol,ll) = o3i(iCol,this%nlevc) + if (wk1(iCol) < this%pkstr(1)) oz(iCol,ll) = o3i(iCol,1) + enddo + enddo + + return + end subroutine oz_clim + + ! ######################################################################################### + ! Procedure (type-bound) for loading ozone climo data. + ! ######################################################################################### + function load_clim(this, file, fileID) result (err_message) + class(ty_ozphys), intent(inout) :: this + integer, intent(in) :: fileID + character(len=*), intent(in) :: file + character(len=128) :: err_message + + ! Locals + real(kind=4) :: blatc4 + integer :: iLev, iLat, imo + real(kind=4), allocatable :: o3clim4(:,:,:), pstr4(:) + integer, allocatable :: imond(:), ilatt(:,:) + + open(unit=fileID,file=trim(file), form='unformatted', convert='big_endian') + read (fileID,end=101) this%nlatc, this%nlevc, this%ntimec, blatc4 +101 if (this%nlevc < 10 .or. this%nlevc > 100) then + rewind (fileID) + this%nlevc = 17 + this%nlatc = 18 + this%blatc = -85.0 + else + this%blatc = blatc4 + endif + this%nlat = 2 + this%nlev = 1 + this%ntimec = 1 + this%ncf = 0 + this%dphiozc = -(this%blatc+this%blatc)/(this%nlatc-1) + + allocate (o3clim4(this%nlatc,this%nlevc,12), pstr4(this%nlevc), imond(12), ilatt(this%nlatc,12) ) + + allocate (this%pkstr(this%nlevc), this%pstr(this%nlevc), this%datac(this%nlatc,this%nlevc,12)) + if ( this%nlevc == 17 ) then ! For the operational ozone climatology + do iLev = 1, this%nlevc + read (fileID,15) pstr4(iLev) +15 format(f10.3) + enddo + + do imo = 1, 12 + do iLat = 1, this%nlatc + read (fileID,16) imond(imo), ilatt(iLat,imo), (o3clim4(iLat,iLev,imo),iLev=1,10) +16 format(i2,i4,10f6.2) + read (fileID,20) (o3clim4(iLat,iLev,imo),iLev=11,this%nlevc) +20 format(6x,10f6.2) + enddo + enddo + else ! For newer ozone climatology + read (fileID) + do iLev = 1, this%nlevc + read (fileID) pstr4(iLev) + enddo + + do imo = 1, 12 + do iLev = 1, this%nlevc + read (fileID) (o3clim4(iLat,iLev,imo),iLat=1,this%nlatc) + enddo + enddo + endif ! end if_this%nlevc_block + + do imo = 1, 12 + do iLev = 1, this%nlevc + do iLat = 1, this%nlatc + this%datac(iLat,iLev,imo) = o3clim4(iLat,iLev,imo) * 1.655e-6 + enddo + enddo + enddo + + do iLev = 1, this%nlevc + this%pstr(iLev) = pstr4(iLev) + this%pkstr(iLev) = fpkapx(this%pstr(iLev)*100.0) + enddo + + end function load_clim + + ! ######################################################################################### + ! Procedure (type-bound) for updating ozone climotological data. + ! ######################################################################################### + subroutine update_clim(this, imon, iday, ihour, loz1st) + class(ty_ozphys), intent(inout) :: this + integer, intent(in) :: imon, iday, ihour + logical, intent(in) :: loz1st + + integer :: midmon=15, midm=15, midp=45, id + integer, parameter, dimension(13) :: mdays = (/31,28,31,30,31,30,31,31,30,31,30,31,30/) + logical :: change + + midmon = mdays(imon)/2 + 1 + change = loz1st .or. ( (iday==midmon) .and. (ihour==0) ) + + if ( change ) then + if ( iday < midmon ) then + this%k1oz = mod(imon+10, 12) + 1 + midm = mdays(this%k1oz)/2 + 1 + this%k2oz = imon + midp = mdays(this%k1oz) + midmon + else + this%k1oz = imon + midm = midmon + this%k2oz = mod(imon, 12) + 1 + midp = mdays(this%k2oz)/2 + 1 + mdays(this%k1oz) + endif + endif + + if (iday < midmon) then + id = iday + mdays(this%k1oz) + else + id = iday + endif + + this%facoz = float(id - midm) / float(midp - midm) + + end subroutine update_clim + +end module module_ozphys diff --git a/physics/module_ozphys.meta b/physics/module_ozphys.meta new file mode 100644 index 000000000..2922d16d7 --- /dev/null +++ b/physics/module_ozphys.meta @@ -0,0 +1,24 @@ +[ccpp-table-properties] + name = ty_ozphys + type = ddt + dependencies = + +[ccpp-arg-table] + name = ty_ozphys + type = ddt + +######################################################################## +[ccpp-table-properties] + name = module_ozphys + type = module + dependencies = machine.F,funcphys.f90 + +[ccpp-arg-table] + name = module_ozphys + type = module +[ty_ozphys] + standard_name = ty_ozphys + long_name = definition of type ty_ozphys + units = DDT + dimensions = () + type = ty_ozphys \ No newline at end of file diff --git a/physics/ozphys_2015.F90 b/physics/ozphys_2015.F90 index 47386bd6e..1478d0d6e 100644 --- a/physics/ozphys_2015.F90 +++ b/physics/ozphys_2015.F90 @@ -3,89 +3,57 @@ !! ! ########################################################################################### module ozphys_2015 - use machine, only : kind_phys, kind_dbl_prec, kind_sngl_prec + use machine, only: kind_phys, kind_dbl_prec, kind_sngl_prec + use module_ozphys, only: ty_ozphys implicit none - public ozphys_2015_init, ozphys_2015_run + public ozphys_2015_run contains ! ########################################################################################### !>\defgroup GFS_ozphys_2015 GFS Ozone Photochemistry (2015) Module !! This module contains the CCPP-compliant Ozone 2015 photochemistry scheme. !> @{ -!> The operational GFS currently parameterizes ozone production and -!! destruction based on monthly mean coefficients ( -!! \c ozprdlos_2015_new_sbuvO3_tclm15_nuchem.f77) provided by Naval -!! Research Laboratory through CHEM2D chemistry model +!> The operational GFS currently parameterizes ozone production and destruction based on +!! monthly mean coefficients ( \c ozprdlos_2015_new_sbuvO3_tclm15_nuchem.f77) provided by +!! Naval Research Laboratory through CHEM2D chemistry model !! (McCormack et al. (2006) \cite mccormack_et_al_2006). !! (https://doi.org/10.5194/acp-6-4943-2006) !! !> \section genal_ozphys_2015 GFS ozphys_2015_run General Algorithm -!> - This code assumes that both prsl and po3 are from bottom to top -!! as are all other variables. -!> - This code is specifically for NRL parameterization and -!! climatological T and O3 are in location 5 and 6 of oz_data array +!> - This code assumes that both 2D fields are ordered from bottom to top. +!> - This code is specifically for NRL parameterization and climatological T and O3 are in +! location 5 and 6 of ozpl array !!\author June 2015 - Shrinivas Moorthi !!\modified May 2023 - Dustin Swales ! ########################################################################################### -! ########################################################################################### -! SUBROUTINE ozphys_2015_init -! ########################################################################################### -!! \section arg_table_ozphys_2015_init Argument Table -!! \htmlinclude ozphys_2015_init.html -!! - subroutine ozphys_2015_init(oz_phys, errmsg, errflg) - ! Inputs - logical, intent(in) :: & - oz_phys - ! Outputs - character(len=*), intent(out) :: & - errmsg - integer, intent(out) :: & - errflg - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - ! Sanity check - if (.not.oz_phys) then - write (errmsg,'(*(a))') 'Logic error: oz_phys_2015 == .false.' - errflg = 1 - return - endif - - end subroutine ozphys_2015_init - ! ########################################################################################### ! SUBROUTINE ozphys_2015_run ! ########################################################################################### !! \section arg_table_ozphys_2015_run Argument Table !! \htmlinclude ozphys_2015_run.html !! - subroutine ozphys_2015_run (oz_phys, im, levs, ko3, dt, oz, tin, po3, prsl, oz_data, & - pl_coeff, delp, con_1ovg, do3_dt_prd, do3_dt_ozmx, do3_dt_temp, do3_dt_ohoz, errmsg, errflg) + subroutine ozphys_2015_run (oz_phys, ozphys, nCol, nLev, dt, oz, tin, prsl, ozpl, & + delp, con_1ovg, do3_dt_prd, do3_dt_ozmx, do3_dt_temp, do3_dt_ohoz, errmsg, errflg) ! Inputs logical, intent(in) :: & oz_phys ! Flag for ozone_physics_2015 scheme. + type(ty_ozphys),intent(in) :: & + ozphys real(kind_phys),intent(in) :: & con_1ovg ! Physical constant: One divided by gravitational acceleration (m-1 s2) integer, intent(in) :: & - im, & ! Horizontal dimension - levs, & ! Number of vertical layers - ko3, & ! Number of vertical layers in ozone forcing data - pl_coeff ! Number of coefficients in ozone forcing data + nCol, & ! Horizontal dimension + nLev ! Number of vertical layers real(kind_phys), intent(in) :: & dt ! Physics timestep (seconds) - real(kind_phys), intent(in), dimension(:) :: & - po3 ! Natural log of ozone forcing data pressure levels real(kind_phys), intent(in), dimension(:,:) :: & prsl, & ! Air-pressure (Pa) tin, & ! Temperature of new-state (K) delp ! Difference between mid-layer pressures (Pa) real(kind_phys), intent(in), dimension(:,:,:) :: & - oz_data ! Ozone forcing data + ozpl ! Ozone forcing data ! Outputs (optional) real(kind=kind_phys), intent(inout), dimension(:,:), pointer, optional :: & @@ -96,26 +64,26 @@ subroutine ozphys_2015_run (oz_phys, im, levs, ko3, dt, oz, tin, po3, prsl, oz_d ! Outputs real(kind=kind_phys), intent(inout), dimension(:,:) :: & - oz ! Ozone concentration updated by physics + oz ! Ozone concentration updated by physics character(len=*), intent(out) :: & - errmsg ! CCPP error message + errmsg ! CCPP error message integer, intent(out) :: & - errflg ! CCPP error flag + errflg ! CCPP error flag ! Locals integer :: k, kmax, kmin, l, i, j - logical, dimension(im) :: flg + logical, dimension(nCol) :: flg real(kind_phys) :: pmax, pmin, tem, temp - real(kind_phys), dimension(im) :: wk1, wk2, wk3, ozib - real(kind_phys), dimension(im,pl_coeff) :: prod - real(kind_phys), dimension(im,levs) :: ozi - real(kind_phys), dimension(im,levs+1) :: colo3, coloz + real(kind_phys), dimension(nCol) :: wk1, wk2, wk3, ozib + real(kind_phys), dimension(nCol,ozphys%ncf) :: prod + real(kind_phys), dimension(nCol,nLev) :: ozi + real(kind_phys), dimension(nCol,nLev+1) :: colo3, coloz ! Initialize CCPP error handling variables errmsg = '' errflg = 0 - ! Sanity checkt + ! Sanity checks if (.not.oz_phys) then write (errmsg,'(*(a))') 'Logic error: oz_phys_2015 == .false.' errflg = 1 @@ -125,14 +93,14 @@ subroutine ozphys_2015_run (oz_phys, im, levs, ko3, dt, oz, tin, po3, prsl, oz_d ! Temporaries ozi = oz - colo3(:,levs+1) = 0.0 - coloz(:,levs+1) = 0.0 + colo3(:,nLev+1) = 0.0 + coloz(:,nLev+1) = 0.0 - do l=levs,1,-1 + do l=nLev,1,-1 pmin = 1.0e10 pmax = -1.0e10 - do i=1,im + do i=1,nCol wk1(i) = log(prsl(i,l)) pmin = min(wk1(i), pmin) pmax = max(wk1(i), pmax) @@ -140,46 +108,46 @@ subroutine ozphys_2015_run (oz_phys, im, levs, ko3, dt, oz, tin, po3, prsl, oz_d enddo kmax = 1 kmin = 1 - do k=1,ko3-1 - if (pmin < po3(k)) kmax = k - if (pmax < po3(k)) kmin = k + do k=1,ozphys%nlev-1 + if (pmin < ozphys%po3(k)) kmax = k + if (pmax < ozphys%po3(k)) kmin = k enddo ! do k=kmin,kmax - temp = 1.0 / (po3(k) - po3(k+1)) - do i=1,im + temp = 1.0 / (ozphys%po3(k) - ozphys%po3(k+1)) + do i=1,nCol flg(i) = .false. - if (wk1(i) < po3(k) .and. wk1(i) >= po3(k+1)) then + if (wk1(i) < ozphys%po3(k) .and. wk1(i) >= ozphys%po3(k+1)) then flg(i) = .true. - wk2(i) = (wk1(i) - po3(k+1)) * temp + wk2(i) = (wk1(i) - ozphys%po3(k+1)) * temp wk3(i) = 1.0 - wk2(i) endif enddo - do j=1,pl_coeff - do i=1,im + do j=1,ozphys%ncf + do i=1,nCol if (flg(i)) then - prod(i,j) = wk2(i) * oz_data(i,k,j) + wk3(i) * oz_data(i,k+1,j) + prod(i,j) = wk2(i) * ozpl(i,k,j) + wk3(i) * ozpl(i,k+1,j) endif enddo enddo enddo - do j=1,pl_coeff - do i=1,im - if (wk1(i) < po3(ko3)) then - prod(i,j) = oz_data(i,ko3,j) + do j=1,ozphys%ncf + do i=1,nCol + if (wk1(i) < ozphys%po3(ozphys%nlev)) then + prod(i,j) = ozpl(i,ozphys%nlev,j) endif - if (wk1(i) >= po3(1)) then - prod(i,j) = oz_data(i,1,j) + if (wk1(i) >= ozphys%po3(1)) then + prod(i,j) = ozpl(i,1,j) endif enddo enddo - do i=1,im + do i=1,nCol colo3(i,l) = colo3(i,l+1) + ozi(i,l) * delp(i,l)*con_1ovg coloz(i,l) = coloz(i,l+1) + prod(i,6) * delp(i,l)*con_1ovg prod(i,2) = min(prod(i,2), 0.0) enddo - do i=1,im + do i=1,nCol ozib(i) = ozi(i,l) ! no filling tem = prod(i,1) - prod(i,2) * prod(i,6) + prod(i,3) * (tin(i,l) - prod(i,5)) & + prod(i,4) * (colo3(i,l)-coloz(i,l)) diff --git a/physics/ozphys_2015.meta b/physics/ozphys_2015.meta index 1d8fba74e..ca2d56e4e 100644 --- a/physics/ozphys_2015.meta +++ b/physics/ozphys_2015.meta @@ -1,11 +1,11 @@ [ccpp-table-properties] name = ozphys_2015 type = scheme - dependencies = machine.F + dependencies = machine.F,module_ozphys.F90 ######################################################################## [ccpp-arg-table] - name = ozphys_2015_init + name = ozphys_2015_run type = scheme [oz_phys] standard_name = flag_for_nrl_2015_ozone_scheme @@ -14,54 +14,27 @@ dimensions = () type = logical intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - -######################################################################## -[ccpp-arg-table] - name = ozphys_2015_run - type = scheme -[oz_phys] - standard_name = flag_for_nrl_2015_ozone_scheme - long_name = flag for new (2015) ozone physics - units = flag +[ozphys] + standard_name = dataset_for_ozone_physics + long_name = dataset for NRL ozone physics + units = mixed dimensions = () - type = logical + type = ty_ozphys intent = in -[im] +[nCol] standard_name = horizontal_loop_extent long_name = horizontal loop extent units = count dimensions = () type = integer intent = in -[levs] +[nLev] standard_name = vertical_layer_dimension long_name = number of vertical layers units = count dimensions = () type = integer intent = in -[ko3] - standard_name = number_of_levels_in_ozone_data - long_name = number of vertical layers in ozone forcing data - units = count - dimensions = () - type = integer - intent = in [dt] standard_name = timestep_for_physics long_name = physics time step @@ -86,14 +59,6 @@ type = real kind = kind_phys intent = in -[po3] - standard_name = natural_log_of_ozone_data_pressure_levels - long_name = natural log of ozone forcing data pressure levels - units = 1 - dimensions = (number_of_levels_in_ozone_data) - type = real - kind = kind_phys - intent = in [prsl] standard_name = air_pressure long_name = mid-layer pressure @@ -102,7 +67,7 @@ type = real kind = kind_phys intent = in -[oz_data] +[ozpl] standard_name = ozone_forcing long_name = ozone forcing data units = mixed @@ -110,13 +75,6 @@ type = real kind = kind_phys intent = in -[pl_coeff] - standard_name = number_of_coefficients_in_ozone_data - long_name = number of coefficients in ozone forcing data - units = count - dimensions = () - type = integer - intent = in [delp] standard_name = air_pressure_difference_between_midlayers long_name = difference between mid-layer pressures diff --git a/physics/ozphys_time_vary.F90 b/physics/ozphys_time_vary.F90 deleted file mode 100644 index ddac1dcd4..000000000 --- a/physics/ozphys_time_vary.F90 +++ /dev/null @@ -1,165 +0,0 @@ -! ########################################################################################### -!> \file ozphys_time_vary.F90 -!! -! ########################################################################################### -module ozphys_time_vary - use machine, only : kind_phys, kind_dbl_prec, kind_sngl_prec - implicit none - public ozphys_time_vary_init, ozphys_time_vary_timestep_init -contains - -! ########################################################################################### -!>\defgroup GFS Ozone Data Module -!! This module updates the ozone data used by physics. -!> @{ -!> \section arg_table_ozphys_time_vary_init Argument Table -!! \htmlinclude ozphys_time_vary_init.html -!! -! ########################################################################################### - subroutine ozphys_time_vary_init(nPts, latsozp, oz_lat, dlat, jindx1, jindx2, ddy, & - errmsg, errflg) - ! Inputs - integer, intent(in) :: & - nPts, & ! Horizontal dimension - latsozp ! Number of latitudes in ozone data - real(kind_phys), intent(in), dimension(:) :: & - oz_lat, & ! Latitudes of ozone data - dlat ! Latitudes of grid - ! Outputs - integer, intent(inout), dimension(:) :: & - jindx1, & ! Interpolation index (low) for ozone data - jindx2 ! Interpolation index (high) for ozone data - real(kind_phys), intent(inout), dimension(:) :: & - ddy ! Interpolation high index for ozone data - character(len=*), intent(out) :: & - errmsg ! CCPP error message - integer, intent(out) :: & - errflg ! CCPP error flag - - ! Local - integer i,j - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - ! Set indices - do j=1,nPts - jindx2(j) = latsozp + 1 - do i=1,latsozp - if (dlat(j) < oz_lat(i)) then - jindx2(j) = i - exit - endif - enddo - jindx1(j) = max(jindx2(j)-1,1) - jindx2(j) = min(jindx2(j),latsozp) - if (jindx2(j) .ne. jindx1(j)) then - ddy(j) = (dlat(j) - oz_lat(jindx1(j))) / (oz_lat(jindx2(j)) - oz_lat(jindx1(j))) - else - ddy(j) = 1.0 - endif - enddo - - end subroutine ozphys_time_vary_init - -! ########################################################################################### -!> \section arg_table_ozphys_time_vary_timestep_init Argument Table -!! \htmlinclude ozphys_time_vary_timestep_init.html -!! -! ########################################################################################### - subroutine ozphys_time_vary_timestep_init(nPts, idate, fhour, jindx1, jindx2, latsozp, & - levozp, oz_coeff, timeoz, ozplin, oz_time, oz_lat, ddy, oz_data, errmsg, errflg) - ! Inputs - integer, intent(in) :: & - nPts, & ! Horizontal dimension - latsozp, & ! Number of latitudes in ozone data - levozp, & ! Number of vertical layers in ozone data - oz_coeff, & ! Number of coefficients in ozone data - timeoz ! Number of times in ozone data - integer, intent(in),dimension(:) :: & - idate, & ! Initial date with different size and ordering - jindx1, & ! Interpolation index (low) for ozone - jindx2 ! Interpolation index (high) for ozone - real(kind_phys), intent(in) :: & - fhour ! Forecast hour - real(kind_phys), intent(in), dimension(:) :: & - ddy, & ! Interpolation high index for ozone data - oz_lat, & ! Latitudes for ozone data - oz_time ! Time for ozone data - real(kind_phys), intent(in), dimension(:,:,:,:) :: & - ozplin ! Ozone data - - ! Outputs - real(kind_phys), intent(inout), dimension(:,:,:) :: & - oz_data ! Ozone forcing data - character(len=*), intent(out) :: & - errmsg ! CCPP error message - integer, intent(out) :: & - errflg ! CCPP error flag - - ! Local - integer :: idat(8),jdat(8),iday,j,j1,j2,l,nc,n1,n2,jdow,jdoy,& - jday,w3kindreal,w3kindint - real(kind_phys) :: tem, tx1, tx2, rjday - real(kind_dbl_prec) :: rinc(5) - real(kind_sngl_prec) :: rinc4(5) - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - ! - idat=0 - idat(1)=idate(4) - idat(2)=idate(2) - idat(3)=idate(3) - idat(5)=idate(1) - rinc=0. - rinc(2)=fhour - call w3kind(w3kindreal,w3kindint) - if(w3kindreal==4) then - rinc4=rinc - CALL w3movdat(rinc4,idat,jdat) - else - CALL w3movdat(rinc,idat,jdat) - endif - ! - jdow = 0 - jdoy = 0 - jday = 0 - call w3doxdat(jdat,jdow,jdoy,jday) - rjday = jdoy + jdat(5) / 24. - IF (RJDAY < oz_time(1)) RJDAY = RJDAY + 365. - ! - n2 = timeoz + 1 - do j=2,timeoz - if (rjday < oz_time(j)) then - n2 = j - exit - endif - enddo - n1 = n2 - 1 - - tx1 = (oz_time(n2) - rjday) / (oz_time(n2) - oz_time(n1)) - tx2 = 1.0 - tx1 - - if (n2 > timeoz) n2 = n2 - timeoz - ! - do nc=1,oz_coeff - do L=1,levozp - do J=1,npts - J1 = jindx1(J) - J2 = jindx2(J) - TEM = 1.0 - ddy(J) - oz_data(j,L,nc) = tx1*(TEM*ozplin(J1,L,nc,n1)+ddy(J)*ozplin(J2,L,nc,n1)) & - + tx2*(TEM*ozplin(J1,L,nc,n2)+ddy(J)*ozplin(J2,L,nc,n2)) - enddo - enddo - enddo - - return - - end subroutine ozphys_time_vary_timestep_init -!> @} -end module ozphys_time_vary diff --git a/physics/ozphys_time_vary.meta b/physics/ozphys_time_vary.meta deleted file mode 100644 index 75b8b8e4f..000000000 --- a/physics/ozphys_time_vary.meta +++ /dev/null @@ -1,200 +0,0 @@ -[ccpp-table-properties] - name = ozphys_time_vary - type = scheme - dependencies = machine.F - -######################################################################## -[ccpp-arg-table] - name = ozphys_time_vary_init - type = scheme -[nPts] - standard_name = horizontal_dimension - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in -[latsozp] - standard_name = number_of_latitudes_in_ozone_data - long_name = number of latitude in ozone data - units = count - dimensions = () - type = integer - intent = in -[oz_lat] - standard_name = ozone_data_latitude - long_name = ozone data latitude - units = deg - dimensions = (number_of_latitudes_in_ozone_data) - type = real - kind = kind_phys - intent = in -[dlat] - standard_name = latitude_in_degree - long_name = latitude in degree north - units = degree_north - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in -[jindx1] - standard_name = lower_latitude_index_of_ozone_forcing_for_interpolation - long_name = interpolation low index for ozone - units = index - dimensions = (horizontal_dimension) - type = integer - intent = inout -[jindx2] - standard_name = upper_latitude_index_of_ozone_forcing_for_interpolation - long_name = interpolation high index for ozone - units = index - dimensions = (horizontal_dimension) - type = integer - intent = inout -[ddy] - standard_name = latitude_interpolation_weight_for_ozone_forcing - long_name = interpolation high index for ozone - units = none - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = inout -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - -######################################################################## -[ccpp-arg-table] - name = ozphys_time_vary_timestep_init - type = scheme -[nPts] - standard_name = horizontal_dimension - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in -[idate] - standard_name = date_and_time_at_model_initialization_in_united_states_order - long_name = initial date with different size and ordering - units = none - dimensions = (4) - type = integer - intent = in -[fhour] - standard_name = forecast_time - long_name = current forecast time - units = h - dimensions = () - type = real - kind = kind_phys - intent = in -[jindx1] - standard_name = lower_latitude_index_of_ozone_forcing_for_interpolation - long_name = interpolation low index for ozone - units = index - dimensions = (horizontal_dimension) - type = integer - intent = in -[jindx2] - standard_name = upper_latitude_index_of_ozone_forcing_for_interpolation - long_name = interpolation high index for ozone - units = index - dimensions = (horizontal_dimension) - type = integer - intent = in -[latsozp] - standard_name = number_of_latitudes_in_ozone_data - long_name = number of latitude in ozone data - units = count - dimensions = () - type = integer - intent = in -[levozp] - standard_name = number_of_levels_in_ozone_data - long_name = number of levels in ozone data - units = count - dimensions = () - type = integer - intent = in -[oz_coeff] - standard_name = number_of_coefficients_in_ozone_data - long_name = number of coefficients in ozone data - units = count - dimensions = () - type = integer - intent = in -[timeoz] - standard_name = number_of_times_in_ozone_data - long_name = number of times in ozone data - units = count - dimensions = () - type = integer - intent = in -[ozplin] - standard_name = ozone_data - long_name = ozone data - units = 1 - dimensions = (number_of_latitudes_in_ozone_data,number_of_levels_in_ozone_data,number_of_coefficients_in_ozone_data,number_of_times_in_ozone_data) - type = real - kind = kind_phys - intent = in -[oz_time] - standard_name = ozone_data_time - long_name = ozone data time - units = none - dimensions = (13) - type = real - kind = kind_phys - intent = in -[oz_lat] - standard_name = ozone_data_latitude - long_name = ozone data latitude - units = deg - dimensions = (number_of_latitudes_in_ozone_data) - type = real - kind = kind_phys - intent = in -[ddy] - standard_name = latitude_interpolation_weight_for_ozone_forcing - long_name = interpolation high index for ozone - units = none - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in -[oz_data] - standard_name = ozone_forcing - long_name = ozone forcing data - units = mixed - dimensions = (horizontal_dimension,number_of_levels_in_ozone_data,number_of_coefficients_in_ozone_data) - type = real - kind = kind_phys - intent = inout -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out diff --git a/physics/radiation_gases.f b/physics/radiation_gases.f index 5f017598f..4c626b348 100644 --- a/physics/radiation_gases.f +++ b/physics/radiation_gases.f @@ -1,17 +1,14 @@ !> \file radiation_gases.f -!! This file contains routines that set up ozone climatological -!! profiles and other constant gas profiles, such as co2, ch4, n2o, -!! o2, and those of cfc gases. All data are entered as mixing ratio -!! by volume, except ozone which is mass mixing ratio (g/g). +!! This file contains routines that set up gas profiles, such as co2, +!! ch4, n2o, o2, and those of cfc gases. All data are entered as mixing +!! ratio by volume ! ========================================================== !!!!! ! 'module_radiation_gases' description !!!!! ! ========================================================== !!!!! ! ! -! set up ozone climatological profiles and other constant gas ! -! profiles, such as co2, ch4, n2o, o2, and those of cfc gases. All ! -! data are entered as mixing ratio by volume, except ozone which is ! -! mass mixing ratio (g/g). ! +! set up constant gas profiles, such as co2, ch4, n2o, o2, and those ! +! of cfc gases. All data are entered as mixing ratio by volume ! ! ! ! in the module, the externally callabe subroutines are : ! ! ! @@ -23,16 +20,10 @@ ! ! ! 'gas_update' -- read in data and update with time ! ! input: ! -! ( iyear, imon, iday, ihour, loz1st, ldoco2, me ) ! +! ( iyear, imon, iday, ihour, ldoco2, me ) ! ! output: ! ! ( errflg, errmsg ) ! ! ! -! 'getozn' -- setup climatological ozone profile ! -! input: ! -! ( prslk,xlat, ! -! IMAX, LM ) ! -! output: ! -! ( o3mmr ) ! ! ! ! 'getgases' -- setup constant gas profiles for LW and SW ! ! input: ! @@ -47,7 +38,6 @@ ! 'module module_iounitdef' in 'iounitdef.f' ! ! ! ! unit used for radiative active gases: ! -! ozone : mass mixing ratio (g/g) ! ! co2 : volume mixing ratio (p/p) ! ! n2o : volume mixing ratio (p/p) ! ! ch4 : volume mixing ratio (p/p) ! @@ -81,15 +71,6 @@ ! seasonal cycle calculations ! ! aug 2011 - y-t hou fix a bug in subr getgases doing vertical ! ! co2 mapping. (for top_at_1 case, not affact opr). ! -! aug 2012 - y-t hou modified subr getozn. moved the if-first ! -! block to subr gas_init to ensure threading safe in ! -! climatology ozone applications. (not affect gfs) ! -! also changed the initialization subr into two parts:! -! 'gas_init' is called at the start of run to set up ! -! module parameters; and 'gas_update' is called within! -! the time loop to check and update data sets. defined! -! the climatology ozone parameters k1oz,k2oz,facoz as ! -! module variables and are set in subr 'gas_update' ! ! nov 2012 - y-t hou modified control parameters thru module ! ! 'physparam'. ! ! jan 2013 - z. janjic/y. hou modified ilon (longitude index) ! @@ -105,10 +86,8 @@ !> \defgroup module_radiation_gases_mod Radiation Gases Module !> @{ -!> This module sets up ozone climatological profiles and other constant -!! gas profiles, such as co2, ch4, n2o, o2, and those of cfc gases. All -!! data are entered as mixing ratio by volume, except ozone which is -!! mass mixing ratio (g/g). +!> This module sets up constant gas profiles, such as co2, ch4, n2o, o2, +!! and those of cfc gases. All data are entered as mixing ratio by volume. !!\image html rad_gas_AGGI.png "Figure 1: Atmospheric radiative forcing, relative to 1750, by long-lived greenhouse gases and the 2016 update of the NOAA Annual Greenhouse Gas Index (AGGI)" !! NOAA Annual Greenhouse Gas Index (AGGI) shows that from 1990 to 2016, !! radiative forcing by long-lived greenhouse gases (LLGHGs) increased by @@ -121,10 +100,6 @@ !!\n ICO2=1: use observed global annual mean value !!\n ICO2=2: use observed monthly 2-d data table in \f$15^o\f$ horizontal resolution !! -!! O3 Distribution (namelist control parameter -\b NTOZ): -!!\n NTOZ=0: use seasonal and zonal averaged climatological ozone -!!\n NTOZ>0: use 3-D prognostic ozone -!! !! Trace Gases (currently using the global mean climatology in unit of ppmv): !! \f$CH_4-1.50\times10^{-6}\f$; !! \f$N_2O-0.31\times10^{-6}\f$; @@ -137,8 +112,8 @@ !! !!\version NCEP-Radiation_gases v5.1 Nov 2012 -!> This module sets up ozone climatological profiles and other constant gas -!! profiles, such as co2, ch4, n2o, o2, and those of cfc gases. +!> This module sets up constant gas rofiles, such as co2, ch4, n2o, o2, and those +!! of cfc gases. module module_radiation_gases use machine, only : kind_phys, kind_io4 use funcphys, only : fpkapx @@ -179,22 +154,8 @@ module module_radiation_gases ! gfdl 1999 value real (kind=kind_phys), parameter :: f113vmr_def= 8.2000e-11 -! --- ozone seasonal climatology parameters defined in module ozne_def -! - 4x5 ozone data parameter -! integer, parameter :: JMR=45, LOZ=17 -! real (kind=kind_phys), parameter :: blte=-86.0, dlte=4.0 -! - geos ozone data -! integer, parameter :: JMR=18, LOZ=17 -! real (kind=kind_phys), parameter :: blte=-85.0, dlte=10.0 - ! --- module variables to be set in subroutin gas_init and/or gas_update -! variables for climatology ozone (ioznflg = 0) - - real (kind=kind_phys), allocatable :: pkstr(:), o3r(:,:,:) - integer :: k1oz = 0, k2oz = 0 - real (kind=kind_phys) :: facoz = 0.0 - ! arrays for co2 2-d monthly data and global mean values from observed data real (kind=kind_phys), allocatable :: co2vmr_sav(:,:,:) @@ -209,33 +170,30 @@ module module_radiation_gases ! --- public interfaces - public gas_init, gas_update, getgases, getozn + public gas_init, gas_update, getgases ! ================= contains ! ================= -!> This subroutine sets up ozone, co2, etc. parameters. If climatology -!! ozone then read in monthly ozone data. +!> This subroutine sets up co2, etc. parameters. !!\param me print message control flag !!\param co2usr_file co2 user defined data table !!\param co2cyc_file co2 climotology monthly cycle data table !!\param ictmflg data ic time/date control flag !!\param ico2flg co2 data source control flag -!!\param ioznflg ozone data control flag !!\param con_pi physical constant Pi !!\param errflg error flag !!\param errmsg error message !>\section gas_init_gen gas_init General Algorithm !----------------------------------- subroutine gas_init( me, co2usr_file, co2cyc_file, ico2flg, & - & ictmflg, ioznflg, con_pi, JMR, LOZ, timeozc, errflg, errmsg) + & ictmflg, con_pi, errflg, errmsg) ! =================================================================== ! ! ! -! gas_init sets up ozone, co2, etc. parameters. if climatology ozone ! -! then read in monthly ozone data. ! +! gas_init sets up co2, etc. parameters. ! ! ! ! inputs: ! ! me - print message control flag ! @@ -256,9 +214,6 @@ subroutine gas_init( me, co2usr_file, co2cyc_file, ico2flg, & ! further data extrapolation. ! ! =yyyy1: use yyyy data for the fcst. if needed, do ! ! extrapolation to match the fcst time. ! -! ioznflg - ozone data control flag ! -! =0: use climatological ozone profile ! -! >0: use interactive ozone profile ! ! co2usr_file - external co2 user defined data table ! ! co2cyc_file - external co2 climotology monthly cycle data table ! ! con_pi - physical constant Pi ! @@ -267,9 +222,6 @@ subroutine gas_init( me, co2usr_file, co2cyc_file, ico2flg, & ! errflg - error flag ! ! errmsg - error message ! ! ! -! internal module variables: ! -! pkstr, o3r - arrays for climatology ozone data ! -! ! ! usage: call gas_init ! ! ! ! subprograms called: none ! @@ -279,8 +231,7 @@ subroutine gas_init( me, co2usr_file, co2cyc_file, ico2flg, & implicit none ! --- inputs: - integer, intent(in) :: me, ictmflg, ioznflg, ico2flg - integer, intent(in) :: JMR, LOZ, timeozc + integer, intent(in) :: me, ictmflg, ico2flg character(len=26),intent(in) :: co2usr_file,co2cyc_file real(kind=kind_phys), intent(in) :: con_pi @@ -291,10 +242,7 @@ subroutine gas_init( me, co2usr_file, co2cyc_file, ico2flg, & ! --- locals: real (kind=kind_phys), dimension(IMXCO2,JMXCO2) :: co2dat real (kind=kind_phys) :: co2g1, co2g2 - real (kind=kind_phys) :: pstr(LOZ) - real (kind=kind_io4) :: o3clim4(JMR,LOZ,12), pstr4(LOZ) - integer :: imond(12), ilat(JMR,12) integer :: i, j, k, iyr, imo logical :: file_exist, lextpl character :: cline*100, cform*8 @@ -316,78 +264,6 @@ subroutine gas_init( me, co2usr_file, co2cyc_file, ico2flg, & kyrsav = 0 kmonsav = 1 -! --- ... climatology ozone data section - - if ( ioznflg > 0 ) then - if ( me == 0 ) then - print *,' - Using interactive ozone distribution' - endif - else - if ( timeozc /= 12 ) then - print *,' - Using climatology ozone distribution' - print *,' timeozc=',timeozc, ' is not monthly mean', & - & ' - job aborting in subroutin gas_init!!!' - errflg = 1 - errmsg = 'ERROR(gas_init): Climatological o3 distribution '// & - & 'is not monthly mean' - return - endif - - allocate (pkstr(LOZ), o3r(JMR,LOZ,12)) - rewind NIO3CLM - - if ( LOZ == 17 ) then ! For the operational ozone climatology - do k = 1, LOZ - read (NIO3CLM,15) pstr4(k) - 15 format(f10.3) - enddo - - do imo = 1, 12 - do j = 1, JMR - read (NIO3CLM,16) imond(imo), ilat(j,imo), & - & (o3clim4(j,k,imo),k=1,10) - 16 format(i2,i4,10f6.2) - read (NIO3CLM,20) (o3clim4(j,k,imo),k=11,LOZ) - 20 format(6x,10f6.2) - enddo - enddo - else ! For newer ozone climatology - read (NIO3CLM) - do k = 1, LOZ - read (NIO3CLM) pstr4(k) - enddo - - do imo = 1, 12 - do k = 1, LOZ - read (NIO3CLM) (o3clim4(j,k,imo),j=1,JMR) - enddo - enddo - endif ! end if_LOZ_block -! - do imo = 1, 12 - do k = 1, LOZ - do j = 1, JMR - o3r(j,k,imo) = o3clim4(j,k,imo) * 1.655e-6 - enddo - enddo - enddo - - do k = 1, LOZ - pstr(k) = pstr4(k) - enddo - - if ( me == 0 ) then - print *,' - Using climatology ozone distribution' - print *,' Found ozone data for levels pstr=', & - & (pstr(k),k=1,LOZ) -! print *,' O3=',(o3r(15,k,1),k=1,LOZ) - endif - - do k = 1, LOZ - pkstr(k) = fpkapx(pstr(k)*100.0) - enddo - endif ! end if_ioznflg_block - ! --- ... co2 data section co2_glb = co2vmr_def @@ -541,20 +417,18 @@ end subroutine gas_init !!\param imon month of the year !!\param iday day of the month !!\param ihour hour of the day -!!\param loz1st clim ozone 1st time update control flag !!\param ldoco2 co2 update control flag !!\param me print message control flag !!\param co2dat_file co2 2d monthly obsv data table !!\param co2gbl_file co2 global annual mean data table !!\param ictmflg data ic time/date control flag !!\param ico2flg co2 data source control flag -!!\param ioznflg ozone data control flag !!\param errflg error flag !!\param errmsg error message !>\section gen_gas_update gas_update General Algorithm !----------------------------------- - subroutine gas_update(iyear, imon, iday, ihour, loz1st, ldoco2, & - & me, co2dat_file, co2gbl_file, ictmflg, ico2flg, ioznflg, & + subroutine gas_update(iyear, imon, iday, ihour, ldoco2, & + & me, co2dat_file, co2gbl_file, ictmflg, ico2flg, & & errflg, errmsg ) ! =================================================================== ! @@ -567,7 +441,6 @@ subroutine gas_update(iyear, imon, iday, ihour, loz1st, ldoco2, & ! imon - month of the year 1 ! ! iday - day of the month 1 ! ! ihour - hour of the day 1 ! -! loz1st - clim ozone 1st time update control flag 1 ! ! ldoco2 - co2 update control flag 1 ! ! me - print message control flag 1 ! ! ico2flg - co2 data source control flag ! @@ -587,9 +460,6 @@ subroutine gas_update(iyear, imon, iday, ihour, loz1st, ldoco2, & ! further data extrapolation. ! ! =yyyy1: use yyyy data for the fcst. if needed, do ! ! extrapolation to match the fcst time. ! -! ioznflg - ozone data control flag ! -! =0: use climatological ozone profile ! -! >0: use interactive ozone profile ! ! ivflip - vertical profile indexing flag ! ! co2dat_file - external co2 2d monthly obsv data table ! ! co2gbl_file - external co2 global annual mean data table ! @@ -603,8 +473,6 @@ subroutine gas_update(iyear, imon, iday, ihour, loz1st, ldoco2, & ! co2cyc_sav - monthly cycle co2 vol mixing ratio IMXCO2*JMXCO2*12 ! ! co2_glb - global annual mean co2 mixing ratio ! ! gco2cyc - global monthly mean co2 variation 12 ! -! k1oz,k2oz,facoz ! -! - climatology ozone parameters 1 ! ! ! ! usage: call gas_update ! ! ! @@ -616,9 +484,8 @@ subroutine gas_update(iyear, imon, iday, ihour, loz1st, ldoco2, & ! --- inputs: integer, intent(in) :: iyear,imon,iday,ihour,me,ictmflg,ico2flg - integer, intent(in) :: ioznflg character(len=26),intent(in) :: co2dat_file, co2gbl_file - logical, intent(in) :: loz1st, ldoco2 + logical, intent(in) :: ldoco2 ! --- output: character(len=*), intent(out) :: errmsg @@ -643,35 +510,6 @@ subroutine gas_update(iyear, imon, iday, ihour, loz1st, ldoco2, & errmsg = '' errflg = 0 -!> - Ozone data section - - if ( ioznflg == 0 ) then - midmon = mdays(imon)/2 + 1 - change = loz1st .or. ( (iday==midmon) .and. (ihour==0) ) -! - if ( change ) then - if ( iday < midmon ) then - k1oz = mod(imon+10, 12) + 1 - midm = mdays(k1oz)/2 + 1 - k2oz = imon - midp = mdays(k1oz) + midmon - else - k1oz = imon - midm = midmon - k2oz = mod(imon, 12) + 1 - midp = mdays(k2oz)/2 + 1 + mdays(k1oz) - endif - endif -! - if (iday < midmon) then - id = iday + mdays(k1oz) - else - id = iday - endif - - facoz = float(id - midm) / float(midp - midm) - endif - !> - co2 data section if ( ico2flg == 0 ) return ! use prescribed global mean co2 data @@ -1103,121 +941,6 @@ subroutine getgases( plvl, xlon, xlat, IMAX, LMAX, ico2flg, & end subroutine getgases !----------------------------------- -!> This subroutine sets up climatological ozone profile for radiation -!! calculation. This code is originally written by Shrinivas Moorthi. -!!\param prslk (IMAX,LM), exner function = \f$(p/p0)^{rocp}\f$ -!!\param xlat (IMAX), latitude in radians, default to pi/2 -> -!! -pi/2 range, otherwise see in-line comment -!!\param IMAX, LM (1), horizontal and vertical dimensions -!!\param top_at_1 (1), vertical profile indexing flag -!!\param o3mmr (IMAX,LM), output ozone profile in mass mixing -!! ratio (g/g) -!>\section getozn_gen getozn General Algorithm -!----------------------------------- - subroutine getozn( prslk,xlat, IMAX, LM, top_at_1, JMR, LOZ, blte,& - & dlte, o3mmr) - -! =================================================================== ! -! ! -! getozn sets up climatological ozone profile for radiation calculation! -! ! -! this code is originally written By Shrinivas Moorthi ! -! ! -! inputs: ! -! prslk (IMAX,LM) - exner function = (p/p0)**rocp ! -! xlat (IMAX) - latitude in radians, default to pi/2 -> -pi/2 ! -! range, otherwise see in-line comment ! -! IMAX, LM - horizontal and vertical dimensions ! -! top_at_1 - vertical profile indexing flag ! -! ! -! outputs: ! -! o3mmr (IMAX,LM) - output ozone profile in mass mixing ratio (g/g)! -! ! -! module variables: ! -! k1oz, k2oz - ozone data interpolation indices ! -! facoz - ozone data interpolation factor ! -! ! -! usage: call getozn ! -! ! -! =================================================================== ! -! - implicit none - -! --- inputs: - integer, intent(in) :: IMAX, LM, JMR, LOZ - real(kind=kind_phys), intent(in) :: blte, dlte - logical, intent(in) :: top_at_1 - real (kind=kind_phys), intent(in) :: prslk(:,:), xlat(:) - -! --- outputs: - real (kind=kind_phys), intent(out) :: o3mmr(:,:) - -! --- locals: - real (kind=kind_phys) :: o3i(IMAX,LOZ), wk1(IMAX), deglat, elte, & - & tem, tem1, tem2, tem3, tem4, temp - integer :: i, j, k, l, j1, j2, ll -! -!===> ... begin here -! - elte = blte + (JMR-1)*dlte - - do i = 1, IMAX - deglat = xlat(i) * raddeg ! if xlat in pi/2 -> -pi/2 range -! deglat = 90.0 - xlat(i)*raddeg ! if xlat in 0 -> pi range - - if (deglat > blte .and. deglat < elte) then - tem1 = (deglat - blte) / dlte + 1 - j1 = tem1 - j2 = j1 + 1 - tem1 = tem1 - j1 - elseif (deglat <= blte) then - j1 = 1 - j2 = 1 - tem1 = 1.0 - elseif (deglat >= elte) then - j1 = JMR - j2 = JMR - tem1 = 1.0 - endif - - tem2 = 1.0 - tem1 - do j = 1, LOZ - tem3 = tem2*o3r(j1,j,k1oz) + tem1*o3r(j2,j,k1oz) - tem4 = tem2*o3r(j1,j,k2oz) + tem1*o3r(j2,j,k2oz) - o3i(i,j) = tem4*facoz + tem3*(1.0 - facoz) - enddo - enddo - - do l = 1, LM - ll = l - if (.not. top_at_1) ll = LM -l + 1 - - do i = 1, IMAX - wk1(i) = prslk(i,ll) - enddo - - do k = 1, LOZ-1 - temp = 1.0 / (pkstr(k+1) - pkstr(k)) - - do i = 1, IMAX - if (wk1(i) > pkstr(k) .and. wk1(i) <= pkstr(k+1)) then - tem = (pkstr(k+1) - wk1(i)) * temp - o3mmr(I,ll) = tem * o3i(i,k) + (1.0 - tem) * o3i(i,k+1) - endif - enddo - enddo - - do i = 1, IMAX - if (wk1(i) > pkstr(LOZ)) o3mmr(i,ll) = o3i(i,LOZ) - if (wk1(i) < pkstr(1)) o3mmr(i,ll) = o3i(i,1) - enddo - enddo -! - return -!................................... - end subroutine getozn -!----------------------------------- - ! !........................................! end module module_radiation_gases ! diff --git a/physics/rrtmgp_lw_main.F90 b/physics/rrtmgp_lw_main.F90 index 67f7f749a..01b25c925 100644 --- a/physics/rrtmgp_lw_main.F90 +++ b/physics/rrtmgp_lw_main.F90 @@ -19,7 +19,6 @@ module rrtmgp_lw_main use rrtmgp_lw_gas_optics, only: lw_gas_props,rrtmgp_lw_gas_optics_init use rrtmgp_lw_cloud_optics, only: lw_cloud_props, rrtmgp_lw_cloud_optics_init, abssnow0, & abssnow1, absrain - use module_radiation_gases, only: NF_VGAS, getgases, getozn use GFS_rrtmgp_pre, only: iStr_h2o, iStr_co2, iStr_o3, iStr_n2o, iStr_ch4, & iStr_o2, iStr_ccl4, iStr_cfc11, iStr_cfc12, iStr_cfc22, & eps, oneminus, ftiny From 2886df96f645f9366d7d0496ac654fc178264e7d Mon Sep 17 00:00:00 2001 From: dustinswales Date: Wed, 27 Sep 2023 14:23:36 -0600 Subject: [PATCH 346/380] Small cosmetic changes --- physics/GFS_phys_time_vary.fv3.F90 | 53 ++++++++++++++---------------- 1 file changed, 24 insertions(+), 29 deletions(-) diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index af2dd9b00..f72763c3a 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -219,14 +219,6 @@ subroutine GFS_phys_time_vary_init ( !$OMP sections -!$OMP section -!> - Setup spatial interpolation indices for ozone physics. - if (ntoz > 0) then - !$OMP CRITICAL - call ozphys%setup_forcing(xlat_d, jindx1_o3, jindx2_o3, ddy_o3) - !$OMP END CRITICAL - endif - !$OMP section !> - Call read_h2odata() to read stratospheric water vapor data call read_h2odata (h2o_phys, me, master) @@ -294,6 +286,12 @@ subroutine GFS_phys_time_vary_init ( !$OMP sections +!$OMP section +!> - Setup spatial interpolation indices for ozone physics. + if (ntoz > 0) then + call ozphys%setup_forcing(xlat_d, jindx1_o3, jindx2_o3, ddy_o3) + endif + !$OMP section !> - Call setindxh2o() to initialize stratospheric water vapor data if (h2o_phys) then @@ -803,21 +801,7 @@ subroutine GFS_phys_time_vary_timestep_init ( return end if -!$OMP parallel num_threads(nthrds) default(none) & -!$OMP shared(kdt,nsswr,lsswr,clstp,imfdeepcnv,cal_pre,random_clds) & -!$OMP shared(fhswr,fhour,seed0,cnx,cny,nrcm,wrk,rannie,rndval) & -!$OMP shared(rann,im,isc,jsc,imap,jmap,ntoz,me,idate,jindx1_o3,jindx2_o3) & -!$OMP shared(ozpl,ddy_o3,h2o_phys,jindx1_h,jindx2_h,h2opl,ddy_h,iaerclm,master) & -!$OMP shared(levs,prsl,iccn,jindx1_ci,jindx2_ci,ddy_ci,iindx1_ci,iindx2_ci) & -!$OMP shared(ddx_ci,in_nm,ccn_nm,do_ugwp_v1,jindx1_tau,jindx2_tau,ddy_j1tau) & -!$OMP shared(ddy_j2tau,tau_amf,iflip,ozphys) & -!$OMP private(iseed,iskip,i,j,rjday,idat,rinc,w3kindreal,w3kindint,jdat)& -!$OMP private(jdow,jdoy,jday,rinc4,n1,n2) - -!$OMP sections - -!$OMP section -!> - Compute temporal interpolation indices for updating gas concentrations. + !> - Compute temporal interpolation indices for updating gas concentrations. idat=0 idat(1)=idate(4) idat(2)=idate(2) @@ -849,12 +833,17 @@ subroutine GFS_phys_time_vary_timestep_init ( n1 = n2 - 1 if (n2 > ozphys%ntime) n2 = n2 - ozphys%ntime - !> - Update ozone concentration. - if (ntoz > 0) then - !$OMP CRITICAL - call ozphys%update_forcing(jindx1_o3, jindx2_o3, ddy_o3, rjday, n1, n2, ozpl) - !$OMP END CRITICAL - endif +!$OMP parallel num_threads(nthrds) default(none) & +!$OMP shared(kdt,nsswr,lsswr,clstp,imfdeepcnv,cal_pre,random_clds) & +!$OMP shared(fhswr,fhour,seed0,cnx,cny,nrcm,wrk,rannie,rndval) & +!$OMP shared(rann,im,isc,jsc,imap,jmap,ntoz,me,idate,jindx1_o3,jindx2_o3) & +!$OMP shared(ozpl,ddy_o3,h2o_phys,jindx1_h,jindx2_h,h2opl,ddy_h,iaerclm,master) & +!$OMP shared(levs,prsl,iccn,jindx1_ci,jindx2_ci,ddy_ci,iindx1_ci,iindx2_ci) & +!$OMP shared(ddx_ci,in_nm,ccn_nm,do_ugwp_v1,jindx1_tau,jindx2_tau,ddy_j1tau) & +!$OMP shared(ddy_j2tau,tau_amf,iflip,ozphys) & +!$OMP private(iseed,iskip,i,j) + +!$OMP sections !$OMP section @@ -901,6 +890,12 @@ subroutine GFS_phys_time_vary_timestep_init ( endif ! imfdeepcnv, cal_re, random_clds +!$OMP section +!> - Update ozone concentration. + if (ntoz > 0) then + call ozphys%update_forcing(jindx1_o3, jindx2_o3, ddy_o3, rjday, n1, n2, ozpl) + endif + !$OMP section !> - Call h2ointerpol() to make stratospheric water vapor data interpolation if (h2o_phys) then From 17b057ce219479a3e46e9c8d7825736a0935083c Mon Sep 17 00:00:00 2001 From: dustinswales Date: Wed, 27 Sep 2023 14:28:52 -0600 Subject: [PATCH 347/380] Housekeeping --- physics/GFS_phys_time_vary.fv3.F90 | 2 +- physics/GFS_phys_time_vary.fv3.meta | 59 ++++++++++++++--------------- 2 files changed, 30 insertions(+), 31 deletions(-) diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index f72763c3a..6fa188471 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -841,7 +841,7 @@ subroutine GFS_phys_time_vary_timestep_init ( !$OMP shared(levs,prsl,iccn,jindx1_ci,jindx2_ci,ddy_ci,iindx1_ci,iindx2_ci) & !$OMP shared(ddx_ci,in_nm,ccn_nm,do_ugwp_v1,jindx1_tau,jindx2_tau,ddy_j1tau) & !$OMP shared(ddy_j2tau,tau_amf,iflip,ozphys) & -!$OMP private(iseed,iskip,i,j) +!$OMP private(iseed,iskip,i,j,k) !$OMP sections diff --git a/physics/GFS_phys_time_vary.fv3.meta b/physics/GFS_phys_time_vary.fv3.meta index bf5a3fa04..639e2db6a 100644 --- a/physics/GFS_phys_time_vary.fv3.meta +++ b/physics/GFS_phys_time_vary.fv3.meta @@ -30,6 +30,13 @@ dimensions = () type = logical intent = in +[ntoz] + standard_name = index_of_ozone_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for ozone mixing ratio + units = index + dimensions = () + type = integer + intent = in [iaerclm] standard_name = flag_for_aerosol_input_MG_radiation long_name = flag for using aerosols in Morrison-Gettelman MP_radiation @@ -72,36 +79,6 @@ dimensions = () type = integer intent = in - intent = in -[ntoz] - standard_name = index_of_ozone_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for ozone mixing ratio - units = index - dimensions = () - type = integer - intent = in -[jindx1_o3] - standard_name = lower_latitude_index_of_ozone_forcing_for_interpolation - long_name = interpolation low index for ozone - units = index - dimensions = (horizontal_dimension) - type = integer - intent = in -[jindx2_o3] - standard_name = upper_latitude_index_of_ozone_forcing_for_interpolation - long_name = interpolation high index for ozone - units = index - dimensions = (horizontal_dimension) - type = integer - intent = in -[ddy_o3] - standard_name = latitude_interpolation_weight_for_ozone_forcing - long_name = interpolation high index for ozone - units = none - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in [nx] standard_name = number_of_points_in_x_direction_for_this_MPI_rank long_name = number of points in x direction for this MPI rank @@ -139,6 +116,28 @@ type = real kind = kind_phys intent = in +[jindx1_o3] + standard_name = lower_latitude_index_of_ozone_forcing_for_interpolation + long_name = interpolation low index for ozone + units = index + dimensions = (horizontal_dimension) + type = integer + intent = inout +[jindx2_o3] + standard_name = upper_latitude_index_of_ozone_forcing_for_interpolation + long_name = interpolation high index for ozone + units = index + dimensions = (horizontal_dimension) + type = integer + intent = inout +[ddy_o3] + standard_name = latitude_interpolation_weight_for_ozone_forcing + long_name = interpolation high index for ozone + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout [jindx1_h] standard_name = lower_latitude_index_of_stratospheric_water_vapor_forcing_for_interpolation long_name = interpolation low index for stratospheric water vapor From 17203fe06a90612ad09a357e8084510c4a277d58 Mon Sep 17 00:00:00 2001 From: dustinswales Date: Wed, 27 Sep 2023 14:32:20 -0600 Subject: [PATCH 348/380] Housekeeping --- physics/GFS_phys_time_vary.fv3.meta | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/physics/GFS_phys_time_vary.fv3.meta b/physics/GFS_phys_time_vary.fv3.meta index 639e2db6a..ad543e146 100644 --- a/physics/GFS_phys_time_vary.fv3.meta +++ b/physics/GFS_phys_time_vary.fv3.meta @@ -23,13 +23,6 @@ dimensions = () type = integer intent = in -[h2o_phys] - standard_name = flag_for_stratospheric_water_vapor_physics - long_name = flag for stratospheric water vapor physics - units = flag - dimensions = () - type = logical - intent = in [ntoz] standard_name = index_of_ozone_mixing_ratio_in_tracer_concentration_array long_name = tracer index for ozone mixing ratio @@ -37,6 +30,13 @@ dimensions = () type = integer intent = in +[h2o_phys] + standard_name = flag_for_stratospheric_water_vapor_physics + long_name = flag for stratospheric water vapor physics + units = flag + dimensions = () + type = logical + intent = in [iaerclm] standard_name = flag_for_aerosol_input_MG_radiation long_name = flag for using aerosols in Morrison-Gettelman MP_radiation From 3f6168b12443a79adf7abcdf326bcfa6813c8d84 Mon Sep 17 00:00:00 2001 From: dustinswales Date: Wed, 27 Sep 2023 15:49:35 -0600 Subject: [PATCH 349/380] More reorg. --- physics/GFS_phys_time_vary.fv3.F90 | 9 +- physics/GFS_rrtmg_pre.F90 | 2 +- physics/GFS_rrtmg_setup.F90 | 2 +- physics/GFS_rrtmgp_pre.F90 | 2 +- physics/GFS_rrtmgp_setup.F90 | 2 +- physics/GFS_suite_stateout_update.F90 | 135 +++++++++++++++---------- physics/GFS_suite_stateout_update.meta | 95 ++++++++++++++++- physics/module_ozphys.F90 | 50 ++++----- 8 files changed, 209 insertions(+), 88 deletions(-) diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index 6fa188471..70eeb81e1 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -95,6 +95,7 @@ subroutine GFS_phys_time_vary_init ( integer, intent(in) :: lkm integer, intent(inout) :: use_lake_model(:) real(kind=kind_phys), intent(in ) :: lakefrac(:), lakedepth(:) + integer, intent(inout) :: jindx1_o3(:), jindx2_o3(:), jindx1_h(:), jindx2_h(:) real(kind_phys), intent(inout) :: ddy_o3(:), ddy_h(:) real(kind_phys), intent(in) :: h2opl(:,:,:) @@ -289,7 +290,7 @@ subroutine GFS_phys_time_vary_init ( !$OMP section !> - Setup spatial interpolation indices for ozone physics. if (ntoz > 0) then - call ozphys%setup_forcing(xlat_d, jindx1_o3, jindx2_o3, ddy_o3) + call ozphys%setup_o3prog(xlat_d, jindx1_o3, jindx2_o3, ddy_o3) endif !$OMP section @@ -729,7 +730,7 @@ subroutine GFS_phys_time_vary_timestep_init ( lakefrac, min_seaice, min_lakeice, smc, slc, stc, smois, sh2o, tslb, tiice, tg3, tref, & tsfc, tsfco, tisfc, hice, fice, facsf, facwf, alvsf, alvwf, alnsf, alnwf, zorli, zorll, & zorlo, weasd, slope, snoalb, canopy, vfrac, vtype, stype,scolor, shdmin, shdmax, snowd, & - cv, cvb, cvt, oro, oro_uf, xlat_d, xlon_d, slmsk, landfrac, ozphys, & + cv, cvb, cvt, oro, oro_uf, xlat_d, xlon_d, slmsk, landfrac, ozphys, & do_ugwp_v1, jindx1_tau, jindx2_tau, ddy_j1tau, ddy_j2tau, tau_amf, errmsg, errflg) implicit none @@ -841,7 +842,7 @@ subroutine GFS_phys_time_vary_timestep_init ( !$OMP shared(levs,prsl,iccn,jindx1_ci,jindx2_ci,ddy_ci,iindx1_ci,iindx2_ci) & !$OMP shared(ddx_ci,in_nm,ccn_nm,do_ugwp_v1,jindx1_tau,jindx2_tau,ddy_j1tau) & !$OMP shared(ddy_j2tau,tau_amf,iflip,ozphys) & -!$OMP private(iseed,iskip,i,j,k) +!$OMP private(iseed,iskip,i,j,k,rjday,n1,n2) !$OMP sections @@ -893,7 +894,7 @@ subroutine GFS_phys_time_vary_timestep_init ( !$OMP section !> - Update ozone concentration. if (ntoz > 0) then - call ozphys%update_forcing(jindx1_o3, jindx2_o3, ddy_o3, rjday, n1, n2, ozpl) + call ozphys%update_o3prog(jindx1_o3, jindx2_o3, ddy_o3, rjday, n1, n2, ozpl) endif !$OMP section diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 69be4f8d0..108d6f407 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -434,7 +434,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& enddo enddo else ! climatological ozone - call ozphys%oz_clim(xlat, prslk1, con_pi, olyr) + call ozphys%run_o3clim(xlat, prslk1, con_pi, olyr) endif ! end_if_ntoz !> - Call coszmn(), to compute cosine of zenith angle (only when SW is called) diff --git a/physics/GFS_rrtmg_setup.F90 b/physics/GFS_rrtmg_setup.F90 index 908a364dc..e48a60ac8 100644 --- a/physics/GFS_rrtmg_setup.F90 +++ b/physics/GFS_rrtmg_setup.F90 @@ -467,7 +467,7 @@ subroutine radupdate( idate,jdate,deltsw,deltim,lsswr,me, iaermdl,& call gas_update ( kyear,kmon,kday,khour,lco2_chg, me, co2dat_file, & co2gbl_file, ictm, ico2, errflg, errmsg ) if (ntoz == 0) then - call ozphys%update_clim(kmon, kday, khour, loz1st) + call ozphys%update_o3clim(kmon, kday, khour, loz1st) endif if ( loz1st ) loz1st = .false. diff --git a/physics/GFS_rrtmgp_pre.F90 b/physics/GFS_rrtmgp_pre.F90 index 9dcc002a0..cbf8d161b 100644 --- a/physics/GFS_rrtmgp_pre.F90 +++ b/physics/GFS_rrtmgp_pre.F90 @@ -353,7 +353,7 @@ subroutine GFS_rrtmgp_pre_run(me, nCol, nLev, i_o3, doSWrad, doLWrad, fhswr, fhl enddo ! OR Use climatological ozone data else - call ozphys%oz_clim(xlat, prslk, con_pi, o3_lay) + call ozphys%run_o3clim(xlat, prslk, con_pi, o3_lay) endif ! ####################################################################################### diff --git a/physics/GFS_rrtmgp_setup.F90 b/physics/GFS_rrtmgp_setup.F90 index 3e4f57d13..9f2b2a9f9 100644 --- a/physics/GFS_rrtmgp_setup.F90 +++ b/physics/GFS_rrtmgp_setup.F90 @@ -243,7 +243,7 @@ subroutine GFS_rrtmgp_setup_timestep_init (idate, jdate, deltsw, deltim, doSWrad call gas_update (kyear, kmon, kday, khour, lco2_chg, me, co2dat_file, co2gbl_file, ictm,& ico2, errflg, errmsg ) if (ntoz == 0) then - call ozphys%update_clim(kmon, kday, khour, loz1st) + call ozphys%update_o3clim(kmon, kday, khour, loz1st) endif if ( loz1st ) loz1st = .false. diff --git a/physics/GFS_suite_stateout_update.F90 b/physics/GFS_suite_stateout_update.F90 index 2771c3e82..41f44e0de 100644 --- a/physics/GFS_suite_stateout_update.F90 +++ b/physics/GFS_suite_stateout_update.F90 @@ -1,63 +1,90 @@ +! ######################################################################################### !> \file GFS_suite_stateout_update.f90 -!! Contains code to update the state variables due to process-split physics from accumulated tendencies during that phase. +!! Update the state variables due to process-split physics from accumulated tendencies +!! during that phase. +!! Update gas concentrations, if using prognostic photolysis schemes. !! Also, set bounds on the mass-weighted rime factor when using Ferrier-Aligo microphysics. - - module GFS_suite_stateout_update - - contains - +! ######################################################################################### +module GFS_suite_stateout_update + use machine, only: kind_phys + use module_ozphys, only: ty_ozphys + implicit none +contains +! ######################################################################################### !> \section arg_table_GFS_suite_stateout_update_run Argument Table !! \htmlinclude GFS_suite_stateout_update_run.html !! - subroutine GFS_suite_stateout_update_run (im, levs, ntrac, dtp, & - tgrs, ugrs, vgrs, qgrs, dudt, dvdt, dtdt, dqdt, & - gt0, gu0, gv0, gq0, ntiw, nqrimef, imp_physics, & - imp_physics_fer_hires, epsq, errmsg, errflg) - - use machine, only: kind_phys - - implicit none - - ! Interface variables - integer, intent(in ) :: im - integer, intent(in ) :: levs - integer, intent(in ) :: ntrac - integer, intent(in ) :: imp_physics,imp_physics_fer_hires - integer, intent(in ) :: ntiw, nqrimef - real(kind=kind_phys), intent(in ) :: dtp, epsq - - real(kind=kind_phys), intent(in ), dimension(:,:) :: tgrs, ugrs, vgrs - real(kind=kind_phys), intent(in ), dimension(:,:,:) :: qgrs - real(kind=kind_phys), intent(in ), dimension(:,:) :: dudt, dvdt, dtdt - real(kind=kind_phys), intent(in ), dimension(:,:,:) :: dqdt - real(kind=kind_phys), intent(out), dimension(:,:) :: gt0, gu0, gv0 - real(kind=kind_phys), intent(out), dimension(:,:,:) :: gq0 - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - integer :: i, k - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - gt0(:,:) = tgrs(:,:) + dtdt(:,:) * dtp - gu0(:,:) = ugrs(:,:) + dudt(:,:) * dtp - gv0(:,:) = vgrs(:,:) + dvdt(:,:) * dtp - gq0(:,:,:) = qgrs(:,:,:) + dqdt(:,:,:) * dtp - - if (imp_physics == imp_physics_fer_hires) then +! ######################################################################################### + subroutine GFS_suite_stateout_update_run (im, levs, ntrac, dtp, tgrs, ugrs, vgrs, qgrs, & + dudt, dvdt, dtdt, dqdt, gt0, gu0, gv0, gq0, oz0, ntiw, nqrimef, imp_physics, & + imp_physics_fer_hires, epsq, ozphys, oz_phys_2015, oz_phys_2006, con_1ovg, prsl, & + dp, ozpl, do3_dt_prd, do3_dt_ozmx, do3_dt_temp, do3_dt_ohoz, errmsg, errflg) + + ! Inputs + integer, intent(in ) :: im + integer, intent(in ) :: levs + integer, intent(in ) :: ntrac + integer, intent(in ) :: imp_physics,imp_physics_fer_hires + integer, intent(in ) :: ntiw, nqrimef + real(kind=kind_phys), intent(in ) :: dtp, epsq, con_1ovg + real(kind=kind_phys), intent(in ), dimension(:,:) :: tgrs, ugrs, vgrs, prsl, dp + real(kind=kind_phys), intent(in ), dimension(:,:,:) :: qgrs, ozpl + real(kind=kind_phys), intent(in ), dimension(:,:) :: dudt, dvdt, dtdt + real(kind=kind_phys), intent(in ), dimension(:,:,:) :: dqdt + logical, intent(in) :: oz_phys_2015 + logical, intent(in) :: oz_phys_2006 + type(ty_ozphys), intent(in) :: ozphys + + ! Outputs (optional) + real(kind=kind_phys), intent(inout), dimension(:,:), pointer, optional :: & + do3_dt_prd, & ! Physics tendency: production and loss effect + do3_dt_ozmx, & ! Physics tendency: ozone mixing ratio effect + do3_dt_temp, & ! Physics tendency: temperature effect + do3_dt_ohoz ! Physics tendency: overhead ozone effect + + ! Outputs + real(kind=kind_phys), intent(out), dimension(:,:) :: gt0, gu0, gv0, oz0 + real(kind=kind_phys), intent(out), dimension(:,:,:) :: gq0 + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Locals + integer :: i, k + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! Update prognostic state varaibles using accumulated tendencies from "process-split" + ! section of GFS suite. + gt0(:,:) = tgrs(:,:) + dtdt(:,:) * dtp + gu0(:,:) = ugrs(:,:) + dudt(:,:) * dtp + gv0(:,:) = vgrs(:,:) + dvdt(:,:) * dtp + gq0(:,:,:) = qgrs(:,:,:) + dqdt(:,:,:) * dtp + + ! If using photolysis physics schemes, update (prognostic) gas concentrations using + ! updated state. + if (oz_phys_2015) then + call ozphys%run_o3prog_2015(con_1ovg, dtp, prsl, gt0, dp, ozpl, oz0, do3_dt_prd, & + do3_dt_ozmx, do3_dt_temp, do3_dt_ohoz) + endif + if (oz_phys_2006) then + call ozphys%run_o3prog_2006() + endif + + ! If using Ferrier-Aligo microphysics, set bounds on the mass-weighted rime factor. + if (imp_physics == imp_physics_fer_hires) then do k=1,levs - do i=1,im - if(gq0(i,k,ntiw) > epsq) then - gq0(i,k,nqrimef) = max(1., gq0(i,k,nqrimef)/gq0(i,k,ntiw)) - else - gq0(i,k,nqrimef) = 1. - end if - end do + do i=1,im + if(gq0(i,k,ntiw) > epsq) then + gq0(i,k,nqrimef) = max(1., gq0(i,k,nqrimef)/gq0(i,k,ntiw)) + else + gq0(i,k,nqrimef) = 1. + end if + end do end do - end if + end if - end subroutine GFS_suite_stateout_update_run + end subroutine GFS_suite_stateout_update_run - end module GFS_suite_stateout_update \ No newline at end of file +end module GFS_suite_stateout_update diff --git a/physics/GFS_suite_stateout_update.meta b/physics/GFS_suite_stateout_update.meta index 580482b71..8cbab9139 100644 --- a/physics/GFS_suite_stateout_update.meta +++ b/physics/GFS_suite_stateout_update.meta @@ -2,7 +2,7 @@ [ccpp-table-properties] name = GFS_suite_stateout_update type = scheme - dependencies = machine.F + dependencies = machine.F,module_ozphys.F90 ######################################################################## [ccpp-arg-table] @@ -37,6 +37,27 @@ type = real kind = kind_phys intent = in +[ozphys] + standard_name = dataset_for_ozone_physics + long_name = dataset for NRL ozone physics + units = mixed + dimensions = () + type = ty_ozphys + intent = in +[oz_phys_2015] + standard_name = flag_for_nrl_2015_ozone_scheme + long_name = flag for new (2015) ozone physics + units = flag + dimensions = () + type = logical + intent = in +[oz_phys_2006] + standard_name = flag_for_nrl_2006_ozone_scheme + long_name = flag for new (2006) ozone physics + units = flag + dimensions = () + type = logical + intent = in [tgrs] standard_name = air_temperature long_name = model layer mean temperature @@ -133,6 +154,14 @@ type = real kind = kind_phys intent = out +[oz0] + standard_name = ozone_concentration_of_new_state + long_name = ozone concentration updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout [ntiw] standard_name = index_of_cloud_ice_mixing_ratio_in_tracer_concentration_array long_name = tracer index for ice water @@ -169,6 +198,70 @@ type = real kind = kind_phys intent = in +[con_1ovg] + standard_name = one_divided_by_the_gravitational_acceleration + long_name = inverse of gravitational acceleration + units = s2 m-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[prsl] + standard_name = air_pressure + long_name = mid-layer pressure + units = Pa + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[ozpl] + standard_name = ozone_forcing + long_name = ozone forcing data + units = mixed + dimensions = (horizontal_loop_extent,number_of_levels_in_ozone_data,number_of_coefficients_in_ozone_data) + type = real + kind = kind_phys + intent = in +[dp] + standard_name = air_pressure_difference_between_midlayers + long_name = difference between mid-layer pressures + units = Pa + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[do3_dt_prd] + standard_name = ozone_tendency_due_to_production_and_loss_rate + long_name = ozone tendency due to production and loss rate + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[do3_dt_ozmx] + standard_name = ozone_tendency_due_to_ozone_mixing_ratio + long_name = ozone tendency due to ozone mixing ratio + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[do3_dt_temp] + standard_name = ozone_tendency_due_to_temperature + long_name = ozone tendency due to temperature + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[do3_dt_ohoz] + standard_name = ozone_tendency_due_to_overhead_ozone_column + long_name = ozone tendency due to overhead ozone column + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/module_ozphys.F90 b/physics/module_ozphys.F90 index 966d27113..205a02b46 100644 --- a/physics/module_ozphys.F90 +++ b/physics/module_ozphys.F90 @@ -41,21 +41,22 @@ module module_ozphys integer :: k2oz !< Upper interpolation index in datac(dim=3), time dim real(kind_phys) :: facoz !< Parameter for ozone climotology contains - procedure, public :: load_forcing - procedure, public :: load_clim - procedure, public :: setup_forcing - procedure, public :: update_forcing - procedure, public :: update_clim - procedure, public :: oz_prog_2015 - procedure, public :: oz_prog_2006 - procedure, public :: oz_clim + procedure, public :: load_o3prog + procedure, public :: setup_o3prog + procedure, public :: update_o3prog + procedure, public :: run_o3prog_2015 + procedure, public :: run_o3prog_2006 + ! + procedure, public :: load_o3clim + procedure, public :: update_o3clim + procedure, public :: run_o3clim end type ty_ozphys contains ! ######################################################################################### ! Procedure (type-bound) for loading ozone forcing data. ! ######################################################################################### - function load_forcing(this, file, fileID) result (err_message) + function load_o3prog(this, file, fileID) result (err_message) class(ty_ozphys), intent(inout) :: this integer, intent(in) :: fileID character(len=*), intent(in) :: file @@ -97,12 +98,12 @@ function load_forcing(this, file, fileID) result (err_message) deallocate(tempin) close(fileID) - end function load_forcing + end function load_o3prog ! ######################################################################################### ! Procedure for setting up interpolation indices between data and model grid. ! ######################################################################################### - subroutine setup_forcing(this, lat, idx1, idx2, idxh) + subroutine setup_o3prog(this, lat, idx1, idx2, idxh) class(ty_ozphys), intent(in) :: this real(kind_phys), intent(in) :: lat(:) integer, intent(out) :: idx1(:), idx2(:) @@ -126,12 +127,12 @@ subroutine setup_forcing(this, lat, idx1, idx2, idxh) endif enddo - end subroutine setup_forcing + end subroutine setup_o3prog ! ######################################################################################### ! Procedure (type-bound) for updating ozone data. ! ######################################################################################### - subroutine update_forcing(this, idx1, idx2, idxh, rjday, idxt1, idxt2, ozpl) + subroutine update_o3prog(this, idx1, idx2, idxh, rjday, idxt1, idxt2, ozpl) class(ty_ozphys), intent(in) :: this integer, intent(in) :: idx1(:), idx2(:) real(kind_phys), intent(in) :: idxh(:) @@ -156,12 +157,12 @@ subroutine update_forcing(this, idx1, idx2, idxh, rjday, idxt1, idxt2, ozpl) enddo enddo - end subroutine update_forcing + end subroutine update_o3prog ! ######################################################################################### ! Procedure (type-bound) for NRL prognostic ozone (2015). ! ######################################################################################### - subroutine oz_prog_2015(this, con_1ovg, dt, p, t, dp, ozpl, oz, do3_dt_prd, do3_dt_ozmx, & + subroutine run_o3prog_2015(this, con_1ovg, dt, p, t, dp, ozpl, oz, do3_dt_prd, do3_dt_ozmx, & do3_dt_temp, do3_dt_ohoz) class(ty_ozphys), intent(in) :: this real(kind_phys),intent(in) :: & @@ -267,21 +268,20 @@ subroutine oz_prog_2015(this, con_1ovg, dt, p, t, dp, ozpl, oz, do3_dt_prd, do3_ enddo return - end subroutine oz_prog_2015 + end subroutine run_o3prog_2015 ! ######################################################################################### ! Procedure (type-bound) for NRL prognostic ozone (2006). ! ######################################################################################### - subroutine oz_prog_2006(this) + subroutine run_o3prog_2006(this) class(ty_ozphys), intent(in) :: this return - end subroutine oz_prog_2006 + end subroutine run_o3prog_2006 ! ######################################################################################### ! Procedure (type-bound) for NRL updating climotological ozone. - ! Build this up from getozn. ! ######################################################################################### - subroutine oz_clim(this, lat, prslk, con_pi, oz) + subroutine run_o3clim(this, lat, prslk, con_pi, oz) class(ty_ozphys), intent(in) :: this real(kind_phys), intent(in) :: & con_pi ! Physics constant: Pi @@ -356,12 +356,12 @@ subroutine oz_clim(this, lat, prslk, con_pi, oz) enddo return - end subroutine oz_clim + end subroutine run_o3clim ! ######################################################################################### ! Procedure (type-bound) for loading ozone climo data. ! ######################################################################################### - function load_clim(this, file, fileID) result (err_message) + function load_o3clim(this, file, fileID) result (err_message) class(ty_ozphys), intent(inout) :: this integer, intent(in) :: fileID character(len=*), intent(in) :: file @@ -432,12 +432,12 @@ function load_clim(this, file, fileID) result (err_message) this%pkstr(iLev) = fpkapx(this%pstr(iLev)*100.0) enddo - end function load_clim + end function load_o3clim ! ######################################################################################### ! Procedure (type-bound) for updating ozone climotological data. ! ######################################################################################### - subroutine update_clim(this, imon, iday, ihour, loz1st) + subroutine update_o3clim(this, imon, iday, ihour, loz1st) class(ty_ozphys), intent(inout) :: this integer, intent(in) :: imon, iday, ihour logical, intent(in) :: loz1st @@ -471,6 +471,6 @@ subroutine update_clim(this, imon, iday, ihour, loz1st) this%facoz = float(id - midm) / float(midp - midm) - end subroutine update_clim + end subroutine update_o3clim end module module_ozphys From d0a4bfd63fae9f4e4a06cb5598049f1019aed945 Mon Sep 17 00:00:00 2001 From: dustinswales Date: Wed, 27 Sep 2023 15:50:51 -0600 Subject: [PATCH 350/380] Remove ozphysics modules. Now part of ty_ozphys --- physics/ozphys_2015.F90 | 167 --------------------------------------- physics/ozphys_2015.meta | 140 -------------------------------- 2 files changed, 307 deletions(-) delete mode 100644 physics/ozphys_2015.F90 delete mode 100644 physics/ozphys_2015.meta diff --git a/physics/ozphys_2015.F90 b/physics/ozphys_2015.F90 deleted file mode 100644 index 1478d0d6e..000000000 --- a/physics/ozphys_2015.F90 +++ /dev/null @@ -1,167 +0,0 @@ -! ########################################################################################### -!> \file ozphys_2015.F90 -!! -! ########################################################################################### -module ozphys_2015 - use machine, only: kind_phys, kind_dbl_prec, kind_sngl_prec - use module_ozphys, only: ty_ozphys - implicit none - public ozphys_2015_run -contains - -! ########################################################################################### -!>\defgroup GFS_ozphys_2015 GFS Ozone Photochemistry (2015) Module -!! This module contains the CCPP-compliant Ozone 2015 photochemistry scheme. -!> @{ -!> The operational GFS currently parameterizes ozone production and destruction based on -!! monthly mean coefficients ( \c ozprdlos_2015_new_sbuvO3_tclm15_nuchem.f77) provided by -!! Naval Research Laboratory through CHEM2D chemistry model -!! (McCormack et al. (2006) \cite mccormack_et_al_2006). -!! (https://doi.org/10.5194/acp-6-4943-2006) -!! -!> \section genal_ozphys_2015 GFS ozphys_2015_run General Algorithm -!> - This code assumes that both 2D fields are ordered from bottom to top. -!> - This code is specifically for NRL parameterization and climatological T and O3 are in -! location 5 and 6 of ozpl array -!!\author June 2015 - Shrinivas Moorthi -!!\modified May 2023 - Dustin Swales -! ########################################################################################### - -! ########################################################################################### -! SUBROUTINE ozphys_2015_run -! ########################################################################################### -!! \section arg_table_ozphys_2015_run Argument Table -!! \htmlinclude ozphys_2015_run.html -!! - subroutine ozphys_2015_run (oz_phys, ozphys, nCol, nLev, dt, oz, tin, prsl, ozpl, & - delp, con_1ovg, do3_dt_prd, do3_dt_ozmx, do3_dt_temp, do3_dt_ohoz, errmsg, errflg) - - ! Inputs - logical, intent(in) :: & - oz_phys ! Flag for ozone_physics_2015 scheme. - type(ty_ozphys),intent(in) :: & - ozphys - real(kind_phys),intent(in) :: & - con_1ovg ! Physical constant: One divided by gravitational acceleration (m-1 s2) - integer, intent(in) :: & - nCol, & ! Horizontal dimension - nLev ! Number of vertical layers - real(kind_phys), intent(in) :: & - dt ! Physics timestep (seconds) - real(kind_phys), intent(in), dimension(:,:) :: & - prsl, & ! Air-pressure (Pa) - tin, & ! Temperature of new-state (K) - delp ! Difference between mid-layer pressures (Pa) - real(kind_phys), intent(in), dimension(:,:,:) :: & - ozpl ! Ozone forcing data - - ! Outputs (optional) - real(kind=kind_phys), intent(inout), dimension(:,:), pointer, optional :: & - do3_dt_prd, & ! Physics tendency: production and loss effect - do3_dt_ozmx, & ! Physics tendency: ozone mixing ratio effect - do3_dt_temp, & ! Physics tendency: temperature effect - do3_dt_ohoz ! Physics tendency: overhead ozone effect - - ! Outputs - real(kind=kind_phys), intent(inout), dimension(:,:) :: & - oz ! Ozone concentration updated by physics - character(len=*), intent(out) :: & - errmsg ! CCPP error message - integer, intent(out) :: & - errflg ! CCPP error flag - - ! Locals - integer :: k, kmax, kmin, l, i, j - logical, dimension(nCol) :: flg - real(kind_phys) :: pmax, pmin, tem, temp - real(kind_phys), dimension(nCol) :: wk1, wk2, wk3, ozib - real(kind_phys), dimension(nCol,ozphys%ncf) :: prod - real(kind_phys), dimension(nCol,nLev) :: ozi - real(kind_phys), dimension(nCol,nLev+1) :: colo3, coloz - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - ! Sanity checks - if (.not.oz_phys) then - write (errmsg,'(*(a))') 'Logic error: oz_phys_2015 == .false.' - errflg = 1 - return - endif - - ! Temporaries - ozi = oz - - colo3(:,nLev+1) = 0.0 - coloz(:,nLev+1) = 0.0 - - do l=nLev,1,-1 - pmin = 1.0e10 - pmax = -1.0e10 - - do i=1,nCol - wk1(i) = log(prsl(i,l)) - pmin = min(wk1(i), pmin) - pmax = max(wk1(i), pmax) - prod(i,:) = 0.0 - enddo - kmax = 1 - kmin = 1 - do k=1,ozphys%nlev-1 - if (pmin < ozphys%po3(k)) kmax = k - if (pmax < ozphys%po3(k)) kmin = k - enddo - ! - do k=kmin,kmax - temp = 1.0 / (ozphys%po3(k) - ozphys%po3(k+1)) - do i=1,nCol - flg(i) = .false. - if (wk1(i) < ozphys%po3(k) .and. wk1(i) >= ozphys%po3(k+1)) then - flg(i) = .true. - wk2(i) = (wk1(i) - ozphys%po3(k+1)) * temp - wk3(i) = 1.0 - wk2(i) - endif - enddo - do j=1,ozphys%ncf - do i=1,nCol - if (flg(i)) then - prod(i,j) = wk2(i) * ozpl(i,k,j) + wk3(i) * ozpl(i,k+1,j) - endif - enddo - enddo - enddo - - do j=1,ozphys%ncf - do i=1,nCol - if (wk1(i) < ozphys%po3(ozphys%nlev)) then - prod(i,j) = ozpl(i,ozphys%nlev,j) - endif - if (wk1(i) >= ozphys%po3(1)) then - prod(i,j) = ozpl(i,1,j) - endif - enddo - enddo - do i=1,nCol - colo3(i,l) = colo3(i,l+1) + ozi(i,l) * delp(i,l)*con_1ovg - coloz(i,l) = coloz(i,l+1) + prod(i,6) * delp(i,l)*con_1ovg - prod(i,2) = min(prod(i,2), 0.0) - enddo - do i=1,nCol - ozib(i) = ozi(i,l) ! no filling - tem = prod(i,1) - prod(i,2) * prod(i,6) + prod(i,3) * (tin(i,l) - prod(i,5)) & - + prod(i,4) * (colo3(i,l)-coloz(i,l)) - oz(i,l) = (ozib(i) + tem*dt) / (1.0 - prod(i,2)*dt) - enddo - - ! Diagnostics (optional) - if (associated(do3_dt_prd)) do3_dt_prd(:,l) = (prod(:,1)-prod(:,2)*prod(:,6))*dt - if (associated(do3_dt_ozmx)) do3_dt_ozmx(:,l) = (oz(:,l) - ozib(:)) - if (associated(do3_dt_temp)) do3_dt_temp(:,l) = prod(:,3)*(tin(:,l)-prod(:,5))*dt - if (associated(do3_dt_ohoz)) do3_dt_ohoz(:,l) = prod(:,4) * (colo3(:,l)-coloz(:,l))*dt - enddo - - return - end subroutine ozphys_2015_run -!> @} -end module ozphys_2015 diff --git a/physics/ozphys_2015.meta b/physics/ozphys_2015.meta deleted file mode 100644 index ca2d56e4e..000000000 --- a/physics/ozphys_2015.meta +++ /dev/null @@ -1,140 +0,0 @@ -[ccpp-table-properties] - name = ozphys_2015 - type = scheme - dependencies = machine.F,module_ozphys.F90 - -######################################################################## -[ccpp-arg-table] - name = ozphys_2015_run - type = scheme -[oz_phys] - standard_name = flag_for_nrl_2015_ozone_scheme - long_name = flag for new (2015) ozone physics - units = flag - dimensions = () - type = logical - intent = in -[ozphys] - standard_name = dataset_for_ozone_physics - long_name = dataset for NRL ozone physics - units = mixed - dimensions = () - type = ty_ozphys - intent = in -[nCol] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[nLev] - standard_name = vertical_layer_dimension - long_name = number of vertical layers - units = count - dimensions = () - type = integer - intent = in -[dt] - standard_name = timestep_for_physics - long_name = physics time step - units = s - dimensions = () - type = real - kind = kind_phys - intent = in -[oz] - standard_name = ozone_concentration_of_new_state - long_name = ozone concentration updated by physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[tin] - standard_name = air_temperature_of_new_state - long_name = updated air temperature - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[prsl] - standard_name = air_pressure - long_name = mid-layer pressure - units = Pa - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[ozpl] - standard_name = ozone_forcing - long_name = ozone forcing data - units = mixed - dimensions = (horizontal_loop_extent,number_of_levels_in_ozone_data,number_of_coefficients_in_ozone_data) - type = real - kind = kind_phys - intent = in -[delp] - standard_name = air_pressure_difference_between_midlayers - long_name = difference between mid-layer pressures - units = Pa - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[con_1ovg] - standard_name = one_divided_by_the_gravitational_acceleration - long_name = inverse of gravitational acceleration - units = s2 m-1 - dimensions = () - type = real - kind = kind_phys - intent = in -[do3_dt_prd] - standard_name = ozone_tendency_due_to_production_and_loss_rate - long_name = ozone tendency due to production and loss rate - units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[do3_dt_ozmx] - standard_name = ozone_tendency_due_to_ozone_mixing_ratio - long_name = ozone tendency due to ozone mixing ratio - units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[do3_dt_temp] - standard_name = ozone_tendency_due_to_temperature - long_name = ozone tendency due to temperature - units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[do3_dt_ohoz] - standard_name = ozone_tendency_due_to_overhead_ozone_column - long_name = ozone tendency due to overhead ozone column - units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out From 385ef4e2802a838fd3099b17ee479ebaae1a6402 Mon Sep 17 00:00:00 2001 From: dustinswales Date: Wed, 27 Sep 2023 22:19:36 -0600 Subject: [PATCH 351/380] Some polishing. Merge 2006 ozone into module_ozphys --- physics/GFS_phys_time_vary.fv3.F90 | 69 ++++----- physics/GFS_suite_stateout_update.F90 | 3 +- physics/module_ozphys.F90 | 127 +++++++++++++++- physics/ozphys.f | 211 -------------------------- physics/ozphys.meta | 208 ------------------------- 5 files changed, 158 insertions(+), 460 deletions(-) delete mode 100644 physics/ozphys.f delete mode 100644 physics/ozphys.meta diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index 70eeb81e1..cd1f8287a 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -802,38 +802,6 @@ subroutine GFS_phys_time_vary_timestep_init ( return end if - !> - Compute temporal interpolation indices for updating gas concentrations. - idat=0 - idat(1)=idate(4) - idat(2)=idate(2) - idat(3)=idate(3) - idat(5)=idate(1) - rinc=0. - rinc(2)=fhour - call w3kind(w3kindreal,w3kindint) - if(w3kindreal==4) then - rinc4=rinc - CALL w3movdat(rinc4,idat,jdat) - else - CALL w3movdat(rinc,idat,jdat) - endif - jdow = 0 - jdoy = 0 - jday = 0 - call w3doxdat(jdat,jdow,jdoy,jday) - rjday = jdoy + jdat(5) / 24. - if (rjday < ozphys%time(1)) rjday = rjday + 365. - - n2 = ozphys%ntime + 1 - do j=2,ozphys%ntime - if (rjday < ozphys%time(j)) then - n2 = j - exit - endif - enddo - n1 = n2 - 1 - if (n2 > ozphys%ntime) n2 = n2 - ozphys%ntime - !$OMP parallel num_threads(nthrds) default(none) & !$OMP shared(kdt,nsswr,lsswr,clstp,imfdeepcnv,cal_pre,random_clds) & !$OMP shared(fhswr,fhour,seed0,cnx,cny,nrcm,wrk,rannie,rndval) & @@ -841,8 +809,9 @@ subroutine GFS_phys_time_vary_timestep_init ( !$OMP shared(ozpl,ddy_o3,h2o_phys,jindx1_h,jindx2_h,h2opl,ddy_h,iaerclm,master) & !$OMP shared(levs,prsl,iccn,jindx1_ci,jindx2_ci,ddy_ci,iindx1_ci,iindx2_ci) & !$OMP shared(ddx_ci,in_nm,ccn_nm,do_ugwp_v1,jindx1_tau,jindx2_tau,ddy_j1tau) & -!$OMP shared(ddy_j2tau,tau_amf,iflip,ozphys) & -!$OMP private(iseed,iskip,i,j,k,rjday,n1,n2) +!$OMP shared(ddy_j2tau,tau_amf,iflip,ozphys,rjday,n1,n2,idat,jdat,rinc,rinc4) & +!$OMP shared(w3kindreal,w3kindint,jdow,jdoy,jday) & +!$OMP private(iseed,iskip,i,j,k) !$OMP sections @@ -892,6 +861,38 @@ subroutine GFS_phys_time_vary_timestep_init ( endif ! imfdeepcnv, cal_re, random_clds !$OMP section + !> - Compute temporal interpolation indices for updating gas concentrations. + idat=0 + idat(1)=idate(4) + idat(2)=idate(2) + idat(3)=idate(3) + idat(5)=idate(1) + rinc=0. + rinc(2)=fhour + call w3kind(w3kindreal,w3kindint) + if(w3kindreal==4) then + rinc4=rinc + CALL w3movdat(rinc4,idat,jdat) + else + CALL w3movdat(rinc,idat,jdat) + endif + jdow = 0 + jdoy = 0 + jday = 0 + call w3doxdat(jdat,jdow,jdoy,jday) + rjday = jdoy + jdat(5) / 24. + if (rjday < ozphys%time(1)) rjday = rjday + 365. + + n2 = ozphys%ntime + 1 + do j=2,ozphys%ntime + if (rjday < ozphys%time(j)) then + n2 = j + exit + endif + enddo + n1 = n2 - 1 + if (n2 > ozphys%ntime) n2 = n2 - ozphys%ntime + !> - Update ozone concentration. if (ntoz > 0) then call ozphys%update_o3prog(jindx1_o3, jindx2_o3, ddy_o3, rjday, n1, n2, ozpl) diff --git a/physics/GFS_suite_stateout_update.F90 b/physics/GFS_suite_stateout_update.F90 index 41f44e0de..e9e477fce 100644 --- a/physics/GFS_suite_stateout_update.F90 +++ b/physics/GFS_suite_stateout_update.F90 @@ -69,7 +69,8 @@ subroutine GFS_suite_stateout_update_run (im, levs, ntrac, dtp, tgrs, ugrs, vgrs do3_dt_ozmx, do3_dt_temp, do3_dt_ohoz) endif if (oz_phys_2006) then - call ozphys%run_o3prog_2006() + call ozphys%run_o3prog_2006(con_1ovg, dtp, prsl, gt0, dp, ozpl, oz0, do3_dt_prd, & + do3_dt_ozmx, do3_dt_temp, do3_dt_ohoz) endif ! If using Ferrier-Aligo microphysics, set bounds on the mass-weighted rime factor. diff --git a/physics/module_ozphys.F90 b/physics/module_ozphys.F90 index 205a02b46..d24585d4d 100644 --- a/physics/module_ozphys.F90 +++ b/physics/module_ozphys.F90 @@ -162,12 +162,12 @@ end subroutine update_o3prog ! ######################################################################################### ! Procedure (type-bound) for NRL prognostic ozone (2015). ! ######################################################################################### - subroutine run_o3prog_2015(this, con_1ovg, dt, p, t, dp, ozpl, oz, do3_dt_prd, do3_dt_ozmx, & - do3_dt_temp, do3_dt_ohoz) + subroutine run_o3prog_2015(this, con_1ovg, dt, p, t, dp, ozpl, oz, do3_dt_prd, & + do3_dt_ozmx, do3_dt_temp, do3_dt_ohoz) class(ty_ozphys), intent(in) :: this - real(kind_phys),intent(in) :: & + real(kind_phys), intent(in) :: & con_1ovg ! Physical constant: One divided by gravitational acceleration (m-1 s2) - real(kind_phys), intent(in) :: & + real(kind_phys), intent(in) :: & dt ! Model timestep (sec) real(kind_phys), intent(in), dimension(:,:) :: & p, & ! Model Pressure (Pa) @@ -253,7 +253,7 @@ subroutine run_o3prog_2015(this, con_1ovg, dt, p, t, dp, ozpl, oz, do3_dt_prd, d prod(iCol,2) = min(prod(iCol,2), 0.0) enddo do iCol=1,nCol - ozib(iCol) = ozi(iCol,iLev) ! no filling + ozib(iCol) = ozi(iCol,iLev) tem = prod(iCol,1) - prod(iCol,2) * prod(iCol,6) & + prod(iCol,3) * (t(iCol,iLev) - prod(iCol,5)) & + prod(iCol,4) * (colo3(iCol,iLev)-coloz(iCol,iLev)) @@ -273,8 +273,123 @@ end subroutine run_o3prog_2015 ! ######################################################################################### ! Procedure (type-bound) for NRL prognostic ozone (2006). ! ######################################################################################### - subroutine run_o3prog_2006(this) + subroutine run_o3prog_2006(this, con_1ovg, dt, p, t, dp, ozpl, oz, do3_dt_prd, & + do3_dt_ozmx, do3_dt_temp, do3_dt_ohoz) class(ty_ozphys), intent(in) :: this + real(kind_phys), intent(in) :: & + con_1ovg ! Physical constant: One divided by gravitational acceleration (m-1 s2) + real(kind_phys), intent(in) :: & + dt ! Model timestep (sec) + real(kind_phys), intent(in), dimension(:,:) :: & + p, & ! Model Pressure (Pa) + t, & ! Model temperature (K) + dp ! Model layer thickness (Pa) + real(kind_phys), intent(in), dimension(:,:,:) :: & + ozpl ! Ozone forcing data + real(kind_phys), intent(inout), dimension(:,:) :: & + oz ! Ozone concentration updated by physics + real(kind_phys), intent(inout), dimension(:,:), pointer, optional :: & + do3_dt_prd, & ! Physics tendency: production and loss effect + do3_dt_ozmx, & ! Physics tendency: ozone mixing ratio effect + do3_dt_temp, & ! Physics tendency: temperature effect + do3_dt_ohoz ! Physics tendency: overhead ozone effect + + ! Locals + integer :: k, kmax, kmin, iLev, iCol, nCol, nLev, iCf + logical, dimension(size(p,1)) :: flg + real(kind_phys) :: pmax, pmin, tem, temp + real(kind_phys), dimension(size(p,1)) :: wk1, wk2, wk3, ozib + real(kind_phys), dimension(size(p,1),this%ncf) :: prod + real(kind_phys), dimension(size(p,1),size(p,2)) :: ozi + real(kind_phys), dimension(size(p,1),size(p,2)+1) :: colo3, coloz + + ! Dimensions + nCol = size(p,1) + nLev = size(p,2) + + ! Temporaries + ozi = oz + + !> - Calculate vertical integrated column ozone values. + if (this%ncf > 2) then + colo3(:,nLev+1) = 0.0 + do iLev=nLev,1,-1 + do iCol=1,nCol + colo3(iCol,iLev) = colo3(iCol,iLev+1) + ozi(iCol,iLev) * dp(iCol,iLev) * con_1ovg + enddo + enddo + endif + + !> - Apply vertically linear interpolation to the ozone coefficients. + do iLev=1,nLev + pmin = 1.0e10 + pmax = -1.0e10 + + do iCol=1,nCol + wk1(iCol) = log(p(iCol,iLev)) + pmin = min(wk1(iCol), pmin) + pmax = max(wk1(iCol), pmax) + prod(iCol,:) = 0._kind_phys + enddo + kmax = 1 + kmin = 1 + do k=1,this%nlev-1 + if (pmin < this%po3(k)) kmax = k + if (pmax < this%po3(k)) kmin = k + enddo + + do k=kmin,kmax + temp = 1.0 / (this%po3(k) - this%po3(k+1)) + do iCol=1,nCol + flg(iCol) = .false. + if (wk1(iCol) < this%po3(k) .and. wk1(iCol) >= this%po3(k+1)) then + flg(iCol) = .true. + wk2(iCol) = (wk1(iCol) - this%po3(k+1)) * temp + wk3(iCol) = 1.0 - wk2(iCol) + endif + enddo + do iCf=1,this%ncf + do iCol=1,nCol + if (flg(iCol)) then + prod(iCol,iCf) = wk2(iCol) * ozpl(iCol,k,iCf) + wk3(iCol) * ozpl(iCol,k+1,iCf) + endif + enddo + enddo + enddo + + do iCf=1,this%ncf + do iCol=1,nCol + if (wk1(iCol) < this%po3(this%nlev)) then + prod(iCol,iCf) = ozpl(iCol,this%nlev,iCf) + endif + if (wk1(iCol) >= this%po3(1)) then + prod(iCol,iCf) = ozpl(iCol,1,iCf) + endif + enddo + enddo + + if (this%ncf == 2) then + do iCol=1,nCol + ozib(iCol) = ozi(iCol,iLev) + oz(iCol,iLev) = (ozib(iCol) + prod(iCol,1)*dt) / (1.0 + prod(iCol,2)*dt) + enddo + endif + + if (this%ncf == 4) then + do iCol=1,nCol + ozib(iCol) = ozi(iCol,iLev) + tem = prod(iCol,1) + prod(iCol,3)*t(iCol,iLev) + prod(iCol,4)*colo3(iCol,iLev+1) + oz(iCol,iLev) = (ozib(iCol) + tem*dt) / (1.0 + prod(iCol,2)*dt) + enddo + endif + ! Diagnostics (optional) + if (associated(do3_dt_prd)) do3_dt_prd(:,iLev) = prod(:,1)*dt + if (associated(do3_dt_ozmx)) do3_dt_ozmx(:,iLev) = (oz(:,iLev) - ozib(:)) + if (associated(do3_dt_temp)) do3_dt_temp(:,iLev) = prod(:,3) * t(:,iLev) * dt + if (associated(do3_dt_ohoz)) do3_dt_ohoz(:,iLev) = prod(:,4) * colo3(:,iLev) * dt + + enddo + return end subroutine run_o3prog_2006 diff --git a/physics/ozphys.f b/physics/ozphys.f deleted file mode 100644 index 18a9ae46f..000000000 --- a/physics/ozphys.f +++ /dev/null @@ -1,211 +0,0 @@ -!> \file ozphys.f -!! This file is ozone sources and sinks (previous version). - - -!> This module contains the CCPP-compliant Ozone photochemistry scheme. - module ozphys - - contains - -! \brief Brief description of the subroutine -! -!> \section arg_table_ozphys_init Argument Table -!! \htmlinclude ozphys_init.html -!! - subroutine ozphys_init(oz_phys, errmsg, errflg) - - implicit none - logical, intent(in) :: oz_phys - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (.not.oz_phys) then - write (errmsg,'(*(a))') 'Logic error: oz_phys == .false.' - errflg = 1 - return - endif - - end subroutine ozphys_init - -!>\defgroup GFS_ozphys GFS ozphys Main -!! \brief The operational GFS currently parameterizes ozone production and -!! destruction based on monthly mean coefficients (\c global_o3prdlos.f77) provided by Naval -!! Research Laboratory through CHEM2D chemistry model -!! (McCormack et al. (2006) \cite mccormack_et_al_2006). -!! \section arg_table_ozphys_run Argument Table -!! \htmlinclude ozphys_run.html -!! -!> \section genal_ozphys GFS ozphys_run General Algorithm -!> @{ - subroutine ozphys_run ( & - & im, levs, ko3, dt, oz, tin, po3, & - & prsl, prdout, oz_coeff, delp, ldiag3d, & - & ntoz, dtend, dtidx, index_of_process_prod_loss, & - & index_of_process_ozmix, index_of_process_temp, & - & index_of_process_overhead_ozone, con_g, me, errmsg, errflg) -! -! this code assumes that both prsl and po3 are from bottom to top -! as are all other variables -! - use machine , only : kind_phys - implicit none -! - ! Interface variables - integer, intent(in) :: im, levs, ko3, oz_coeff, me - real(kind=kind_phys), intent(inout) :: oz(:,:) - real(kind=kind_phys), intent(inout) :: dtend(:,:,:) - integer, intent(in) :: dtidx(:,:), ntoz, & - & index_of_process_prod_loss, index_of_process_ozmix, & - & index_of_process_temp, index_of_process_overhead_ozone - real(kind=kind_phys), intent(in) :: & - & dt, po3(:), prdout(:,:,:), & - & prsl(:,:), tin(:,:), delp(:,:), & - & con_g - real :: gravi - logical, intent(in) :: ldiag3d - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg -! - ! Local variables - integer k,kmax,kmin,l,i,j, idtend(4) - logical flg(im) - real(kind=kind_phys) pmax, pmin, tem, temp - real(kind=kind_phys) wk1(im), wk2(im), wk3(im), prod(im,oz_coeff), - & ozib(im), colo3(im,levs+1), ozi(im,levs) -! - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 -! -! save input oz in ozi - ozi = oz - gravi=1.0/con_g - - - if(ldiag3d) then - idtend(1) = dtidx(100+ntoz,index_of_process_prod_loss) ! was ozp1 - idtend(2) = dtidx(100+ntoz,index_of_process_ozmix) ! was ozp2 - idtend(3) = dtidx(100+ntoz,index_of_process_temp) ! was ozp3 - idtend(4) = dtidx(100+ntoz,index_of_process_overhead_ozone) ! was ozp4 - else - idtend=0 - endif - -! -!> - Calculate vertical integrated column ozone values. - if (oz_coeff > 2) then - colo3(:,levs+1) = 0.0 - do l=levs,1,-1 - do i=1,im - colo3(i,l) = colo3(i,l+1) + ozi(i,l) * delp(i,l) * gravi - enddo - enddo - endif -! -!> - Apply vertically linear interpolation to the ozone coefficients. - do l=1,levs - pmin = 1.0e10 - pmax = -1.0e10 -! - do i=1,im - wk1(i) = log(prsl(i,l)) - pmin = min(wk1(i), pmin) - pmax = max(wk1(i), pmax) - prod(i,:) = 0.0 - enddo - kmax = 1 - kmin = 1 - do k=1,ko3-1 - if (pmin < po3(k)) kmax = k - if (pmax < po3(k)) kmin = k - enddo -! - do k=kmin,kmax - temp = 1.0 / (po3(k) - po3(k+1)) - do i=1,im - flg(i) = .false. - if (wk1(i) < po3(k) .and. wk1(i) >= po3(k+1)) then - flg(i) = .true. - wk2(i) = (wk1(i) - po3(k+1)) * temp - wk3(i) = 1.0 - wk2(i) - endif - enddo - do j=1,oz_coeff - do i=1,im - if (flg(i)) then - prod(i,j) = wk2(i) * prdout(i,k,j) - & + wk3(i) * prdout(i,k+1,j) - endif - enddo - enddo - enddo -! - do j=1,oz_coeff - do i=1,im - if (wk1(i) < po3(ko3)) then - prod(i,j) = prdout(i,ko3,j) - endif - if (wk1(i) >= po3(1)) then - prod(i,j) = prdout(i,1,j) - endif - enddo - enddo - - if (oz_coeff == 2) then - do i=1,im - ozib(i) = ozi(i,l) ! no filling - oz(i,l) = (ozib(i) + prod(i,1)*dt) / (1.0 + prod(i,2)*dt) - enddo -! - if(idtend(1)>=1) then - dtend(:,l,idtend(1)) = dtend(:,l,idtend(1)) + ! was ozp1 - & prod(:,1)*dt - endif - if(idtend(2)>=1) then - dtend(:,l,idtend(2)) = dtend(:,l,idtend(2)) + ! was ozp2 - & (oz(:,l) - ozib(:)) - endif - endif -!> - Calculate the 4 terms of prognostic ozone change during time \a dt: -!! - ozp1(:,:) - Ozone production from production/loss ratio -!! - ozp2(:,:) - Ozone production from ozone mixing ratio -!! - ozp3(:,:) - Ozone production from temperature term at model layers -!! - ozp4(:,:) - Ozone production from column ozone term at model layers - if (oz_coeff == 4) then - do i=1,im - ozib(i) = ozi(i,l) ! no filling - tem = prod(i,1) + prod(i,3)*tin(i,l) - & + prod(i,4)*colo3(i,l+1) -! if (me .eq. 0) print *,'ozphys tem=',tem,' prod=',prod(i,:) -! &,' ozib=',ozib(i),' l=',l,' tin=',tin(i,l),'colo3=',colo3(i,l+1) - oz(i,l) = (ozib(i) + tem*dt) / (1.0 + prod(i,2)*dt) - enddo - if(idtend(1)>=1) then - dtend(:,l,idtend(1)) = dtend(:,l,idtend(1)) + ! was ozp1 - & prod(:,1)*dt - endif - if(idtend(2)>=1) then - dtend(:,l,idtend(2)) = dtend(:,l,idtend(2)) + ! was ozp2 - & (oz(:,l)-ozib(:)) - endif - if(idtend(3)>=1) then - dtend(:,l,idtend(3)) = dtend(:,l,idtend(3)) + ! was ozp3 - & prod(:,3)*tin(:,l)*dt - endif - if(idtend(4)>=1) then - dtend(:,l,idtend(4)) = dtend(:,l,idtend(4)) + ! was ozp4 - & prod(:,4)*colo3(:,l+1)*dt - endif - endif - enddo ! vertical loop -! - return - end subroutine ozphys_run -!> @} - - end module ozphys diff --git a/physics/ozphys.meta b/physics/ozphys.meta deleted file mode 100644 index 485e2a491..000000000 --- a/physics/ozphys.meta +++ /dev/null @@ -1,208 +0,0 @@ -[ccpp-table-properties] - name = ozphys - type = scheme - dependencies = machine.F - -######################################################################## -[ccpp-arg-table] - name = ozphys_init - type = scheme -[oz_phys] - standard_name = flag_for_nrl_2006_ozone_scheme - long_name = flag for old (2006) ozone physics - units = flag - dimensions = () - type = logical - intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - -######################################################################## -[ccpp-arg-table] - name = ozphys_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in -[levs] - standard_name = vertical_layer_dimension - long_name = number of vertical layers - units = count - dimensions = () - type = integer - intent = in -[ko3] - standard_name = vertical_dimension_of_ozone_forcing_data - long_name = number of vertical layers in ozone forcing data - units = count - dimensions = () - type = integer - intent = in -[dt] - standard_name = timestep_for_physics - long_name = physics time step - units = s - dimensions = () - type = real - kind = kind_phys - intent = in -[oz] - standard_name = ozone_concentration_of_new_state - long_name = ozone concentration updated by physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[tin] - standard_name = air_temperature_of_new_state - long_name = updated air temperature - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[po3] - standard_name = natural_log_of_ozone_forcing_data_pressure_levels - long_name = natural log of ozone forcing data pressure levels - units = 1 - dimensions = (vertical_dimension_of_ozone_forcing_data) - type = real - kind = kind_phys - intent = in -[prsl] - standard_name = air_pressure - long_name = mid-layer pressure - units = Pa - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[prdout] - standard_name = ozone_forcing - long_name = ozone forcing coefficients - units = mixed - dimensions = (horizontal_loop_extent,vertical_dimension_of_ozone_forcing_data,number_of_coefficients_in_ozone_forcing_data) - type = real - kind = kind_phys - intent = in -[oz_coeff] - standard_name = number_of_coefficients_in_ozone_forcing_data - long_name = number of coefficients in ozone forcing data - units = index - dimensions = () - type = integer - intent = in -[delp] - standard_name = air_pressure_difference_between_midlayers - long_name = difference between mid-layer pressures - units = Pa - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[ldiag3d] - standard_name = flag_for_diagnostics_3D - long_name = flag for calculating 3-D diagnostic fields - units = flag - dimensions = () - type = logical - intent = in -[dtend] - standard_name = cumulative_change_of_state_variables - long_name = diagnostic tendencies for state variables - units = mixed - dimensions = (horizontal_loop_extent,vertical_layer_dimension,cumulative_change_of_state_variables_outer_index_max) - type = real - kind = kind_phys - active = (flag_for_diagnostics_3D) - intent = inout -[dtidx] - standard_name = cumulative_change_of_state_variables_outer_index - long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index - units = index - dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes) - type = integer - intent = in -[ntoz] - standard_name = index_of_ozone_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for ozone mixing ratio - units = index - dimensions = () - type = integer - intent = in -[index_of_process_prod_loss] - standard_name = index_of_production_and_loss_process_in_cumulative_change_index - long_name = index of production and loss effect in photochemistry process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_process_ozmix] - standard_name = index_of_ozone_mixing_ratio_process_in_cumulative_change_index - long_name = index of ozone mixing ratio effect in photochemistry process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_process_temp] - standard_name = index_of_temperature_process_in_cumulative_change_index - long_name = index of temperature effect in photochemistry process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_process_overhead_ozone] - standard_name = index_of_overhead_process_in_cumulative_change_index - long_name = index of overhead ozone effect in photochemistry process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[con_g] - standard_name = gravitational_acceleration - long_name = gravitational acceleration - units = m s-2 - dimensions = () - type = real - kind = kind_phys - intent = in -[me] - standard_name = mpi_rank - long_name = rank of the current MPI task - units = index - dimensions = () - type = integer - intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out From a55ce5e69e85d93e6b28b303a92c9ad7087aad08 Mon Sep 17 00:00:00 2001 From: "Samuel Trahan (NOAA contractor)" <39415369+SamuelTrahanNOAA@users.noreply.github.com> Date: Thu, 28 Sep 2023 12:09:44 -0400 Subject: [PATCH 352/380] z => dz --- physics/clm_lake.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/clm_lake.f90 b/physics/clm_lake.f90 index da4712810..620f79a96 100644 --- a/physics/clm_lake.f90 +++ b/physics/clm_lake.f90 @@ -551,7 +551,7 @@ SUBROUTINE clm_lake_run( & do c = 2,column z_lake(c,:) = z_lake(1,:) - dz_lake(c,:) = z_lake(1,:) + dz_lake(c,:) = dz_lake(1,:) enddo ! Soil hydraulic and thermal properties From 00d90608a08f13ac367f2c002b8ae18eea4e8f6b Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Thu, 28 Sep 2023 17:19:33 +0000 Subject: [PATCH 353/380] Added documentation --- physics/GFS_physics_post.F90 | 12 +++- physics/module_ozphys.F90 | 119 +++++++++++++++++++++++------------ 2 files changed, 87 insertions(+), 44 deletions(-) diff --git a/physics/GFS_physics_post.F90 b/physics/GFS_physics_post.F90 index d034c1999..e6a50cc3a 100644 --- a/physics/GFS_physics_post.F90 +++ b/physics/GFS_physics_post.F90 @@ -1,6 +1,11 @@ ! ########################################################################################### !> \file GFS_physics_post.F90 !! +!! This module contains GFS specific calculations (e.g. diagnostics) and suite specific +!! code (e.g Saving fields for subsequent physics timesteps). For interoperability across a +!! wide range of hosts, CCPP compliant schemes should avoid including such calculations. This +!! module/scheme is intended for such "host-specific" computations. +!! ! ########################################################################################### module GFS_physics_post use machine, only : kind_phys, kind_dbl_prec, kind_sngl_prec @@ -30,9 +35,10 @@ end subroutine GFS_physics_post_init !! \section arg_table_GFS_physics_post_run Argument Table !! \htmlinclude GFS_physics_post_run.html !! - subroutine GFS_physics_post_run(nCol, nLev, ntoz, dtidx, ip_prod_loss, ip_ozmix, & - ip_temp, ip_overhead_ozone, do3_dt_prd, do3_dt_ozmx, do3_dt_temp, do3_dt_ohoz, dtend,& - errmsg, errflg) + subroutine GFS_physics_post_run(nCol, nLev, ntoz, dtidx, ip_prod_loss, ip_ozmix, ip_temp, & + ip_overhead_ozone, do3_dt_prd, do3_dt_ozmx, do3_dt_temp, do3_dt_ohoz, dtend, errmsg, & + errflg) + ! Inputs integer, intent(in) :: & nCol, & ! Horizontal dimension diff --git a/physics/module_ozphys.F90 b/physics/module_ozphys.F90 index d24585d4d..f824736b1 100644 --- a/physics/module_ozphys.F90 +++ b/physics/module_ozphys.F90 @@ -2,6 +2,39 @@ !> \section arg_table_module_ozphys Argument table !! \htmlinclude module_ozphys.html !! +! +!> The operational GFS currently parameterizes ozone production and destruction based on +!! monthly mean coefficients (\c global_o3prdlos.f77) provided by Naval Research Laboratory +!! through CHEM2D chemistry model (McCormack et al. (2006) \cite mccormack_et_al_2006). +!! +!! There are two implementations of this parameterization within this module. +!! run_o3prog_2006 - Relies on either two/four mean monthly coefficients. This is explained +!! in (https://doi.org/10.5194/acp-6-4943-2006. See Eq.(4)). +!! run_o3prog_2015 - Relies on six mean monthly coefficients, specifically for NRL +!! parameterization and climatological T and O3 are in location 5 and 6 of +!! the coefficient array. +!! +!! Both of these rely on the scheme being setup correctly by invoking the load(), setup(), +!! and update() procedures prior to calling the run() procedure. +!! +!! load_o3prog() - Read in data and load into type ty_ozphys (called once from host) +!! setup_o3prog() - Create spatial interpolation indices (called once, after model grid is known) +!! update_o3prog() - Update ozone concentration in time (call in physics loop, before run()) +!! *CAVEAT* Since the radiation is often run at a lower temporal resolution +!! than the rest of the physics, update_o3prog() needs to be +!! called before the radiation, which is called before the physics. +!! For example, within the physics loop: +!! update_o3prog() -> radiation() -> run_o3prog() -> physics.... +!! +!! Additionally, there is the functionality to not use interactive ozone, instead reverting +!! to ozone climatology. In this case, analagous to when using prognostic ozone, there are +!! update() and run() procedures that need to be called before the radiation. +!! For example, within the physics loop: +!! update_o3clim() -> run_o3clim() -> radiation() -> physics... +!! +!!\author June 2015 - Shrinivas Moorthi +!!\modified Sep 2023 - Dustin Swales +!! ! ######################################################################################### module module_ozphys use machine, only : kind_phys @@ -14,7 +47,8 @@ module module_ozphys !> \section arg_table_ty_ozphys Argument Table !! \htmlinclude ty_ozphys.html !! -!! All data field are ordered from surface-to-toa (j=1=isfc) +!> Derived type containing data and procedures needed by ozone photochemistry parameterization +!! *Note* All data field are ordered from surface-to-toa. !! ! ######################################################################################### type ty_ozphys @@ -54,7 +88,7 @@ module module_ozphys contains ! ######################################################################################### - ! Procedure (type-bound) for loading ozone forcing data. + ! Procedure (type-bound) for loading data for prognostic ozone. ! ######################################################################################### function load_o3prog(this, file, fileID) result (err_message) class(ty_ozphys), intent(inout) :: this @@ -101,7 +135,9 @@ function load_o3prog(this, file, fileID) result (err_message) end function load_o3prog ! ######################################################################################### - ! Procedure for setting up interpolation indices between data and model grid. + ! Procedure (type-bound) for setting up interpolation indices between data-grid and + ! model-grid. + ! Called once during initialization ! ######################################################################################### subroutine setup_o3prog(this, lat, idx1, idx2, idxh) class(ty_ozphys), intent(in) :: this @@ -130,7 +166,7 @@ subroutine setup_o3prog(this, lat, idx1, idx2, idxh) end subroutine setup_o3prog ! ######################################################################################### - ! Procedure (type-bound) for updating ozone data. + ! Procedure (type-bound) for updating data used in prognostic ozone scheme. ! ######################################################################################### subroutine update_o3prog(this, idx1, idx2, idxh, rjday, idxt1, idxt2, ozpl) class(ty_ozphys), intent(in) :: this @@ -474,7 +510,7 @@ subroutine run_o3clim(this, lat, prslk, con_pi, oz) end subroutine run_o3clim ! ######################################################################################### - ! Procedure (type-bound) for loading ozone climo data. + ! Procedure (type-bound) for loading data for climotological ozone. ! ######################################################################################### function load_o3clim(this, file, fileID) result (err_message) class(ty_ozphys), intent(inout) :: this @@ -546,46 +582,47 @@ function load_o3clim(this, file, fileID) result (err_message) this%pstr(iLev) = pstr4(iLev) this%pkstr(iLev) = fpkapx(this%pstr(iLev)*100.0) enddo - + end function load_o3clim - ! ######################################################################################### - ! Procedure (type-bound) for updating ozone climotological data. - ! ######################################################################################### - subroutine update_o3clim(this, imon, iday, ihour, loz1st) - class(ty_ozphys), intent(inout) :: this - integer, intent(in) :: imon, iday, ihour - logical, intent(in) :: loz1st - - integer :: midmon=15, midm=15, midp=45, id - integer, parameter, dimension(13) :: mdays = (/31,28,31,30,31,30,31,31,30,31,30,31,30/) - logical :: change - - midmon = mdays(imon)/2 + 1 - change = loz1st .or. ( (iday==midmon) .and. (ihour==0) ) + ! ######################################################################################### + ! Procedure (type-bound) for updating temporal interpolation index when using climotological + ! ozone + ! ######################################################################################### + subroutine update_o3clim(this, imon, iday, ihour, loz1st) + class(ty_ozphys), intent(inout) :: this + integer, intent(in) :: imon, iday, ihour + logical, intent(in) :: loz1st + + integer :: midmon=15, midm=15, midp=45, id + integer, parameter, dimension(13) :: mdays = (/31,28,31,30,31,30,31,31,30,31,30,31,30/) + logical :: change + + midmon = mdays(imon)/2 + 1 + change = loz1st .or. ( (iday==midmon) .and. (ihour==0) ) - if ( change ) then - if ( iday < midmon ) then - this%k1oz = mod(imon+10, 12) + 1 - midm = mdays(this%k1oz)/2 + 1 - this%k2oz = imon - midp = mdays(this%k1oz) + midmon - else - this%k1oz = imon - midm = midmon - this%k2oz = mod(imon, 12) + 1 - midp = mdays(this%k2oz)/2 + 1 + mdays(this%k1oz) - endif - endif + if ( change ) then + if ( iday < midmon ) then + this%k1oz = mod(imon+10, 12) + 1 + midm = mdays(this%k1oz)/2 + 1 + this%k2oz = imon + midp = mdays(this%k1oz) + midmon + else + this%k1oz = imon + midm = midmon + this%k2oz = mod(imon, 12) + 1 + midp = mdays(this%k2oz)/2 + 1 + mdays(this%k1oz) + endif + endif - if (iday < midmon) then - id = iday + mdays(this%k1oz) - else - id = iday - endif + if (iday < midmon) then + id = iday + mdays(this%k1oz) + else + id = iday + endif - this%facoz = float(id - midm) / float(midp - midm) + this%facoz = float(id - midm) / float(midp - midm) - end subroutine update_o3clim + end subroutine update_o3clim -end module module_ozphys + end module module_ozphys From ab4d5f1206d5bb8a7550682612a84bf77e0bdbdc Mon Sep 17 00:00:00 2001 From: "Haiqin.Li" Date: Fri, 29 Sep 2023 02:49:39 +0000 Subject: [PATCH 354/380] "correct the dimension of soil moisture for dust emission" --- physics/smoke_dust/rrfs_smoke_wrapper.meta | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/smoke_dust/rrfs_smoke_wrapper.meta b/physics/smoke_dust/rrfs_smoke_wrapper.meta index a0a641246..cddc20fbc 100755 --- a/physics/smoke_dust/rrfs_smoke_wrapper.meta +++ b/physics/smoke_dust/rrfs_smoke_wrapper.meta @@ -220,7 +220,7 @@ standard_name = volume_fraction_of_soil_moisture_for_land_surface_model long_name = volumetric fraction of soil moisture for lsm units = frac - dimensions = (horizontal_dimension,vertical_dimension_of_soil_internal_to_land_surface_scheme) + dimensions = (horizontal_loop_extent,vertical_dimension_of_soil_internal_to_land_surface_scheme) type = real kind = kind_phys intent = inout From e08ecd648a3f984a79e1dfd042f66edfbfb54d62 Mon Sep 17 00:00:00 2001 From: Helin Wei Date: Fri, 6 Oct 2023 15:07:48 -0400 Subject: [PATCH 355/380] land surface updates for hr3 --- physics/module_sf_noahmplsm.F90 | 15 +++++++++------ physics/noahmpdrv.F90 | 2 +- 2 files changed, 10 insertions(+), 7 deletions(-) diff --git a/physics/module_sf_noahmplsm.F90 b/physics/module_sf_noahmplsm.F90 index 86853dabe..8ced8930f 100644 --- a/physics/module_sf_noahmplsm.F90 +++ b/physics/module_sf_noahmplsm.F90 @@ -2116,7 +2116,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in ! thermal properties of soil, snow, lake, and frozen soil call thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , & !in - dt ,snowh ,snice ,snliq , & !in + dt ,snowh ,snice ,snliq , shdfac, & !in smc ,sh2o ,tg ,stc ,ur , & !in lat ,z0m ,zlvl ,vegtyp , & !in df ,hcpct ,snicev ,snliqv ,epore , & !out @@ -2463,7 +2463,7 @@ end subroutine energy !>\ingroup NoahMP_LSM subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , & !in - dt ,snowh ,snice ,snliq , & !in + dt ,snowh ,snice ,snliq , shdfac, & !in smc ,sh2o ,tg ,stc ,ur , & !in lat ,z0m ,zlvl ,vegtyp , & !in df ,hcpct ,snicev ,snliqv ,epore , & !out @@ -2480,6 +2480,7 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , real (kind=kind_phys) , intent(in) :: dt !< time step [s] real (kind=kind_phys), dimension(-nsnow+1: 0), intent(in) :: snice !< snow ice mass (kg/m2) real (kind=kind_phys), dimension(-nsnow+1: 0), intent(in) :: snliq !< snow liq mass (kg/m2) + real (kind=kind_phys) , intent(in) :: shdfac !< green vegetation fraction [0.0-1.0] real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !< thickness of snow/soil layers [m] real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: smc !< soil moisture (ice + liq.) [m3/m3] real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: sh2o !< liquid soil moisture [m3/m3] @@ -2539,6 +2540,7 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , ! not in use because of the separation of the canopy layer from the ground. ! but this may represent the effects of leaf litter (niu comments) ! df1 = df1 * exp (sbeta * shdfac) + df(1) = df(1) * exp (sbeta * shdfac) ! compute lake thermal properties ! (no consideration of turbulent mixing for this version) @@ -4888,7 +4890,7 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & end if endif ! 4 -! use sfc_diag to calculate t2mv and q2v for opt_sfc=1&3 +! use sfc_diag to calculate t2mb and q2b for opt_sfc=1&3 if(opt_diag ==3) then if(opt_sfc == 1 .or. opt_sfc == 3) then @@ -5823,7 +5825,8 @@ subroutine thermalz0(parameters, fveg, z0m, z0mg, zlvl, elseif (opt_trs == chen09) then - z0m_out = exp(fveg * log(z0m) + (1.0 - fveg) * log(z0mg)) +! z0m_out = exp(fveg * log(z0m) + (1.0 - fveg) * log(z0mg)) +! z0m_out = fveg * z0m + (1.0 - fveg) * z0mg czil = 10.0 ** (- 0.4 * parameters%hvt) reyn = ustarx*z0m_out/viscosity ! Blumel99 eqn 36c @@ -5873,7 +5876,7 @@ subroutine thermalz0(parameters, fveg, z0m, z0mg, zlvl, z0h_out = z0m_out - elseif (opt_trs == tessel) then + elseif (opt_trs == chen09 .or. opt_trs == tessel) then if (vegtyp <= 5) then z0h_out = z0m_out @@ -5881,7 +5884,7 @@ subroutine thermalz0(parameters, fveg, z0m, z0mg, zlvl, z0h_out = z0m_out * 0.01 endif - elseif (opt_trs == blumel99 .or. opt_trs == chen09) then + elseif (opt_trs == blumel99) then reyn = ustarx*z0m_out/viscosity ! Blumel99 eqn 36c if (reyn > 2.0) then diff --git a/physics/noahmpdrv.F90 b/physics/noahmpdrv.F90 index 4500d51a8..c2c03d0de 100644 --- a/physics/noahmpdrv.F90 +++ b/physics/noahmpdrv.F90 @@ -450,7 +450,7 @@ subroutine noahmpdrv_run & integer :: iopt_pedo = 1 ! option for pedotransfer function integer :: iopt_crop = 0 ! option for crop model integer :: iopt_gla = 2 ! option for glacier treatment - integer :: iopt_z0m = 2 ! option for z0m treatment + integer :: iopt_z0m = 1 ! option for z0m treatment ! ! --- local inputs to noah-mp and glacier subroutines; listed in order in noah-mp call From 4f8004ab57b85d76884858849a5f4211f28d3084 Mon Sep 17 00:00:00 2001 From: Helin Wei Date: Fri, 6 Oct 2023 18:05:17 -0400 Subject: [PATCH 356/380] remove one printout from sfcsub.f and uncomment z0m composition in module_sf_noahmplsm.F90 --- physics/module_sf_noahmplsm.F90 | 2 +- physics/sfcsub.F | 3 --- 2 files changed, 1 insertion(+), 4 deletions(-) diff --git a/physics/module_sf_noahmplsm.F90 b/physics/module_sf_noahmplsm.F90 index 8ced8930f..6abd59f69 100644 --- a/physics/module_sf_noahmplsm.F90 +++ b/physics/module_sf_noahmplsm.F90 @@ -5826,7 +5826,7 @@ subroutine thermalz0(parameters, fveg, z0m, z0mg, zlvl, elseif (opt_trs == chen09) then ! z0m_out = exp(fveg * log(z0m) + (1.0 - fveg) * log(z0mg)) -! z0m_out = fveg * z0m + (1.0 - fveg) * z0mg + z0m_out = fveg * z0m + (1.0 - fveg) * z0mg czil = 10.0 ** (- 0.4 * parameters%hvt) reyn = ustarx*z0m_out/viscosity ! Blumel99 eqn 36c diff --git a/physics/sfcsub.F b/physics/sfcsub.F index 7be07b39c..494b8f7dc 100644 --- a/physics/sfcsub.F +++ b/physics/sfcsub.F @@ -7491,9 +7491,6 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil,slmskl,slmskw, & endif call abort endif -! -! soil type - print *,'in FIXREAD fnsotc =',fnsotc ! if(fnsotc(1:8).ne.' ') then if ( index(fnsotc, "tileX.nc") == 0) then ! grib file From 5bd6da748d22564212a448ba0e143fb8ada23722 Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Wed, 11 Oct 2023 14:21:32 -0500 Subject: [PATCH 357/380] Set initial values for some constants (just in case) --- physics/module_mp_nssl_2mom.F90 | 25 +++++++++++++------------ 1 file changed, 13 insertions(+), 12 deletions(-) diff --git a/physics/module_mp_nssl_2mom.F90 b/physics/module_mp_nssl_2mom.F90 index a40a62f02..a88ffe053 100644 --- a/physics/module_mp_nssl_2mom.F90 +++ b/physics/module_mp_nssl_2mom.F90 @@ -951,19 +951,20 @@ MODULE module_mp_nssl_2mom real, parameter :: cawbolton = 17.67 real, parameter :: tfrh = 233.15 +! -------------------------- + ! For CCPP, the following variables should be set by the host model, but initial values are set just in case real :: tfr = 273.15 - real :: cp = 1004.0, rd = 287.04 real :: rw = 461.5 ! gas const. for water vapor - REAL, PRIVATE :: cpl = 4190.0 - REAL, PRIVATE :: cpigb = 2106.0 - real :: cpi - real :: cap - real :: tfrcbw - real :: tfrcbi - real :: rovcp - real, public :: rdorv = 0.622 - + real :: cpl = 4190.0 + real :: cpigb = 2106.0 + real :: cpi = 1.0/1004.0 + real :: cap = 287.04/1004.0 + real :: tfrcbw = 273.15 - cbw + real :: tfrcbi = 273.15 - cbi + real :: rovcp = 287.04/1004.0 + real :: rdorv = 0.622 +! -------------------------- real, parameter :: poo = 1.0e+05 real, parameter :: advisc0 = 1.832e-05 ! reference dynamic viscosity (SMT; see Beard & Pruppacher 71) real, parameter :: advisc1 = 1.718e-05 ! dynamic viscosity constant used in thermal conductivity calc @@ -4113,7 +4114,7 @@ subroutine hailmaxd(dtp,nx,ny,nz,an,na,nor,norz,alpha2d,dn, & g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami tmp = dn(ix,jy,kz)*an(ix,jy,kz,lh)/(hwdn*an(ix,jy,kz,lnh)) - diam = (6.0*tmp/(3.14159))**(1./3.) + diam = (6.0*tmp/pi)**(1./3.) IF ( lzh > 1 ) THEN ! 3moment cwchtmp = ((3. + alpha2d(ix,1,kz,2))*(2. + alpha2d(ix,1,kz,2))*(1.0 + alpha2d(ix,1,kz,2)))**(-1./3.) ENDIF @@ -4184,7 +4185,7 @@ subroutine hailmaxd(dtp,nx,ny,nz,an,na,nor,norz,alpha2d,dn, & g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami tmp = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/(hwdn*an(ix,jy,kz,lnhl)) - diam = (6.0*tmp/(3.14159))**(1./3.) + diam = (6.0*tmp/pi)**(1./3.) IF ( lzhl > 1 ) THEN ! 3moment cwchltmp = ((3. + alpha2d(ix,1,kz,3))*(2. + alpha2d(ix,1,kz,3))*(1.0 + alpha2d(ix,1,kz,3)))**(-1./3.) ENDIF From 1b2239714a949341409261ebbfb8a0bdf6a4f5da Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Thu, 12 Oct 2023 03:40:06 +0000 Subject: [PATCH 358/380] Some more cleanup --- physics/GFS_physics_post.F90 | 99 ++++++++++++++++++++++++++++++----- physics/GFS_physics_post.meta | 49 +++++++++++++++++ physics/phys_tend.F90 | 96 --------------------------------- physics/phys_tend.meta | 95 --------------------------------- 4 files changed, 134 insertions(+), 205 deletions(-) delete mode 100644 physics/phys_tend.F90 delete mode 100644 physics/phys_tend.meta diff --git a/physics/GFS_physics_post.F90 b/physics/GFS_physics_post.F90 index e6a50cc3a..def38cd1a 100644 --- a/physics/GFS_physics_post.F90 +++ b/physics/GFS_physics_post.F90 @@ -35,47 +35,62 @@ end subroutine GFS_physics_post_init !! \section arg_table_GFS_physics_post_run Argument Table !! \htmlinclude GFS_physics_post_run.html !! - subroutine GFS_physics_post_run(nCol, nLev, ntoz, dtidx, ip_prod_loss, ip_ozmix, ip_temp, & - ip_overhead_ozone, do3_dt_prd, do3_dt_ozmx, do3_dt_temp, do3_dt_ohoz, dtend, errmsg, & - errflg) + subroutine GFS_physics_post_run(nCol, nLev, ntoz, ntracp100, nprocess, nprocess_summed, & + dtidx, is_photochem, ldiag3d, ip_physics, ip_photochem, & + ip_prod_loss, ip_ozmix, ip_temp, ip_overhead_ozone, do3_dt_prd, do3_dt_ozmx, & + do3_dt_temp, do3_dt_ohoz, dtend, errmsg, errflg) ! Inputs integer, intent(in) :: & nCol, & ! Horizontal dimension nLev, & ! Number of vertical layers ntoz, & ! Index for ozone mixing ratio + ntracp100, & ! Number of tracers plus 100 + nprocess, & ! Number of processes that cause changes in state variables + nprocess_summed,& ! Number of causes in dtidx per tracer summed for total physics tendency + ip_physics, & ! Index for process in diagnostic tendency output + ip_photochem, & ! ip_prod_loss, & ! Index for process in diagnostic tendency output ip_ozmix, & ! Index for process in diagnostic tendency output ip_temp, & ! Index for process in diagnostic tendency output ip_overhead_ozone ! Index for process in diagnostic tendency output integer, intent(in), dimension(:,:) :: & dtidx ! Bookkeeping indices for GFS diagnostic tendencies + logical, intent(in) :: & + ldiag3d ! Flag for 3d diagnostic fields + logical, intent(in), dimension(:) :: & + is_photochem ! Flags for photochemistry processes to sum ! Inputs (optional) real(kind=kind_phys), intent(in), dimension(:,:), pointer, optional :: & - do3_dt_prd, & ! Physics tendency: production and loss effect - do3_dt_ozmx, & ! Physics tendency: ozone mixing ratio effect - do3_dt_temp, & ! Physics tendency: temperature effect - do3_dt_ohoz ! Physics tendency: overhead ozone effect + do3_dt_prd, & ! Physics tendency: production and loss effect + do3_dt_ozmx, & ! Physics tendency: ozone mixing ratio effect + do3_dt_temp, & ! Physics tendency: temperature effect + do3_dt_ohoz ! Physics tendency: overhead ozone effect ! Outputs real(kind=kind_phys), intent(inout), dimension(:,:,:) :: & - dtend ! Diagnostic tendencies for state variables + dtend ! Diagnostic tendencies for state variables character(len=*), intent(out) :: & - errmsg ! CCPP error message + errmsg ! CCPP error message integer, intent(out) :: & - errflg ! CCPP error flag + errflg ! CCPP error flag ! Locals - integer :: idtend - + integer :: idtend, ichem, iphys, itrac + logical :: all_true(nprocess) + ! Initialize CCPP error handling variables errmsg = '' errflg = 0 + if(.not.ldiag3d) then + return + endif + ! ####################################################################################### ! - ! Ozone physics diagnostic + ! Ozone physics diagnostics ! ! ####################################################################################### idtend = dtidx(100+ntoz,ip_prod_loss) @@ -98,6 +113,62 @@ subroutine GFS_physics_post_run(nCol, nLev, ntoz, dtidx, ip_prod_loss, ip_ozmix, dtend(:,:,idtend) = dtend(:,:,idtend) + do3_dt_ohoz endif - end subroutine GFS_physics_post_run + ! ####################################################################################### + ! + ! Total (photochemical) tendencies. + ! + ! ####################################################################################### + itrac = ntoz+100 + ichem = dtidx(itrac, ip_photochem) + if(ichem >= 1) then + call sum_it(ichem, itrac, is_photochem) + endif + ! ####################################################################################### + ! + ! Total (physics) tendencies + ! + ! ####################################################################################### + all_true = .true. + do itrac = 2,ntracp100 + iphys = dtidx(itrac,ip_physics) + if(iphys >= 1) then + call sum_it(iphys, itrac, all_true) + endif + enddo + + contains + + subroutine sum_it(isum,itrac,sum_me) + integer, intent(in) :: isum ! third index of dtend of summary process + integer, intent(in) :: itrac ! tracer or state variable being summed + logical, intent(in) :: sum_me(nprocess) ! false = skip this process + logical :: first + integer :: idtend, iprocess + + first=.true. + do iprocess=1,nprocess + if(iprocess>nprocess_summed) then + exit ! Don't sum up the sums. + else if(.not.sum_me(iprocess)) then + cycle ! We were asked to skip this one. + endif + idtend = dtidx(itrac,iprocess) + if(idtend>=1) then + ! This tendency was calculated for this tracer, so + ! accumulate it into the total tendency. + if(first) then + dtend(:,:,isum) = dtend(:,:,idtend) + first=.false. + else + dtend(:,:,isum) = dtend(:,:,isum) + dtend(:,:,idtend) + endif + endif + enddo + if(first) then + ! No tendencies were calculated, so sum is 0: + dtend(:,:,isum) = 0 + endif + end subroutine sum_it + end subroutine GFS_physics_post_run end module GFS_physics_post diff --git a/physics/GFS_physics_post.meta b/physics/GFS_physics_post.meta index 8b5120b9e..649ef6491 100644 --- a/physics/GFS_physics_post.meta +++ b/physics/GFS_physics_post.meta @@ -63,6 +63,55 @@ dimensions = () type = integer intent = in +[ntracp100] + standard_name = number_of_tracers_plus_one_hundred + long_name = number of tracers plus one hundred + units = count + dimensions = () + type = integer + intent = in +[nprocess] + standard_name = number_of_cumulative_change_processes + long_name = number of processes that cause changes in state variables + units = count + dimensions = () + type = integer + intent = in +[nprocess_summed] + standard_name = number_of_physics_causes_of_tracer_changes + long_name = number of causes in dtidx per tracer summed for total physics tendency + units = count + dimensions = () + type = integer + intent = in +[ip_physics] + standard_name = index_of_all_physics_process_in_cumulative_change_index + long_name = index of all physics transport process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[ip_photochem] + standard_name = index_of_photochemistry_process_in_cumulative_change_index + long_name = index of photochemistry process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[is_photochem] + standard_name = flags_for_photochemistry_processes_to_sum + long_name = flags for photochemistry processes to sum as the total photochemistry process cumulative change + units = flag + dimensions = (number_of_cumulative_change_processes) + type = logical + intent = in +[ldiag3d] + standard_name = flag_for_diagnostics_3D + long_name = flag for 3d diagnostic fields + units = flag + dimensions = () + type = logical + intent = in [ip_prod_loss] standard_name = index_of_production_and_loss_process_in_cumulative_change_index long_name = index of production and loss effect in photochemistry process in second dimension of array cumulative change index diff --git a/physics/phys_tend.F90 b/physics/phys_tend.F90 deleted file mode 100644 index e63f44be5..000000000 --- a/physics/phys_tend.F90 +++ /dev/null @@ -1,96 +0,0 @@ -!>\file phys_tend.F90 -!! -module phys_tend - - use machine, only: kind_phys - - implicit none - - private - - public phys_tend_run - -contains - -!> \section arg_table_phys_tend_run Argument Table -!! \htmlinclude phys_tend_run.html -!! - subroutine phys_tend_run(ldiag3d, dtend, dtidx, ntracp100, & - index_of_process_physics, index_of_process_photochem, & - nprocess, nprocess_summed, is_photochem, ntoz, errmsg, errflg) - - ! Interface variables - logical, intent(in) :: ldiag3d, is_photochem(:) - real(kind=kind_phys), optional, intent(inout) :: dtend(:,:,:) - integer, intent(in) :: dtidx(:,:), index_of_process_physics, ntoz, & - ntracp100, nprocess, nprocess_summed, index_of_process_photochem - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - integer :: ichem, iphys, itrac - logical :: all_true(nprocess) - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if(.not.ldiag3d) then - return - endif - - all_true = .true. - - ! Total photochemical tendencies - itrac=ntoz+100 - ichem = dtidx(itrac,index_of_process_photochem) - if(ichem>=1) then - call sum_it(ichem,itrac,is_photochem) - endif - - - do itrac=2,ntracp100 - ! Total physics tendencies - iphys = dtidx(itrac,index_of_process_physics) - if(iphys>=1) then - call sum_it(iphys,itrac,all_true) - endif - enddo - - contains - - subroutine sum_it(isum,itrac,sum_me) - implicit none - integer, intent(in) :: isum ! third index of dtend of summary process - integer, intent(in) :: itrac ! tracer or state variable being summed - logical, intent(in) :: sum_me(nprocess) ! false = skip this process - logical :: first - integer :: idtend, iprocess - - first=.true. - do iprocess=1,nprocess - if(iprocess>nprocess_summed) then - exit ! Don't sum up the sums. - else if(.not.sum_me(iprocess)) then - cycle ! We were asked to skip this one. - endif - idtend = dtidx(itrac,iprocess) - if(idtend>=1) then - ! This tendency was calculated for this tracer, so - ! accumulate it into the total tendency. - if(first) then - dtend(:,:,isum) = dtend(:,:,idtend) - first=.false. - else - dtend(:,:,isum) = dtend(:,:,isum) + dtend(:,:,idtend) - endif - endif - enddo - if(first) then - ! No tendencies were calculated, so sum is 0: - dtend(:,:,isum) = 0 - endif - end subroutine sum_it - - end subroutine phys_tend_run - -end module phys_tend diff --git a/physics/phys_tend.meta b/physics/phys_tend.meta deleted file mode 100644 index 0f78af20b..000000000 --- a/physics/phys_tend.meta +++ /dev/null @@ -1,95 +0,0 @@ -[ccpp-table-properties] - name = phys_tend - type = scheme - dependencies = machine.F - -######################################################################## -[ccpp-arg-table] - name = phys_tend_run - type = scheme -[ldiag3d] - standard_name = flag_for_diagnostics_3D - long_name = flag for 3d diagnostic fields - units = flag - dimensions = () - type = logical - intent = in -[dtend] - standard_name = cumulative_change_of_state_variables - long_name = diagnostic tendencies for state variables - units = mixed - dimensions = (horizontal_loop_extent,vertical_layer_dimension,cumulative_change_of_state_variables_outer_index_max) - type = real - kind = kind_phys - intent = inout -[dtidx] - standard_name = cumulative_change_of_state_variables_outer_index - long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index - units = index - dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes) - type = integer - intent = in -[ntracp100] - standard_name = number_of_tracers_plus_one_hundred - long_name = number of tracers plus one hundred - units = count - dimensions = () - type = integer - intent = in -[index_of_process_physics] - standard_name = index_of_all_physics_process_in_cumulative_change_index - long_name = index of all physics transport process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_process_photochem] - standard_name = index_of_photochemistry_process_in_cumulative_change_index - long_name = index of photochemistry process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[nprocess] - standard_name = number_of_cumulative_change_processes - long_name = number of processes that cause changes in state variables - units = count - dimensions = () - type = integer - intent = in -[nprocess_summed] - standard_name = number_of_physics_causes_of_tracer_changes - long_name = number of causes in dtidx per tracer summed for total physics tendency - units = count - dimensions = () - type = integer - intent = in -[is_photochem] - standard_name = flags_for_photochemistry_processes_to_sum - long_name = flags for photochemistry processes to sum as the total photochemistry process cumulative change - units = flag - dimensions = (number_of_cumulative_change_processes) - type = logical - intent = in -[ntoz] - standard_name = index_of_ozone_mixing_ratio_in_tracer_concentration_array - long_name = tracer index for ozone mixing ratio - units = index - dimensions = () - type = integer - intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out From 06bb2bcc9ea2fa5dd52d8f0aa8be2f41b65ab8c0 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Thu, 12 Oct 2023 15:17:00 +0000 Subject: [PATCH 359/380] Final cleanup --- physics/GFS_phys_time_vary.scm.F90 | 83 +++++++++++++++++++++++------ physics/GFS_phys_time_vary.scm.meta | 75 +++++++++++++++++++++++++- physics/GFS_physics_post.F90 | 24 ++------- physics/GFS_physics_post.meta | 20 ------- 4 files changed, 144 insertions(+), 58 deletions(-) diff --git a/physics/GFS_phys_time_vary.scm.F90 b/physics/GFS_phys_time_vary.scm.F90 index 97460ac98..075bfc039 100644 --- a/physics/GFS_phys_time_vary.scm.F90 +++ b/physics/GFS_phys_time_vary.scm.F90 @@ -2,15 +2,17 @@ !! Contains code related to GFS physics suite setup (physics part of time_vary_step) !>\defgroup mod_GFS_phys_time_vary GFS Physics Time Update -!! This module contains GFS physics time vary subroutines including, stratospheric water vapor, +!! This module contains GFS physics time vary subroutines including stratospheric water vapor, !! aerosol, IN&CCN and surface properties updates. !> @{ module GFS_phys_time_vary - use machine, only : kind_phys + use machine, only : kind_phys, kind_dbl_prec, kind_sngl_prec use mersenne_twister, only: random_setseed, random_number + use module_ozphys, only: ty_ozphys + use h2o_def, only : levh2o, h2o_coeff, h2o_lat, h2o_pres, h2o_time, h2oplin use h2ointerp, only : read_h2odata, setindxh2o, h2ointerpol @@ -58,8 +60,8 @@ module GFS_phys_time_vary !>\section gen_GFS_phys_time_vary_init GFS_phys_time_vary_init General Algorithm !! @{ subroutine GFS_phys_time_vary_init ( & - me, master, h2o_phys, iaerclm, iccn, iflip, im, nx, ny, idate, xlat_d, xlon_d, & - jindx1_h, jindx2_h, ddy_h, h2opl,fhour, & + me, master, ntoz, h2o_phys, iaerclm, iccn, iflip, im, nx, ny, idate, xlat_d, xlon_d, & + jindx1_o3, jindx2_o3, ddy_o3, ozphys, jindx1_h, jindx2_h, ddy_h, h2opl,fhour, & jindx1_aer, jindx2_aer, ddy_aer, iindx1_aer, iindx2_aer, ddx_aer, aer_nm, & jindx1_ci, jindx2_ci, ddy_ci, iindx1_ci, iindx2_ci, ddx_ci, imap, jmap, & do_ugwp_v1, jindx1_tau, jindx2_tau, ddy_j1tau, ddy_j2tau, & @@ -76,14 +78,14 @@ subroutine GFS_phys_time_vary_init ( implicit none ! Interface variables - integer, intent(in) :: me, master, iccn, iflip, im, nx, ny + integer, intent(in) :: me, master, ntoz, iccn, iflip, im, nx, ny logical, intent(in) :: h2o_phys, iaerclm, lsm_cold_start integer, intent(in) :: idate(:) real(kind_phys), intent(in) :: fhour real(kind_phys), intent(in) :: xlat_d(:), xlon_d(:) - integer, intent(inout) :: jindx1_h(:), jindx2_h(:) - real(kind_phys), intent(inout) :: ddy_h(:) + integer, intent(inout) :: jindx1_o3(:), jindx2_o3(:), jindx1_h(:), jindx2_h(:) + real(kind_phys), intent(inout) :: ddy_o3(:), ddy_h(:) real(kind_phys), intent(in) :: h2opl(:,:,:) integer, intent(inout) :: jindx1_aer(:), jindx2_aer(:), iindx1_aer(:), iindx2_aer(:) real(kind_phys), intent(inout) :: ddy_aer(:), ddx_aer(:) @@ -101,6 +103,7 @@ subroutine GFS_phys_time_vary_init ( real(kind_phys), intent(in) :: min_seaice, fice(:) real(kind_phys), intent(in) :: landfrac(:) real(kind_phys), intent(inout) :: weasd(:) + type(ty_ozphys), intent(in) :: ozphys ! NoahMP - only allocated when NoahMP is used integer, intent(in) :: lsoil, lsnow_lsm_lbound, lsnow_lsm_ubound @@ -244,6 +247,11 @@ subroutine GFS_phys_time_vary_init ( !> - Initialize soil vegetation (needed for sncovr calculation further down) call set_soilveg(me, isot, ivegsrc, nlunit, errmsg, errflg) +!> - Setup spatial interpolation indices for ozone physics. + if (ntoz > 0) then + call ozphys%setup_o3prog(xlat_d, jindx1_o3, jindx2_o3, ddy_o3) + endif + !> - Call setindxh2o() to initialize stratospheric water vapor data if (h2o_phys) then call setindxh2o (im, xlat_d, jindx1_h, jindx2_h, ddy_h) @@ -625,8 +633,8 @@ end subroutine GFS_phys_time_vary_init !! @{ subroutine GFS_phys_time_vary_timestep_init ( & me, master, cnx, cny, isc, jsc, nrcm, im, levs, kdt, idate, nsswr, fhswr, lsswr, fhour, & - imfdeepcnv, cal_pre, random_clds, h2o_phys, iaerclm, iccn, clstp, & - jindx1_h, jindx2_h, ddy_h, h2opl, iflip, & + imfdeepcnv, cal_pre, random_clds, ozphys, ntoz, h2o_phys, iaerclm, iccn, clstp, & + jindx1_o3, jindx2_o3, ddy_o3, ozpl, jindx1_h, jindx2_h, ddy_h, h2opl, iflip, & jindx1_aer, jindx2_aer, ddy_aer, iindx1_aer, iindx2_aer, ddx_aer, aer_nm, & jindx1_ci, jindx2_ci, ddy_ci, iindx1_ci, iindx2_ci, ddx_ci, in_nm, ccn_nm, & imap, jmap, prsl, seed0, rann, do_ugwp_v1, jindx1_tau, jindx2_tau, ddy_j1tau, ddy_j2tau,& @@ -636,14 +644,14 @@ subroutine GFS_phys_time_vary_timestep_init ( ! Interface variables integer, intent(in) :: me, master, cnx, cny, isc, jsc, nrcm, im, levs, kdt, & - nsswr, imfdeepcnv, iccn, iflip + nsswr, imfdeepcnv, iccn, ntoz, iflip integer, intent(in) :: idate(:) real(kind_phys), intent(in) :: fhswr, fhour logical, intent(in) :: lsswr, cal_pre, random_clds, h2o_phys, iaerclm real(kind_phys), intent(out) :: clstp - integer, intent(in) :: jindx1_h(:), jindx2_h(:) - real(kind_phys), intent(in) :: ddy_h(:) - real(kind_phys), intent(inout) :: h2opl(:,:,:) + integer, intent(in) :: jindx1_o3(:), jindx2_o3(:), jindx1_h(:), jindx2_h(:) + real(kind_phys), intent(in) :: ddy_o3(:), ddy_h(:) + real(kind_phys), intent(inout) :: ozpl(:,:,:), h2opl(:,:,:) integer, intent(in) :: jindx1_aer(:), jindx2_aer(:), iindx1_aer(:), iindx2_aer(:) real(kind_phys), intent(in) :: ddy_aer(:), ddx_aer(:) real(kind_phys), intent(inout) :: aer_nm(:,:,:) @@ -659,15 +667,19 @@ subroutine GFS_phys_time_vary_timestep_init ( integer, intent(in) :: jindx1_tau(:), jindx2_tau(:) real(kind_phys), intent(in) :: ddy_j1tau(:), ddy_j2tau(:) real(kind_phys), intent(inout) :: tau_amf(:) + type(ty_ozphys), intent(in) :: ozphys integer, intent(in) :: nthrds character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg ! Local variables - integer :: i, j, k, iseed, iskip, ix - real(kind=kind_phys) :: wrk(1) - real(kind=kind_phys) :: rannie(cny) - real(kind=kind_phys) :: rndval(cnx*cny*nrcm) + integer :: i, j, k, iseed, iskip, ix, idat(8), jdat(8), iday, j1, j2, nc, n1, n2, jdow, & + jdoy, jday, w3kindreal, w3kindint + real(kind_phys) :: wrk(1), tem, tx1, tx2, rjday + real(kind_phys) :: rannie(cny) + real(kind_phys) :: rndval(cnx*cny*nrcm) + real(kind_dbl_prec) :: rinc(5) + real(kind_sngl_prec) :: rinc4(5) ! Initialize CCPP error handling variables errmsg = '' @@ -721,6 +733,43 @@ subroutine GFS_phys_time_vary_timestep_init ( endif ! imfdeepcnv, cal_re, random_clds + !> - Compute temporal interpolation indices for updating gas concentrations. + idat=0 + idat(1)=idate(4) + idat(2)=idate(2) + idat(3)=idate(3) + idat(5)=idate(1) + rinc=0. + rinc(2)=fhour + call w3kind(w3kindreal,w3kindint) + if(w3kindreal==4) then + rinc4=rinc + CALL w3movdat(rinc4,idat,jdat) + else + CALL w3movdat(rinc,idat,jdat) + endif + jdow = 0 + jdoy = 0 + jday = 0 + call w3doxdat(jdat,jdow,jdoy,jday) + rjday = jdoy + jdat(5) / 24. + if (rjday < ozphys%time(1)) rjday = rjday + 365. + + n2 = ozphys%ntime + 1 + do j=2,ozphys%ntime + if (rjday < ozphys%time(j)) then + n2 = j + exit + endif + enddo + n1 = n2 - 1 + if (n2 > ozphys%ntime) n2 = n2 - ozphys%ntime + +!> - Update ozone concentration. + if (ntoz > 0) then + call ozphys%update_o3prog(jindx1_o3, jindx2_o3, ddy_o3, rjday, n1, n2, ozpl) + endif + !> - Call h2ointerpol() to make stratospheric water vapor data interpolation if (h2o_phys) then call h2ointerpol (me, im, idate, fhour, & diff --git a/physics/GFS_phys_time_vary.scm.meta b/physics/GFS_phys_time_vary.scm.meta index 21d1f2736..cf5ad15ca 100644 --- a/physics/GFS_phys_time_vary.scm.meta +++ b/physics/GFS_phys_time_vary.scm.meta @@ -2,7 +2,7 @@ name = GFS_phys_time_vary type = scheme dependencies = aerclm_def.F,aerinterp.F90,h2o_def.f,h2ointerp.f90,iccn_def.F,iccninterp.F90,machine.F,mersenne_twister.f - dependencies = namelist_soilveg.f,set_soilveg.f,cires_tauamf_data.F90,noahmp_tables.f90 + dependencies = namelist_soilveg.f,set_soilveg.f,module_ozphys.F90,cires_tauamf_data.F90,noahmp_tables.f90 ######################################################################## [ccpp-arg-table] @@ -23,6 +23,13 @@ dimensions = () type = integer intent = in +[ntoz] + standard_name = index_of_ozone_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for ozone mixing ratio + units = index + dimensions = () + type = integer + intent = in [h2o_phys] standard_name = flag_for_stratospheric_water_vapor_physics long_name = flag for stratospheric water vapor physics @@ -95,6 +102,28 @@ type = real kind = kind_phys intent = in +[jindx1_o3] + standard_name = lower_latitude_index_of_ozone_forcing_for_interpolation + long_name = interpolation low index for ozone + units = index + dimensions = (horizontal_dimension) + type = integer + intent = inout +[jindx2_o3] + standard_name = upper_latitude_index_of_ozone_forcing_for_interpolation + long_name = interpolation high index for ozone + units = index + dimensions = (horizontal_dimension) + type = integer + intent = inout +[ddy_o3] + standard_name = latitude_interpolation_weight_for_ozone_forcing + long_name = interpolation high index for ozone + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout [jindx1_h] standard_name = lower_latitude_index_of_stratospheric_water_vapor_forcing_for_interpolation long_name = interpolation low index for stratospheric water vapor @@ -1019,6 +1048,13 @@ dimensions = () type = logical intent = in +[ntoz] + standard_name = index_of_ozone_mixing_ratio_in_tracer_concentration_array + long_name = tracer index for ozone mixing ratio + units = index + dimensions = () + type = integer + intent = in [h2o_phys] standard_name = flag_for_stratospheric_water_vapor_physics long_name = flag for stratospheric water vapor physics @@ -1048,6 +1084,36 @@ type = real kind = kind_phys intent = out +[jindx1_o3] + standard_name = lower_latitude_index_of_ozone_forcing_for_interpolation + long_name = interpolation low index for ozone + units = index + dimensions = (horizontal_dimension) + type = integer + intent = in +[jindx2_o3] + standard_name = upper_latitude_index_of_ozone_forcing_for_interpolation + long_name = interpolation high index for ozone + units = index + dimensions = (horizontal_dimension) + type = integer + intent = in +[ddy_o3] + standard_name = latitude_interpolation_weight_for_ozone_forcing + long_name = interpolation high index for ozone + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in +[ozpl] + standard_name = ozone_forcing + long_name = ozone forcing data + units = mixed + dimensions = (horizontal_dimension,number_of_levels_in_ozone_data,number_of_coefficients_in_ozone_data) + type = real + kind = kind_phys + intent = inout [jindx1_h] standard_name = lower_latitude_index_of_stratospheric_water_vapor_forcing_for_interpolation long_name = interpolation low index for stratospheric water vapor @@ -1279,6 +1345,13 @@ type = real kind = kind_phys intent = inout +[ozphys] + standard_name = dataset_for_ozone_physics + long_name = dataset for NRL ozone physics + units = mixed + dimensions = () + type = ty_ozphys + intent = in [nthrds] standard_name = number_of_openmp_threads long_name = number of OpenMP threads available for physics schemes diff --git a/physics/GFS_physics_post.F90 b/physics/GFS_physics_post.F90 index def38cd1a..f89b257a8 100644 --- a/physics/GFS_physics_post.F90 +++ b/physics/GFS_physics_post.F90 @@ -13,22 +13,6 @@ module GFS_physics_post public GFS_physics_post_init, GFS_physics_post_run contains -! ########################################################################################### -! SUBROUTINE GFS_physics_post_init -! ########################################################################################### -!! \section arg_table_GFS_physics_post_init Argument Table -!! \htmlinclude GFS_physics_post_init.html -!! - subroutine GFS_physics_post_init(errmsg, errflg) - - ! Outputs - character(len=*), intent(out) :: & - errmsg ! CCPP error message - integer, intent(out) :: & - errflg ! CCPP error flag - - end subroutine GFS_physics_post_init - ! ########################################################################################### ! SUBROUTINE GFS_physics_post_run ! ########################################################################################### @@ -36,9 +20,9 @@ end subroutine GFS_physics_post_init !! \htmlinclude GFS_physics_post_run.html !! subroutine GFS_physics_post_run(nCol, nLev, ntoz, ntracp100, nprocess, nprocess_summed, & - dtidx, is_photochem, ldiag3d, ip_physics, ip_photochem, & - ip_prod_loss, ip_ozmix, ip_temp, ip_overhead_ozone, do3_dt_prd, do3_dt_ozmx, & - do3_dt_temp, do3_dt_ohoz, dtend, errmsg, errflg) + dtidx, is_photochem, ldiag3d, ip_physics, ip_photochem, ip_prod_loss, ip_ozmix, & + ip_temp, ip_overhead_ozone, do3_dt_prd, do3_dt_ozmx, do3_dt_temp, do3_dt_ohoz, & + dtend, errmsg, errflg) ! Inputs integer, intent(in) :: & @@ -49,7 +33,7 @@ subroutine GFS_physics_post_run(nCol, nLev, ntoz, ntracp100, nprocess, nprocess_ nprocess, & ! Number of processes that cause changes in state variables nprocess_summed,& ! Number of causes in dtidx per tracer summed for total physics tendency ip_physics, & ! Index for process in diagnostic tendency output - ip_photochem, & ! + ip_photochem, & ! Index for process in diagnostic tendency output ip_prod_loss, & ! Index for process in diagnostic tendency output ip_ozmix, & ! Index for process in diagnostic tendency output ip_temp, & ! Index for process in diagnostic tendency output diff --git a/physics/GFS_physics_post.meta b/physics/GFS_physics_post.meta index 649ef6491..5701909fd 100644 --- a/physics/GFS_physics_post.meta +++ b/physics/GFS_physics_post.meta @@ -3,26 +3,6 @@ type = scheme dependencies = machine.F -######################################################################## -[ccpp-arg-table] - name = GFS_physics_post_init - type = scheme -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - ######################################################################## [ccpp-arg-table] name = GFS_physics_post_run From 89af3d8946ab25737628a016fe89356a261155ac Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Thu, 12 Oct 2023 15:45:58 +0000 Subject: [PATCH 360/380] Omission from previous commit --- physics/GFS_physics_post.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/GFS_physics_post.F90 b/physics/GFS_physics_post.F90 index f89b257a8..fe5409353 100644 --- a/physics/GFS_physics_post.F90 +++ b/physics/GFS_physics_post.F90 @@ -10,7 +10,7 @@ module GFS_physics_post use machine, only : kind_phys, kind_dbl_prec, kind_sngl_prec implicit none - public GFS_physics_post_init, GFS_physics_post_run + public GFS_physics_post_run contains ! ########################################################################################### From c6204e149fdbff013532cf991e9ad00b107d111b Mon Sep 17 00:00:00 2001 From: "denise.worthen" Date: Sun, 15 Oct 2023 08:15:23 -0400 Subject: [PATCH 361/380] add dlw,dsw inst to cpllnd block --- physics/GFS_surface_generic_post.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/physics/GFS_surface_generic_post.F90 b/physics/GFS_surface_generic_post.F90 index 9faebc8cf..7e8cfa753 100644 --- a/physics/GFS_surface_generic_post.F90 +++ b/physics/GFS_surface_generic_post.F90 @@ -130,6 +130,8 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplaqm, cplchm, cplwav, cpl if (cplflx .or. cpllnd) then do i=1,im + dlwsfci_cpl (i) = adjsfcdlw(i) + dswsfci_cpl (i) = adjsfcdsw(i) dlwsfc_cpl (i) = dlwsfc_cpl(i) + adjsfcdlw(i)*dtf dswsfc_cpl (i) = dswsfc_cpl(i) + adjsfcdsw(i)*dtf psurfi_cpl (i) = pgr(i) @@ -138,8 +140,6 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplaqm, cplchm, cplwav, cpl if (cplflx) then do i=1,im - dlwsfci_cpl (i) = adjsfcdlw(i) - dswsfci_cpl (i) = adjsfcdsw(i) dnirbmi_cpl (i) = adjnirbmd(i) dnirdfi_cpl (i) = adjnirdfd(i) dvisbmi_cpl (i) = adjvisbmd(i) @@ -242,7 +242,7 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplaqm, cplchm, cplwav, cpl tedir(i) = tedir(i) + edir(i) * dtf if (lsm == lsm_noahmp) then paha(i) = paha(i) + pah(i) * dtf - twa(i) = waxy(i) + twa(i) = waxy(i) endif enddo endif @@ -252,7 +252,7 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplaqm, cplchm, cplwav, cpl ! heat torage parameterization the kinematic sensible heat flux ! (hflx) as surface boundary forcing to the pbl scheme is ! reduced in a factor of hffac given as a function of surface roughness & -! green vegetation fraction (zvfun) +! green vegetation fraction (zvfun) ! do i=1,im hflxq(i) = hflx(i) From 2f417bb5f8c1e814ea5f3539615395d9ed096eca Mon Sep 17 00:00:00 2001 From: Helin Wei Date: Tue, 17 Oct 2023 12:32:30 -0400 Subject: [PATCH 362/380] refine surface 2m t/q diagnostic method --- physics/sfc_diag_post.F90 | 24 ++++++++++++++++++------ physics/sfc_diag_post.meta | 7 +++++++ 2 files changed, 25 insertions(+), 6 deletions(-) diff --git a/physics/sfc_diag_post.F90 b/physics/sfc_diag_post.F90 index c1a43f170..6945e48e9 100644 --- a/physics/sfc_diag_post.F90 +++ b/physics/sfc_diag_post.F90 @@ -14,16 +14,17 @@ module sfc_diag_post !! #endif subroutine sfc_diag_post_run (im, lsm, lsm_noahmp, opt_diag, dry, lssav, dtf, con_eps, con_epsm1, pgr,& - t2mmp,q2mp, t2m, q2m, u10m, v10m, tmpmin, tmpmax, spfhmin, spfhmax, & + vegtype,t2mmp,q2mp, t2m, q2m, u10m, v10m, tmpmin, tmpmax, spfhmin, spfhmax, & wind10mmax, u10mmax, v10mmax, dpt2m, errmsg, errflg) use machine, only: kind_phys, kind_dbl_prec implicit none - integer, intent(in) :: im, lsm, lsm_noahmp,opt_diag - logical, intent(in) :: lssav - real(kind=kind_phys), intent(in) :: dtf, con_eps, con_epsm1 + integer, intent(in) :: im, lsm, lsm_noahmp,opt_diag + integer, dimension(:), intent(in) :: vegtype ! vegetation type (integer index) + logical, intent(in) :: lssav + real(kind=kind_phys), intent(in) :: dtf, con_eps, con_epsm1 logical , dimension(:), intent(in) :: dry real(kind=kind_phys), dimension(:), intent(in) :: pgr, u10m, v10m real(kind=kind_phys), dimension(:), intent(inout) :: t2m, q2m, tmpmin, tmpmax, spfhmin, spfhmax @@ -41,12 +42,23 @@ subroutine sfc_diag_post_run (im, lsm, lsm_noahmp, opt_diag, dry, lssav, dtf, co errflg = 0 if (lsm == lsm_noahmp) then - if (opt_diag == 2 .or. opt_diag == 3)then +! over shrublands use opt_diag=2 + do i=1, im + if(dry(i)) then + if (vegtype(i) == 6 .or. vegtype(i) == 7 & + .or. vegtype(i) == 16) then + t2m(i) = t2mmp(i) + q2m(i) = q2mp(i) + endif + endif + enddo + + if (opt_diag == 2 .or. opt_diag == 3) then do i=1,im if(dry(i)) then t2m(i) = t2mmp(i) q2m(i) = q2mp(i) - endif + endif enddo endif endif diff --git a/physics/sfc_diag_post.meta b/physics/sfc_diag_post.meta index c50d3c4dc..17648753a 100644 --- a/physics/sfc_diag_post.meta +++ b/physics/sfc_diag_post.meta @@ -81,6 +81,13 @@ type = real kind = kind_phys intent = in +[vegtype] + standard_name = vegetation_type_classification + long_name = vegetation type at each grid cell + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent= in [t2mmp] standard_name = temperature_at_2m_from_noahmp long_name = 2 meter temperature from noahmp From 91415d42d51059697e8d0c03f8b7f00e3fb7aea3 Mon Sep 17 00:00:00 2001 From: "Xiaqiong.Zhou" Date: Fri, 20 Oct 2023 14:45:01 +0000 Subject: [PATCH 363/380] Add a switch to turn off samfdeepcnv when the MYNN shallow convection is active --- physics/samfdeepcnv.f | 6 ++++-- physics/samfdeepcnv.meta | 15 +++++++++++++++ 2 files changed, 19 insertions(+), 2 deletions(-) diff --git a/physics/samfdeepcnv.f b/physics/samfdeepcnv.f index 8a36fe34c..94a4cd148 100644 --- a/physics/samfdeepcnv.f +++ b/physics/samfdeepcnv.f @@ -83,7 +83,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & & CNV_DQLDT,CLCN,CNV_FICE,CNV_NDROP,CNV_NICE,mp_phys,mp_phys_mg,& & clam,c0s,c1,betal,betas,evef,pgcon,asolfac, & & do_ca, ca_closure, ca_entr, ca_trigger, nthresh,ca_deep, & - & rainevap,sigmain, sigmaout, errmsg,errflg) + & rainevap,sigmain, sigmaout, maxMF, do_mynnedmf, errmsg,errflg) ! use machine , only : kind_phys use funcphys , only : fpvs @@ -99,11 +99,12 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & & prslp(:,:), garea(:), hpbl(:), dot(:,:), phil(:,:) real(kind=kind_phys), dimension(:), intent(in) :: fscav logical, intent(in) :: first_time_step,restart,hwrf_samfdeep, & - & progsigma + & progsigma,do_mynnedmf real(kind=kind_phys), intent(in) :: nthresh real(kind=kind_phys), intent(in) :: ca_deep(:) real(kind=kind_phys), intent(in) :: sigmain(:,:),qmicro(:,:), & & tmf(:,:,:),q(:,:), prevsq(:,:) + real(kind=kind_phys), dimension (:), intent(in) :: maxMF real(kind=kind_phys), intent(out) :: rainevap(:) real(kind=kind_phys), intent(out) :: sigmaout(:,:) logical, intent(in) :: do_ca,ca_closure,ca_entr,ca_trigger @@ -347,6 +348,7 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & ! do i=1,im cnvflg(i) = .true. + if(do_mynnedmf.and.(maxMF(i).gt.0.))cnvflg(i)=.false. sfcpbl(i) = sfclfac * hpbl(i) rn(i)=0. mbdt(i)=10. diff --git a/physics/samfdeepcnv.meta b/physics/samfdeepcnv.meta index bed4d655d..86c713a06 100644 --- a/physics/samfdeepcnv.meta +++ b/physics/samfdeepcnv.meta @@ -450,6 +450,21 @@ type = real kind = kind_phys intent = out +[maxMF] + standard_name = maximum_mass_flux + long_name = maximum mass flux within a column + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[do_mynnedmf] + standard_name = flag_for_mellor_yamada_nakanishi_niino_pbl_scheme + long_name = flag to activate MYNN-EDMF + units = flag + dimensions = () + type = logical + intent = in [qlcn] standard_name = mass_fraction_of_convective_cloud_liquid_water long_name = mass fraction of convective cloud liquid water From b314eabab45297076deaad068e5d30f1fa6eab68 Mon Sep 17 00:00:00 2001 From: Xiaqiong Zhou Date: Tue, 24 Oct 2023 13:30:32 +0000 Subject: [PATCH 364/380] Fix the undefined dimension issue for maxmf in tests with GNU debug --- physics/samfdeepcnv.f | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/physics/samfdeepcnv.f b/physics/samfdeepcnv.f index 94a4cd148..7bf9cd2f5 100644 --- a/physics/samfdeepcnv.f +++ b/physics/samfdeepcnv.f @@ -348,7 +348,9 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & ! do i=1,im cnvflg(i) = .true. - if(do_mynnedmf.and.(maxMF(i).gt.0.))cnvflg(i)=.false. + if(do_mynnedmf) then + if(maxMF(i).gt.0.)cnvflg(i)=.false. + endif sfcpbl(i) = sfclfac * hpbl(i) rn(i)=0. mbdt(i)=10. From 2fc4a64040e36f150af41890270112b1abc3200d Mon Sep 17 00:00:00 2001 From: Lisa Bengtsson Date: Tue, 24 Oct 2023 22:11:54 +0000 Subject: [PATCH 365/380] Updates to bring out tuning parameters in C3 and SAS convection schemes --- physics/cu_c3_deep.F90 | 26 ++++++++++++++++++-------- physics/cu_c3_driver.F90 | 16 ++++++++++++---- physics/cu_c3_driver.meta | 23 +++++++++++++++++++++++ physics/cu_c3_sh.F90 | 23 ++++++++++++++--------- physics/progsigma_calc.f90 | 31 ++++++++++++++++++++----------- physics/samfdeepcnv.f | 19 +++++++++++-------- physics/samfdeepcnv.meta | 23 +++++++++++++++++++++++ physics/samfshalcnv.f | 19 +++++++++++-------- physics/samfshalcnv.meta | 23 +++++++++++++++++++++++ 9 files changed, 155 insertions(+), 48 deletions(-) diff --git a/physics/cu_c3_deep.F90 b/physics/cu_c3_deep.F90 index 7092840c3..7e907aaba 100644 --- a/physics/cu_c3_deep.F90 +++ b/physics/cu_c3_deep.F90 @@ -97,6 +97,9 @@ subroutine cu_c3_deep_run( & ,tmf & ! instantanious tendency from turbulence ,qmicro & ! instantanious tendency from microphysics ,forceqv_spechum & !instantanious tendency from dynamics + ,betascu & ! Tuning parameter for shallow clouds + ,betamcu & ! Tuning parameter for mid-level clouds + ,betadcu & ! Tuning parameter for deep clouds ,sigmain & ! input area fraction after advection ,sigmaout & ! updated prognostic area fraction ,z1 & ! terrain @@ -233,8 +236,8 @@ subroutine cu_c3_deep_run( & real(kind=kind_phys) & - ,intent (in ) :: & - dtime,ccnclean,fv,r_d + ,intent (in ) :: & + dtime,ccnclean,fv,r_d,betascu,betamcu,betadcu ! @@ -386,13 +389,16 @@ subroutine cu_c3_deep_run( & real(kind=kind_phys), dimension (its:ite) :: pefc real(kind=kind_phys) entdo,dp,subin,detdo,entup, & detup,subdown,entdoj,entupk,detupk,totmas + real(kind=kind_phys) :: & + sigmind,sigminm,sigmins + parameter(sigmind=0.005,sigmins=0.03,sigminm=0.01) real(kind=kind_phys), dimension (its:ite) :: lambau,flux_tun,zws,ztexec,zqexec !$acc declare create(lambau,flux_tun,zws,ztexec,zqexec) integer :: jprnt,jmini,start_k22 logical :: keep_going,flg(its:ite),cnvflg(its:ite) - logical :: flag_shallow + logical :: flag_shallow,flag_mid !$acc declare create(flg) @@ -1988,7 +1994,11 @@ subroutine cu_c3_deep_run( & ! equation 8, call progsigma_calc() to compute updraft area fraction based on a moisture budget if(progsigma)then + flag_mid = .false. flag_shallow = .false. + if(imid.eq.1)then + flag_mid = .true. + endif do k=kts,ktf do i=its,itf del(i,k) = delp(i,k)*0.001 @@ -2003,9 +2013,9 @@ subroutine cu_c3_deep_run( & endif enddo call progsigma_calc(itf,ktf,flag_init,flag_restart,flag_shallow, & - del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,xlv,dtime, & - forceqv_spechum,kbcon,ktop,cnvflg, & - sigmain,sigmaout,sigmab) + flag_mid,del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,xlv,dtime, & + forceqv_spechum,kbcon,ktop,cnvflg,betascu,betamcu,betadcu, & + sigmind,sigminm,sigmins,sigmain,sigmaout,sigmab) endif !$acc end kernels @@ -3147,7 +3157,7 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 ! pcrit,acrit,acritt integer, dimension (its:ite) :: kloc real(kind=kind_phys) :: & - a1,a_ave,xff0,xomg,gravinv!,aclim1,aclim2,aclim3,aclim4 + a1,a_ave,xff0,xomg,gravinv real(kind=kind_phys), dimension (its:ite) :: ens_adj !$acc declare create(kloc,ens_adj) @@ -5748,7 +5758,7 @@ subroutine calculate_updraft_velocity(its,itf,ktf,ite,kts,kte,ierr,progsigma, do k = 2, ktf-1 do i = 1, itf if (ierr(i)==0) then - if(k >= kbcon(i) .and. k < ktcon(i))then + if(k >= kbcon(i) .and. k < ktcon(i) .and. dbyo(i,k)>0.)then gamma = el2orc * qeso(i,k+1) / (to(i,k+1)**2) if(k >= kbcon(i) .and. clw_all(i,k)>0.)then buo(i,k) = buo(i,k) - g * qlk(i,k) diff --git a/physics/cu_c3_driver.F90 b/physics/cu_c3_driver.F90 index 8592e08f9..0ecb81750 100644 --- a/physics/cu_c3_driver.F90 +++ b/physics/cu_c3_driver.F90 @@ -60,7 +60,8 @@ end subroutine cu_c3_driver_init subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& do_ca,progsigma,cactiv,cactiv_m,g,cp,fv,r_d,xlv,r_v,forcet, & forceqv_spechum,phil,delp,raincv,tmf,qmicro,sigmain, & - qv_spechum,t,cld1d,us,vs,t2di,w,qv2di_spechum,p2di,psuri, & + betascu,betamcu,betadcu,qv_spechum,t,cld1d,us,vs,t2di,w, & + qv2di_spechum,p2di,psuri, & hbot,htop,kcnv,xland,hfx2,qfx2,aod_gf,cliw,clcw,ca_deep,rainevap,& pbl,ud_mf,dd_mf,dt_mf,cnvw_moist,cnvc,imfshalcnv, & flag_for_scnv_generic_tend,flag_for_dcnv_generic_tend, & @@ -97,7 +98,7 @@ subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& logical, intent(in ) :: flag_init, flag_restart, do_mynnedmf logical, intent(in ) :: flag_for_scnv_generic_tend,flag_for_dcnv_generic_tend, & do_ca,progsigma - real (kind=kind_phys), intent(in) :: g,cp,fv,r_d,xlv,r_v + real (kind=kind_phys), intent(in) :: g,cp,fv,r_d,xlv,r_v,betascu,betamcu,betadcu logical, intent(in ) :: ldiag3d real(kind=kind_phys), intent(inout) :: dtend(:,:,:) @@ -587,7 +588,7 @@ subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& hfx(i)=hfx2(i)*cp*rhoi(i,1) qfx(i)=qfx2(i)*xlv*rhoi(i,1) dx(i) = sqrt(garea(i)) - enddo + enddo do i=its,itf do k=kts,kpbli(i) @@ -669,7 +670,8 @@ subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& zus,xmbs,kbcons,ktops,k22s,ierrs,ierrcs, & ! Prog closure flag_init, flag_restart,fv,r_d,delp,tmfq,qmicro, & - forceqv_spechum,sigmain,sigmaout,progsigma,dx, & + forceqv_spechum,betascu,betamcu,betadcu,sigmain, & + sigmaout,progsigma,dx, & ! output tendencies outts,outqs,outqcs,outus,outvs,cnvwt,prets,cupclws, & ! dimesnional variables @@ -714,6 +716,9 @@ subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,tmfq & ,qmicro & ,forceqv_spechum & + ,betascu & + ,betamcu & + ,betadcu & ,sigmain & ,sigmaout & ,ter11 & @@ -805,6 +810,9 @@ subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ,tmfq & ,qmicro & ,forceqv_spechum & + ,betascu & + ,betamcu & + ,betadcu & ,sigmain & ,sigmaout & ,ter11 & diff --git a/physics/cu_c3_driver.meta b/physics/cu_c3_driver.meta index 999b5c2bc..e02116243 100644 --- a/physics/cu_c3_driver.meta +++ b/physics/cu_c3_driver.meta @@ -244,6 +244,29 @@ type = real kind = kind_phys intent = out +[betascu] + standard_name = tuning_param_for_shallow_cu + long_name = tuning param for shallow cu in case prognostic closure is used + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[betamcu] + standard_name = tuning_param_for_midlevel_cu + long_name = tuning param for midlevel cu in case prognostic closure is used + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[betadcu] + standard_name = tuning_param_for_deep_cu + long_name = tuning param for deep cu in case prognostic closure is used + units = none + dimensions = () + type = real + intent = in [phil] standard_name = geopotential long_name = layer geopotential diff --git a/physics/cu_c3_sh.F90 b/physics/cu_c3_sh.F90 index a79e1dfcf..704f2a0fc 100644 --- a/physics/cu_c3_sh.F90 +++ b/physics/cu_c3_sh.F90 @@ -68,7 +68,8 @@ subroutine cu_c3_sh_run ( & hfx,qfx,xland,ichoice,tcrit,dtime, & zuo,xmb_out,kbcon,ktop,k22,ierr,ierrc, & flag_init, flag_restart,fv,r_d,delp,tmf,qmicro, & - forceqv_spechum,sigmain,sigmaout,progsigma,dx, & + forceqv_spechum,betascu,betamcu,betadcu,sigmain,& + sigmaout,progsigma,dx, & outt,outq,outqc,outu,outv,cnvwt,pre,cupclw, & ! output tendencies itf,ktf,its,ite, kts,kte,ipr,tropics) ! dimesnional variables ! @@ -131,7 +132,7 @@ subroutine cu_c3_sh_run ( & real(kind=kind_phys) & ,intent (in ) :: & - dtime,tcrit,fv,r_d + dtime,tcrit,fv,r_d,betascu,betamcu,betadcu !$acc declare sigmaout real(kind=kind_phys), dimension (its:,kts:) & ,intent (out) :: & @@ -234,15 +235,18 @@ subroutine cu_c3_sh_run ( & !$acc cap_max_increment,lambau, & !$acc kstabi,xland1,kbmax,ktopx) - logical :: flag_shallow + logical :: flag_shallow,flag_mid logical, dimension(its:ite) :: cnvflg integer :: & kstart,i,k,ki - real(kind=kind_phys) :: & + real(kind=kind_phys) :: & dz,mbdt,zkbmax, & cap_maxs,trash,trash2,frh,el2orc,gravinv - real(kind=kind_phys) buo_flux,pgeoh,dp,entup,detup,totmas + real(kind=kind_phys) buo_flux,pgeoh,dp,entup,detup,totmas + real(kind=kind_phys) :: & + sigmind,sigminm,sigmins + parameter(sigmind=0.005,sigmins=0.03,sigminm=0.01) real(kind=kind_phys) xff_shal(3),blqe,xkshal character*50 :: ierrc(its:) @@ -672,13 +676,13 @@ subroutine cu_c3_sh_run ( & dz=z_cup(i,k)-z_cup(i,k-1) ! cloud liquid water c1d(i,k)=c1_shal! 0. !.02*up_massdetr(i,k-1) + clw_all(i,k)=max(0.,qco(i,k)-trash) qrco(i,k)= (qco(i,k)-trash)/(1.+(c0_shal+c1d(i,k))*dz) if(qrco(i,k).lt.0.)then ! hli new test 02/12/19 qrco(i,k)=0. !c1d(i,k)=0. endif pwo(i,k)=c0_shal*dz*qrco(i,k)*zuo(i,k) - clw_all(i,k)=qco(i,k)-trash !LB total cloud before rain and detrain ! cloud water vapor qco (i,k)= trash+qrco(i,k) @@ -960,6 +964,7 @@ subroutine cu_c3_sh_run ( & ! equation 8, call progsigma_calc() to compute updraft area fraction based on a moisture budget if(progsigma)then flag_shallow = .true. + flag_mid = .false. do k=kts,ktf do i=its,itf del(i,k) = delp(i,k)*0.001 @@ -974,9 +979,9 @@ subroutine cu_c3_sh_run ( & endif enddo call progsigma_calc(itf,ktf,flag_init,flag_restart,flag_shallow, & - del,tmf,qmicro,dbyo,zdqca,omega_u,zeta,xlv,dtime, & - forceqv_spechum,kbcon,ktop,cnvflg, & - sigmain,sigmaout,sigmab) + flag_mid,del,tmf,qmicro,dbyo,zdqca,omega_u,zeta,xlv,dtime, & + forceqv_spechum,kbcon,ktop,cnvflg,betascu,betamcu,betadcu, & + sigmind,sigminm,sigmins,sigmain,sigmaout,sigmab) endif diff --git a/physics/progsigma_calc.f90 b/physics/progsigma_calc.f90 index c87308602..469df49f6 100644 --- a/physics/progsigma_calc.f90 +++ b/physics/progsigma_calc.f90 @@ -19,10 +19,10 @@ module progsigma !! This subroutine computes a prognostic updraft area fracftion !! used in the closure computations in the samfshalcnv. scheme !!\section gen_progsigma progsigma_calc General Algorithm - subroutine progsigma_calc (im,km,flag_init,flag_restart, & - flag_shallow,del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,hvap, & - delt,qadv,kbcon1,ktcon,cnvflg,sigmain,sigmaout, & - sigmab) + subroutine progsigma_calc (im,km,flag_init,flag_restart,flag_shallow,& + flag_mid,del,tmf,qmicro,dbyo1,zdqca,omega_u,zeta,hvap, & + delt,qadv,kbcon1,ktcon,cnvflg,betascu,betamcu,betadcu, & + sigmind,sigminm,sigmins,sigmain,sigmaout,sigmab) ! ! use machine, only : kind_phys @@ -32,11 +32,12 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & ! intent in integer, intent(in) :: im,km,kbcon1(im),ktcon(im) - real(kind=kind_phys), intent(in) :: hvap,delt + real(kind=kind_phys), intent(in) :: hvap,delt,betascu,betamcu,betadcu, & + sigmind,sigminm,sigmins real(kind=kind_phys), intent(in) :: qadv(im,km),del(im,km), & qmicro(im,km),tmf(im,km),dbyo1(im,km),zdqca(im,km), & omega_u(im,km),zeta(im,km) - logical, intent(in) :: flag_init,flag_restart,cnvflg(im),flag_shallow + logical, intent(in) :: flag_init,flag_restart,cnvflg(im),flag_shallow,flag_mid real(kind=kind_phys), intent(in) :: sigmain(im,km) ! intent out @@ -53,15 +54,13 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & real(kind=kind_phys) :: gcvalmx,epsilon,ZZ,cvg,mcon,buy2, & fdqb,dtdyn,dxlim,rmulacvg,tem, & - DEN,betascu,betadcu,dp1,invdelt + DEN,dp1,invdelt !Parameters gcvalmx = 0.1 rmulacvg=10. epsilon=1.E-11 km1=km-1 - betadcu = 2.0 - betascu = 8.0 invdelt = 1./delt !Initialization 2D @@ -206,17 +205,27 @@ subroutine progsigma_calc (im,km,flag_init,flag_restart, & do i= 1, im if(cnvflg(i)) then sigmab(i)=sigmab(i)/betascu - sigmab(i)=MAX(0.03,sigmab(i)) + sigmab(i)=MAX(sigmins,sigmab(i)) + endif + enddo + elseif(flag_mid)then + do i= 1, im + if(cnvflg(i)) then + sigmab(i)=sigmab(i)/betamcu + sigmab(i)=MAX(sigminm,sigmab(i)) endif enddo else do i= 1, im if(cnvflg(i)) then sigmab(i)=sigmab(i)/betadcu - sigmab(i)=MAX(0.01,sigmab(i)) + sigmab(i)=MAX(sigmind,sigmab(i)) endif enddo endif + do i= 1, im + sigmab(i) = MIN(0.95,sigmab(i)) + enddo end subroutine progsigma_calc diff --git a/physics/samfdeepcnv.f b/physics/samfdeepcnv.f index 8a36fe34c..e8faecf14 100644 --- a/physics/samfdeepcnv.f +++ b/physics/samfdeepcnv.f @@ -83,7 +83,8 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & & CNV_DQLDT,CLCN,CNV_FICE,CNV_NDROP,CNV_NICE,mp_phys,mp_phys_mg,& & clam,c0s,c1,betal,betas,evef,pgcon,asolfac, & & do_ca, ca_closure, ca_entr, ca_trigger, nthresh,ca_deep, & - & rainevap,sigmain, sigmaout, errmsg,errflg) + & rainevap,sigmain,sigmaout,betadcu,betamcu,betascu, & + & errmsg,errflg) ! use machine , only : kind_phys use funcphys , only : fpvs @@ -100,14 +101,14 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & real(kind=kind_phys), dimension(:), intent(in) :: fscav logical, intent(in) :: first_time_step,restart,hwrf_samfdeep, & & progsigma - real(kind=kind_phys), intent(in) :: nthresh + real(kind=kind_phys), intent(in) :: nthresh,betadcu,betamcu, & + & betascu real(kind=kind_phys), intent(in) :: ca_deep(:) real(kind=kind_phys), intent(in) :: sigmain(:,:),qmicro(:,:), & & tmf(:,:,:),q(:,:), prevsq(:,:) real(kind=kind_phys), intent(out) :: rainevap(:) real(kind=kind_phys), intent(out) :: sigmaout(:,:) logical, intent(in) :: do_ca,ca_closure,ca_entr,ca_trigger - integer, intent(inout) :: kcnv(:) ! DH* TODO - check dimensions of qtr, ntr+2 correct? *DH real(kind=kind_phys), intent(inout) :: qtr(:,:,:), & @@ -213,8 +214,9 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & ! parameters for prognostic sigma closure real(kind=kind_phys) omega_u(im,km),zdqca(im,km),tmfq(im,km), & omegac(im),zeta(im,km),dbyo1(im,km),sigmab(im),qadv(im,km) - real(kind=kind_phys) gravinv,invdelt - logical flag_shallow + real(kind=kind_phys) gravinv,invdelt,sigmind,sigminm,sigmins + parameter(sigmind=0.01,sigmins=0.03,sigminm=0.01) + logical flag_shallow, flag_mid c physical parameters ! parameter(grav=grav,asolfac=0.958) ! parameter(elocp=hvap/cp,el2orc=hvap*hvap/(rv*cp)) @@ -2930,10 +2932,11 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & enddo flag_shallow = .false. + flag_mid = .false. call progsigma_calc(im,km,first_time_step,restart,flag_shallow, - & del,tmfq,qmicro,dbyo1,zdqca,omega_u,zeta,hvap,delt, - & qadv,kbcon1,ktcon,cnvflg, - & sigmain,sigmaout,sigmab) + & flag_mid,del,tmfq,qmicro,dbyo1,zdqca,omega_u,zeta,hvap, + & delt,qadv,kbcon1,ktcon,cnvflg,betascu,betamcu,betadcu, + & sigmind,sigminm,sigmins,sigmain,sigmaout,sigmab) endif !> - From Han et al.'s (2017) \cite han_et_al_2017 equation 6, calculate cloud base mass flux as a function of the mean updraft velcoity for the grid sizes where the quasi-equilibrium assumption of Arakawa-Schubert is not valid any longer. diff --git a/physics/samfdeepcnv.meta b/physics/samfdeepcnv.meta index bed4d655d..d0d39d830 100644 --- a/physics/samfdeepcnv.meta +++ b/physics/samfdeepcnv.meta @@ -450,6 +450,29 @@ type = real kind = kind_phys intent = out +[betascu] + standard_name = tuning_param_for_shallow_cu + long_name = tuning param for shallow cu in case prognostic closure is used + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[betamcu] + standard_name = tuning_param_for_midlevel_cu + long_name = tuning param for midlevel cu in case prognostic closure is used + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[betadcu] + standard_name = tuning_param_for_deep_cu + long_name = tuning param for deep cu in case prognostic closure is used + units = none + dimensions = () + type = real + intent = in [qlcn] standard_name = mass_fraction_of_convective_cloud_liquid_water long_name = mass fraction of convective cloud liquid water diff --git a/physics/samfshalcnv.f b/physics/samfshalcnv.f index a7682342f..3869ea6ea 100644 --- a/physics/samfshalcnv.f +++ b/physics/samfshalcnv.f @@ -57,7 +57,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & & rn,kbot,ktop,kcnv,islimsk,garea, & & dot,ncloud,hpbl,ud_mf,dt_mf,cnvw,cnvc, & & clam,c0s,c1,evef,pgcon,asolfac,hwrf_samfshal, & - & sigmain,sigmaout,errmsg,errflg) + & sigmain,sigmaout,betadcu,betamcu,betascu,errmsg,errflg) ! use machine , only : kind_phys use funcphys , only : fpvs @@ -67,7 +67,8 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & integer, intent(in) :: im, km, itc, ntc, ntk, ntr, ncloud integer, intent(in) :: islimsk(:) real(kind=kind_phys), intent(in) :: cliq, cp, cvap, & - & eps, epsm1, fv, grav, hvap, rd, rv, t0c + & eps, epsm1, fv, grav, hvap, rd, rv, t0c, betascu, betadcu, & + & betamcu real(kind=kind_phys), intent(in) :: delt real(kind=kind_phys), intent(in) :: psp(:), delp(:,:), & & prslp(:,:), garea(:), hpbl(:), dot(:,:), phil(:,:), & @@ -159,8 +160,9 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & real(kind=kind_phys) omega_u(im,km),zdqca(im,km),tmfq(im,km), & omegac(im),zeta(im,km),dbyo1(im,km), & sigmab(im),qadv(im,km) - real(kind=kind_phys) gravinv,dxcrtas,invdelt - logical flag_shallow + real(kind=kind_phys) gravinv,dxcrtas,invdelt,sigmind,sigmins, + & sigminm + logical flag_shallow,flag_mid c physical parameters ! parameter(g=grav,asolfac=0.89) ! parameter(g=grav) @@ -194,7 +196,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & parameter(betaw=.03,dxcrtc0=9.e3) parameter(h1=0.33333333) ! progsigma - parameter(dxcrtas=30.e3) + parameter(dxcrtas=30.e3,sigmind=0.01,sigmins=0.03,sigminm=0.01) c local variables and arrays real(kind=kind_phys) pfld(im,km), to(im,km), qo(im,km), & uo(im,km), vo(im,km), qeso(im,km), @@ -1974,10 +1976,11 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & enddo flag_shallow = .true. + flag_mid = .false. call progsigma_calc(im,km,first_time_step,restart,flag_shallow, - & del,tmfq,qmicro,dbyo1,zdqca,omega_u,zeta,hvap,delt, - & qadv,kbcon1,ktcon,cnvflg, - & sigmain,sigmaout,sigmab) + & flag_mid,del,tmfq,qmicro,dbyo1,zdqca,omega_u,zeta,hvap, + & delt,qadv,kbcon1,ktcon,cnvflg,betascu,betamcu,betadcu, + & sigmind,sigminm,sigmins,sigmain,sigmaout,sigmab) endif !> - From Han et al.'s (2017) \cite han_et_al_2017 equation 6, calculate cloud base mass flux as a function of the mean updraft velcoity. diff --git a/physics/samfshalcnv.meta b/physics/samfshalcnv.meta index c1fffef58..200e33707 100644 --- a/physics/samfshalcnv.meta +++ b/physics/samfshalcnv.meta @@ -482,6 +482,29 @@ type = real kind = kind_phys intent = out +[betascu] + standard_name = tuning_param_for_shallow_cu + long_name = tuning param for shallow cu in case prognostic closure is used + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[betamcu] + standard_name = tuning_param_for_midlevel_cu + long_name = tuning param for midlevel cu in case prognostic closure is used + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[betadcu] + standard_name = tuning_param_for_deep_cu + long_name = tuning param for deep cu in case prognostic closure is used + units = none + dimensions = () + type = real + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 12b400a210854d33e64fd6d211482d9f8ab7add5 Mon Sep 17 00:00:00 2001 From: Lisa Bengtsson Date: Wed, 25 Oct 2023 21:30:26 +0000 Subject: [PATCH 366/380] Ensure prognostic closure is not used at coarse resolution --- physics/cu_c3_deep.F90 | 2 +- physics/cu_c3_driver.F90 | 16 ++++++++++++---- physics/cu_c3_driver.meta | 7 +++++++ 3 files changed, 20 insertions(+), 5 deletions(-) diff --git a/physics/cu_c3_deep.F90 b/physics/cu_c3_deep.F90 index 7e907aaba..b7cd5f62d 100644 --- a/physics/cu_c3_deep.F90 +++ b/physics/cu_c3_deep.F90 @@ -5758,7 +5758,7 @@ subroutine calculate_updraft_velocity(its,itf,ktf,ite,kts,kte,ierr,progsigma, do k = 2, ktf-1 do i = 1, itf if (ierr(i)==0) then - if(k >= kbcon(i) .and. k < ktcon(i) .and. dbyo(i,k)>0.)then + if(k >= kbcon(i) .and. k < ktcon(i))then gamma = el2orc * qeso(i,k+1) / (to(i,k+1)**2) if(k >= kbcon(i) .and. clw_all(i,k)>0.)then buo(i,k) = buo(i,k) - g * qlk(i,k) diff --git a/physics/cu_c3_driver.F90 b/physics/cu_c3_driver.F90 index 0ecb81750..5b6be1d6c 100644 --- a/physics/cu_c3_driver.F90 +++ b/physics/cu_c3_driver.F90 @@ -58,7 +58,7 @@ end subroutine cu_c3_driver_init !! !>\section gen_c3_driver Grell-Freitas Cumulus Scheme Driver General Algorithm subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& - do_ca,progsigma,cactiv,cactiv_m,g,cp,fv,r_d,xlv,r_v,forcet, & + do_ca,progsigma,cnx,cactiv,cactiv_m,g,cp,fv,r_d,xlv,r_v,forcet, & forceqv_spechum,phil,delp,raincv,tmf,qmicro,sigmain, & betascu,betamcu,betadcu,qv_spechum,t,cld1d,us,vs,t2di,w, & qv2di_spechum,p2di,psuri, & @@ -93,14 +93,14 @@ subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& integer :: ishallow_g3 ! depend on imfshalcnv !------------------------------------------------------------- integer :: its,ite, jts,jte, kts,kte - integer, intent(in ) :: im,km,ntracer + integer, intent(in ) :: im,km,ntracer,cnx integer, intent(in ) :: ichoice_in,ichoicem_in,ichoice_s_in logical, intent(in ) :: flag_init, flag_restart, do_mynnedmf logical, intent(in ) :: flag_for_scnv_generic_tend,flag_for_dcnv_generic_tend, & - do_ca,progsigma + do_ca real (kind=kind_phys), intent(in) :: g,cp,fv,r_d,xlv,r_v,betascu,betamcu,betadcu logical, intent(in ) :: ldiag3d - + logical, intent(inout) :: progsigma real(kind=kind_phys), intent(inout) :: dtend(:,:,:) !$acc declare copy(dtend) integer, intent(in) :: dtidx(:,:), & @@ -280,6 +280,14 @@ subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& !$acc end kernels endif + + if(progsigma)then + if(cnx < 384)then + progsigma=.false. + write(*,*)'Forcing prognostic closure to .false. due to coarse resolution' + endif + endif + if(ldiag3d) then if(flag_for_dcnv_generic_tend) then cliw_deep_idx=0 diff --git a/physics/cu_c3_driver.meta b/physics/cu_c3_driver.meta index e02116243..71a785318 100644 --- a/physics/cu_c3_driver.meta +++ b/physics/cu_c3_driver.meta @@ -133,6 +133,13 @@ units = flag dimensions = () type = logical + intent = inout +[cnx] + standard_name = number_of_x_points_for_current_cubed_sphere_tile + long_name = number of points in x direction for this cubed sphere face + units = count + dimensions = () + type = integer intent = in [cactiv] standard_name = counter_for_grell_freitas_convection From 81563de9686260bc5f1c85fe350d48e56fdf7afc Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Thu, 26 Oct 2023 19:17:33 +0000 Subject: [PATCH 367/380] move setting of flag from run to init phase --- physics/cu_c3_driver.F90 | 26 ++++++++++++++------------ physics/cu_c3_driver.meta | 21 ++++++++++++++------- 2 files changed, 28 insertions(+), 19 deletions(-) diff --git a/physics/cu_c3_driver.F90 b/physics/cu_c3_driver.F90 index 5b6be1d6c..c911ff5e4 100644 --- a/physics/cu_c3_driver.F90 +++ b/physics/cu_c3_driver.F90 @@ -30,7 +30,8 @@ module cu_c3_driver !! \htmlinclude cu_c3_driver_init.html !! subroutine cu_c3_driver_init(imfshalcnv, imfshalcnv_c3, imfdeepcnv, & - imfdeepcnv_c3,mpirank, mpiroot, errmsg, errflg) + imfdeepcnv_c3,progsigma, cnx, mpirank, mpiroot, & + errmsg, errflg) implicit none @@ -38,6 +39,8 @@ subroutine cu_c3_driver_init(imfshalcnv, imfshalcnv_c3, imfdeepcnv, & integer, intent(in) :: imfdeepcnv, imfdeepcnv_c3 integer, intent(in) :: mpirank integer, intent(in) :: mpiroot + integer, intent(in) :: cnx + logical, intent(inout) :: progsigma character(len=*), intent( out) :: errmsg integer, intent( out) :: errflg @@ -45,6 +48,13 @@ subroutine cu_c3_driver_init(imfshalcnv, imfshalcnv_c3, imfdeepcnv, & errmsg = '' errflg = 0 + if(progsigma)then + if(cnx < 384)then + progsigma=.false. + write(*,*)'Forcing prognostic closure to .false. due to coarse resolution' + endif + endif + end subroutine cu_c3_driver_init ! @@ -58,7 +68,7 @@ end subroutine cu_c3_driver_init !! !>\section gen_c3_driver Grell-Freitas Cumulus Scheme Driver General Algorithm subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& - do_ca,progsigma,cnx,cactiv,cactiv_m,g,cp,fv,r_d,xlv,r_v,forcet, & + do_ca,progsigma,cactiv,cactiv_m,g,cp,fv,r_d,xlv,r_v,forcet, & forceqv_spechum,phil,delp,raincv,tmf,qmicro,sigmain, & betascu,betamcu,betadcu,qv_spechum,t,cld1d,us,vs,t2di,w, & qv2di_spechum,p2di,psuri, & @@ -93,14 +103,14 @@ subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& integer :: ishallow_g3 ! depend on imfshalcnv !------------------------------------------------------------- integer :: its,ite, jts,jte, kts,kte - integer, intent(in ) :: im,km,ntracer,cnx + integer, intent(in ) :: im,km,ntracer integer, intent(in ) :: ichoice_in,ichoicem_in,ichoice_s_in logical, intent(in ) :: flag_init, flag_restart, do_mynnedmf logical, intent(in ) :: flag_for_scnv_generic_tend,flag_for_dcnv_generic_tend, & do_ca real (kind=kind_phys), intent(in) :: g,cp,fv,r_d,xlv,r_v,betascu,betamcu,betadcu logical, intent(in ) :: ldiag3d - logical, intent(inout) :: progsigma + logical, intent(in ) :: progsigma real(kind=kind_phys), intent(inout) :: dtend(:,:,:) !$acc declare copy(dtend) integer, intent(in) :: dtidx(:,:), & @@ -280,14 +290,6 @@ subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& !$acc end kernels endif - - if(progsigma)then - if(cnx < 384)then - progsigma=.false. - write(*,*)'Forcing prognostic closure to .false. due to coarse resolution' - endif - endif - if(ldiag3d) then if(flag_for_dcnv_generic_tend) then cliw_deep_idx=0 diff --git a/physics/cu_c3_driver.meta b/physics/cu_c3_driver.meta index 71a785318..801b1e9d7 100644 --- a/physics/cu_c3_driver.meta +++ b/physics/cu_c3_driver.meta @@ -49,6 +49,20 @@ dimensions = () type = integer intent = in +[progsigma] + standard_name = do_prognostic_updraft_area_fraction + long_name = flag for prognostic sigma in cumuls scheme + units = flag + dimensions = () + type = logical + intent = inout +[cnx] + standard_name = number_of_x_points_for_current_cubed_sphere_tile + long_name = number of points in x direction for this cubed sphere face + units = count + dimensions = () + type = integer + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -133,13 +147,6 @@ units = flag dimensions = () type = logical - intent = inout -[cnx] - standard_name = number_of_x_points_for_current_cubed_sphere_tile - long_name = number of points in x direction for this cubed sphere face - units = count - dimensions = () - type = integer intent = in [cactiv] standard_name = counter_for_grell_freitas_convection From e861277c1ffe8fdcb1b026240f98077bb7a91473 Mon Sep 17 00:00:00 2001 From: Lisa Bengtsson Date: Thu, 26 Oct 2023 21:10:37 +0000 Subject: [PATCH 368/380] address review comments --- physics/cu_c3_sh.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/cu_c3_sh.F90 b/physics/cu_c3_sh.F90 index 704f2a0fc..736292092 100644 --- a/physics/cu_c3_sh.F90 +++ b/physics/cu_c3_sh.F90 @@ -676,7 +676,7 @@ subroutine cu_c3_sh_run ( & dz=z_cup(i,k)-z_cup(i,k-1) ! cloud liquid water c1d(i,k)=c1_shal! 0. !.02*up_massdetr(i,k-1) - clw_all(i,k)=max(0.,qco(i,k)-trash) + clw_all(i,k)=max(0._kind_phys,qco(i,k)-trash) qrco(i,k)= (qco(i,k)-trash)/(1.+(c0_shal+c1d(i,k))*dz) if(qrco(i,k).lt.0.)then ! hli new test 02/12/19 qrco(i,k)=0. From 32cf7ba5484db1387e33c7f9d25de87079e9014c Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Fri, 27 Oct 2023 17:01:01 +0000 Subject: [PATCH 369/380] Reverted standard_name change --- physics/GFS_phys_time_vary.fv3.meta | 2 +- physics/GFS_phys_time_vary.scm.meta | 2 +- physics/GFS_suite_stateout_update.meta | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/GFS_phys_time_vary.fv3.meta b/physics/GFS_phys_time_vary.fv3.meta index ad543e146..968f33027 100644 --- a/physics/GFS_phys_time_vary.fv3.meta +++ b/physics/GFS_phys_time_vary.fv3.meta @@ -1205,7 +1205,7 @@ standard_name = ozone_forcing long_name = ozone forcing data units = mixed - dimensions = (horizontal_dimension,number_of_levels_in_ozone_data,number_of_coefficients_in_ozone_data) + dimensions = (horizontal_dimension,vertical_dimension_of_ozone_forcing_data,number_of_coefficients_in_ozone_data) type = real kind = kind_phys intent = inout diff --git a/physics/GFS_phys_time_vary.scm.meta b/physics/GFS_phys_time_vary.scm.meta index cf5ad15ca..d72e27fd5 100644 --- a/physics/GFS_phys_time_vary.scm.meta +++ b/physics/GFS_phys_time_vary.scm.meta @@ -1110,7 +1110,7 @@ standard_name = ozone_forcing long_name = ozone forcing data units = mixed - dimensions = (horizontal_dimension,number_of_levels_in_ozone_data,number_of_coefficients_in_ozone_data) + dimensions = (horizontal_dimension,vertical_dimension_of_ozone_forcing_data,number_of_coefficients_in_ozone_data) type = real kind = kind_phys intent = inout diff --git a/physics/GFS_suite_stateout_update.meta b/physics/GFS_suite_stateout_update.meta index 8cbab9139..fae276d2f 100644 --- a/physics/GFS_suite_stateout_update.meta +++ b/physics/GFS_suite_stateout_update.meta @@ -218,7 +218,7 @@ standard_name = ozone_forcing long_name = ozone forcing data units = mixed - dimensions = (horizontal_loop_extent,number_of_levels_in_ozone_data,number_of_coefficients_in_ozone_data) + dimensions = (horizontal_loop_extent,vertical_dimension_of_ozone_forcing_data,number_of_coefficients_in_ozone_data) type = real kind = kind_phys intent = in From 1abaff07fabc582e2ddaaf4977e337c85e5e9dfa Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Sun, 29 Oct 2023 15:42:36 -0500 Subject: [PATCH 370/380] module_mp_nssl_2mom.F90: fix bug when nz > 128 where sedimentation did not work for k > 128 --- physics/module_mp_nssl_2mom.F90 | 152 ++++++++++++++++++++++++-------- 1 file changed, 115 insertions(+), 37 deletions(-) diff --git a/physics/module_mp_nssl_2mom.F90 b/physics/module_mp_nssl_2mom.F90 index a88ffe053..ad90ec81f 100644 --- a/physics/module_mp_nssl_2mom.F90 +++ b/physics/module_mp_nssl_2mom.F90 @@ -4274,7 +4274,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ! real gz(-nor+ng1:nz+nor),z1d(-nor+ng1:nz+nor,4) real dtp real xfall(nx,ny,na) ! array for stuff landing on the ground - real xfall0(nx,ny) ! dummy array +! real xfall0(nx,ny) ! dummy array integer infdo integer jslab ! which line of xfall to use @@ -4282,47 +4282,81 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & real tmp, vtmax, dtptmp, dtfrac real, parameter :: dz = 200. - real :: xvt(nz+1,nx,3,lc:lhab) ! (nx,nz,2,lc:lhab) ! 1=mass-weighted, 2=number-weighted - real :: tmpn(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) - real :: tmpn2(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) - real :: z(-nor+ng1:nx+nor,-norz+ng1:nz+norz,lr:lhab) - real :: db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1) +! real :: xvt(nz+1,nx,3,lc:lhab) ! (nx,nz,2,lc:lhab) ! 1=mass-weighted, 2=number-weighted +! real :: tmpn(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) +! real :: tmpn2(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) +! real :: z(-nor+ng1:nx+nor,-norz+ng1:nz+norz,lr:lhab) +! real :: db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1) - real :: rhovtzx(nz,nx) +! real :: rhovtzx(nz,nx) + + real, allocatable :: db1(:,:), dtz1(:,:,:),dz2dinv(:,:),db1inv(:,:) ! db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1) + real, allocatable :: rhovtzx(:,:) + real, allocatable :: xfall0(:,:), xvt(:,:,:,:),tmpn(:,:,:),tmpn2(:,:,:),z(:,:,:) double precision :: timesed1,timesed2,timesed3, zmaxsed,timesetvt,dummy double precision :: dt1,dt2,dt3,dt4 - integer,parameter :: ngs = 128 + integer :: ngs ! = 512 integer :: ngscnt,mgs,ipconc0 - real :: qx(ngs,lv:lhab) - real :: qxw(ngs,ls:lhab) - real :: cx(ngs,lc:lhab) - real :: xv(ngs,lc:lhab) - real :: vtxbar(ngs,lc:lhab,3) - real :: xmas(ngs,lc:lhab) - real :: xdn(ngs,lc:lhab) - real :: xdia(ngs,lc:lhab,3) - real :: vx(ngs,li:lhab) - real :: alpha(ngs,lc:lhab) - real :: zx(ngs,lr:lhab) - logical :: hasmass(nx,lc+1:lhab) - - integer igs(ngs),kgs(ngs) - - real rho0(ngs),temcg(ngs) - - real temg(ngs) - - real rhovt(ngs) - - real cwnc(ngs),cinc(ngs) - real fadvisc(ngs),cwdia(ngs),cipmas(ngs) - - real cimasn,cimasx,cnina(ngs),cimas(ngs) - - real cnostmp(ngs) +! real :: qx(ngs,lv:lhab) +! real :: qxw(ngs,ls:lhab) +! real :: cx(ngs,lc:lhab) +! real :: xv(ngs,lc:lhab) +! real :: vtxbar(ngs,lc:lhab,3) +! real :: xmas(ngs,lc:lhab) +! real :: xdn(ngs,lc:lhab) +! real :: xdia(ngs,lc:lhab,3) +! real :: vx(ngs,li:lhab) +! real :: alpha(ngs,lc:lhab) +! real :: zx(ngs,lr:lhab) +! logical :: hasmass(nx,lc+1:lhab) +! +! integer igs(ngs),kgs(ngs) +! +! real rho0(ngs),temcg(ngs) +! +! real temg(ngs) +! +! real rhovt(ngs) +! +! real cwnc(ngs),cinc(ngs) +! real fadvisc(ngs),cwdia(ngs),cipmas(ngs) +! +! real cimasn,cimasx,cnina(ngs),cimas(ngs) +! +! real cnostmp(ngs) + + real, allocatable :: qx(:,:) + real, allocatable :: qxw(:,:) + real, allocatable :: cx(:,:) + real, allocatable :: xv(:,:) + real, allocatable :: vtxbar(:,:,:) + real, allocatable :: xmas(:,:) + real, allocatable :: xdn(:,:) + real, allocatable :: xdia(:,:,:) + real, allocatable :: vx(:,:) + real, allocatable :: alpha(:,:) + real, allocatable :: zx(:,:) + logical, allocatable :: hasmass(:,:) + + integer, allocatable :: igs(:),kgs(:) + + real, allocatable :: rho0(:),temcg(:) + + real, allocatable :: temg(:) + + real, allocatable :: rhovt(:) + + real, allocatable :: cwnc(:),cinc(:) + real, allocatable :: fadvisc(:),cwdia(:),cipmas(:) + + real, allocatable :: cnina(:),cimas(:) + + real, allocatable :: cnostmp(:) + + real :: cimasn,cimasx !----------------------------------------------------------------------------- @@ -4336,7 +4370,30 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ! ################################################################### - + allocate( db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1),rhovtzx(nz,nx) ) + allocate( xfall0(nx,ny), xvt(nz+1,nx,3,lc:lhab), tmpn(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) ) + allocate( tmpn2(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz), z(-nor+ng1:nx+nor,-norz+ng1:nz+norz,lr:lhab)) + + ngs = nz+3 + + allocate( qx(ngs,lv:lhab), & + qxw(ngs,ls:lhab), & + cx(ngs,lc:lhab), & + xv(ngs,lc:lhab), & + vtxbar(ngs,lc:lhab,3), & + xmas(ngs,lc:lhab), & + xdn(ngs,lc:lhab), & + xdia(ngs,lc:lhab,3), & + vx(ngs,li:lhab), & + alpha(ngs,lc:lhab), & + zx(ngs,lr:lhab), & + hasmass(nx,lc+1:lhab), & + igs(ngs),kgs(ngs), & + rho0(ngs),temcg(ngs),temg(ngs), rhovt(ngs), & + cwnc(ngs),cinc(ngs), & + fadvisc(ngs),cwdia(ngs),cipmas(ngs), & + cnina(ngs),cimas(ngs), & + cnostmp(ngs) ) kzb = 1 kze = nz @@ -4656,8 +4713,29 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ENDDO ! ix + deallocate( db1,dtz1,dz2dinv,db1inv,rhovtzx ) + deallocate( xfall0, xvt, tmpn ) + deallocate( tmpn2, z) + + deallocate( qx, & + qxw, & + cx, & + xv, & + vtxbar, & + xmas, & + xdn, & + xdia, & + vx, & + alpha, & + zx, & + hasmass, & + igs,kgs, & + rho0,temcg,temg, rhovt, & + cwnc,cinc, & + fadvisc,cwdia,cipmas, & + cnina,cimas, & + cnostmp ) - RETURN END SUBROUTINE SEDIMENT1D From e10030bf5a9578046d04adef261440bf9173013f Mon Sep 17 00:00:00 2001 From: Ted Mansell Date: Thu, 2 Nov 2023 13:28:39 -0500 Subject: [PATCH 371/380] mp_nssl.F90: space formatting --- physics/mp_nssl.F90 | 233 ++++++++++++++++++++++---------------------- 1 file changed, 115 insertions(+), 118 deletions(-) diff --git a/physics/mp_nssl.F90 b/physics/mp_nssl.F90 index aacf4c3dd..e79376709 100644 --- a/physics/mp_nssl.F90 +++ b/physics/mp_nssl.F90 @@ -26,12 +26,12 @@ module mp_nssl !! \htmlinclude mp_nssl_init.html !! subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & - mpirank, mpiroot, & - con_g, con_rd, con_cp, con_rv, & - con_t0c, con_cliq, con_csol, con_eps, & - imp_physics, imp_physics_nssl, & - nssl_cccn, nssl_alphah, nssl_alphahl, & - nssl_alphar, nssl_ehw0, nssl_ehlw0, & + mpirank, mpiroot, & + con_g, con_rd, con_cp, con_rv, & + con_t0c, con_cliq, con_csol, con_eps, & + imp_physics, imp_physics_nssl, & + nssl_cccn, nssl_alphah, nssl_alphahl, & + nssl_alphar, nssl_ehw0, nssl_ehlw0, & nssl_ccn_on, nssl_hail_on, nssl_invertccn, nssl_3moment ) @@ -134,7 +134,7 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & ! write(0,*) 'call nssl_2mom_init' CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=ipc,mixphase=0, & - ihvol=ihailv,nssl_ehw0=nssl_ehw0,nssl_ehlw0=nssl_ehlw0,errmsg=errmsg, & + ihvol=ihailv,nssl_ehw0=nssl_ehw0,nssl_ehlw0=nssl_ehlw0,errmsg=errmsg, & nssl_alphar=nssl_alphar, & nssl_alphah=nssl_alphah, & nssl_alphahl=nssl_alphahl, & @@ -165,19 +165,18 @@ end subroutine mp_nssl_init !! \htmlinclude mp_nssl_run.html !! subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & -! spechum, cccn, qc, qr, qi, qs, qh, qhl, & - spechum, cccn, cccna, qc, qr, qi, qs, qh, qhl, & - ccw, crw, cci, csw, chw, chl, vh, vhl, & - zrw, zhw, zhl, & - tgrs, prslk, prsl, phii, omega, dtp, & - prcp, rain, graupel, ice, snow, sr, & + spechum, cccn, cccna, qc, qr, qi, qs, qh, qhl, & + ccw, crw, cci, csw, chw, chl, vh, vhl, & + zrw, zhw, zhl, & + tgrs, prslk, prsl, phii, omega, dtp, & + prcp, rain, graupel, ice, snow, sr, & refl_10cm, do_radar_ref, first_time_step, restart, & - re_cloud, re_ice, re_snow, re_rain, & - nleffr, nieffr, nseffr, nreffr, & - imp_physics, convert_dry_rho, & - imp_physics_nssl, nssl_ccn_on, & - nssl_hail_on, nssl_invertccn, nssl_3moment, & - ntccn, ntccna, & + re_cloud, re_ice, re_snow, re_rain, & + nleffr, nieffr, nseffr, nreffr, & + imp_physics, convert_dry_rho, & + imp_physics_nssl, nssl_ccn_on, & + nssl_hail_on, nssl_invertccn, nssl_3moment, & + ntccn, ntccna, & errflg, errmsg) use module_mp_nssl_2mom, only: calcnfromq, na @@ -602,116 +601,114 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & IF ( nssl_ccn_on ) THEN - - CALL nssl_2mom_driver( & - ITIMESTEP=itimestep, & - ! TH=th, & - tt=tgrs, & - QV=qv_mp, & - QC=qc_mp, & - QR=qr_mp, & - QI=qi_mp, & - QS=qs_mp, & - QH=qh_mp, & - QHL=qhl_mp, & - CCW=nc_mp, & - CRW=nr_mp, & - CCI=ni_mp, & - CSW=ns_mp, & - CHW=nh_mp, & - CHL=nhl_mp, & - VHW=vh_mp, & - VHL=vhl_mp, & - cn=cn_mp, & - ZRW=zrw_mp, & - ZHW=zhw_mp, & - ZHL=zhl_mp, & -! cna=cna_mp, f_cna=( ntccna > 0 ), & ! for future use - cna=cna_mp, f_cna=.false. , & - PII=prslk, & - P=prsl, & - W=w, & - DZ=dz, & - DTP=dtptmp, & - DN=rho, & - rainnc=xrain_mp, rainncv=xdelta_rain_mp, & - snownc=xsnow_mp, snowncv=xdelta_snow_mp, & -! icenc=ice_mp, icencv=delta_ice_mp, & - GRPLNC=xgraupel_mp, GRPLNCV=xdelta_graupel_mp, sr=sr, & - dbz = refl_10cm, & -! nssl_progn=.false., & - diagflag = diagflag, & - errmsg=errmsg,errflg=errflg, & - re_cloud=re_cloud_mp, & - re_ice=re_ice_mp, & - re_snow=re_snow_mp, & - re_rain=re_rain_mp, & - has_reqc=has_reqc, & ! ala G. Thompson - has_reqi=has_reqi, & ! ala G. Thompson - has_reqs=has_reqs, & ! ala G. Thompson - has_reqr=has_reqr, & + CALL nssl_2mom_driver( & + ITIMESTEP=itimestep, & + ! TH=th, & + tt=tgrs, & + QV=qv_mp, & + QC=qc_mp, & + QR=qr_mp, & + QI=qi_mp, & + QS=qs_mp, & + QH=qh_mp, & + QHL=qhl_mp, & + CCW=nc_mp, & + CRW=nr_mp, & + CCI=ni_mp, & + CSW=ns_mp, & + CHW=nh_mp, & + CHL=nhl_mp, & + VHW=vh_mp, & + VHL=vhl_mp, & + cn=cn_mp, & + ZRW=zrw_mp, & + ZHW=zhw_mp, & + ZHL=zhl_mp, & +! cna=cna_mp, f_cna=( ntccna > 0 ), & ! for future use + cna=cna_mp, f_cna=.false. , & + PII=prslk, & + P=prsl, & + W=w, & + DZ=dz, & + DTP=dtptmp, & + DN=rho, & + rainnc=xrain_mp, rainncv=xdelta_rain_mp, & + snownc=xsnow_mp, snowncv=xdelta_snow_mp, & + GRPLNC=xgraupel_mp, & + GRPLNCV=xdelta_graupel_mp, & + sr=sr, & + dbz = refl_10cm, & + diagflag = diagflag, & + errmsg=errmsg,errflg=errflg, & + re_cloud=re_cloud_mp, & + re_ice=re_ice_mp, & + re_snow=re_snow_mp, & + re_rain=re_rain_mp, & + has_reqc=has_reqc, & + has_reqi=has_reqi, & + has_reqs=has_reqs, & + has_reqr=has_reqr, & IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde, & IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme, & ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & ) - ELSE - CALL nssl_2mom_driver( & - ITIMESTEP=itimestep, & - ! TH=th, & - tt=tgrs, & - QV=qv_mp, & - QC=qc_mp, & - QR=qr_mp, & - QI=qi_mp, & - QS=qs_mp, & - QH=qh_mp, & - QHL=qhl_mp, & -! CCW=qnc_mp, & - CCW=nc_mp, & - CRW=nr_mp, & - CCI=ni_mp, & - CSW=ns_mp, & - CHW=nh_mp, & - CHL=nhl_mp, & - VHW=vh_mp, & - VHL=vhl_mp, & - ZRW=zrw_mp, & - ZHW=zhw_mp, & - ZHL=zhl_mp, & - ! cn=cccn, & - PII=prslk, & - P=prsl, & - W=w, & - DZ=dz, & - DTP=dtptmp, & - DN=rho, & - rainnc=xrain_mp, rainncv=xdelta_rain_mp, & - snownc=xsnow_mp, snowncv=xdelta_snow_mp, & -! icenc=ice_mp, icencv=delta_ice_mp, & - GRPLNC=xgraupel_mp, GRPLNCV=xdelta_graupel_mp, sr=sr, & - dbz = refl_10cm, & -! nssl_progn=.false., & - diagflag = diagflag, & - errmsg=errmsg,errflg=errflg, & - re_cloud=re_cloud_mp, & - re_ice=re_ice_mp, & - re_snow=re_snow_mp, & - re_rain=re_rain_mp, & - has_reqc=has_reqc, & ! ala G. Thompson - has_reqi=has_reqi, & ! ala G. Thompson - has_reqs=has_reqs, & ! ala G. Thompson - has_reqr=has_reqr, & + CALL nssl_2mom_driver( & + ITIMESTEP=itimestep, & + ! TH=th, & + tt=tgrs, & + QV=qv_mp, & + QC=qc_mp, & + QR=qr_mp, & + QI=qi_mp, & + QS=qs_mp, & + QH=qh_mp, & + QHL=qhl_mp, & + CCW=nc_mp, & + CRW=nr_mp, & + CCI=ni_mp, & + CSW=ns_mp, & + CHW=nh_mp, & + CHL=nhl_mp, & + VHW=vh_mp, & + VHL=vhl_mp, & +! cn=cn_mp, & + ZRW=zrw_mp, & + ZHW=zhw_mp, & + ZHL=zhl_mp, & +! cna=cna_mp, f_cna=( ntccna > 0 ), & ! for future use +! cna=cna_mp, f_cna=.false. , & + PII=prslk, & + P=prsl, & + W=w, & + DZ=dz, & + DTP=dtptmp, & + DN=rho, & + rainnc=xrain_mp, rainncv=xdelta_rain_mp, & + snownc=xsnow_mp, snowncv=xdelta_snow_mp, & + GRPLNC=xgraupel_mp, & + GRPLNCV=xdelta_graupel_mp, & + sr=sr, & + dbz = refl_10cm, & + diagflag = diagflag, & + errmsg=errmsg,errflg=errflg, & + re_cloud=re_cloud_mp, & + re_ice=re_ice_mp, & + re_snow=re_snow_mp, & + re_rain=re_rain_mp, & + has_reqc=has_reqc, & + has_reqi=has_reqi, & + has_reqs=has_reqs, & + has_reqr=has_reqr, & IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde, & IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme, & ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & ) - + ENDIF - - + DO i = 1,ncol delta_rain_mp(i) = delta_rain_mp(i) + xdelta_rain_mp(i) ! this is liquid equivalent of all precip delta_graupel_mp(i) = delta_graupel_mp(i) + xdelta_graupel_mp(i) ! this is liquid equivalent of graupel @@ -720,7 +717,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & ENDDO ENDDO - + ENDIF From 911e4f9e5a7e8fc4a27e6d8cafb76ae4d69078ba Mon Sep 17 00:00:00 2001 From: drnimbusrain Date: Thu, 16 Nov 2023 14:28:08 +0000 Subject: [PATCH 372/380] Added TODO comments for input canopy variables and draft meta. --- physics/satmedmfvdifq.F | 46 +- physics/satmedmfvdifq.meta_canopy | 751 ++++++++++++++++++++++++++++++ 2 files changed, 792 insertions(+), 5 deletions(-) create mode 100644 physics/satmedmfvdifq.meta_canopy diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index e9741bbc5..fdc7f9a74 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -87,7 +87,10 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & & dspheat,dusfc,dvsfc,dtsfc,dqsfc,hpbl,dkt,dku, & & kinver,xkzm_m,xkzm_h,xkzm_s,dspfac,bl_upfr,bl_dnfr, & & rlmx,elmx,sfc_rlm,tc_pbl, & - & do_canopy, vegtype, lai, & + & do_canopy, vegtype, lai, & +!TODO -Canopy Inputs +! & rdcanopylai, rdcanopyfch, rdcanopyffrac, rdcanopyclu, & +! & canopylaixy, canopyfchxy, canopyffracxy, canopycluxy, & & ntqv,dtend,dtidx,index_of_temperature,index_of_x_wind, & & index_of_y_wind,index_of_process_pbl,gen_tend,ldiag3d, & & errmsg,errflg) @@ -115,6 +118,13 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & logical, intent(in) :: do_canopy integer, intent(in) :: vegtype(:) real(kind=kind_phys), intent(in) :: lai(:) +!TODO Canopy Inputs +! logical, intent(in) :: rdcanopylai, rdcanopyfch, rdcanopyffrac, & +! rdcanopyclu +! real(kind=kind_phys), intent(in) :: canopylaixy(:), & +! canopyfchxy(:), & +! canopyffracxy(:), & +! canopycluxy(:) !---------------------------------------------- real(kind=kind_phys), intent(inout) :: dv(:,:), du(:,:), & & tdt(:,:), rtg(:,:,:) @@ -275,7 +285,9 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & real(kind=kind_phys) FCH, MOL, HOL, TLCAN, & SIGMACAN, RRCAN, BBCAN, & AACAN, ZCAN, ZFL, BOTCAN, - & EDDYVEST1, EDDYVEST_INT + & EDDYVEST1, EDDYVEST_INT, + & XCANOPYLAI, XCANOPYFCH, + & XCANOPYFFRAC, XCANOPYCLU ! in canopy eddy diffusivity [ m**2/s ] real(kind=kind_phys), allocatable :: EDDYVESTX ( : ) @@ -1334,7 +1346,29 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & if (do_canopy) then do k = 1, km1-1 do i = 1, im - FCH = hvt_table(vegtype(i)) !top of canopy +!TODO: Canopy Inputs +! if(rdcanopylai) then +! XCANOPYLAI = canopylaixy(i) +! else +! XCANOPYLAI = 0.0 +! endif +! if(rdcanopyfch) then +! XCANOPYFCH = canopyfchxy(i) +! else +! XCANOPYFCH = 0.0 +! endif +! if(rdcanopyffrac) then +! XCANOPYFFRAC = canopyffracxy(i) +! else +! XCANOPYFFRAC = 0.0 +! endif +! if(rdcanopyclu) then +! XCANOPYCLU = canopycluxy(i) +! else +! XCANOPYCLU = 0.0 +! endif +! FCH = XCANOPYFCH !top of canopy from input file + FCH = hvt_table(vegtype(i)) !top of canopy from table IF (k .EQ. 1) THEN !use model layer interfaces KCAN = 1 ELSE @@ -1347,11 +1381,13 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & END IF IF (KCAN .EQ. 1) THEN !canopy inside model layer ! Check for other Contiguous Canopy Grid Cell Conditions +!TODO: Canopy Inputs +! IF ( XCANOPYLAI .LT. 0.1 !from canopy inputs IF ( lai(i) .LT. 0.1 !from LSM & .OR. FCH .LT. 0.5 ) THEN -! & .OR. MAX(0.0, 1.0 - FRT) .GT. 0.5 +! & .OR. MAX(0.0, 1.0 - XCANOPYFFRAC) .GT. 0.5 ! & .OR. POPU .GT. 10000.0 -! & .OR. EXP(-0.5*LAI*CLU).GT. 0.45 +! & .OR. EXP(-0.5*XCANOPYLAI*XCANOPYCLU).GT. 0.45 ! & .AND. FCH .LT. 18.0 ) THEN ! not a contigous canopy cell dkt(i,k)= dkt(i,k) diff --git a/physics/satmedmfvdifq.meta_canopy b/physics/satmedmfvdifq.meta_canopy new file mode 100644 index 000000000..ebd21181a --- /dev/null +++ b/physics/satmedmfvdifq.meta_canopy @@ -0,0 +1,751 @@ +[ccpp-table-properties] + name = satmedmfvdifq + type = scheme + dependencies = funcphys.f90,machine.F,mfpbltq.f,mfscuq.f,tridi.f,canopy_utils_mod.f,noahmp_tables.f90 + +######################################################################## +[ccpp-arg-table] + name = satmedmfvdifq_init + type = scheme +[satmedmf] + standard_name = flag_for_scale_aware_TKE_moist_EDMF_PBL + long_name = flag for scale-aware TKE moist EDMF PBL scheme + units = flag + dimensions = () + type = logical + intent = in +[isatmedmf] + standard_name = choice_of_scale_aware_TKE_moist_EDMF_PBL + long_name = choice of scale-aware TKE moist EDMF PBL scheme + units = none + dimensions = () + type = integer + intent = in +[isatmedmf_vdifq] + standard_name = choice_of_updated_scale_aware_TKE_moist_EDMF_PBL + long_name = choice of updated scale-aware TKE moist EDMF PBL scheme + units = none + dimensions = () + type = integer + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out + +##################################################################### +[ccpp-arg-table] + name = satmedmfvdifq_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[km] + standard_name = vertical_layer_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in +[ntrac] + standard_name = number_of_vertical_diffusion_tracers + long_name = number of tracers to diffuse vertically + units = count + dimensions = () + type = integer + intent = in +[ntcw] + standard_name = index_for_liquid_cloud_condensate_vertical_diffusion_tracer + long_name = tracer index for cloud condensate (or liquid water) + units = index + dimensions = () + type = integer + intent = in +[ntrw] + standard_name = index_for_rain_water_vertical_diffusion_tracer + long_name = tracer index for rain water in the vertically diffused tracer array + units = index + dimensions = () + type = integer + intent = in +[ntiw] + standard_name = index_for_ice_cloud_condensate_vertical_diffusion_tracer + long_name = tracer index for ice water in the vertically diffused tracer array + units = index + dimensions = () + type = integer + intent = in +[ntke] + standard_name = index_for_turbulent_kinetic_energy_vertical_diffusion_tracer + long_name = index for turbulent kinetic energy in the vertically diffused tracer array + units = index + dimensions = () + type = integer + intent = in +[grav] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[rd] + standard_name = gas_constant_of_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[rv] + standard_name = gas_constant_water_vapor + long_name = ideal gas constant for water vapor + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[hvap] + standard_name = latent_heat_of_vaporization_of_water_at_0C + long_name = latent heat of evaporation/sublimation + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[hfus] + standard_name = latent_heat_of_fusion_of_water_at_0C + long_name = latent heat of fusion + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[fv] + standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one + long_name = (rv/rd) - 1 (rv = ideal gas constant for water vapor) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[eps] + standard_name = ratio_of_dry_air_to_water_vapor_gas_constants + long_name = rd/rv + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[epsm1] + standard_name = ratio_of_dry_air_to_water_vapor_gas_constants_minus_one + long_name = (rd/rv) - 1 + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[dv] + standard_name = process_split_cumulative_tendency_of_y_wind + long_name = updated tendency of the y wind + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[du] + standard_name = process_split_cumulative_tendency_of_x_wind + long_name = updated tendency of the x wind + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[tdt] + standard_name = process_split_cumulative_tendency_of_air_temperature + long_name = updated tendency of the temperature + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[rtg] + standard_name = tendency_of_vertically_diffused_tracer_concentration + long_name = updated tendency of the tracers due to vertical diffusion in PBL scheme + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_vertical_diffusion_tracers) + type = real + kind = kind_phys + intent = inout +[u1] + standard_name = x_wind + long_name = x component of layer wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[v1] + standard_name = y_wind + long_name = y component of layer wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[t1] + standard_name = air_temperature + long_name = layer mean air temperature + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[q1] + standard_name = vertically_diffused_tracer_concentration + long_name = tracer concentration diffused by PBL scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_vertical_diffusion_tracers) + type = real + kind = kind_phys + intent = in +[swh] + standard_name = tendency_of_air_temperature_due_to_shortwave_heating_on_radiation_timestep + long_name = total sky shortwave heating rate + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[hlw] + standard_name = tendency_of_air_temperature_due_to_longwave_heating_on_radiation_timestep + long_name = total sky longwave heating rate + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[xmu] + standard_name = zenith_angle_temporal_adjustment_factor_for_shortwave_fluxes + long_name = zenith angle temporal adjustment factor for shortwave + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[garea] + standard_name = cell_area + long_name = area of the grid cell + units = m2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[zvfun] + standard_name = function_of_surface_roughness_length_and_green_vegetation_fraction + long_name = function of surface roughness length and green vegetation fraction + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[sigmaf] + standard_name = bounded_vegetation_area_fraction + long_name = areal fractional cover of green vegetation bounded on the bottom + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[psk] + standard_name = surface_dimensionless_exner_function + long_name = dimensionless Exner function at the surface interface + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[rbsoil] + standard_name = bulk_richardson_number_at_lowest_model_level + long_name = bulk Richardson number at the surface + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[zorl] + standard_name = surface_roughness_length + long_name = surface roughness length in cm + units = cm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[u10m] + standard_name = x_wind_at_10m + long_name = x component of wind at 10 m + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[v10m] + standard_name = y_wind_at_10m + long_name = y component of wind at 10 m + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[fm] + standard_name = Monin_Obukhov_similarity_function_for_momentum + long_name = Monin-Obukhov similarity function for momentum + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[fh] + standard_name = Monin_Obukhov_similarity_function_for_heat + long_name = Monin-Obukhov similarity function for heat + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[tsea] + standard_name = surface_skin_temperature + long_name = surface skin temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[heat] + standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness_and_vegetation + long_name = kinematic surface upward sensible heat flux reduced by surface roughness and vegetation + units = K m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[evap] + standard_name = surface_upward_specific_humidity_flux + long_name = kinematic surface upward latent heat flux + units = kg kg-1 m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[stress] + standard_name = surface_wind_stress + long_name = surface wind stress + units = m2 s-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[spd1] + standard_name = wind_speed_at_lowest_model_layer + long_name = wind speed at lowest model level + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[kpbl] + standard_name = vertical_index_at_top_of_atmosphere_boundary_layer + long_name = PBL top model level index + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = out +[prsi] + standard_name = air_pressure_at_interface + long_name = air pressure at model layer interfaces + units = Pa + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in +[del] + standard_name = air_pressure_difference_between_midlayers + long_name = pres(k) - pres(k+1) + units = Pa + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[prsl] + standard_name = air_pressure + long_name = mean layer pressure + units = Pa + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[prslk] + standard_name = dimensionless_exner_function + long_name = Exner function at layers + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[phii] + standard_name = geopotential_at_interface + long_name = geopotential at model layer interfaces + units = m2 s-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in +[phil] + standard_name = geopotential + long_name = geopotential at model layer centers + units = m2 s-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[delt] + standard_name = timestep_for_physics + long_name = time step for physics + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[dspheat] + standard_name = flag_TKE_dissipation_heating + long_name = flag for using TKE dissipation heating + units = flag + dimensions = () + type = logical + intent = in +[dusfc] + standard_name = instantaneous_surface_x_momentum_flux + long_name = x momentum flux + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[dvsfc] + standard_name = instantaneous_surface_y_momentum_flux + long_name = y momentum flux + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[dtsfc] + standard_name = instantaneous_surface_upward_sensible_heat_flux + long_name = surface upward sensible heat flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[dqsfc] + standard_name = instantaneous_surface_upward_latent_heat_flux + long_name = surface upward latent heat flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[hpbl] + standard_name = atmosphere_boundary_layer_thickness + long_name = PBL thickness + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[dkt] + standard_name = atmosphere_heat_diffusivity + long_name = atmospheric heat diffusivity + units = m2 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[dku] + standard_name = atmosphere_momentum_diffusivity + long_name = atmospheric momentum diffusivity + units = m2 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[kinver] + standard_name = index_of_highest_temperature_inversion + long_name = index of highest temperature inversion + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[xkzm_m] + standard_name = atmosphere_momentum_diffusivity_due_to_background + long_name = background value of momentum diffusivity + units = m2 s-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[xkzm_h] + standard_name = atmosphere_heat_diffusivity_due_to_background + long_name = background value of heat diffusivity + units = m2 s-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[xkzm_s] + standard_name = sigma_pressure_threshold_at_upper_extent_of_background_diffusion + long_name = sigma level threshold for background diffusivity + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[dspfac] + standard_name = multiplicative_tuning_parameter_for_tke_dissipative_heating + long_name = tke dissipative heating factor + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[bl_upfr] + standard_name = updraft_area_fraction_in_scale_aware_tke_moist_edmf_pbl_scheme + long_name = updraft fraction in boundary layer mass flux scheme + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[bl_dnfr] + standard_name = downdraft_area_fraction_in_scale_aware_tke_moist_edmf_pbl_scheme + long_name = downdraft fraction in boundary layer mass flux scheme + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[rlmx] + standard_name = maximum_allowed_mixing_length_in_boundary_layer_mass_flux_scheme + long_name = maximum allowed mixing length in boundary layer mass flux scheme + units = m + dimensions = () + type = real + kind = kind_phys + intent = in +[elmx] + standard_name = maximum_allowed_dissipation_mixing_length_in_boundary_layer_mass_flux_scheme + long_name = maximum allowed dissipation mixing length in boundary layer mass flux scheme + units = m + dimensions = () + type = real + kind = kind_phys + intent = in +[do_canopy] + standard_name = flag_for_canopy_option + long_name = flag for in-canopy eddy diffusivity adjustment option + units = flag + dimensions = () + type = logical + intent = in +[rdcanopylai] + standard_name = flag_for_reading_canopy_leaf_area_index_from_input + long_name = flag for reading canopy leaf area index from initial conditions + units = flag + dimensions = () + type = logical + intent = in +[rdcanopyfch] + standard_name = flag_for_reading_canopy_forest_height_from_input + long_name = flag for reading canopy forest height from initial conditions + units = flag + dimensions = () + type = logical + intent = in +[rdcanopyffrac] + standard_name = flag_for_reading_canopy_forest_fraction_from_input + long_name = flag for reading canopy forest fraction from initial conditions + units = flag + dimensions = () + type = logical + intent = in +[rdcanopyclu] + standard_name = flag_for_reading_canopy_clumping_index_from_input + long_name = flag for reading canopy clumping index from initial conditions + units = flag + dimensions = () + type = logical + intent = in +[canopylaixy] + standard_name = canopy_leaf_area_index + long_name = canopy leaf area index + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[canopyfchxy] + standard_name = canopy_forest_height + long_name = canopy forest height + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[canopyffracxy] + standard_name = canopy_forest_fraction + long_name = canopy forest fraction + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[canopycluxy] + standard_name = canopy_clumping_index + long_name = canopy clumping index + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[vegtype] + standard_name = vegetation_type_classification + long_name = vegetation type at each grid cell + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[lai] + standard_name = leaf_area_index + long_name = leaf area index + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[sfc_rlm] + standard_name = choice_of_near_surface_mixing_length_in_boundary_layer_mass_flux_scheme + long_name = choice of near surface mixing length in boundary layer mass flux scheme + units = none + dimensions = () + type = integer + intent = in +[tc_pbl] + standard_name = control_for_TC_applications_in_the_PBL_scheme + long_name = control for TC applications in the PBL scheme + units = none + dimensions = () + type = integer + intent = in +[ntqv] + standard_name = index_of_specific_humidity_in_tracer_concentration_array + long_name = tracer index for water vapor (specific humidity) + units = index + dimensions = () + type = integer + intent = in +[dtend] + standard_name = cumulative_change_of_state_variables + long_name = diagnostic tendencies for state variables + units = mixed + dimensions = (horizontal_loop_extent,vertical_layer_dimension,cumulative_change_of_state_variables_outer_index_max) + type = real + kind = kind_phys + intent = in +[dtidx] + standard_name = cumulative_change_of_state_variables_outer_index + long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index + units = index + dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes) + type = integer + intent = in +[index_of_temperature] + standard_name = index_of_temperature_in_cumulative_change_index + long_name = index of temperature in first dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_x_wind] + standard_name = index_of_x_wind_in_cumulative_change_index + long_name = index of x-wind in first dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_y_wind] + standard_name = index_of_y_wind_in_cumulative_change_index + long_name = index of x-wind in first dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_process_pbl] + standard_name = index_of_subgrid_scale_vertical_mixing_process_in_cumulative_change_index + long_name = index of subgrid scale vertical mixing process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[gen_tend] + standard_name = flag_for_generic_tendency_due_to_planetary_boundary_layer + long_name = true if GFS_PBL_generic should calculate tendencies + units = flag + dimensions = () + type = logical + intent = in +[ldiag3d] + standard_name = flag_for_diagnostics_3D + long_name = flag for 3d diagnostic fields + units = flag + dimensions = () + type = logical + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out From 3a9338f2b53abb73646897878ef92892f5cf6778 Mon Sep 17 00:00:00 2001 From: drnimbusrain Date: Tue, 19 Dec 2023 01:51:38 +0000 Subject: [PATCH 373/380] Fixed canopy height table and changed ffrac to frt. --- physics/satmedmfvdifq.F | 36 +++++++++++++++++++------------ physics/satmedmfvdifq.meta_canopy | 4 ++-- 2 files changed, 24 insertions(+), 16 deletions(-) diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index 0c469828b..959b04170 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -9,7 +9,6 @@ module satmedmfvdifq use mfscuq_mod !PCC_CANOPY use canopy_utils_mod - use noahmp_tables, only : hvt_table contains @@ -89,8 +88,8 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & & rlmx,elmx,sfc_rlm,tc_pbl, & & do_canopy, vegtype, lai, & !TODO -Canopy Inputs -! & rdcanopylai, rdcanopyfch, rdcanopyffrac, rdcanopyclu, & -! & canopylaixy, canopyfchxy, canopyffracxy, canopycluxy, & +! & rdcanopylai, rdcanopyfch, rdcanopyfrt, rdcanopyclu, & +! & canopylaixy, canopyfchxy, canopyfrtxy, canopycluxy, & & ntqv,dtend,dtidx,index_of_temperature,index_of_x_wind, & & index_of_y_wind,index_of_process_pbl,gen_tend,ldiag3d, & & errmsg,errflg) @@ -119,11 +118,11 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & integer, intent(in) :: vegtype(:) real(kind=kind_phys), intent(in) :: lai(:) !TODO Canopy Inputs -! logical, intent(in) :: rdcanopylai, rdcanopyfch, rdcanopyffrac, & +! logical, intent(in) :: rdcanopylai, rdcanopyfch, rdcanopyfrt, & ! rdcanopyclu ! real(kind=kind_phys), intent(in) :: canopylaixy(:), & ! canopyfchxy(:), & -! canopyffracxy(:), & +! canopyfrtxy(:), & ! canopycluxy(:) !---------------------------------------------- real(kind=kind_phys), intent(inout) :: dv(:,:), du(:,:), & @@ -285,9 +284,10 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & real(kind=kind_phys) FCH, MOL, HOL, TLCAN, & SIGMACAN, RRCAN, BBCAN, & AACAN, ZCAN, ZFL, BOTCAN, - & EDDYVEST1, EDDYVEST_INT, - & XCANOPYLAI, XCANOPYFCH, - & XCANOPYFFRAC, XCANOPYCLU + & EDDYVEST1, EDDYVEST_INT +!TODO Canopy Inputs +! & XCANOPYLAI, XCANOPYFCH, +! & XCANOPYFRT, XCANOPYCLU ! in canopy eddy diffusivity [ m**2/s ] real(kind=kind_phys), allocatable :: EDDYVESTX ( : ) @@ -295,7 +295,15 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & real(kind=kind_phys), allocatable :: ZCANX ( : ) ! Declare local maximum canopy layers integer, parameter :: MAXCAN = 1000 - + integer, parameter :: mvt = 30 ! use 30 instead of 27 + !Based on MODIS IGBP 20 Category Dataset + real :: fch_table(mvt) !< top of canopy (m) + data ( fch_table(i),i=1,mvt) / + & 20.0, 20.0, 18.0, 16.0, 16.0, 1.10, + & 1.10, 13.0, 10.0, 1.00, 5.00, 2.00, + & 15.0, 1.50, 0.00, 0.00, 0.00, 4.00, + & 2.00, 0.50, 0.00, 0.00, 0.00, 0.00, + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / !---------------------------------------------- !! @@ -1359,10 +1367,10 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & ! else ! XCANOPYFCH = 0.0 ! endif -! if(rdcanopyffrac) then -! XCANOPYFFRAC = canopyffracxy(i) +! if(rdcanopyfrt) then +! XCANOPYFRT = canopyfrtxy(i) ! else -! XCANOPYFFRAC = 0.0 +! XCANOPYFRT = 0.0 ! endif ! if(rdcanopyclu) then ! XCANOPYCLU = canopycluxy(i) @@ -1370,7 +1378,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & ! XCANOPYCLU = 0.0 ! endif ! FCH = XCANOPYFCH !top of canopy from input file - FCH = hvt_table(vegtype(i)) !top of canopy from table + FCH = fch_table(vegtype(i)) !top of canopy from table IF (k .EQ. 1) THEN !use model layer interfaces KCAN = 1 ELSE @@ -1387,7 +1395,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & ! IF ( XCANOPYLAI .LT. 0.1 !from canopy inputs IF ( lai(i) .LT. 0.1 !from LSM & .OR. FCH .LT. 0.5 ) THEN -! & .OR. MAX(0.0, 1.0 - XCANOPYFFRAC) .GT. 0.5 +! & .OR. MAX(0.0, 1.0 - XCANOPYFRT) .GT. 0.5 ! & .OR. POPU .GT. 10000.0 ! & .OR. EXP(-0.5*XCANOPYLAI*XCANOPYCLU).GT. 0.45 ! & .AND. FCH .LT. 18.0 ) THEN diff --git a/physics/satmedmfvdifq.meta_canopy b/physics/satmedmfvdifq.meta_canopy index ebd21181a..c3b0af101 100644 --- a/physics/satmedmfvdifq.meta_canopy +++ b/physics/satmedmfvdifq.meta_canopy @@ -595,7 +595,7 @@ dimensions = () type = logical intent = in -[rdcanopyffrac] +[rdcanopyfrt] standard_name = flag_for_reading_canopy_forest_fraction_from_input long_name = flag for reading canopy forest fraction from initial conditions units = flag @@ -625,7 +625,7 @@ type = real kind = kind_phys intent = in -[canopyffracxy] +[canopyfrtxy] standard_name = canopy_forest_fraction long_name = canopy forest fraction units = none From 1e28ccd6197d02b5b6c8c21b594367fcaddadd47 Mon Sep 17 00:00:00 2001 From: drnimbusrain Date: Tue, 19 Dec 2023 15:27:35 +0000 Subject: [PATCH 374/380] Removed noah_mp_table dependency for aqm_canopy --- physics/satmedmfvdifq.meta | 2 +- physics/satmedmfvdifq.meta_canopy | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/satmedmfvdifq.meta b/physics/satmedmfvdifq.meta index 7582ef2e5..f35002cf4 100644 --- a/physics/satmedmfvdifq.meta +++ b/physics/satmedmfvdifq.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = satmedmfvdifq type = scheme - dependencies = funcphys.f90,machine.F,mfpbltq.f,mfscuq.f,tridi.f,canopy_utils_mod.f,noahmp_tables.f90 + dependencies = funcphys.f90,machine.F,mfpbltq.f,mfscuq.f,tridi.f,canopy_utils_mod.f ######################################################################## [ccpp-arg-table] diff --git a/physics/satmedmfvdifq.meta_canopy b/physics/satmedmfvdifq.meta_canopy index c3b0af101..16232ec13 100644 --- a/physics/satmedmfvdifq.meta_canopy +++ b/physics/satmedmfvdifq.meta_canopy @@ -1,7 +1,7 @@ [ccpp-table-properties] name = satmedmfvdifq type = scheme - dependencies = funcphys.f90,machine.F,mfpbltq.f,mfscuq.f,tridi.f,canopy_utils_mod.f,noahmp_tables.f90 + dependencies = funcphys.f90,machine.F,mfpbltq.f,mfscuq.f,tridi.f,canopy_utils_mod.f ######################################################################## [ccpp-arg-table] From b0706c2ef038e62c3315bdcf9f9dd308f2a57a9b Mon Sep 17 00:00:00 2001 From: iri01 Date: Wed, 28 Feb 2024 16:23:20 +0000 Subject: [PATCH 375/380] Pass via interface 5 AQM canopy inputs and build-in diagnostic arrays aux2d/aux3d (activated with ldiag3d). Replace look-up table canopy inputs with AQM canopy inputs for canopy correction on diffusivities. --- physics/satmedmfvdifq.F | 162 +++++++++++++++++++++--------- physics/satmedmfvdifq.meta | 65 ++++++++++++ physics/satmedmfvdifq.meta_canopy | 65 ++++++++++++ 3 files changed, 246 insertions(+), 46 deletions(-) diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index 959b04170..6633708a3 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -87,12 +87,18 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & & kinver,xkzm_m,xkzm_h,xkzm_s,dspfac,bl_upfr,bl_dnfr, & & rlmx,elmx,sfc_rlm,tc_pbl, & & do_canopy, vegtype, lai, & +!IVAI: canopy inputs + & claie, cfch, cfrt, cclu, cpopu, +!IVAI !TODO -Canopy Inputs ! & rdcanopylai, rdcanopyfch, rdcanopyfrt, rdcanopyclu, & ! & canopylaixy, canopyfchxy, canopyfrtxy, canopycluxy, & & ntqv,dtend,dtidx,index_of_temperature,index_of_x_wind, & & index_of_y_wind,index_of_process_pbl,gen_tend,ldiag3d, & - & errmsg,errflg) + & errmsg,errflg, & +!IVAI: aux arrays + & naux2d,naux3d,aux2d,aux3d) + ! use machine , only : kind_phys use funcphys , only : fpvs @@ -117,6 +123,9 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & logical, intent(in) :: do_canopy integer, intent(in) :: vegtype(:) real(kind=kind_phys), intent(in) :: lai(:) +!IVAI: canopy inputs + real(kind=kind_phys), intent(in) :: claie(:), cfch(:), cfrt(:), + & cclu(:), cpopu(:) !TODO Canopy Inputs ! logical, intent(in) :: rdcanopylai, rdcanopyfch, rdcanopyfrt, & ! rdcanopyclu @@ -281,6 +290,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & !PCC_CANOPY------------------------------------ integer COUNTCAN,KCAN + integer kount !IVAI real(kind=kind_phys) FCH, MOL, HOL, TLCAN, & SIGMACAN, RRCAN, BBCAN, & AACAN, ZCAN, ZFL, BOTCAN, @@ -306,6 +316,12 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / !---------------------------------------------- +!IVAI + integer, intent(in) :: naux2d,naux3d + real(kind_phys), intent(inout) :: aux2d(:,:) + real(kind_phys), intent(inout) :: aux3d(:,:,:) +!IVAI + !! parameter(bfac=100.) parameter(wfac=7.0,cfac=4.5) @@ -1353,58 +1369,99 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & enddo enddo !PCC_CANOPY------------------------------------ + kount=0 !IVAI if (do_canopy) then + +!IVAI +! print*, 'SATMEDMFVDIFQ_RUN: CLAIE = ', claie(:) +! print*, 'SATMEDMFVDIFQ_RUN: CFCH = ' , cfch (:) +! print*, 'SATMEDMFVDIFQ_RUN: CFRT = ' , cfrt (:) +! print*, 'SATMEDMFVDIFQ_RUN: CCLU = ' , cclu (:) +! print*, 'SATMEDMFVDIFQ_RUN: CPOPU= ' , cpopu(:) +! 2D aux arrays: canopy data in diffusion + aux2d(:,1) = cfch (:) + aux2d(:,2) = claie(:) + aux2d(:,3) = cfrt(:) + +! 3D aux arrays: before canopy correction + aux3d(:,:,1) = dkq(:,:) + aux3d(:,:,2) = dkt(:,:) + aux3d(:,:,3) = dku(:,:) +!IVAI do k = 1, km1-1 do i = 1, im + !TODO: Canopy Inputs -! if(rdcanopylai) then -! XCANOPYLAI = canopylaixy(i) -! else -! XCANOPYLAI = 0.0 -! endif -! if(rdcanopyfch) then -! XCANOPYFCH = canopyfchxy(i) -! else -! XCANOPYFCH = 0.0 -! endif -! if(rdcanopyfrt) then -! XCANOPYFRT = canopyfrtxy(i) -! else -! XCANOPYFRT = 0.0 -! endif -! if(rdcanopyclu) then -! XCANOPYCLU = canopycluxy(i) -! else -! XCANOPYCLU = 0.0 -! endif -! FCH = XCANOPYFCH !top of canopy from input file - FCH = fch_table(vegtype(i)) !top of canopy from table - IF (k .EQ. 1) THEN !use model layer interfaces - KCAN = 1 - ELSE - IF (FCH .GT. zi(i,k) - & .AND. FCH .LE. zi(i,k+1) ) THEN - KCAN = 1 - ELSE - KCAN = 0 - END IF - END IF - IF (KCAN .EQ. 1) THEN !canopy inside model layer -! Check for other Contiguous Canopy Grid Cell Conditions +! if(rdcanopylai) then +! XCANOPYLAI = canopylaixy(i) +! else +! XCANOPYLAI = 0.0 +! endif +! if(rdcanopyfch) then +! XCANOPYFCH = canopyfchxy(i) +! else +! XCANOPYFCH = 0.0 +! endif +! if(rdcanopyfrt) then +! XCANOPYFRT = canopyfrtxy(i) +! else +! XCANOPYFRT = 0.0 +! endif +! if(rdcanopyclu) then +! XCANOPYCLU = canopycluxy(i) +! else +! XCANOPYCLU = 0.0 +! endif +! +! FCH = XCANOPYFCH !top of canopy from input file + +!IVAI: AQM canopy Inputs +! FCH = fch_table(vegtype(i)) !top of canopy from look-up table + FCH = cfch(i) !top of canopy from AQM canopy inputs + IF (k .EQ. 1) THEN !use model layer interfaces + KCAN = 1 + ELSE + IF ( cfch(i) .GT. zi(i,k) + & .AND. cfch(i) .LE. zi(i,k+1) ) THEN + KCAN = 1 + ELSE + KCAN = 0 + END IF + END IF + + IF (KCAN .EQ. 1) THEN !canopy inside model layer +! Check for other Contiguous Canopy Grid Cell Conditions + +! Not a contigous canopy cell + IF ( claie(i) .LT. 0.1 + & .OR. cfch (i) .LT. 0.5 +!IVAI: modified contiguous canopy condition +! & .OR. MAX(0.0, 1.0 - cfrt(i)) .GT. 0.5 + & .OR. MAX(0.0, 1.0 - cfrt(i)) .GT. 0.75 +!IVAI + & .OR. cpopu(i) .GT. 10000.0 + & .OR. (EXP(-0.5*claie(i)*cclu(i)) .GT. 0.45 + & .AND. cfch(i) .LT. 18.) ) THEN + + !TODO: Canopy Inputs ! IF ( XCANOPYLAI .LT. 0.1 !from canopy inputs - IF ( lai(i) .LT. 0.1 !from LSM - & .OR. FCH .LT. 0.5 ) THEN +! IF ( lai(i) .LT. 0.1 !from LSM +! & .OR. FCH .LT. 0.5 ) THEN ! & .OR. MAX(0.0, 1.0 - XCANOPYFRT) .GT. 0.5 ! & .OR. POPU .GT. 10000.0 ! & .OR. EXP(-0.5*XCANOPYLAI*XCANOPYCLU).GT. 0.45 ! & .AND. FCH .LT. 18.0 ) THEN -! not a contigous canopy cell - dkt(i,k)= dkt(i,k) - dkq(i,k)= dkq(i,k) - dku(i,k)= dku(i,k) - ELSE ! There is a contiguous forest canopy, -! apply correction over canopy layers + + dkt(i,k)= dkt(i,k) + dkq(i,k)= dkq(i,k) + dku(i,k)= dku(i,k) + + ELSE ! There is a contiguous forest canopy, apply correction over canopy layers + +! Output contiguous canopy mask + if (kount .EQ. 0 ) aux2d(i,5) = aux2d(i,5) + 1 + !Raupauch M. R. A Practical Lagrangian method for relating scalar !concentrations to ! source distributions in vegetation canopies. Q. J. R. Meteor. Soc. @@ -1489,12 +1546,25 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & dkt(i,k)= (dkt(i,k)/EDDYVEST1) * EDDYVEST_INT !Scale dkt to resolved eddy diffusivity dkq(i,k)= (dkq(i,k)/EDDYVEST1) * EDDYVEST_INT !Scale dkq to resolved eddy diffusivity dku(i,k)= (dku(i,k)/EDDYVEST1) * EDDYVEST_INT !Scale dku to resolved eddy diffusivity - END IF !contigous canopy conditions -! END IF ! first model layer scaled canopy - END IF ! model layers containing canopy + +!IVAI: Output contiguos canopy correction bottom layer and 3D + if ( kount .EQ. 0) + & aux2d(i,4) = 1./EDDYVEST1 * EDDYVEST_INT + aux3d(i,k,4) = 1./EDDYVEST1 * EDDYVEST_INT +!IVAI + + END IF ! contigous canopy conditions + + END IF ! (KCAN .EQ. 1) model layer(s) containing canopy + enddo !i + + kount = kount + 1 !IVAI + enddo !k + endif !do_canopy + !> ## Compute TKE. !! - Compute a minimum TKE deduced from background diffusivity for momentum. ! diff --git a/physics/satmedmfvdifq.meta b/physics/satmedmfvdifq.meta index f35002cf4..158dd3404 100644 --- a/physics/satmedmfvdifq.meta +++ b/physics/satmedmfvdifq.meta @@ -596,6 +596,43 @@ type = real kind = kind_phys intent = in +#IVAI +[claie] + standard_name = leaf_area_index_eccc + long_name = Leaf area index ECCC + units = none + dimensions = (horizontal_loop_extent,number_of_3d_auxiliary_arrays) + type = real + kind = kind_phys +[cfch] + standard_name = forest_canopy_height + long_name = Forest Canopy Height + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_3d_auxiliary_arrays) + type = real + kind = kind_phys +[cfrt] + standard_name = forest_fraction + long_name = Forest Fraction for canopy correction + units = none + dimensions = (horizontal_loop_extent,number_of_3d_auxiliary_arrays) + type = real + kind = kind_phys +[cclu] + standard_name = clumping_index + long_name = Clumping Index for canopy correction + units = none + dimensions = (horizontal_loop_extent,number_of_3d_auxiliary_arrays) + type = real + kind = kind_phys +[cpopu] + standard_name = population_density + long_name = Population dencity for canopy correction + units = none + dimensions = (horizontal_loop_extent,number_of_3d_auxiliary_arrays) + type = real + kind = kind_phys +#IVAI [sfc_rlm] standard_name = choice_of_near_surface_mixing_length_in_boundary_layer_mass_flux_scheme long_name = choice of near surface mixing length in boundary layer mass flux scheme @@ -689,3 +726,31 @@ dimensions = () type = integer intent = out +#IVAI +[naux2d] + standard_name = number_of_2d_auxiliary_arrays + long_name = number of 2d auxiliary arrays to output (for debugging) + units = count + dimensions = () + type = integer +[naux3d] + standard_name = number_of_3d_auxiliary_arrays + long_name = number of 3d auxiliary arrays to output (for debugging) + units = count + dimensions = () + type = integer +[aux2d] + standard_name = auxiliary_2d_arrays + long_name = auxiliary 2d arrays to output (for debugging) + units = none + dimensions = (horizontal_loop_extent,number_of_3d_auxiliary_arrays) + type = real + kind = kind_phys +[aux3d] + standard_name = auxiliary_3d_arrays + long_name = auxiliary 3d arrays to output (for debugging) + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_3d_auxiliary_arrays) + type = real + kind = kind_phys +#IVAI diff --git a/physics/satmedmfvdifq.meta_canopy b/physics/satmedmfvdifq.meta_canopy index 16232ec13..6870ac0d7 100644 --- a/physics/satmedmfvdifq.meta_canopy +++ b/physics/satmedmfvdifq.meta_canopy @@ -43,6 +43,34 @@ dimensions = () type = integer intent = out +#IVAI +[naux2d] + standard_name = number_of_2d_auxiliary_arrays + long_name = number of 2d auxiliary arrays to output (for debugging) + units = count + dimensions = () + type = integer +[naux3d] + standard_name = number_of_3d_auxiliary_arrays + long_name = number of 3d auxiliary arrays to output (for debugging) + units = count + dimensions = () + type = integer +[aux2d] + standard_name = auxiliary_2d_arrays + long_name = auxiliary 2d arrays to output (for debugging) + units = none + dimensions = (horizontal_loop_extent,number_of_3d_auxiliary_arrays) + type = real + kind = kind_phys +[aux3d] + standard_name = auxiliary_3d_arrays + long_name = auxiliary 3d arrays to output (for debugging) + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_3d_auxiliary_arrays) + type = real + kind = kind_phys +#IVAI ##################################################################### [ccpp-arg-table] @@ -656,6 +684,43 @@ type = real kind = kind_phys intent = in +#IVAI +[claie] + standard_name = leaf_area_index_eccc + long_name = Leaf area index ECCC + units = none + dimensions = (horizontal_loop_extent,number_of_3d_auxiliary_arrays) + type = real + kind = kind_phys +[cfch] + standard_name = forest_canopy_height + long_name = Forest Canopy Height + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_3d_auxiliary_arrays) + type = real + kind = kind_phys +[cfrt] + standard_name = forest_fraction + long_name = Forest Fraction for canopy correction + units = none + dimensions = (horizontal_loop_extent,number_of_3d_auxiliary_arrays) + type = real + kind = kind_phys +[cclu] + standard_name = clumping_index + long_name = Clumping Index for canopy correction + units = none + dimensions = (horizontal_loop_extent,number_of_3d_auxiliary_arrays) + type = real + kind = kind_phys +[cpopu] + standard_name = population_density + long_name = Population dencity for canopy correction + units = none + dimensions = (horizontal_loop_extent,number_of_3d_auxiliary_arrays) + type = real + kind = kind_phys +#IVAI [sfc_rlm] standard_name = choice_of_near_surface_mixing_length_in_boundary_layer_mass_flux_scheme long_name = choice of near surface mixing length in boundary layer mass flux scheme From 7726000ffd64cdea4d85cb0ae317877fccf6ed77 Mon Sep 17 00:00:00 2001 From: iri01 Date: Wed, 28 Feb 2024 21:44:27 +0000 Subject: [PATCH 376/380] Corrected canopy arrays meta names and dimensions for consistency with their definitions in GFS_typedefs.meta --- physics/satmedmfvdifq.meta | 30 +++++++++++++++--------------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/physics/satmedmfvdifq.meta b/physics/satmedmfvdifq.meta index 158dd3404..cef8332a8 100644 --- a/physics/satmedmfvdifq.meta +++ b/physics/satmedmfvdifq.meta @@ -598,38 +598,38 @@ intent = in #IVAI [claie] - standard_name = leaf_area_index_eccc - long_name = Leaf area index ECCC + standard_name = canopy_leaf_area_index + long_name = canopy leaf area index units = none - dimensions = (horizontal_loop_extent,number_of_3d_auxiliary_arrays) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys [cfch] - standard_name = forest_canopy_height - long_name = Forest Canopy Height + standard_name = canopy_forest_height + long_name = canopy forest height units = none - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_3d_auxiliary_arrays) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys [cfrt] - standard_name = forest_fraction - long_name = Forest Fraction for canopy correction + standard_name = canopy_forest_fraction + long_name = canopy forest fraction units = none - dimensions = (horizontal_loop_extent,number_of_3d_auxiliary_arrays) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys [cclu] - standard_name = clumping_index - long_name = Clumping Index for canopy correction + standard_name = canopy_clumping_index + long_name = canopy clumping index units = none - dimensions = (horizontal_loop_extent,number_of_3d_auxiliary_arrays) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys [cpopu] - standard_name = population_density - long_name = Population dencity for canopy correction + standard_name = canopy_population_density + long_name = population density used for canopy correction units = none - dimensions = (horizontal_loop_extent,number_of_3d_auxiliary_arrays) + dimensions = (horizontal_loop_extent) type = real kind = kind_phys #IVAI From 4d171ceedb076f0ead232b67d1b88d9a83e2bb8e Mon Sep 17 00:00:00 2001 From: iri01 Date: Wed, 28 Feb 2024 21:51:40 +0000 Subject: [PATCH 377/380] Remove unnecessary definitions of canopy arrays --- physics/satmedmfvdifq.meta_canopy | 65 ------------------------------- 1 file changed, 65 deletions(-) diff --git a/physics/satmedmfvdifq.meta_canopy b/physics/satmedmfvdifq.meta_canopy index 6870ac0d7..16232ec13 100644 --- a/physics/satmedmfvdifq.meta_canopy +++ b/physics/satmedmfvdifq.meta_canopy @@ -43,34 +43,6 @@ dimensions = () type = integer intent = out -#IVAI -[naux2d] - standard_name = number_of_2d_auxiliary_arrays - long_name = number of 2d auxiliary arrays to output (for debugging) - units = count - dimensions = () - type = integer -[naux3d] - standard_name = number_of_3d_auxiliary_arrays - long_name = number of 3d auxiliary arrays to output (for debugging) - units = count - dimensions = () - type = integer -[aux2d] - standard_name = auxiliary_2d_arrays - long_name = auxiliary 2d arrays to output (for debugging) - units = none - dimensions = (horizontal_loop_extent,number_of_3d_auxiliary_arrays) - type = real - kind = kind_phys -[aux3d] - standard_name = auxiliary_3d_arrays - long_name = auxiliary 3d arrays to output (for debugging) - units = none - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_3d_auxiliary_arrays) - type = real - kind = kind_phys -#IVAI ##################################################################### [ccpp-arg-table] @@ -684,43 +656,6 @@ type = real kind = kind_phys intent = in -#IVAI -[claie] - standard_name = leaf_area_index_eccc - long_name = Leaf area index ECCC - units = none - dimensions = (horizontal_loop_extent,number_of_3d_auxiliary_arrays) - type = real - kind = kind_phys -[cfch] - standard_name = forest_canopy_height - long_name = Forest Canopy Height - units = none - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_3d_auxiliary_arrays) - type = real - kind = kind_phys -[cfrt] - standard_name = forest_fraction - long_name = Forest Fraction for canopy correction - units = none - dimensions = (horizontal_loop_extent,number_of_3d_auxiliary_arrays) - type = real - kind = kind_phys -[cclu] - standard_name = clumping_index - long_name = Clumping Index for canopy correction - units = none - dimensions = (horizontal_loop_extent,number_of_3d_auxiliary_arrays) - type = real - kind = kind_phys -[cpopu] - standard_name = population_density - long_name = Population dencity for canopy correction - units = none - dimensions = (horizontal_loop_extent,number_of_3d_auxiliary_arrays) - type = real - kind = kind_phys -#IVAI [sfc_rlm] standard_name = choice_of_near_surface_mixing_length_in_boundary_layer_mass_flux_scheme long_name = choice of near surface mixing length in boundary layer mass flux scheme From 7a0e1e2ab6494ffaf20bd14a62ee53a90a52aa1b Mon Sep 17 00:00:00 2001 From: iri01 Date: Fri, 1 Mar 2024 22:56:21 +0000 Subject: [PATCH 378/380] Fix to canopy arrays definitions: add intent --- physics/satmedmfvdifq.meta | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/physics/satmedmfvdifq.meta b/physics/satmedmfvdifq.meta index cef8332a8..2029d4015 100644 --- a/physics/satmedmfvdifq.meta +++ b/physics/satmedmfvdifq.meta @@ -604,6 +604,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys + intent = in [cfch] standard_name = canopy_forest_height long_name = canopy forest height @@ -611,6 +612,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys + intent = in [cfrt] standard_name = canopy_forest_fraction long_name = canopy forest fraction @@ -618,6 +620,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys + intent = in [cclu] standard_name = canopy_clumping_index long_name = canopy clumping index @@ -625,6 +628,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys + intent = in [cpopu] standard_name = canopy_population_density long_name = population density used for canopy correction @@ -632,6 +636,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys + intent = in #IVAI [sfc_rlm] standard_name = choice_of_near_surface_mixing_length_in_boundary_layer_mass_flux_scheme @@ -733,12 +738,14 @@ units = count dimensions = () type = integer + intent = out [naux3d] standard_name = number_of_3d_auxiliary_arrays long_name = number of 3d auxiliary arrays to output (for debugging) units = count dimensions = () type = integer + intent = out [aux2d] standard_name = auxiliary_2d_arrays long_name = auxiliary 2d arrays to output (for debugging) @@ -746,6 +753,7 @@ dimensions = (horizontal_loop_extent,number_of_3d_auxiliary_arrays) type = real kind = kind_phys + intent = out [aux3d] standard_name = auxiliary_3d_arrays long_name = auxiliary 3d arrays to output (for debugging) @@ -753,4 +761,5 @@ dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_3d_auxiliary_arrays) type = real kind = kind_phys + intent = out #IVAI From fc1fb3f6916844f3579cc4b52e49461182d06015 Mon Sep 17 00:00:00 2001 From: drnimbusrain Date: Sun, 3 Mar 2024 03:35:32 +0000 Subject: [PATCH 379/380] Fixed cfch and cpopu units in the canopy meta variables. --- physics/satmedmfvdifq.meta | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/satmedmfvdifq.meta b/physics/satmedmfvdifq.meta index 2029d4015..91ad9ce09 100644 --- a/physics/satmedmfvdifq.meta +++ b/physics/satmedmfvdifq.meta @@ -608,7 +608,7 @@ [cfch] standard_name = canopy_forest_height long_name = canopy forest height - units = none + units = m dimensions = (horizontal_loop_extent) type = real kind = kind_phys @@ -632,7 +632,7 @@ [cpopu] standard_name = canopy_population_density long_name = population density used for canopy correction - units = none + units = 10000people 10km-2 dimensions = (horizontal_loop_extent) type = real kind = kind_phys From cbcb5441c14675d51e6e57fe6136da9b16728cd8 Mon Sep 17 00:00:00 2001 From: drnimbusrain Date: Sun, 3 Mar 2024 03:54:23 +0000 Subject: [PATCH 380/380] Fixed standard_name for naux2d and naux3d in meta file. --- physics/satmedmfvdifq.meta | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/satmedmfvdifq.meta b/physics/satmedmfvdifq.meta index 91ad9ce09..02f2ab6c4 100644 --- a/physics/satmedmfvdifq.meta +++ b/physics/satmedmfvdifq.meta @@ -733,14 +733,14 @@ intent = out #IVAI [naux2d] - standard_name = number_of_2d_auxiliary_arrays + standard_name = number_of_xy_dimensioned_auxiliary_arrays long_name = number of 2d auxiliary arrays to output (for debugging) units = count dimensions = () type = integer intent = out [naux3d] - standard_name = number_of_3d_auxiliary_arrays + standard_name = number_of_xyz_dimensioned_auxiliary_arrays long_name = number of 3d auxiliary arrays to output (for debugging) units = count dimensions = ()